view LISP09/LISP09.txt @ 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
children d9dbd943db21
line wrap: on
line source




*======================================
*
*  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