Mercurial > hg > Members > kono > os9 > sbc09
changeset 181:63de06ad7a49
add LISP09 (not yet finished)
| author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
|---|---|
| date | Wed, 12 May 2021 12:57:20 +0900 |
| parents | 41d578d28d8c |
| children | aa6398acd2d5 |
| files | LISP09/LISP09.LST LISP09/LISP09.txt TL1/TL1os9.asm TL1/test/t4.tl1 TL1/tl1.html |
| diffstat | 5 files changed, 6723 insertions(+), 20 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/LISP09/LISP09.LST Wed May 12 12:57:20 2021 +0900 @@ -0,0 +1,3437 @@ + + + + + *====================================== + * + * LISP-09 INTERPRETER + * vers.2.08 + * written by TERUO SERIZAWA + * 1982.11.04 + * 83.10.07 + * + *====================================== + * + * + * ADDRESS MAP + * + 0000 HSHTOP EQU $0000 + 0800 HSHBTM EQU HSHTOP+$800 + * atom hash table + * # of atoms : 1024 + * if contents=0 : undefined + * else : pointer to atom information table + * + 0800 CELTOP EQU HSHBTM + 8000 CELBTM EQU $8000 + * cell area ( lists and numbers ) + * # of cells : 7680 + * + 8000 LSPTOP EQU CELBTM + 94DB LSPBTM EQU XXXXX + * LISP-09 interpreter + * + * S stack is here + A000 SSKBTM EQU $A000 + A000 ATMTOP EQU SSKBTM + * atom information table + * + * ATMEND indicates table's end ( variable ) + * USKTOP indicates U stack's barrier ( variable ) + * ( [USKTOP] == [ATMEND] + 30 ) + * + * U stack is here + C000 USKBTM EQU $C000 + * + * $C000-$FFFF FLEX SYSTEM + * + + + *-------------------------------------- + * + * MAIN PROGRAM + * + *-------------------------------------- + * + 8000 ORG LSPTOP + 8000 16 14D8 COLDS LBRA STARTU + >8003 16 0003 WARMS LBRA WARMS2 + * + * unbind variables + * + 8006 17 0A94 WARMS1 LBSR UNBIND + 8009 11B3 813F WARMS2 CMPU USKTOP + 800D 25 06 BCS START + 800F 1183 C000 CMPU #USKBTM + 8013 25 F1 BCS WARMS1 + * + * initialize system + * + 8015 10CE A000 START LDS #SSKBTM + 8019 CE C000 LDU #USKBTM + 801C 8D 14 BSR INITIO + 801E 8D 21 BSR INITVA + 8020 17 058A LBSR TERPRI + * + * + * LISP system top level function + * + 8023 17 06D8 START1 LBSR READ + 8026 30 A4 LEAX ,Y + 8028 17 0953 LBSR EVAL + 802B 30 A4 LEAX ,Y + 802D 17 0577 LBSR PRINT + 8030 20 F1 BRA START1 + * + * initialize I/O + * + 8032 17 1138 INITIO LBSR CLOSE + 8035 7F 8132 CLR ECHOSW + 8038 7F 8139 CLR OLDCHR + 803B BE 80B3 LDX IBFP + 803E 6F 84 CLR ,X + 8040 39 RTS + * + * initialize system variables + * + 8041 7F 8135 INITVA CLR GOSW + 8044 7F 8136 CLR RTNSW + 8047 8E 0418 LDX #NIL + 804A BF 8137 STX CATCHL + 804D 39 RTS + + *-------------------------------------- + * + * CONSTANTS AND VARIABLES + * + *-------------------------------------- + * + * + * MACROES + * + TESTS MACRO + CMPS #LSPBTM+100 + LBCS ERRSSK + ENDM + * + TESTU MACRO + CMPU USKTOP + LBCS ERRUSK + ENDM + * + * + * ASCII CHARACTERS + * + 0007 BEL EQU $07 + 0008 BS EQU $08 + 000A LF EQU $0A + 000C FF EQU $0C + 000D CR EQU $0D + 0018 CAN EQU $18 + * + * + * FUNCTION TYPES + * + 0000 N0 EQU 0 + 0001 NSUBR EQU 1 + 0002 NFSUBR EQU 2 + 0003 NLSUBR EQU 3 + 0007 NERR EQU 7 + 0009 NEXPR EQU 9 + 000A NFEXPR EQU 10 + 000C NMACRO EQU 12 + * + * + * SYSTEM VARIABLES + * + 0064 IBFL EQU 100 + 804E IBF RMB IBFL + 80B2 00 FCB 0 + 80B3 804E IBFP FDB IBF + * + 0064 ABFL EQU 100 + 80B5 ABF RMB ABFL + 8119 00 FCB 0 + 811A 80B5 ABFP FDB ABF + * + 811C 30 30 30 30 GBUF FCC /0000/ + 8120 0000 FDB 0 + 8122 NX RMB 4 + 8126 NY RMB 4 + 812A 0000 FDB 0 + 812C NR RMB 4 + 8130 OP RMB 2 + * + 8132 00 ECHOSW FCB 0 + 8133 00 CARSW FCB 0 + 8134 00 GBCSW FCB 0 + 8135 00 GOSW FCB 0 + 8136 00 RTNSW FCB 0 + 8137 0418 CATCHL FDB NIL + * + 8139 00 OLDCHR FCB 0 + 813A 00 NSIGN FCB 0 + * + 813B 0418 FREE FDB NIL + 813D A773 ATMEND FDB AAAAA + 813F A791 USKTOP FDB AAAAA+30 + + *-------------------------------------- + * + * ARITHMETIC FUNCTIONS + * + *-------------------------------------- + *** + *** ( QUOTIENT n1 n2 ... ) + *** val <= n1 / n2 / ... + *** + 8141 CC 828D QUOTIE LDD #DIV + 8144 20 03 BRA TIMES1 + *** + *** ( TIMES n1 n2 ... ) LSUBR + *** val <= n1 * n2 * ... + *** + 8146 CC 8316 TIMES LDD #MULT + 8149 6D 84 TIMES1 TST ,X + 814B 2B 53 BMI ONE + 814D 20 0C BRA ARITH + *** + *** ( DIFFERENCE n1 n2 ... ) LSUBR + *** val <= n1 - n2 - ... + *** + 814F CC 838E DIFFER LDD #NSUB + 8152 20 03 BRA PLUS1 + *** + *** ( PLUS n1 n2 ... ) LSUBR + *** val <= n1 + n2 + ... + *** + 8154 CC 837F PLUS LDD #NADD + 8157 6D 84 PLUS1 TST ,X + 8159 2B 3B BMI ZERO + * + * execute arithmetic functions + * X : list of arguments + * + 815B FD 8130 ARITH STD OP + 815E 36 10 PSHU X + 8160 AE 84 LDX ,X + 8162 8D 5A BSR NUMX + 8164 10AE C4 ARITH1 LDY ,U + 8167 10AE 22 LDY 2,Y + 816A 10AF C4 STY ,U + 816D 10AE A4 LDY ,Y + 8170 2B 7A BMI MNA0 + 8172 8D 60 BSR NUMY + 8174 AD 9F 8130 JSR [OP] + 8178 20 EA BRA ARITH1 + *** + *** ( MAX n1 n2 ... ) LSUBR + *** val <= maximum value of numbers + *** + 817A CC 83A8 MAX LDD #NMAX + 817D 6D 84 TST ,X + 817F 2B 29 BMI MINF + 8181 20 D8 BRA ARITH + *** + *** ( MIN n1 n2 ... ) LSUBR + *** val <= minimum value of numbers + *** + 8183 CC 83B5 MIN LDD #NMIN + 8186 6D 84 TST ,X + 8188 2B 1B BMI INF + 818A 20 CF BRA ARITH + *** + *** ( SIGN n ) SUBR + *** if n>0 then val <= 1 + *** n=0 0 + *** n<0 -1 + *** + 818C 8D 30 SIGN BSR NUMX + 818E 2B 0B BMI MONE + 8190 26 0E BNE ONE + 8192 EC 02 LDD 2,X + 8194 26 0A BNE ONE + * + * value <= 0 + * + 8196 8E 8414 ZERO LDX #ZEROV + 8199 20 53 BRA MNA + * + * value <= -1 + * + 819B 8E 841C MONE LDX #MONEV + 819E 20 4E BRA MNA + * + * value <= 1 + * + 81A0 8E 8416 ONE LDX #ONEV + 81A3 20 49 BRA MNA + * + * value <= infinity ( largest number ) + * + 81A5 8E 841A INF LDX #INFV + 81A8 20 44 BRA MNA + * + * value <= minus infinity ( smallest number ) + * + 81AA 8E 8412 MINF LDX #MINFV + 81AD 20 3F BRA MNA + * + * transpose numerical atom(s) into number register(s) + * + 81AF 102A 0397 NUMS LBPL ERRNUM + 81B3 47 ASRA + 81B4 56 RORB + 81B5 85 20 BITA #$20 + 81B7 26 32 BNE NUMRTS + 81B9 84 3F ANDA #$3F + 81BB 39 RTS + * + 81BC 8D 16 NUMXY BSR NUMY + 81BE 8C 0800 NUMX CMPX #CELTOP + 81C1 1025 0385 LBCS ERRNUM + 81C5 EC 02 LDD 2,X + 81C7 FD 8124 STD NX+2 + 81CA EC 84 LDD ,X + 81CC 8D E1 BSR NUMS + 81CE 8E 8122 LDX #NX + 81D1 ED 84 STD ,X + 81D3 39 RTS + * + 81D4 108C 0800 NUMY CMPY #CELTOP + 81D8 1025 036E LBCS ERRNUM + 81DC EC 22 LDD 2,Y + 81DE FD 8128 STD NY+2 + 81E1 EC A4 LDD ,Y + 81E3 8D CA BSR NUMS + 81E5 108E 8126 LDY #NY + 81E9 ED A4 STD ,Y + 81EB 39 NUMRTS RTS + * + * make numerical atom + * X : number register + * + 81EC 33 42 MNA0 LEAU 2,U + * + 81EE 17 0E8F MNA LBSR NEW + 81F1 EC 84 LDD ,X + 81F3 58 ASLB + 81F4 49 ROLA + 81F5 8A 80 ORA #$80 + 81F7 ED A4 STD ,Y + 81F9 EC 02 LDD 2,X + 81FB ED 22 STD 2,Y + 81FD 39 RTS + *** + *** ( ADD1 n ) SUBR + *** val <= n + 1 + *** + 81FE 108E 8416 ADD1 LDY #ONEV + 8202 8D BA ADD11 BSR NUMX + 8204 17 0178 LBSR NADD + 8207 20 E5 BRA MNA + *** + *** ( SUB1 n ) SUBR + *** val <= n - 1 + *** + 8209 108E 841C SUB1 LDY #MONEV + 820D 20 F3 BRA ADD11 + *** + *** ( ABS n ) SUBR + *** val <= absolute value of n + *** + 820F 8D AD ABS BSR NUMX + 8211 2A DB BPL MNA + 8213 20 02 BRA MINUS1 + *** + *** ( MINUS n ) SUBR + *** val <= - n + *** + 8215 8D A7 MINUS BSR NUMX + 8217 17 00DC MINUS1 LBSR NNEG + 821A 20 D2 BRA MNA + *** + *** ( LOGAND n1 n2 ) SUBR + *** logical <AND> operation + *** val <= n1 and n2 + *** + 821C 8D 9E LOGAND BSR NUMXY + 821E A4 A4 ANDA ,Y + 8220 E4 21 ANDB 1,Y + 8222 ED 84 STD ,X + 8224 EC 02 LDD 2,X + 8226 A4 22 ANDA 2,Y + 8228 E4 23 ANDB 3,Y + 822A ED 02 STD 2,X + 822C 20 C0 BRA MNA + *** + *** ( LOGOR n1 n2 ) SUBR + *** logical <OR> operation + *** val <= n1 or n2 + *** + 822E 8D 8C LOGOR BSR NUMXY + 8230 AA A4 ORA ,Y + 8232 EA 21 ORB 1,Y + 8234 ED 84 STD ,X + 8236 EC 02 LDD 2,X + 8238 AA 22 ORA 2,Y + 823A EA 23 ORB 3,Y + 823C ED 02 STD 2,X + 823E 20 AE BRA MNA + *** + *** ( LOGXOR n1 n2 ) SUBR + *** logical ,exclusive-OR> operation + *** val <= n1 xor n2 + *** + 8240 17 FF79 LOGXOR LBSR NUMXY + 8243 A8 A4 EORA ,Y + 8245 E8 21 EORB 1,Y + 8247 ED 84 STD ,X + 8249 EC 02 LDD 2,X + 824B A8 22 EORA 2,Y + 824D E8 23 EORB 3,Y + 824F ED 02 STD 2,X + 8251 20 9B BRA MNA + *** + *** ( REMAINDER n1 n2 ) SUBR + *** val <= n1 mod n2 + *** + 8253 17 FF66 REMAIN LBSR NUMXY + 8256 8D 35 BSR DIV + 8258 30 A4 LEAX ,Y + 825A 20 92 BRA MNA + *** + *** ( DIVIDE n1 n2 ) SUBR + *** n1 / n2 + *** val <= dot pAir of quotient and remainder + *** + 825C 17 FF5D DIVIDE LBSR NUMXY + 825F 8D 2C BSR DIV + 8261 8D 8B BSR MNA + 8263 36 20 PSHU Y + 8265 8E 8126 LDX #NY + 8268 8D 84 BSR MNA + 826A 16 0DF8 LBRA CONSU + *** + *** ( GCD n1 n2 ) SUBR + *** greatest common divisor + *** val <= GCD ( n1, n2 ) + *** + 826D 17 FF4C GCD LBSR NUMXY + 8270 EC 22 GCD1 LDD 2,Y + 8272 34 06 PSHS D + 8274 EC A4 LDD ,Y + 8276 34 06 PSHS D + 8278 8D 13 BSR DIV + 827A 35 06 PULS D + 827C ED 84 STD ,X + 827E 35 06 PULS D + 8280 ED 02 STD 2,X + 8282 EC 22 LDD 2,Y + 8284 26 EA BNE GCD1 + 8286 EC A4 LDD ,Y + 8288 26 E6 BNE GCD1 + 828A 16 FF61 LBRA MNA + * + * divide NX by NY + * NX <= NX / NY quotient + * NY <= NX mod NY remainder + * + 828D 32 78 DIV LEAS -8,S + 828F CC 001E LDD #30 + 8292 ED 64 STD 4,S + 8294 A6 84 LDA ,X + 8296 2A 04 BPL DIV1 + 8298 6C 64 INC 4,S + 829A 8D 5A BSR NNEG + 829C A6 A4 DIV1 LDA ,Y + 829E 2B 04 BMI DIV2 + 82A0 6C 64 INC 4,S + 82A2 8D 41 BSR NNEGY + 82A4 EC A4 DIV2 LDD ,Y + 82A6 ED E4 STD ,S + 82A8 EC 22 LDD 2,Y + 82AA ED 62 STD 2,S + 82AC CC 0000 LDD #0 + 82AF ED A4 STD ,Y + 82B1 ED 22 STD 2,Y + 82B3 8D 54 BSR NASL3 + 82B5 69 23 DIV3 ROL 3,Y + 82B7 69 22 ROL 2,Y + 82B9 69 21 ROL 1,Y + 82BB 69 A4 ROL ,Y + 82BD EC 22 LDD 2,Y + 82BF E3 62 ADDD 2,S + 82C1 ED 66 STD 6,S + 82C3 EC A4 LDD ,Y + 82C5 E9 61 ADCB 1,S + 82C7 A9 E4 ADCA ,S + 82C9 24 06 BCC DIV4 + 82CB ED A4 STD ,Y + 82CD EC 66 LDD 6,S + 82CF ED 22 STD 2,Y + 82D1 69 03 DIV4 ROL 3,X + 82D3 69 02 ROL 2,X + 82D5 69 01 ROL 1,X + 82D7 69 84 ROL ,X + 82D9 6A 65 DEC 5,S + 82DB 26 D8 BNE DIV3 + 82DD 6A 64 DEC 4,S + 82DF 32 68 LEAS 8,S + 82E1 27 32 BEQ DIVRTS + 82E3 8D 11 BSR NNEG + * + * negate number + * Y : number register + * + 82E5 CC 0000 NNEGY LDD #0 + 82E8 A3 22 SUBD 2,Y + 82EA ED 22 STD 2,Y + 82EC CC 0000 LDD #0 + 82EF E2 21 SBCB 1,Y + 82F1 A2 A4 SBCA ,Y + 82F3 ED A4 STD ,Y + 82F5 39 RTS + * + * negate number + * X : number register + * + 82F6 CC 0000 NNEG LDD #0 + 82F9 A3 02 SUBD 2,X + 82FB ED 02 STD 2,X + 82FD CC 0000 LDD #0 + 8300 E2 01 SBCB 1,X + 8302 A2 84 SBCA ,X + 8304 ED 84 STD ,X + 8306 39 RTS + * + * arithmetic shift left + * X : number register + * + 8307 8D 04 NASL4 BSR NASL + 8309 8D 02 NASL3 BSR NASL + 830B 8D 00 NASL2 BSR NASL + 830D 68 03 NASL ASL 3,X + 830F 69 02 ROL 2,X + 8311 69 01 ROL 1,X + 8313 69 84 ROL ,X + 8315 39 DIVRTS RTS + * + * multiply NX with NY + * NX <= NX * NY + * + MMM MACRO + LDA &1,S + LDB &2,Y + MUL + ENDM + * + 8316 EC 02 MULT LDD 2,X + 8318 34 06 PSHS D + 831A EC 84 LDD ,X + 831C 34 06 PSHS D + 831E MMM 3,3 + 8323 ED 02 STD 2,X + 8325 MMM 2,2 + 832A ED 84 STD ,X + 832C MMM 3,2 + 8331 E3 01 ADDD 1,X + 8333 ED 01 STD 1,X + 8335 24 02 BCC MULT1 + 8337 6C 84 INC ,X + 8339 MULT1 MMM 2,3 + 833E E3 01 ADDD 1,X + 8340 ED 01 STD 1,X + 8342 24 02 BCC MULT2 + 8344 6C 84 INC ,X + 8346 MULT2 MMM 1,3 + 834B E3 84 ADDD ,X + 834D ED 84 STD ,X + 834F MMM 3,1 + 8354 E3 84 ADDD ,X + 8356 ED 84 STD ,X + 8358 MMM 0,3 + 835D EB 84 ADDB ,X + 835F E7 84 STB ,X + 8361 MMM 1,2 + 8366 EB 84 ADDB ,X + 8368 E7 84 STB ,X + 836A MMM 2,1 + 836F EB 84 ADDB ,X + 8371 E7 84 STB ,X + 8373 MMM 3,0 + 8378 EB 84 ADDB ,X + 837A E7 84 STB ,X + 837C 32 64 LEAS 4,S + 837E 39 RTS + * + * add numbers + * NX <= NX + NY + * + 837F EC 02 NADD LDD 2,X + 8381 E3 22 ADDD 2,Y + 8383 ED 02 STD 2,X + 8385 EC 84 LDD ,X + 8387 E9 21 ADCB 1,Y + 8389 A9 A4 ADCA ,Y + 838B ED 84 STD ,X + 838D 39 RTS + * + * subtract numbers + * NX <= NX - NY + * + 838E EC 02 NSUB LDD 2,X + 8390 A3 22 SUBD 2,Y + 8392 ED 02 STD 2,X + 8394 EC 84 LDD ,X + 8396 E2 21 SBCB 1,Y + 8398 A2 A4 SBCA ,Y + 839A ED 84 STD ,X + 839C 39 RTS + * + * compare numbers + * CCR <= NX - NY + * + 839D EC 02 NCMP LDD 2,X + 839F A3 22 SUBD 2,Y + 83A1 EC 84 LDD ,X + 83A3 E2 21 SBCB 1,Y + 83A5 A2 A4 SBCA ,Y + 83A7 39 RTS + * + * NX <= max ( NX, NY ) + * + 83A8 8D F3 NMAX BSR NCMP + 83AA 2C 08 BGE MAXRTS + 83AC EC A4 NMAX1 LDD ,Y + 83AE ED 84 STD ,X + 83B0 EC 22 LDD 2,Y + 83B2 ED 02 STD 2,X + 83B4 39 MAXRTS RTS + * + * NX <= min ( NX, NY ) + * + 83B5 8D E6 NMIN BSR NCMP + 83B7 2C F3 BGE NMAX1 + 83B9 39 RTS + *** + *** ( RND n ) SUBR + *** generate random number + *** val <= 0 .. n-1 + *** + 83BA 17 FE01 RND LBSR NUMX + 83BD 8E 812C LDX #NR + 83C0 108E 840E LDY #RNDV + 83C4 17 FF4F LBSR MULT + 83C7 108E 8416 LDY #ONEV + 83CB 8D B2 BSR NADD + 83CD 31 1E LEAY -2,X + 83CF 8E 8122 LDX #NX + 83D2 17 FF41 LBSR MULT + 83D5 30 1E LEAX -2,X + 83D7 16 FE14 LBRA MNA + *** + *** ( INC 'var ) FSUBR + *** increae value of var by 1 + *** (SETQ var (ADD1 var)) + *** + 83DA AE 84 INC LDX ,X + 83DC 102B 00ED LBMI ERROR + 83E0 8C 0800 CMPX #CELTOP + 83E3 1024 012C LBCC ERRATM + 83E7 AE 84 LDX ,X + 83E9 34 10 PSHS X + 83EB AE 84 LDX ,X + 83ED 17 FE0E LBSR ADD1 + 83F0 10AF F1 STY [,S++] + 83F3 39 RTS + *** + *** ( DEC 'var ) FSUBR + *** decrease value of var by 1 + *** (SETQ var (SUB1 var)) + *** + 83F4 AE 84 DEC LDX ,X + 83F6 102B 00D3 LBMI ERROR + 83FA 8C 0800 CMPX #CELTOP + 83FD 1024 0112 LBCC ERRATM + 8401 AE 84 LDX ,X + 8403 34 10 PSHS X + 8405 AE 84 LDX ,X + 8407 17 FDFF LBSR SUB1 + 840A 10AF F1 STY [,S++] + 840D 39 RTS + * + * numerical constants + * + 840E 0019 660D RNDV FDB $0019,$660D + 8412 2000 MINFV FDB $2000 + 8414 0000 ZEROV FDB $0000 + 8416 0000 0001 ONEV FDB $0000,$0001 + 841A 1FFF INFV FDB $1FFF + 841C FFFF FFFF MONEV FDB $FFFF,$FFFF + *** + *** ( CALL address ) SUBR + *** call subroutine + *** val <= NIL + *** + 8420 17 FD9B CALL LBSR NUMX + 8423 34 40 PSHS U + 8425 AD 98 02 JSR [2,X] + 8428 108E 0418 LDY #NIL + 842C 35 C0 PULS U,PC + *** + *** ( POKE address value(8) ) SUBR + *** store Value + *** val <= value + *** + 842E 34 20 POKE PSHS Y + 8430 17 FD89 LBSR NUMXY + 8433 A6 23 LDA 3,Y + 8435 A7 98 02 STA [2,X] + 8438 35 A0 PULS Y,PC + *** + *** ( PEEK address ) SUBR + *** val <= memory value of address + *** + 843A 17 FD81 PEEK LBSR NUMX + 843D A6 98 02 LDA [2,X] + * + * make numerical atom ( A ) + * + 8440 34 02 MNAA PSHS A + 8442 17 0C3B LBSR NEW + 8445 35 02 PULS A + 8447 A7 23 STA 3,Y + 8449 6F 22 CLR 2,Y + 844B 6F 21 MNAA1 CLR 1,Y + 844D 86 80 LDA #$80 + 844F A7 A4 STA ,Y + 8451 39 RTS + * + * make numerical atom ( Y ) + * + 8452 30 A4 MNAY LEAX ,Y + 8454 17 0C29 MNAX LBSR NEW + 8457 AF 22 STX 2,Y + 8459 20 F0 BRA MNAA1 + *** + *** ( ATOMLENGTH atom ) SUBR + *** val <= length of atom + *** + 845B 8C 0800 ATOMLE CMPX #CELTOP + 845E 1024 FD34 LBCC ZERO + 8462 AE 84 LDX ,X + 8464 30 07 LEAX 7,X + 8466 108E 0000 LDY #0 + 846A A6 80 ATOML1 LDA ,X+ + 846C 27 E4 BEQ MNAY + 846E 31 21 LEAY 1,Y + 8470 20 F8 BRA ATOML1 + *** + *** ( LENGTH list ) SUBR + *** val <= length of list + *** + 8472 108E 0000 LENGTH LDY #0 + 8476 A6 84 LENGT1 LDA ,X + 8478 2B D8 BMI MNAY + 847A AE 02 LDX 2,X + 847C 31 21 LEAY 1,Y + 847E 20 F6 BRA LENGT1 + + + *-------------------------------------- + * + * ERRORS + * + *-------------------------------------- + * + 8480 0D 0A 07 ERRM FCB CR,LF,BEL + 8483 2D 2D 45 52 FCC /--ERROR-- /,0 + 8487 52 4F 52 2D + 848B 2D 20 00 + * + 848E 8D 32 ERRSSK BSR ERR + 8490 53 20 6F 76 FCC /S over/,0 + 8494 65 72 00 + 8497 8D 29 ERRUSK BSR ERR + 8499 55 20 6F 76 FCC /U over/,0 + 849D 65 72 00 + 84A0 8D 20 ERRGBC BSR ERR + 84A2 43 65 6C 6C FCC /Cell area over/,0 + 84A6 20 61 72 65 + 84AA 61 20 6F 76 + 84AE 65 72 00 + 84B1 8D 0F ERRMSA BSR ERR + 84B3 41 74 6F 6D FCC /Atom area over/,0 + 84B7 20 61 72 65 + 84BB 61 20 6F 76 + 84BF 65 72 00 + * + 84C2 17 00B2 ERR LBSR ERRS + 84C5 35 10 PULS X + 84C7 17 00B8 LBSR MSG + 84CA 16 FB36 LBRA WARMS + *** + *** ( ERROR e1 e2 ) SUBR + *** print e1 e2, goto top level + *** + 84CD 17 0092 ERROR LBSR ERRXY + 84D0 00 FCB 0 + * + 84D1 17 008E ERRCAT LBSR ERRXY + 84D4 43 61 74 63 FCC /Catch and Throw/,0 + 84D8 68 20 61 6E + 84DC 64 20 54 68 + 84E0 72 6F 77 00 + 84E4 8D 7C ERRCAR BSR ERRXY + 84E6 43 61 72 20 FCC /Car or Cdr of atom/,0 + 84EA 6F 72 20 43 + 84EE 64 72 20 6F + 84F2 66 20 61 74 + 84F6 6F 6D 00 + 84F9 8D 67 ERRSET BSR ERRXY + 84FB 53 65 74 00 FCC /Set/,0 + 84FF 8D 61 ERRPRG BSR ERRXY + 8501 50 72 6F 67 FCC /Prog/,0 + 8505 00 + 8506 8D 5A ERRDE BSR ERRXY + 8508 44 65 66 69 FCC /Definition/,0 + 850C 6E 69 74 69 + 8510 6F 6E 00 + 8513 8D 4D ERRATM BSR ERRXY + 8515 41 74 6F 6D FCC /Atom expected/,0 + 8519 20 65 78 70 + 851D 65 63 74 65 + 8521 64 00 + 8523 8D 3D ERRSTR BSR ERRXY + 8525 53 74 72 69 FCC /String expected/,0 + 8529 6E 67 20 65 + 852D 78 70 65 63 + 8531 74 65 64 00 + 8535 8D 2B ERRUND BSR ERRXY + 8537 55 6E 64 65 FCC /Undefined Function/,0 + 853B 66 69 6E 65 + 853F 64 20 46 75 + 8543 6E 63 74 69 + 8547 6F 6E 00 + 854A 8D 16 ERRNUM BSR ERRXY + 854C 4E 75 6D 62 FCC /Number expected/,0 + 8550 65 72 20 65 + 8554 78 70 65 63 + 8558 74 65 64 00 + 855C 8D 04 ERRPUT BSR ERRXY + 855E 50 75 74 00 FCC /Put/,0 + * + 8562 36 30 ERRXY PSHU X,Y + 8564 8D 11 BSR ERRS + 8566 35 10 PULS X + 8568 8D 18 BSR MSG + 856A 8D 41 BSR TERPRI + 856C 37 10 PULU X + 856E 8D 37 BSR PRINT + 8570 37 10 PULU X + 8572 8D 33 BSR PRINT + 8574 16 FA8C LBRA WARMS + * + 8577 17 FAB8 ERRS LBSR INITIO + 857A 8E 8480 LDX #ERRM + 857D 20 03 BRA MSG + + *-------------------------------------- + * + * OUTPUT + * + *-------------------------------------- + * + * print message + * X : top of message + * + 857F 17 0080 MSG0 LBSR OUT + 8582 A6 80 MSG LDA ,X+ + 8584 26 F9 BNE MSG0 + 8586 39 RTS + *** + *** ( CRLF num(16) ) SUBR + *** print crlfs + *** val <= NIL + *** + 8587 17 FC34 CRLF LBSR NUMX + 858A AE 02 LDX 2,X + 858C 27 14 BEQ PRIRTS + 858E 8D 1D CRLF1 BSR TERPRI + 8590 30 1F LEAX -1,X + 8592 26 FA BNE CRLF1 + 8594 39 RTS + *** + *** ( SPACES num(16) ) SUBR + *** print blanks + *** val <= NIL + *** + 8595 17 FC26 SPACES LBSR NUMX + 8598 AE 02 LDX 2,X + 859A 27 06 BEQ PRIRTS + 859C 8D 05 SPACE1 BSR BLANK + 859E 30 1F LEAX -1,X + 85A0 26 FA BNE SPACE1 + 85A2 39 PRIRTS RTS + * + * print blank + * + 85A3 86 20 BLANK LDA #' + 85A5 20 5B BRA OUT + *** + *** ( PRIANT e ) SUBR + *** print e, print crlf + *** val <= e + *** + 85A7 36 10 PRINT PSHU X + 85A9 8D 2B BSR PRIN1 + 85AB 37 20 PULU Y + *** + *** ( TERPRI ) SUBR + *** print crlf + *** val <= NIL + *** + 85AD 86 0D TERPRI LDA #CR + 85AF 8D 51 BSR OUT + 85B1 86 0A LDA #LF + 85B3 20 4D BRA OUT + *** + *** ( LPRI e ) SUBR + *** print e without top level "(" and ")" + *** val <= NIL + *** + 85B5 8D 1F LPRI0 BSR PRIN1 + 85B7 35 10 PULS X + 85B9 AE 02 LDX 2,X + 85BB A6 84 LDA ,X + 85BD 2B 0A BMI LPRI1 + 85BF 8D E2 BSR BLANK + 85C1 34 10 LPRI PSHS X + 85C3 AE 84 LDX ,X + 85C5 2A EE BPL LPRI0 + 85C7 35 10 PULS X + 85C9 8C 0418 LPRI1 CMPX #NIL + 85CC 27 D4 BEQ PRIRTS + 85CE 8D D3 BSR BLANK + 85D0 86 2E LDA #'. + 85D2 8D 2E BSR OUT + 85D4 8D CD BSR BLANK + *** + *** ( PRIN1 e ) SUBR + *** print e + *** val <= NIL + *** + 85D6 PRIN1 TESTS + 85DE 8C 8000 CMPX #CELBTM + 85E1 24 BF BCC PRIRTS + 85E3 8C 0800 CMPX #CELTOP + 85E6 24 08 BCC PRIN2 + 85E8 AE 84 LDX ,X + 85EA 2A B6 BPL PRIRTS + 85EC 30 07 LEAX 7,X + 85EE 20 92 BRA MSG + * + 85F0 1F 10 PRIN2 TFR X,D + 85F2 C5 03 BITB #3 + 85F4 26 AC BNE PRIRTS + 85F6 A6 84 LDA ,X + 85F8 2B 0B BMI PRINN + 85FA 86 28 LDA #'( + 85FC 8D 04 BSR OUT + 85FE 8D C1 BSR LPRI + 8600 86 29 LDA #') + * + * output a char in A + * + 8602 16 0BA0 OUT LBRA OUTPUT + * + * print number ( decimal form ) + * + 8605 86 D0 PRINN LDA #-'0 + 8607 34 22 PSHS A,Y + 8609 108E 8126 LDY #NY + 860D 17 FBAE LBSR NUMX + 8610 2A 07 BPL PRINN1 + 8612 86 2D LDA #'- + 8614 8D EC BSR OUT + 8616 17 FCDD LBSR NNEG + 8619 CC 000A PRINN1 LDD #10 + 861C ED 22 STD 2,Y + 861E 5F CLRB + 861F ED A4 STD ,Y + 8621 17 FC69 LBSR DIV + 8624 A6 23 LDA 3,Y + 8626 34 02 PSHS A + 8628 EC 02 LDD 2,X + 862A 26 ED BNE PRINN1 + 862C EC 84 LDD ,X + 862E 26 E9 BNE PRINN1 + 8630 20 02 BRA PRINN3 + * + 8632 8D CE PRINN2 BSR OUT + 8634 35 02 PRINN3 PULS A + 8636 8B 30 ADDA #'0 + 8638 26 F8 BNE PRINN2 + 863A 35 A0 PULS Y,PC + *** + *** ( TYO num(8) ) SUBR + *** output ASCII character + *** val <= NIL + *** + 863C 17 FB7F TYO LBSR NUMX + 863F A6 03 LDA 3,X + 8641 20 BF BRA OUT + *** + *** ( PRINH n ) SUBR + *** print number ( hex form ) + *** val <= NIL + *** + 8643 17 FB78 PRINH LBSR NUMX + 8646 86 24 LDA #'$ + 8648 8D B8 BSR OUT + 864A EC 84 LDD ,X + 864C 8D 02 BSR PRINH4 + 864E EC 02 LDD 2,X + 8650 8D 02 PRINH4 BSR PRINH2 + 8652 1F 98 TFR B,A + 8654 34 02 PRINH2 PSHS A + 8656 46 RORA + 8657 46 RORA + 8658 46 RORA + 8659 46 RORA + 865A 8D 02 BSR PRINH1 + 865C 35 02 PULS A + 865E 84 0F PRINH1 ANDA #$0F + 8660 8B 30 ADDA #'0 + 8662 81 3A CMPA #'9+1 + 8664 25 9C BCS OUT + 8666 8B 07 ADDA #7 + 8668 20 98 BRA OUT + + *-------------------------------------- + * + * INPUT + * + *-------------------------------------- + *** + *** ( TYI ) SUBR + *** read a char + *** val <= ASCII code + *** + 866A 8D 6A TYI BSR IN + 866C 16 FDD1 LBRA MNAA + *** + *** ( READCH ) SUBR + *** read a char + *** val <= symbolic atom + *** + 866F 8D 65 READCH BSR IN + 8671 16 024A LBRA MSAA + *** + *** ( GETCH ) SUBR + *** read char, direct input + *** val <= symbolic atom + *** + 8674 17 0B31 GETCH LBSR INPUT + 8677 16 0244 LBRA MSAA + * + * read a line + * + 867A BE A025 GETLIN LDX prompt + 867D 17 FF56 LBSR PRIN1 + 8680 8E 804E GETL1 LDX #IBF + 8683 BF 80B3 STX IBFP + 8686 17 0B1F GETL2 LBSR INPUT + 8689 81 08 CMPA #BS + 868B 27 17 BEQ GETL3 + 868D 81 18 CMPA #CAN + 868F 27 1E BEQ GETL5 + 8691 81 0D CMPA #CR + 8693 27 21 BEQ GETL6 + 8695 81 20 CMPA #' + 8697 25 ED BCS GETL2 + 8699 A7 80 STA ,X+ + 869B 8D 31 BSR EOUT + 869D 8C 80B2 CMPX #IBF+IBFL + 86A0 26 E4 BNE GETL2 + 86A2 20 37 BRA IN1 + * + 86A4 8C 804E GETL3 CMPX #IBF + 86A7 27 DD BEQ GETL2 + 86A9 8D 19 BSR EOUTBS + 86AB 20 D9 BRA GETL2 + * + 86AD 8D 15 GETL4 BSR EOUTBS + 86AF 8C 804E GETL5 CMPX #IBF + 86B2 26 F9 BNE GETL4 + 86B4 20 D0 BRA GETL2 + * + 86B6 A7 80 GETL6 STA ,X+ + 86B8 6F 84 CLR ,X + 86BA 7D 8132 TST ECHOSW + 86BD 26 1C BNE IN1 + 86BF 17 FEEB LBSR TERPRI + 86C2 20 17 BRA IN1 + * + * output back space + * + 86C4 30 1F EOUTBS LEAX -1,X + 86C6 8D 04 BSR EOUTB1 + 86C8 86 20 LDA #' + 86CA 8D 02 BSR EOUT + 86CC 86 08 EOUTB1 LDA #BS + * + * output a char + * + 86CE 7D 8132 EOUT TST ECHOSW + 86D1 1027 FF2D LBEQ OUT + 86D5 39 RTS + * + * read a char in A + * + 86D6 B6 8139 IN LDA OLDCHR + 86D9 26 0A BNE IN2 + 86DB BE 80B3 IN1 LDX IBFP + 86DE A6 80 LDA ,X+ + 86E0 27 98 BEQ GETLIN + 86E2 BF 80B3 STX IBFP + 86E5 7F 8139 IN2 CLR OLDCHR + 86E8 39 RTS + * + * skip blank ( cntr ) chars, char in A + * + 86E9 8D EB SKIP0 BSR IN + 86EB 81 3B CMPA #'; + 86ED 27 04 BEQ SKIP + 86EF 81 0D CMPA #CR + 86F1 26 F6 BNE SKIP0 + 86F3 8D E1 SKIP BSR IN + 86F5 81 21 CMPA #' +1 + 86F7 25 FA BCS SKIP + 86F9 81 3B CMPA #'; + 86FB 27 EC BEQ SKIP0 + 86FD 39 RTS + *** + *** ( READ ) SUBR + *** read a expression + *** val <= expression + *** + 86FE READ TESTS + 8706 TESTU + 870E 17 012E LBSR CLRABF + 8711 8D E0 BSR SKIP + 8713 81 29 CMPA #') + 8715 27 E7 BEQ READ + 8717 81 5D CMPA #'] + 8719 27 E3 BEQ READ + 871B 81 28 CMPA #'( + 871D 27 23 BEQ READR + 871F 81 5B CMPA #'[ + 8721 27 15 BEQ READG + 8723 81 22 CMPA #'" + 8725 1027 00F0 LBEQ READS + 8729 81 27 CMPA #'' + 872B 26 49 BNE READA + * + * read quate + * + 872D 8D CF BSR READ + 872F 17 0940 LBSR CONSN + 8732 8E 0692 LDX #QUOTE + 8735 16 092B LBRA CONS + * + * read right part + * + 8738 8D 08 READG BSR READR + 873A B6 8139 LDA OLDCHR + 873D 81 5D CMPA #'] + 873F 27 A4 BEQ IN2 + 8741 39 RTS + * + 8742 8D AF READR BSR SKIP + 8744 108E 0418 LDY #NIL + 8748 81 29 CMPA #') + 874A 27 23 BEQ REDRTS + 874C 81 5D CMPA #'] + 874E 27 1C BEQ READR3 + 8750 81 2E CMPA #'. + 8752 27 0C BEQ READR1 + 8754 B7 8139 STA OLDCHR + 8757 8D A5 BSR READ + 8759 36 20 PSHU Y + 875B 8D E5 BSR READR + 875D 16 0905 LBRA CONSU + * + 8760 8D 9C READR1 BSR READ + 8762 8D 8F READR2 BSR SKIP + 8764 81 29 CMPA #') + 8766 27 07 BEQ REDRTS + 8768 81 5D CMPA #'] + 876A 26 F6 BNE READR2 + 876C B7 8139 READR3 STA OLDCHR + 876F 39 REDRTS RTS + * + * read atom + * + 8770 17 00D8 READA0 LBSR STOREA + 8773 17 FF60 LBSR IN + 8776 81 21 READA CMPA #' +1 + 8778 25 10 BCS READA1 + 877A 81 28 CMPA #'( + 877C 27 0C BEQ READA1 + 877E 81 5B CMPA #'[ + 8780 27 08 BEQ READA1 + 8782 81 29 CMPA #') + 8784 27 04 BEQ READA1 + 8786 81 5D CMPA #'] + 8788 26 E6 BNE READA0 + 878A B7 8139 READA1 STA OLDCHR + * + * make atom ( input is number ??? ) + * + 878D 8E 8122 MATM LDX #NX + 8790 CC 0000 LDD #0 + 8793 ED 02 STD 2,X + 8795 ED 84 STD ,X + 8797 7F 813A CLR NSIGN + 879A 108E 80B5 LDY #ABF + 879E A6 A0 LDA ,Y+ + 87A0 81 2B CMPA #'+ + 87A2 27 07 BEQ MATM1 + 87A4 81 2D CMPA #'- + 87A6 26 05 BNE MATM2 + 87A8 7C 813A INC NSIGN + 87AB A6 A0 MATM1 LDA ,Y+ + 87AD 81 24 MATM2 CMPA #'$ + 87AF 26 15 BNE MATM4 + * + * make hex number + * + 87B1 A6 A0 LDA ,Y+ + 87B3 8D 27 MATM3 BSR TSTHEX + 87B5 1024 010A LBCC MSA + 87B9 17 FB4B LBSR NASL4 + 87BC AB 03 ADDA 3,X + 87BE A7 03 STA 3,X + 87C0 A6 A0 LDA ,Y+ + 87C2 26 EF BNE MATM3 + 87C4 20 0C BRA MATM5 + * + * make decimal number + * + 87C6 8D 1F MATM4 BSR TSTDEC + 87C8 1024 00F7 LBCC MSA + 87CC 8D 23 BSR N10A + 87CE A6 A0 LDA ,Y+ + 87D0 26 F4 BNE MATM4 + * + 87D2 B6 813A MATM5 LDA NSIGN + 87D5 1027 FA15 LBEQ MNA + 87D9 16 FA3B LBRA MINUS1 + * + * char in ( 0..9, A..F ) ??? + * + 87DC 81 41 TSTHEX CMPA #'A + 87DE 25 07 BCS TSTDEC + 87E0 81 47 CMPA #'G + 87E2 24 0C BCC TSTRTS + 87E4 8B C9 ADDA #10-'A + 87E6 39 RTS + * + * char in ( 0..9 ) ??? + * + 87E7 80 30 TSTDEC SUBA #'0 + 87E9 25 03 BCS TSTCLC + 87EB 81 0A CMPA #10 + 87ED 39 RTS + * + 87EE 1C FE TSTCLC CLC + 87F0 39 TSTRTS RTS + * + * NX <= NX * 10 + A + * + 87F1 36 02 N10A PSHU A + 87F3 8D 09 BSR N10 + 87F5 CC 0000 LDD #0 + 87F8 34 06 PSHS D + 87FA 37 04 PULU B + 87FC 20 0C BRA N10A1 + * + 87FE 17 FB0C N10 LBSR NASL + 8801 EC 84 LDD ,X + 8803 34 06 PSHS D + 8805 EC 02 LDD 2,X + 8807 17 FB01 LBSR NASL2 + 880A E3 02 N10A1 ADDD 2,X + 880C ED 02 STD 2,X + 880E 35 06 PULS D + 8810 E9 01 ADCB 1,X + 8812 A9 84 ADCA ,X + 8814 ED 84 STD ,X + 8816 39 RTS + * + * read string + * + 8817 8D 32 READS0 BSR STOREA + 8819 17 FEBA READS LBSR IN + 881C 81 0D CMPA #CR + 881E 1027 00A1 LBEQ MSA + 8822 81 22 CMPA #'" + 8824 26 F1 BNE READS0 + 8826 17 FEAD LBSR IN + 8829 81 22 CMPA #'" + 882B 27 EA BEQ READS0 + 882D B7 8139 STA OLDCHR + 8830 16 0090 LBRA MSA + * + * compute string address + * + 8833 8C 0800 STRING CMPX #CELTOP + 8836 1024 FCE9 LBCC ERRSTR + 883A AE 84 LDX ,X + 883C 30 07 LEAX 7,X + 883E 39 RTS + * + * clear atom buffer + * + 883F 34 10 CLRABF PSHS X + 8841 8E 80B5 LDX #ABF + 8844 BF 811A STX ABFP + 8847 6F 84 CLR ,X + 8849 35 90 PULS X,PC + * + * store a char into Atom buffer + * + 884B 34 10 STOREA PSHS X + 884D BE 811A LDX ABFP + 8850 A7 80 STA ,X+ + 8852 8C 8119 CMPX #ABF+ABFL + 8855 27 05 BEQ STORE1 + 8857 BF 811A STX ABFP + 885A 6F 84 CLR ,X + 885C 35 90 STORE1 PULS X,PC + * + * store chars into atom buffer + * X : POINTER + * + 885E 8D EB STORE0 BSR STOREA + 8860 A6 80 STORES LDA ,X+ + 8862 26 FA BNE STORE0 + 8864 39 RTS + *** + *** ( IMPLODE list_of _atom ) SUBR + *** val <= connected atom + *** + *** + *** ( CONCAT atom1 atoM2 ... ) LSUBR + *** val <= connected atom + *** + 8865 CONCAT EQU * + 8865 8D D8 IMPLOD BSR CLRABF + 8867 36 10 IMPLD1 PSHU X + 8869 AE 84 LDX ,X + 886B 2B 0A BMI IMPLD2 + 886D 8D C4 BSR STRING + 886F 8D EF BSR STORES + 8871 37 10 PULU X + 8873 AE 02 LDX 2,X + 8875 20 F0 BRA IMPLD1 + 8877 33 42 IMPLD2 LEAU 2,U + 8879 20 48 BRA MSA + *** + *** ( EXPLODE atom ) SUBR + *** val <= list of chars + *** + 887B CC 88BE EXPLOD LDD #MSAA + 887E 20 03 BRA EXPL1 + *** + *** ( EXPLODEN atom ) SUBR + *** val <= list of ascii codes + *** + 8880 CC 8440 EXPLN LDD #MNAA + 8883 FD 8130 EXPL1 STD OP + 8886 8D AB BSR STRING + 8888 TESTU + 8890 TESTS + 8898 A6 80 EXPL2 LDA ,X+ + 889A 1027 0571 LBEQ FALSE + 889E 34 10 PSHS X + 88A0 AD 9F 8130 JSR [OP] + 88A4 35 10 PULS X + 88A6 36 20 PSHU Y + 88A8 8D EE BSR EXPL2 + 88AA 16 07B8 LBRA CONSU + *** + *** ( ATOMCDR atom ) SUBR + *** val <= butfirst chars of atom + *** + 88AD 8D 84 ATOMCD BSR STRING + 88AF 8D 8E BSR CLRABF + 88B1 A6 80 LDA ,X+ + 88B3 27 0E BEQ MSA + 88B5 8D A9 BSR STORES + 88B7 20 0A BRA MSA + *** + *** ( ATOMCAR atom ) SUBR + *** val <= first char of atom + *** + 88B9 17 FF77 ATOMCA LBSR STRING + 88BC A6 84 LDA ,X + * + * make single char atom (A ) + * + 88BE 17 FF7E MSAA LBSR CLRABF + 88C1 8D 88 BSR STOREA + * + * make symbolic atom + * + 88C3 8E 80B5 MSA LDX #ABF + 88C6 CC 0000 LDD #0 + 88C9 6D 84 MSA1 TST ,X + 88CB 27 0F BEQ MSA2 + 88CD 44 LSRA + 88CE 56 RORB + 88CF 44 LSRA + 88D0 56 RORB + 88D1 44 LSRA + 88D2 56 RORB + 88D3 A8 80 EORA ,X+ + 88D5 20 F2 BRA MSA1 + * + 88D7 35 06 MSA4 PULS D + 88D9 C3 0002 ADDD #2 + 88DC 84 07 MSA2 ANDA #$07 + 88DE C4 FE ANDB #$FE + 88E0 C3 0000 ADDD #HSHTOP + 88E3 34 06 PSHS D + 88E5 108E 80B5 LDY #ABF + 88E9 AE F4 LDX [,S] + 88EB 27 0D BEQ MSA5 + 88ED 30 07 LEAX 7,X + 88EF A6 80 MSA3 LDA ,X+ + 88F1 A1 A0 CMPA ,Y+ + 88F3 26 E2 BNE MSA4 + 88F5 4D TSTA + 88F6 26 F7 BNE MSA3 + 88F8 35 A0 PULS Y,PC + * + * create new atom + * + 88FA 30 56 MSA5 LEAX -10,U + 88FC 34 10 PSHS X + 88FE BE 813D LDX ATMEND + 8901 CC 012A LDD #UNDEFI + 8904 ED 81 STD ,X++ + 8906 CC 0418 LDD #NIL + 8909 ED 81 STD ,X++ + 890B CC 8535 LDD #ERRUND + 890E ED 81 STD ,X++ + 8910 6F 80 CLR ,X+ + 8912 AC E4 MSA6 CMPX ,S + 8914 1024 FB99 LBCC ERRMSA + 8918 A6 A0 LDA ,Y+ + 891A A7 80 STA ,X+ + 891C 26 F4 BNE MSA6 + 891E FC 813D LDD ATMEND + 8921 ED F8 02 STD [2,S] + 8924 BF 813D STX ATMEND + 8927 30 88 1E LEAX 30,X + 892A BF 813F STX USKTOP + 892D TESTU + 8935 35 A6 PULS D,Y,PC + *** + *** ( ASCII n ) SUBR + *** val <= syumbolic atom + *** + 8937 17 F884 ASCII LBSR NUMX + 893A A6 03 LDA 3,X + 893C 16 FF7F LBRA MSAA + *** + *** ( GENSYM [atom] ) SUBR + *** generate symbolic atom + *** val <= atom + *** + 893F 17 FEFD GENSYM LBSR CLRABF + 8942 8C 0418 CMPX #NIL + 8945 26 07 BNE GENSY0 + 8947 86 47 LDA #'G + 8949 17 FEFF LBSR STOREA + 894C 20 06 BRA GENSY1 + 894E 17 FEE2 GENSY0 LBSR STRING + 8951 17 FF0C LBSR STORES + 8954 8E 8120 GENSY1 LDX #GBUF+4 + 8957 6C 82 GENSY2 INC ,-X + 8959 A6 84 LDA ,X + 895B 81 3A CMPA #'9+1 + 895D 26 06 BNE GENSY3 + 895F 86 30 LDA #'0 + 8961 A7 84 STA ,X + 8963 20 F2 BRA GENSY2 + 8965 8E 811C GENSY3 LDX #GBUF + 8968 17 FEF5 LBSR STORES + 896B 16 FF55 LBRA MSA + + + *-------------------------------------- + * + * EVALUATION + * + *-------------------------------------- + * + * EVAL - FSUBR + * + 896E AE 02 EVFSBR LDX 2,X + 8970 108E 0418 LDY #NIL + 8974 39 RTS + * + * EVAL - MACRO + * + 8975 10AE 02 EVMACR LDY 2,X + 8978 35 10 EVMAC1 PULS X + 897A 8D 66 BSR EVALL1 + 897C 30 A4 LEAX ,Y + *** + *** ( EVAL e ) SUBR + *** val <= value of e + *** + 897E EVAL TESTS + 8986 TESTU + 898E 10AE 84 LDY ,X + 8991 2A 11 BPL EVAL3 + 8993 8C 0800 CMPX #CELTOP + 8996 24 04 BCC EVAL1 + 8998 10AE A4 LDY ,Y + 899B 39 RTS + 899C 31 84 EVAL1 LEAY ,X + 899E 39 RTS + 899F 32 62 EVAL2 LEAS 2,S + 89A1 10AE A4 LDY ,Y + 89A4 108C 0800 EVAL3 CMPY #CELTOP + 89A8 24 28 BCC EVALL + 89AA 10AE A4 LDY ,Y + 89AD EC 24 LDD 4,Y + 89AF 34 06 PSHS D + 89B1 A6 26 LDA 6,Y + 89B3 27 EA BEQ EVAL2 + 89B5 81 01 CMPA #NSUBR + 89B7 27 5B BEQ EVSUBR + 89B9 81 02 CMPA #NFSUBR + 89BB 27 B1 BEQ EVFSBR + 89BD 81 03 CMPA #NLSUBR + 89BF 27 75 BEQ EVLSBR + 89C1 81 09 CMPA #NEXPR + 89C3 27 7A BEQ EVEXPR + 89C5 81 0A CMPA #NFEXPR + 89C7 1027 0082 LBEQ EVFEXP + 89CB 81 0C CMPA #NMACRO + 89CD 27 A6 BEQ EVMACR + 89CF 16 FB63 EVAL9 LBRA ERRUND + * + * EVAL - LAMBDA + * + 89D2 36 20 EVALL PSHU Y + 89D4 EC A4 LDD ,Y + 89D6 1083 00AA CMPD #LAMBDA + 89DA 26 F3 BNE EVAL9 + 89DC 8D 0A BSR EVLIS + 89DE 37 10 PULU X + 89E0 AE 02 EVALL2 LDX 2,X + 89E2 34 10 EVALL1 PSHS X + 89E4 AE 84 LDX ,X + 89E6 20 5B BRA EVEXP2 + *** + *** ( EVLIS list ) SUBR + *** evaluate each element of list + *** val <= list of values + *** + 89E8 AE 02 EVLIS LDX 2,X + 89EA 36 10 PSHU X + 89EC AE 84 LDX ,X + 89EE 2B 21 BMI EVLIS1 + 89F0 8D 8C BSR EVAL + 89F2 AE C4 LDX ,U + 89F4 10AF C4 STY ,U + 89F7 AE 02 LDX 2,X + 89F9 36 10 PSHU X + 89FB AE 84 LDX ,X + 89FD 102B 0666 LBMI CONSUU + 8A01 17 FF7A LBSR EVAL + 8A04 AE C4 LDX ,U + 8A06 10AF C4 STY ,U + 8A09 8D DD BSR EVLIS + 8A0B 17 0657 LBSR CONSU + 8A0E 16 0654 LBRA CONSU + 8A11 37 20 EVLIS1 PULU Y + 8A13 39 RTS + * + * EVAL - SUBR + * + 8A14 AE 02 EVSUBR LDX 2,X + 8A16 36 10 PSHU X + 8A18 AE 84 LDX ,X + 8A1A 2B 13 BMI EVSBR1 + 8A1C 17 FF5F LBSR EVAL + 8A1F AE C4 LDX ,U + 8A21 10AF C4 STY ,U + 8A24 AE 98 02 LDX [2,X] + 8A27 2B 06 BMI EVSBR1 + 8A29 17 FF52 LBSR EVAL + 8A2C 37 10 PULU X + 8A2E 39 RTS + 8A2F 37 10 EVSBR1 PULU X + 8A31 108E 0418 LDY #NIL + 8A35 39 RTS + * + * EVAL - LSBUR + * + 8A36 8D B0 EVLSBR BSR EVLIS + 8A38 30 A4 EVLSB1 LEAX ,Y + 8A3A 108E 0418 LDY #NIL + 8A3E 39 RTS + * + * EVAL - EXPR + * + 8A3F 8D A7 EVEXPR BSR EVLIS + 8A41 AE F4 EVEXP1 LDX [,S] + 8A43 2B 8A EVEXP2 BMI EVAL9 + 8A45 8D 0B BSR BIND + 8A47 35 10 PULS X + 8A49 8D 5C BSR EVBODY + 8A4B 20 50 BRA UNBIND + * + * EVAL - FEXPR + * + 8A4D 10AE 02 EVFEXP LDY 2,X + 8A50 20 EF BRA EVEXP1 + * + * bind varables + * X : variable(s) + * Y : argument(s) + * + 8A52 CC 0418 BIND LDD #NIL + 8A55 36 06 PSHU D + 8A57 BIND1 TESTU + 8A5F 34 30 PSHS X,Y + 8A61 AE 84 LDX ,X + 8A63 2B 1C BMI BINDA0 + 8A65 10AE A4 LDY ,Y + 8A68 2B 0B BMI BIND2 + 8A6A 8D 17 BSR BINDA + 8A6C 35 30 PULS X,Y + 8A6E AE 02 LDX 2,X + 8A70 10AE 22 LDY 2,Y + 8A73 20 E2 BRA BIND1 + 8A75 108E 0418 BIND2 LDY #NIL + 8A79 8D 08 BSR BINDA + 8A7B 35 30 PULS X,Y + 8A7D AE 02 LDX 2,X + 8A7F 20 D6 BRA BIND1 + * + * bind atom + * + 8A81 35 30 BINDA0 PULS X,Y + 8A83 8C 0800 BINDA CMPX #CELTOP + 8A86 24 10 BCC BINRTS + 8A88 8C 0418 CMPX #NIL + 8A8B 27 0B BEQ BINRTS + 8A8D AE 84 LDX ,X + 8A8F EC 84 LDD ,X + 8A91 36 06 PSHU D + 8A93 36 10 PSHU X + 8A95 10AF 84 STY ,X + 8A98 39 BINRTS RTS + * + * unbind variables + * + 8A99 37 06 UNBIN0 PULU D + 8A9B ED 84 STD ,X + 8A9D AE C1 UNBIND LDX ,U++ + 8A9F 2B F8 BMI UNBIN0 + 8AA1 39 RTS + *** + *** ( EVBODY list ) SUBR + *** evaluate each element of list + *** val <= last element + *** + 8AA2 17 FED9 EVBOD0 LBSR EVAL + 8AA5 37 10 PULU X + 8AA7 AE 02 EVBODY LDX 2,X + 8AA9 36 10 PSHU X + 8AAB AE 84 LDX ,X + 8AAD 2A F3 BPL EVBOD0 + 8AAF 37 10 EVBOD1 PULU X + 8AB1 39 RTS + *** + *** ( COND clause1 clause2 ... ) FSUBR + *** val <= result or NIL + *** + 8AB2 37 10 COND0 PULU X + 8AB4 AE 02 LDX 2,X + 8AB6 36 10 COND PSHU X + 8AB8 AE 84 LDX ,X + 8ABA 2B F3 BMI EVBOD1 + 8ABC AE 84 LDX ,X + 8ABE 2B F2 BMI COND0 + 8AC0 17 FEBB LBSR EVAL + 8AC3 108C 0418 CMPY #NIL + 8AC7 27 E9 BEQ COND0 + 8AC9 AE D1 LDX [,U++] + 8ACB 20 DA BRA EVBODY + *** + *** ( MAPCAR fn list ) SUBR + *** val <= list of values + *** + 8ACD 36 30 MAPCAR PSHU X,Y + 8ACF AE A4 LDX ,Y + 8AD1 2B 15 BMI MAPCA1 + 8AD3 17 059E LBSR CONSN1 + 8AD6 AE C4 LDX ,U + 8AD8 8D 54 BSR APPLY + 8ADA 1F 20 TFR Y,D + 8ADC 37 30 PULU X,Y + 8ADE 10AE 22 LDY 2,Y + 8AE1 36 06 PSHU D + 8AE3 8D E8 BSR MAPCAR + 8AE5 16 057D LBRA CONSU + * + 8AE8 37 30 MAPCA1 PULU X,Y + 8AEA 39 RTS + *** + *** ( MAPCAN fn list ) SUBR + *** val <= appended list of values + *** + 8AEB 36 30 MAPCAN PSHU X,Y + 8AED AE A4 LDX ,Y + 8AEF 2B F7 BMI MAPCA1 + 8AF1 17 0580 LBSR CONSN1 + 8AF4 AE C4 LDX ,U + 8AF6 8D 36 BSR APPLY + 8AF8 1F 20 TFR Y,D + 8AFA 37 30 PULU X,Y + 8AFC 10AE 22 LDY 2,Y + 8AFF 36 06 PSHU D + 8B01 8D E8 BSR MAPCAN + 8B03 37 10 PULU X + 8B05 16 0472 LBRA APPXY + *** + *** ( MAPC fn list ) SUBR + *** val <= NIL + *** + 8B08 36 30 MAPC PSHU X,Y + 8B0A AE A4 MAPC1 LDX ,Y + 8B0C 2B DA BMI MAPCA1 + 8B0E 17 0563 LBSR CONSN1 + 8B11 AE C4 LDX ,U + 8B13 8D 19 BSR APPLY + 8B15 10AE 42 LDY 2,U + 8B18 10AE 22 LDY 2,Y + 8B1B 10AF 42 STY 2,U + 8B1E 20 EA BRA MAPC1 + *** + *** ( FUNCALL fn arg! ... ) LSUBR + *** evaluate function + *** val <= value of function + *** + 8B20 10AE 02 FUNCALL LDY 2,X + 8B23 AE 84 LDX ,X + 8B25 2A 07 BPL APPLY + 8B27 16 F9A3 LBRA ERROR + *** + *** ( APPLY fn list ) SUBR + *** evaluate function, argument are list + *** val <= value of function + *** + 8B2A 32 62 APPLY0 LEAS 2,S + 8B2C AE 84 LDX ,X + 8B2E APPLY TESTS + 8B36 TESTU + 8B3E 8C 0800 CMPX #CELTOP + 8B41 24 46 BCC APPLYL + 8B43 AE 84 LDX ,X + 8B45 EC 04 LDD 4,X + 8B47 34 06 PSHS D + 8B49 A6 06 LDA 6,X + 8B4B 27 DD BEQ APPLY0 + 8B4D 81 01 CMPA #NSUBR + 8B4F 27 1F BEQ APSUBR + 8B51 81 02 CMPA #NFSUBR + 8B53 1027 FEE1 LBEQ EVLSB1 + 8B57 81 03 CMPA #NLSUBR + 8B59 1027 FEDB LBEQ EVLSB1 + 8B5D 81 09 CMPA #NEXPR + 8B5F 1027 FEDE LBEQ EVEXP1 + 8B63 81 0A CMPA #NFEXPR + 8B65 1027 FED8 LBEQ EVEXP1 + 8B69 81 0C CMPA #NMACRO + 8B6B 27 16 BEQ APMACR + 8B6D 16 F9C5 LBRA ERRUND + * + * APPLY - SUBR + * + 8B70 AE A4 APSUBR LDX ,Y + 8B72 2B 07 BMI APSUB1 + 8B74 10AE B8 02 LDY [2,Y] + 8B78 2B 04 BMI APSUB2 + 8B7A 39 RTS + 8B7B 8E 0418 APSUB1 LDX #NIL + 8B7E 108E 0418 APSUB2 LDY #NIL + 8B82 39 RTS + * + * APPLY - MACRO + * + 8B83 17 04DD APMACR LBSR CONS + 8B86 16 FDEF LBRA EVMAC1 + * + * APPLY - LAMBDA + * + 8B89 EC 84 APPLYL LDD ,X + 8B8B 1083 00AA CMPD #LAMBDA + 8B8F 1026 F9A2 LBNE ERRUND + 8B93 16 FE4A LBRA EVALL2 + + + *-------------------------------------- + * + * PROPERTY + * + *-------------------------------------- + *** + *** ( DEFUN 'fn ['type] 'args 'body ) FSUBR + *** define function + *** val <= fn + *** + 8B96 10AE 84 DEFUN LDY ,X + 8B99 AE 02 LDX 2,X + 8B9B EC 84 LDD ,X + 8B9D 1083 0142 CMPD #EXPR + 8BA1 27 13 BEQ DE1 + 8BA3 1083 0146 CMPD #FEXPR + 8BA7 27 27 BEQ DF1 + 8BA9 1083 0468 CMPD #MACRO + 8BAD 27 28 BEQ DM1 + 8BAF 86 09 LDA #NEXPR + 8BB1 20 07 BRA DE3 + *** + *** ( DE 'fn 'args 'body ) FSUBR + *** define EXPR function + *** val <= fn + *** + 8BB3 10AE 84 DE LDY ,X + 8BB6 86 09 DE1 LDA #NEXPR + 8BB8 AE 02 DE2 LDX 2,X + 8BBA 108C 0800 DE3 CMPY #CELTOP + 8BBE 1024 F944 LBCC ERRDE + 8BC2 34 20 PSHS Y + 8BC4 10AE A4 LDY ,Y + 8BC7 A7 26 STA 6,Y + 8BC9 AF 24 STX 4,Y + 8BCB 35 A0 PULS Y,PC + *** + *** ( DF 'fn 'args 'body ) FSUBR + *** define FEXPR function + *** val <= fn + *** + 8BCD 10AE 84 DF LDY ,X + 8BD0 86 0A DF1 LDA #NFEXPR + 8BD2 20 E4 BRA DE2 + *** + *** ( DM 'fn 'args 'body ) FSUBR + *** define MACRO function + *** val <= fn + *** + 8BD4 10AE 84 DM LDY ,X + 8BD7 86 0C DM1 LDA #NMACRO + 8BD9 20 DD BRA DE2 + *** + *** ( SET atom value ) SUBR + *** give value to symbolic atom + *** val <= value + *** + 8BDB 8C 0800 SET CMPX #CELTOP + 8BDE 24 3F BCC SET9 + 8BE0 8C 0418 CMPX #NIL + 8BE3 27 3A BEQ SET9 + 8BE5 8C 0400 CMPX #T + 8BE8 27 35 BEQ SET9 + 8BEA 10AF 94 STY [,X] + 8BED 39 RTS + *** + *** ( SETQ 'atom1 value1 ... ) FSUBR + *** val <= last value + *** + 8BEE AE 98 02 SETQ0 LDX [2,X] + 8BF1 2B 2C BMI SET9 + 8BF3 17 FD88 LBSR EVAL + 8BF6 AE D4 LDX [,U] + 8BF8 8D E1 BSR SET + 8BFA 37 10 PULU X + 8BFC AE 02 LDX 2,X + 8BFE AE 02 LDX 2,X + 8C00 36 10 SETQ PSHU X + 8C02 A6 84 LDA ,X + 8C04 2A E8 BPL SETQ0 + 8C06 33 42 SETQ1 LEAU 2,U + 8C08 39 RTS + *** + *** ( SETQQ 'atom1 'value1 ... ) FSUBR + *** val <= last value + *** + 8C09 AE 84 SETQQ0 LDX ,X + 8C0B 8D CE BSR SET + 8C0D 37 10 PULU X + 8C0F AE 02 LDX 2,X + 8C11 AE 02 LDX 2,X + 8C13 36 10 SETQQ PSHU X + 8C15 A6 84 LDA ,X + 8C17 2B ED BMI SETQ1 + 8C19 10AE 98 02 LDY [2,X] + 8C1D 2A EA BPL SETQQ0 + 8C1F 16 F8D7 SET9 LBRA ERRSET + *** + *** ( FVALUE atom ) SUBR + *** val <= function values of atom ( list or number ) + *** + 8C22 8C 0800 FVALUE CMPX #CELTOP + 8C25 1024 F8EA LBCC ERRATM + 8C29 AE 84 LDX ,X + 8C2B 10AE 04 LDY 4,X + 8C2E A6 06 LDA 6,X + 8C30 8E 0142 LDX #EXPR + 8C33 81 09 CMPA #NEXPR + 8C35 1025 F819 LBCS MNAY + 8C39 27 0A BEQ FVALU1 + 8C3B 8E 0146 LDX #FEXPR + 8C3E 81 0A CMPA #NFEXPR + 8C40 27 03 BEQ FVALU1 + 8C42 8E 0468 LDX #MACRO + 8C45 16 041B FVALU1 LBRA CONS + *** + *** ( PROPLIST atom ) SUBR + *** val <= p-list of atom + *** + 8C48 8C 0800 PROPLI CMPX #CELTOP + 8C4B 1024 F8C4 LBCC ERRATM + 8C4F AE 84 LDX ,X + 8C51 10AE 02 LDY 2,X + 8C54 39 RTS + *** + *** ( GET atom ind ) SUBR + *** get property of symbolic atom + *** val <= property or NIL + *** + 8C55 8C 0800 GET CMPX #CELTOP + 8C58 1024 F8B7 LBCC ERRATM + 8C5C AE 84 LDX ,X + 8C5E AE 02 LDX 2,X + 8C60 1E 12 EXG X,Y + 8C62 17 0235 LBSR ASSOC + 8C65 108C 0418 CMPY #NIL + 8C69 27 5F BEQ ERMRTS + 8C6B 10AE 22 LDY 2,Y + 8C6E 39 RTS + *** + *** ( PUT atom ind e ) LSUBR + *** add property + *** val <= e + *** + 8C6F 10AE 84 PUT LDY ,X + 8C72 102B F8E6 PUTERR LBMI ERRPUT + 8C76 AE 02 LDX 2,X + 8C78 EC 84 LDD ,X + 8C7A 2B F6 BMI PUTERR + 8C7C AE 02 LDX 2,X + 8C7E AE 84 LDX ,X + 8C80 2B F0 BMI PUTERR + 8C82 108C 0800 CMPY #CELTOP + 8C86 1024 F889 LBCC ERRATM + 8C8A 10AE A4 LDY ,Y + 8C8D 31 22 LEAY 2,Y + 8C8F 34 30 PSHS X,Y + 8C91 10AE A4 LDY ,Y + 8C94 1F 01 TFR D,X + 8C96 17 0201 LBSR ASSOC + 8C99 108C 0418 CMPY #NIL + 8C9D 27 08 BEQ PUT1 + 8C9F 35 10 PULS X + 8CA1 AF 22 STX 2,Y + 8CA3 31 84 LEAY ,X + 8CA5 35 86 PULS D,PC + * + 8CA7 10AE E4 PUT1 LDY ,S + 8CAA 17 03B6 LBSR CONS + 8CAD 30 A4 LEAX ,Y + 8CAF 10AE F8 02 LDY [2,S] + 8CB3 17 03AD LBSR CONS + 8CB6 10AF F8 02 STY [2,S] + 8CBA 10AE E4 LDY ,S + 8CBD 35 96 PULS D,X,PC + *** + *** ( CARMODE e ) SUBR + *** if e = NIL then disable (CAR atom) + *** else enable + *** val <= NIL + *** + 8CBF 7F 8133 CARMOD CLR CARSW + 8CC2 8C 0418 CMPX #NIL + 8CC5 26 03 BNE ERMRTS + 8CC7 7C 8133 INC CARSW + 8CCA 39 ERMRTS RTS + *** + *** ( GBCMODE e ) SUBR + *** if e = NIL then disable message + *** else enable + *** val <= NIL + *** + 8CCB 7F 8134 GBCMODE CLR GBCSW + 8CCE 8C 0418 CMPX #NIL + 8CD1 27 F7 BEQ ERMRTS + 8CD3 7C 8134 INC GBCSW + 8CD6 39 RTS + *** + *** ( ECHOMODE e ) SUBR + *** if e = NIL then disable echoback + *** else enable + *** val <= NIL + *** + 8CD7 7F 8132 ECHOMO CLR ECHOSW + 8CDA 8C 0418 CMPX #NIL + 8CDD 26 EB BNE ERMRTS + 8CDF 7C 8132 INC ECHOSW + 8CE2 39 RTS + + + *-------------------------------------- + * + * PROG AND LOOP + * + *-------------------------------------- + *** + *** ( PROG 'args 'body ) FSUBR + *** val <= value of RETURN or NIL + *** + 8CE3 34 10 PROG PSHS X + 8CE5 AE 84 LDX ,X + 8CE7 102B F814 PROG9 LBMI ERRPRG + 8CEB 17 FD64 LBSR BIND + 8CEE 35 10 PULS X + 8CF0 36 10 PSHU X + 8CF2 8D 20 BSR PROGS + 8CF4 7F 8136 PRG1 CLR RTNSW + 8CF7 33 42 LEAU 2,U + 8CF9 16 FDA1 LBRA UNBIND + *** + *** ( LOOP 'args 'body ) FSUBR + *** val <= value of RETURN + *** + 8CFC 34 10 LOOP PSHS X + 8CFE AE 84 LDX ,X + 8D00 2B E5 BMI PROG9 + 8D02 17 FD4D LBSR BIND + 8D05 35 10 PULS X + 8D07 36 10 PSHU X + 8D09 AE C4 LOOP1 LDX ,U + 8D0B 8D 07 BSR PROGS + 8D0D B6 8136 LDA RTNSW + 8D10 27 F7 BEQ LOOP1 + 8D12 20 E0 BRA PRG1 + * + * + * + 8D14 AE 02 PROGS LDX 2,X + 8D16 36 10 PSHU X + 8D18 AE 84 LDX ,X + 8D1A 2B 21 BMI PROGS2 + 8D1C 17 FC5F LBSR EVAL + 8D1F 37 10 PULU X + 8D21 B6 8136 LDA RTNSW + 8D24 26 19 BNE PRGRTS + 8D26 B6 8135 LDA GOSW + 8D29 27 E9 BEQ PROGS + 8D2B 7F 8135 CLR GOSW + 8D2E AE C4 LDX ,U + 8D30 AE 02 PROGS1 LDX 2,X + 8D32 A6 84 LDA ,X + 8D34 2B B1 BMI PROG9 + 8D36 10AC 84 CMPY ,X + 8D39 26 F5 BNE PROGS1 + 8D3B 20 D7 BRA PROGS + 8D3D 37 20 PROGS2 PULU Y + 8D3F 39 PRGRTS RTS + *** + *** ( GO 'label ) FSUBR + *** val <= label + *** + 8D40 7C 8135 GO INC GOSW + 8D43 10AE 84 LDY ,X + 8D46 2B 9F BMI PROG9 + 8D48 39 RTS + *** + *** ( RETURN value ) SUBR + *** val <= value + *** + 8D49 7C 8136 RETURN INC RTNSW + 8D4C 31 84 LEAY ,X + 8D4E 39 RTS + *** + *** ( PROGN e1 e2 ... ) LSUBR + *** val <= last e + *** + 8D4F 10AE 84 PROGN0 LDY ,X + 8D52 AE 02 LDX 2,X + 8D54 A6 84 PROGN LDA ,X + 8D56 2A F7 BPL PROGN0 + 8D58 39 RTS + *** + *** ( PROG1 e1 e2 ... ) LSUBR + *** val <= e1 + *** + 8EE2 PROG1 EQU CAR + *** + *** ( PROG2 e1 e2 ... ) LSUBR + *** val <= e2 + *** + 8EE0 PROG2 EQU CADR + *** + *** ( CATCH e1 'tag ) FSUBR + *** val <= value of e1 or THROWed value + *** + 8D59 34 40 CATCH PSHS U + 8D5B 36 10 PSHU X + 8D5D 30 E4 LEAX ,S + 8D5F 17 F6F2 LBSR MNAX + 8D62 30 A4 LEAX ,Y + 8D64 10BE 8137 LDY CATCHL + 8D68 17 02F8 LBSR CONS + 8D6B AE C4 LDX ,U + 8D6D A6 84 LDA ,X + 8D6F 2B 37 BMI CATERR + 8D71 AE 98 02 LDX [2,X] + 8D74 2B 32 BMI CATERR + 8D76 17 02EA LBSR CONS + 8D79 10BF 8137 STY CATCHL + 8D7D AE D1 LDX [,U++] + 8D7F 17 FBFC LBSR EVAL + 8D82 BE 8137 LDX CATCHL + 8D85 AE 02 LDX 2,X + 8D87 AE 02 LDX 2,X + 8D89 BF 8137 STX CATCHL + 8D8C 35 C0 CATCH1 PULS U,PC + *** + *** ( THROW value 'tag ) FSUBR + *** val <= value + *** + 8D8E 36 10 THROW PSHU X + 8D90 AE 84 LDX ,X + 8D92 2B 14 BMI CATERR + 8D94 17 FBE7 LBSR EVAL + 8D97 AE C4 LDX ,U + 8D99 10AF C4 STY ,U + 8D9C AE 98 02 LDX [2,X] + 8D9F 2B 07 BMI CATERR + 8DA1 10BE 8137 LDY CATCHL + 8DA5 17 00E1 LBSR MEMBER + 8DA8 1026 F725 CATERR LBNE ERRCAT + 8DAC AE 22 LDX 2,Y + 8DAE 10AE 02 LDY 2,X + 8DB1 10BF 8137 STY CATCHL + 8DB5 AE 84 LDX ,X + 8DB7 32 98 02 LEAS [2,X] + 8DBA 37 20 PULU Y + 8DBC 11A3 E4 THROW1 CMPU ,S + 8DBF 27 CB BEQ CATCH1 + 8DC1 17 FCD9 LBSR UNBIND + 8DC4 20 F6 BRA THROW1 + + + *-------------------------------------- + * + * PREDICATES + * + *-------------------------------------- + *** + *** ( ALPHORDER atom1 atom2 ) SUBR + *** val <= T or NIL + *** + 8DC6 17 FA6A ALPHOR LBSR STRING + 8DC9 1E 12 EXG X,Y + 8DCB 17 FA65 LBSR STRING + 8DCE A6 80 ALPHO1 LDA ,X+ + 8DD0 A1 A0 CMPA ,Y+ + 8DD2 25 3B BCS FALSE + 8DD4 26 2F BNE TRUE + 8DD6 4D TSTA + 8DD7 26 F5 BNE ALPHO1 + 8DD9 20 2A BRA TRUE + *** + *** ( GREATERP n1 n2 ) SUBR + *** n1 > n2 ??? + *** val <= T or NIL + *** + 8DDB 1E 12 GREATE EXG X,Y + *** + *** ( LESSP n1 n2 ) SUBR + *** n1 < n2 ??? + *** val <= T or NIL + *** + 8DDD 17 F3DC LESSP LBSR NUMXY + 8DE0 17 F5BA LBSR NCMP + 8DE3 2C 2A BGE FALSE + 8DE5 20 1E BRA TRUE + *** + *** ( SYMBOLP e ) SUBR + *** e is symbol ??? + *** val <= T or NIL + *** + 8DE7 8C 0800 SYMBOL CMPX #CELTOP + 8DEA 24 23 BCC FALSE + 8DEC 20 17 BRA TRUE + *** + *** ( NUMBERP e ) SUBR + *** e is number ??? + *** val <= T or NIL + ***+ + 8DEE 8C 0800 NUMBER CMPX #CELTOP + 8DF1 25 1C BCS FALSE + *** + *** ( ATOM e ) SUBR + *** e is atom ??? + *** val <= T or NIL + *** + 8DF3 A6 84 ATOM LDA ,X + 8DF5 2A 18 BPL FALSE + 8DF7 20 0C BRA TRUE + *** + *** ( LSITP e ) SUBR + *** e Is list ??? + *** val <= T or NIL + *** + 8DF9 A6 84 LISTP LDA ,X + 8DFB 2A 08 BPL TRUE + 8DFD 20 10 BRA FALSE + *** + *** ( EQ e1 e2 ) SUBR + *** e1 = e2 ??? + *** val <= T or NIL + *** + 8DFF 36 20 EQ PSHU Y + 8E01 AC C1 CMPX ,U++ + 8E03 26 0A BNE FALSE + 8E05 108E 0400 TRUE LDY #T + 8E09 39 RTS + *** + *** ( NULL e ) SUBR + *** ( NOT e ) SUBR + *** e is NIL ??? + *** val <= T or NIL + *** + 8E0A NULL EQU * + 8E0A 8C 0418 NOT CMPX #NIL + 8E0D 27 F6 BEQ TRUE + 8E0F 108E 0418 FALSE LDY #NIL + 8E13 39 RTS + *** + *** ( PLUSP e ) SUBR + *** e >= 0 ??? + *** val <= T or NIL + *** + 8E14 8C 0800 PLUSP CMPX #CELTOP + 8E17 25 F6 BCS FALSE + 8E19 A6 84 LDA ,X + 8E1B 2A F2 BPL FALSE + 8E1D 85 40 BITA #$40 + 8E1F 27 E4 BEQ TRUE + 8E21 20 EC BRA FALSE + *** + *** ( MINUSP e ) SUBR + *** e < 0 ??? + *** val <= T or NIL + *** + 8E23 8C 0800 MINUSP CMPX #CELTOP + 8E26 25 E7 BCS FALSE + 8E28 A6 84 LDA ,X + 8E2A 2A E3 BPL FALSE + 8E2C 85 40 BITA #$40 + 8E2E 26 D5 BNE TRUE + 8E30 20 DD BRA FALSE + *** + *** ( oneP e ) SUBR + *** e = 1 ??? + *** + 8E32 EC 02 ONEP LDD 2,X + 8E34 1083 0001 CMPD #1 + 8E38 26 D5 ONEP1 BNE FALSE + 8E3A 8C 0800 CMPX #CELTOP + 8E3D 25 D0 BCS FALSE + 8E3F EC 84 LDD ,X + 8E41 1083 8000 CMPD #$8000 + 8E45 27 BE BEQ TRUE + 8E47 20 C6 BRA FALSE + *** + *** ( ZEROP e ) SUBR + *** e = 0 ??? + *** val <= T or NIL + *** + 8E49 EC 02 ZEROP LDD 2,X + 8E4B 20 EB BRA ONEP1 + *** + *** ( EQUAL e1 e2 ) SUBR + *** compare e1 with e2 + *** val <= T or NIL + *** zero flag is set ( T ) + *** + 8E4D EQUAL0 TESTS + 8E55 8D 09 BSR EQUAL + 8E57 26 16 BNE EQUAL2 + 8E59 35 30 PULS X,Y + 8E5B AE 02 LDX 2,X + 8E5D 10AE 22 LDY 2,Y + 8E60 34 30 EQUAL PSHS X,Y + 8E62 AE 84 LDX ,X + 8E64 2B 0C BMI EQUAL3 + 8E66 10AE A4 LDY ,Y + 8E69 2A E2 BPL EQUAL0 + 8E6B 108E 0418 EQUAL1 LDY #NIL + 8E6F 32 64 EQUAL2 LEAS 4,S + 8E71 39 RTS + * + 8E72 AC A4 EQUAL3 CMPX ,Y + 8E74 26 F5 BNE EQUAL1 + 8E76 AE E4 LDX ,S + 8E78 AE 02 LDX 2,X + 8E7A AC 22 CMPX 2,Y + 8E7C 26 ED BNE EQUAL1 + 8E7E 108E 0400 LDY #T + 8E82 4F CLRA + 8E83 32 64 LEAS 4,S + 8E85 39 RTS + *** + *** ( MEMBER e list ) SUBR + *** e is top listevel element of 1 ??? + *** val <= sublist or NIL + *** + 8E86 10AE 22 MEMBE0 LDY 2,Y + 8E89 34 30 MEMBER PSHS X,Y + 8E8B 10AE A4 LDY ,Y + 8E8E 2B DB BMI EQUAL1 + 8E90 8D CE BSR EQUAL + 8E92 35 30 PULS X,Y + 8E94 26 F0 BNE MEMBE0 + 8E96 39 RTS + *** + *** ( ASSOC e a-list ) SUBR + *** search e + *** val <= element or NIL + *** + 8E97 10AE 22 ASSOC0 LDY 2,Y + 8E9A 34 30 ASSOC PSHS X,Y + 8E9C 10AE A4 LDY ,Y + 8E9F 2B CA BMI EQUAL1 + 8EA1 10AE A4 LDY ,Y + 8EA4 2B 02 BMI ASSOC1 + 8EA6 8D B8 BSR EQUAL + 8EA8 35 30 ASSOC1 PULS X,Y + 8EAA 26 EB BNE ASSOC0 + 8EAC 10AE A4 LDY ,Y + 8EAF 39 RTS + *** + *** ( MEMQ obj list ) SUBR + *** obj is top level element of list ??? + *** ( uses EQ instead of EQUAL ) + *** val <= sublist or NIL + *** + 8EB0 10AE 22 MEMQ0 LDY 2,Y + 8EB3 AC A4 MEMQ CMPX ,Y + 8EB5 27 04 BEQ MEMRTS + 8EB7 A6 A4 LDA ,Y + 8EB9 2A F5 BPL MEMQ0 + 8EBB 39 MEMRTS RTS + *** + *** ( ASSQ obj a-list ) SUBR + *** search obj + *** ( uses EQ instead of EQUAL ) + *** val <= element or NIL + *** + 8EBC 35 20 ASSQ0 PULS Y + 8EBE 10AE 22 LDY 2,Y + 8EC1 34 20 ASSQ PSHS Y + 8EC3 10AE A4 LDY ,Y + 8EC6 2B 06 BMI ASSQ1 + 8EC8 AC A4 CMPX ,Y + 8ECA 26 F0 BNE ASSQ0 + 8ECC 35 90 PULS X,PC + 8ECE 35 A0 ASSQ1 PULS Y,PC + + + *-------------------------------------- + * + * LIST FUNCTIONS + * + *-------------------------------------- + *** + *** ( C..R e ) SUBR + *** ( C..R e ) " + *** ( CAR e ) " + *** ( CDR e ) " + *** + 8ED0 8D 22 CAAAR BSR CARX + 8ED2 20 02 BRA CAAR + 8ED4 8D 23 CAADR BSR CDRX + 8ED6 8D 1C CAAR BSR CARX + 8ED8 20 08 BRA CAR + 8EDA 8D 18 CADAR BSR CARX + 8EDC 20 02 BRA CADR + 8EDE 8D 19 CADDR BSR CDRX + 8EE0 8D 17 CADR BSR CDRX + 8EE2 10AE 84 CAR LDY ,X + 8EE5 2A 11 BPL CARRTS + 8EE7 B6 8133 CARERR LDA CARSW + 8EEA 1026 F5F6 LBNE ERRCAR + 8EEE 8E 0418 LDX #NIL + 8EF1 31 84 LEAY ,X + 8EF3 39 RTS + * + 8EF4 AE 84 CARX LDX ,X + 8EF6 2B EF BMI CARERR + 8EF8 39 CARRTS RTS + * + 8EF9 A6 84 CDRX LDA ,X + 8EFB 2B EA BMI CARERR + 8EFD AE 02 LDX 2,X + 8EFF 39 RTS + * + 8F00 8D F2 CDAAR BSR CARX + 8F02 20 02 BRA CDAR + 8F04 8D F3 CDADR BSR CDRX + 8F06 8D EC CDAR BSR CARX + 8F08 20 08 BRA CDR + 8F0A 8D E8 CDDAR BSR CARX + 8F0C 20 02 BRA CDDR + 8F0E 8D E9 CDDDR BSR CDRX + 8F10 8D E7 CDDR BSR CDRX + 8F12 A6 84 CDR LDA ,X + 8F14 2B D1 BMI CARERR + 8F16 10AE 02 LDY 2,X + 8F19 39 RTS + *** + *** ( LAST list ) SUBR + *** val <= list of last element of list + *** + 8F1A 31 84 LAST0 LEAY ,X + 8F1C AE 02 LDX 2,X + 8F1E A6 84 LAST LDA ,X + 8F20 2A F8 BPL LAST0 + 8F22 39 RTS + *** + *** ( REVERSE list ) SUBR + *** val <= reversed list + *** + 8F23 17 013D REVER0 LBSR CONS + 8F26 37 10 PULU X + 8F28 AE 02 LDX 2,X + 8F2A 36 10 REVERS PSHU X + 8F2C AE 84 LDX ,X + 8F2E 2A F3 BPL REVER0 + 8F30 33 42 LEAU 2,U + 8F32 39 RTS + *** + *** ( COPY e ) SUBR + *** val <= copy of e + *** + 8F33 COPY TESTS + 8F3B TESTU + 8F43 36 10 PSHU X + 8F45 AE 84 LDX ,X + 8F47 2B 0E BMI COPY1 + 8F49 8D E8 BSR COPY + 8F4B AE C4 LDX ,U + 8F4D 10AF C4 STY ,U + 8F50 AE 02 LDX 2,X + 8F52 8D DF BSR COPY + 8F54 16 010E LBRA CONSU + 8F57 37 20 COPY1 PULU Y + 8F59 39 CPYRTS RTS + *** + *** ( APPEND 11 12 ... ) LSUBR + *** val <= connected list + *** + 8F5A EC 84 APPEND LDD ,X + 8F5C 2B FB BMI CPYRTS + 8F5E 36 06 APPEN1 PSHU D + 8F60 AE 02 LDX 2,X + 8F62 EC 84 LDD ,X + 8F64 2B F1 BMI COPY1 + 8F66 TESTU + 8F6E TESTS + 8F76 8D E6 BSR APPEN1 + 8F78 37 10 PULU X + * + * append X to Y + * + 8F7A EC 84 APPXY LDD ,X + 8F7C 2B DB BMI CPYRTS + 8F7E 36 06 PSHU D + 8F80 AE 02 LDX 2,X + 8F82 TESTS + 8F8A TESTU + 8F92 8D E6 BSR APPXY + 8F94 16 00CE LBRA CONSU + *** + *** ( NCONC 11 12 ... ) LSUBR + *** val <= append list, use RPLACD + *** + 8F97 EC 84 NCONC LDD ,X + 8F99 2B BE BMI CPYRTS + 8F9B 34 06 NCONC1 PSHS D + 8F9D AE 02 LDX 2,X + 8F9F EC 84 LDD ,X + 8FA1 2B 1C BMI NCONC4 + 8FA3 TESTS + 8FAB 8D EE BSR NCONC1 + 8FAD AE E4 LDX ,S + 8FAF A6 84 LDA ,X + 8FB1 2B 0E BMI NCONC5 + 8FB3 A6 98 02 NCONC2 LDA [2,X] + 8FB6 2B 04 BMI NCONC3 + 8FB8 AE 02 LDX 2,X + 8FBA 20 F7 BRA NCONC2 + 8FBC 10AF 02 NCONC3 STY 2,X + 8FBF 35 A0 NCONC4 PULS Y,PC + 8FC1 35 86 NCONC5 PULS D,PC + *** + *** ( AND 'e1 'e2 ... ) FSUBR + *** search NIL + *** val <= NIL or last e + *** + 8FC3 108E 0400 AND LDY #T + 8FC7 36 10 AND1 PSHU X + 8FC9 AE 84 LDX ,X + 8FCB 2B 22 BMI OR1 + 8FCD 17 F9AE LBSR EVAL + 8FD0 108C 0418 CMPY #NIL + 8FD4 27 19 BEQ OR1 + 8FD6 37 10 PULU X + 8FD8 AE 02 LDX 2,X + 8FDA 20 EB BRA AND1 + *** + *** ( OR 'e1 'e2 ... ) FSUBR + *** search non-NIL + *** val <= non-NIL or NIL + *** + 8FDC 17 F99F OR0 LBSR EVAL + 8FDF 108C 0418 CMPY #NIL + 8FE3 26 0A BNE OR1 + 8FE5 37 10 PULU X + 8FE7 AE 02 LDX 2,X + 8FE9 36 10 OR PSHU X + 8FEB AE 84 LDX ,X + 8FED 2A ED BPL OR0 + 8FEF 33 42 OR1 LEAU 2,U + 8FF1 39 RTS + *** + *** ( RPLACA l e ) SUBR + *** replace car of l with e + *** val <= 1 + *** + 8FF2 A6 84 RPLACA LDA ,X + 8FF4 102B F4D5 LBMI ERROR + 8FF8 10AF 84 STY ,X + 8FFB 31 84 LEAY ,X + 8FFD 39 RTS + *** + *** ( RPLACD l e ) SUBR + *** replace cdr of l with e + *** val <= l + *** + 8FFE A6 84 RPLACD LDA ,X + 9000 102B F4C9 LBMI ERROR + 9004 10AF 02 STY 2,X + 9007 31 84 LEAY ,X + 9009 39 RTS + *** + *** ( LIST e1 e2 ... ) LSUBR + *** val <= list of e1 ... + *** + 899C LIST EQU EVAL1 + *** + *** ( DBLIST ) SUBR + *** val <= list of atoms + *** + 900A 108E 0418 OBLIST LDY #NIL + 900E 8E 0000 LDX #HSHTOP + 9011 34 10 OBLIS1 PSHS X + 9013 EC 84 LDD ,X + 9015 27 03 BEQ OBLIS2 + >9017 17 0049 LBSR CONS + 901A 35 10 OBLIS2 PULS X + 901C 30 02 LEAX 2,X + 901E 8C 0800 CMPX #HSHBTM + 9021 26 EE BNE OBLIS1 + 9023 39 RTS + *** + *** ( POP 'var ) FSUBR + *** (PROG1 (CAR var) (SETQ var (CDR var))) + *** + 9024 AE 84 POP LDX ,X + 9026 8C 0800 CMPX #CELTOP + 9029 1024 F4A0 LBCC ERROR + 902D AE 84 LDX ,X + 902F 10AE 84 LDY ,X + 9032 EC 22 LDD 2,Y + 9034 10AE A4 LDY ,Y + 9037 102B F4A9 LBMI ERRCAR + 903B ED 84 STD ,X + 903D 39 RTS + *** + *** ( PUSH item 'var ) FSUBR + *** (SETQ var (CONS item var)) + *** + 903E 36 10 PUSH PSHU X + 9040 AE 84 LDX ,X + 9042 102B F487 LBMI ERROR + 9046 17 F935 LBSR EVAL + 9049 37 10 PULU X + 904B AE 98 02 LDX [2,X] + 904E 8C 0800 CMPX #CELTOP + 9051 1024 F478 LBCC ERROR + 9055 AE 84 LDX ,X + 9057 34 10 PSHS X + 9059 AE 84 LDX ,X + 905B 1E 12 EXG X,Y + 905D 8D 04 BSR CONS + 905F 10AF F1 STY [,S++] + 9062 39 RTS + + + *-------------------------------------- + * + * GARBAGE COLLECTION + * + *-------------------------------------- + *** + *** ( CONS e1 e2 ) SUBR + *** val <= list + *** + 9063 36 10 CONS PSHU X + 9065 36 20 CONSU PSHU Y + 9067 8D 17 CONSUU BSR NEW + 9069 37 06 PULU D + 906B ED 22 STD 2,Y + 906D 37 06 PULU D + 906F ED A4 STD ,Y + 9071 39 RTS + * + 9072 30 A4 CONSN LEAX ,Y + 9074 108E 0418 CONSN1 LDY #NIL + 9078 20 E9 BRA CONS + * + * get a free cell ( address in Y ) + * + 907A 34 10 NEW0 PSHS X + 907C 8D 0E BSR GBC + 907E 35 10 PULS X + 9080 10BE 813B NEW LDY FREE + 9084 EC A4 LDD ,Y + 9086 2B F2 BMI NEW0 + 9088 FD 813B STD FREE + 908B 39 RTS + *** + *** ( GBC ) SUBR + *** garbage collection + *** val <= # of collected cells + *** + 908C 34 41 GBC PSHS U,CC + 908E 1A 50 ORCC #$50 + 9090 8D 1B BSR MARKS + 9092 8D 71 BSR COLLCT + 9094 1F 31 TFR U,X + 9096 35 41 PULS U,CC + 9098 8C 0003 CMPX #3 + 909B 1025 F401 LBCS ERRGBC + 909F 17 F3B2 LBSR MNAX + 90A2 8E 912C LDX #GMSG + 90A5 B6 8134 LDA GBCSW + 90A8 1026 F4D6 LBNE MSG + 90AC 39 RTS + * + * mark used cells + * + 90AD 108E A000 MARKS LDY #ATMTOP + 90B1 AE A1 MARKS1 LDX ,Y++ + 90B3 8D 3F BSR MARK + 90B5 AE A1 LDX ,y++ + 90B7 8D 3B BSR MARK + 90B9 AE A4 LDX ,Y + 90BB 8C 8000 CMPX #CELBTM + 90BE 24 02 BCC MARKS2 + 90C0 8D 32 BSR MARK + 90C2 31 23 MARKS2 LEAY 3,Y + 90C4 A6 A0 MARKS3 LDA ,Y+ + 90C6 26 FC BNE MARKS3 + 90C8 10BC 813D CMPY ATMEND + 90CC 25 E3 BCS MARKS1 + 90CE 20 06 BRA MARKS5 + * + 90D0 AE C1 MARKS4 LDX ,U++ + 90D2 2B 02 BMI MARKS5 + 90D4 8D 1E BSR MARK + 90D6 1183 C000 MARKS5 CMPU #USKBTM + 90DA 25 F4 BCS MARKS4 + 90DC BE 8137 LDX CATCHL + 90DF 8D 13 BSR MARK + 90E1 39 RTS + * + * mark list ( X ) + * + 90E2 34 10 MARK0 PSHS X + 90E4 118C 94F9 CMPS #LSPBTM+30 + 90E8 1025 0085 LBCS QUIT + 90EC 1F 01 TFR D,X + 90EE 8D 04 BSR MARK + 90F0 35 10 PULS X + 90F2 AE 02 LDX 2,X + 90F4 8C 0800 MARK CMPX #CELTOP + 90F7 25 0B BCS MAKRTS + 90F9 EC 84 LDD ,X + 90FB C5 01 BITB #1 + 90FD 26 05 BNE MAKRTS + 90FF 6C 01 INC 1,X + 9101 4D TSTA + 9102 2A DE BPL MARK0 + 9104 39 MAKRTS RTS + * + * collect frdd cells + * + 9105 8E 0800 COLLCT LDX #CELTOP + 9108 108E 0418 LDY #NIL + 910C CE 0000 LDU #0 + 910F E6 01 COLL1 LDB 1,X + 9111 C5 01 BITB #1 + 9113 26 09 BNE COLL2 + 9115 10AF 84 STY ,X + 9118 31 84 LEAY ,X + 911A 33 41 LEAU 1,U + 911C 20 02 BRA COLL3 + 911E 6A 01 COLL2 DEC 1,X + 9120 30 04 COLL3 LEAX 4,X + 9122 8C 8000 CMPX #CELBTM + 9125 25 E8 BCS COLL1 + 9127 10BF 813B STY FREE + 912B 39 RTS + * + * + 912C 2D 2D 47 61 GMSG FCC /--Garbage Collection--/,CR,LF,0 + 9130 72 62 61 67 + 9134 65 20 43 6F + 9138 6C 6C 65 63 + 913C 74 69 6F 6E + 9140 2D 2D 0D 0A + 9144 00 + + + *-------------------------------------- + * + * DISK I/O + * + *-------------------------------------- + *** + *** ( MREAD filename ) SUBR + *** read s-expr from DISK + *** val <= s-expr + *** + 9145 8D 10 MREAD BSR OPENR open file + 9147 17 F5B4 LBSR READ read s-expr + 914A 20 68 BRA CLOSEI close file + *** + *** ( MPRINT filename expr ) SUBR + *** write expr into DISK file + *** val <= expr + *** + 914C 8D 14 MPRINT BSR OPENW open output file + 914E 30 A4 LEAX ,Y + 9150 17 F454 LBSR PRINT print expr + 9153 20 5C BRA CLOSEO close file + *** + *** ( LOAD 'filename ) FSUBR + *** load programs + *** val <= NIL + *** + 9155 AE 84 LOAD LDX ,X + *** + *** ( OPENR filename ) SUBR + *** open input file + *** val <= NIL + *** + 9157 34 10 OPENR PSHS X + 9159 8D 59 BSR CLOSEI close input file + 915B 35 10 PULS X + 915D 17 F6D3 LBSR STRING + 9160 20 4C BRA OPENFI open input file + *** + *** ( OPENW filename ) SUBR + *** open output file + *** val <= NIL + *** + 9162 34 10 OPENW PSHS X + 9164 8D 4B BSR CLOSEO close output file + 9166 35 10 PULS X + 9168 17 F6C8 LBSR STRING + 916B 20 3E BRA OPENFO open output file + *** + *** ( CLOSER ) SUBR + *** close read file + *** val <= NIL + *** + 91B4 CLOSER EQU CLOSEI + *** + *** ( CLOSEW ) SUBR + *** close write file + *** val <= NIL + *** + 91B1 CLOSEW EQU CLOSEO + *** + *** ( CLOSE ) SUBR + *** close I/O files + *** val <= NIL + *** + 916D 8D 45 CLOSE BSR CLOSEI + 916F 20 40 BRA CLOSEO + *** + *** ( QUIT ) SUBR + *** terminate lisp, return to monitor + *** + 9171 8D FA QUIT BSR CLOSE close any open files + 9173 8E 917B LDX #QMSG + 9176 17 F409 LBSR MSG print message + 9179 20 3F BRA MON + * + 917B 0D 0A QMSG FCC CR,LF + 917D 6D 61 79 20 FCC /may the force be with you!/ + 9181 74 68 65 20 + 9185 66 6F 72 63 + 9189 65 20 62 65 + 918D 20 77 69 74 + 9191 68 20 79 6F + 9195 75 21 + 9197 0D 0A 00 FCB CR,LF,0 + *** + *** ( DOS 'command ) FSUBR + *** execute DOS command + *** val <= NIL + *** + 919A AE 84 DOS LDX ,X + 919C 17 F694 LBSR STRING + 919F 34 60 PSHS Y,U + 91A1 8D 14 BSR DODOS + 91A3 35 E0 PULS Y,U,PC + + + *************************************** + * + * LISP-09 I/O DRIVERS + * 1982.9.21 + * + *************************************** + * + * JUMP TABLE + * + 91A5 16 029A OUTPUT LBRA OUTPT1 + * output char in A to terminal ( OUTSW = 0 ) or + * disk (OUTSW <> 0 ) + * + 91A8 16 02A5 INPUT LBRA INPUT1 + * input char from terminal ( INSW = 0 ) or disk + * ( INSW <> 0 ) without echo + * + 91AB 16 02B5 OPENFO LBRA OPNFO1 + * open file for output + * X = filename pointer ( terminater = 0 ) + * + 91AE 16 02C8 OPENFI LBRA OPNFI1 + * open file for input + * X = filename pointer + * + 91B1 16 030E CLOSEO LBRA CLSO1 + * close output file + * + 91B4 16 0310 CLOSEI LBRA CLSI1 + * close input file + * + 91B7 16 0301 DODOS LBRA DODOS1 + * execute DOS command + * X = pointer to DOS command string + * + 91BA 7E CD03 MON JMP FLEX + * return to FLEX + * + 91BD 16 0314 INIT LBRA INI1 + * initialize system + * + ********** + * + * SYSTEM ADDRESSES + * + CD03 FLEX EQU $CD03 FLEX warm start entry + D3F9 OUTCH EQU $D3F9 output char ( pointer ) + D3E5 INCHNE EQU $D3E5 input char ( pointer ) + CD18 PUTCHR EQU $CD18 put character + D406 FMS EQU $D406 FMS call + CD24 PCRLF EQU $CD24 output crlf + CD2D GETFIL EQU $CD2D get file specification + CD33 SETEXT EQU $CD33 set extension + CD3F RPTERR EQU $CD3F report error message + CD4B DOCMND EQU $CD4B call DOS as a subroutine + C080 FLBUF EQU $C080 FLEX input line buffer + CC14 FLBUFP EQU $CC14 FLEX line buffer pointer + CC16 ESCRTN EQU $CC16 escape return register + CC0E SYSDAT EQU $CC0E system date register + * + * FMS functions + * + 0001 FMSR EQU 1 : read command + 0002 FMSW EQU 2 : write command + 0004 FMSC EQU 4 : close command + * + * FILE CONTROL BLOCKS + * + 91C0 00 OUTSW FCB 0 output file switch + 91C1 OUTFCB RMB 320 output file FCB + 9301 00 INSW FCB 0 input file switch + 9302 INFCB RMB 320 input file FCB + * + * + 9442 34 34 OUTPT1 PSHS B,X,Y + 9444 8E 91C0 LDX #OUTSW + 9447 6D 80 TST ,X+ + 9449 26 14 BNE FLEXIO + 944B BD CD18 JSR PUTCHR + 944E 35 B4 PULS B,X,Y,PC + * + 9450 34 34 INPUT1 PSHS B,X,Y + 9452 8E 9301 LDX #INSW + 9455 6D 80 TST ,X+ + 9457 26 06 BNE FLEXIO + 9459 AD 9F D3E5 JSR [INCHNE] + 945D 35 B4 PULS B,X,Y,PC + * + 945F 8D 2E FLEXIO BSR CALFMS + 9461 35 B4 PULS B,X,Y,PC + * + 9463 8D 40 OPNFO1 BSR SETSTR + 9465 8E 91C1 LDX #OUTFCB + 9468 BD CD2D JSR GETFIL + 946B 25 2D BCS FILERR + 946D 86 01 LDA #1 + 946F B7 91C0 STA OUTSW + 9472 BD CD33 JSR SETEXT + 9475 86 02 LDA #FMSW + 9477 20 14 BRA OPNFIL + * + 9479 8D 2A OPNFI1 BSR SETSTR + 947B 8E 9302 LDX #INFCB + 947E BD CD2D JSR GETFIL + 9481 25 17 BCS FILERR + 9483 86 01 LDA #1 + 9485 B7 9301 STA INSW + 9488 BD CD33 JSR SETEXT + 948B 86 01 LDA #FMSR + 948D A7 84 OPNFIL STA ,X + 948F BD D406 CALFMS JSR FMS + 9492 27 10 BEQ FMSRTS + 9494 A6 01 LDA 1,X + 9496 81 08 CMPA #8 + 9498 27 06 BEQ FMSEOF + 949A BD CD3F FILERR JSR RPTERR + 949D 16 EB63 LBRA WARMS + 94A0 8D 25 FMSEOF BSR CLSI1 + 94A2 86 0D LDA #CR + 94A4 39 FMSRTS RTS + * + 94A5 34 20 SETSTR PSHS Y + 94A7 108E C080 LDY #FLBUF + 94AB 10BF CC14 STY FLBUFP + 94AF A6 80 STSTR1 LDA ,X+ + 94B1 A7 A0 STA ,Y+ + 94B3 26 FA BNE STSTR1 + 94B5 86 0D LDA #CR + 94B7 A7 A2 STA ,-Y + 94B9 35 A0 PULS Y,PC + * + 94BB 8D E8 DODOS1 BSR SETSTR + 94BD BD CD4B JSR DOCMND + 94C0 20 12 BRA INI1 + * + 94C2 8E 91C0 CLSO1 LDX #OUTSW + 94C5 20 03 BRA CLSIO + * + 94C7 8E 9301 CLSI1 LDX #INSW + 94CA 6D 84 CLSIO TST ,X + 94CC 27 D6 BEQ FMSRTS + 94CE 6F 80 CLR ,X+ + 94D0 86 04 LDA #FMSC + 94D2 20 B9 BRA OPNFIL + * + 94D4 CC 8003 INI1 LDD #WARMS + 94D7 FD CC16 STD ESCRTN + 94DA 39 RTS + + + *-------------------------------------- + * + * START UP INITIALIZATION + * + *-------------------------------------- + * + 94DB XXXXX EQU * + * + * + 94DB 10CE A000 STARTU LDS #SSKBTM + 94DF CE C000 LDU #USKBTM + 94E2 8E 956F LDX #LSPMSG + 94E5 CC 1E00 LDD #(CELBTM-CELTOP)/4 + 94E8 8D 61 BSR MSGOUT + 94EA CC 0773 LDD #AAAAA-ATMTOP + 94ED 8D 5C BSR MSGOUT + 94EF CC 188D LDD #USKBTM-AAAAA + 94F2 8D 57 BSR MSGOUT + 94F4 CC 0B25 LDD #SSKBTM-LSPBTM + 94F7 8D 52 BSR MSGOUT + * + 94F9 8E 0000 LDX #HSHTOP + 94FC 6F 80 STATU0 CLR ,X+ + 94FE 8C 0800 CMPX #HSHBTM + 9501 26 F9 BNE STATU0 + 9503 8E 0800 LDX #CELTOP + 9506 CC 0418 LDD #NIL + 9509 FD 813B STD FREE + 950C ED 81 STATU1 STD ,X++ + 950E 8C 8000 CMPX #CELBTM + 9511 26 F9 BNE STATU1 + * + 9513 8E A000 LDX #ATMTOP + 9516 34 10 STATU2 PSHS X + 9518 30 07 LEAX 7,X + 951A 17 F322 LBSR CLRABF + 951D 17 F340 LBSR STORES + 9520 34 10 PSHS X + 9522 17 F39E LBSR MSA + 9525 AE 62 LDX 2,S + 9527 AF A4 STX ,Y + 9529 CC A773 LDD #AAAAA + 952C FD 813D STD ATMEND + 952F CC A791 LDD #AAAAA+30 + 9532 FD 813F STD USKTOP + 9535 35 30 PULS X,Y + 9537 8C A773 CMPX #AAAAA + 953A 26 DA BNE STATU2 + * + 953C CC 0012 LDD #START-COLDS-3 + 953F FD 8001 STD COLDS+1 + 9542 17 FC78 LBSR INIT + 9545 17 FB44 LBSR GBC + 9548 16 EAB5 LBRA COLDS + * + * print opening messages + * + 954B 34 06 MSGOUT PSHS D + 954D 17 F032 LBSR MSG + 9550 EC E4 LDD ,S + 9552 AF E4 STX ,S + 9554 8E 8122 LDX #NX + 9557 ED 02 STD 2,X + 9559 6F 01 CLR 1,X + 955B 6F 84 CLR ,X + 955D 8D 05 BSR MSGOU1 + 955F 17 F04B LBSR TERPRI + 9562 35 90 PULS X,PC + * + 9564 86 D0 MSGOU1 LDA #-'0 + 9566 34 22 PSHS A,Y + 9568 108E 8126 LDY #NY + 956C 16 F0AA LBRA PRINN1 + * + * messages + * + 956F 0D 0A LSPMSG FCB CR,LF + 9571 2D 2D 2D 2D FCC /---------------------------------------------/,CR,LF + 9575 2D 2D 2D 2D + 9579 2D 2D 2D 2D + 957D 2D 2D 2D 2D + 9581 2D 2D 2D 2D + 9585 2D 2D 2D 2D + 9589 2D 2D 2D 2D + 958D 2D 2D 2D 2D + 9591 2D 2D 2D 2D + 9595 2D 2D 2D 2D + 9599 2D 2D 2D 2D + 959D 2D 0D 0A + 95A0 4C 49 53 50 FCC /LISP-09 Interpreter version 2.08 1983.10.07/,CR,LF + 95A4 2D 30 39 20 + 95A8 49 6E 74 65 + 95AC 72 70 72 65 + 95B0 74 65 72 20 + 95B4 20 76 65 72 + 95B8 73 69 6F 6E + 95BC 20 32 2E 30 + 95C0 38 20 20 31 + 95C4 39 38 33 2E + 95C8 31 30 2E 30 + 95CC 37 0D 0A + 95CF 20 20 43 6F FCC / Copyright (C) 1982 by Kogakuin University/,CR,LF + 95D3 70 79 72 69 + 95D7 67 68 74 20 + 95DB 28 43 29 20 + 95DF 31 39 38 32 + 95E3 20 62 79 20 + 95E7 4B 6F 67 61 + 95EB 6B 75 69 6E + 95EF 20 55 6E 69 + 95F3 76 65 72 73 + 95F7 69 74 79 0D + 95FB 0A + 95FC 2D 2D 2D 2D FCC /---------------------------------------------/,CR,LF + 9600 2D 2D 2D 2D + 9604 2D 2D 2D 2D + 9608 2D 2D 2D 2D + 960C 2D 2D 2D 2D + 9610 2D 2D 2D 2D + 9614 2D 2D 2D 2D + 9618 2D 2D 2D 2D + 961C 2D 2D 2D 2D + 9620 2D 2D 2D 2D + 9624 2D 2D 2D 2D + 9628 2D 0D 0A + 962B 23 20 6F 66 FCC /# of free cells : /,0 + 962F 20 66 72 65 + 9633 65 20 63 65 + 9637 6C 6C 73 20 + 963B 20 3A 20 00 + 963F 61 74 6F 6D FCC /atom area, used : /,0 + 9643 20 61 72 65 + 9647 61 2C 20 75 + 964B 73 65 64 20 + 964F 20 3A 20 00 + 9653 55 73 65 72 FCC /User stack area : /,0 + 9657 20 73 74 61 + 965B 63 6B 20 61 + 965F 72 65 61 20 + 9663 20 3A 20 00 + 9667 53 79 73 74 FCC /System stack area: /,0 + 966B 65 6D 20 73 + 966F 74 61 63 6B + 9673 20 61 72 65 + 9677 61 3A 20 00 + + + *-------------------------------------- + * + * ATOM INFORMATION TABLE + * + *-------------------------------------- + * + A000 ORG ATMTOP + * + * + * DATA FORMAT + * + * 0,1 : value of atom + * 2,3 : p-list + * 4,5 : function value ( expr or address ) + * 6 : function type + * 7--- : p-name ( terminater = 0 ) + * + * + * MACROES + * + OBJ MACRO + FDB &1,&2,&3 + FCB N&4 + FCC /&5/,0 + ENDM + * + FN MACRO + FDB UNDEFI,NIL,&1 + FCB N&2 + FCC /&1/,0 + ENDM + * + * + * + 0418 NIL EQU $418+HSHTOP + A000 OBJ NIL,NIL,FALSE,LSUBR,NIL + 0400 T EQU $400+HSHTOP + A00B OBJ T,NIL,TRUE,LSUBR,T + 012A UNDEFI EQU $12A+HSHTOP + A014 OBJ UNDEFI,NIL,ERRUND,ERR,undefined + A025 prompt OBJ COLON,NIL,ERRUND,0,PROMPT + 0200 COLON EQU $200+HSHTOP + A033 OBJ UNDEFI,NIL,ERRUND,0,: + 00AA LAMBDA EQU $0AA+HSHTOP + A03C OBJ UNDEFI,NIL,ERRUND,0,LAMBDA + 0142 EXPR EQU $142+HSHTOP + A04A OBJ UNDEFI,NIL,ERRUND,0,EXPR + 0146 FEXPR EQU $146+HSHTOP + A056 OBJ UNDEFI,NIL,ERRUND,0,FEXPR + 0468 MACRO EQU $468+HSHTOP + A063 OBJ UNDEFI,NIL,ERRUND,0,MACRO + * + 0692 QUOTE EQU $692+HSHTOP + A070 OBJ UNDEFI,NIL,CAR,FSUBR,QUOTE + * + A07D FN COLDS,SUBR + A08A FN WARMS,SUBR + A097 FN QUOTIENT,LSUBR + A0A7 FN TIMES,LSUBR + A0B4 FN DIFFERENCE,LSUBR + A0C6 FN PLUS,LSUBR + A0D2 FN MAX,LSUBR + A0DD FN MIN,LSUBR + A0E8 FN SIGN,SUBR + A0F4 FN ADD1,SUBR + A100 FN SUB1,SUBR + A10C FN ABS,SUBR + A117 FN MINUS,SUBR + A124 FN LOGAND,SUBR + A132 FN LOGOR,SUBR + A13F FN LOGXOR,SUBR + A14D FN REMAINDER,SUBR + A15E FN DIVIDE,SUBR + A16C FN GCD,SUBR + A177 FN RND,SUBR + A182 FN INC,FSUBR + A18D FN DEC,FSUBR + A198 FN CALL,SUBR + A1A4 FN POKE,SUBR + A1B0 FN PEEK,SUBR + A1BC FN ATOMLENGTH,SUBR + A1CE FN LENGTH,SUBR + A1DC FN ERROR,SUBR + A1E9 FN CRLF,SUBR + A1F5 FN SPACES,SUBR + A203 FN PRINT,SUBR + A210 FN TERPRI,SUBR + A21E FN LPRI,SUBR + A22A FN PRIN1,SUBR + A237 FN TYO,SUBR + A242 FN PRINH,SUBR + A24F FN TYI,SUBR + A25A FN READCH,SUBR + A268 FN GETCH,SUBR + A275 FN READ,SUBR + A281 FN IMPLODE,SUBR + A290 FN CONCAT,LSUBR + A29E FN EXPLODE,SUBR + A2AD OBJ UNDEFI,NIL,EXPLN,SUBR,EXPLODEN + A2BD FN ATOMCDR,SUBR + A2CC FN ATOMCAR,SUBR + A2DB FN ASCII,SUBR + A2E8 FN GENSYM,SUBR + A2F6 FN EVAL,SUBR + A302 OBJ UNDEFI,NIL,EVLIS+2,SUBR,EVLIS + A30F OBJ UNDEFI,NIL,EVBODY+2,SUBR,EVBODY + A31D FN COND,FSUBR + A329 FN MAPCAR,SUBR + A337 FN MAPCAN,SUBR + A345 FN MAPC,SUBR + A351 FN FUNCALL,LSUBR + A360 FN APPLY,SUBR + A36D FN DEFUN,FSUBR + A37A FN DE,FSUBR + A384 FN DF,FSUBR + A38E FN DM,FSUBR + A398 FN SET,SUBR + A3A3 FN SETQ,FSUBR + A3AF FN SETQQ,FSUBR + A3BC FN FVALUE,SUBR + A3CA FN PROPLIST,SUBR + A3DA FN GET,SUBR + A3E5 FN PUT,LSUBR + A3F0 FN CARMODE,SUBR + A3FF FN GBCMODE,SUBR + A40E FN ECHOMODE,SUBR + A41E FN PROG,FSUBR + A42A FN LOOP,FSUBR + A436 FN GO,FSUBR + A440 FN RETURN,SUBR + A44E FN PROGN,LSUBR + A45B FN PROG1,LSUBR + A468 FN PROG2,LSUBR + A475 FN CATCH,FSUBR + A482 FN THROW,FSUBR + A48F FN ALPHORDER,SUBR + A4A0 FN GREATERP,SUBR + A4B0 FN LESSP,SUBR + A4BD FN SYMBOLP,SUBR + A4CC FN NUMBERP,SUBR + A4DB FN ATOM,SUBR + A4E7 FN LISTP,SUBR + A4F4 FN EQ,SUBR + A4FE FN NULL,SUBR + A50A FN NOT,SUBR + A515 FN PLUSP,SUBR + A522 FN MINUSP,SUBR + A530 FN ONEP,SUBR + A53C FN ZEROP,SUBR + A549 FN EQUAL,SUBR + A556 FN MEMBER,SUBR + A564 FN ASSOC,SUBR + A571 FN MEMQ,SUBR + A57D FN ASSQ,SUBR + A589 FN CAAAR,SUBR + A596 FN CAADR,SUBR + A5A3 FN CADAR,SUBR + A5B0 FN CADDR,SUBR + A5BD FN CDAAR,SUBR + A5CA FN CDADR,SUBR + A5D7 FN CDDAR,SUBR + A5E4 FN CDDDR,SUBR + A5F1 FN CAAR,SUBR + A5FD FN CADR,SUBR + A609 FN CDAR,SUBR + A615 FN CDDR,SUBR + A621 FN CAR,SUBR + A62C FN CDR,SUBR + A637 FN LAST,SUBR + A643 FN REVERSE,SUBR + A652 FN COPY,SUBR + A65E FN APPEND,LSUBR + A66C FN NCONC,LSUBR + A679 FN AND,FSUBR + A684 FN OR,FSUBR + A68E FN RPLACA,SUBR + A69C FN RPLACD,SUBR + A6AA FN LIST,LSUBR + A6B6 FN OBLIST,SUBR + A6C4 FN POP,FSUBR + A6CF FN PUSH,FSUBR + A6DB FN CONS,SUBR + A6E7 FN GBC,SUBR + A6F2 FN MREAD,SUBR + A6FF FN MPRINT,SUBR + A70D FN LOAD,FSUBR + A719 FN OPENR,SUBR + A726 FN OPENW,SUBR + A733 FN CLOSER,SUBR + A741 FN CLOSEW,SUBR + A74F FN CLOSE,SUBR + A75C FN QUIT,SUBR + A768 FN DOS,FSUBR + * + * + * + A773 AAAAA EQU * + END COLDS + +0 ERROR(S) DETECTED + +SYMBOL TABLE: + +AAAAA A773 ABF 80B5 ABFL 0064 ABFP 811A ABS 820F +ADD1 81FE ADD11 8202 ALPHO1 8DCE ALPHOR 8DC6 AND 8FC3 +AND1 8FC7 APMACR 8B83 APPEN1 8F5E APPEND 8F5A APPLY 8B2E +APPLY0 8B2A APPLYL 8B89 APPXY 8F7A APSUB1 8B7B APSUB2 8B7E +APSUBR 8B70 ARITH 815B ARITH1 8164 ASCII 8937 ASSOC 8E9A +ASSOC0 8E97 ASSOC1 8EA8 ASSQ 8EC1 ASSQ0 8EBC ASSQ1 8ECE +ATMEND 813D ATMTOP A000 ATOM 8DF3 ATOMCA 88B9 ATOMCD 88AD +ATOML1 846A ATOMLE 845B BEL 0007 BIND 8A52 BIND1 8A57 +BIND2 8A75 BINDA 8A83 BINDA0 8A81 BINRTS 8A98 BLANK 85A3 +BS 0008 CAAAR 8ED0 CAADR 8ED4 CAAR 8ED6 CADAR 8EDA +CADDR 8EDE CADR 8EE0 CALFMS 948F CALL 8420 CAN 0018 +CAR 8EE2 CARERR 8EE7 CARMOD 8CBF CARRTS 8EF8 CARSW 8133 +CARX 8EF4 CATCH 8D59 CATCH1 8D8C CATCHL 8137 CATERR 8DA8 +CDAAR 8F00 CDADR 8F04 CDAR 8F06 CDDAR 8F0A CDDDR 8F0E +CDDR 8F10 CDR 8F12 CDRX 8EF9 CELBTM 8000 CELTOP 0800 +CLOSE 916D CLOSEI 91B4 CLOSEO 91B1 CLOSER 91B4 CLOSEW 91B1 +CLRABF 883F CLSI1 94C7 CLSIO 94CA CLSO1 94C2 COLDS 8000 +COLL1 910F COLL2 911E COLL3 9120 COLLCT 9105 COLON 0200 +CONCAT 8865 COND 8AB6 COND0 8AB2 CONS 9063 CONSN 9072 +CONSN1 9074 CONSU 9065 CONSUU 9067 COPY 8F33 COPY1 8F57 +CPYRTS 8F59 CR 000D CRLF 8587 CRLF1 858E DE 8BB3 +DE1 8BB6 DE2 8BB8 DE3 8BBA DEC 83F4 DEFUN 8B96 +DF 8BCD DF1 8BD0 DIFFER 814F DIV 828D DIV1 829C +DIV2 82A4 DIV3 82B5 DIV4 82D1 DIVIDE 825C DIVRTS 8315 +DM 8BD4 DM1 8BD7 DOCMND CD4B DODOS 91B7 DODOS1 94BB +DOS 919A ECHOMO 8CD7 ECHOSW 8132 EOUT 86CE EOUTB1 86CC +EOUTBS 86C4 EQ 8DFF EQUAL 8E60 EQUAL0 8E4D EQUAL1 8E6B +EQUAL2 8E6F EQUAL3 8E72 ERMRTS 8CCA ERR 84C2 ERRATM 8513 +ERRCAR 84E4 ERRCAT 84D1 ERRDE 8506 ERRGBC 84A0 ERRM 8480 +ERRMSA 84B1 ERRNUM 854A ERROR 84CD ERRPRG 84FF ERRPUT 855C +ERRS 8577 ERRSET 84F9 ERRSSK 848E ERRSTR 8523 ERRUND 8535 +ERRUSK 8497 ERRXY 8562 ESCRTN CC16 EVAL 897E EVAL1 899C +EVAL2 899F EVAL3 89A4 EVAL9 89CF EVALL 89D2 EVALL1 89E2 +EVALL2 89E0 EVBOD0 8AA2 EVBOD1 8AAF EVBODY 8AA7 EVEXP1 8A41 +EVEXP2 8A43 EVEXPR 8A3F EVFEXP 8A4D EVFSBR 896E EVLIS 89E8 +EVLIS1 8A11 EVLSB1 8A38 EVLSBR 8A36 EVMAC1 8978 EVMACR 8975 +EVSBR1 8A2F EVSUBR 8A14 EXPL1 8883 EXPL2 8898 EXPLN 8880 +EXPLOD 887B EXPR 0142 FALSE 8E0F FEXPR 0146 FF 000C +FILERR 949A FLBUF C080 FLBUFP CC14 FLEX CD03 FLEXIO 945F +FMS D406 FMSC 0004 FMSEOF 94A0 FMSR 0001 FMSRTS 94A4 +FMSW 0002 FREE 813B FUNCAL 8B20 FVALU1 8C45 FVALUE 8C22 +GBC 908C GBCMOD 8CCB GBCSW 8134 GBUF 811C GCD 826D +GCD1 8270 GENSY0 894E GENSY1 8954 GENSY2 8957 GENSY3 8965 +GENSYM 893F GET 8C55 GETCH 8674 GETFIL CD2D GETL1 8680 +GETL2 8686 GETL3 86A4 GETL4 86AD GETL5 86AF GETL6 86B6 +GETLIN 867A GMSG 912C GO 8D40 GOSW 8135 GREATE 8DDB +HSHBTM 0800 HSHTOP 0000 IBF 804E IBFL 0064 IBFP 80B3 +IMPLD1 8867 IMPLD2 8877 IMPLOD 8865 IN 86D6 IN1 86DB +IN2 86E5 INC 83DA INCHNE D3E5 INF 81A5 INFCB 9302 +INFV 841A INI1 94D4 INIT 91BD INITIO 8032 INITVA 8041 +INPUT 91A8 INPUT1 9450 INSW 9301 LAMBDA 00AA LAST 8F1E +LAST0 8F1A LENGT1 8476 LENGTH 8472 LESSP 8DDD LF 000A +LIST 899C LISTP 8DF9 LOAD 9155 LOGAND 821C LOGOR 822E +LOGXOR 8240 LOOP 8CFC LOOP1 8D09 LPRI 85C1 LPRI0 85B5 +LPRI1 85C9 LSPBTM 94DB LSPMSG 956F LSPTOP 8000 MACRO 0468 +MAKRTS 9104 MAPC 8B08 MAPC1 8B0A MAPCA1 8AE8 MAPCAN 8AEB +MAPCAR 8ACD MARK 90F4 MARK0 90E2 MARKS 90AD MARKS1 90B1 +MARKS2 90C2 MARKS3 90C4 MARKS4 90D0 MARKS5 90D6 MATM 878D +MATM1 87AB MATM2 87AD MATM3 87B3 MATM4 87C6 MATM5 87D2 +MAX 817A MAXRTS 83B4 MEMBE0 8E86 MEMBER 8E89 MEMQ 8EB3 +MEMQ0 8EB0 MEMRTS 8EBB MIN 8183 MINF 81AA MINFV 8412 +MINUS 8215 MINUS1 8217 MINUSP 8E23 MNA 81EE MNA0 81EC +MNAA 8440 MNAA1 844B MNAX 8454 MNAY 8452 MON 91BA +MONE 819B MONEV 841C MPRINT 914C MREAD 9145 MSA 88C3 +MSA1 88C9 MSA2 88DC MSA3 88EF MSA4 88D7 MSA5 88FA +MSA6 8912 MSAA 88BE MSG 8582 MSG0 857F MSGOU1 9564 +MSGOUT 954B MULT 8316 MULT1 8339 MULT2 8346 N0 0000 +N10 87FE N10A 87F1 N10A1 880A NADD 837F NASL 830D +NASL2 830B NASL3 8309 NASL4 8307 NCMP 839D NCONC 8F97 +NCONC1 8F9B NCONC2 8FB3 NCONC3 8FBC NCONC4 8FBF NCONC5 8FC1 +NERR 0007 NEW 9080 NEW0 907A NEXPR 0009 NFEXPR 000A +NFSUBR 0002 NIL 0418 NLSUBR 0003 NMACRO 000C NMAX 83A8 +NMAX1 83AC NMIN 83B5 NNEG 82F6 NNEGY 82E5 NOT 8E0A +NR 812C NSIGN 813A NSUB 838E NSUBR 0001 NULL 8E0A +NUMBER 8DEE NUMRTS 81EB NUMS 81AF NUMX 81BE NUMXY 81BC +NUMY 81D4 NX 8122 NY 8126 OBLIS1 9011 OBLIS2 901A +OBLIST 900A OLDCHR 8139 ONE 81A0 ONEP 8E32 ONEP1 8E38 +ONEV 8416 OP 8130 OPENFI 91AE OPENFO 91AB OPENR 9157 +OPENW 9162 OPNFI1 9479 OPNFIL 948D OPNFO1 9463 OR 8FE9 +OR0 8FDC OR1 8FEF OUT 8602 OUTCH D3F9 OUTFCB 91C1 +OUTPT1 9442 OUTPUT 91A5 OUTSW 91C0 PCRLF CD24 PEEK 843A +PLUS 8154 PLUS1 8157 PLUSP 8E14 POKE 842E POP 9024 +PRG1 8CF4 PRGRTS 8D3F PRIN1 85D6 PRIN2 85F0 PRINH 8643 +PRINH1 865E PRINH2 8654 PRINH4 8650 PRINN 8605 PRINN1 8619 +PRINN2 8632 PRINN3 8634 PRINT 85A7 PRIRTS 85A2 PROG 8CE3 +PROG1 8EE2 PROG2 8EE0 PROG9 8CE7 PROGN 8D54 PROGN0 8D4F +PROGS 8D14 PROGS1 8D30 PROGS2 8D3D PROPLI 8C48 PUSH 903E +PUT 8C6F PUT1 8CA7 PUTCHR CD18 PUTERR 8C72 QMSG 917B +QUIT 9171 QUOTE 0692 QUOTIE 8141 READ 86FE READA 8776 +READA0 8770 READA1 878A READCH 866F READG 8738 READR 8742 +READR1 8760 READR2 8762 READR3 876C READS 8819 READS0 8817 +REDRTS 876F REMAIN 8253 RETURN 8D49 REVER0 8F23 REVERS 8F2A +RND 83BA RNDV 840E RPLACA 8FF2 RPLACD 8FFE RPTERR CD3F +RTNSW 8136 SET 8BDB SET9 8C1F SETEXT CD33 SETQ 8C00 +SETQ0 8BEE SETQ1 8C06 SETQQ 8C13 SETQQ0 8C09 SETSTR 94A5 +SIGN 818C SKIP 86F3 SKIP0 86E9 SPACE1 859C SPACES 8595 +SSKBTM A000 START 8015 START1 8023 STARTU 94DB STATU0 94FC +STATU1 950C STATU2 9516 STORE0 885E STORE1 885C STOREA 884B +STORES 8860 STRING 8833 STSTR1 94AF SUB1 8209 SYMBOL 8DE7 +SYSDAT CC0E T 0400 TERPRI 85AD THROW 8D8E THROW1 8DBC +TIMES 8146 TIMES1 8149 TRUE 8E05 TSTCLC 87EE TSTDEC 87E7 +TSTHEX 87DC TSTRTS 87F0 TYI 866A TYO 863C UNBIN0 8A99 +UNBIND 8A9D UNDEFI 012A USKBTM C000 USKTOP 813F WARMS 8003 +WARMS1 8006 WARMS2 8009 XXXXX 94DB ZERO 8196 ZEROP 8E49 +ZEROV 8414 prompt A025 + + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/LISP09/LISP09.txt Wed May 12 12:57:20 2021 +0900 @@ -0,0 +1,3217 @@ + + + +*====================================== +* +* LISP-09 INTERPRETER +* vers.2.08 +* written by TERUO SERIZAWA +* 1982.11.04 +* 83.10.07 +* +*====================================== +* +* +* ADDRESS MAP +* +HSHTOP EQU $0000 +HSHBTM EQU HSHTOP+$800 +* atom hash table +* # of atoms : 1024 +* if contents=0 : undefined +* else : pointer to atom information table +* +CELTOP EQU HSHBTM +CELBTM EQU $8000 +* cell area ( lists and numbers ) +* # of cells : 7680 +* +LSPTOP EQU CELBTM +LSPBTM EQU XXXXX +* LISP-09 interpreter +* +* S stack is here +SSKBTM EQU $A000 +ATMTOP EQU SSKBTM +* atom information table +* +* ATMEND indicates table's end ( variable ) +* USKTOP indicates U stack's barrier ( variable ) +* ( [USKTOP] == [ATMEND] + 30 ) +* +* U stack is here +USKBTM EQU $C000 +* +* $C000-$FFFF FLEX SYSTEM +* + + +*-------------------------------------- +* +* MAIN PROGRAM +* +*-------------------------------------- +* + ORG LSPTOP +COLDS LBRA STARTU +WARMS LBRA WARMS2 +* +* unbind variables +* +WARMS1 LBSR UNBIND +WARMS2 CMPU USKTOP + BCS START + CMPU #USKBTM + BCS WARMS1 +* +* initialize system +* +START LDS #SSKBTM + LDU #USKBTM + BSR INITIO + BSR INITVA + LBSR TERPRI +* +* +* LISP system top level function +* +START1 LBSR READ + LEAX ,Y + LBSR EVAL + LEAX ,Y + LBSR PRINT + BRA START1 +* +* initialize I/O +* +INITIO LBSR CLOSE + CLR ECHOSW + CLR OLDCHR + LDX IBFP + CLR ,X + RTS +* +* initialize system variables +* +INITVA CLR GOSW + CLR RTNSW + LDX #NIL + STX CATCHL + RTS + +*-------------------------------------- +* +* CONSTANTS AND VARIABLES +* +*-------------------------------------- +* +* +* MACROES +* +TESTS MACRO + CMPS #LSPBTM+100 + LBCS ERRSSK + ENDM +* +TESTU MACRO + CMPU USKTOP + LBCS ERRUSK + ENDM +* +* +* ASCII CHARACTERS +* +BEL EQU $07 +BS EQU $08 +LF EQU $0A +FF EQU $0C +CR EQU $0D +CAN EQU $18 +* +* +* FUNCTION TYPES +* +N0 EQU 0 +NSUBR EQU 1 +NFSUBR EQU 2 +NLSUBR EQU 3 +NERR EQU 7 +NEXPR EQU 9 +NFEXPR EQU 10 +NMACRO EQU 12 +* +* +* SYSTEM VARIABLES +* +IBFL EQU 100 +IBF RMB IBFL + FCB 0 +IBFP FDB IBF +* +ABFL EQU 100 +ABF RMB ABFL + FCB 0 +ABFP FDB ABF +* +GBUF FCC /0000/ + FDB 0 +NX RMB 4 +NY RMB 4 + FDB 0 +NR RMB 4 +OP RMB 2 +* +ECHOSW FCB 0 +CARSW FCB 0 +GBCSW FCB 0 +GOSW FCB 0 +RTNSW FCB 0 +CATCHL FDB NIL +* +OLDCHR FCB 0 +NSIGN FCB 0 +* +FREE FDB NIL +ATMEND FDB AAAAA +USKTOP FDB AAAAA+30 + +*-------------------------------------- +* +* ARITHMETIC FUNCTIONS +* +*-------------------------------------- +*** +*** ( QUOTIENT n1 n2 ... ) +*** val <= n1 / n2 / ... +*** +QUOTIE LDD #DIV + BRA TIMES1 +*** +*** ( TIMES n1 n2 ... ) LSUBR +*** val <= n1 * n2 * ... +*** +TIMES LDD #MULT +TIMES1 TST ,X + BMI ONE + BRA ARITH +*** +*** ( DIFFERENCE n1 n2 ... ) LSUBR +*** val <= n1 - n2 - ... +*** +DIFFER LDD #NSUB + BRA PLUS1 +*** +*** ( PLUS n1 n2 ... ) LSUBR +*** val <= n1 + n2 + ... +*** +PLUS LDD #NADD +PLUS1 TST ,X + BMI ZERO +* +* execute arithmetic functions +* X : list of arguments +* +ARITH STD OP + PSHU X + LDX ,X + BSR NUMX +ARITH1 LDY ,U + LDY 2,Y + STY ,U + LDY ,Y + BMI MNA0 + BSR NUMY + JSR [OP] + BRA ARITH1 +*** +*** ( MAX n1 n2 ... ) LSUBR +*** val <= maximum value of numbers +*** +MAX LDD #NMAX + TST ,X + BMI MINF + BRA ARITH +*** +*** ( MIN n1 n2 ... ) LSUBR +*** val <= minimum value of numbers +*** +MIN LDD #NMIN + TST ,X + BMI INF + BRA ARITH +*** +*** ( SIGN n ) SUBR +*** if n>0 then val <= 1 +*** n=0 0 +*** n<0 -1 +*** +SIGN BSR NUMX + BMI MONE + BNE ONE + LDD 2,X + BNE ONE +* +* value <= 0 +* +ZERO LDX #ZEROV + BRA MNA +* +* value <= -1 +* +MONE LDX #MONEV + BRA MNA +* +* value <= 1 +* +ONE LDX #ONEV + BRA MNA +* +* value <= infinity ( largest number ) +* +INF LDX #INFV + BRA MNA +* +* value <= minus infinity ( smallest number ) +* +MINF LDX #MINFV + BRA MNA +* +* transpose numerical atom(s) into number register(s) +* +NUMS LBPL ERRNUM + ASRA + RORB + BITA #$20 + BNE NUMRTS + ANDA #$3F + RTS +* +NUMXY BSR NUMY +NUMX CMPX #CELTOP + LBCS ERRNUM + LDD 2,X + STD NX+2 + LDD ,X + BSR NUMS + LDX #NX + STD ,X + RTS +* +NUMY CMPY #CELTOP + LBCS ERRNUM + LDD 2,Y + STD NY+2 + LDD ,Y + BSR NUMS + LDY #NY + STD ,Y +NUMRTS RTS +* +* make numerical atom +* X : number register +* +MNA0 LEAU 2,U +* +MNA LBSR NEW + LDD ,X + ASLB + ROLA + ORA #$80 + STD ,Y + LDD 2,X + STD 2,Y + RTS +*** +*** ( ADD1 n ) SUBR +*** val <= n + 1 +*** +ADD1 LDY #ONEV +ADD11 BSR NUMX + LBSR NADD + BRA MNA +*** +*** ( SUB1 n ) SUBR +*** val <= n - 1 +*** +SUB1 LDY #MONEV + BRA ADD11 +*** +*** ( ABS n ) SUBR +*** val <= absolute value of n +*** +ABS BSR NUMX + BPL MNA + BRA MINUS1 +*** +*** ( MINUS n ) SUBR +*** val <= - n +*** +MINUS BSR NUMX +MINUS1 LBSR NNEG + BRA MNA +*** +*** ( LOGAND n1 n2 ) SUBR +*** logical <AND> operation +*** val <= n1 and n2 +*** +LOGAND BSR NUMXY + ANDA ,Y + ANDB 1,Y + STD ,X + LDD 2,X + ANDA 2,Y + ANDB 3,Y + STD 2,X + BRA MNA +*** +*** ( LOGOR n1 n2 ) SUBR +*** logical <OR> operation +*** val <= n1 or n2 +*** +LOGOR BSR NUMXY + ORA ,Y + ORB 1,Y + STD ,X + LDD 2,X + ORA 2,Y + ORB 3,Y + STD 2,X + BRA MNA +*** +*** ( LOGXOR n1 n2 ) SUBR +*** logical ,exclusive-OR> operation +*** val <= n1 xor n2 +*** +LOGXOR LBSR NUMXY + EORA ,Y + EORB 1,Y + STD ,X + LDD 2,X + EORA 2,Y + EORB 3,Y + STD 2,X + BRA MNA +*** +*** ( REMAINDER n1 n2 ) SUBR +*** val <= n1 mod n2 +*** +REMAIN LBSR NUMXY + BSR DIV + LEAX ,Y + BRA MNA +*** +*** ( DIVIDE n1 n2 ) SUBR +*** n1 / n2 +*** val <= dot pAir of quotient and remainder +*** +DIVIDE LBSR NUMXY + BSR DIV + BSR MNA + PSHU Y + LDX #NY + BSR MNA + LBRA CONSU +*** +*** ( GCD n1 n2 ) SUBR +*** greatest common divisor +*** val <= GCD ( n1, n2 ) +*** +GCD LBSR NUMXY +GCD1 LDD 2,Y + PSHS D + LDD ,Y + PSHS D + BSR DIV + PULS D + STD ,X + PULS D + STD 2,X + LDD 2,Y + BNE GCD1 + LDD ,Y + BNE GCD1 + LBRA MNA +* +* divide NX by NY +* NX <= NX / NY quotient +* NY <= NX mod NY remainder +* +DIV LEAS -8,S + LDD #30 + STD 4,S + LDA ,X + BPL DIV1 + INC 4,S + BSR NNEG +DIV1 LDA ,Y + BMI DIV2 + INC 4,S + BSR NNEGY +DIV2 LDD ,Y + STD ,S + LDD 2,Y + STD 2,S + LDD #0 + STD ,Y + STD 2,Y + BSR NASL3 +DIV3 ROL 3,Y + ROL 2,Y + ROL 1,Y + ROL ,Y + LDD 2,Y + ADDD 2,S + STD 6,S + LDD ,Y + ADCB 1,S + ADCA ,S + BCC DIV4 + STD ,Y + LDD 6,S + STD 2,Y +DIV4 ROL 3,X + ROL 2,X + ROL 1,X + ROL ,X + DEC 5,S + BNE DIV3 + DEC 4,S + LEAS 8,S + BEQ DIVRTS + BSR NNEG +* +* negate number +* Y : number register +* +NNEGY LDD #0 + SUBD 2,Y + STD 2,Y + LDD #0 + SBCB 1,Y + SBCA ,Y + STD ,Y + RTS +* +* negate number +* X : number register +* +NNEG LDD #0 + SUBD 2,X + STD 2,X + LDD #0 + SBCB 1,X + SBCA ,X + STD ,X + RTS +* +* arithmetic shift left +* X : number register +* +NASL4 BSR NASL +NASL3 BSR NASL +NASL2 BSR NASL +NASL ASL 3,X + ROL 2,X + ROL 1,X + ROL ,X +DIVRTS RTS +* +* multiply NX with NY +* NX <= NX * NY +* +MMM MACRO + LDA &1,S + LDB &2,Y + MUL + ENDM +* +MULT LDD 2,X + PSHS D + LDD ,X + PSHS D + MMM 3,3 + STD 2,X + MMM 2,2 + STD ,X + MMM 3,2 + ADDD 1,X + STD 1,X + BCC MULT1 + INC ,X +MULT1 MMM 2,3 + ADDD 1,X + STD 1,X + BCC MULT2 + INC ,X +MULT2 MMM 1,3 + ADDD ,X + STD ,X + MMM 3,1 + ADDD ,X + STD ,X + MMM 0,3 + ADDB ,X + STB ,X + MMM 1,2 + ADDB ,X + STB ,X + MMM 2,1 + ADDB ,X + STB ,X + MMM 3,0 + ADDB ,X + STB ,X + LEAS 4,S + RTS +* +* add numbers +* NX <= NX + NY +* +NADD LDD 2,X + ADDD 2,Y + STD 2,X + LDD ,X + ADCB 1,Y + ADCA ,Y + STD ,X + RTS +* +* subtract numbers +* NX <= NX - NY +* +NSUB LDD 2,X + SUBD 2,Y + STD 2,X + LDD ,X + SBCB 1,Y + SBCA ,Y + STD ,X + RTS +* +* compare numbers +* CCR <= NX - NY +* +NCMP LDD 2,X + SUBD 2,Y + LDD ,X + SBCB 1,Y + SBCA ,Y + RTS +* +* NX <= max ( NX, NY ) +* +NMAX BSR NCMP + BGE MAXRTS +NMAX1 LDD ,Y + STD ,X + LDD 2,Y + STD 2,X +MAXRTS RTS +* +* NX <= min ( NX, NY ) +* +NMIN BSR NCMP + BGE NMAX1 + RTS +*** +*** ( RND n ) SUBR +*** generate random number +*** val <= 0 .. n-1 +*** +RND LBSR NUMX + LDX #NR + LDY #RNDV + LBSR MULT + LDY #ONEV + BSR NADD + LEAY -2,X + LDX #NX + LBSR MULT + LEAX -2,X + LBRA MNA +*** +*** ( INC 'var ) FSUBR +*** increae value of var by 1 +*** (SETQ var (ADD1 var)) +*** +INC LDX ,X + LBMI ERROR + CMPX #CELTOP + LBCC ERRATM + LDX ,X + PSHS X + LDX ,X + LBSR ADD1 + STY [,S++] + RTS +*** +*** ( DEC 'var ) FSUBR +*** decrease value of var by 1 +*** (SETQ var (SUB1 var)) +*** +DEC LDX ,X + LBMI ERROR + CMPX #CELTOP + LBCC ERRATM + LDX ,X + PSHS X + LDX ,X + LBSR SUB1 + STY [,S++] + RTS +* +* numerical constants +* +RNDV FDB $0019,$660D +MINFV FDB $2000 +ZEROV FDB $0000 +ONEV FDB $0000,$0001 +INFV FDB $1FFF +MONEV FDB $FFFF,$FFFF +*** +*** ( CALL address ) SUBR +*** call subroutine +*** val <= NIL +*** +CALL LBSR NUMX + PSHS U + JSR [2,X] + LDY #NIL + PULS U,PC +*** +*** ( POKE address value(8) ) SUBR +*** store Value +*** val <= value +*** +POKE PSHS Y + LBSR NUMXY + LDA 3,Y + STA [2,X] + PULS Y,PC +*** +*** ( PEEK address ) SUBR +*** val <= memory value of address +*** +PEEK LBSR NUMX + LDA [2,X] +* +* make numerical atom ( A ) +* +MNAA PSHS A + LBSR NEW + PULS A + STA 3,Y + CLR 2,Y +MNAA1 CLR 1,Y + LDA #$80 + STA ,Y + RTS +* +* make numerical atom ( Y ) +* +MNAY LEAX ,Y +MNAX LBSR NEW + STX 2,Y + BRA MNAA1 +*** +*** ( ATOMLENGTH atom ) SUBR +*** val <= length of atom +*** +ATOMLE CMPX #CELTOP + LBCC ZERO + LDX ,X + LEAX 7,X + LDY #0 +ATOML1 LDA ,X+ + BEQ MNAY + LEAY 1,Y + BRA ATOML1 +*** +*** ( LENGTH list ) SUBR +*** val <= length of list +*** +LENGTH LDY #0 +LENGT1 LDA ,X + BMI MNAY + LDX 2,X + LEAY 1,Y + BRA LENGT1 + + +*-------------------------------------- +* +* ERRORS +* +*-------------------------------------- +* +ERRM FCB CR,LF,BEL + FCC /--ERROR-- /,0 +* +ERRSSK BSR ERR + FCC /S over/,0 +ERRUSK BSR ERR + FCC /U over/,0 +ERRGBC BSR ERR + FCC /Cell area over/,0 +ERRMSA BSR ERR + FCC /Atom area over/,0 +* +ERR LBSR ERRS + PULS X + LBSR MSG + LBRA WARMS +*** +*** ( ERROR e1 e2 ) SUBR +*** print e1 e2, goto top level +*** +ERROR LBSR ERRXY + FCB 0 +* +ERRCAT LBSR ERRXY + FCC /Catch and Throw/,0 +ERRCAR BSR ERRXY + FCC /Car or Cdr of atom/,0 +ERRSET BSR ERRXY + FCC /Set/,0 +ERRPRG BSR ERRXY + FCC /Prog/,0 +ERRDE BSR ERRXY + FCC /Definition/,0 +ERRATM BSR ERRXY + FCC /Atom expected/,0 +ERRSTR BSR ERRXY + FCC /String expected/,0 +ERRUND BSR ERRXY + FCC /Undefined Function/,0 +ERRNUM BSR ERRXY + FCC /Number expected/,0 +ERRPUT BSR ERRXY + FCC /Put/,0 +* +ERRXY PSHU X,Y + BSR ERRS + PULS X + BSR MSG + BSR TERPRI + PULU X + BSR PRINT + PULU X + BSR PRINT + LBRA WARMS +* +ERRS LBSR INITIO + LDX #ERRM + BRA MSG + +*-------------------------------------- +* +* OUTPUT +* +*-------------------------------------- +* +* print message +* X : top of message +* +MSG0 LBSR OUT +MSG LDA ,X+ + BNE MSG0 + RTS +*** +*** ( CRLF num(16) ) SUBR +*** print crlfs +*** val <= NIL +*** +CRLF LBSR NUMX + LDX 2,X + BEQ PRIRTS +CRLF1 BSR TERPRI + LEAX -1,X + BNE CRLF1 + RTS +*** +*** ( SPACES num(16) ) SUBR +*** print blanks +*** val <= NIL +*** +SPACES LBSR NUMX + LDX 2,X + BEQ PRIRTS +SPACE1 BSR BLANK + LEAX -1,X + BNE SPACE1 +PRIRTS RTS +* +* print blank +* +BLANK LDA #' + BRA OUT +*** +*** ( PRIANT e ) SUBR +*** print e, print crlf +*** val <= e +*** +PRINT PSHU X + BSR PRIN1 + PULU Y +*** +*** ( TERPRI ) SUBR +*** print crlf +*** val <= NIL +*** +TERPRI LDA #CR + BSR OUT + LDA #LF + BRA OUT +*** +*** ( LPRI e ) SUBR +*** print e without top level "(" and ")" +*** val <= NIL +*** +LPRI0 BSR PRIN1 + PULS X + LDX 2,X + LDA ,X + BMI LPRI1 + BSR BLANK +LPRI PSHS X + LDX ,X + BPL LPRI0 + PULS X +LPRI1 CMPX #NIL + BEQ PRIRTS + BSR BLANK + LDA #'. + BSR OUT + BSR BLANK +*** +*** ( PRIN1 e ) SUBR +*** print e +*** val <= NIL +*** +PRIN1 TESTS + CMPX #CELBTM + BCC PRIRTS + CMPX #CELTOP + BCC PRIN2 + LDX ,X + BPL PRIRTS + LEAX 7,X + BRA MSG +* +PRIN2 TFR X,D + BITB #3 + BNE PRIRTS + LDA ,X + BMI PRINN + LDA #'( + BSR OUT + BSR LPRI + LDA #') +* +* output a char in A +* +OUT LBRA OUTPUT +* +* print number ( decimal form ) +* +PRINN LDA #-'0 + PSHS A,Y + LDY #NY + LBSR NUMX + BPL PRINN1 + LDA #'- + BSR OUT + LBSR NNEG +PRINN1 LDD #10 + STD 2,Y + CLRB + STD ,Y + LBSR DIV + LDA 3,Y + PSHS A + LDD 2,X + BNE PRINN1 + LDD ,X + BNE PRINN1 + BRA PRINN3 +* +PRINN2 BSR OUT +PRINN3 PULS A + ADDA #'0 + BNE PRINN2 + PULS Y,PC +*** +*** ( TYO num(8) ) SUBR +*** output ASCII character +*** val <= NIL +*** +TYO LBSR NUMX + LDA 3,X + BRA OUT +*** +*** ( PRINH n ) SUBR +*** print number ( hex form ) +*** val <= NIL +*** +PRINH LBSR NUMX + LDA #'$ + BSR OUT + LDD ,X + BSR PRINH4 + LDD 2,X +PRINH4 BSR PRINH2 + TFR B,A +PRINH2 PSHS A + RORA + RORA + RORA + RORA + BSR PRINH1 + PULS A +PRINH1 ANDA #$0F + ADDA #'0 + CMPA #'9+1 + BCS OUT + ADDA #7 + BRA OUT + +*-------------------------------------- +* +* INPUT +* +*-------------------------------------- +*** +*** ( TYI ) SUBR +*** read a char +*** val <= ASCII code +*** +TYI BSR IN + LBRA MNAA +*** +*** ( READCH ) SUBR +*** read a char +*** val <= symbolic atom +*** +READCH BSR IN + LBRA MSAA +*** +*** ( GETCH ) SUBR +*** read char, direct input +*** val <= symbolic atom +*** +GETCH LBSR INPUT + LBRA MSAA +* +* read a line +* +GETLIN LDX prompt + LBSR PRIN1 +GETL1 LDX #IBF + STX IBFP +GETL2 LBSR INPUT + CMPA #BS + BEQ GETL3 + CMPA #CAN + BEQ GETL5 + CMPA #CR + BEQ GETL6 + CMPA #' + BCS GETL2 + STA ,X+ + BSR EOUT + CMPX #IBF+IBFL + BNE GETL2 + BRA IN1 +* +GETL3 CMPX #IBF + BEQ GETL2 + BSR EOUTBS + BRA GETL2 +* +GETL4 BSR EOUTBS +GETL5 CMPX #IBF + BNE GETL4 + BRA GETL2 +* +GETL6 STA ,X+ + CLR ,X + TST ECHOSW + BNE IN1 + LBSR TERPRI + BRA IN1 +* +* output back space +* +EOUTBS LEAX -1,X + BSR EOUTB1 + LDA #' + BSR EOUT +EOUTB1 LDA #BS +* +* output a char +* +EOUT TST ECHOSW + LBEQ OUT + RTS +* +* read a char in A +* +IN LDA OLDCHR + BNE IN2 +IN1 LDX IBFP + LDA ,X+ + BEQ GETLIN + STX IBFP +IN2 CLR OLDCHR + RTS +* +* skip blank ( cntr ) chars, char in A +* +SKIP0 BSR IN + CMPA #'; + BEQ SKIP + CMPA #CR + BNE SKIP0 +SKIP BSR IN + CMPA #' +1 + BCS SKIP + CMPA #'; + BEQ SKIP0 + RTS +*** +*** ( READ ) SUBR +*** read a expression +*** val <= expression +*** +READ TESTS + TESTU + LBSR CLRABF + BSR SKIP + CMPA #') + BEQ READ + CMPA #'] + BEQ READ + CMPA #'( + BEQ READR + CMPA #'[ + BEQ READG + CMPA #'" + LBEQ READS + CMPA #'' + BNE READA +* +* read quate +* + BSR READ + LBSR CONSN + LDX #QUOTE + LBRA CONS +* +* read right part +* +READG BSR READR + LDA OLDCHR + CMPA #'] + BEQ IN2 + RTS +* +READR BSR SKIP + LDY #NIL + CMPA #') + BEQ REDRTS + CMPA #'] + BEQ READR3 + CMPA #'. + BEQ READR1 + STA OLDCHR + BSR READ + PSHU Y + BSR READR + LBRA CONSU +* +READR1 BSR READ +READR2 BSR SKIP + CMPA #') + BEQ REDRTS + CMPA #'] + BNE READR2 +READR3 STA OLDCHR +REDRTS RTS +* +* read atom +* +READA0 LBSR STOREA + LBSR IN +READA CMPA #' +1 + BCS READA1 + CMPA #'( + BEQ READA1 + CMPA #'[ + BEQ READA1 + CMPA #') + BEQ READA1 + CMPA #'] + BNE READA0 +READA1 STA OLDCHR +* +* make atom ( input is number ??? ) +* +MATM LDX #NX + LDD #0 + STD 2,X + STD ,X + CLR NSIGN + LDY #ABF + LDA ,Y+ + CMPA #'+ + BEQ MATM1 + CMPA #'- + BNE MATM2 + INC NSIGN +MATM1 LDA ,Y+ +MATM2 CMPA #'$ + BNE MATM4 +* +* make hex number +* + LDA ,Y+ +MATM3 BSR TSTHEX + LBCC MSA + LBSR NASL4 + ADDA 3,X + STA 3,X + LDA ,Y+ + BNE MATM3 + BRA MATM5 +* +* make decimal number +* +MATM4 BSR TSTDEC + LBCC MSA + BSR N10A + LDA ,Y+ + BNE MATM4 +* +MATM5 LDA NSIGN + LBEQ MNA + LBRA MINUS1 +* +* char in ( 0..9, A..F ) ??? +* +TSTHEX CMPA #'A + BCS TSTDEC + CMPA #'G + BCC TSTRTS + ADDA #10-'A + RTS +* +* char in ( 0..9 ) ??? +* +TSTDEC SUBA #'0 + BCS TSTCLC + CMPA #10 + RTS +* +TSTCLC CLC +TSTRTS RTS +* +* NX <= NX * 10 + A +* +N10A PSHU A + BSR N10 + LDD #0 + PSHS D + PULU B + BRA N10A1 +* +N10 LBSR NASL + LDD ,X + PSHS D + LDD 2,X + LBSR NASL2 +N10A1 ADDD 2,X + STD 2,X + PULS D + ADCB 1,X + ADCA ,X + STD ,X + RTS +* +* read string +* +READS0 BSR STOREA +READS LBSR IN + CMPA #CR + LBEQ MSA + CMPA #'" + BNE READS0 + LBSR IN + CMPA #'" + BEQ READS0 + STA OLDCHR + LBRA MSA +* +* compute string address +* +STRING CMPX #CELTOP + LBCC ERRSTR + LDX ,X + LEAX 7,X + RTS +* +* clear atom buffer +* +CLRABF PSHS X + LDX #ABF + STX ABFP + CLR ,X + PULS X,PC +* +* store a char into Atom buffer +* +STOREA PSHS X + LDX ABFP + STA ,X+ + CMPX #ABF+ABFL + BEQ STORE1 + STX ABFP + CLR ,X +STORE1 PULS X,PC +* +* store chars into atom buffer +* X : POINTER +* +STORE0 BSR STOREA +STORES LDA ,X+ + BNE STORE0 + RTS +*** +*** ( IMPLODE list_of _atom ) SUBR +*** val <= connected atom +*** +*** +*** ( CONCAT atom1 atoM2 ... ) LSUBR +*** val <= connected atom +*** +CONCAT EQU * +IMPLOD BSR CLRABF +IMPLD1 PSHU X + LDX ,X + BMI IMPLD2 + BSR STRING + BSR STORES + PULU X + LDX 2,X + BRA IMPLD1 +IMPLD2 LEAU 2,U + BRA MSA +*** +*** ( EXPLODE atom ) SUBR +*** val <= list of chars +*** +EXPLOD LDD #MSAA + BRA EXPL1 +*** +*** ( EXPLODEN atom ) SUBR +*** val <= list of ascii codes +*** +EXPLN LDD #MNAA +EXPL1 STD OP + BSR STRING + TESTU + TESTS +EXPL2 LDA ,X+ + LBEQ FALSE + PSHS X + JSR [OP] + PULS X + PSHU Y + BSR EXPL2 + LBRA CONSU +*** +*** ( ATOMCDR atom ) SUBR +*** val <= butfirst chars of atom +*** +ATOMCD BSR STRING + BSR CLRABF + LDA ,X+ + BEQ MSA + BSR STORES + BRA MSA +*** +*** ( ATOMCAR atom ) SUBR +*** val <= first char of atom +*** +ATOMCA LBSR STRING + LDA ,X +* +* make single char atom (A ) +* +MSAA LBSR CLRABF + BSR STOREA +* +* make symbolic atom +* +MSA LDX #ABF + LDD #0 +MSA1 TST ,X + BEQ MSA2 + LSRA + RORB + LSRA + RORB + LSRA + RORB + EORA ,X+ + BRA MSA1 +* +MSA4 PULS D + ADDD #2 +MSA2 ANDA #$07 + ANDB #$FE + ADDD #HSHTOP + PSHS D + LDY #ABF + LDX [,S] + BEQ MSA5 + LEAX 7,X +MSA3 LDA ,X+ + CMPA ,Y+ + BNE MSA4 + TSTA + BNE MSA3 + PULS Y,PC +* +* create new atom +* +MSA5 LEAX -10,U + PSHS X + LDX ATMEND + LDD #UNDEFI + STD ,X++ + LDD #NIL + STD ,X++ + LDD #ERRUND + STD ,X++ + CLR ,X+ +MSA6 CMPX ,S + LBCC ERRMSA + LDA ,Y+ + STA ,X+ + BNE MSA6 + LDD ATMEND + STD [2,S] + STX ATMEND + LEAX 30,X + STX USKTOP + TESTU + PULS D,Y,PC +*** +*** ( ASCII n ) SUBR +*** val <= syumbolic atom +*** +ASCII LBSR NUMX + LDA 3,X + LBRA MSAA +*** +*** ( GENSYM [atom] ) SUBR +*** generate symbolic atom +*** val <= atom +*** +GENSYM LBSR CLRABF + CMPX #NIL + BNE GENSY0 + LDA #'G + LBSR STOREA + BRA GENSY1 +GENSY0 LBSR STRING + LBSR STORES +GENSY1 LDX #GBUF+4 +GENSY2 INC ,-X + LDA ,X + CMPA #'9+1 + BNE GENSY3 + LDA #'0 + STA ,X + BRA GENSY2 +GENSY3 LDX #GBUF + LBSR STORES + LBRA MSA + + +*-------------------------------------- +* +* EVALUATION +* +*-------------------------------------- +* +* EVAL - FSUBR +* +EVFSBR LDX 2,X + LDY #NIL + RTS +* +* EVAL - MACRO +* +EVMACR LDY 2,X +EVMAC1 PULS X + BSR EVALL1 + LEAX ,Y +*** +*** ( EVAL e ) SUBR +*** val <= value of e +*** +EVAL TESTS + TESTU + LDY ,X + BPL EVAL3 + CMPX #CELTOP + BCC EVAL1 + LDY ,Y + RTS +EVAL1 LEAY ,X + RTS +EVAL2 LEAS 2,S + LDY ,Y +EVAL3 CMPY #CELTOP + BCC EVALL + LDY ,Y + LDD 4,Y + PSHS D + LDA 6,Y + BEQ EVAL2 + CMPA #NSUBR + BEQ EVSUBR + CMPA #NFSUBR + BEQ EVFSBR + CMPA #NLSUBR + BEQ EVLSBR + CMPA #NEXPR + BEQ EVEXPR + CMPA #NFEXPR + LBEQ EVFEXP + CMPA #NMACRO + BEQ EVMACR +EVAL9 LBRA ERRUND +* +* EVAL - LAMBDA +* +EVALL PSHU Y + LDD ,Y + CMPD #LAMBDA + BNE EVAL9 + BSR EVLIS + PULU X +EVALL2 LDX 2,X +EVALL1 PSHS X + LDX ,X + BRA EVEXP2 +*** +*** ( EVLIS list ) SUBR +*** evaluate each element of list +*** val <= list of values +*** +EVLIS LDX 2,X + PSHU X + LDX ,X + BMI EVLIS1 + BSR EVAL + LDX ,U + STY ,U + LDX 2,X + PSHU X + LDX ,X + LBMI CONSUU + LBSR EVAL + LDX ,U + STY ,U + BSR EVLIS + LBSR CONSU + LBRA CONSU +EVLIS1 PULU Y + RTS +* +* EVAL - SUBR +* +EVSUBR LDX 2,X + PSHU X + LDX ,X + BMI EVSBR1 + LBSR EVAL + LDX ,U + STY ,U + LDX [2,X] + BMI EVSBR1 + LBSR EVAL + PULU X + RTS +EVSBR1 PULU X + LDY #NIL + RTS +* +* EVAL - LSBUR +* +EVLSBR BSR EVLIS +EVLSB1 LEAX ,Y + LDY #NIL + RTS +* +* EVAL - EXPR +* +EVEXPR BSR EVLIS +EVEXP1 LDX [,S] +EVEXP2 BMI EVAL9 + BSR BIND + PULS X + BSR EVBODY + BRA UNBIND +* +* EVAL - FEXPR +* +EVFEXP LDY 2,X + BRA EVEXP1 +* +* bind varables +* X : variable(s) +* Y : argument(s) +* +BIND LDD #NIL + PSHU D +BIND1 TESTU + PSHS X,Y + LDX ,X + BMI BINDA0 + LDY ,Y + BMI BIND2 + BSR BINDA + PULS X,Y + LDX 2,X + LDY 2,Y + BRA BIND1 +BIND2 LDY #NIL + BSR BINDA + PULS X,Y + LDX 2,X + BRA BIND1 +* +* bind atom +* +BINDA0 PULS X,Y +BINDA CMPX #CELTOP + BCC BINRTS + CMPX #NIL + BEQ BINRTS + LDX ,X + LDD ,X + PSHU D + PSHU X + STY ,X +BINRTS RTS +* +* unbind variables +* +UNBIN0 PULU D + STD ,X +UNBIND LDX ,U++ + BMI UNBIN0 + RTS +*** +*** ( EVBODY list ) SUBR +*** evaluate each element of list +*** val <= last element +*** +EVBOD0 LBSR EVAL + PULU X +EVBODY LDX 2,X + PSHU X + LDX ,X + BPL EVBOD0 +EVBOD1 PULU X + RTS +*** +*** ( COND clause1 clause2 ... ) FSUBR +*** val <= result or NIL +*** +COND0 PULU X + LDX 2,X +COND PSHU X + LDX ,X + BMI EVBOD1 + LDX ,X + BMI COND0 + LBSR EVAL + CMPY #NIL + BEQ COND0 + LDX [,U++] + BRA EVBODY +*** +*** ( MAPCAR fn list ) SUBR +*** val <= list of values +*** +MAPCAR PSHU X,Y + LDX ,Y + BMI MAPCA1 + LBSR CONSN1 + LDX ,U + BSR APPLY + TFR Y,D + PULU X,Y + LDY 2,Y + PSHU D + BSR MAPCAR + LBRA CONSU +* +MAPCA1 PULU X,Y + RTS +*** +*** ( MAPCAN fn list ) SUBR +*** val <= appended list of values +*** +MAPCAN PSHU X,Y + LDX ,Y + BMI MAPCA1 + LBSR CONSN1 + LDX ,U + BSR APPLY + TFR Y,D + PULU X,Y + LDY 2,Y + PSHU D + BSR MAPCAN + PULU X + LBRA APPXY +*** +*** ( MAPC fn list ) SUBR +*** val <= NIL +*** +MAPC PSHU X,Y +MAPC1 LDX ,Y + BMI MAPCA1 + LBSR CONSN1 + LDX ,U + BSR APPLY + LDY 2,U + LDY 2,Y + STY 2,U + BRA MAPC1 +*** +*** ( FUNCALL fn arg! ... ) LSUBR +*** evaluate function +*** val <= value of function +*** +FUNCALL LDY 2,X + LDX ,X + BPL APPLY + LBRA ERROR +*** +*** ( APPLY fn list ) SUBR +*** evaluate function, argument are list +*** val <= value of function +*** +APPLY0 LEAS 2,S + LDX ,X +APPLY TESTS + TESTU + CMPX #CELTOP + BCC APPLYL + LDX ,X + LDD 4,X + PSHS D + LDA 6,X + BEQ APPLY0 + CMPA #NSUBR + BEQ APSUBR + CMPA #NFSUBR + LBEQ EVLSB1 + CMPA #NLSUBR + LBEQ EVLSB1 + CMPA #NEXPR + LBEQ EVEXP1 + CMPA #NFEXPR + LBEQ EVEXP1 + CMPA #NMACRO + BEQ APMACR + LBRA ERRUND +* +* APPLY - SUBR +* +APSUBR LDX ,Y + BMI APSUB1 + LDY [2,Y] + BMI APSUB2 + RTS +APSUB1 LDX #NIL +APSUB2 LDY #NIL + RTS +* +* APPLY - MACRO +* +APMACR LBSR CONS + LBRA EVMAC1 +* +* APPLY - LAMBDA +* +APPLYL LDD ,X + CMPD #LAMBDA + LBNE ERRUND + LBRA EVALL2 + + +*-------------------------------------- +* +* PROPERTY +* +*-------------------------------------- +*** +*** ( DEFUN 'fn ['type] 'args 'body ) FSUBR +*** define function +*** val <= fn +*** +DEFUN LDY ,X + LDX 2,X + LDD ,X + CMPD #EXPR + BEQ DE1 + CMPD #FEXPR + BEQ DF1 + CMPD #MACRO + BEQ DM1 + LDA #NEXPR + BRA DE3 +*** +*** ( DE 'fn 'args 'body ) FSUBR +*** define EXPR function +*** val <= fn +*** +DE LDY ,X +DE1 LDA #NEXPR +DE2 LDX 2,X +DE3 CMPY #CELTOP + LBCC ERRDE + PSHS Y + LDY ,Y + STA 6,Y + STX 4,Y + PULS Y,PC +*** +*** ( DF 'fn 'args 'body ) FSUBR +*** define FEXPR function +*** val <= fn +*** +DF LDY ,X +DF1 LDA #NFEXPR + BRA DE2 +*** +*** ( DM 'fn 'args 'body ) FSUBR +*** define MACRO function +*** val <= fn +*** +DM LDY ,X +DM1 LDA #NMACRO + BRA DE2 +*** +*** ( SET atom value ) SUBR +*** give value to symbolic atom +*** val <= value +*** +SET CMPX #CELTOP + BCC SET9 + CMPX #NIL + BEQ SET9 + CMPX #T + BEQ SET9 + STY [,X] + RTS +*** +*** ( SETQ 'atom1 value1 ... ) FSUBR +*** val <= last value +*** +SETQ0 LDX [2,X] + BMI SET9 + LBSR EVAL + LDX [,U] + BSR SET + PULU X + LDX 2,X + LDX 2,X +SETQ PSHU X + LDA ,X + BPL SETQ0 +SETQ1 LEAU 2,U + RTS +*** +*** ( SETQQ 'atom1 'value1 ... ) FSUBR +*** val <= last value +*** +SETQQ0 LDX ,X + BSR SET + PULU X + LDX 2,X + LDX 2,X +SETQQ PSHU X + LDA ,X + BMI SETQ1 + LDY [2,X] + BPL SETQQ0 +SET9 LBRA ERRSET +*** +*** ( FVALUE atom ) SUBR +*** val <= function values of atom ( list or number ) +*** +FVALUE CMPX #CELTOP + LBCC ERRATM + LDX ,X + LDY 4,X + LDA 6,X + LDX #EXPR + CMPA #NEXPR + LBCS MNAY + BEQ FVALU1 + LDX #FEXPR + CMPA #NFEXPR + BEQ FVALU1 + LDX #MACRO +FVALU1 LBRA CONS +*** +*** ( PROPLIST atom ) SUBR +*** val <= p-list of atom +*** +PROPLI CMPX #CELTOP + LBCC ERRATM + LDX ,X + LDY 2,X + RTS +*** +*** ( GET atom ind ) SUBR +*** get property of symbolic atom +*** val <= property or NIL +*** +GET CMPX #CELTOP + LBCC ERRATM + LDX ,X + LDX 2,X + EXG X,Y + LBSR ASSOC + CMPY #NIL + BEQ ERMRTS + LDY 2,Y + RTS +*** +*** ( PUT atom ind e ) LSUBR +*** add property +*** val <= e +*** +PUT LDY ,X +PUTERR LBMI ERRPUT + LDX 2,X + LDD ,X + BMI PUTERR + LDX 2,X + LDX ,X + BMI PUTERR + CMPY #CELTOP + LBCC ERRATM + LDY ,Y + LEAY 2,Y + PSHS X,Y + LDY ,Y + TFR D,X + LBSR ASSOC + CMPY #NIL + BEQ PUT1 + PULS X + STX 2,Y + LEAY ,X + PULS D,PC +* +PUT1 LDY ,S + LBSR CONS + LEAX ,Y + LDY [2,S] + LBSR CONS + STY [2,S] + LDY ,S + PULS D,X,PC +*** +*** ( CARMODE e ) SUBR +*** if e = NIL then disable (CAR atom) +*** else enable +*** val <= NIL +*** +CARMOD CLR CARSW + CMPX #NIL + BNE ERMRTS + INC CARSW +ERMRTS RTS +*** +*** ( GBCMODE e ) SUBR +*** if e = NIL then disable message +*** else enable +*** val <= NIL +*** +GBCMODE CLR GBCSW + CMPX #NIL + BEQ ERMRTS + INC GBCSW + RTS +*** +*** ( ECHOMODE e ) SUBR +*** if e = NIL then disable echoback +*** else enable +*** val <= NIL +*** +ECHOMO CLR ECHOSW + CMPX #NIL + BNE ERMRTS + INC ECHOSW + RTS + + +*-------------------------------------- +* +* PROG AND LOOP +* +*-------------------------------------- +*** +*** ( PROG 'args 'body ) FSUBR +*** val <= value of RETURN or NIL +*** +PROG PSHS X + LDX ,X +PROG9 LBMI ERRPRG + LBSR BIND + PULS X + PSHU X + BSR PROGS +PRG1 CLR RTNSW + LEAU 2,U + LBRA UNBIND +*** +*** ( LOOP 'args 'body ) FSUBR +*** val <= value of RETURN +*** +LOOP PSHS X + LDX ,X + BMI PROG9 + LBSR BIND + PULS X + PSHU X +LOOP1 LDX ,U + BSR PROGS + LDA RTNSW + BEQ LOOP1 + BRA PRG1 +* +* +* +PROGS LDX 2,X + PSHU X + LDX ,X + BMI PROGS2 + LBSR EVAL + PULU X + LDA RTNSW + BNE PRGRTS + LDA GOSW + BEQ PROGS + CLR GOSW + LDX ,U +PROGS1 LDX 2,X + LDA ,X + BMI PROG9 + CMPY ,X + BNE PROGS1 + BRA PROGS +PROGS2 PULU Y +PRGRTS RTS +*** +*** ( GO 'label ) FSUBR +*** val <= label +*** +GO INC GOSW + LDY ,X + BMI PROG9 + RTS +*** +*** ( RETURN value ) SUBR +*** val <= value +*** +RETURN INC RTNSW + LEAY ,X + RTS +*** +*** ( PROGN e1 e2 ... ) LSUBR +*** val <= last e +*** +PROGN0 LDY ,X + LDX 2,X +PROGN LDA ,X + BPL PROGN0 + RTS +*** +*** ( PROG1 e1 e2 ... ) LSUBR +*** val <= e1 +*** +PROG1 EQU CAR +*** +*** ( PROG2 e1 e2 ... ) LSUBR +*** val <= e2 +*** +PROG2 EQU CADR +*** +*** ( CATCH e1 'tag ) FSUBR +*** val <= value of e1 or THROWed value +*** +CATCH PSHS U + PSHU X + LEAX ,S + LBSR MNAX + LEAX ,Y + LDY CATCHL + LBSR CONS + LDX ,U + LDA ,X + BMI CATERR + LDX [2,X] + BMI CATERR + LBSR CONS + STY CATCHL + LDX [,U++] + LBSR EVAL + LDX CATCHL + LDX 2,X + LDX 2,X + STX CATCHL +CATCH1 PULS U,PC +*** +*** ( THROW value 'tag ) FSUBR +*** val <= value +*** +THROW PSHU X + LDX ,X + BMI CATERR + LBSR EVAL + LDX ,U + STY ,U + LDX [2,X] + BMI CATERR + LDY CATCHL + LBSR MEMBER +CATERR LBNE ERRCAT + LDX 2,Y + LDY 2,X + STY CATCHL + LDX ,X + LEAS [2,X] + PULU Y +THROW1 CMPU ,S + BEQ CATCH1 + LBSR UNBIND + BRA THROW1 + + +*-------------------------------------- +* +* PREDICATES +* +*-------------------------------------- +*** +*** ( ALPHORDER atom1 atom2 ) SUBR +*** val <= T or NIL +*** +ALPHOR LBSR STRING + EXG X,Y + LBSR STRING +ALPHO1 LDA ,X+ + CMPA ,Y+ + BCS FALSE + BNE TRUE + TSTA + BNE ALPHO1 + BRA TRUE +*** +*** ( GREATERP n1 n2 ) SUBR +*** n1 > n2 ??? +*** val <= T or NIL +*** +GREATE EXG X,Y +*** +*** ( LESSP n1 n2 ) SUBR +*** n1 < n2 ??? +*** val <= T or NIL +*** +LESSP LBSR NUMXY + LBSR NCMP + BGE FALSE + BRA TRUE +*** +*** ( SYMBOLP e ) SUBR +*** e is symbol ??? +*** val <= T or NIL +*** +SYMBOL CMPX #CELTOP + BCC FALSE + BRA TRUE +*** +*** ( NUMBERP e ) SUBR +*** e is number ??? +*** val <= T or NIL +***+ +NUMBER CMPX #CELTOP + BCS FALSE +*** +*** ( ATOM e ) SUBR +*** e is atom ??? +*** val <= T or NIL +*** +ATOM LDA ,X + BPL FALSE + BRA TRUE +*** +*** ( LSITP e ) SUBR +*** e Is list ??? +*** val <= T or NIL +*** +LISTP LDA ,X + BPL TRUE + BRA FALSE +*** +*** ( EQ e1 e2 ) SUBR +*** e1 = e2 ??? +*** val <= T or NIL +*** +EQ PSHU Y + CMPX ,U++ + BNE FALSE +TRUE LDY #T + RTS +*** +*** ( NULL e ) SUBR +*** ( NOT e ) SUBR +*** e is NIL ??? +*** val <= T or NIL +*** +NULL EQU * +NOT CMPX #NIL + BEQ TRUE +FALSE LDY #NIL + RTS +*** +*** ( PLUSP e ) SUBR +*** e >= 0 ??? +*** val <= T or NIL +*** +PLUSP CMPX #CELTOP + BCS FALSE + LDA ,X + BPL FALSE + BITA #$40 + BEQ TRUE + BRA FALSE +*** +*** ( MINUSP e ) SUBR +*** e < 0 ??? +*** val <= T or NIL +*** +MINUSP CMPX #CELTOP + BCS FALSE + LDA ,X + BPL FALSE + BITA #$40 + BNE TRUE + BRA FALSE +*** +*** ( oneP e ) SUBR +*** e = 1 ??? +*** +ONEP LDD 2,X + CMPD #1 +ONEP1 BNE FALSE + CMPX #CELTOP + BCS FALSE + LDD ,X + CMPD #$8000 + BEQ TRUE + BRA FALSE +*** +*** ( ZEROP e ) SUBR +*** e = 0 ??? +*** val <= T or NIL +*** +ZEROP LDD 2,X + BRA ONEP1 +*** +*** ( EQUAL e1 e2 ) SUBR +*** compare e1 with e2 +*** val <= T or NIL +*** zero flag is set ( T ) +*** +EQUAL0 TESTS + BSR EQUAL + BNE EQUAL2 + PULS X,Y + LDX 2,X + LDY 2,Y +EQUAL PSHS X,Y + LDX ,X + BMI EQUAL3 + LDY ,Y + BPL EQUAL0 +EQUAL1 LDY #NIL +EQUAL2 LEAS 4,S + RTS +* +EQUAL3 CMPX ,Y + BNE EQUAL1 + LDX ,S + LDX 2,X + CMPX 2,Y + BNE EQUAL1 + LDY #T + CLRA + LEAS 4,S + RTS +*** +*** ( MEMBER e list ) SUBR +*** e is top listevel element of 1 ??? +*** val <= sublist or NIL +*** +MEMBE0 LDY 2,Y +MEMBER PSHS X,Y + LDY ,Y + BMI EQUAL1 + BSR EQUAL + PULS X,Y + BNE MEMBE0 + RTS +*** +*** ( ASSOC e a-list ) SUBR +*** search e +*** val <= element or NIL +*** +ASSOC0 LDY 2,Y +ASSOC PSHS X,Y + LDY ,Y + BMI EQUAL1 + LDY ,Y + BMI ASSOC1 + BSR EQUAL +ASSOC1 PULS X,Y + BNE ASSOC0 + LDY ,Y + RTS +*** +*** ( MEMQ obj list ) SUBR +*** obj is top level element of list ??? +*** ( uses EQ instead of EQUAL ) +*** val <= sublist or NIL +*** +MEMQ0 LDY 2,Y +MEMQ CMPX ,Y + BEQ MEMRTS + LDA ,Y + BPL MEMQ0 +MEMRTS RTS +*** +*** ( ASSQ obj a-list ) SUBR +*** search obj +*** ( uses EQ instead of EQUAL ) +*** val <= element or NIL +*** +ASSQ0 PULS Y + LDY 2,Y +ASSQ PSHS Y + LDY ,Y + BMI ASSQ1 + CMPX ,Y + BNE ASSQ0 + PULS X,PC +ASSQ1 PULS Y,PC + + +*-------------------------------------- +* +* LIST FUNCTIONS +* +*-------------------------------------- +*** +*** ( C..R e ) SUBR +*** ( C..R e ) " +*** ( CAR e ) " +*** ( CDR e ) " +*** +CAAAR BSR CARX + BRA CAAR +CAADR BSR CDRX +CAAR BSR CARX + BRA CAR +CADAR BSR CARX + BRA CADR +CADDR BSR CDRX +CADR BSR CDRX +CAR LDY ,X + BPL CARRTS +CARERR LDA CARSW + LBNE ERRCAR + LDX #NIL + LEAY ,X + RTS +* +CARX LDX ,X + BMI CARERR +CARRTS RTS +* +CDRX LDA ,X + BMI CARERR + LDX 2,X + RTS +* +CDAAR BSR CARX + BRA CDAR +CDADR BSR CDRX +CDAR BSR CARX + BRA CDR +CDDAR BSR CARX + BRA CDDR +CDDDR BSR CDRX +CDDR BSR CDRX +CDR LDA ,X + BMI CARERR + LDY 2,X + RTS +*** +*** ( LAST list ) SUBR +*** val <= list of last element of list +*** +LAST0 LEAY ,X + LDX 2,X +LAST LDA ,X + BPL LAST0 + RTS +*** +*** ( REVERSE list ) SUBR +*** val <= reversed list +*** +REVER0 LBSR CONS + PULU X + LDX 2,X +REVERS PSHU X + LDX ,X + BPL REVER0 + LEAU 2,U + RTS +*** +*** ( COPY e ) SUBR +*** val <= copy of e +*** +COPY TESTS + TESTU + PSHU X + LDX ,X + BMI COPY1 + BSR COPY + LDX ,U + STY ,U + LDX 2,X + BSR COPY + LBRA CONSU +COPY1 PULU Y +CPYRTS RTS +*** +*** ( APPEND 11 12 ... ) LSUBR +*** val <= connected list +*** +APPEND LDD ,X + BMI CPYRTS +APPEN1 PSHU D + LDX 2,X + LDD ,X + BMI COPY1 + TESTU + TESTS + BSR APPEN1 + PULU X +* +* append X to Y +* +APPXY LDD ,X + BMI CPYRTS + PSHU D + LDX 2,X + TESTS + TESTU + BSR APPXY + LBRA CONSU +*** +*** ( NCONC 11 12 ... ) LSUBR +*** val <= append list, use RPLACD +*** +NCONC LDD ,X + BMI CPYRTS +NCONC1 PSHS D + LDX 2,X + LDD ,X + BMI NCONC4 + TESTS + BSR NCONC1 + LDX ,S + LDA ,X + BMI NCONC5 +NCONC2 LDA [2,X] + BMI NCONC3 + LDX 2,X + BRA NCONC2 +NCONC3 STY 2,X +NCONC4 PULS Y,PC +NCONC5 PULS D,PC +*** +*** ( AND 'e1 'e2 ... ) FSUBR +*** search NIL +*** val <= NIL or last e +*** +AND LDY #T +AND1 PSHU X + LDX ,X + BMI OR1 + LBSR EVAL + CMPY #NIL + BEQ OR1 + PULU X + LDX 2,X + BRA AND1 +*** +*** ( OR 'e1 'e2 ... ) FSUBR +*** search non-NIL +*** val <= non-NIL or NIL +*** +OR0 LBSR EVAL + CMPY #NIL + BNE OR1 + PULU X + LDX 2,X +OR PSHU X + LDX ,X + BPL OR0 +OR1 LEAU 2,U + RTS +*** +*** ( RPLACA l e ) SUBR +*** replace car of l with e +*** val <= 1 +*** +RPLACA LDA ,X + LBMI ERROR + STY ,X + LEAY ,X + RTS +*** +*** ( RPLACD l e ) SUBR +*** replace cdr of l with e +*** val <= l +*** +RPLACD LDA ,X + LBMI ERROR + STY 2,X + LEAY ,X + RTS +*** +*** ( LIST e1 e2 ... ) LSUBR +*** val <= list of e1 ... +*** +LIST EQU EVAL1 +*** +*** ( DBLIST ) SUBR +*** val <= list of atoms +*** +OBLIST LDY #NIL + LDX #HSHTOP +OBLIS1 PSHS X + LDD ,X + BEQ OBLIS2 + LBSR CONS +OBLIS2 PULS X + LEAX 2,X + CMPX #HSHBTM + BNE OBLIS1 + RTS +*** +*** ( POP 'var ) FSUBR +*** (PROG1 (CAR var) (SETQ var (CDR var))) +*** +POP LDX ,X + CMPX #CELTOP + LBCC ERROR + LDX ,X + LDY ,X + LDD 2,Y + LDY ,Y + LBMI ERRCAR + STD ,X + RTS +*** +*** ( PUSH item 'var ) FSUBR +*** (SETQ var (CONS item var)) +*** +PUSH PSHU X + LDX ,X + LBMI ERROR + LBSR EVAL + PULU X + LDX [2,X] + CMPX #CELTOP + LBCC ERROR + LDX ,X + PSHS X + LDX ,X + EXG X,Y + BSR CONS + STY [,S++] + RTS + + +*-------------------------------------- +* +* GARBAGE COLLECTION +* +*-------------------------------------- +*** +*** ( CONS e1 e2 ) SUBR +*** val <= list +*** +CONS PSHU X +CONSU PSHU Y +CONSUU BSR NEW + PULU D + STD 2,Y + PULU D + STD ,Y + RTS +* +CONSN LEAX ,Y +CONSN1 LDY #NIL + BRA CONS +* +* get a free cell ( address in Y ) +* +NEW0 PSHS X + BSR GBC + PULS X +NEW LDY FREE + LDD ,Y + BMI NEW0 + STD FREE + RTS +*** +*** ( GBC ) SUBR +*** garbage collection +*** val <= # of collected cells +*** +GBC PSHS U,CC + ORCC #$50 + BSR MARKS + BSR COLLCT + TFR U,X + PULS U,CC + CMPX #3 + LBCS ERRGBC + LBSR MNAX + LDX #GMSG + LDA GBCSW + LBNE MSG + RTS +* +* mark used cells +* +MARKS LDY #ATMTOP +MARKS1 LDX ,Y++ + BSR MARK + LDX ,y++ + BSR MARK + LDX ,Y + CMPX #CELBTM + BCC MARKS2 + BSR MARK +MARKS2 LEAY 3,Y +MARKS3 LDA ,Y+ + BNE MARKS3 + CMPY ATMEND + BCS MARKS1 + BRA MARKS5 +* +MARKS4 LDX ,U++ + BMI MARKS5 + BSR MARK +MARKS5 CMPU #USKBTM + BCS MARKS4 + LDX CATCHL + BSR MARK + RTS +* +* mark list ( X ) +* +MARK0 PSHS X + CMPS #LSPBTM+30 + LBCS QUIT + TFR D,X + BSR MARK + PULS X + LDX 2,X +MARK CMPX #CELTOP + BCS MAKRTS + LDD ,X + BITB #1 + BNE MAKRTS + INC 1,X + TSTA + BPL MARK0 +MAKRTS RTS +* +* collect frdd cells +* +COLLCT LDX #CELTOP + LDY #NIL + LDU #0 +COLL1 LDB 1,X + BITB #1 + BNE COLL2 + STY ,X + LEAY ,X + LEAU 1,U + BRA COLL3 +COLL2 DEC 1,X +COLL3 LEAX 4,X + CMPX #CELBTM + BCS COLL1 + STY FREE + RTS +* +* +GMSG FCC /--Garbage Collection--/,CR,LF,0 + + +*-------------------------------------- +* +* DISK I/O +* +*-------------------------------------- +*** +*** ( MREAD filename ) SUBR +*** read s-expr from DISK +*** val <= s-expr +*** +MREAD BSR OPENR open file + LBSR READ read s-expr + BRA CLOSEI close file +*** +*** ( MPRINT filename expr ) SUBR +*** write expr into DISK file +*** val <= expr +*** +MPRINT BSR OPENW open output file + LEAX ,Y + LBSR PRINT print expr + BRA CLOSEO close file +*** +*** ( LOAD 'filename ) FSUBR +*** load programs +*** val <= NIL +*** +LOAD LDX ,X +*** +*** ( OPENR filename ) SUBR +*** open input file +*** val <= NIL +*** +OPENR PSHS X + BSR CLOSEI close input file + PULS X + LBSR STRING + BRA OPENFI open input file +*** +*** ( OPENW filename ) SUBR +*** open output file +*** val <= NIL +*** +OPENW PSHS X + BSR CLOSEO close output file + PULS X + LBSR STRING + BRA OPENFO open output file +*** +*** ( CLOSER ) SUBR +*** close read file +*** val <= NIL +*** +CLOSER EQU CLOSEI +*** +*** ( CLOSEW ) SUBR +*** close write file +*** val <= NIL +*** +CLOSEW EQU CLOSEO +*** +*** ( CLOSE ) SUBR +*** close I/O files +*** val <= NIL +*** +CLOSE BSR CLOSEI + BRA CLOSEO +*** +*** ( QUIT ) SUBR +*** terminate lisp, return to monitor +*** +QUIT BSR CLOSE close any open files + LDX #QMSG + LBSR MSG print message + BRA MON +* +QMSG FCC CR,LF + FCC /may the force be with you!/ + FCB CR,LF,0 +*** +*** ( DOS 'command ) FSUBR +*** execute DOS command +*** val <= NIL +*** +DOS LDX ,X + LBSR STRING + PSHS Y,U + BSR DODOS + PULS Y,U,PC + + +*************************************** +* +* LISP-09 I/O DRIVERS +* 1982.9.21 +* +*************************************** +* +* JUMP TABLE +* +OUTPUT LBRA OUTPT1 +* output char in A to terminal ( OUTSW = 0 ) or +* disk (OUTSW <> 0 ) +* +INPUT LBRA INPUT1 +* input char from terminal ( INSW = 0 ) or disk +* ( INSW <> 0 ) without echo +* +OPENFO LBRA OPNFO1 +* open file for output +* X = filename pointer ( terminater = 0 ) +* +OPENFI LBRA OPNFI1 +* open file for input +* X = filename pointer +* +CLOSEO LBRA CLSO1 +* close output file +* +CLOSEI LBRA CLSI1 +* close input file +* +DODOS LBRA DODOS1 +* execute DOS command +* X = pointer to DOS command string +* +MON JMP FLEX +* return to FLEX +* +INIT LBRA INI1 +* initialize system +* +********** +* +* SYSTEM ADDRESSES +* +FLEX EQU $CD03 FLEX warm start entry +OUTCH EQU $D3F9 output char ( pointer ) +INCHNE EQU $D3E5 input char ( pointer ) +PUTCHR EQU $CD18 put character +FMS EQU $D406 FMS call +PCRLF EQU $CD24 output crlf +GETFIL EQU $CD2D get file specification +SETEXT EQU $CD33 set extension +RPTERR EQU $CD3F report error message +DOCMND EQU $CD4B call DOS as a subroutine +FLBUF EQU $C080 FLEX input line buffer +FLBUFP EQU $CC14 FLEX line buffer pointer +ESCRTN EQU $CC16 escape return register +SYSDAT EQU $CC0E system date register +* +* FMS functions +* +FMSR EQU 1 : read command +FMSW EQU 2 : write command +FMSC EQU 4 : close command +* +* FILE CONTROL BLOCKS +* +OUTSW FCB 0 output file switch +OUTFCB RMB 320 output file FCB +INSW FCB 0 input file switch +INFCB RMB 320 input file FCB +* +* +OUTPT1 PSHS B,X,Y + LDX #OUTSW + TST ,X+ + BNE FLEXIO + JSR PUTCHR + PULS B,X,Y,PC +* +INPUT1 PSHS B,X,Y + LDX #INSW + TST ,X+ + BNE FLEXIO + JSR [INCHNE] + PULS B,X,Y,PC +* +FLEXIO BSR CALFMS + PULS B,X,Y,PC +* +OPNFO1 BSR SETSTR + LDX #OUTFCB + JSR GETFIL + BCS FILERR + LDA #1 + STA OUTSW + JSR SETEXT + LDA #FMSW + BRA OPNFIL +* +OPNFI1 BSR SETSTR + LDX #INFCB + JSR GETFIL + BCS FILERR + LDA #1 + STA INSW + JSR SETEXT + LDA #FMSR +OPNFIL STA ,X +CALFMS JSR FMS + BEQ FMSRTS + LDA 1,X + CMPA #8 + BEQ FMSEOF +FILERR JSR RPTERR + LBRA WARMS +FMSEOF BSR CLSI1 + LDA #CR +FMSRTS RTS +* +SETSTR PSHS Y + LDY #FLBUF + STY FLBUFP +STSTR1 LDA ,X+ + STA ,Y+ + BNE STSTR1 + LDA #CR + STA ,-Y + PULS Y,PC +* +DODOS1 BSR SETSTR + JSR DOCMND + BRA INI1 +* +CLSO1 LDX #OUTSW + BRA CLSIO +* +CLSI1 LDX #INSW +CLSIO TST ,X + BEQ FMSRTS + CLR ,X+ + LDA #FMSC + BRA OPNFIL +* +INI1 LDD #WARMS + STD ESCRTN + RTS + + +*-------------------------------------- +* +* START UP INITIALIZATION +* +*-------------------------------------- +* +XXXXX EQU * +* +* +STARTU LDS #SSKBTM + LDU #USKBTM + LDX #LSPMSG + LDD #(CELBTM-CELTOP)/4 + BSR MSGOUT + LDD #AAAAA-ATMTOP + BSR MSGOUT + LDD #USKBTM-AAAAA + BSR MSGOUT + LDD #SSKBTM-LSPBTM + BSR MSGOUT +* + LDX #HSHTOP +STATU0 CLR ,X+ + CMPX #HSHBTM + BNE STATU0 + LDX #CELTOP + LDD #NIL + STD FREE +STATU1 STD ,X++ + CMPX #CELBTM + BNE STATU1 +* + LDX #ATMTOP +STATU2 PSHS X + LEAX 7,X + LBSR CLRABF + LBSR STORES + PSHS X + LBSR MSA + LDX 2,S + STX ,Y + LDD #AAAAA + STD ATMEND + LDD #AAAAA+30 + STD USKTOP + PULS X,Y + CMPX #AAAAA + BNE STATU2 +* + LDD #START-COLDS-3 + STD COLDS+1 + LBSR INIT + LBSR GBC + LBRA COLDS +* +* print opening messages +* +MSGOUT PSHS D + LBSR MSG + LDD ,S + STX ,S + LDX #NX + STD 2,X + CLR 1,X + CLR ,X + BSR MSGOU1 + LBSR TERPRI + PULS X,PC +* +MSGOU1 LDA #-'0 + PSHS A,Y + LDY #NY + LBRA PRINN1 +* +* messages +* +LSPMSG FCB CR,LF + FCC /---------------------------------------------/,CR,LF + FCC /LISP-09 Interpreter version 2.08 1983.10.07/,CR,LF + FCC / Copyright (C) 1982 by Kogakuin University/,CR,LF + FCC /---------------------------------------------/,CR,LF + FCC /# of free cells : /,0 + FCC /atom area, used : /,0 + FCC /User stack area : /,0 + FCC /System stack area: /,0 + + +*-------------------------------------- +* +* ATOM INFORMATION TABLE +* +*-------------------------------------- +* + ORG ATMTOP +* +* +* DATA FORMAT +* +* 0,1 : value of atom +* 2,3 : p-list +* 4,5 : function value ( expr or address ) +* 6 : function type +* 7--- : p-name ( terminater = 0 ) +* +* +* MACROES +* +OBJ MACRO + FDB &1,&2,&3 + FCB N&4 + FCC /&5/,0 + ENDM +* +FN MACRO + FDB UNDEFI,NIL,&1 + FCB N&2 + FCC /&1/,0 + ENDM +* +* +* +NIL EQU $418+HSHTOP + OBJ NIL,NIL,FALSE,LSUBR,NIL +T EQU $400+HSHTOP + OBJ T,NIL,TRUE,LSUBR,T +UNDEFI EQU $12A+HSHTOP + OBJ UNDEFI,NIL,ERRUND,ERR,undefined +prompt OBJ COLON,NIL,ERRUND,0,PROMPT +COLON EQU $200+HSHTOP + OBJ UNDEFI,NIL,ERRUND,0,: +LAMBDA EQU $0AA+HSHTOP + OBJ UNDEFI,NIL,ERRUND,0,LAMBDA +EXPR EQU $142+HSHTOP + OBJ UNDEFI,NIL,ERRUND,0,EXPR +FEXPR EQU $146+HSHTOP + OBJ UNDEFI,NIL,ERRUND,0,FEXPR +MACRO EQU $468+HSHTOP + OBJ UNDEFI,NIL,ERRUND,0,MACRO +* +QUOTE EQU $692+HSHTOP + OBJ UNDEFI,NIL,CAR,FSUBR,QUOTE +* + FN COLDS,SUBR + FN WARMS,SUBR + FN QUOTIENT,LSUBR + FN TIMES,LSUBR + FN DIFFERENCE,LSUBR + FN PLUS,LSUBR + FN MAX,LSUBR + FN MIN,LSUBR + FN SIGN,SUBR + FN ADD1,SUBR + FN SUB1,SUBR + FN ABS,SUBR + FN MINUS,SUBR + FN LOGAND,SUBR + FN LOGOR,SUBR + FN LOGXOR,SUBR + FN REMAINDER,SUBR + FN DIVIDE,SUBR + FN GCD,SUBR + FN RND,SUBR + FN INC,FSUBR + FN DEC,FSUBR + FN CALL,SUBR + FN POKE,SUBR + FN PEEK,SUBR + FN ATOMLENGTH,SUBR + FN LENGTH,SUBR + FN ERROR,SUBR + FN CRLF,SUBR + FN SPACES,SUBR + FN PRINT,SUBR + FN TERPRI,SUBR + FN LPRI,SUBR + FN PRIN1,SUBR + FN TYO,SUBR + FN PRINH,SUBR + FN TYI,SUBR + FN READCH,SUBR + FN GETCH,SUBR + FN READ,SUBR + FN IMPLODE,SUBR + FN CONCAT,LSUBR + FN EXPLODE,SUBR + OBJ UNDEFI,NIL,EXPLN,SUBR,EXPLODEN + FN ATOMCDR,SUBR + FN ATOMCAR,SUBR + FN ASCII,SUBR + FN GENSYM,SUBR + FN EVAL,SUBR + OBJ UNDEFI,NIL,EVLIS+2,SUBR,EVLIS + OBJ UNDEFI,NIL,EVBODY+2,SUBR,EVBODY + FN COND,FSUBR + FN MAPCAR,SUBR + FN MAPCAN,SUBR + FN MAPC,SUBR + FN FUNCALL,LSUBR + FN APPLY,SUBR + FN DEFUN,FSUBR + FN DE,FSUBR + FN DF,FSUBR + FN DM,FSUBR + FN SET,SUBR + FN SETQ,FSUBR + FN SETQQ,FSUBR + FN FVALUE,SUBR + FN PROPLIST,SUBR + FN GET,SUBR + FN PUT,LSUBR + FN CARMODE,SUBR + FN GBCMODE,SUBR + FN ECHOMODE,SUBR + FN PROG,FSUBR + FN LOOP,FSUBR + FN GO,FSUBR + FN RETURN,SUBR + FN PROGN,LSUBR + FN PROG1,LSUBR + FN PROG2,LSUBR + FN CATCH,FSUBR + FN THROW,FSUBR + FN ALPHORDER,SUBR + FN GREATERP,SUBR + FN LESSP,SUBR + FN SYMBOLP,SUBR + FN NUMBERP,SUBR + FN ATOM,SUBR + FN LISTP,SUBR + FN EQ,SUBR + FN NULL,SUBR + FN NOT,SUBR + FN PLUSP,SUBR + FN MINUSP,SUBR + FN ONEP,SUBR + FN ZEROP,SUBR + FN EQUAL,SUBR + FN MEMBER,SUBR + FN ASSOC,SUBR + FN MEMQ,SUBR + FN ASSQ,SUBR + FN CAAAR,SUBR + FN CAADR,SUBR + FN CADAR,SUBR + FN CADDR,SUBR + FN CDAAR,SUBR + FN CDADR,SUBR + FN CDDAR,SUBR + FN CDDDR,SUBR + FN CAAR,SUBR + FN CADR,SUBR + FN CDAR,SUBR + FN CDDR,SUBR + FN CAR,SUBR + FN CDR,SUBR + FN LAST,SUBR + FN REVERSE,SUBR + FN COPY,SUBR + FN APPEND,LSUBR + FN NCONC,LSUBR + FN AND,FSUBR + FN OR,FSUBR + FN RPLACA,SUBR + FN RPLACD,SUBR + FN LIST,LSUBR + FN OBLIST,SUBR + FN POP,FSUBR + FN PUSH,FSUBR + FN CONS,SUBR + FN GBC,SUBR + FN MREAD,SUBR + FN MPRINT,SUBR + FN LOAD,FSUBR + FN OPENR,SUBR + FN OPENW,SUBR + FN CLOSER,SUBR + FN CLOSEW,SUBR + FN CLOSE,SUBR + FN QUIT,SUBR + FN DOS,FSUBR +* +* +* +AAAAA EQU * + END COLDS
--- a/TL1/TL1os9.asm Mon Apr 15 14:21:00 2019 +0900 +++ b/TL1/TL1os9.asm Wed May 12 12:57:20 2021 +0900 @@ -70,6 +70,8 @@ ** LIBR equ . ioentry rmb $80 +memds equ ioentry +membuf equ ioentry+1 readbuff rmb bufsiz+1 OBJSTART RMB 10 @@ -405,7 +407,7 @@ LBEQ EXPR CMPA #$A3 seekr LBEQ EXPR - CMPA #$A4 position + CMPA #$A4 tell LBEQ EXPR SSEND1 COM SSW RTS @@ -1145,7 +1147,7 @@ FDB RND RTS * FUNTION GET -TM61 CMPA #$71 +TM61 CMPA #$71 get BNE TM62 LBSR SUBSC LBSR PUTHS @@ -1156,7 +1158,7 @@ FDB getchar RTS * FUNCTION READ etc -TM62 CMPA #$72 +TM62 CMPA #$72 read BNE TM63 LBSR SUBSC LBSR PUTHS @@ -1176,7 +1178,7 @@ BNE TM65 LBSR DSUBSC bra tmm3 -TM65 CMPA #$A4 position +TM65 CMPA #$A4 tell BNE TM66 LBSR DSUBSA tstb @@ -1184,15 +1186,17 @@ bra aradr TM66 CMPA #$A5 open BNE TM67 - LBSR DSUBSC - bra tmm3 + LBSR DSUBSA + tstb + beq tmm3 + bra aradr TM67 CMPA #$A6 openm BNE TM7 LBSR DSUBSA tstb beq tmm3 bra aradr -* ; pshs u; leau ?,[xy] ; stu <tm1 ; puls u +* ; pshs u; leau ?,[xy] aradr LBSR PUTHS FCB 2,$34,$40 ldb VAL @@ -1202,7 +1206,7 @@ addb #$20 aradr1 LBSR PUTAB LBSR PUTHS - FCB 4,$DF,WT1,$35,$40 + FCB 6,$DF,WT1,$35,$40,$97,INDN ; stu <wt1 ; puls u LBSR WORD LDA #$3B ')' LBSR CHECK @@ -1211,7 +1215,7 @@ FDB NONE RTS tmm3 LBSR PUTHS - FCB 6,$35,$04,$D7,WT2,$0F,WT1 ; puls b ; stb <tm2; clr <tm1 + FCB 9,$35,$04,$97,INDN,$1F,$23,$4f,$dd,WT1 ; puls b ; stb <INDN ; tfr a,b ; clra ; std <wt1 bra tmm4 * FUNCTION NOT ASL ET AL @@ -1722,8 +1726,8 @@ FCC "EEK" FCB $A3,-'S' FCC "EEKR" - FCB $A4,-'P' - FCC "OSITION" + FCB $A4,-'T' + FCC "ELL" FCB $A5,-'O' FCC "PEN" FCB $A6,-'O' @@ -1907,7 +1911,25 @@ os9 F$Exit * no return - +** +** memory buffer io +** +** ioentry +bufptr equ 0 +buftop equ 2 +bufend equ 4 +** +** openm size wt1 +** return io number > 0x1f +MEMBUF eq 0x20 +** +** seek postion wt1 +** seekr relative postion in A +** tell put position in wt1 +** +** putca +** getca +** close err ldb #1 L0049 @@ -1919,11 +1941,38 @@ PSHS X,Y BRA OUTCH1 -close +close pshs x,y,u lda <INDN else get path + bita #MEMBUF + bne memclose os9 I$Close and close it bcs L0049 branch if error - rts + puls x,y,u,pc +memclose + suba #MEMBUF + lsla + lsla + lsla + leax membuf,u + leax a,x + clr ,x+ + clr ,x + puls x,y,u,pc + +seek pshs x,y,u + puls x,y,u,pc + +seekr pshs x,y,u + puls x,y,u,pc + +tell pshs x,y,u + puls x,y,u,pc + +fopen pshs x,y,u + puls x,y,u,pc + +mopen pshs x,y,u + puls x,y,u,pc MEMIN PSHS A,B,X,Y
--- a/TL1/test/t4.tl1 Mon Apr 15 14:21:00 2019 +0900 +++ b/TL1/test/t4.tl1 Wed May 12 12:57:20 2021 +0900 @@ -2,15 +2,15 @@ FUNC SEARCH %--- MAIN --- VAR DICT,BUF -ARRAY TEND[2] +ARRAY TEND[1] BEGIN - POSITION(DICT,TEND) + TELL(DICT,TEND) DICT := OPENM($2,0) WRITE(DICT:ASCII(0)) WRITE(DICT:ASCII(30),ASCII(-'P'),"ROC") WRITE(DICT:ASCII(31),ASCII(-'F'),"UNC") WRITE(DICT:ASCII(33),ASCII(-'V'),"AR",CRLF) - POSITION(DICT,TEND) + TELL(DICT,TEND) BUF := OPENM($2,0) WRITE(BUF:"FUNC",ASCII(0)) WRITE(0:SEARCH(BUF),CRLF) @@ -21,10 +21,10 @@ SEARCH(BUF) VAR VAL,K,C -ARRAY BEND +ARRAY BEND[1] BEGIN VAL := SEEK(DICT,TEND) - POSITION(BUF,BEND) + TELL(BUF,BEND) WHILE VAL#0 DO [ C:=SEEKR(BUF,-1) K:=SEEKR(DICT,-1)
--- a/TL1/tl1.html Mon Apr 15 14:21:00 2019 +0900 +++ b/TL1/tl1.html Wed May 12 12:57:20 2021 +0900 @@ -519,7 +519,7 @@ </table> <h4> Relational operator </h4> -<p> Compares two values and returns a boolean value. <span class = 'reserved'> GT </span> and <span class = 'reserved'> LT </span> compare and compare left and right numbers as signed binary numbers in 2's complement representation. Other operators interpret numbers as unsigned binary. </p> +<p> Compares two values and returns a boolean value. <span class = 'reserved'> GT </span> and <span class = 'reserved'> LT </span> compare and compare left and right numbers as signed binary numbers in 2's complement representation. Other operators interpret numbers as unsigned binary. </p> <table> <tr> <td> > </td> <td> large </td> </tr> <tr> <td> < </td> <td> small </td> </tr>