Permalink
Switch branches/tags
Nothing to show
Find file Copy path
d536b22 Sep 17, 2018
1 contributor

Users who have contributed to this file

13451 lines (12893 sloc) 205 KB
;-*-MIDAS-*-
.NLIST SEQ
.ENABL LC
.TITLE APPLE-LOGO
; LOGO Language Interpreter for the Apple-II-Plus Personal Microcomputer
; Written and developed by Stephen L. Hain, Patrick G. Sobalvarro,
; and the M.I.T. LOGO Group, at the Massachusetts Institute of
; Technology.
; Property of the M.I.T. LOGO Laboratory,
; 545 Technology Square, Cambridge, MA 02139.
; All rights reserved.
.PAGE
.SBTTL Assembly Data
; Page Zero Variables:
LNIL =0 ;The NIL node
PRECED =4 ;Current function's precedence
NARGS =5 ;No. of arguments for current function
EXPOUT =6 ;Output expected if nonzero
OTPUTN =7 ;Number of outputs given
EDSW =8 ;Edit mode if nonzero
GRPHCS =9 ;Indicates graphics mode if nonzero
CHBUFS =10 ;Character buffer next-free-loc pointer
RUNFLG =11 ;Evaluating the RUN primitive if nonzero
STPFLG =12 ;Stop executing current Ufun if nonzero
DCOFLG =13 ;Return from current break-loop if nonzero
FUNTYP =14 ;Typecode of current function
UFRMAT =15 ;Format (List or Fpack) of current Ufun
ERRFLG =16 ;Error code of last error
RETADR =17 ;Holds stack pointer reset value for error recovery
ERRRET =18 ;Holds program counter reset value for error recovery
SP =20 ;Stack pointer
VSP =22 ;Value-stack pointer
SIZE1 =24 ;Size of area pointed to by AREA1
SIZE2 =26 ;Size of area pointed to by AREA2
AREA1 =28 ;Pointer to g.c.-protected area of SIZE1 contiguous nodes
AREA2 =30 ;Pointer to g.c.-protected area of SIZE2 contiguous nodes
; Monitor variables:
WNDLFT =32
WNDWTH =33
WNDTOP =34
WNDBTM =35
CH =36
CV =37
;DOS wants 38,39
BASLIN =40
BSLTMP =42
;DOS wants 42,43,44,45,46,47
MODE =49
INVFLG =50
;DOS wants 51
DSPFL1 =51
YSAV =52
YSAV1 =53 ;(DOS wants 53,54,55,56,57)
CSWL =54
CSWH =55
KSWL =56
KSWH =57
PCL =58
PCH =59
A1L =60
A1H =61
A2L =62 ;(DOS wants 62,63,64,65,66,67,68,69,70,71,72)
A2H =63
A3L =64
A3H =65
A4L =66
A4H =67
A5L =68
A5H =69
ACC =69
XREG =70
YREG =71
STATUS =72
SPNT =73
;(DOS wants 74,75,76,77)
LTRUE =78 ;TRUE atom pointer
LFALSE =80 ;FALSE atom pointer
RANDOM =82 ;Random number
MONFLG =84 ;Flag indicates Monitor mode (if non-zero)
BANK4K =85 ;High-RAM 4K bank select flag (0=first, 1=second)
PRDFLG =86 ;Indicates READ_LINE is executing, for CONS
INDEV =87 ;Input device code (zero is Apple standard I/O)
OUTDEV =88 ;Output device code (zero is Apple standard I/O)
SOBLST =89 ;Pointer to start of System Object List
SOBTOP =91 ;Pointer to end of System Object List
SARTOP =93 ;Pointer to end of System Array
FRLIST =95 ;Pointer to start of Freelist
TOKPTR =97 ;Token Pointer
CURTOK =99 ;Curent Token pointer
NEXTOK =101 ;Next Token pointer
FUNCT =103 ;Points to current Function
TEMPX3 =105 ;Temporary variable
FRAME =107 ;Pointer to current stack frame
XFRAME =109 ;Pointer to end of current stack frame
FBODY =111 ;Pointer to full body of current Ufun
FBODY1 =113 ;Current Ufun body or System index
LINNUM =115 ;Current Ufun line number
FPTR =117 ;Pointer to remainder of Ufun being executed
GOPTR =119 ;Pointer to location of Ufun line to GO to
ULNEND =121 ;Pointer to end of current line of Fpack Ufun
LEVNUM =123 ;Ufun nesting level
NEST =125 ;EVAL nesting of current EVLINE
DSPFL2 =127 ;DOS wants 127
TLLEVS =128 ;Number of tail recursions included in LEVNUM
IFLEVL =130 ;IF nesting level
EDTATM =132 ;Pointer to atom of Ufun currently being edited
MARK1 =134 ;Garbage collector protected variable
MARK2 =136 ; "
MARK3 =138 ; "
MARK4 =140 ; "
MARK5 =142 ; "
OBLIST =144 ;Pointer to Object List
UNSUM =146 ;Unary_Sum pointer
UNDIF =148 ;Unary_Difference pointer
ILINE =150 ;Pointer to current or last command line
EDBOD =152 ;Pointer to body of Ufun (Flist type) currently being edited
CELPTR =154 ;Garbage collector protected variable
PODEFL =156 ;Default Ufun atom for PO
ARG2 =158 ;Primitive's second argument
NARG2 =158 ;Primitive's second argument (numerical - 4 bytes)
ARG1 =162 ;Primitive's first argument
NARG1 =162 ;Primitive's first argument (numerical - 4 bytes)
TEMPNH =166 ;Temporary variable (must follow NARG1 for floating pt. routines)
TEMPN =168 ; "
TEMPN1 =170 ; "
TEMPN2 =172 ; "
TEMPN3 =174 ; "
TEMPN4 =176 ; "
ANSN =178 ; "
ANSN1 =179 ; "
TEMPN5 =180 ;(Last swapped) Temporary variable
TEMPN6 =182 ;Temporary variable
TEMPN7 =184 ; "
TEMPN8 =186 ; "
TEMPX1 =188 ; "
TEMPX2 =190 ; "
ANSN2 =192 ; "
ANSN3 =193 ; "
ANSNX =194 ; "
NNODES =195 ;Number of nodes allocated
; Turtle-Graphics/Editor variables:
EPOINT =197 ;Editor point
ENDBUF =199 ;Location after last character in buffer
PEN =201 ;Indicates pen down if nonzero
TSHOWN =202 ;Indicates turtle shown if nonzero
XCOR =203 ;X-Coordinate, floating pt.
YCOR =207 ;Y-Coordinate, floating pt.
HEADNG =211 ;Heading, floating pt.
GANSN2 =215
GRP0 =216
GRP1 =217
GRP2 =218
GRP5 =219
GTMP4 =220
DERCOD =222 ;Error code location for DOS
COLR =223 ;Color
CHBUFR =224 ;Character buffer next-char-to-read pointer
RNDL =225
RNDH =226
.PAGE
; LOGO primitive pointers (page 3):
ALL =$340
COMMNT =$342 ;Comment
ER =$344
ERASE =$346
LELSE =$348 ;Else
LEND =$34A ;End
LIF =$34C ;If
LPAR =$34E ;(Left-parenthesis)
LSTOP =$350 ;Stop
LTHEN =$352 ;Then
LTITLE =$354 ;Title
NAMES =$356
PO =$358
POTS =$35A
PRNTOT =$35C ;Printout
PROCS =$35E ;Procedures
RPAR =$360 ;(Right-parenthesis)
TI =$362
TITLES =$364
INFSUM =$366 ;(Infix Sum)
INFDIF =$368 ;(Infix Difference)
LASTPP =INFDIF
.PAGE
; Type code constants:
LIST =0 ;List
ATOM =1 ;Atom (either Qatom, Datom, Latom)
STRING =2 ;Regular linked-list
FIX =3 ;Integer (GT2NUM requires that FIX < FLO)
FLO =4 ;Floating point number
SFUN =5 ;System Function
UFUN =6 ;User Function
SATOM =7 ;System atom
QATOM =8 ;Quoted atom
DATOM =9 ;Dotted atom
LATOM =10 ;Label atom
FPACK =11 ;Packed Ufun
FLIST =12 ;Regular Ufun format
; Tokenizer constants:
NEWLIN =1 ;Start of input line
NEWLST =2 ;Start of sublist
REGCEL =3 ;Regular linked cell
; General constants:
FULCHR =$06 ;Full-screen graphics character (Control-F)
STPKEY =$07 ;Stop-key character code (Control-G)
MIXCHR =$0C ;Mixed-screen graphics character (Control-L)
PULCHR =$10 ;Re-enter last line typed (Control-P)
LSTKEY =$13 ;Interrupt output listing (Control-S)
PAUSKY =$1A ;Pause-key character code (Control-Z)
RPRMPT =$3C ;REQUEST prompt ("<")
EPRMPT =$3E ;Edit-mode prompt character (">")
QPRMPT =$3F ;Regular prompt character (Question-mark)
LBRAK =$5E ;Left-bracket replacement character
GCVST =MARK1 ;Start of Garbage Collecor protected variable area
GCVEND =CELPTR+2 ;End of Garbage Collector protected variable area
LININC =10 ;Default line number increment
MONNUM =15 ;Number of Monitor commands
RANDA =5353 ;Random transform constant "A"
RANDC =43277 ;Random transform constant "C"
TTLC1 =6 ;Turtle length constant, center to tip
TTLC2 =18 ;Turtle length constant, side
TTLC3 =12 ;Turtle length constant, rear
TTLA1 =160 ;Turtle angle constant, first turn
TTLA2 =110 ;Turtle angle constant, base turns
; I/O Device constants:
KBD =0 ;For Keyboard input
VDT =0 ;For Screen output
BUFFER =1 ;For buffer I/O
; Storage Parameters:
LINARY =$200 ;Input line buffer (page 2)
CHBSTT =$300 ;Start of character buffer
CHBLEN =64 ;Length of character buffer
TMPNUM =TEMPN5-TMPSTT+2;Number of temporary bytes to swap
TMPSTT =TEMPNH ;Start of page-zero swapped temporaries
TMPTAB =LASTPP+2 ;Start of temporary storage area (page 3)
GRPSTT =$2000 ;Start of hires graphics area
GRPEND =$4000 ;End of Hires graphics area
EDBUF =$2000 ;Start of editor buffer
EBFEND =$3FFB ;End of edit buffer (with room for CR and EOF marker)
SYSTAB =$30 ;Page no. of System tables (after loading)
GHOMEM =$D0 ;Page no. of Ghost-memory
TDIFF =$A000 ;Difference between above storage areas
; Mapped I/O locations:
GETRM1 =$C08B ;Enable high RAM (with first 4K bank)
GETRM2 =$C083 ;Enable high RAM (with second 4K bank)
KILRAM =$C08A ;Deselect high RAM (enable Monitor/BASIC)
KPFLAG =$C000 ;Keyboard input byte
KPCLR =$C010 ;Keyboard clear strobe
SPKR =$C030 ;Toggle speaker
IOADR =$C0 ;Start of I/O ROM area
; Interrupt Vector areas:
RSTVEC =$FFFC ;Location of RESET vector
IRQVEC =$FFFE ;Location of IRQ vector
NMIVEC =$FFFA ;Location of NMI vector (BRK command)
; System vectors:
USRADR =$03F8 ;User JMP location for ROM monitor
SYSMON =$FF59 ;ROM monitor entry point
; DOS sacred locations
DOSEAT =$A851 ;DOS subroutine to give DOS control of input
DOSERR =$00D8 ;DOS onerr goto flag - set high bit to turn on
DSERET =$9D5A ;DOS error return address
DLNGFG =$AAB6 ;DOS language flag -- stuff a $40 for Applesoft
FILLEN =$AA60 ;length of last file loaded
APCOUT =$FDED ;location of COUT routine in monitor (DOS calls it)
.PAGE
; System Function Constants:
INULL =0
ITHNGP =1 ;Thingp
IWORD =2
IWORDP =3
IUNSUM =4 ;Unary_sum
IUNDIF =5 ;Unary_difference
IMAKE =6
IOTPUT =7 ;Output
ISTOP =8
IPRINT =9
ITYPE =10
IDEFIN =11 ;Define
ICLEAR =12
ICNTIN =13 ;Continue
IPAUSE =14
IELSE =15
ISNTNC =16 ;Sentence
IBOTH =17
IEITHR =18 ;Either
ITHEN =19
INOT =20
ILPAR =21 ;(Left-parenthesis)
IRPAR =22 ;(Right-parenthesis)
IIF =23
IRUN =24
IGO =25
IBPT =26 ;.bpt
IGDBYE =27 ;Goodbye
IGCOLL =28 ;.gcoll
INODES =29 ;.nodes
IBTFST =30 ;Butfirst
IFIRST =31
IBTLST =32 ;Butlast
ILAST =33
ITO =34
IEDIT =35
IEND =36
ITEXT =37
IFORWD =38 ;Forward
IBACK =39
IRIGHT =40
ILEFT =41
ILIST =42
ICS =43
IHOME =44
IPENUP =45
IPENDN =46 ;Pendown
IEMPTP =47
ISHOWT =48 ;Showturtle
IHIDET =49 ;Hideturtle
ITSTAT =50 ;Turtlestate
ITITLE =51
IFPUT =52
IPO =53
IALL =54
INAMES =55
IERASE =56
IREAD =57
ISAVE =58
IREQST =59 ;Request
ITHING =60
IRETRV =61 ;Retrieve
ISUM =62
IDIF =63 ;Difference
IPROD =64 ;Product
IQUOT =65 ;Quotient
IGREAT =66 ;Greater
ILESS =67
ICOMNT =68 ;Comment
IEQUAL =69
ITRCBK =70 ;Traceback
IPOTS =71
ITITLS =72 ;Titles
IPROCS =73 ;Procedures
IPEEK =74
IPOKE =75
INSUM =76 ;Infix Sum
INDIF =77 ;Infix Difference
INPROD =78 ;Infix Product
INQUOT =79 ;Infix quotient
INGRTR =80 ;Infix Greater
INLESS =81 ;Infix Less
INEQUL =82 ;Infix Equal
ILPUT =83
IRANDM =84 ;Random
ICTYI =85
ICURSR =86 ;Cursor
IRNDMZ =87 ;Randomize
ICALL =88
ILISTP =89
INMBRP =90 ;Numberp
ICLINP =91
ICHNGE =92
IRPEAT =93
ISETX =94
ISETY =95
ISETXY =96
ISETH =97
ISETT =98
IXCOR =99
IYCOR =100
IHDING =101 ;Heading
INDSPL =102 ;Nodisplay
IINT =103
IFULL =104
IMIX =105
IDELET =106 ;delete file
ICATLG =107 ;list files
.PAGE
; Error Codes:
XUOP =1
XEOL =2
XUDF =3
XHNV =4
XNIP =5
XNOP =6
XRPN =7
XIFX =8
XVNA =9
XTIP =10
XWTA =11
XUBL =12
XNTL =13
XNTF =14
XELS =15
XBRK =16
XLABEL =17
XTHN =18
XLNF =19
XEDT =20
XDEF =21
XETL =22
XNED =23
XOPO =24
XTML =25
XDBZ =26
XNWE =27
XLNTB =28
XILN =29
XOFLOW =30
XNDF =31
XCRSR =32
XYNT =33
XOOB =34
XIOR =35
XWTP =36
XFNF =37
XDKF =38
XLKF =39
XZAP =100 ;(Errors not in dispatch table)
XARGTB =101
XNSTOR =0 ;(XZAP Quantifiers)
XNSTRN =1
XSTOP =2
XEXCED =3
.PAGE
; Storage Parameters and Map:
; Miscellaneous: Page 0 - Variables
; Page 1 - Processor Stack
; Page 2 - Input line buffer
; Page 3 - Pointers, variable storage, character buffer
; Pages 4 to 7 - Text screen page
; Pages 8 to 13 - System Primitive Array
; Pages 14 to 31 - Stacks (PDL, VPDL)
; Pages 32 to 63 - Hi-res. graphics scrren/Screen editor buffer
; MISC.: $0000 - $07FF: $ 800 bytes (2K bytes)
; SARRAY: $0800 - $0DFF: $ 600 bytes (1.5K characters)
; STACKS: $0E00 - $1FF9: $11F9 bytes (about 2.25K words) PDL, VDPL
; VECTORS: $1FFA - $1FFF: $ 6 bytes (2 vectors) Start address, restart address
; BUFFER: $2000 - $3FFF: $2000 bytes (8K bytes) Screen Editor, Graphics, boot buffer
; LOGO: $4000 - $95FF: $5600 bytes (21.5K bytes)
; DOS: $9600 - $BFFF: $2A00 bytes (10.5K bytes)
; I/O: $C000 - $CFFF: $1000 bytes (4K bytes)
; BIGARRAY: $D000 - $F65F: $2660 bytes (2456. nodes)
; TYPBASE: $F660 - $FFF7: $ 998 bytes (2456. typecodes)
; UNUSED: $FFF8 - $FFF9: $ 2 bytes
; INTRPTS.: $FFFA - $FFFF: $ 6 bytes (3 vectors) NMI, RESET, IRQ addresses
; GHOSTMEM: $D000 - $DFFF: $1000 bytes (4K bytes)
PGMSTT =$4000 ;Program starts after High-res. graphics storage
BIGBAS =$D000 ;Nodespace beginning
BBASX =BIGBAS-4
BIGLEN =$2660 ;Nodespace length
SINODS =BIGBAS+BIGLEN ;Nodespace end
;OFSET1 =BIGBAS/4 but the stupid cross assembler can't divide correctly so we have to it...
OFSET1 =$3400 ;Offset constant
TYPBAS =SINODS-OFSET1 ;Typebase offset
TYPLEN =BIGLEN/4 ;Typebase length
TYPEND =SINODS+TYPLEN ;Typebase end
NODTST =50 ;Minimum free nodes for tokenizer
NODLIM =TYPLEN-NODTST ;Node allocation limit
BASARY =$800 ;SARRAY beginning
SARLEN =$600 ;SARRAY length
STKLEN =$11F9 ;Combined stack length
PDLBAS =BASARY+SARLEN ;PDL beginning (grows upwards, Push-then-incr.)
VPDLBA =PDLBAS+STKLEN-2;VPDL beginning (grows downwards, Push-then-decr.)
STKLIM =80 ;Minimum unused stack space before panicking
.PAGE
.SBTTL Top Level
.=PGMSTT
;Calling point for the LOGO Interpreter
LOGO: LDA GETRM2 ;Select Ghost-memory bank 2 for writing
LDA GETRM2
LDX #$00
STX TEMPNH
STX TEMPN
INX
STX BANK4K
LDA #SYSTAB ;Page no. of tables
STA TEMPNH+1
LDA #GHOMEM ;Page no. of ghost-memory
STA TEMPN+1
LDY #$00
MOVLOP: LDA (TEMPNH),Y
STA (TEMPN),Y
INY
BNE MOVLOP
INC TEMPNH+1
INC TEMPN+1
LDA #ENDTAB^
CMP TEMPNH+1 ;See if last page transferred
BCS MOVLOP
;falls through
;Re-entry point for GOODBYE:
;falls in
LOGO1: SEI ;Disable interrupts
CLD ;Disable decimal mode
LDX #$00
TXS ;Initialize processor stack
STX MONFLG ;Disable monitor mode
STX $00 ;Define LNIL as $0000 at $0000
STX $01
STX $02
STX $03
STX BANK4K
LDA GETRM1
LDA GETRM1 ;Disable Ghost-memory bank 2
LDA #MONBRK&$FF
STA IRQVEC
STA NMIVEC ;Interrupts cause a break to Monitor
LDA #MONBRK^
STA IRQVEC+1
STA NMIVEC+1
LDA #MONBRK&$FF ;?Vector to LOGO when debugged
STA RSTVEC ;RESET reinitializes LOGO
LDA #MONBRK^
STA RSTVEC+1
JSR INITLZ
LDX #HELSTR&$FF
LDY #HELSTR^
JSR PRTSTR ;Types Hello-String
TOPLOP: LDX #ILINE
JSR PRDLIN ;Get a line
TYA
BNE TOPLOP ;Y nonzero means not OK
LDA ILINE+1
BEQ TOPLOP ;Ignore if line is empty
STA TOKPTR+1
LDA ILINE
STA TOKPTR
LDA EDSW
BEQ EVLUAT ;Evaluate it if not in Edit mode
JSR CHKLNN
LDY #$00
CMP #FIX
BEQ TOPEDL ;If there's a line number, add it to the procedure
JSR CHKEVL ;Returns Carry set if Evaluatable
BCS EVLUAT
TOPLIN: LDX #ILINE
STX ANSN
LDA #FLIST
JSR CONS
LDY #$01
TOPEDL: JSR EDLINE
JMP TOPLOP
.PAGE
.SBTTL Evaluator Routines
;EVLUAT initializes the Evaluator variables, starts EVLINE.
EVLUAT: LDA #PDLBAS&$FF
STA SP
LDA #PDLBAS^
STA SP+1 ;SP := PDLBASE
LDA #VPDLBA&$FF
STA VSP
LDA #VPDLBA^
STA VSP+1 ;VSP := VPDLBASE
LDA #$00
STA EXPOUT ;EXPECTED_OUTPUT := 0
STA RUNFLG ;RUN_FLAG := 0
STA STPFLG ;STOP_FLAG := 0
STA DCOFLG ;DONT_CONTINUE_FLAG := 0
STA ERRFLG ;ERROR_FLAG := 0
STA LEVNUM
STA LEVNUM+1 ;LEVEL_NUMBER := 0
STA LINNUM
STA LINNUM+1 ;LINE_NUMBER := 0
STA FRAME+1 ;FRAME := 0
STA XFRAME+1 ;XFRAME := 0
STA UFRMAT ;UFORMAT := LIST
LDX #TOPLOP&$FF
LDY #TOPLOP^
JSR PUSH ;Top-level Return Address (TOPLOP)
;falls through
.PAGE
;EVLINE called with TOKPTR pointing to line of code to execute.
; Pushes IFLEVEL and EXPOUT and then resets them.
;falls in
EVLINE: JSR STKTST
LDX EXPOUT
JSR PUSH
LDX #IFLEVL
JSR PUSHP
LDA #$00
STA EXPOUT ;EXPECTED_OUTPUT := 0
STA IFLEVL ;IF_LEVEL := 0
STA IFLEVL+1
LDA TOKPTR+1
BEQ EVLN1P
EVLN1: LDY #$00
LDA (TOKPTR),Y
STA TEMPN
INY
LDA (TOKPTR),Y
STA TEMPN+1 ;(GETTOK)
LDX #TEMPN
JSR GETTYP
CMP #LATOM
BNE EVLIN1
LDX #TOKPTR
JSR TTKADV
;falls through
;EVLIN1 keeps calling EVLEXP until EOL.
;falls in
EVLIN1: LDA TOKPTR+1
BNE EVLN1A
EVLN1P: LDX #IFLEVL
JSR POP
JSR POPB
STA EXPOUT
POPJ: LDX #TEMPN
JSR POP
JMP (TEMPN)
EVLN1A: LDA STPFLG
BNE EVLN1P
LDX #EVLIN1&$FF
LDY #EVLIN1^
JSR PUSH ;PUSH (EVLIN1) Return Address
;falls through
;EVLEXP calls EVAL with PRECED = 0. EVAL returns to EVEX1,
;which restores old PRECED.
;falls in
EVLEXP: LDX PRECED
JSR PUSH ;Call PUSH (PRECEDENCE)
LDA #$00
STA PRECED ;PRECEDENCE := 0
LDX #EVEX1&$FF
LDY #EVEX1^
JSR PUSH ;Call PUSH (EV_EX_1)
;falls through
.PAGE
;EVAL dispatches to either EVWRAP, PARLOP, UFUNCL, or SFUNCL.
;All return eventually to EVWRAP.
;falls in
EVAL: LDX #CURTOK ;Push CURTOK and increment NEST if FRAME <> 0
JSR PUSHP
LDA FRAME+1
BEQ XEVL2
XEVL1: INC NEST
BNE XEVL2
INC NEST+1
BPL XEVL2
JMP EXCED
XEVL2: LDA TOKPTR+1
BNE XEVL3
JMP SCMMT1 ;ERROR End-of-Line if EOL
XEVL3: LDY #$00 ;Get CURTOK and NEXTOK
LDA (TOKPTR),Y
STA CURTOK
INY
LDA (TOKPTR),Y
STA CURTOK+1 ;(GETTOK)
LDX #TOKPTR
JSR TTKADV
JSR GTNXTK
LDX #CURTOK
JSR GETTYP ;Dispatch off Type of CURTOK
CMP #SATOM
BEQ XCASA
CMP #ATOM
BEQ XCASA
CMP #DATOM
BEQ XCASD
CMP #LIST
BEQ XCASQ ;(If LIST)
CMP #QATOM
BEQ XCASQ
CMP #FIX
BEQ XCASQ
CMP #FLO
BEQ XCASQ
XCASL: LDA #XLABEL ;ERROR, can't execute a label
JMP ERROR
XCASD: LDY #CURTOK ;DATOM, so VPush it unless it's Novalue (then Error)
LDX #TEMPN
JSR GETVAL
LDX #TEMPN ;For VPUSHP in XCASQ1
LDA TEMPN+1
BNE XCASQ1
LDA TEMPN
BEQ XCASQ1
LDA CURTOK
AND #$FC
STA CURTOK
LDY #CURTOK
LDA #XHNV
JMP ERROR
XCASQ: LDA CURTOK ;QATOM, FIX, FLO, LIST: Just push it and set OTPUTN
AND #$FC ;Strip off last two bits
STA CURTOK
LDX #CURTOK
XCASQ1: JSR VPUSHP ;VPUSH (CURRENT_TOKEN)
INC OTPUTN
JMP EVWRAP
XCASA: LDX #CURTOK ;ATOM, SATOM: It's some sort of Function
LDA #FUNCT
JSR GETFUN
STA FUNTYP
LDA FUNCT+1
BNE XCASA1
LDY #CURTOK
LDA #XUDF
JMP ERROR ;Error if GETFUN couldn't find it
XCASA1: LDA FUNTYP
LDX #FUNCT
JSR INFIXP
BCC XCASA2
CMP #INSUM
BNE XCASA3
LDX UNSUM
LDY UNSUM+1
BNE XCASA4 ;(Always)
XCASA5: LDY #CURTOK
LDA #XIFX
JMP ERROR
XCASA3: CMP #INDIF
BNE XCASA5
LDX UNDIF
LDY UNDIF+1
XCASA4: STX CURTOK
STY CURTOK+1
LDX #CURTOK
LDA #FUNCT
JSR GETFUN
STA FUNTYP
XCASA2: LDX PRECED ;It should be a UFUN or SFUN
JSR PUSH
LDY FUNTYP
LDX #FUNCT
JSR GETPRC
STA PRECED
LDA FUNTYP
LDX #FUNCT
JSR GETNGS
BPL XCASF1
EOR #$FF ;NARGS := - NARGS - 1
XCASF1: STA NARGS
LDX #EVAL1&$FF
LDY #EVAL1^
JSR PUSH
;falls through
.PAGE
;falls in
ARGLOP: LDA NARGS ;ARGLOP gets the args for a function
BNE ARGLP1
JMP POPJ ;Exit if no args to be gotten
ARGLP1: LDX NARGS
STX ANSN ;AL1 will push this
JSR PUSH
LDX #FUNCT
JSR PUSHP
LDX FUNTYP
JSR PUSH
LDX EXPOUT
JSR PUSH
LDX #IFLEVL
JSR PUSHP
;falls through
;falls in
AL1: JSR GTNXTK
LDX #NEXTOK
JSR PUSHP
LDX ANSN
JSR PUSH
LDX PRECED
JSR PUSH
LDX #$00
STX IFLEVL
STX IFLEVL+1
INX
STX EXPOUT
LDX #AL2&$FF
LDY #AL2^
JSR PUSH
JMP EVAL
VL1RG: JMP VAL1R ;Error if no output received
AL2: JSR POPB
STA PRECED
JSR POPB
STA ANSN
LDX #NEXTOK
JSR POP
LDA OTPUTN
BEQ VL1RG
DEC ANSN
BNE AL1 ;Get another arg if not done
LDX #IFLEVL
JSR POP
JSR POPB
STA EXPOUT
JSR POPB
STA FUNTYP
LDX #FUNCT
JSR POP
JSR POPB
STA NARGS
JMP POPJ
CHKEVL: LDX TEMPN
LDY TEMPN+1
CPX POTS
BNE CHKEV2
CPY POTS+1
BEQ EVLOK
CHKEV2: CPX LEND
BNE CHKEV3
CPY LEND+1
BEQ EVLOK
CHKEV3: CPX PO
BNE CHKEV4
CPY PO+1
BEQ EVLOK
CHKEV4: CPX PRNTOT
BNE CHKEV5
CPY PRNTOT+1
BEQ EVLOK
CHKEV5: CPX LTITLE
BNE CHKEV6
CPY LTITLE+1
BEQ EVLOK
CHKEV6: CPX ERASE
BNE CHKEV7
CPY ERASE+1
BEQ EVLOK
CHKEV7: CPX ER
BNE EVLNO
CPY ER+1
BNE EVLNO
EVLOK: SEC
RTS
EVLNO: CLC
RTS
EVEX1: JSR POPB
STA PRECED
JMP POPJ
.PAGE
PARLOP: LDX #NEXTOK ;Executed when an LPAR is encountered
LDA #FUNCT
JSR GETFUN
STA FUNTYP
CMP #SFUN
BNE PARLPA
LDA NEXTOK
CMP RPAR
BNE PARLPA
LDA NEXTOK+1
CMP RPAR+1
BNE PARLPA
LDA #XNIP ;"Nothing inside parenthesis"
JMP ERROR
PARLPA: LDA FUNCT+1
BEQ PARLP7
PARLP1: LDA FUNTYP
LDX #FUNCT
JSR GETNGS
STA NARGS
PARLP4: LDA NARGS
BMI PARLP3
PARLP7: LDX EXPOUT
JSR PUSH
LDX #IFLEVL
JSR PUSHP
LDX #$00
STX IFLEVL ;IF_LEVEL := 0
STX IFLEVL+1
INX
STX EXPOUT
LDX #PLOP1&$FF
LDY #PLOP1^
JSR PUSH
JMP EVLEXP
PARLP3: LDY FUNTYP
LDX #FUNCT
JSR GETPRC
STA PRECED
LDA NEXTOK
STA CURTOK
LDA NEXTOK+1
STA CURTOK+1 ;CURRENT_TOKEN := NEXT_TOKEN
LDX #TOKPTR
JSR TTKADV
LDA #$00
STA NARGS ;NARGS := 0
LDX #FUNCT
JSR PUSHP
LDX FUNTYP
JSR PUSH
;falls through
.PAGE
;falls in
VARGLP: JSR GTNXTK
LDA NEXTOK
CMP RPAR
BNE VRGLP1
LDA NEXTOK+1
CMP RPAR+1
BNE VRGLP1
JSR POPB ;Call POP (FUNTYPE)
STA FUNTYP
LDX #FUNCT
JSR POP
LDX #TOKPTR
JSR TTKADV
LDA NARGS
EOR #$FF
STA NARGS ;NARGS := - NARGS - 1
JMP FNCAL1
VRGLP1: LDX NARGS
JSR PUSH
LDX #NEXTOK
JSR PUSHP
LDX EXPOUT
JSR PUSH
LDX #IFLEVL
JSR PUSHP
LDX #$00
STX IFLEVL ;IF_LEVEL := 0
STX IFLEVL+1
INX
STX EXPOUT
LDX PRECED
JSR PUSH
LDX #VAL1&$FF
LDY #VAL1^
JSR PUSH
JMP EVAL
.PAGE
VAL1: JSR POPB
STA PRECED
LDX #IFLEVL
JSR POP
JSR POPB
STA EXPOUT
LDX #NEXTOK
JSR POP
JSR POPB
STA NARGS
LDA OTPUTN
BEQ VAL1R
INC NARGS
BNE VARGLP
EXCED: LDA #XZAP
LDX #XEXCED
JMP ERROR
VAL1R: LDA #XNOP
LDY #NEXTOK
JMP ERROR
GTNXTK: LDY #$00
LDA (TOKPTR),Y
STA NEXTOK
INY
LDA (TOKPTR),Y
STA NEXTOK+1 ;(GETTOK)
RTS
.PAGE
;PLOP1 cleans up after a parenthesized expression.
PLOP1: LDX #IFLEVL
JSR POP
JSR POPB
STA EXPOUT
LDA TOKPTR+1
BEQ SCMMTG
JSR GTNXTK
LDA NEXTOK
CMP RPAR ;Next token must be an RPAR, else Error
BNE PLOP1B
LDA NEXTOK+1
CMP RPAR+1
BNE PLOP1B
LDX #TOKPTR ;Everything OK, get the next token and exit
JSR TTKADV
JMP POPJ
PLOP1B: LDA #XTIP
JMP ERROR
SCMMTG: JMP SCMMT1 ;Error if EOL
RUNHAN: LDX UFRMAT
JSR PUSH
LDX #ULNEND
JSR PUSHP
LDX #TOKPTR
JSR VPUSHP
LDA ARG1
STA TOKPTR
LDA ARG1+1
STA TOKPTR+1
LDX RUNFLG
JSR PUSH
LDX #$00
STX OTPUTN
STX UFRMAT
INX
STX RUNFLG
LDX #RH1&$FF
LDY #RH1^
JSR PUSH
JMP EVLINE
RH1: JSR POPB
STA RUNFLG
LDX #TOKPTR
JSR VPOP
LDX #ULNEND
JSR POP
JSR POPB
STA UFRMAT
JMP POPJ
.PAGE
SREAD1: LDA INDEV ;If something reset INDEV to default,
BEQ SREAD3 ;then break out, don't check for EOF.
SRED1A: LDA ENDBUF+1
CMP EPOINT+1
BNE EDIN
LDA ENDBUF
CMP EPOINT
BEQ SREAD2
EDIN: LDX #$00
EDIN2: LDY #$00
LDA (EPOINT),Y
STA LINARY,X
JSR INCPNT
LDA LINARY,X
CMP #$0D
BEQ EDIN1
INX
BNE EDIN2
EDIN1: STX TEMPN7
INC OUTDEV ;Nullify the TPCHR in PRDLIN (closing brackets, etc.)
LDA #ILINE
STA TEMPX2
JSR PRDLNX ;Read a line. If error, reset & go to SREAD2
DEC OUTDEV ;Re-enable TPCHR's
TYA
BEQ SRD1A ;Y zero means OK
LDA #$00
STA ERRFLG
SREAD2: LDA #KBD ;Break out of Read loop, reset INDEV
STA INDEV ;to default.
SREAD3: STA EDSW
STA OTPUTN ;OUTPUTN := 0
JMP POPJ ;Return to S_READ1's superior
SRD1A: LDA ILINE+1
STA TOKPTR+1
BEQ SRED1A
LDA ILINE
STA TOKPTR
LDA EDSW
BEQ SRD1E
JSR CHKLNN
LDY #$00
CMP #FIX
BEQ SRDEDL ;If there's a line number, add it to the procedure
JSR CHKEVL ;Returns Carry set if Evaluatable
BCC SRD1F
SRD1E: LDX #SREAD1&$FF
LDY #SREAD1^
JSR PUSH
JMP EVLINE
SRD1F: LDX #ILINE
STX ANSN
LDA #FLIST
JSR CONS
LDY #$01
SRDEDL: JSR EDLINE
JMP SREAD1
.PAGE
EVWRAP: LDA TOKPTR+1
BEQ EVRETN
LDA OTPUTN
BEQ EVRETN
LDA STPFLG
BNE EVRETN
LDY #$00
LDA (TOKPTR),Y
STA CURTOK
INY
LDA (TOKPTR),Y
STA CURTOK+1 ;(GETTOK)
LDA CURTOK
CMP RPAR
BNE EVW2
LDA CURTOK+1
CMP RPAR+1
BEQ EVRETN
EVW2: LDX #CURTOK
LDA #FUNCT
JSR GETFUN
STA FUNTYP
LDX #FUNCT
JSR INFIXP
BCC EVRETN
LDY FUNTYP
LDX #FUNCT
JSR GETPRC
STA ANSN2
CMP PRECED
BCC EVRETN
BEQ EVRETN
LDX #TOKPTR
JSR TTKADV
JSR GTNXTK
LDX #NEXTOK
JSR PUSHP
LDX #FUNCT
JSR PUSHP
LDX FUNTYP
JSR PUSH
LDX EXPOUT
JSR PUSH
LDX #IFLEVL
JSR PUSHP
LDX PRECED
JSR PUSH
LDA #$01
STA EXPOUT
LDA ANSN2
STA PRECED
LDX #EW1&$FF
LDY #EW1^
JSR PUSH
JMP EVAL
EVRETN: LDA FRAME+1
BEQ EVRET1
EVRTN1: DEC NEST
BPL EVRET1
DEC NEST+1
EVRET1: LDA OTPUTN
BEQ EVRET2
LDA EXPOUT
BNE EVRET2
LDA STPFLG
BNE EVRET2
LDA RUNFLG
BNE EVRET2
LDX #NEXTOK
JSR VPOP
LDY #NEXTOK
LDA #XUOP
JMP ERROR
EVRET2: LDX #CURTOK
JSR POP
JMP POPJ
.PAGE
;EW1 pops everything EVWRAP pushed, checks for output (error if none),
;then goes to FUNCAL with NARGS = 2.
EW1: JSR POPB
STA PRECED
LDX #IFLEVL
JSR POP
JSR POPB
STA EXPOUT
JSR POPB
STA FUNTYP
LDX #FUNCT
JSR POP
LDX #NEXTOK
JSR POP
LDA OTPUTN
BNE EW1A
JMP VAL1R ;(ERROR XNOP,NEXTOK)
EW1A: LDA #$02
STA NARGS ;NARGS := 2
BNE FUNCAL ;(Always)
EVAL1: JSR POPB ;Now that we have the args, get the old PRECED
STA PRECED ; back and do the function
;falls through
;FUNCAL calls either SFUNCL (with FBODY1 = Funct. #) or UFUNCL (with FBODY1
; pointing to text). Both return to EVWRAP. (FNCAL1 is same, except U&SFNCL
; don't return to EVWRAP).
;falls in
FUNCAL: LDX #EVWRAP&$FF
LDY #EVWRAP^
JSR PUSH
FNCAL1: LDA FUNTYP
CMP #SFUN
BEQ FUN1
LDY #$02 ;UFUN, get text pointer
LDA (FUNCT),Y
STA FBODY1
INY
LDA (FUNCT),Y
STA FBODY1+1 ;(CDR)
JMP XUFNCL
FUN1: LDY #$02 ;SFUN, get Function # from Sarray
LDA (FUNCT),Y ;FBODY1 := SARRAY[FUNCT + SA_SINDEX] (SA_SINDEX = 2)
STA FBODY1
;falls through
.PAGE
;falls in
XSFNCL: LDA #$00
STA OTPUTN ;Default, no outputs
LDA #GHOMEM ;Page no. of dispatch addresses
STA TEMPN+1
LDA FBODY1
ASL A
STA TEMPN
BCC XSFNC1
INC TEMPN+1
XSFNC1: LDA GETRM2 ;Ghost-memory bank 2, System table
INC BANK4K
LDY #$00
LDA (TEMPN),Y
STA TEMPNH
INY
LDA (TEMPN),Y
STA TEMPNH+1 ;(CAR)
LDA GETRM1 ;Ghost-memory bank 2 disable
LDA GETRM1
DEC BANK4K
JMP (TEMPNH) ;Execute the routine
;FBODY1 contains a one-byte index to a table of pointers to system routines
;The table starts at GHOMEM, and the index is multiplied by two for indexing
;the sixteen-bit addresses. Adresses in the table are stored low byte first,
;high byte next.
;For THEN, pointer points to XXSFR1
;For RPAR, pointer points to XXSFR2
;For LPAR, pointer points to PARLOP
;For ALL, NAMES, TITLES, and PROCEDURES, pointers all point to XXSFR3
XXSFR1: LDA #XTHN
JMP ERROR
XXSFR2: LDA #XRPN
JMP ERROR
XXSFR3: LDY #CURTOK
LDA #XOPO
JMP ERROR
.PAGE
XUFNCL: LDY #FPTR
LDX #TEMPN ;Lastline
JSR LINPEK
JSR STKTST
LDX #ULNEND
JSR PUSHP
LDX UFRMAT
JSR PUSH
LDX #FBODY
JSR PUSHP
LDX #FPTR
JSR PUSHP
LDX RUNFLG
JSR PUSH
LDA #$00
STA STPFLG
STA RUNFLG
STA GOPTR+1 ;GO_PTR := LNIL (0)
STA TEMPN1+1 ;TEMP := LNIL (0)
LDA FBODY1
STA FBODY
STA FPTR
LDA FBODY1+1
STA FBODY+1
STA FPTR+1
LDA NEST
BNE XUFN1
LDA NEST+1
BNE XUFN1
LDA LEVNUM
BNE XUFN2
LDA LEVNUM+1
BEQ XUFN1
XUFN2: LDA TEMPN+1 ;Lastline
BNE XUFN3
LDA TOKPTR+1
BNE XUFN5
JMP XUFN1A
XUFN3: LDA TOKPTR+1
BEQ XUFN1
XUFN5: LDY #$00
LDA (TOKPTR),Y
STA TEMPN1
INY
LDA (TOKPTR),Y
STA TEMPN1+1 ;(GETTOK)
XUFN1: LDX #FBODY
JSR GETTYP
STA UFRMAT
LDA TEMPN1
CMP LSTOP
BNE XUFN6
LDA TEMPN1+1
CMP LSTOP+1
BNE XUFN6
XUFN1A: LDA XFRAME
STA SP
LDA XFRAME+1
STA SP+1
JMP XTAIL
XUFN6: LDX FRAME
LDY FRAME+1
LDA SP
STA FRAME
LDA SP+1
STA FRAME+1 ;FRAME points to PREV_FRAME
JSR PUSH
LDX #XFRAME
JSR PUSHP
LDX UFRMAT
JSR PUSH
LDX #CURTOK
JSR PUSHP
LDX #NEST
JSR PUSHP
LDX #LINNUM
JSR PUSHP
LDX #TOKPTR
JSR PUSHP
LDX NARGS
INX
JSR PUSH ;PUSH (NARGS+1)
LDX #TLLEVS
JSR PUSHP
LDY #$00
LDA (FUNCT),Y
TAX
INY
LDA (FUNCT),Y
TAY ;(GET_FFRAME)
JSR PUSH
LDX FUNCT
LDY FUNCT+1
INX
BNE XUFN6B
INY
XUFN6B: JSR PUSH ;PUSH (FUNCT+1)
LDY #$01
STY TLLEVS
DEY
STY LINNUM
STY LINNUM+1
STY TLLEVS+1
DEY
STY NEST
STY NEST+1
INC LEVNUM
BNE XUFN6C
INC LEVNUM+1
BNE XUFN6C
JMP EXCED
XUFN6C: INY
LDA FRAME
STA (FUNCT),Y
INY
LDA FRAME+1
STA (FUNCT),Y ;(PUT_FFRAME)
JSR STPTR1
LDY #FBODY
LDX #TEMPN1 ;TEMPN1 gets ARGLIST
JSR GTTULN
XUFNW: LDA TEMPN1+1
BEQ XUFNWE
JSR PTVTST
LDY #$00
LDA (TEMPN1),Y
STA TEMPN2 ;TEMPN2 is VARNAM
INY
LDA (TEMPN1),Y
STA TEMPN2+1 ;(GETTOK)
LDX #TEMPN1
JSR TTKADV
LDY #TEMPN2
LDX #TEMPN ;TEMPN is TEMP1
JSR GETVAL
LDX #TEMPN
JSR PUSHP
LDY #$00
LDA (TEMPN5),Y ;TEMPN5 is POINTER
STA TEMPN
INY
LDA (TEMPN5),Y
STA TEMPN+1 ;(GETBAR)
JSR PTRDEC
LDX #TEMPN
LDY #TEMPN2
JSR PUTVAL
LDX #TEMPN2
JSR PUSHP
JMP XUFNW
XUFNWE: LDA SP
STA XFRAME ;XFRAME points to location after last binding pair
LDA SP+1
STA XFRAME+1
JSR INCVSP
;falls through
.PAGE
;UF1 does a line of the procedure.
;falls in
UF1: LDA GOPTR+1
BNE UF1A
LDX #FPTR
JSR ULNADV
JMP UF1C
UF1A: LDA GOPTR ;GOPTR <> NIL, so FPTR := GOPTR, reset GOPTR.
STA FPTR
LDA GOPTR+1
STA FPTR+1
LDA #$00
STA GOPTR+1
UF1C: LDA STPFLG
BNE UF2A
LDA FPTR+1
BEQ UF2
UF1D: LDY #FPTR
LDX #TOKPTR
JSR GTTULN
LDY #$00
LDA (TOKPTR),Y
STA LINNUM
INY
LDA (TOKPTR),Y
STA LINNUM+1 ;(GETTOK)
LDX #TOKPTR
JSR TTKADV
LDX #UF1&$FF
LDY #UF1^
JSR PUSH
JMP EVLINE
;End of a procedure.
UF2: STA OTPUTN
UF2A: SEC
LDA LEVNUM
SBC TLLEVS
STA LEVNUM
LDA LEVNUM+1
SBC TLLEVS+1
STA LEVNUM+1
LDA #$00
STA STPFLG
JSR POPFRM
JSR POPB
STA RUNFLG
LDX #FPTR
JSR POP
LDX #FBODY
JSR POP
JSR POPB
STA UFRMAT
LDX #ULNEND
JSR POP
JMP POPJ
.PAGE
ERROR1: LDX #$00
STX RUNFLG
LDA ERRFLG
STA ANSNX
STX ERRFLG
CMP #XZAP
BEQ PPTTP
LDX LEVNUM
BNE ERR1A
LDX LEVNUM+1
BEQ PPTTP
ERR1A: CMP #XBRK
BEQ ERR1B
PPTTP: LDA FRAME+1
BEQ PPTT2
PPTTP1: JSR RSTBND
LDY #$02 ;(SF_XFRAME = 2.)
LDA (FRAME),Y
STA XFRAME
INY
LDA (FRAME),Y
STA XFRAME+1 ;(GETBAR)
LDY #$00 ;(SF_PREVIOUS_FRAME = 0)
LDA (FRAME),Y
TAX
INY
LDA (FRAME),Y
STA FRAME+1 ;(GETBAR)
STX FRAME
BNE PPTTP1
PPTT2: LDA #$00
STA LEVNUM
STA LEVNUM+1
LDA ANSNX
CMP #XZAP
BNE JTOP
LDA ANSN3
CMP #XNSTRN
BNE JTOP
LDA #VPDLBA&$FF
STA VSP ;If error was "out-of-nodes",
LDA #VPDLBA^ ;reset VPDL, do a garbage collect,
STA VSP+1 ;and check remaining nodes. If low,
JSR GARCOL ;ask user to delete something.
LDA NNODES+1
CMP #NODLIM^
BCC JTOP
BNE NWARN
LDA NNODES
CMP #NODLIM&$FF
BCC JTOP
NWARN: JSR BREAK1
LDX #WRNMSG&$FF
LDY #WRNMSG^ ;"Please delete something"
JSR PRTSTR
JTOP: JMP TOPLOP
ERR1B: LDA #$00
STA EXPOUT ;(EXPOUT := 0)
CLC
LDA XFRAME
ADC #$02 ;Don't pop the top return address
STA SP ;(RESET_EVAL)
LDA XFRAME+1
ADC #$00
STA SP+1
LDX #TOKPTR ;Save rest of line for CONTINUE
JSR PUSHP
LDX #ULNEND ;Save uline-end for CONTINUE
JSR PUSHP
;falls through
.PAGE
;falls in
ERROR2: LDA DCOFLG
BEQ ERR2A
LDA #$00
STA STPFLG
STA DCOFLG
STA TOKPTR+1
ERR2A1: LDY #$04 ;(SF_FORMAT = 4.)
LDA (FRAME),Y
STA UFRMAT ;(GETBAR)
LDX #ULNEND
JSR POP ;Restore Uline-end
LDX #TOKPTR ;Restore rest of eval-line
JSR POP
JMP POPJ
ERR2A: LDA STPFLG
BNE ERR2A1 ;Zap out of EVLINE without resetting stuff.
LDA #'L ;Both flags = 0, it's a Pause.
JSR TPCHR ;Type an "L"
LDX #LEVNUM
JSR TYPFIX
LDX #TOKPTR
JSR PRDLIN ;Get a line
TYA
BEQ ERR2A2 ;Y zero means OK
JMP ERROR1
ERR2A2: LDX #ERROR2&$FF
LDY #ERROR2^
JSR PUSH
LDA #LIST
STA UFRMAT
JMP EVLINE
.PAGE
XTAIL: LDX #$00
STX LINNUM
STX LINNUM+1
DEX
STX NEST
STX NEST+1
INC LEVNUM
BNE XTAIL1
INC LEVNUM+1
BNE XTAIL1
JMP EXCED
XTAIL1: INC TLLEVS
BNE XTAIL2
INC TLLEVS+1
BNE XTAIL2
JMP EXCED
XTAIL2: JSR STPTR1 ;POINTER is TEMPN1
LDY #$0E ;SF_NUMBER_BINDINGS (14.)
LDA (FRAME),Y
STA TEMPN3 ;BINDINGS
LDY #FBODY
LDX #TEMPN2 ;ARGLIST
JSR GTTULN ;GET_ULINE (ARG_LIST,FBODY,TRUE)
LDY #$04 ;(SF_FORMAT = 4.)
LDA UFRMAT
STA (FRAME),Y ;(PUTBAR)
LDY #$06 ;(SF_UFUN = 6.)
LDA CURTOK
STA (FRAME),Y
INY
LDA CURTOK+1
STA (FRAME),Y ;(PUTBAR)
LDY #$00
LDA (FUNCT),Y
CMP FRAME
BNE XTALWB
INY
LDA (FUNCT),Y ;(GET_FFRAME)
CMP FRAME+1
BNE XTALWB
XTALWA: LDA TEMPN2+1
BEQ XTLWAE
XTALW1: JSR PTVTST
LDY #$00
LDA (TEMPN2),Y
STA TEMPN4 ;VAR_NAME
INY
LDA (TEMPN2),Y
STA TEMPN4+1 ;(GETTOK)
LDX #TEMPN2
JSR TTKADV
LDY #$00
LDA (TEMPN5),Y
STA TEMPN1
INY
LDA (TEMPN5),Y
STA TEMPN1+1 ;(GETBAR)
JSR PTRDEC
LDX #TEMPN1
LDY #TEMPN4
JSR PUTVAL
JMP XTALWA
XTLWAE: LDY #$0E ;(SF_NUMBER_BINDINGS = 14.)
LDA TEMPN3
STA (FRAME),Y
JMP XTAIL4
XTALWB: LDA TEMPN2+1
BEQ XTLWBE
XTALW2: JSR PTVTST
LDY #$00
LDA (TEMPN2),Y
STA TEMPN4
INY
LDA (TEMPN2),Y
STA TEMPN4+1 ;(GETTOK)
LDX #TEMPN2
JSR TTKADV
LDY #TEMPN4
LDX #TEMPN1
JSR GETVAL
LDX #TEMPN1
JSR PUSHP
LDY #$00
LDA (TEMPN5),Y
STA TEMPN1
INY
LDA (TEMPN5),Y
STA TEMPN1+1 ;(GETBAR)
JSR PTRDEC
LDX #TEMPN1
LDY #TEMPN4
JSR PUTVAL
LDX #TEMPN4
JSR PUSHP
JMP XTALWB
XTLWBE: LDY #$00
LDA (FUNCT),Y
STA TEMPN1
INY
LDA (FUNCT),Y
STA TEMPN1+1 ;(GET_FFRAME)
LDX #TEMPN1
JSR PUSHP
LDX FUNCT
LDY FUNCT+1
INX
BNE XTAIL5
INY
XTAIL5: JSR PUSH ;PUSH (FUNCT+1)
LDY #$00
LDA FRAME
STA (FUNCT),Y
INY
LDA FRAME+1
STA (FUNCT),Y ;(PUT_FFRAME)
LDY #$0E
SEC ;Carry added in (BINDINGS + NARGS + 1)
LDA TEMPN3
ADC NARGS
STA (FRAME),Y
LDA SP
STA XFRAME
LDA SP+1
STA XFRAME+1 ;XFRAME := SP (right above last binding pair)
XTAIL4: JSR INCVSP
JMP UF1
.PAGE
STPTR1: LDA NARGS
ASL A
STA TEMPNH
CLC
LDA VSP
ADC TEMPNH
STA TEMPN5
LDA VSP+1
ADC #$00
STA TEMPN5+1 ;POINTR := VSP + (NARGS * 2)
RTS
PTVTST: LDA VSP+1
CMP TEMPN5+1
BNE SBHAK1
LDA VSP
CMP TEMPN5
BNE SBHAK1
PTVBUG: JSR SYSBUG ;Error if POINTER = VSP
PTRDEC: SEC
LDA TEMPN5
SBC #$02
STA TEMPN5
BCS SBHAK1
DEC TEMPN5+1 ;POINTR := POINTR - 2
SBHAK1: RTS
INCVSP: LDA NARGS
ASL A
STA TEMPNH
CLC
LDA VSP
ADC TEMPNH
STA VSP
BCC INCVE
INC VSP+1 ;VSP := VSP + NARGS * 2
INCVE: RTS
.PAGE
.SBTTL Reader and Tokenizer
READLN: STX TEMPX2 ;Input line pointer location
BNE REDLN1 ;(Always)
PRDLIN: STX TEMPX2
LDA EDSW
BEQ PRD2
LDA #EPRMPT ;Edit-mode prompt
BNE PRD3
PRD2: LDA #QPRMPT ;Reqular prompt
PRD3: JSR TPCHR
REDLN1: JSR GETLN ;Get a line into the Line buffer
STX TEMPN7
PRDLNX: LDY #$00
STY TEMPN8 ;List-nesting counter
STY TEMPN8+1 ;Character buffer pointer
STY CELPTR
STY CELPTR+1
LDX TEMPX2
STY $00,X ;Initialize ANS to Lnil
STY $01,X
INY
STY PRDFLG
LDA #RDL1&$FF ;Error return address
STA ERRRET
LDA #RDL1^
STA ERRRET+1
TSX
STX RETADR
LDA #NEWLIN
STA TEMPX2+1 ;Current cell type
RDLNW: LDA TEMPN8+1 ;Loop processes line, token by token
CMP TEMPN7
BNE TGTTOK ;Process the next token
RDLNWE: LDA TEMPN8 ;Done, close all lists
BEQ RDL1A
RDL1A1: LDA OUTDEV
BNE RDL1A2
LDA #'] ;Close the list (unless non-default output)
RDL1A2: JSR TPCHR
LDX #TEMPN1
JSR POP ;Discard pushed list pointers
DEC TEMPN8 ;Decrement list nesting counter
BNE RDL1A1
JSR BREAK1
RDL1A: LDY #$00 ;Y zero means OK
BEQ RDL1B ;(Always)
RDL1: LDY #$01 ;Y nonzero means error
RDL1B: LDA #$00
STA CELPTR
STA CELPTR+1
STA PRDFLG
RSTERR: LDX #$00 ;General reset-error routine
STX RETADR
LDX #ERROR1&$FF
STX ERRRET
LDX #ERROR1^
STX ERRRET+1
RTS
TGTTOK: LDA #$00
STA ANSN3 ;No typecode yet (for SLFDLP)
STA TEMPN7+1 ;Funny-pname if non-zero
STA TEMPN4+1 ;Indicates quoted atom if non-zero
LDX TEMPN8+1
TGT1: LDA LINARY,X
CMP #$20
BNE TGT2
INX
CPX TEMPN7
BNE TGT1 ;Skip spaces
BEQ RDLNWE
TGT2: STX TEMPN8+1
CMP #']
BEQ TKRBR
PHA
JSR ALLSTC
PLA
CMP #'[
BEQ TKLBR
JSR SLFDLP
BCC TKNDL
STA TEMPN5
INC TEMPN8+1
LDX #$00
STX TEMPN5+1
LDY #TEMPN5 ;Cons up a pname
LDA #TEMPN6
STA ANSN
LDA #STRING
JSR CONS
LDA #ATOM
STA ANSN3
JMP ADDTOK
TKLBR: INC TEMPN8 ;Start list - increment list nesting counter
INC TEMPN8+1 ;Skip to next character
LDX #CELPTR
JSR PUSHP ;Push the list-pointer cell
LDA #NEWLST
STA TEMPX2+1 ;Next cell allocated will be New-list type
JMP RDLNW ;Continue processing line
TKRBR: DEC TEMPN8 ;End list - decrement list nesting counter
BMI TKRBR1 ;Error if unbalanced brackets
INC TEMPN8+1 ;Skip to next character
LDX #CELPTR
JSR POP ;Pop list pointer
LDA #REGCEL
STA TEMPX2+1
JMP RDLNW ;Continue processing line
TKRBR1: JSR RSTIO ;Reset I/O to master drivers
LDX #RDRER2&$FF
LDY #RDRER2^
JSR PRTSTR ;Print "You have mismatched brackets" error
JMP RDL1 ;Error escape
TKNDL: CMP #'"
BNE TGT3A
INC TEMPN4+1 ;Quoted atom
INC TEMPN8+1 ;Skip to next character
LDA #QATOM
STA ANSN3
JMP TGT3B1 ;Check for funny-pname
TGT3A: CMP #$27 ;(Single Quote)
BNE TGT3B
INC TEMPN8+1 ;Skip to next character
INC TEMPN7+1 ;Token is a funny_pname
TKAORL: LDA #ATOM ;Token is an Atom or Label
STA ANSN3
JMP TKATOM ;Tokenize it
TGT3B: CMP #':
BNE TKAORL
INC TEMPN8+1 ;Dotted atom, skip to next character
LDA #DATOM
STA ANSN3
TGT3B1: LDX TEMPN8+1
LDA LINARY,X
CMP #$27
BNE TKATOM
INC TEMPN7+1 ;Token is funny-pname
INC TEMPN8+1 ;Skip to next character
TKATOM: LDX TEMPN8+1
CPX TEMPN7 ;Check for empty word at end-of-line
BEQ EMPTWD
LDA TEMPN7+1
BNE NOTNUM ;Funny_pname, not fixnum then
TKATM2: LDA LINARY,X
CMP #$20 ;Check for empty word inside line
BNE TKATM1
EMTWD1: INC TEMPN8+1 ;Skip space if necessary
EMPTWD: LDA #$00 ;Empty word, link Lnil node onto input line
STA TEMPN6
STA TEMPN6+1
JMP ADDTOK ;Link up token and continue
TKATM1: JSR CLRNG1 ;Attempt to compute numerical value, clear indicators
ATM1: STX TEMPN2 ;Save temporary character pointer
CPX TEMPN7
BEQ ATM2 ;End of line encountered, must be numerical
LDA LINARY,X
JSR SLFDLP
BCS ATM2 ;Self delimiter encountered, must be numerical
JSR CNUML1 ;Process the next digit
BCC NOTNUM ;Carry clear means not a number
LDX TEMPN2
INX ;Get next digit
JMP ATM1
ATM2: STX TEMPN2 ;All characters processed - save character pointer
JSR CNUML2 ;Finish numerical processing
BCC NOTNUM
LDX TEMPN2
STX TEMPN8+1 ;Numerically ok, reset real charcater pointer
LDX #TEMPN6
STX ANSN
LDX #NARG1+2 ;High word
LDY #NARG1 ;Low word
JSR CONS ;Cons a numerical cell with the value in it
LDY #$00
LDA TEMPN6
STA (CELPTR),Y ;Link the cell on to the input line
INY
LDA TEMPN6+1
STA (CELPTR),Y
JMP RDLNW ;Continue processing line
NOTNUM: LDX #TEMPX1 ;Not a fixnum - cons up a pname (original pointer)
LDA #$00
STA TEMPN6 ;Zero pointer in case it's nil
STA TEMPN6+1
STA ANSNX ;Indicates end of pname if non-zero
PHA ;First time around, push zero
BEQ NXTCHS ;(Always)
NXTTWO: LDA ANSNX ;Next two characters
BNE ADDTOK ;Link up token if end of pname
LDA #$02
PHA ;Not first time around, push 2
LDX #TEMPN5 ;Next pointer
NXTCHS: STX ANSN
LDX TEMPN8+1
CPX TEMPN7
BEQ ADDTK1 ;Finish token (end of line), even no. chars.
LDA LINARY,X
STA TEMPN1 ;First character in pair
JSR SLFDLP
BCS ADDTK2 ;Finish token (delimiter hit), even no. chars.
INX ;Skip to next character
CPX TEMPN7
BEQ FINTK1 ;Finish token (end of line), odd no. chars.
LDA LINARY,X
STA TEMPN1+1 ;Second character in pair
JSR SLFDLP
BCS FINTK1 ;Finish token (delimiter hit), odd no. chars.
INX
BCC CNSSTR ;(Always) Cons new pair on to pname string
FINTK1: LDA #$00
STA TEMPN1+1 ;Odd no. chars. in pname, zero last character
INC ANSNX ;Indicates end of pname
CNSSTR: STX TEMPN8+1 ;Skip the last character (if not delimiter)
LDY #TEMPN1
LDX #$00
LDA #STRING
JSR CONS ;Cons up the new pname pair
PLA
TAY ;0 first time, 2 otherwise
BNE NTFRST
LDA TEMPX1
STA (CELPTR),Y ;(Linking garbage-collect-protects it)
STA TEMPN6 ;Atom pointer
INY
LDA TEMPX1+1
STA (CELPTR),Y
STA TEMPN6+1
JMP NXTTWO ;Continue making the pname
NTFRST: LDA TEMPN5 ;Link cell onto pname string
TAX
STA (TEMPX1),Y
INY
LDA TEMPN5+1
STA (TEMPX1),Y ;(RPLACD)
STA TEMPX1+1
STX TEMPX1
JMP NXTTWO ;Continue making the pname
ADDTK2: STX TEMPN8+1 ;In case colon or quote skipped
ADDTK1: PLA ;Pop chain indicator if loop exit
ADDTOK: LDX #TEMPN6
LDY #TEMPX1
JSR INTERN ;Intern atom
ATM12B: LDA ANSN3
CMP #ATOM
BEQ ATM12A
LDX #TEMPX1
JSR PUTTYP ;Give atom a type if not Atom
ATM12A: LDY #$00
LDA TEMPX1
STA (CELPTR),Y ;Link atom onto input line
INY
LDA TEMPX1+1
STA (CELPTR),Y
LDA TEMPN7+1
BEQ NXTE
LDX #TEMPX1
JSR PTSPNM ;Put-strange-pname if funny-pname indicated
NXTE: JMP RDLNW ;Continue processing line
ALLSTC: LDA #TEMPN ;Allocate a new list cell
STA ANSN
LDA #$00
TAX
TAY
JSR CONS ;(Type list)
LDY #$00
LDA TEMPX2+1
CMP #NEWLIN
BNE ALSTC1
LDX TEMPX2 ;New line, ANS pointer points to cell
LDA TEMPN
STA $00,X
LDA TEMPN+1
STA $01,X
BNE ALSTC3 ;(Always)
ALSTC1: CMP #NEWLST
BEQ ALSTC4 ;For new-list, rplaca onto input line
INY ;Regular cell, link onto input line
INY
ALSTC4: LDA TEMPN
STA (CELPTR),Y ;Rplaca or Rplacd for new-list or regular-cell
INY
LDA TEMPN+1
STA (CELPTR),Y
ALSTC3: LDA TEMPN
STA CELPTR ;New input line end pointer
LDA TEMPN+1
STA CELPTR+1
LDA #REGCEL
STA TEMPX2+1 ;Next cell allocated will be regular-cell
RTS
.PAGE
SLFDLP: LDY TEMPN7+1 ;Checks for self-delimiter
BEQ SLF2 ;Not funny-pname
CMP #$27 ;If funny-pname, look for quote
BNE DIGN ;Not delimiter if no quote
INX
LDA LINARY,X
CMP #$27 ;Look for pair of quotes
BEQ DIGN ;If pair, skip over one, not delimiter
JMP DIGY ;If no pair, the quote is a delimiter, skip it
SLF2: LDY TEMPN4+1 ;Check for quoted atom
BEQ SLF1
CMP #$20 ;Quoted atoms can be terminated by a space,
BEQ DIGY
CMP #'] ;or a closing bracket,
BEQ DIGY
CMP #') ;or a closing parenthesis.
BEQ DIGY
BNE DIGN ;(Always)
SLF1: LDY ANSN3 ;Check for type Atom
CPY #ATOM
BNE SLF3
CMP #': ;If Atom, check for colon (for Label atom)
BNE SLF3
INX ;If colon, skip over it and change type to Latom
LDY #LATOM
STY ANSN3
JMP DIGY
SLF3: CMP #$20 ;Compare character to all delimiters
BEQ DIGY
CMP #'<
BEQ DIGY
CMP #'>
BEQ DIGY
CMP #'=
BEQ DIGY
CMP #$3B ;(Semicolon)
BEQ DIGY
CMP #')
BEQ DIGY
CMP #'(
BEQ DIGY
CMP #'+
BEQ DIGY
CMP #'-
BEQ DIGY
CMP #'*
BEQ DIGY
CMP #'/
BEQ DIGY
CMP #']
BEQ DIGY
CMP #'[
BNE DIGN
DIGY: SEC ;Carry set means true
RTS
DIGITP: CMP #': ;Checks to see if character is a digit (0-9)
BCC DIGP1
DIGN: CLC ;Carry clear means not true
RTS
DIGP1: CMP #'0 ;(Sets carry correctly)
RTS
.PAGE
.SBTTL Number Parsing Utilities:
;Process a character, number-building
CNUML1: LDX TEMPN5 ;Flonum indicator
BNE NFLDIG ;Process next flonum character
JSR DIGITP ;Still a fixnum
BCC NTFIX1 ;Not a digit, isn't a fixnum then
INC TEMPN6+1 ;Indicate presence of digit
PHA ;Save digit
JSR NMROL1 ;Multiply by 2 first
BMI NTFIX3 ;Not a fixnum if value overflow
LDY #A1L
JSR XN1TOY ;Copy doubled number
JSR NMROL1 ;Multiplied by 4
BMI NTFIX2
JSR NMROL1 ;Multiplied by 8
BMI NTFIX2
JSR ADDNUM ;Multiplied by 10.
BMI NTFIX2
PLA
PHA
JSR ADDDIG ;Add value of current digit to subtotal
BMI NTFIX2
PLA ;Retrieve digit
NUMOK: SEC ;Indicate number OK
RTS
NTFIX2: LDY #A1L
JSR XYTON1 ;Fixnum overflow, doubled number is in A1L-A2H, transfer
NTFIX3: JSR NMROR1 ;Halve it
INC TEMPN5 ;Indicate flonum (1)
JSR FLOTN1 ;Convert to floating pt.
PLA ;Get the digit back
FADNML: INC TEMPN6+1 ;Indicate prescence of digit
JSR MULN10 ;Shift number before adding
JSR FADDIG ;Add it to the number (left of point)
JMP NUMOK
FNDIGD: INC TEMPN6+1 ;Indicate presence of digit
LDX TEMPX1+1 ;See if it's significant
BNE NUMOK ;No, ignore it
JSR FADDGN ;Yes, add it to the number (right of point)
JMP NUMOK
NFLDIG: CPX #$02 ;New flonum digit
BNE NFLDG1
JSR DIGITP ;In decimal mode
BCS FNDIGD ;If digit, add to number
BCC FCKEN ;Else check for E or N
NFLDG1: CPX #$03 ;See if exponent mode
BEQ FXDIG
JSR DIGITP ;Normal mode, check for digit
BCS FADNML ;Add it if it is, else
NTFIX1: CMP #'. ;See if digit is legal
BEQ FMDECI
FCKEN: CMP #'E ;Check for E or N
BEQ FXPOS
CMP #'N
BNE NTNUM
INC TEMPN5+1 ;Indicate negative exponent
FXPOS: LDA TEMPN6+1
BEQ NTNUM ;Check that a digit was typed (so ".Ex" is illegal)
LDX TEMPN5
LDA #$03
STA TEMPN5 ;Indicate exponent mode (3)
LDA #$00
STA TEMPN6+1 ;Now, indicates exponent digit presence
BEQ MAKFLO ;(Always)
FXDIG: JSR DIGITP ;Exponent mode, must be a digit
BCC CNMR
INC TEMPN6+1 ;Indicate presence of exponent digit
JSR INCEXP ;Exponentiate by vA
JMP NUMOK
FMDECI: LDX TEMPN5
LDA #$02
STA TEMPN5 ;Indicate decimal mode (2)
MAKFLO: TXA
BNE NUMOK ;Exit OK if flonum, else...
JSR FLOTN1 ;make it one
JMP NUMOK
NTNUM: CLC ;Not a number
CNMR: RTS
;Number gobbled, finish number-building.
CNUML2: LDX TEMPN5
BEQ CNUM2X
LDA TEMPN6+1 ;If floating pt., make sure that there's a digit
BEQ NTNUM
LDA TEMPN6 ;Check placeholder counter
BEQ CNUM2A
CNUM2B: JSR FDVD10 ;Divide by 10. until back to correct decimal point location
DEC TEMPN6
BNE CNUM2B
CNUM2A: LDA TEMPX1 ;Check for exponent
BEQ CNUM2R
LDA TEMPN5+1 ;Check its sign
BNE CNUM2D
CNUM2C: JSR MULN10 ;Multiply by 10 according to (positive) exponent value
BCS NTNUM
DEC TEMPX1
BNE CNUM2C
BEQ CNUM2R ;(Always)
CNUM2D: JSR FDVD10 ;Divide by 10 according to (negative) exponent value
DEC TEMPX1
BNE CNUM2D
CNUM2R: LDA #FLO
SEC
RTS
CNUM2X: LDA #FIX
SEC
RTS
CLRNG1: LDA #$00
STA NARG1 ;Initialize number to 0
STA NARG1+1
STA NARG1+2
STA NARG1+3
STA TEMPN5 ;Flonum indicator
STA TEMPN5+1 ;Exponent sign indicator
STA TEMPN6 ;Fraction decimal shift (placeholder) counter
STA TEMPN6+1 ;Indicates the presence of a mant. or exp. digit
STA TEMPX1 ;Exponent counter
STA TEMPX1+1 ;Significant digit indicator
RTS
NMROL1: ASL NARG1 ;Double number in NARG1
ROL NARG1+1
ROL NARG1+2
ROL NARG1+3
RTS
NMROR1: LSR NARG1+3 ;Halve number in NARG1
ROR NARG1+2
ROR NARG1+1
ROR NARG1
RTS
XN1TOY: LDX #$FC
XN1YL: LDA NARG1+4,X
STA $00,Y
INY
INX
BMI XN1YL
RTS
XYTON1: LDX #$FC
XYN1L: LDA $00,Y
STA NARG1+4,X
INY
INX
BMI XYN1L
RTS
XYTON2: LDX #$FC
XYN2L: LDA $00,Y
STA NARG2+4,X
INY
INX
BMI XYN2L
RTS
XN2TOY: LDX #$FC
XN2YL: LDA NARG2+4,X
STA $00,Y
INY
INX
BMI XN2YL
RTS
ADDNUM: LDX #$FC ;Add A1L to NARG1
CLC
ADDNML: LDA A1L+4,X
ADC NARG1+4,X
STA NARG1+4,X
INX
BMI ADDNML
TAX
RTS
ADDDIG: SEC ;Add Ascii digit in A to NARG1
SBC #'0
CLC
LDX #$FC
BNE ADDL1A ;(Always)
ADDLP1: LDA #$00
ADDL1A: ADC NARG1+4,X
STA NARG1+4,X
INX
BMI ADDLP1
TAX
RTS
FADDGX: SEC
SBC #'0 ;Get the digit's value
STA NARG2 ;Add A to NARG1, floating pt.
LDA #$00
STA NARG2+1 ;Put A in NARG2, make it floating pt., and add
STA NARG2+2
STA NARG2+3
JSR FLOTN2
JMP FADD
FADDIG: JSR FADDGX
BCS NUMOVF
RTS
FADDGN: PHA ;Add decimal digit to floating pt. number
LDY #A1L
JSR XN1TOY ;Save NARG1
JSR MULN10 ;Multiply number by 10
BCS FADDG1 ;Overflow, digit will be insignificant
PLA ;Get digit
JSR FADDGX ;and add it
BCS FADDG2 ;If overflow, digit not significant
INC TEMPN6 ;Else increment placeholder counter
RTS
FADDG1: PLA ;Discard digit
FADDG2: INC TEMPX1+1 ;Indicate no more significant digits, restore NARG1
LDY #A1L
JMP XYTON1
MULN10: LDX #$03 ;Multiply NARG1 by 10., floating pt.
MLN10L: LDA FLT10,X ;Put 10. (floating pt. constant) in NARG2
STA NARG2,X
DEX
BPL MLN10L
JMP FMUL ;and multiply (calling procedure checks for overflow)
FDVD10: LDX #$03 ;Divide NARG1 by 10., floating pt.
FDV10L: LDA FLT10,X ;Put 10. (floating pt. constant) in NARG2
STA NARG2,X
DEX
BPL FDV10L
JMP FDIV
INCEXP: SEC
SBC #'0
TAY ;Multiply exponent by ten and add new digit
ASL TEMPX1
BMI NUMOVF
LDA TEMPX1
ASL A
BMI NUMOVF
ASL A
BMI NUMOVF
ADC TEMPX1
BMI NUMOVF
STA TEMPX1
TYA
ADC TEMPX1
BMI NUMOVF
STA TEMPX1
RTS
NUMOVF: PLA ;Overflow, pop past subroutine
PLA
CLC ;Indicate not a number
RTS
.PAGE
.SBTTL Initializations
INITLZ: LDA #$00
STA GRPHCS
STA EDSW
STA EDBOD
STA EDBOD+1
JSR RSTIO ;Set I/O to to default
JSR RESETT ;Clear screen, etc.
JSR CLRMRK ;Reset G.C. Array (Typebase bits)
LDA #BASARY&$FF
STA TEMPN
LDA #BASARY^
STA TEMPN+1
LDY #$00
TYA ;Clear the SARRAY, 4 at a time
CLRLP1: STA (TEMPN),Y
INC TEMPN
BNE ADHAK4
INC TEMPN+1
ADHAK4: LDX TEMPN
CPX #PDLBAS&$FF ;PDL starts right after S_ARRAY
BNE CLRLP1
LDX TEMPN+1
CPX #PDLBAS^
BNE CLRLP1
;falls through
.PAGE
;falls in
REINIT: LDX #$00
STX NNODES ;Node allocation counter
STX NNODES+1
STX PODEFL+1
JSR CLRCBF
LDA #BASARY&$FF
STA SARTOP
LDA #BASARY^
STA SARTOP+1
LDA #PDLBAS&$FF
STA SP
LDA #PDLBAS^
STA SP+1
LDA #VPDLBA&$FF
STA VSP
LDA #VPDLBA^
STA VSP+1
LDA #EDBUF&$FF ;Tell RETRIEVE that buffer is not retrievable
STA ENDBUF
LDA #EDBUF^
STA ENDBUF+1
LDA #BIGBAS&$FF ;(FIRST_NODE)
STA SOBLST
STA SOBTOP
LDA #BIGBAS^
STA SOBLST+1 ;SOBLIST := FIRST_NODE
STA SOBTOP+1 ;SOBTOP is SOBPTR for now
LDA #PRMTAB&$FF ;Points to first byte of Primitive-table
STA TEMPN
LDA #PRMTAB^
STA TEMPN+1
SOBLP1: JSR SOBST1
LDA TEMPN+1
CMP #VPRMTB^
BNE SOBLP1
LDA TEMPN
CMP #VPRMTB&$FF
BNE SOBLP1
SEC
LDA SOBTOP
SBC #$08
STA TEMPN1 ;TEMPN1 is SOBTOP - 8, for comparison
LDA SOBTOP+1
SBC #$00
STA TEMPN1+1
SBVLP1: LDA GETRM2 ;Ghost-memory bank 2, VPrim table
INC BANK4K
LDY #$00
LDA (TEMPN),Y
STA ANSN ;ANSN is INDEX constant
INY
LDA (TEMPN),Y
STA TEMPN3+1 ;TEMPN3 is Primitive's pointer address
INY
LDA (TEMPN),Y
STA TEMPN3
INY
LDA (TEMPN),Y
STA ANSN3 ;ANSN3 is INSTANCE counter
LDA GETRM1 ;Ghost-memory disable
LDA GETRM1
DEC BANK4K
CLC
LDA TEMPN
ADC #$04
STA TEMPN
BCC ADHAK8
INC TEMPN+1
ADHAK8: LDA #BBASX&$FF
STA TEMPN2 ;TEMPN2 is temporary VARNAM pointer
LDA #BBASX^
STA TEMPN2+1
SBVRW: LDA TEMPN1+1
CMP TEMPN2+1
BNE SBVRW1
LDA TEMPN1
CMP TEMPN2
BNE SBVRW1
JSR SYSBUG
SBVRW1: CLC
LDA TEMPN2
ADC #$04
STA TEMPN2
BCC ADHAK9
INC TEMPN2+1
ADHAK9: LDY #$02
LDA (TEMPN2),Y
STA TEMPNH
INY
LDA (TEMPN2),Y
STA TEMPNH+1 ;(CDR)
DEY
LDA (TEMPNH),Y
CMP ANSN
BNE SBVRW
DEC ANSN3
BNE SBVRW
SBVRWE: LDY #$00
LDA TEMPN2 ;Put TEMPN2 in the right variable
STA (TEMPN3),Y
INY
LDA TEMPN2+1
STA (TEMPN3),Y
LDA TEMPN+1
CMP #VPRMTE^
BNE SBVLPJ
LDA TEMPN
CMP #VPRMTE&$FF
BEQ SBVLL1
SBVLPJ: JMP SBVLP1
SBVLL1: CLC
LDA SOBTOP
STA FRLIST
ADC #$04
STA TEMPN
LDA SOBTOP+1
STA FRLIST+1
ADC #$00
STA TEMPN+1
LDY #$02
LDA #$00
STA (SOBTOP),Y
INY
STA (SOBTOP),Y ;RPLACD (SOBTOP,LNIL)
DEY
RINLP2: LDA FRLIST
STA (TEMPN),Y
INY
LDA FRLIST+1
STA (TEMPN),Y ;(RPLACD)
DEY
CLC
LDA TEMPN
STA FRLIST
ADC #$04
STA TEMPN
LDA TEMPN+1
STA FRLIST+1
ADC #$00
STA TEMPN+1
CMP #SINODS^ ;(Ptr. to byte after last node)
BNE RINLP2
LDA TEMPN
CMP #SINODS&$FF
BNE RINLP2
LDX #$00
STX TEMPN1+1
INX
STX TEMPN1 ;Set to Novalue for MKSFUN
LDX #UNSUM
LDA #IUNSUM
JSR MKSFUN
LDX #UNDIF
LDA #IUNDIF
JSR MKSFUN
LDA #$00 ;(LNIL)
JSR CLMK5
STA CELPTR
STA CELPTR+1 ;CELL_PTR := LNIL
STA OBLIST+1 ;OBLIST := LNIL
STA SIZE1
STA SIZE1+1 ;SIZE1 := 0
STA SIZE2
STA SIZE2+1 ;SIZE2 := 0
LDA #'U
STA TEMPN2
LDA #'E
STA TEMPN2+1
LDX #$00
LDY #TEMPN2
LDA #TEMPN3
STA ANSN
LDA #STRING
JSR CONS ;"UE" of TRUE
LDA #'T
STA TEMPN2
LDA #'R
STA TEMPN2+1
LDY #TEMPN2
LDX #TEMPN3
STX ANSN
LDA #STRING
JSR CONS ;"TR" of TRUE
LDX #TEMPN3
LDA #LTRUE
STA ANSN2
JSR INTRNX
LDX #$00
STX TEMPN2+1
LDA #'E
STA TEMPN2
LDY #TEMPN2
LDA #TEMPN3
STA ANSN
LDA #STRING
JSR CONS ;"E" of FALSE
LDA #'L
STA TEMPN2
LDA #'S
STA TEMPN2+1
LDY #TEMPN2
LDX #TEMPN3
STX ANSN
LDA #STRING
JSR CONS ;"LS" of FALSE
LDA #'F
STA TEMPN2
LDA #'A
STA TEMPN2+1
LDY #TEMPN2
LDX #TEMPN3
STX ANSN
LDA #STRING
JSR CONS ;"FA" of FALSE
LDX #TEMPN3
LDA #LFALSE
STA ANSN2
JMP INTRNX
CLMK5: STA MARK5
STA MARK5+1 ;MARK5 := LNIL
CLMK4: STA MARK4
STA MARK4+1 ;MARK4 := LNIL
CLMK3: STA MARK3
STA MARK3+1 ;MARK3 := LNIL
CLMK2: STA MARK2
STA MARK2+1 ;MARK2 := LNIL
CLMK1: STA MARK1
STA MARK1+1 ;MARK1 := LNIL
RTS
.PAGE
SOBST1: LDY #$01
TYA
DEY
STA (SOBTOP),Y
TYA
INY
STA (SOBTOP),Y ;(RPLACA)
INY
LDA SARTOP
STA (SOBTOP),Y
INY
LDA SARTOP+1
STA (SOBTOP),Y ;(RPLACD)
LDA #SATOM
LDX #SOBTOP
JSR PUTTYP
LDA GETRM2 ;Ghost-memory bank 2, Prim table
INC BANK4K
LDY #$00
LDA (TEMPN),Y
STA (SARTOP),Y
INY
LDA (TEMPN),Y
STA (SARTOP),Y
INY
LDA (TEMPN),Y
STA (SARTOP),Y
SBST1A: INY
LDA (TEMPN),Y
STA (SARTOP),Y
CMP #$20 ;See if the last byte was transferred
BNE SBST1A ;Yes.
LDA GETRM1 ;Ghost-memory bank 2 disable
LDA GETRM1
DEC BANK4K
LDA #$00
STA (SARTOP),Y
INY
CLC
TYA
ADC SARTOP
STA SARTOP
BCC ADHAK5
INC SARTOP+1
ADHAK5: CLC
TYA
ADC TEMPN
STA TEMPN
BCC ADHAK6
INC TEMPN+1
ADHAK6: CLC
LDA SOBTOP
ADC #$04
STA SOBTOP
BCC ADHAK7
INC SOBTOP+1
ADHAK7: INC NNODES
BNE ADHK7A
INC NNODES+1
ADHK7A: RTS
.PAGE
.SBTTL Miscellaneous and Evaluator Utility Routines
; Toplevel Evaluator Utility Routines:
CHKLNN: LDY #$00
LDA (TOKPTR),Y
STA TEMPN
INY
LDA (TOKPTR),Y
STA TEMPN+1 ;(CAR)
LDX #TEMPN
JMP GETTYP
EDLINE: TYA
BNE GETHIG ;Y nonzero for default line number
LDA (ILINE),Y
STA TEMPN4 ;TEMPN4 is the line pointer
INY
LDA (ILINE),Y
STA TEMPN4+1 ;(car line)
LDY #$02
LDA (TEMPN4),Y
BNE EDLERR
INY
LDA (TEMPN4),Y
BNE EDLERR
LDY #$00
LDA (TEMPN4),Y
TAX
INY
LDA (TEMPN4),Y
STA TEMPN4+1
BMI LINERR ;Line numbers limited to two bytes, positive
STX TEMPN4
BNE EDL1
TXA
BNE EDL1
LINERR: LDA #XILN ;"Illegal Line Number"
JMP ERROR
EDLERR: LDA #XLNTB ;"Line number too big"
JMP ERROR
GETHIG: LDA #$00
STA TEMPN4
STA TEMPN4+1
LDY #$02 ;get body pointer
LDA (EDBOD),Y ;skip args
STA TEMPN3 ;TEMPN3 is BODY ptr.
INY
LDA (EDBOD),Y
STA TEMPN3+1 ;(cdr body)
GTHW: LDA TEMPN3+1 ;if it ain't LNIL,
BEQ GTHE ;take the cdr again
LDY #$00
LDA (TEMPN3),Y
STA TEMPN2 ;TEMPN2 is Current Line
INY ;(car line) - put pointer
LDA (TEMPN3),Y
STA TEMPN2+1 ;to line num in TEMPN2
INY
LDA (TEMPN3),Y
TAX ;get (cdr body)
INY
LDA (TEMPN3),Y
STA TEMPN3+1
STX TEMPN3
LDY #$00
LDA (TEMPN2),Y
TAX
INY ;(car line) -- this one
LDA (TEMPN2),Y ;gets actual line number
STA TEMPN2+1
STX TEMPN2
LDA TEMPN4+1
CMP TEMPN2+1 ;old greatest line #
BCC GTH3 ;old < new - replace
BNE GTHW ;old > new, go back for next
LDA TEMPN4
CMP TEMPN2
BCS GTHW ;old > new -- just go back
GTH3: LDA TEMPN2 ;replace old highest line #
STA TEMPN4 ;with new highest line number
LDA TEMPN2+1
STA TEMPN4+1
JMP GTHW ;look for more
GTHE: CLC
LDA TEMPN4
ADC #LININC ;make default line number
STA TEMPN4
BCC EDL1
INC TEMPN4+1
BMI EDLERR
EDL1: LDY #$00 ;place line # in car of line
LDA TEMPN4
STA (ILINE),Y
INY
LDA TEMPN4+1
STA (ILINE),Y ;(RPLACA)
LDA #FLIST
LDX ANSN1
JSR PUTTYP
LDY #TEMPN4 ;NUMBER
LDX #EDBOD
LDA #TEMPN2 ;Line to be gotten
JSR FNDLIN
BCC PTLN1 ;Branch if not found
LDX ANSN1 ;POINTER
LDY #$00
LDA $00,X
STA (TEMPN2),Y
INY
LDA $01,X
STA (TEMPN2),Y ;(RPLACA)
RTS
PTLN1: LDY #$02
LDA (TEMPN2),Y
STA TEMPN3
INY
LDA (TEMPN2),Y
STA TEMPN3+1 ;(CDR)
LDY ANSN1
LDX #TEMPN3
STX ANSN
LDA #LIST
JSR CONS
LDY #$02
LDA TEMPN3
STA (TEMPN2),Y
INY
LDA TEMPN3+1
STA (TEMPN2),Y ;(RPLACD)
RTS
.PAGE
MKSFUN: LDY #$02
STA (SARTOP),Y
DEY
LDA #$08 ;(PREC = 8)
STA (SARTOP),Y
TYA ;(NARGS = 1)
DEY
STA (SARTOP),Y
TYA
LDY #$03
STA (SARTOP),Y
STX ANSN
LDX #SARTOP
LDY #TEMPN1 ;TEMPN1 Set to Novalue by the calling procedure
LDA #SATOM
JSR CONS
CLC
LDA SARTOP
ADC #$04
STA SARTOP
BCC ADHK11
INC SARTOP+1
ADHK11: RTS
.PAGE
; Frame Utility Routines:
POPFRM: JSR RSTBND
LDX #TLLEVS
JSR POP
SEC
LDA SP
SBC #$02 ;Skip SF_NUMBER_BINDINGS
STA SP
BCS PPFM2
DEC SP+1
PPFM2: LDX #TOKPTR
JSR POP
LDX #LINNUM
JSR POP
LDX #NEST
JSR POP
LDX #CURTOK
JSR POP
JSR POPB
STA UFRMAT
LDX #XFRAME
JSR POP
LDX #FRAME
JMP POP
RSTBND: LDA XFRAME
STA SP
LDA XFRAME+1
STA SP+1
LDY #$0E ;(SF_NUMBER_BINDINGS = 14.)
LDA (FRAME),Y
BEQ RSTBWE
STA ANSN ;(GETBAR)
RSTBW: LDX #TEMPN1
JSR POP
LDX #TEMPN
JSR POP
LDX #TEMPN
LDY #TEMPN1
JSR PUTVAL
DEC ANSN
BNE RSTBW
RSTBWE: RTS
.PAGE
; Stack Routines:
;PUSHP is given the location of a page-zero variable in X,
;and pushes the contents of the variable onto the LOGO stack.
PUSHP: LDY #$00
LDA $00,X
STA (SP),Y
INY
LDA $01,X
STA (SP),Y
CLC
LDA SP
ADC #$02
STA SP
BCC PSHP1
INC SP+1
PSHP1: RTS
;PUSH pushes onto the stack the sixteen-bit value in the X and Y registers.
PUSH: TYA
LDY #$01
STA (SP),Y
DEY
TXA
STA (SP),Y
CLC
LDA SP
ADC #$02
STA SP
BCC PSHP2
INC SP+1
PSHP2: RTS
;VPUSHP is given the address of a page-zero variable in X,
;and pushes the contents of that variable onto the Value stack.
VPUSHP: LDY #$00
LDA $00,X
STA (VSP),Y
INY
LDA $01,X
STA (VSP),Y
SEC
LDA VSP
SBC #$02
STA VSP
BCS VPSH1
DEC VSP+1
VPSH1: RTS
.PAGE
;POP pops a value off of the LOGO stack and into the page-zero variable
;whose address is in X.
POP: SEC
LDA SP
SBC #$02
STA SP
BCS POP1
DEC SP+1
POP1: LDY #$00
LDA (SP),Y
STA $00,X
INY
LDA (SP),Y
STA $01,X
RTS
;VPOP pops a value off of the Value stack and into the page-zero variable
;whose address is in X. Doesn't destroy X.
VPOP: CLC
LDA VSP
ADC #$02
STA VSP
BCC VPOP1
INC VSP+1
VPOP1: LDY #$00
LDA (VSP),Y
STA $00,X
INY
LDA (VSP),Y
STA $01,X
RTS
;POPB pops a one-byte value off of the LOGO stack and returns with it in A.
POPB: SEC
LDA SP
SBC #$02
STA SP
BCS POPB1
DEC SP+1
POPB1: LDY #$00
LDA (SP),Y
RTS
.PAGE
;STKTS1 tests to see if the LOGO stack test limit has been exceeded,
;and gives an error if so. It doesn't poll for interrupts.
STKTS1: LDA VSP+1
CMP SP+1
BCC STKTZ
BNE STKTR
SEC
LDA VSP
SBC SP
CMP #STKLIM
BCC STKTZ
STKTR: RTS
STKTZ: LDA #PDLBAS&$FF
STA SP
LDA #PDLBAS^
STA SP+1 ;Reset the stack for reader/tokenizer
LDX #XNSTOR ;(No Stack) "No storage left" zapcode
LDA #XZAP
JMP ERROR
;STKTST tests to see if the LOGO stack test limit has been exceeded,
;and gives an error if so. Polls for interrupts.
STKTST: JSR STKTS1
;falls through
;STPPEK is the polling routine for user interrupts.
;falls in
STPPEK: JSR TSTCHR
BCC PRTS
BIT KPCLR
CMP #STPKEY
BEQ STPPK1
CMP #PAUSKY
BEQ STPPKZ
CMP #LSTKEY
BEQ PRTS
CMP #FULCHR ;Full-screen graphics character
BEQ STPFUL
CMP #MIXCHR ;Mixed-screen graphics character
BEQ STPMIX
TAY ;Save character
SEC
LDA CHBUFR
SBC CHBUFS ;Check for buffer-full
AND #$3F
CMP #$01
BEQ BOFL ;Buffer overflow if next-free loc right before next-to-read
LDA CHBUFS
AND #$3F
TAX
TYA
STA CHBSTT,X ;Store character in buffer
INC CHBUFS ;Increment next-free-loc
PRTS: RTS
BOFL: JMP BELL ;Ding-dong if buffer overflow
STPPKZ: LDA #XBRK
JMP ERROR
STPPK1: LDX #ERROR1&$FF
LDY #ERROR1^
JSR PUSH
LDX #XSTOP ;Stop_key Zapcode
LDA #XZAP
JMP ERROR
STPFUL: LDA GRPHCS
BEQ PRTS
LDA $C052
RTS
STPMIX: LDA GRPHCS
BEQ PRTS
LDA $C053
RTS
.PAGE
; Atomic Value Routines:
GETVAL: LDA $00,Y ;Get value into X's pointer from Y's pointer
AND #$FC ;Strip off last two bits
STA TEMPNH
LDA $01,Y
STA TEMPNH+1
LDY #$00
LDA (TEMPNH),Y
STA $00,X
INY
LDA (TEMPNH),Y
STA $01,X ;(CAR)
RTS
PUTVAL: LDA $00,Y
AND #$FC
STA TEMPNH
LDA $01,Y
STA TEMPNH+1
LDY #$00
LDA $00,X
STA (TEMPNH),Y
INY
LDA $01,X
STA (TEMPNH),Y ;(RPLACA)
RTS
.PAGE
; Function Utility Routines:
GETFUN: STA ANSN ;Save ANS_FUNCT pointer
LDA $00,X
STA TEMPN ;Get OBJECT pointer
LDA $01,X
STA TEMPN+1
JSR GETTYP
LDX ANSN
LDY #$02
CMP #ATOM
BEQ GTFN1
CMP #SATOM
BEQ GTFN2
LDA #$00
STA $01,X
RTS
GTFN1: LDA (TEMPN),Y
PHA
INY
LDA (TEMPN),Y
STA TEMPN+1
PLA
STA TEMPN
LDY #$00
LDA (TEMPN),Y
PHA
INY
LDA (TEMPN),Y
STA $01,X
PLA
STA $00,X ;(CAR)
LDA #UFUN
RTS
GTFN2: LDA (TEMPN),Y
STA $00,X
INY
LDA (TEMPN),Y
STA $01,X ;(CDR)
LDA #SFUN
RTS
.PAGE
PUTFUN: STY ANSN
STX ANSN1
JSR GETTYP
CMP #ATOM
BEQ PTFN2
PTFN1: LDY ANSN1
JSR PTRYOK
LDA #XUBL
JMP ERROR
PTFN2: LDX ANSN1
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$02
LDA (TEMPNH),Y
TAX
INY
LDA (TEMPNH),Y
STA TEMPNH+1
STX TEMPNH ;(CDR)
LDX ANSN
LDY #$00
LDA $00,X
STA (TEMPNH),Y
INY
LDA $01,X
STA (TEMPNH),Y ;(RPLACA)
RTS
.PAGE
;GETPRC returns the precedence (in A) of the function in Y,
;given the funtype in X.
GETPRC: LDA #$05 ;Assume Ufun, precedence 5
CPY #UFUN
BEQ GPRCU
GPRCS: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$01
LDA (TEMPNH),Y
GPRCU: RTS
GETNGS: CMP #SFUN
BEQ GTNG2
GTNG1: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$04
LDA (TEMPNH),Y ;(GETBAR)
RTS
GTNG2: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$00
LDA (TEMPNH),Y
RTS
.PAGE
INFIXP: CMP #SFUN
BNE IFP1
LDA $01,X
BNE IFP2
IFP1: CLC ;Not infix
RTS
IFP2: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$02
LDA (TEMPNH),Y
CMP #INSUM
BEQ IFP3
CMP #INDIF
BEQ IFP3
CMP #INPROD
BEQ IFP3
CMP #INQUOT
BEQ IFP3
CMP #INGRTR
BEQ IFP3
CMP #INLESS
BEQ IFP3
CMP #INEQUL
BNE IFP1
IFP3: SEC ;Infix.
RTS ;Return with proper index in A
.PAGE
PTFTXT: STY ANSNX ;FUNTEXT
STA ANSN3 ;NARGS
STX TEMPN7 ;ATOMM
JSR GETTYP
CMP #ATOM
BEQ PTFTX2
LDY TEMPN7
LDA #XUBL
JMP ERROR
PTFTX2: LDX TEMPN7
LDA $00,X
STA TEMPNH ;TEMPNH is ATOMM
LDA $01,X
STA TEMPNH+1
LDY #$02
LDA (TEMPNH),Y
STA TEMPN5 ;TEMPN5 is CELL
INY
LDA (TEMPNH),Y
STA TEMPN5+1 ;(CDR)
LDY #$00
LDA (TEMPN5),Y
STA TEMPN6 ;TEMPN6 is FUNCT
INY
LDA (TEMPN5),Y
STA TEMPN6+1 ;(CAR)
BNE PTFTX3
LDX ANSNX ;FUNTEXT ptr.
LDA $00,X
STA MARK1
LDA $01,X
STA MARK1+1
LDA #$04
STA TEMPN8
LDA #$00
STA TEMPN8+1
LDY #TEMPN8
LDX #TEMPN6
JSR GETWDS
LDY #$01
LDA TEMPN6+1 ;FUNCT
BEQ PTFER
STA (TEMPN5),Y ;CELL
DEY
LDA TEMPN6
STA (TEMPN5),Y ;(RPLACA)
LDX #TEMPN6
LDA #UFUN
JSR PUTTYP
LDY #$06
LDX TEMPN7 ;ATOMM
LDA $00,X
STA (TEMPN6),Y
INY
LDA $01,X
STA (TEMPN6),Y ;(PUTBAR)
LDA #$00
STA MARK1
STA MARK1+1
PTFTX3: LDY #$00
TYA
STA (TEMPN6),Y
INY
STA (TEMPN6),Y ;(PUTBAR)
INY
LDX ANSNX
LDA $00,X ;FUNTEXT
STA (TEMPN6),Y
INY
LDA $01,X
STA (TEMPN6),Y ;(PUTBAR)
INY
LDX ANSN3 ;NARGS
LDA $00,X
STA (TEMPN6),Y
INY
LDA $01,X
STA (TEMPN6),Y ;(PUTBAR)
PTFTXE: RTS
PTFER: JMP CONSR ;(No Nodes, most likely) "No storage left" zapcode
.PAGE
UNFUNC: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$02
LDA (TEMPNH),Y
TAX
INY
LDA (TEMPNH),Y
STA TEMPNH+1
STX TEMPNH ;(CDR)
LDY #$00
LDA #$01
STA (TEMPNH),Y
TYA
INY
STA (TEMPNH),Y ;(RPLACA)
RTS
.PAGE
; Nodespace Routines:
;CONS creates a new node from the freelist. X points to the Cdr,
;Y to the Car, ANSN to the node's pointer, and A holds the typecode.
CONS: PHA
CMP #LIST
BEQ FCONS
CMP #STRING
BEQ SCONS
CMP #FIX
BEQ NCONS
CMP #FLO
BEQ NCONS
CMP #ATOM
BEQ SCONS
CMP #FLIST
BEQ SCONS
CMP #SATOM
BEQ S1CONS
JSR SYSBUG
;"F" CONS - Protect both CAR and CDR. Used for Lists.
FCONS: JSR XCONS
LDX TEMPNH
JSR VPUSHP ;VPUSHP Xcar
LDX TEMPNH+1
JSR VPUSHP ;VPUSHP Xcdr
JSR GARCOL
CLC ;Reset the VPDL
LDA VSP
ADC #$04
JMP SCONS2
;"N" CONS - Doesn't protect either CAR or CDR. Used for numbers.
NCONS: JSR XCONS
JSR GARCOL
JMP CONSG1
;"S" CONS - Protects only CDR. Used for strings.
SCONS: JSR XCONS
LDX TEMPNH+1
JSR VPUSHP ;VPUSHP Xcdr
JSR GARCOL
JMP SCONS1 ;Reset the VPDL
;"S1" CONS - Protects only CAR. Used for Satoms.
S1CONS: JSR XCONS
LDX TEMPNH
JSR VPUSHP
JSR GARCOL
SCONS1: CLC
LDA VSP
ADC #$02
SCONS2: STA VSP
BCC CONSG1
INC VSP+1
BNE CONSG1 ;(Always)
XCONS: STY TEMPNH ;TEMPNH.L is XCAR
STX TEMPNH+1 ;TEMPNH.H is XCDR
LDA FRLIST+1
BEQ XCONSG
LDA PRDFLG
BNE XCONS2 ;Don't check limit for READ_LINE callers
LDA NNODES+1
CMP #NODLIM^
BCC XCONS2
BNE XCONSG
LDA NNODES
CMP #NODLIM&$FF
BCC XCONS2
XCONSG: RTS
XCONS2: PLA
PLA
JMP CONS2
CONSG1: LDA PRDFLG
BEQ CONST2
LDA FRLIST+1
BNE CONS2
BEQ CONSR
CONST2: LDA NNODES+1
CMP #NODLIM^
BCC CONS2
BNE CONSR
LDA NNODES
CMP #NODLIM&$FF
BCC CONS2
CONSR: LDX #XNSTRN ;Error "No storage left" (No nodes)
LDA #XZAP
JMP ERROR
CONS2: INC NNODES
BNE CONS2A
INC NNODES+1 ;Increment node counter
CONS2A: LDY #$00
LDX TEMPNH
LDA $00,X
STA (FRLIST),Y
INY
LDA $01,X
STA (FRLIST),Y ;(RPLACA)
INY
LDX TEMPNH+1
LDA (FRLIST),Y
PHA
LDA $00,X
STA (FRLIST),Y
INY
LDA (FRLIST),Y
PHA
LDA $01,X
STA (FRLIST),Y ;(RPLACD)
LDX ANSN
LDA FRLIST
STA $00,X
LDA FRLIST+1
STA $01,X
PLA
STA FRLIST+1
PLA
STA FRLIST
PLA ;GET TYPE
;falls through
;falls in
PUTTYP: CMP #LATOM+1
BCS PUTTP2
CMP #QATOM
BCC PUTTP2
SBC #$07
CLC
ADC $00,X
STA $00,X
PUTTPE: RTS
PUTTP2: LDY $01,X
BEQ PUTTPE
STY TEMPNH+1
LDY $00,X
STY TEMPNH
TAX
JSR TYPACS
TXA
STA (TEMPNH),Y
RTS
GETTYP: LDA $01,X
BEQ GETTPE
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
JSR TYPACS
CMP #ATOM
BEQ GETTP4
CMP #SATOM
BNE GETTPE
GETTP4: TAY
LDA $00,X
AND #$03
BEQ GETTPF
CLC
ADC #$07
GETTPE: RTS
GETTPF: TYA
RTS
TYPACS: LSR TEMPNH+1
ROR TEMPNH
LSR TEMPNH+1
ROR TEMPNH
CLC
LDA TEMPNH
ADC #TYPBAS&$FF
STA TEMPNH
LDA TEMPNH+1
ADC #TYPBAS^
STA TEMPNH+1
LDY #$00
LDA (TEMPNH),Y
RTS
.PAGE
PTSPNM: LDA $00,X
AND #$FC
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$02
LDA (TEMPNH),Y
TAX
INY
LDA (TEMPNH),Y
STA TEMPNH+1
STX TEMPNH ;(CDR)
DEY
LDA (TEMPNH),Y
ORA #$01
STA (TEMPNH),Y
RTS2: RTS
.PAGE
;Tries to find a block of (Y) contiguous free words in nodespace.
;If successful, return the start addr in (X). If not, return LNIL.
GETWDS: STX ANSN ;ANSN is ans
STY ANSN1 ;ANSN1 is size
LDA #$00
STA $00,X ;zero ans
STA $01,X
LDA $00,Y
BNE GW1A
LDA $01,Y
BEQ RTS2 ;If size=0, just return with ANS = 0
GW1A: JSR GW1 ;try once
LDX ANSN
LDA $01,X
BNE RTS2 ;if found something, quit.
JSR GARCOL ;otherwise, try again after a GC
;falls through
;falls in
GW1: LDA #$00
STA TEMPN+1 ;Zero lastptr (TEMPN)
STA TEMPN4+1 ;and lastptr1 (TEMPN4)
LDA FRLIST ;init ptr (TEMPN1) and
STA TEMPN1 ;ptr1 (TEMPN3) to freelist
STA TEMPN3
LDA FRLIST+1
STA TEMPN1+1
STA TEMPN3+1
GW1W: LDX ANSN
LDA $01,X ;if ans neq LNIL, done
BEQ GW1WA ;cuz found something
GWRTS: LDX ANSN1
CLC
LDA NNODES
ADC $00,X
STA NNODES ;Adjust allocation pointer
LDA NNODES+1
ADC $01,X
STA NNODES+1
RTS
GW1WA: LDA TEMPN1+1 ;if ptr1 = LNIL, done cuz been thru whole
BEQ RTS2 ;freelist, found nothing
GW1W1: LDA #$00
STA TEMPN2 ;sofar (TEMPN2) := 0
STA TEMPN2+1
STA ANSN2 ;contig (ANSN2) := 0 (T)
GW1X: LDX ANSN1
LDA TEMPN2+1
CMP $01,X
BCC GW1X2 ;if sofar >= size, go if2
BNE GWIF2
LDA TEMPN2
CMP $00,X
BCS GWIF2
LDA ANSN2 ;if contig = false, go else
BNE GWELSE
LDA TEMPN3
BNE GW1X2 ;if ptr1 = LNIL, goto else
LDA TEMPN3+1
BEQ GWELSE
GW1X2: CLC
LDA TEMPN2
ADC #$02 ;sofar := sofar + 2
STA TEMPN2
BCC GW1X3
INC TEMPN2+1
GW1X3: LDY #$02
LDA (TEMPN3),Y
STA TEMPNH ;temp (TEMPNH) := (cdr ptr1)
INY
LDA (TEMPN3),Y
STA TEMPNH+1 ;(CDR)
CLC
LDA TEMPNH ;add 4 to temp and see if
ADC #$04 ;result is = ptr1
TAX
LDA TEMPNH+1
ADC #$00
CMP TEMPN3+1
BNE NCNTIG
CPX TEMPN3
BEQ CONTIG ;if so, contig := 1 (false)
NCNTIG: INC ANSN2
CONTIG: LDA TEMPN3
STA TEMPN4 ;lastptr1 := ptr1
LDA TEMPN3+1
STA TEMPN4+1
LDA TEMPNH
STA TEMPN3 ;ptr1 := temp
LDA TEMPNH+1
STA TEMPN3+1
JMP GW1X ;round the while loop
GWIF2: LDA TEMPN+1 ;if lastptr = LNIL, freelist := ptr1
BNE GWIF3
LDA TEMPN3
STA FRLIST ;freelist := ptr1
LDA TEMPN3+1
STA FRLIST+1
JMP GWIF4
GWIF3: LDY #$02 ;else (rplacd lasptr ptr1)
LDA TEMPN3
STA (TEMPN),Y
INY
LDA TEMPN3+1
STA (TEMPN),Y ;(rplacd)
GWIF4: LDX ANSN
LDA TEMPN4
STA $00,X ;ans := lastptr1
LDA TEMPN4+1
STA $01,X
JMP GW1W ;back to top
GWELSE: LDA TEMPN3
STA TEMPN1 ;ptr := ptr1
LDA TEMPN3+1
STA TEMPN1+1
LDA TEMPN4
STA TEMPN ;lastptr := lastptr1
LDA TEMPN4+1
STA TEMPN+1
JMP GW1W ;back to top
.PAGE