; LISP/8-6502 interpreter ; ; This is an implementation of the LISP programming language for the ; 6502-CPU. In follows the LISP/8 specifications. (http://www.hugbox.org/) ; ; Copyright (c) 2005,2006 Sven Klose .data .org 0 zero_page dm 8 ; System vectors ; Zero page register set reg_set .org $1000 atom_names asciiz "FUNCTION" asciiz "COND" asciiz "CONS" asciiz "CAR" asciiz "CDR" asciiz "RPLACA" asciiz "RPLACD" asciiz "TAGBODY" asciiz "MAKE-VECTOR" asciiz "MACRO" asciiz "SPECIAL" asciiz "APPLY" asciiz "SETQ" asciiz "PRINT" asciiz "READ" asciiz "LOAD" asciiz "EQ" asciiz "EVAL" asciiz "%%CPU-CALL" asciiz "+" asciiz "-" asciiz "<<" asciiz ">>" asciiz "LSHIFTR" byte -1 ; *********************** ; *** Object pointers *** ; *********************** atom_types enum TYPE_CONS ; List element TYPE_NUMBER ; 16-bit integer TYPE_ATOM ; 16-bit integer TYPE_VECTOR ; User-defined vector. end enum num_conses = 16384 num_atoms = 4096 num_numbers = 1024 num_vectors = 32768 num_vectortypes = 256 type? macro type tay and #3 cpa #type tya rts end macro ; Set zero flag if pointer is a cons. cons? macro bit #TYPE_MASK end macro number? type? TYPE_NUMBER atom? type? TYPE_ATOM vector? type? TYPE_VECTOR ; Built-in predicate functions. bt_p macro test jsr car test bne >n1 ldax_nil rts n1 ldax_t rts end macro bt_consp bt_p cons? bt_numberp bt_p number? bt_atomp bt_p atom? bt_vector bt_p vector? ; ********************** ; *** Virtual memory *** ; ********************** ; Page caching and write back is left to the nix core. pagetable_info struct word pt byte file end struct .data ; Page table descriptors. pti_cons pagetable_info pt_cons pti_numbers pagetable_info pt_numbers pti_atoms pagetable_info pt_atoms pti_vectorinfos pagetable_info pt_vectorinfos pti_vectordata pagetable_info pt_vectordata pti_symbols pagetable_info pt_symbols pti_stack pagetable_info pt_stack current_page word .code load_page proc local tmp, t stx tmp ; Save page number. cpx current_page ; Same page again? bne >n1 lda r0 cpa current_type beq rts sta current_type n1 ldaxri r0 pti.pagetable ; Remove page from table. stax t ldx current_page clrb (t),x lda current_page ; Release former page. jsr core_bunref lda tmp sta current_page sta r2 ldaxri r0 pti.file ; Map new page stax r1 ldaxc r8 stax r0 jsr core_bref zero? bne >e1 ; System call returned error code. ldaxri r8 core_buffer.data ; Save page number to table. txa ldx current_page sta (t),x rts e1 jmp core_error end proc ; Load page and return its address in AX. ; ; AX: object pointer ; r0: page translation table get_page macro pt pti and #INDEX_MASK stx r8 ldy r8 ldx pt,y beq >l1 rts l1 ldy #pti sty r1+1 jmp load_page end macro .data ; Page translators. cons_addr get_page pt_cons, pti_cons number_addr get_page pt_numbers, pti_numbers atom_addr get_page pt_atoms, pti_atoms vectorinfo_addr get_page pt_vectorinfos, pti_vectorinfos vectordata_addr get_page pt_vectordata, pti_vectordata symbol_addr get_page pt_symbol, pti_symbol stack_addr get_page pt_stack, pti_stack ; ************** ; *** conses *** ; ************** .data pt_cons page free_conses word .code ; Link all conses to a single list. cons_init proc local cnt, i, p ldaxc NUM_CONSES-1 stax cnt clrax stax free_conses stax r0 l1 ldax r0 incax jsr rplacd incw r0 decw cnt bcc l1 incw r0 ldax lispptr_nil jsr rplacd rts car jsr cons_addr stax r0 ldaxr r0 rts cdr jsr cons_addr stax r0 ldaxri r0 2 rts rplaca proc val, tmp stax val ldax r0 jsr cons_addr stax tmp ldax val staxwr tmp ldx r0+1 jsr cons_write_page rts end proc rplacd proc val, tmp stax val ldax r0 jsr cons_addr stax tmp ldax val staxwrbi tmp 2 ldx r0+1 jsr cons_write_page rts end proc list_pop proc local tmp, ret stax ret stax tmp jsr cdr staxr tmp ldax ret rts end proc ; Make new cons of two objects. ; ax: car ; r0: cdr cons proc local ar, dr, new stax ar ldax r0 stax dr ldax lisplist_unused jsr list_pop ; Get an unused cons. stax new jsr cons_write_page ldax ar ; Set CAR. sta (new) ldy #1 stx (new),y ldax dr ; Set CDR. iny sta (new),y iny stx (new),y ldax new rts end proc bt_atom_type jsr car jsr atom_to_addr stax r0 ldy #atom.type lda (r0),y ldx #0 jmp number_value ; Control flow bt_cond proc local testp l1 stax testp ; Save test list. jsr car ; Get test expression. stax tmp jsr car ; Evaluate test. jsr eval nil? beq >n1 ; Test next. ldax tmp ; Evaluate test body. jsr cdr jmp eval_list n1 ldax testp ; Step to next test. jsr cdr nil? bne l1 rts end proc bt_tagbody proc stax body nil! ret l1 nil? ; Anything to execute? stax p beq >d1 jsr car ; Skip tags. cons? bne >l1 jsr eval ; Evalueate expression. stax ret cons? ; Returned tag? (%GO . tag) bne >n1 stax tmp jsr car cmp #ATOM_GO bne >n1 ; Not a go, continue. ldax tmp ; Get tag. jsr cdr stax tag ldax body ; Search body for tag. l2 stax tmp jsr car cons? ; Skip conses. bne >n2 cmpax tag bne >n2 ldax tmp ; Continue with found tag. jmp l1 n2 ldax tmp ; Tag search: get next. jsr cdr jmp l2 n1 ldax p ; Evaluate next. jsr cdr jmp l1 d1 ldax ret ; Done. rts ; ************* ; *** Atoms *** ; ************* atom struct name word binding word detail word value word fun word type byte end struct ; Make object pointer from atom index. atom_to_ptr proc lsr ora #TYPE_ATOM tay txa lsr tax tya bcc >n1 ora #128 n1 rts ; *************** ; *** Numbers *** ; *************** ; Allocate number value slot. number_alloc proc local tmp ldax free_numbers jsr list_pop stax tmp jsr cons_free ldax tmp jsr car ora #TYPE_NUMBER rts end proc ; Allocate number value slot. number_free proc local tmp nil_m r0 jsr cons stax tmp ldax free_numbers stax r0 ldax tmp jmp list_push end proc ; Add arguments to 0. btfun_add proc local val p clrw val l1 nil? beq >d1 stax p jsr car jsr number? bne >e1 jsr number_value adaxm val stax val ldax p jsr cdr bra l1 d1 ldax val jmp number_get e1 lda #err_number_expected jmp error end proc ; Substract argument from 0 or rest from first argument. btfun_sub proc local val p stax p jsr car stax val ldax p jsr cdr nil? bne >l1 ldax val negax rts l1 nil? beq >d1 stax p jsr car jsr number? bne >e1 jsr number_value stax tmp ldax val sbax tmp stax val ldax p jsr cdr bra l1 d1 ldax val jmp number_get e1 lda #err_number_expected jmp error end proc ; Logical shift left. btfun_lsl proc local val p stax p jsr car jsr number_value stax val ldax p jsr cdr jsr car jsr number_value tay l1 pha txa lsl tax pla lsl bcc >n1 inx n1 dey bne l1 d1 jmp number_get ; Logical shift right. btfun_lsr proc local val p stax p jsr car jsr number_value stax val ldax p jsr cdr jsr car jsr number_value tay l1 pha txa lsr tax pla php lsr plp bcc >n1 clc adc #128 n1 dey bne l1 d1 jmp number_get ; Arithmetic shift right. btfun_asr proc local val p stax p jsr car jsr number_value stax val ldax p jsr cdr jsr car jsr number_value tay l1 pha txa asr tax pla php lsr plp bcc >n1 clc adc #128 n1 dey bne l1 d1 jmp number_get e1 lda #err_number_expected jmp error end proc ; *************** ; *** Vectors *** ; *************** vectortype struct gc objptr ? ; Object pointer to marking lambda expression. end struct vectorinfo struct ptr objptr ? ; Address of memory block or 0 if swapped out. end struct ; Allocate array atom and memory. vector_get proc local size, i stax size ; Save size locally. jsr vector_info_alloc ; Allocate vector info. stax i ldax size ; Allocate vector. jsr vmalloc staxwri i vectorinfo.ptr ; Save address in atom. jsr vectorinfo_to_ptr ; Return object pointer. rts s1 jsr vector_address stax r15 rts ; r0: vector ; r1: index ; r2: new value bt_vector_set jsr s1 ldax r2 staxrwi r15 r1 rts bt_vector_get jsr s1 ldaxrwi r15 r1 rts ; ************************** ; *** Garbage collection *** ; ************************** mark_cons proc stack0ax jsr mark_set_cons stack0ax jsr car jsr mark_obj jsr pop_ax jsr cdr jsr mark_obj jsr pop_stack rts mark_atom proc stack0ax jsr mark_set_atom stack0ax jsr atom_addr stax a ldaxr a atom.value jsr push_ax ldaxr a atom.fun jsr push_ax ldaxr a atom.bindings jsr mark_obj jsr pop_ax jsr mark_obj jsr pop_ax jsr mark_obj jsr dec2_stack jsr pop_stack rts mark_vector proc stack0ax jsr mark_set_vector stack0ax jsr vectorinfo_addr stax r0 ldy #vector.type lda (r0),y ldx #0 jsr vectortype_addr stax r8 stack0ax stax r0 ldaxric r8 vectortype.mark jsr eval jsr dec2_stack jsr pop_stack rts mark_obj proc jsr push_ax pha jsr push_stack pla and #3 beq mark_cons tax dex beq mark_number dex beq mark_atom jmp mark_vector mark ldax gc_stack jsr mark_obj ldax toplevel jmp mark_obj sweep jsr sweep_conses jsr sweep_numbers jsr sweep_atoms jsr sweep_vectors rts ; ****************** ; *** Evaluation *** ; ****************** eval_funcall proc expr local expr args fun do_eval ret ; Save argument. ldy r0 sty do_eval ; Get function atom. stax expr jsr car stax fun ; Evaluate arguments. lda do_eval beq >n1 ldax expr jsr cdr jsr list_copy jsr eval_args stax args n1 ; Call function. ldax args stax r0 ldax fun jsr xlat_func stax ret lda do_eval beq >n1 ldax args jsr list_free_toplevel n1 ldax ret rts end proc eval proc stax expr jsr push_stack ldax expr jsr car cons? bne >n1 ; not a cons. jsr eval n1 jsr atom? bne >e1 jsr atom_addr stax r0 ldy #atom_type lda (r0),y tay php ldax expr jsr cdr plp beq >b1 ; built-in function dey bcs >s1 ; special form dey bcs >u1 ; user-defined function dey bcs >r1 ; user-defined special form dey bcs >m1 ; macro lda #err_unknown_atom_type e2 jmp error e1 lda #err_atom_expected bra e2 env_loop proc l1 jsr read jsr call_macro_expand_stub jsr eval jsr print jsr end_of_file? bcc l1 end proc init jsr vm_init jsr cons_init rts ; Evaluate boot file from memory. ; It contains the syscall stubs to read the environment from disk. main jsr init ldaxc boot_image stax input_ptr lda #-1 sta input_stream_index jsr eval_loop rts