github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-05 16:14:50 +00:00
Code Issues Releases Wiki Activity
Files
e3ba11ffbc1cc0e7932d3faff7472b56588b15fc
PDP-10.its/src/aplogo/logo.958
Lars Brinkhoff d536b228ac Apple II Logo. 
Written by:
- Stephen L. Hain
- Patrick G. Sobalvarro
- Leigh L. Klotz.
2018-09-17 20:13:47 +02:00

13451 lines
204 KiB
Plaintext
Raw Blame History

;-*-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
; Ufun Line Utility Routines:
FNDLIN: STA ANSN ;LINE returned
STY ANSN1 ;NUMBER looked for
LDA $00,X
STA TEMPN ;TEMPN is LAST_LINE
LDA $01,X
STA TEMPN+1
LDX ANSN
LDY #$02
LDA (TEMPN),Y
STA $00,X
INY
LDA (TEMPN),Y
STA $01,X ;(CDR)
BEQ FDLNWE
FDLNW: LDX ANSN
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$00
LDA (TEMPNH),Y
STA TEMPN1 ;TEMPN1 is incremental ptr.
INY
LDA (TEMPNH),Y
STA TEMPN1+1 ;(CAR)
DEY
LDA (TEMPN1),Y
TAX
INY
LDA (TEMPN1),Y
STA TEMPN1+1
STX TEMPN1 ;(GETBAR)
LDX ANSN1
LDA TEMPN1+1
CMP $01,X
BCC FDLNW3
BNE FDLNWE
LDA TEMPN1
CMP $00,X
BEQ FDLNWF
BCS FDLNWE
FDLNW3: LDX ANSN
LDA $00,X
STA TEMPN
LDA $01,X
STA TEMPN+1
LDY #$02
LDA (TEMPN),Y
STA $00,X
INY
LDA (TEMPN),Y
STA $01,X ;(CDR)
BNE FDLNW
FDLNWE: LDX ANSN
LDA TEMPN
STA $00,X
LDA TEMPN+1
STA $01,X
CLC ;Clear Carry means Not Found
RTS
FDLNWF: SEC ;Set Carry means Found
RTS
.PAGE
LINPEK: LDA $00,Y
STA TEMPNH ;BODY
LDA $01,Y
STA TEMPNH+1
LDY #$02
LDA UFRMAT
BEQ LPK1
INY
INY
LPK1: LDA (TEMPNH),Y
STA $00,X
INY
LDA (TEMPNH),Y
STA $01,X ;(CDR or GETBAR)
RTS
.PAGE
GTFULN: LDA $00,Y
STA TEMPNH
LDA $01,Y
STA TEMPNH+1 ;BODY
LDY #$00
LDA (TEMPNH),Y
STA $00,X
INY
LDA (TEMPNH),Y
STA $01,X ;(CAR or GETBAR)
LDA UFRMAT
BEQ GTFR
GTF2: INY
LDA (TEMPNH),Y
STA ULNEND
INY
LDA (TEMPNH),Y
STA ULNEND+1 ;(GETBAR)
LDA $00,X
CMP ULNEND
BNE GTFR
LDA $01,X
CMP ULNEND+1
BEQ FLLIN
GTFR: RTS
GTTULN: JSR GTFULN
LDA $01,X
BEQ GTFR
GTT1: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$00
LDA (TEMPNH),Y
CMP COMMNT
BNE GTFR
INY
LDA (TEMPNH),Y
CMP COMMNT+1
BNE GTFR
FLLIN: LDA #$00
STA $00,X
STA $01,X
RTS
.PAGE
ULNADV: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1 ;BODY
LDY #$02
LDA UFRMAT
BNE ULDV2
ULDV1: LDA (TEMPNH),Y
PHA
INY
LDA (TEMPNH),Y
STA $01,X
PLA
STA $00,X ;(CDR)
RTS
ULDV2: INY
INY
LDA (TEMPNH),Y
PHA
INY
LDA (TEMPNH),Y ;(GETBAR)
BNE ULDV3
PLA
BNE ULDV3A
STA $00,X
STA $01,X
RTS
ULDV3: PLA
ULDV3A: CLC
LDA $00,X
ADC #$02
STA $00,X
BCC ADHK13
INC $01,X
ADHK13: RTS
.PAGE
; Token-list Routines:
TTKADV: JSR TFKADV
LDA TEMPNH
CMP COMMNT
BNE TTKE
LDA TEMPNH+1
CMP COMMNT+1
BNE TTKE
LDA #$00
STA $00,X
STA $01,X
TTKE: RTS
TFKADV: LDA UFRMAT
CMP #FPACK
BEQ TFK2
TFK1: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$02
LDA (TEMPNH),Y
STA $00,X
INY
LDA (TEMPNH),Y
STA $01,X ;(CDR)
JMP TFK3
TFK2: CLC
LDA $00,X
ADC #$02
STA $00,X
BCC TFK2A
INC $01,X
TFK2A: CMP ULNEND
BNE TFK3
LDA $01,X
CMP ULNEND+1
BNE TFK3
LDA #$00
STA $00,X
STA $01,X
RTS
TFK3: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$00
LDA (TEMPNH),Y
PHA
INY
LDA (TEMPNH),Y
STA TEMPNH+1
PLA
STA TEMPNH ;(GETTOK)
RTS
.PAGE
SKPPTH: LDA TOKPTR+1
BEQ RTSA2X
LDY #$00
LDA (TOKPTR),Y
STA TEMPN
INY
LDA (TOKPTR),Y
STA TEMPN+1 ;(GETTOK)
LDX #TOKPTR
JSR TTKADV
LDA TEMPN
CMP LPAR
BNE RTSA2X
LDA TEMPN+1
CMP LPAR+1
BNE RTSA2X
LDA #$01
STA ANSN ;ANSN is PAREN_COUNTER
SKPPW: LDA TOKPTR+1
BEQ RTSA2X
LDY #$00
LDA (TOKPTR),Y
STA TEMPN
INY
LDA (TOKPTR),Y
STA TEMPN+1 ;(GETTOK)
LDX #TOKPTR
JSR TTKADV
LDX TEMPN
LDY TEMPN+1
CPX LPAR
BNE SKPPW2
CPY LPAR+1
BNE SKPPW2
INC ANSN
JMP SKPPW
SKPPW2: CPX RPAR
BNE SKPPW
CPY RPAR+1
BNE SKPPW
DEC ANSN
BNE SKPPW
RTSA2X: RTS
.PAGE
EXIFSC: STX ANSN1 ;ANSN1 is ANS
LDA IFLEVL
STA TEMPN1 ;TEMPN2 is IF_COUNTER
LDA IFLEVL+1
STA TEMPN1+1
EXFW: LDA TEMPN1+1
CMP IFLEVL+1
BCC EXFWE
BNE EXFWA1
LDA TEMPN1
CMP IFLEVL
BCS EXFWA1
EXFWE: SEC
LDA IFLEVL
SBC #$01
STA IFLEVL
BCS EXFWR
DEC IFLEVL+1
EXFWR: RTS
EXFWA1: LDA TOKPTR+1
BEQ EXFWE
LDY #$00
LDX ANSN1
LDA (TOKPTR),Y
STA $00,X
INY
LDA (TOKPTR),Y
STA $01,X ;(GETTOK)
TAY
LDA $00,X
TAX
CPX LIF
BNE EXFW2
CPY LIF+1
BNE EXFW2
INC TEMPN1
BNE EXIFWB
INC TEMPN1+1
EXIFWB: LDX #TOKPTR
JSR TTKADV
JMP EXFW
EXFW2: CPX LELSE
BNE EXFW3
CPY LELSE+1
BNE EXFW3
SEC
LDA TEMPN1
SBC #$01
STA TEMPN1
BCS EXFWC
DEC TEMPN1+1
EXFWC: LDA TEMPN1+1
CMP IFLEVL+1
BCC EXFWE
BNE EXFWD
LDA TEMPN1
CMP IFLEVL
BCC EXFWE
EXFWD: LDX #TOKPTR
JSR TTKADV
JMP EXFWA1
EXFW3: CPX RPAR
BNE EXFW4
CPY RPAR+1
BEQ EXFWE
EXFW4: JSR SKPPTH
JMP EXFW
.PAGE
; Edit mode Utility Routines:
EDTSTP: LDA EDSW
CMP #$01
BEQ EDTSR1 ;Error if already in CHANGE (not EDIT) mode
LDA LEVNUM
BNE EDTSR2
LDA LEVNUM+1
BNE EDTSR2
LDA TOKPTR+1
BEQ EDTSR3
LDY #$00
LDA (TOKPTR),Y
STA ARG1
INY
LDA (TOKPTR),Y
STA ARG1+1 ;(GETTOK)
LDX #TOKPTR
JSR TTKADV
LDX #ARG1
JSR GETTYP
CMP #SATOM
BEQ EDTSR4
CMP #ATOM
BNE EDTSR5
LDA ARG1
STA EDTATM
STA PODEFL
LDA ARG1+1
STA EDTATM+1
STA PODEFL+1
RTS
EDTSR1: LDA #XEDT
JMP ERROR
EDTSR2: JMP STTLR2 ;(ERROR XETL)
EDTSR3: JMP SCMMT1 ;(ERROR XEOL)
EDTSR4: JMP SPO5S ;(ERROR XUBL,ARG1)
EDTSR5: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
EXTEDT: LDA #$00
STA EDSW
STA EDBOD
STA EDBOD+1
STA EDTATM
STA EDTATM+1
RTS9: RTS
.PAGE
; Stuffed stuff Routines:
STUFF: STA ANSN3 ;try to associate the name (ATOM)
STX ANSNX ;definition with the function (BODY).
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1 ;TEMPNH is BODY
LDY #$00
LDA (TEMPNH),Y
STA TEMPN7
INY
LDA (TEMPNH),Y
STA TEMPN7+1 ;(CAR) to LINE
LDX #TEMPX2 ;TEMPX2 becomes NARGS
LDY #TEMPN7
JSR GETLEN
LDA #$00
STA TEMPN6 ;TEMPN6 is SIZE
STA TEMPN6+1
LDX ANSNX
LDA $00,X
STA TEMPNH ;TEMPNH is BODY
LDA $01,X
STA TEMPNH+1
GTSZW: LDA TEMPNH+1
BEQ GTSZND
LDY #$00
LDA (TEMPNH),Y
STA TEMPN
INY
LDA (TEMPNH),Y
STA TEMPN+1 ;(CAR) to LINE (GETSIZ local)
INY
LDA (TEMPNH),Y
TAX
INY
LDA (TEMPNH),Y
STA TEMPNH+1
STX TEMPNH ;(CDR)
GTSZX: LDA TEMPN+1
BEQ GTSZW
GTSZX1: INC TEMPN6
BNE GTSZX2
INC TEMPN6+1
GTSZX2: LDY #$02
LDA (TEMPN),Y
TAX
INY
LDA (TEMPN),Y
STA TEMPN+1
STX TEMPN ;(CDR)
BNE GTSZX1
BEQ GTSZW
GTSZND: LDX #TEMPN5 ;TEMPN5 becomes PTR
LDY #TEMPN6 ;SIZE
JSR GETWDS
LDA TEMPN5+1
BNE STFF1
STFFA: LDA #TEMPX2
LDY ANSNX
LDX ANSN3
JMP PTFTXT ;PUT_FTEXT (FUNATOM, BODY, NARGS) (X,Y,A)
STFF1: LDA TEMPN5
STA AREA1
LDA TEMPN5+1
STA AREA1+1
LDA TEMPN6
STA SIZE1
LDA TEMPN6+1
STA SIZE1+1
LDX #TEMPN6
LDY ANSNX ;BODY
JSR GETLEN
CLC
LDA TEMPN6
ADC #$02
STA TEMPN6
BCC ADHK55
INC TEMPN6+1
ADHK55: LDX #TEMPX1 ;TEMPX1 becomes INDEX
LDY #TEMPN6
JSR GETWDS
LDA TEMPX1+1
BNE STFF2
STA SIZE1
STA SIZE1+1
JMP STFFA
STFF2: LDA TEMPX1
STA AREA2
STA TEMPN1 ;TEMPN1 is INDEX1
LDA TEMPX1+1
STA AREA2+1
STA TEMPN1+1
CLC
LDA TEMPN6
ADC #$02
STA SIZE2
LDA TEMPN6+1
ADC #$00
STA SIZE2+1
LDX ANSNX
LDA $00,X
STA TEMPNH ;TEMPNH is BODY
LDA $01,X
STA TEMPNH+1
STFFW: LDA TEMPNH+1
BEQ STFFWE
STFFW1: LDY #$00
LDA TEMPN5 ;PTR
STA (TEMPN1),Y
INY
LDA TEMPN5+1
STA (TEMPN1),Y ;(PUTBAR)
CLC
LDA TEMPN1
ADC #$02
STA TEMPN1
BCC STFFX
INC TEMPN1+1
STFFX: LDA TEMPN7+1 ;LINE
BEQ STFFXE
LDY #$00
LDA (TEMPN7),Y
STA TEMPN3 ;TEMPN3 is TOKEN
INY
LDA (TEMPN7),Y
STA TEMPN3+1 ;(CAR)
INY
LDA (TEMPN7),Y
TAX
INY
LDA (TEMPN7),Y
STA TEMPN7+1
STX TEMPN7 ;(CDR)
LDY #$00
LDA TEMPN3
STA (TEMPN5),Y
INY
LDA TEMPN3+1
STA (TEMPN5),Y ;(PUTBAR)
CLC
LDA TEMPN5
ADC #$02
STA TEMPN5
BCC STFFX
INC TEMPN5+1
BNE STFFX ;(Always)
STFFXE: LDY #$03
LDA (TEMPNH),Y
TAX
DEY
LDA (TEMPNH),Y
STA TEMPNH ;(CDR)
STX TEMPNH+1
DEY
LDA (TEMPNH),Y
STA TEMPN7+1
DEY
LDA (TEMPNH),Y
STA TEMPN7 ;(CAR)
JMP STFFW
STFFWE: LDY #$00
LDA TEMPN5
STA (TEMPN1),Y ;TEMPN1 is INDEX1
INY
LDA TEMPN5+1
STA (TEMPN1),Y ;(PUTBAR)
INY
LDA #$00
STA (TEMPN1),Y
INY
STA (TEMPN1),Y ;(PUTBAR)
LDX #TEMPX1 ;INDEX
LDA #FPACK
JSR PUTTYP
LDA #TEMPX2
LDY #TEMPX1
LDX ANSN3
JSR PTFTXT ;(X,Y,A)
LDA #$00
STA SIZE1
STA SIZE1+1
STA SIZE2
STA SIZE2+1
RTS3: RTS
.PAGE
UNSTUF: STA ANSN2 ;ANSN2 is TEXTP
STY ANSN1 ;ANSN1 is BODY ptr. (X is FUN ptr.)
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$02
LDA (TEMPNH),Y
STA TEMPN1 ;TEMPN1 is INDEX
INY
LDA (TEMPNH),Y
STA TEMPN1+1 ;(CDR)
LDX #TEMPN1
JSR GETTYP
CMP #FPACK
BEQ USTF2
USTF1: LDX ANSN1
LDA TEMPN1
STA $00,X
LDA TEMPN1+1
STA $01,X
USTFE1: RTS
USTF2: LDA #$00
STA MARK1
STA MARK1+1
LDA SP
STA TEMPN4 ;TEMPN4 is STACK
LDA SP+1
STA TEMPN4+1
USTFW2: LDY #$00
LDA (TEMPN1),Y
STA TEMPN2 ;TEMPN2 is PTR
INY
LDA (TEMPN1),Y
STA TEMPN2+1 ;(GETBAR)
INY
LDA (TEMPN1),Y
STA TEMPN3 ;TEMPN3 is ENDPTR
INY
LDA (TEMPN1),Y
STA TEMPN3+1 ;(GETBAR)
USTFW: LDA TEMPN3+1
BEQ USTFWE
JSR STKTST
LDX #TEMPN2
JSR PUSHP
CLC
LDA TEMPN1
ADC #$02
STA TEMPN1
BCC USTFW2
INC TEMPN1+1
JMP USTFW2
USTFWE: LDA TEMPN2
STA TEMPN3
LDA TEMPN2+1
STA TEMPN3+1
USTFX: LDA TEMPN4
CMP SP
BNE USTFX1
LDA TEMPN4+1
CMP SP+1
BEQ USTFXE
USTFX1: LDX #TEMPN2
JSR POP
LDA #$00
STA MARK2
STA MARK2+1
USTFY: LDA TEMPN3
CMP TEMPN2
BNE USTFY1
LDA TEMPN3+1
CMP TEMPN2+1
BEQ USTFYE
USTFY1: SEC
LDA TEMPN3
SBC #$02
STA TEMPN3
BCS USTFY2
DEC TEMPN3+1
USTFY2: LDY #$00
LDA (TEMPN3),Y
STA TEMPN
INY
LDA (TEMPN3),Y
STA TEMPN+1 ;(GETBAR)
LDA #LIST
LDX #MARK2
STX ANSN
LDY #TEMPN
JSR CONS
JMP USTFY
USTFYE: LDX #MARK2
LDA TEMPN4
CMP SP
BNE USTFX2
LDA TEMPN4+1
CMP SP+1
BNE USTFX2
LDA #LIST
JSR PUTTYP
JMP USTFX3
USTFX2: LDA #FLIST
JSR PUTTYP
LDA ANSN2
BEQ USTFX3
LDY #$02
LDA (MARK2),Y
TAX
INY
LDA (MARK2),Y
STA MARK2+1
STX MARK2 ;(CDR)
USTFX3: LDX #MARK1
STX ANSN
LDY #MARK2
LDA #LIST
JSR CONS
JMP USTFWE
USTFXE: LDX ANSN1 ;BODY
LDA MARK1
STA $00,X
LDA MARK1+1
STA $01,X
LDA #$00
JMP CLMK2 ;Clear MARK1, MARK2
USTFE: RTS
.PAGE
; Oblist Interning Routine:
INTERN: STX ANSN1 ;ANSN1 IS STRING PTR.
STY ANSN2 ;ANSN2 IS ANS PTR.
JSR VPUSHP
LDA OBLIST ;OBFIND starts
STA TEMPN4
LDA OBLIST+1
STA TEMPN4+1 ;TEMPN4 IS OB_PTR
BEQ OBFNFE
OBFW: LDY #$00
LDX ANSN2
LDA (TEMPN4),Y
STA $00,X
INY
LDA (TEMPN4),Y
STA $01,X ;(CAR) TO ANS
LDY #TEMPN5 ;TEMPN5 IS PNAME
JSR GETPNM
LDX ANSN1 ;MATCH2 starts (STRING1 IS TEMPN5)
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1 ;TEMPNH IS STRING2
MTC2W: LDA TEMPNH+1
BNE MTC2W1
LDA TEMPN5+1 ;IF STRING2 IS 0 AND STRING1 ISN'T, NOT FOUND
BNE OBFNF
LDX #TEMPN5
JMP VPOP ;Pop the Vpushed string
MTC2W1: LDY #$00
LDA (TEMPNH),Y
CMP (TEMPN5),Y
BNE OBFNF
INY
LDA (TEMPNH),Y
CMP (TEMPN5),Y
BNE OBFNF
INY
LDA (TEMPNH),Y
TAX
INY
LDA (TEMPNH),Y
STA TEMPNH+1
STX TEMPNH ;(CDR)
DEY
LDA (TEMPN5),Y
TAX
INY
LDA (TEMPN5),Y
STA TEMPN5+1
STX TEMPN5 ;(CDR)
JMP MTC2W ;TRY NEXT TWO CHARACTERS
OBFNF: LDY #$02 ;TRY NEXT OBLIST OBJECT
LDA (TEMPN4),Y ;(OB_PTR)
TAX
INY
LDA (TEMPN4),Y
STA TEMPN4+1
STX TEMPN4 ;(CDR)
BNE OBFW
OBFNFE: LDX ANSN1 ;IT'S NOT ON THE OBLIST
JSR VPOP ;GET STRING BACK
LDA SOBLST ;SOBFIND starts
LDX ANSN2 ;ANS BECOMES SOBLIST POINTER
STA $00,X
LDA SOBLST+1
STA $01,X
SBFW: LDX ANSN2 ;OBJECT POINTER
SBFWX: LDA $00,X
CMP SOBTOP
BNE SBFW1
LDA $01,X
CMP SOBTOP+1
BNE SBFW1
SBFWEN: LDX ANSN1 ;STRING
INTRNX: LDY #$00 ;Not found anywhere
STY TEMPN1+1
INY
STY TEMPN1
LDA ANSN2
STA ANSN
LDY #TEMPN1 ;(NOVALUE)
LDA #LIST
JSR CONS
LDA ANSN2
STA ANSN ;(ANS)
TAX
LDY #TEMPN1 ;(NOVALUE)
LDA #ATOM
JSR CONS
LDA #LIST
LDX #OBLIST
STX ANSN
LDY ANSN2 ;ANS
JMP CONS
SBFW1: LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$02
LDA (TEMPNH),Y
INY
CLC
ADC #$03
STA TEMPN2 ;TEMPN2 IS SOBNAME
LDA (TEMPNH),Y
ADC #$00
STA TEMPN2+1 ;(CDR)
LDX ANSN1 ;ANSN1 POINTS TO STRING
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1 ;TEMPNH BECOMES PNAME
MTC1W: LDA TEMPNH
BNE MTC1W1
LDA TEMPNH+1
BEQ SBFNF
MTC1W1: LDY #$00
LDA (TEMPNH),Y
STA TEMPN ;TEMPN IS TEMP
INY
LDA (TEMPNH),Y
STA TEMPN+1 ;(CAR)
DEY
LDA (TEMPN2),Y
CMP TEMPN
BNE SBFNF
INC TEMPN2
BNE ADHK21
INC TEMPN2+1
ADHK21: LDA (TEMPN2),Y
CMP TEMPN+1
BNE SBFNF
LDY #$02
LDA (TEMPNH),Y ;TEMPNH IS PNAME
TAX
INY
LDA (TEMPNH),Y
STA TEMPNH+1
STX TEMPNH ;(CDR)
LDY #$00
LDA (TEMPN2),Y
BEQ MTC1WF
INC TEMPN2
BNE MTC1WE
INC TEMPN2+1
MTC1WE: LDA TEMPNH+1
BNE MTC1W1
LDA (TEMPN2),Y
BNE SBFNF
MTC1WF: RTS
SBFNF: CLC ;NOT THIS SOBLIST OBJECT
LDX ANSN2 ;ANS
LDA $00,X
ADC #$04
STA $00,X
BCC SBFWJ
INC $01,X
SBFWJ: JMP SBFWX
.PAGE
; Linked-list Utility Routines:
GETLEN: LDA $00,Y
STA TEMPNH ;LIST
LDA $01,Y
STA TEMPNH+1
LDA #$00
STA $00,X ;NARGS
STA $01,X
GLENW: LDA TEMPNH+1
BEQ GTLCR
GLENW1: LDY #$00
LDA (TEMPNH),Y
STA TEMPN
INY
LDA (TEMPNH),Y
STA TEMPN+1 ;(CAR)
INY
LDA (TEMPNH),Y
PHA
INY
LDA (TEMPNH),Y
STA TEMPNH+1
PLA
STA TEMPNH ;(CDR)
LDA TEMPN
CMP COMMNT
BNE GLENW2
LDA TEMPN+1
CMP COMMNT+1
BEQ GTLCR
GLENW2: INC $00,X
BNE GLENW
INC $01,X
BNE GLENW ;(Always)
GTLSTC: STX ANSN
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1 ;PTR
LDY #$02
GTLC2: LDA (TEMPNH),Y
TAX
BEQ GTLC3
INY
LDA (TEMPNH),Y
GTLC2A: STA TEMPNH+1
STX TEMPNH ;(CDR)
DEY
JMP GTLC2
GTLC3: INY
LDA (TEMPNH),Y
BNE GTLC2A
LDX ANSN
LDA TEMPNH
STA $00,X
LDA TEMPNH+1
STA $01,X
GTLCR: RTS
.PAGE
; Error Break Routines:
;Note - the only temporary variables which can be passed to ERROR
;as pointers are TEMPN6, TEMPN7, TEMPX1, and TEMPX2. PTRXOK and
;PTRYOK insure that the X or Y args point to safe temporaries.
PTRXOK: LDA $00,X
STA TEMPX2
LDA $01,X
STA TEMPX2+1
LDX #TEMPX2
RTS
PTRYOK: LDA $00,Y
STA TEMPX2
LDA $01,Y
STA TEMPX2+1
LDY #TEMPX2
RTS
ERROR: STA ERRFLG
PHA
STA ANSN2
ASL ANSN2 ;Error pointers are stored two bytes apart
STX ANSN3
STY ANSN1
LDA GRPHCS
BEQ ERRO1
LDA $C053 ;If FULL Graphics, make MIXED
ERRO1: JSR RSTIO
JSR EXTEDT ;Zap out of EDIT or CHANGE mode if necessary
PLA
LDX RETADR
TXS ;Restore all necessary return addresses
CMP #XZAP
BEQ ERRZ1
CMP #XARGTB
BEQ ERRZ2
CLC ;The Error-table holds pointers to the error-strings
LDA #ERRTBL&$FF
ADC ANSN2
STA TEMPN8
LDA #ERRTBL^
ADC #$00
STA TEMPN8+1
LDA GETRM2 ;Ghost-memory bank 2, error table
INC BANK4K
LDY #$00
LDA (TEMPN8),Y
TAX
INY
LDA (TEMPN8),Y
STA TEMPN8+1
STX TEMPN8
ERRW: LDA GETRM2 ;Ghost-memory bank 2, error messages
INC BANK4K
LDY #$00
LDA (TEMPN8),Y
LDX GETRM1 ;Ghost-memory bank 2 disable
LDX GETRM1
DEC BANK4K
TAX
BEQ ERRW2
CMP #$FF
BEQ ERRWE
CMP #$01
BEQ ERRW1
JSR TPCHR
JMP ERRW4
ERRZ1: JSR ZAPMSG
JMP ERRWE
ERRZ2: LDX ANSN3
JSR TYPFIX
LDX #ERRM4&$FF
LDY #ERRM4^
JSR PRTSTR
LDA #$00
LDX ANSN1
JSR LTYPE
JMP ERRWE
ERRW1: LDX ANSN3
JMP ERRW3
ERRW2: LDX ANSN1
ERRW3: LDA #$00
JSR LTYPE
ERRW4: INC TEMPN8
BNE ERRW
INC TEMPN8+1
BNE ERRW ;(Always)
ERRWE: LDA #$00
JSR CLMK5 ;Clear all the MARK pointers
LDA LEVNUM
BNE ERRWE1
LDA LEVNUM+1
BEQ ERR1
ERRWE1: JSR BREAK1
LDX #ERRM1&$FF
LDY #ERRM1^
JSR PRTSTR
LDX #LEVNUM
JSR TYPFIX
LDX #ERRM2&$FF
LDY #ERRM2^
JSR PRTSTR
LDX #LINNUM
JSR TYPFIX
LDX #ERRM3&$FF
LDY #ERRM3^
JSR PRTSTR
LDY #$06 ;(SF_UFUN = 6.)
LDA (FRAME),Y
STA TEMPN8
INY
LDA (FRAME),Y
STA TEMPN8+1 ;(CAR)
LDA #$00
LDX #TEMPN8
JSR LTYPE
ERR1: JSR BREAK1
LDA ERRRET
LDY ERRRET+1
JSR RSTERR
STA TEMPNH
STY TEMPNH+1
JMP (TEMPNH)
.PAGE
;ZAPMSG is a special case of ERROR, for error XZAP. It displays the
;appropriate error message.
ZAPMSG: JSR BREAK1
JSR BREAK1
LDA ANSN3
CMP #XNSTRN
BEQ ZPC1
CMP #XNSTOR
BEQ ZPC1
CMP #XSTOP
BEQ ZPC2
CMP #XEXCED
BEQ ZPC3
JSR SYSBUG
ZPC1: LDX #ZPMSG1&$FF
LDY #ZPMSG1^ ;"No Storage Left!"
JMP PRTSTR
ZPC2: LDX #ZPMSG2&$FF
LDY #ZPMSG2^ ;"Stopped!"
JMP PRTSTR
ZPC3: LDX #ZPMSG3&$FF
LDY #ZPMSG3^ ;"Evaluator Overflow"
JMP PRTSTR
;SYSBUG prints an error message and exits.
SYSBUG: STA $02
PLA
STA $01 ;Store calling point in locations $00,$01
PLA
STA $00
TXA
PHA
TYA
PHA
JSR RSTIO
LDX #LBUG1&$FF
LDY #LBUG1^
JSR PRTSTR ;Print "LOGO BUG!"
PLA
TAY
PLA
TAX
LDA $02
;falls through
;falls in
SBPT: BRK
NOP
NOP
JMP POPJ ;Monitor "G" command re-enters here
.PAGE
.SBTTL Garbage Collector
GARCOL: TSX
STX RETADR
LDA #GCLERR&$FF
STA ERRRET
LDA #GCLERR^
STA ERRRET+1
JSR SWAPT1
LDA SOBLST
STA TEMPN3 ;TEMPN3 is INDEX
LDA SOBLST+1
STA TEMPN3+1
GCLP2: LDX #TEMPN3
JSR MARK
CLC
LDA TEMPN3
ADC #$04
STA TEMPN3
BCC GCLP2A
INC TEMPN3+1
GCLP2A: LDA TEMPN3
CMP SOBTOP
BNE GCLP2
LDA TEMPN3+1
CMP SOBTOP+1
BNE GCLP2
LDA #VPDLBA&$FF
STA TEMPN3
LDA #VPDLBA^
STA TEMPN3+1
GCLP3: LDA TEMPN3
CMP VSP
BNE GCLP3X
LDA TEMPN3+1
CMP VSP+1
BEQ GCLP3A
GCLP3X: LDY #$00
LDA (TEMPN3),Y
STA TEMPN
INY
LDA (TEMPN3),Y
STA TEMPN+1 ;(GETBAR)
JSR MARKX ;Expects TEMPN as node
SEC
LDA TEMPN3
SBC #$02
STA TEMPN3
BCS GCLP3
DEC TEMPN3+1
BNE GCLP3 ;(Always)
GCLP3A: LDA FRAME
STA TEMPN3 ;TEMPN3 is FRAMEPTR
LDA FRAME+1
BEQ GCOL1
STA TEMPN3+1
GCLP4: LDY #$0E ;(SF_NUMBER_BINDINGS = 14.)
LDA (TEMPN3),Y
BEQ GCLP5E
STA ANSN1 ;ANSN1 is NARGS
CLC
LDA TEMPN3
ADC #$12 ;PTR1 points to first binding pair
STA TEMPN4 ;TEMPN4 is PTR1
LDA TEMPN3+1
ADC #$00
STA TEMPN4+1
GCLP5: LDY #$02
LDA (TEMPN4),Y ;See if it's a fun/frame pair
ROR A
BCS GCLP5A
LDY #$00 ;Nope, get value and mark
LDA (TEMPN4),Y
STA TEMPN
INY
LDA (TEMPN4),Y
STA TEMPN+1
JSR MARKX ;Expects TEMPN as node
GCLP5A: CLC
LDA TEMPN4
ADC #$04
STA TEMPN4
BCC GCLP5B
INC TEMPN4+1
GCLP5B: DEC ANSN1
BNE GCLP5
GCLP5E: LDY #$00 ;(SF_PREVIOUS_FRAME)
LDA (TEMPN3),Y
TAX
INY
LDA (TEMPN3),Y
STA TEMPN3+1
STX TEMPN3 ;(GETBAR)
BNE GCLP4
GCOL1: LDA #GCVST ;Mark all G.C.-protected variables
STA ANSN1
GCOL1L: LDX ANSN1
JSR MARK
INC ANSN1
INC ANSN1
LDA ANSN1
CMP #GCVEND
BNE GCOL1L
LDX #SIZE1
LDY #AREA1
JSR MARKA
LDX #SIZE2
LDY #AREA2
JSR MARKA
LDA #$00
STA FRLIST
STA FRLIST+1
STA NNODES
STA NNODES+1
LDA #BIGBAS&$FF
STA TEMPNH
LDA #BIGBAS^
STA TEMPNH+1 ;Nodespace pointer
LDA #SINODS&$FF
STA TEMPN
LDA #SINODS^
STA TEMPN+1 ;Typebase pointer
GCLP6: LDY #$00
LDA (TEMPN),Y
ROL A ;Type bit
BCS GCLP6C
LDY #$02
LDA FRLIST
STA (TEMPNH),Y
INY
LDA FRLIST+1
STA (TEMPNH),Y ;(RPLACD)
LDA TEMPNH
STA FRLIST
LDA TEMPNH+1
STA FRLIST+1
JMP GCLP6F
GCLP6C: INC NNODES
BNE GCLP6F
INC NNODES+1
GCLP6F: CLC
LDA TEMPNH
ADC #$04
STA TEMPNH
BCC GCLP6D
INC TEMPNH+1
GCLP6D: INC TEMPN
BNE GCLP6E
INC TEMPN+1
GCLP6E: LDA TEMPN
CMP #TYPEND&$FF
BNE GCLP6
LDA TEMPN+1
CMP #TYPEND^
BNE GCLP6
JSR CLRMRK
JSR SWAPT2
JMP RSTERR
GCLERR: LDA #$00
STA FRLIST
STA FRLIST+1
JSR CLRMRK
JSR SWAPT2
JMP ERROR1
.PAGE
CLRMRK: LDA #SINODS&$FF
STA TEMPNH
LDA #SINODS^
STA TEMPNH+1 ;TEMPN is pointer to Typebase
LDY #$00
GCLP1: LDA (TEMPNH),Y
AND #$7F ;Set Mark bit to 0 (False)
STA (TEMPNH),Y
INC TEMPNH
BNE GCLP1A
INC TEMPNH+1
GCLP1A: LDA TEMPNH
CMP #TYPEND&$FF
BNE GCLP1
LDA TEMPNH+1
CMP #TYPEND^
BNE GCLP1
MRKRTS: RTS
MARKA: LDA $00,X
STA TEMPN
LDA $01,X
STA TEMPN+1 ;TEMPN is SIZE
LDA $00,Y
STA TEMPNH
LDA $01,Y
STA TEMPNH+1
JSR TYPACS ;TEMPNH becomes address of typecodes
MRKAW: LDA TEMPN+1
BMI MRKRTS
BNE MRKAW1
LDA TEMPN
BEQ MRKRTS
MRKAW1: LDA (TEMPNH),Y
ORA #$80 ;Mark the word
STA (TEMPNH),Y
INC TEMPNH
BNE MRKAW2
INC TEMPNH+1
MRKAW2: SEC
LDA TEMPN
SBC #$01
STA TEMPN
BCS MRKAW
DEC TEMPN+1
JMP MRKAW
.PAGE
MARK: LDA $00,X
STA TEMPN
LDA $01,X
STA TEMPN+1 ;TEMPN is INDEX
MARKX: LDX #$FF
LDY #$FF
JSR PUSH
MRKW: LDA #$FF
CMP TEMPN
BNE MRKW1
CMP TEMPN+1
BEQ MRKRTS
MRKW1: LDA TEMPN+1
BEQ MRKW3
STA TEMPNH+1
LDA TEMPN
STA TEMPNH
JSR TYPACS
STA ANSN
ROL A
BCC MRKW2
MRKW3: JSR STKTS1
LDX #TEMPN
JSR POP
JMP MRKW
MRKW2: LDA ANSN
ORA #$80
STA (TEMPNH),Y
AND #$7F
CMP #LIST
BEQ MRKCL
CMP #STRING
BEQ MRKCF
CMP #FIX
BEQ MRKW3
CMP #FLO
BEQ MRKW3
CMP #FLIST
BEQ MRKCF
CMP #UFUN
BEQ MRKCU
CMP #SATOM
BEQ MRKCS
CMP #ATOM
BEQ MRKCL
CMP #DATOM
BEQ MRKCL
CMP #LATOM
BEQ MRKCL
CMP #QATOM
BEQ MRKCL
CMP #FPACK
BEQ MRKCP
JSR SYSBUG
MRKCF: LDY #$02
MRKCN: LDA (TEMPN),Y
TAX
INY
LDA (TEMPN),Y
BEQ MRKW3
TAY
MRKCF1: JSR PUSH
JMP MRKW3
MRKCS: LDY #$00
JMP MRKCN
MRKCL: LDA TEMPN
AND #$FC
STA TEMPN
LDY #$00
LDA (TEMPN),Y
TAX
INY
LDA (TEMPN),Y
BEQ MRKCF
TAY
MRKCL1: JSR PUSH
JMP MRKCF
MRKCU: CLC
LDA TEMPN
ADC #$04
STA TEMPNH
LDA TEMPN+1
ADC #$00
STA TEMPNH+1
JSR TYPACS
ORA #$80
STA (TEMPNH),Y
JMP MRKCF
MRKCP: LDY #$01
STY ANSN ;ANSN is FIRSTLINE
DEY
MRKCP1: LDA (TEMPN),Y
STA TEMPN1 ;TEMPN1 is LINE
INY
LDA (TEMPN),Y
STA TEMPN1+1 ;(GETBAR)
INY
LDA (TEMPN),Y
STA TEMPN2 ;TEMPN2 is LINE_END
INY
LDA (TEMPN),Y
STA TEMPN2+1 ;(GETBAR)
MRKPW: LDA TEMPN2+1
BNE MRKPW1
CLC
LDA TEMPN
ADC #$02
STA TEMPNH
LDA TEMPN+1
ADC #$00
STA TEMPNH+1
JSR TYPACS
ORA #$80
STA (TEMPNH),Y
JMP MRKW3
MRKPW1: CLC
LDA TEMPN
ADC #$02
STA TEMPNH
LDA TEMPN+1
ADC #$00
STA TEMPNH+1
JSR TYPACS
ORA #$80
STA (TEMPNH),Y
LDA TEMPN1
STA TEMPNH
LDA TEMPN1+1
STA TEMPNH+1
JSR TYPACS
ORA #$80
STA (TEMPNH),Y
LDA ANSN
BNE MRKPW2
CLC
LDA TEMPN1
ADC #$02
STA TEMPN1
BCC MRKPW2
INC TEMPN1+1
MRKPW2: LDA #$00
STA ANSN
MRKPX: LDA TEMPN1
CMP TEMPN2
BNE MRKPX1
LDA TEMPN1+1
CMP TEMPN2+1
BNE MRKPX1
MRKPXE: CLC
LDA TEMPN
ADC #$02
STA TEMPN
BCC MRKCP1
INC TEMPN+1
BNE MRKCP1 ;(Always)
MRKPX1: LDA TEMPN1
STA TEMPNH
LDA TEMPN1+1
STA TEMPNH+1
JSR TYPACS
ORA #$80
STA (TEMPNH),Y
LDA (TEMPN1),Y
TAX
INY
LDA (TEMPN1),Y
TAY
JSR PUSH
JSR STKTS1
CLC
LDA TEMPN1
ADC #$02
STA TEMPN1
BCC MRKPX
INC TEMPN1+1
BNE MRKPX ;(Always)
.PAGE
SWAPT1: LDY #TMPNUM-1
LDX #TMPSTT
SWPLP1: LDA $00,X
STA TMPTAB,Y
INX
DEY
BPL SWPLP1
RTS
SWAPT2: LDY #TMPNUM-1
LDX #TMPSTT
SWPLP2: LDA TMPTAB,Y
STA $00,X
INX
DEY
BPL SWPLP2
RTS
.PAGE
.SBTTL Output Routines:
;PRTSTR prints the Ascii string whose address is in the X and Y registers.
;The string is terminated with a 0.
PRTSTR: STX TEMPNH
STY TEMPNH+1
LDA GETRM2 ;Ghost-memory bank 2, Text strings
INC BANK4K
LDY #$00
PTSTR1: LDA (TEMPNH),Y
BEQ PTRRTS
JSR TPCHR
INY
BNE PTSTR1 ;(Always)
PTRRTS: LDA GETRM1 ;Ghost-memory bank 2 disable
LDA GETRM1
DEC BANK4K
RTS
SPRNT: LDA NARGS
BEQ SPRNT2
BPL SPRNT1
EOR #$FF
STA NARGS
SPRNT1: LDX #ARG1
JSR VPOP
LDA #$01
JSR LTYPE
DEC NARGS
BNE SPRNT1
SPRNT2: RTS
LTYPE: STA TEMPN4 ;TOPLEVELP
LDA $00,X
STA TEMPN5
LDA $01,X
STA TEMPN5+1 ;THING
LDX #LTPRTS&$FF
LDY #LTPRTS^
JSR PUSH
PRTHNG: LDX #TEMPN5
JSR GETTYP
CMP #LIST
BEQ LTPLS
CMP #ATOM
BEQ LTPA
CMP #SATOM
BEQ LTPS
CMP #DATOM
BEQ LTPD
CMP #QATOM
BEQ LTPQ
CMP #LATOM
BEQ LTPL
PHA ;Assuming Fix or Flo, save typecode
LDY #$00 ;and prep. for TYPFIX/FLO
LDX #$03
LTYPL1: LDA (TEMPN5),Y
STA NARG1,Y
INY
DEX
BPL LTYPL1
PLA
CMP #FIX
BEQ LTPF
CMP #FLO
BEQ LTPF1
JSR SYSBUG
LTPQ: LDA #'"
BNE LTPD1 ;(Always)
LTPD: LDA #':
LTPD1: JSR TPCHR
LTPA: JSR TYPATM
JMP POPJ
LTPS: JSR TPSATM
JMP POPJ
LTPL: JSR TYPATM
LDA #':
JSR TPCHR
JMP POPJ
LTPF: JSR TPBFIX
JMP POPJ
LTPF1: JSR TYPFLO
JMP POPJ
LTPLS: LDA #$01
STA TEMPN4+1 ;NOSPACE
LDA TEMPN4 ;TOPLEVELP
BNE PLSTLP
LDA #'[
JSR TPCHR
PLSTLP: JSR STKTST
LDA TEMPN5+1
BNE PLLP1
LDA TEMPN4 ;TOPLEVELP
BNE PLLP2
STA TEMPN4+1 ;Print a space after Sublists
LDA #']
JSR TPCHR
PLLP2: JMP POPJ
PLLP1: LDA TEMPN4+1 ;NOSPACE
BNE PLLP1A
LDA #$20 ;(Space)
JSR TPCHR
PLLP1A: LDX #TEMPN5
JSR PUSHP
LDX TEMPN4
JSR PUSH
LDY #$00
STY TEMPN4
STY TEMPN4+1
LDA (TEMPN5),Y
TAX
INY
LDA (TEMPN5),Y
STA TEMPN5+1
STX TEMPN5 ;(CAR)
LDX #TPP1&$FF
LDY #TPP1^
JSR PUSH
JMP PRTHNG
TPP1: JSR POPB
STA TEMPN4
LDX #TEMPN5
JSR POP
LDY #$02
LDA (TEMPN5),Y
TAX
INY
LDA (TEMPN5),Y
STA TEMPN5+1
STX TEMPN5 ;(CDR)
JMP PLSTLP
.PAGE
TYPATM: LDA TEMPN5
AND #$FC
STA TEMPN5
LDX #TEMPN5
LDY #TEMPN5
JSR GETPNM ;Returns with A nonzero if Funny-pname
STA ANSN
BEQ TPATMW
LDA INDEV
BEQ TPATMW
LDA #$27 ;(Single Quote)
JSR TPCHR
TPATMW: LDA TEMPN5+1
BEQ TPTMWE
LDY #$00
LDA (TEMPN5),Y
STA TEMPNH
INY
LDA (TEMPN5),Y
STA TEMPNH+1 ;(CAR)
INY
LDA (TEMPN5),Y
TAX
INY
LDA (TEMPN5),Y
STA TEMPN5+1
STX TEMPN5 ;(CDR)
LDA TEMPNH
JSR TPCHR
LDA TEMPNH+1
BEQ TPTMWE
JSR TPCHR
JMP TPATMW
TPTMWE: LDA ANSN
BEQ LTPRTS
LDA INDEV
BEQ LTPRTS
LDA #$27 ;(Single Quote)
JMP TPCHR
.PAGE
TPSATM: LDY #$02
LDA (TEMPN5),Y
TAX
INY
LDA (TEMPN5),Y
STA TEMPN5+1
STX TEMPN5 ;(CDR)
LDY #$03
TPSTMW: LDA (TEMPN5),Y
BEQ LTPRTS
STY ANSN
JSR TPCHR
LDY ANSN
INY
BNE TPSTMW ;(Always)
LTPRTS: RTS
;Types a two-byte fixnum, always positive.
TYPFIX: JSR CVFIX ;Get string on PDL
JMP PRTPDL ;Type string on PDL
;Types a four-byte fixnum in NARG1.
TPBFIX: JSR CVBFIX ;Get string on PDL
JMP PRTPDL ;Type string on PDL
;Type the flonum in NARG1.
TYPFLO: JSR CVFLO ;Get String on PDL
;falls through
;Type the string on the PDL, ANSN1 holds character count.
;falls in
PRTPDL: LDA #$00
PHA ;Push stop indicator
PRTPL1: JSR POPB ;Pop chars off PDL and onto stack
PHA
DEC ANSN1
BNE PRTPL1
PRTPL2: PLA ;Pop chars from stack and type them
BEQ LTPRTS ;until stop indicator popped
JSR TPCHR
JMP PRTPL2
.PAGE
PONAMS: LDA OBLIST
STA TEMPN8
LDA OBLIST+1
STA TEMPN8+1 ;TEMPN8 is OBLIST pointer
PONW1: LDA TEMPN8+1
BEQ PONW1E ;See if done
LDY #$00
LDA (TEMPN8),Y
STA TEMPN6 ;Get name pointer
INY
LDA (TEMPN8),Y
STA TEMPN6+1 ;(CAR)
INY
LDA (TEMPN8),Y
TAX
INY
LDA (TEMPN8),Y
STA TEMPN8+1
STX TEMPN8 ;(CDR) to next OBLIST object
JSR PON1 ;Print the name and value
JMP PONW1
PONW1E: LDA SOBLST
STA TEMPN6 ;TEMPN6 is SOBLIST pointer
LDA SOBLST+1
STA TEMPN6+1
PONW2: LDA TEMPN6
CMP SOBTOP
BNE PONW2A ;See if done
LDA TEMPN6+1
CMP SOBTOP+1
BNE PONW2A
PONRTS: RTS
PONW2A: JSR PON1 ;Print the name and value
CLC
LDA TEMPN6
ADC #$04
STA TEMPN6
BCC PONW2
INC TEMPN6+1
BNE PONW2 ;(Always)
.PAGE
PON1: LDX #TEMPN7 ;TEMPN7 is value
LDY #TEMPN6 ;TEMPN6 is NAME
JSR GETVAL
LDA TEMPN7+1
BNE PON1A
LDA TEMPN7
BNE PONRTS ;Skip if NOVALUE
PON1A: LDA INDEV
BNE PON1B ;Use "MAKE" if not screen output
LDA #'"
JSR TPCHR
LDA #$00
LDX #TEMPN6
JSR LTYPE
LDX #PNMSG1&$FF ;"IS "
LDY #PNMSG1^
JSR PRTSTR
LDA #$00
LDX #TEMPN7
JSR LTYPE
JMP BREAK1
PON1B: LDX #PNMSG2&$FF ;"MAKE "
LDY #PNMSG2^
JSR PRTSTR
LDA #'"
JSR TPCHR
LDA #$00
LDX #TEMPN6
JSR LTYPE
LDA #$20
JSR TPCHR
LDX #TEMPN7
JSR GETTYP
CMP #ATOM
BNE PON1C
LDA #'"
JSR TPCHR
PON1C: LDA #$00
LDX #TEMPN7
JSR LTYPE
JMP BREAK1
.PAGE
POFUNS: STA ANSN2 ;ANSN2 is FULL
LDA OBLIST
STA TEMPX2 ;TEMPN7 is OBLIST pointer
LDA OBLIST+1
STA TEMPX2+1
POFNSW: LDY #$03
LDA (TEMPX2),Y
PHA
DEY
LDA (TEMPX2),Y
PHA
DEY
LDA (TEMPX2),Y
TAX
DEY
LDA (TEMPX2),Y
STA TEMPX2
STX TEMPX2+1
LDA #TEMPX2
JSR PTEXTX
PLA
STA TEMPX2
PLA
STA TEMPX2+1
BNE POFNSW
RTS
.PAGE
POTEXT: STX ANSN2 ;ANSN2 is FULL
PTEXTX: STA ANSN1 ;Save ATOMM (Entry point for POFUNS)
TAX
LDA #TEMPN6 ;TEMPN6 becomes FUN
JSR GETFUN
LDA TEMPN6+1
BEQ PTXRTS
LDX #TOMSG&$FF ;"TO "
LDY #TOMSG^
JSR PRTSTR
LDX ANSN1 ;Retrieve ATOMM
LDA #$00
JSR LTYPE ;Print the title
LDY #$02
LDA (TEMPN6),Y
TAX
INY
LDA (TEMPN6),Y
STA TEMPN6+1
STX TEMPN6 ;(CDR)
LDX #TEMPN6
JSR GETTYP
CMP #LIST
BEQ POTXTL
JMP POTXTF
POTXTL: LDY #$00
LDA (TEMPN6),Y
STA TEMPN8 ;TEMPN8 is LINE
INY
LDA (TEMPN6),Y
STA TEMPN8+1 ;(CAR)
INY
LDA (TEMPN6),Y
TAX
INY
LDA (TEMPN6),Y
STA TEMPN6+1
STX TEMPN6 ;(CDR)
PTXLW: LDA TEMPN8+1
BEQ PTXLWE
LDY #$00
LDA (TEMPN8),Y
STA TEMPX1
INY
LDA (TEMPN8),Y
STA TEMPX1+1 ;(CAR)
INY
LDA (TEMPN8),Y
TAX
INY
LDA (TEMPN8),Y
STA TEMPN8+1
STX TEMPN8
LDA #$20 ;(Space)
JSR TPCHR
LDA #$00
LDX #TEMPX1
JSR LTYPE
JMP PTXLW
PTXLWE: JSR BREAK1
LDA ANSN2 ;FULL
BNE PTXLX
PTXRTS: RTS
PTXLX: LDA TEMPN6+1
BNE PTXLX1
PTXEND: LDX #ENDMSG&$FF
LDY #ENDMSG^
JMP PRTSTR
PTXLX1: LDY #$00
LDA (TEMPN6),Y
STA TEMPN8
INY
LDA (TEMPN6),Y
STA TEMPN8+1 ;(CAR)
INY
LDA (TEMPN6),Y
TAX
INY
LDA (TEMPN6),Y
STA TEMPN6+1
STX TEMPN6 ;(CDR)
LDY #$00
LDA (TEMPN8),Y
STA TEMPX1
INY
LDA (TEMPN8),Y
STA TEMPX1+1 ;(CAR)
INY
LDA (TEMPN8),Y
TAX
INY
LDA (TEMPN8),Y
STA TEMPN8+1
STX TEMPN8 ;(CDR)
LDA INDEV
BNE PTXLY ;If screen editor, no line numbers
LDA EDSW
BEQ PTXLY ;else if not other editor, no line numbers
PTXLX2: LDX #TEMPX1
JSR TYPFIX
PTXLY: LDA TEMPN8+1
BEQ PTXLYE
LDY #$00
LDA (TEMPN8),Y
STA TEMPX1
INY
LDA (TEMPN8),Y
STA TEMPX1+1 ;(CAR)
INY
LDA (TEMPN8),Y
TAX
INY
LDA (TEMPN8),Y
STA TEMPN8+1
STX TEMPN8
LDA #$20 ;(Space)
JSR TPCHR
LDA #$00
LDX #TEMPX1
JSR LTYPE
JMP PTXLY
PTXLYE: JSR BREAK1
JMP PTXLX
POTXTF: LDY #$00
LDA (TEMPN6),Y
STA TEMPN8 ;TEMPN8 is PTR
INY
LDA (TEMPN6),Y
STA TEMPN8+1 ;(GETBAR)
INY
LDA (TEMPN6),Y
STA TEMPN7 ;TEMPN7 is ENDPTR
INY
LDA (TEMPN6),Y
STA TEMPN7+1 ;(GETBAR)
CLC
LDA TEMPN6
ADC #$02
STA TEMPN6
BCC PTXFW
INC TEMPN6+1
PTXFW: LDA TEMPN7
CMP TEMPN8
BNE PTXFW1
LDA TEMPN7+1
CMP TEMPN8+1
BEQ PTXFWE
PTXFW1: LDY #$00
LDA (TEMPN8),Y
STA TEMPX1
INY
LDA (TEMPN8),Y
STA TEMPX1+1 ;(GETBAR)
CLC
LDA TEMPN8
ADC #$02
STA TEMPN8
BCC PTXFW2
INC TEMPN8+1
PTXFW2: LDA #$20
JSR TPCHR
LDA #$00
LDX #TEMPX1
JSR LTYPE
JMP PTXFW
PTXFWE: JSR BREAK1
LDA ANSN2
BNE PTXFX
RTS
PTXFX: LDA TEMPN7+1
BNE PTXFX1
JMP PTXEND
PTXFX1: LDA TEMPN7
STA TEMPN8
LDA TEMPN7+1
STA TEMPN8+1
LDY #$02
LDA (TEMPN6),Y
STA TEMPN7
INY
LDA (TEMPN6),Y
STA TEMPN7+1 ;(GETBAR)
CLC
LDA TEMPN6
ADC #$02
STA TEMPN6
BCC PTXFX2
INC TEMPN6+1
PTXFX2: LDA TEMPN7+1
BNE PTXFX3
JMP PTXEND
PTXFX3: LDY #$00
LDA (TEMPN8),Y
STA TEMPX1
INY
LDA (TEMPN8),Y
STA TEMPX1+1 ;(GETBAR)
CLC
LDA TEMPN8
ADC #$02
STA TEMPN8
BCC PTXFX4
INC TEMPN8+1
PTXFX4: LDA INDEV
BNE PTXFY ;No line numbers if screen-editor
LDA EDSW
BEQ PTXFY ;or if not in otherr editor
PTXFX5: LDX #TEMPX1
JSR TYPFIX
PTXFY: LDA TEMPN7
CMP TEMPN8
BNE PTXFY1
LDA TEMPN7+1
CMP TEMPN8+1
BEQ PTXFYE
PTXFY1: LDY #$00
LDA (TEMPN8),Y
STA TEMPX1
INY
LDA (TEMPN8),Y
STA TEMPX1+1 ;(GETBAR)
CLC
LDA TEMPN8
ADC #$02
STA TEMPN8
BCC PTXFY2
INC TEMPN8+1
PTXFY2: LDA #$20
JSR TPCHR
LDA #$00
LDX #TEMPX1
JSR LTYPE
JMP PTXFY
PTXFYE: JSR BREAK1
JMP PTXFX
.PAGE
.SBTTL Arithmetic Routines:
;Floating Point routines:
FLOTN2: JSR SWAP
JSR FLOTN1
JMP SWAP
FLOTN1: LDA NARG1+3
BPL XFLOAT
LDX #NARG1
JSR COMPL
JSR XFLOAT
JMP FCOMPL
XFLOAT: LDA #$9E
STA ANSN ;Shift counter (exponent)
XFLT1: LDA NARG1+3
CMP #$C0
BMI XFLT2
ASL NARG1
ROL NARG1+1 ;Rotate left to left-justify
ROL NARG1+2
ROL NARG1+3
DEC ANSN
BNE XFLT1 ;Stop if exponent is zero
XFLT2: LDA NARG1+1 ;Reverse LSB, MSB for floating pt. format
LDY NARG1+3
STY NARG1+1
STA NARG1+3
LDA ANSN
STA NARG1 ;Put in exponent
RTS
;Add M1 and M2, result in M1.
ADD: CLC ;Clear carry
LDX #$02 ;Index for 3-byte add
ADD1: LDA NARG1+1,X
ADC NARG2+1,X ;Add a byte of Mant2 to Mant1
STA NARG1+1,X
DEX ;Index to next more signif. byte
BPL ADD1 ;Loop until done
RTS ;Return
;Makes X/M1 and X/M2 positive. Returns with LSB of SIGN equal to XOR of
;signs of original numbers. Copies (positive) mantissa of X/M1 into E.
MD1: ASL ANSN ;Clear LSB of Sign
JSR ABSWAP ;Abs. val. of M1, then swap with M2
ABSWAP: BIT NARG1+1 ;Is Mant1 negative...
BPL ABSWP1 ;No, swap with Mant2 and return
JSR FCOMPL ;Yes, complement it.
INC ANSN ;Increment sign, complementing LSB
ABSWP1: SEC ;Set carry for return to MUL/DIV
;Swaps X/M1 and X/M2 and leaves a copy of M1 in E.
SWAP: LDX #$04 ;Index for 4-byte swap
SWAP1: STY TEMPNH-1,X
LDA NARG1-1,X ;Swap a byte of Exp/Mant1 with
LDY NARG2-1,X ;Exp/Mant2 and leave a copy of
STY NARG1-1,X ;Mant1 in E (3 bytes). (E+3 is destroyed.)
STA NARG2-1,X
DEX ;Advance index to next byte
BNE SWAP1 ;Loop until done
RTS ;Return
;Normalize M1 and X1 to standard format floating pt. (left-justified mantissa,
;exponent tells how much so).
NORM1: LDA NARG1+1 ;High-order Mant1 byte
CMP #$C0 ;Are Upper two bits unequal...
BMI RTS1 ;Yes, return with Mant1 normalized.
DEC NARG1 ;Decrement X1
ASL NARG1+3
ROL NARG1+2 ;Shift Mant1 3 bytes left
ROL NARG1+1
FNORM: LDA NARG1 ;Is Exp1 zero...
BNE NORM1 ;No, continue normalizing.
RTS1: RTS ;Return
;Floating pt. add. X/M1 becomes X/M2 + X/M1.
FADD: JSR FADD1
CLC ;If it returns, then no overflow
RTS
FSUB: JSR SWAP ;It does M2-M1, we want M1-M2
FSUBX: JSR FSUB1
CLC
RTS
FMUL: JSR FMULT
CLC
RTS
FDIV: JSR SWAP ;It does M2/M1, we want M1/M2.
JSR FDIVD
CLC
RTS
;Floating pt. subtract. X/M1 becomes X/M2 - X/M1.
FSUB1: JSR FCOMPL ;Complement Mant1, clears carry unless 0
SWPALN: JSR ALNSWP ;Right shift Mant1 or swap
FADD1: LDA NARG2
CMP NARG1 ;Compare Exp1 with Exp2
BNE SWPALN ;If unequal, swap addends or align mantissas
JSR ADD ;Add aligned mantissas
;Cleans up after complementing mantissa, or after adding mantissas.
ADDEND: BVC FNORM ;No overflow, normalize result
BVS RTLOG ;(Always) Overflow - shift M1 right, carry into Sign
;Either swap mantissas (for another alignment) or do an alignment. Carry bit
;resultants determine which to do each time over.
ALNSWP: BCC SWAP ;Swap if carry clear, else shift right arith.
;Shifts mantissa right, towards pure fixnum.
RTAR: LDA NARG1+1 ;Sign of M1 into carry for
ASL A ;right arith. shift
;Make upper two bits of mantissa unequal by shifting M1 right.
;Also shifts LSB of M1 into MSB of E.
RTLOG: INC NARG1 ;Increment X1 to adjust for right shift
BEQ OVFL ;Exp1 out of range
RTLOG1: LDX #$FA ;Index for 6 byte right shift
ROR1: ROR TEMPNH+3,X ;(M1 and E must be contiguous)
INX ;Next byte of shift
BNE ROR1 ;Loop until done
RTS ;Return
;Floating pt. multiply. X/M1 becomes X/M1 * X/M2.
FMULT: JSR MD1 ;Absolute value of Mant1, Mant2.
ADC NARG1 ;Add Exp1 to Exp2 for product Exp
JSR MD2 ;Check product exp. and prepare for multiply
CLC ;Clear carry for first bit
FMUL1: JSR RTLOG1 ;M1 and E right (product and multiplier)
BCC FMUL2 ;If carry clear, skip partial product
JSR ADD ;Add multiplicand to product
FMUL2: DEY ;Next multiply iteration
BPL FMUL1 ;Loop until done
MDEND: LSR ANSN ;Test Sign LSB
NORMX: BCC FNORM ;If even, normalize product, else complement
;Complement the mantissa of M1.
FCOMPL: SEC ;Set carry for subtract
LDX #$03 ;Index for 3-byte subtract
COMPL1: LDA #$00 ;Clear A
SBC NARG1,X ;Subtract byte of Exp1
STA NARG1,X ;Restore it
DEX ;Next more significant byte
BNE COMPL1 ;Loop until done
BEQ ADDEND
;Floating pt. multiply. X/M1 becomes X/M1 / X/M2.
FDIVD: JSR MD1 ;Take abs. val. of Mant1, Mant2
SBC NARG1 ;Subtract Exp1 from Exp2
JSR MD2 ;Save as quotient exp.
DIV1: SEC ;Set carry for subtract
LDX #$02 ;Index for 3-byte subtraction
DIV2: LDA NARG2+1,X
SBC TEMPNH,X ;Subtract a byte of E from Mant2
PHA ;Save on stack
DEX ;Next more significant byte
BPL DIV2 ;Loop until done
LDX #$FD ;Index for 3-byte conditional move
DIV3: PLA ;Pull byte of difference off stack
BCC DIV4 ;If M2 smaller than E then don't restore M2
STA NARG2+4,X
DIV4: INX ;Next less significant byte
BNE DIV3 ;Loop until done
ROL NARG1+3
ROL NARG1+2 ;Roll quotient left, carry into LSB
ROL NARG1+1
ASL NARG2+3
ROL NARG2+2 ;Shift dividend left
ROL NARG2+1
BCS OVFL ;Overflow is due to un-normalized divisor
DEY ;Next divide iteration
BNE DIV1 ;Loop until done 23 iterations
BEQ MDEND ;(Always) Normalize quotient and correct sign
;Prepare for multiply or divide, check result's exponent.
MD2: STX NARG1+3
STX NARG1+2 ;Clear Mant1 (3 bytes) for MUL/DIV
STX NARG1+1
BCS OVCHK ;If calculation set carry, check for overflow
BMI MD3 ;If negative, then no underflow
PLA ;Pop one return level (undeflow, answer is 0)
PLA
BCC NORMX ;Clear X1 and return
MD3: EOR #$80 ;Complement sign bit of exponent
STA NARG1 ;Store it.
LDY #$17 ;Count 24. (MUL) or 23. (DIV) iterations
RTS ;Return
OVCHK: BPL MD3 ;If positive exponent, then no overflow.
PLA
PLA ;Pop past MD2 call
OVFL: PLA ;Overflow, pop past first function call
PLA
SEC ;Indicate overflow
RTS
;Changes the argument in (X) from Flonum to four-byte Fixnum.
XINT2: JSR SWAP ;Pos or neg, only NARG2
JSR XINT1
JMP SWAP
XINT1: LDA NARG1 ;Pos or neg, only NARG1
BMI FFIXP
LDA #$00 ;Negative exponent gives zero result
STA NARG1
STA NARG1+1
STA NARG1+2
STA NARG1+3
FFIXR: RTS
FFIXP: CMP #$9F
BCS OVFL1 ;Exponent too high, overflow
LDA NARG1+1
BPL FFIXP1
JSR FCOMPL
JSR FFIXP1
LDX #NARG1
JMP COMPL
FFIXP1: LDA NARG1
STA ANSN
LDA #$00
STA NARG1 ;Init LSB to zero
LDA NARG1+1
LDY NARG1+3 ;Switch LSB, MSB for fixnum format
STY NARG1+1
STA NARG1+3
FFIX1: LDA ANSN
CMP #$9E
BEQ FFIXR ;Done when Exp=30. (4 bytes, binary point two places in)
LSR NARG1+3
ROR NARG1+2 ;Rotate to right-justify
ROR NARG1+1
ROR NARG1
INC ANSN
BNE FFIX1 ;(Always)
OVFL1: LDA #XOFLOW
JMP ERROR
;Complement (negate) a fixnum.
COMPL: LDY #$03
SEC
CMPL1: LDA $00,X
EOR #$FF ;Complement
ADC #$00 ;and increment.
STA $00,X
INX
DEY
BPL CMPL1
RTS
;Divides NARG1 by 10.
XDVD10: LDA #$0A
STA NARG2
LDA #$00
STA NARG2+1
STA NARG2+2
STA NARG2+3
;falls through
.PAGE
;Fast and clean fixnum division routine, assumes positive numbers.
;Dividend in NARG1, divisor in NARG2.
;NARG1 becomes quotient.
;falls in
XDIVID: LDA #$00 ;Zero temp. quotient (A1L-A2H)
LDX #$03
XDLP1: STA A1L,X
STA TEMPN,X
DEX
BPL XDLP1
INC TEMPN ;Initialize bitholder (TEMPN,TEMPN1)
NORM: ASL TEMPN ;Normalize the bitholder...
ROL TEMPN+1
ROL TEMPN1
ROL TEMPN1+1
ASL NARG2
ROL NARG2+1 ;and the divisor
ROL NARG2+2
ROL NARG2+3
BPL NORM ;to the left side
BMI SHFT ;(Always)
SHFTX: PLA ;(Discard intermediate result)
SHFT: LSR TEMPN1+1 ;Back 'em off one
ROR TEMPN1
ROR TEMPN+1
ROR TEMPN
LSR NARG2+3
ROR NARG2+2
ROR NARG2+1
ROR NARG2
LDX #$03
XDLP2: LDA TEMPN,X
BNE DV2 ;If bitholder is zero, done
DEX
BPL XDLP2
BMI DONE ;(Always)
DV2: SEC ;Subtract divisor from dividend
LDA NARG1
SBC NARG2
PHA
LDA NARG1+1
SBC NARG2+1
TAX
LDA NARG1+2
SBC NARG2+2
TAY
LDA NARG1+3
SBC NARG2+3
BCC SHFTX ;If borrow, don't save remainder
STA NARG1+3 ;or add to result
STY NARG1+2
STX NARG1+1
PLA
STA NARG1
CLC
LDX #$FC
XDLP3: LDA A1L+4,X ;Add bitholder to result
ADC TEMPN+4,X
STA A1L+4,X
INX
BMI XDLP3
BPL SHFT ;(Always)
DONE: LDA NARG1
PHA
LDY #A1L
JSR XYTON1
PLA
CLC
ADC #'0
RTS
.PAGE
.SBTTL Screen Editor
;increment the point (EPOINT,EPOINT+1).
INCPNT: INC EPOINT
BNE INCPT2
INC EPOINT+1
INCPT2: RTS
;decrement the point.
DECPNT: LDA EPOINT
SEC
SBC #$01
STA EPOINT
BCS DECPT2
DEC EPOINT+1
DECPT2: RTS
;set the point to the beginning of the buffer.
PNTBEG: LDA #EDBUF&$FF
STA EPOINT
LDA #EDBUF^
STA EPOINT+1
RTS
;place cursor at top of screen
TOPSCR: LDA #$00 ;cursor at top of screen
STA BASLIN ;baseline for top of screen
STA CH
STA CV
LDA #$04
STA BASLIN+1
RTS
;output char in AC to EDBUF at point. Increments point. Does NOT
;increment last-char-in-buffer pointer. Returns without modifying if
;at end of buffer.
EDOUT: TAX ;save char
STY YSAV1
LDA EPOINT+1
CMP #EBFEND^
BCC EDOUT1
BNE EDORTS
LDA EPOINT
CMP #EBFEND&$FF ;Are we at end of edit buffer...
BCS EDORTS ;if so, quit
EDOUT1: LDY #$00
TXA
STA (EPOINT),Y ;if not, store char and inc pointer
JSR INCPNT
EDORTS: LDY YSAV1
NULOUT: RTS
;top level loop in the editor; listens for characters; outputs them to
;the screen and the edit buffer; accepts commands and has them
;processed.
CHGLOP: JSR RDKEY ;get char from kbd
CMP #$03 ;^C means finished
BEQ CHGLPC ;read function into Logo and return.
CMP #$02 ;^B means previous screen
BEQ CHGLPB
CMP #$04 ;^D is delete char under cursor
BEQ CHGLPD
CMP #$06 ;^F means forward screen
BEQ CHGLPF
CMP #$08 ;^H means back char
BEQ CHGLPH
CMP #$0C ;^L means center point on screen
BEQ CHGLPL
CMP #$0F ;^O means open line
BEQ CHGLPO
CMP #$10 ;^P means up line
BEQ CHGLPP
CMP #$15 ;^U means forward char
BEQ CHGLPU
CMP #$1B ;ESC means rubout
BEQ CHGLRB
JSR INSERT ;not a command - insert it
JMP CHGLOP
CHGLPB: JSR PRVSCR
JMP CHGLOP
CHGLPC: JMP EDDONE
CHGLPD: JSR DELETE ;the return address CHGLOP was pushed
JMP CHGLOP
CHGLPF: JSR NXTSCR ;for these above (space bum)
JMP CHGLOP
CHGLPH: JSR BACKUP
JMP CHGLOP
CHGLPL: JSR CENTER
JMP CHGLOP
CHGLPO: JSR OPLINE
JMP CHGLOP
CHGLPP: JSR UPLINE
JMP CHGLOP
CHGLPU: JSR FORCHR
JMP CHGLOP
CHGLRB: JSR RUBOUT
JMP CHGLOP
;EDDONE will read the editor-defined code back into Logo.
EDDONE: LDY #$00
LDA #$0D ;Carriage return at end, just in case none there
STA (ENDBUF),Y
INC ENDBUF
BNE EDDON2
INC ENDBUF+1
EDDON2: LDX #ERDBK1&$FF
LDY #ERDBK1^
JSR PUSH ;Return address from SREAD2
JSR PNTBEG ;point to beginning
JSR RESETT ;Clear the output device
LDX #WAITM&$FF
LDY #WAITM^
JSR PRTSTR
JMP SREAD1
ERDBK1: JSR RSTIO
JMP POPJ
;this function will display the buffer beginning at the point on the
;screen, beginning at CH, CV (should be consistent with BASLIN). It
;will stop if there is nothing more in the buffer, or when there is no
;more room on the screen. Updates TEMPN8 (last-char-displayed
;pointer). EDSPBF will check as it displays for the point and will set
;CV, CH accordingly. If you would like it to turn on the cursor at a
;place other than the point, set A4L,A4H to it and call EDPBUF.
EDSPBF: LDA EPOINT
STA A4L
LDA EPOINT+1
STA A4H
EDPBUF: LDA CV
STA A2L
LDA CH
STA A2H
EDSPLP: LDA EPOINT+1
CMP ENDBUF+1
BCC EDSPB1
BNE EDPRTS
LDA EPOINT
CMP ENDBUF
BCS EDPRTS ;quit if no more in buffer
EDSPB1: LDY #$00
LDA (EPOINT),Y ;get char
CMP #$0D ;#$0D = CR
BEQ EDSPCR
LDX CH
INX
CPX WNDWTH ;if at end of line and next char is a
BCC EDPCHR ;cr, then no !. otherwise yes.
PHA
LDA #'!
JSR COUT ;output continuation line char
PLA
LDX CV ;when we output the continuation char COUT
JMP EDPCR1 ;inc'ed CV, so don't now.
EDOPCR: LDX CV
INX ;if we output the CR (or char on next line),
EDPCR1: CPX WNDBTM ;will we have exceeded the screen length...
BCS EDPRTS ;yes, quit while we're not ahead
EDPCHR: LDX EPOINT
CPX A4L
BNE EDPCH2
LDX EPOINT+1 ;if we're at point then set CV, CH so we can
CPX A4H ;display the cursor in the right place when
BNE EDPCH2 ;we come back
LDX CV
STX A2L
LDX CH
STX A2H
EDPCH2: JSR COUT ;output char; back for more
JSR INCPNT
JMP EDSPLP
EDSPCR: PHA
JSR CLREOL
PLA
JMP EDOPCR
EDPRTS: JSR CLREOP
LDX EPOINT
CPX A4L
BNE EDPRS2
LDX EPOINT+1 ;if we're at point then set CV, CH so we can
CPX A4H ;display the cursor in the right place when
BNE EDPRS2 ;we come back
LDX CV
STX A2L
LDX CH
STX A2H
EDPRS2: LDY #$00
LDA (EPOINT),Y
CMP #$0D ;if it was a CR then it was displayed even if
BNE EDPRS3 ;we couldn't COUT it, so INCPNT so TEMPN8 is
JSR INCPNT ;correct.
EDPRS3: LDA EPOINT ;point is now at location after last char on
STA TEMPN8 ;screen; store in char-after-last-char-pointer
LDA EPOINT+1
STA TEMPN8+1
LDA A2H
STA CH
LDA A2L
STA CV
JSR BCALCA ;have CV in AC already
LDA A4L
STA EPOINT
LDA A4H
STA EPOINT+1
RTS
CHGSTP: LDA INDEV
BNE CHGSR1 ;Error if already editing with CHANGE
CHGST1: LDA LEVNUM
BNE CHGSR2
LDA LEVNUM+1
BNE CHGSR2
LDA TOKPTR+1
BEQ CHGNON
LDY #$00
LDA (TOKPTR),Y
STA ARG1
INY
LDA (TOKPTR),Y
STA ARG1+1 ;(GETTOK)
LDX #ARG1
JSR GETTYP
CMP #SATOM
BEQ CHGSR4
CMP #ATOM
BNE CHGSR5
LDX #ARG1
LDA #TEMPN1
JSR GETFUN
LDA TEMPN1+1
BEQ CHGNEW
CHGOLD: JSR CHGIN1
LDX #$01
LDA #ARG1
JSR POTEXT ;store function text in EDBUF
JSR CHGIN2
JMP CHGIN3
CHGSR1: LDA #XEDT
JMP ERROR
CHGSR2: JMP STTLR2 ;(ERROR XETL)
CHGSR4: JMP SPO5S ;(ERROR XUBL,ARG1)
CHGSR5: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
CHGNON: JSR CHGIN1
JSR PNTBEG ;set point to beginning of buffer
JSR CHGIN2
CHGIN3: JSR EDSPBF ;call edit-display-buffer
JMP CHGLOP ;call text and command handling loop
CHGNEW: JSR CHGIN1
LDX #TOMSG&$FF
LDY #TOMSG^
JSR PRTSTR
LDX #ARG1
LDA #$01
JSR LTYPE
CHGNLP: LDX #TOKPTR
JSR TFKADV
LDA TOKPTR+1
BEQ CHGN2
LDY #$00
LDA (TOKPTR),Y
STA ARG1
INY
LDA (TOKPTR),Y
STA ARG1+1
LDA #$20
JSR TPCHR
LDA #$00
LDX #ARG1
JSR LTYPE
JMP CHGNLP
CHGN2: LDA EPOINT
STA A4L
LDA EPOINT+1
STA A4H
JSR CHGIN2
JSR EDPBUF
JMP CHGLOP
CHGIN2: JSR SETVID ;make output device be screen again
LDA EPOINT
STA ENDBUF ;save end of buffer
LDA EPOINT+1
STA ENDBUF+1
CHGX1: JSR PNTBEG
LDA #$17 ;Window bottom to allow display of
STA WNDBTM ;"Apple Logo Editor" crock
LDA #EDBUF^ ;store location of first char displayed
STA TEMPN7+1 ;on screen (at beginning of buffer)
LDA #EDBUF&$FF
STA TEMPN7
JSR TOPSCR
JMP CHGNYM ;print editor name
CHGIN1: LDA #EDOUT&$FF ;location of edbuf output
STA CSWL
LDA #EDOUT^ ;routine (for TPCHR)
STA CSWH
LDA #BUFFER
STA INDEV
JMP PNTBEG ;initialize point for EDOUT
CHGNYM: LDA INVFLG
PHA ;Save old INVFLG
JSR SETINV ;print the "Apple Logo Screen Editor" thing on
LDA CH ;the bottom line in reversed characters.
PHA
LDA CV ;save current screen location
PHA
LDA BASLIN ;save old baseline
PHA
LDA BASLIN+1
PHA
LDA #$00
STA CH ;far left
LDA #$23
STA CV ;bottom of screen
LDA #$D0 ;slight speed bum -- we know we want
STA BASLIN ;the bottom of the screen, so instead
LDA #$07 ;of calculating it via BCALC, we load
STA BASLIN+1 ;it up.
LDX #CHGMSG&$FF
LDY #CHGMSG^
JSR PRTSTR
PLA
STA BASLIN+1
PLA
STA BASLIN
PLA
STA CV
PLA
STA CH
PLA
STA INVFLG ;Restore previous INVFLG
RTS
.PAGE
;Command subroutines. It is the responsibility of a command to do its
;own redisplay, leave CH and CV indicating the position of the point
;on the screen, and the appropriate value in BASLIN before returning
;to CHGLOP. The cursor will be turned on by CHGLOP, however.
;Any command (that does anything) must update the database. The
;database consists of the edit buffer (EDBUF), whose contents must be
;updated by insertions/deletions; the point (EPOINT,EPOINT+1); the
;location in the EDBUF of the first character displayed on the screen
;(TEMPN7,TEMPN7+1); the location in the EDBUF AFTER the last character
;displayed on the screen (TEMPN8,TEMPN8+1), and the location AFTER
;the last character in the EDBUF (ENDBUF,ENDBUF+1).
INSERT: PHA ;save char
JSR MVDOWN ;move the buffer (starting at point) down one.
PLA
PHA
JSR EDOUT ;put the char in the edit buffer
PLA
CMP #$0D
BEQ INSRCR
LDX CH
INX
CPX WNDWTH ;Are we at end of line...
BCC INSRT2 ;no, output straight
PHA
LDA #'! ;output a line continuation char.
JSR COUT
PLA ;recover char
LDX CV ;if we output the line cont. char then COUT
JMP INSRT0 ;has inc'ed CV, so don't do it again.
INSRT1: LDX CV
INX
INSRT0: CPX WNDBTM ;are we at end of screen...
BNE INSRT2
PHA ;yes, redisplay instead of EDSPBF
JSR CENTER ;^L type redisplay
PLA
INSRTS: RTS
INSRT2: JSR COUT ;output char to screen
JMP EDSPBF ;redisplay buffer from point down
INSRCR: PHA
JSR CLREOL
PLA
JMP INSRT1
;move the contents of the edit buffer after point down one until
;reaching end of buffer contents (NOT end of buffer). Increments end
;of buffer contents pointer. Bashes AC,Y.
MVDOWN: LDA ENDBUF
SEC
SBC #$01
STA A1L
LDA ENDBUF+1
SBC #$00
STA A1H
LDY #$01
MVLOOP: LDA A1H
CMP EPOINT+1
BCC MVRTS
BNE MVCONT
LDA A1L
CMP EPOINT
BCC MVRTS
MVCONT: DEY
LDA (A1L),Y
INY
STA (A1L),Y
LDA A1L
SEC
SBC #$01
STA A1L
BCS MVLOOP
DEC A1H
BCC MVLOOP ;(Always)
MVRTS: INC ENDBUF
BNE MVRTS1
INC ENDBUF+1
MVRTS1: RTS
;RDSPNT repositions the text on the screen around the point. The AC
;should hold the number of lines before the point one wants redisplay
;to start from. So, for ^L it should hold 12; for M-V it should hold
;23. RDSPNT will get confused if given a buffer that contains more
;than 256*39 contiguous chars without a carriage-return in them,
;because we have a one-bite physical line counter. You change it. Sets
;first and last char on screen pointers.
RDSPNT: STA A1H ;store the number of lines one wants before
LDY #$00 ;point on screen
STY A1L ;zero char-counter
STY A2L ;zero line-counter
LDA EPOINT+1
STA A4H ;save for recovery by EDPBUF
LDA EPOINT
STA A4L
SEC
SBC CH ;get to beginning of screen line
STA EPOINT
BCS RDSPT2
DEC EPOINT+1
RDSPT2: JSR DECPNT
LDA #EDBUF^
CMP EPOINT+1
BCC RDSPT3 ;if EDBUF is less than point, you're in
LDA #EDBUF&$FF ;buffer, otherwise at beginning or before
CMP EPOINT ;if at beginning or before (horrors) quit
BCC RDSPT3 ;else continue
JSR PNTBEG
JMP COUNTM
RDSPT3: LDA (EPOINT),Y
CMP #$0D ;CR
BEQ COUNTM ;if so, see if we have enough lines now
INC A1L ;else bump char counter
LDA A1L
CMP #$27 ;do we have a full line...
BNE RDSPT2 ;no, go back for more
COUNTM: STY A1L ;zero char counter
INC A2L ;bump line counter
LDA A2L ;lines gotten
CMP A1H ;lines wanted
BEQ REDISP ;if same, we done won, go redisplay.
BCS CNTDWN
LDA EPOINT+1
CMP #EDBUF^
BNE RDSPT2 ;if too few and at beginning of buffer,
LDA EPOINT
CMP #EDBUF&$FF ;redisplay anyway
BEQ REDISP
BNE RDSPT2 ;else go for more
CNTDWN: LDA A2L ;faster than a multiply, usually
SEC
SBC A1H ;# of extra lines
STA A3L
CNTLOP: LDA EPOINT
CLC
ADC #$27 ;move down a screen line of chars
BCC CNTLP2
INC EPOINT+1
CNTLP2: LDA A3L
SEC
SBC #$01 ;dec line counter
STA A3L
BNE CNTLOP ;go for more if not zero
REDISP: JSR TOPSCR ;physical cursor at top of screen
LDA EPOINT
STA TEMPN7 ;make first-char-on-screen point
LDA EPOINT+1
STA TEMPN7+1
JMP EDPBUF ;redisplay and restore point
;redisplay screen around point. Sets CV, CH, BASLIN,
;first-char-on-screen, char-after-last-char-on-screen.
CENTER: LDA #$0C ;#$0C = 12.
JMP RDSPNT ;redisplay for point on 13th line
;NXTSCR moves to the next screenful in the buffer and displays it,
;setting point to the character after the last char on the previous
;screenful (thus it will be at top of screen).
NXTSCR: LDA TEMPN8+1
CMP ENDBUF+1
BNE NXTSC2
LDA TEMPN8
CMP ENDBUF
BEQ RCMPLN ;complain if no next screen
NXTSC2: LDA TEMPN8
STA EPOINT ;point
STA TEMPN7 ;first char on screen
LDA TEMPN8+1
STA EPOINT+1
STA TEMPN7+1
JSR TOPSCR
JMP EDSPBF ;display
;PRVSCR moves to the previous screenful in the buffer, leaves point at
;the top.
PRVSCR: LDA TEMPN7
STA EPOINT ;make point be beginning of screen
LDA TEMPN7+1
STA EPOINT+1
LDA #$17 ;redisplay 23 lines before it
JSR RDSPNT
LDA TEMPN7
STA EPOINT ;make point be beginning of screen
LDA TEMPN7+1
STA EPOINT+1
JMP TOPSCR ;cursor at top of screen
;RUBOUT deletes char behind cursor, redisplays.
RUBOUT: LDA EPOINT+1
CMP #EDBUF^
BCC RCMPLN ;are we before or at beginning...
BNE RUBOT2
LDA #EDBUF&$FF ;I know the switch is unorthodox, sorry
CMP EPOINT
BCS RCMPLN
RUBOT2: JSR BACKUP
JMP DELET2
RCMPLN: JMP BELL ;complain if so.
;DELETE deletes char under cursor, redisplays.
DELETE: LDA ENDBUF+1
CMP EPOINT+1
BCC RCMPLN ;if at buffer end, complain
BNE DELET2
LDA EPOINT
CMP ENDBUF
BCS RCMPLN
DELET2: LDA #$01 ;only moving stuff up one place
STA A1L
LDA #$00
STA A1H
LDA #A1L&$FF
JSR MOVEUP
JMP EDSPBF
;MOVEUP takes the location of an arg in AC,Y and moves the argth char
;after the point into the point, the arg+1th into the point+1, and so
;on until the buffer end is reached. Then it sets the end of buffer
;pointer to the point before restoring it. Better make plenty damned
;sure that MOVEUP is used carefully so that end-of-buffer-pointer
;doesn't become too small.
MOVEUP: TAX
LDA EPOINT ;we are saving point to restore it later
PHA
STA TEMPX3 ;in TEMPX3 for source
LDA EPOINT+1
PHA
STA TEMPX3+1
LDA $00,X
CLC
ADC TEMPX3 ;and add to point for source address
STA TEMPX3
LDA $01,X
ADC TEMPX3+1
STA TEMPX3+1
MVULOP: LDA TEMPX3+1
CMP ENDBUF+1 ;are we looking at end-of-buffer...
BCC MVULP2 ;no, continue
BNE MVURTS ;past, return
LDA TEMPX3
CMP ENDBUF
BCS MVURTS ;past or end, return
MVULP2: LDY #$00
LDA (TEMPX3),Y ;source
STA (EPOINT),Y ;dest
JSR INCPNT ;inc dest
INC TEMPX3 ;inc source
BNE MVULOP
INC TEMPX3+1
JMP MVULOP
MVURTS: LDA EPOINT
STA ENDBUF ;new end-of-buffer
LDA EPOINT+1
STA ENDBUF+1
PLA
STA EPOINT+1
PLA
STA EPOINT ;recover point
RTS ;that's all, folks
;FORCHR moves forward one character, bells if at end of buffer.
FORCHR: LDA EPOINT+1
CMP ENDBUF+1
BCC FORCH2 ;if at buffer end complain
BNE FCMPLN
LDA EPOINT
CMP ENDBUF
BCS FCMPLN
FORCH2: LDA TEMPN8 ;!!**CROCK**!! THIS CAUSES REDISPLAY WHEN
SEC ;YOU TRY FORWARD ON NEXT TO LAST CHAR IN
SBC #$01 ;BUFFER!!! SHOULD CHECK CV,CH OR (EPOINT).
STA A3L ;see if on last char on screen
LDA TEMPN8+1
SBC #$00
STA A3H
CMP EPOINT+1
BNE FORCH3
LDA A3L
CMP EPOINT
BNE FORCH3
JSR INCPNT ;yes, inc point and center
JMP CENTER
FCMPLN: JMP BELL
FORCH3: LDY #$00
LDA (EPOINT),Y
CMP #$0D
BNE FORCH5
FORCH4: STY CH ;if on a CR, we know we're not at end of
INC CV ;screen by now, so zero CH, inc CV.
JSR BCALC ;must calc new baseline
JMP INCPNT
FORCH5: LDA CH
CMP #$26 ;at right before "!"
BEQ FORCH4
INC CH
JMP INCPNT
;BACKUP backs CH and CV up, decs point. No redisplay, unless page
;boundary crossed, or previous char is a CR. Don't call it unless the
;database is consistent; i.e., CV and CH are at the point on the
;screen.
BACKUP: LDA #EDBUF^ ;check if at beginning of buffer
CMP EPOINT+1
BCC BACK2 ;no, win
BNE FCMPLN ;yes, complain, quit
LDA #EDBUF&$FF
CMP EPOINT
BCS FCMPLN
BACK2: JSR DECPNT
LDA CV ;see if we're at beginning of screen
BNE BACK3
LDA CH
BNE BACK3
JMP CENTER ;center
BACK3: LDA CH
BNE BACK5
LDY #$00
LDA (EPOINT),Y
CMP #$0D ;#$0D = CR
BNE BACK4
LDA EPOINT
STA A4L ;when we back over a cr we call
LDA EPOINT+1 ;EDPBUF so as to save space (by
STA A4H ;not having code here to count down a
LDA TEMPN7 ;line)
STA EPOINT
LDA TEMPN7+1
STA EPOINT+1
JSR TOPSCR
JMP EDPBUF ;don't need redisplay, space bum
BACK4: DEC CV
LDA #$26 ;just before the "!"
STA CH
JSR BCALC
RTS
BACK5: DEC CH
RTS
;UPLINE moves to the previous line, maintaining horizontal position if
;that line's length allows it. Does redisplay. Bashes A4L, A4H, A3L,
;A3H.
UPLINE: LDY #$00
STY A4L ;zero char counters - A3L, A3H for desired
STY A3L ;line's length; A4L, A4H for current line's
STY A4H ;length up to current char
STY A3H
LDA EPOINT ;complain if at beginning of buffer
CMP #EDBUF&$FF
BNE UPLOP1
LDA EPOINT+1
CMP #EDBUF^
BEQ UCMPLN
UPLOP1: JSR DECPNT ;dec point; we are searching (while counting
LDA EPOINT ;chars) for the beginning of this line.
CMP #EDBUF&$FF
BNE UPLOP2 ;complain if you encounter the buffer
LDA EPOINT+1 ;beginning while doing this, because this
CMP #EDBUF^ ;means there was no previous line.
BEQ UCMPLN
UPLOP2: LDA (EPOINT),Y
CMP #$0D ;if we are on a CR we have gotten as far as we
BEQ GETNXT ;want, found Nirvana, all that stuff. Go check
INC A4L ;out the previous line; else inc counter and
BNE UPLOP1 ;go back for more.
INC A4H
JMP UPLOP1
UCMPLN: JMP BELL ;complain
GETNXT: LDA EPOINT ;if at buffer beginning we are done and should
CMP #EDBUF&$FF ;go do compares.
BNE GTNXT2
LDA EPOINT+1
CMP #EDBUF^
BEQ GTDOWN ;if we get to buffer beginning count back
JSR DECPNT ;down
GTNXT2: LDA (EPOINT),Y
CMP #$0D ;also count back down if we found a CR, but
BNE GTNXT3 ;first inc pint to be on real beginning of
JSR INCPNT ;line.
JMP GTDOWN
GTNXT3: INC A3L ;else inc counter and go fer more.
BNE GETNXT
INC A3H
JMP GETNXT
GTDOWN: LDA A4H ;in GTDOWN (maw faw) what we are doing is
CMP A3H ;comparing the lengths of the desired line
BCC OLDWIN ;and the old line. If that of the desired
BNE NEWWIN ;is the lesser, we will move down it the
LDA A4L ;length of the old one. Otherwise we will
CMP A3L ;go to its end.
BCC OLDWIN
BCS NEWWIN
OLDWIN: LDA EPOINT
CLC
ADC A4L ;add length to point
STA EPOINT
LDA EPOINT+1
ADC A4H
STA EPOINT+1
JMP GTRDSP
NEWWIN: LDA EPOINT
CLC
ADC A3L ;add length to point
STA EPOINT
LDA EPOINT+1
ADC A3H
STA EPOINT+1
GTRDSP: CMP TEMPN7+1
BCC UCENTR ;now we see if we are off the screen
BNE GTRDP2
LDA EPOINT
CMP TEMPN7
BCC UCENTR ;if before beginning CENTER
BEQ UTPSCR ;if exactly at top no redisplay necessary
GTRDP2: LDA EPOINT+1
CMP TEMPN8+1
BCC GTRDP3 ;if in bounds call EDPBUF
BNE UCENTR ;if after (need to check because this
LDA EPOINT ;routine also used by NXTLIN), CENTER.
CMP TEMPN8
BCC GTRDP3
BCS UCENTR ;always
GTRDP3: LDA EPOINT ;point stored for recovery by EDPBUF
STA A4L
LDA EPOINT+1
STA A4H
JMP REDISP
UCENTR: JMP CENTER
UTPSCR: JMP TOPSCR
;OPLINE inserts a CR at point w/o inc'ing point.
OPLINE: LDA EPOINT+1
CMP #EBFEND^
BCC OPLIN1
BNE OPLRTS
LDA EPOINT
CMP #EBFEND&$FF ;Are we at end of edit buffer...
BCS OPLRTS ;if so, quit
OPLIN1: JSR MVDOWN
LDY #$00
LDA #$0D
STA (EPOINT),Y ;insert CR at point
JMP EDSPBF ;redisplay from here down.
OPLRTS: RTS
.PAGE
.SBTTL File System
SDELET: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #SATOM
BEQ SDELR2
CMP #ATOM
BNE SDELR3
JSR DOSSTP
LDX #DELETM&$FF
LDY #DELETM^
JSR PRTSTR
JSR DTPATM ;Type atom DOS-style
LDX #LOGOM&$FF
LDY #LOGOM^
JSR PRTSTR
LDA #$8D
JSR TPCHR
JSR RSTIO
JMP POPJ
SDELR2: JMP SPO5S ;(ERROR XUBL,ARG1)
SDELR3: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
;file routines should call this to set up error return from DOS.
STDERR: LDA DOSERR
ORA #$80 ;high bit on for DOSERR flag
STA DOSERR
LDA #DERROR&$FF
STA DSERET
LDA #DERROR^
STA DSERET+1
RTS
;DOS error routine comes here
DERROR: JSR RSTIO
LDA DERCOD ;DOS error code
CMP #$04
BEQ WTPROT ;write-protected file
CMP #$06
BEQ FLNFND ;file not found
CMP #$09
BEQ DSKFUL ;disk full
CMP #$0A
BEQ LCKFIL ;attempt to overwrite a locked file
IOERRR: LDA #XIOR ;i/o error
JMP ERROR
WTPROT: LDA #XWTP
JMP ERROR
FLNFND: LDA #XFNF
JMP ERROR
DSKFUL: LDA #XDKF
JMP ERROR
LCKFIL: LDA #XLKF
JMP ERROR
;set up magic things for DOS
DOSSTP: LDA #$40 ;magic number for Applesoft
STA DLNGFG ;store in DOS language flag
LDA #$00
STA DSPFL2 ;store things not = to $FF
STA DSPFL1 ;or apple val for ], in these, respectively.
JSR STDERR ;set up return address for DOS error
JSR SAPOUT ;store APOUT in CSWL so DOS prints properly
JMP DOSEAT ;let DOS eat these
SSAVE: LDA INDEV
BNE SAVSR1 ;Error if editing with ALEC
LDA GRPHCS
BEQ SAVST1
JSR RESETT
LDX #SCS&$FF
LDY #SCS^
JSR PUSH ;So we return to graphics mode when done
SAVST1: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #SATOM
BEQ SAVSR2
CMP #ATOM
BNE SAVSR3
JSR CHGIN1 ;output to buffer
JSR POFUNS ;get functions into buffer
JSR PONAMS ;get variables into buffer
LDA EPOINT
STA ENDBUF
LDA EPOINT+1
STA ENDBUF+1
LDA #$00
STA INDEV ;Reset INDEV so quotes not printed on funny-pnames
JSR DOSSTP ;Wake up DOS
LDX #SAVEM&$FF
LDY #SAVEM^
JSR PRTSTR
JSR DTPATM ;Type atom DOS-style
LDX #LOGOM&$FF
LDY #LOGOM^
JSR PRTSTR
LDX #SAVEM2&$FF
LDY #SAVEM2^
JSR PRTSTR ;write file
JSR DPRLEN ;Give it file's length
LDA #$8D
JSR TPCHR ;let it go
JSR PNTBEG
LDA #EDBUF&$FF
STA ENDBUF
LDA #EDBUF^
STA ENDBUF+1 ;zero ENDBUF so RETRIEVE not possible
JSR RSTIO
JMP POPJ
SAVSR1: LDA #XNWE ;can't hack files from editor
JMP ERROR
SAVSR2: JMP SPO5S ;(ERROR XUBL,ARG1)
SAVSR3: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
DPRLEN: SEC
LDA ENDBUF
SBC #$00
STA TEMPN
LDA ENDBUF+1
SBC #$20
STA TEMPN+1
JSR DPR2HX
LDA TEMPN
DPR2HX: PHA
LSR A
LSR A
LSR A
LSR A
JSR DPRHEX
PLA
DPRHEX: AND #$0F
CMP #$0A
BCC DPRH1
ADC #$06
DPRH1: ORA #$B0
JMP TPCHR
SREAD: LDA INDEV
BNE SAVSR1 ;Error if editing with ALEC
LDA GRPHCS
BEQ SRDF1
JSR RESETT
LDX #SCS&$FF
LDY #SCS^
JSR PUSH ;So we return to graphics mode when done
SRDF1: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #SATOM
BEQ SAVSR2
CMP #ATOM
BNE SAVSR3
JSR DOSSTP
LDX #LOADM&$FF
LDY #LOADM^
JSR PRTSTR
JSR DTPATM ;Type atom DOS-style
LDX #LOGOM&$FF
LDY #LOGOM^
JSR PRTSTR
LDA #$8D
JSR TPCHR
JSR RSTIO
CLC
LDA FILLEN
ADC #EDBUF&$FF
STA ENDBUF ;recover buffer length from file length
LDA FILLEN+1
ADC #EDBUF^
STA ENDBUF+1
LDA #BUFFER
STA INDEV
LDX #SRDF2&$FF
LDY #SRDF2^
JSR PUSH ;Return address from SREAD2
JSR PNTBEG ;point to beginning
JMP SREAD1
SRDF2: JSR RSTIO
LDA #EDBUF&$FF ;If successful, RETRIEVE won't be necessary
STA ENDBUF
LDA #EDBUF^
STA ENDBUF+1
JMP POPJ
SCATLG: JSR DOSSTP
LDA APCOUT
PHA
LDA APCOUT+1
PHA
LDA APCOUT+2
PHA ;Incredibly bletcherous hack to allow DOS to work
LDA #$6C ;(JMP indirect code)
STA APCOUT
LDA #CSWL ;for JMP (CSWL)
STA APCOUT+1
LDA #$00 ;DOS does a JSR $FDED here -
STA APCOUT+2 ;it depends on their monitor being in place (End of gross hack)
LDX #CATLGM&$FF
LDY #CATLGM^
JSR PRTSTR
PLA
STA APCOUT+2
PLA
STA APCOUT+1
PLA
STA APCOUT
JSR RSTIO
JMP POPJ
DTPATM: LDA ARG1
AND #$FC
STA ARG1
LDX #ARG1
LDY #TEMPN5
JSR GETPNM
DTPTMW: LDA TEMPN5+1
BEQ RSTR
LDY #$00
LDA (TEMPN5),Y
STA TEMPNH
INY
LDA (TEMPN5),Y
STA TEMPNH+1 ;(CAR)
INY
LDA (TEMPN5),Y
TAX
INY
LDA (TEMPN5),Y
STA TEMPN5+1
STX TEMPN5 ;(CDR)
LDA TEMPNH
ORA #$80
JSR TPCHR
LDA TEMPNH+1
BEQ RSTR
ORA #$80
JSR TPCHR
JMP DTPTMW
APOUT: AND #$7F ;eat Apple idiot char codes, type Ascii
JMP COUT
SAPOUT: LDA #APOUT&$FF
STA CSWL
LDA #APOUT^
STA CSWH
RTS
.PAGE
.SBTTL Monitor Routines
BREAK1: LDA #$0D
JMP TPCHR
;Reset I/O to default drivers (INDEV, OUTDEV = 0).
RSTIO: JSR SETVID
JSR SETKBD
LDA #KBD
STA INDEV
STA OUTDEV
RSTR: RTS
CLRCBF: LDA CHBUFR ;Buffer empty when next-free equals next-to-read
STA CHBUFS
RTS
GTBUF: SEC
LDA CHBUFR
SBC CHBUFS
AND #$3F
BEQ GTBRTS ;Return zero if buffer empty (CHBUFR = CHBUFS)
LDX CHBUFR
AND #$3F
LDA CHBSTT,X
INC CHBUFR ;Increment next-to-read
GTBRTS: RTS
;Clear the display/output.
RESETT: JSR SETTXT
JSR SETNRM
JMP HOME
;TPCHR should always be called with an Ascii character. If you want it to flash
;or be inverted, call SETFLS or SETINV first, and resetting INVFLG when done.
TPCHR: JMP (CSWL)
.PAGE
;Modified Monitor for Apple-LOGO
SCRN2: BCC RTMSKZ
LSR A
LSR A
LSR A
LSR A
RTMSKZ: AND #$0F
RTS
PRNTYX: TYA
PRNTAX: JSR PRBYTE
PRNTX: TXA
JMP PRBYTE
INSDS1: LDX PCL
LDY PCH
JSR PRYX2
PRBLNK: LDX #$03
PRBL2: LDA #$20
PRBL3: JSR TPCHR
DEX
BNE PRBL2
RTS
.PAGE
MONBRK: PHA
LDA GETRM1
LDA GETRM1
LDA #$00
STA BANK4K
JSR SETNRM
JSR SETVID
JSR SETKBD
JSR CLRCBF
PLA
PLP
JSR SAVE
PLA
STA PCL
PLA
STA PCH
LDA #$01
STA MONFLG
OLDBRK: JSR INSDS1
JSR RGDSP1
MON: CLD
JSR BELL
MONZ: JSR BREAK1
LDA #'*
JSR TPCHR
JSR GETLN
JSR ZMODE
NXTITM: JSR GETNMB
STY YSAV
LDY #MONNUM
CHRSRC: DEY
BMI MON
CMP CHRTBL,Y
BNE CHRSRC
JSR TOSUB
LDY YSAV
JMP NXTITM
.PAGE
DIG: LDX #$03
ASL A
ASL A
ASL A
ASL A
NXTBIT: ASL A
ROL A2L
ROL A2H
DEX
BPL NXTBIT
NXTBAS: LDA MODE
BNE NXTBS2
LDA A2H,X
STA A1H,X
STA A3H,X
NXTBS2: INX
BEQ NXTBAS
BNE NXTCHR
GETNMB: LDX #$00
STX A2L
STX A2H
NXTCHR: LDA LINARY,Y
INY
CMP #'0
BCC NTDIG
CMP #':
BCC DIG
CMP #'A
BCC NTDIG
CMP #'G
BCS NTDIG
ADC #$09
BNE DIG ;(Always)
TOSUB: TYA
ASL A
TAY
LDA SUBTBL,Y
STA BSLTMP
INY
LDA SUBTBL,Y
STA BSLTMP+1
LDA MODE
JSR ZMODE
JMP (BSLTMP)
ZMODE: LDY #$00
STY MODE
NTDIG: RTS
.PAGE
REGDSP: JSR BREAK1
RGDSP1: LDA #ACC
STA A3L
LDA #ACC^
STA A3H
LDX #$FB
RDSP1: LDA #$20
JSR TPCHR
LDA RTBL-$FB,X
JSR TPCHR
LDA #'=
JSR TPCHR
LDA ACC+5,X
JSR PRBYTE
INX
BMI RDSP1
RTS
NXTA4: INC A4L
BNE NXTA1
INC A4H
NXTA1: LDA A1L
CMP A2L
LDA A1H
SBC A2H
INC A1L
BNE RTS4B
INC A1H
RTS4B: RTS
PRA1: LDY A1H
LDX A1L
PRYX2: JSR BREAK1
JSR PRNTYX
LDY #$00
LDA #'-
JMP TPCHR
.PAGE
XAM8: LDA A1L
ORA #$07
STA A2L
LDA A1H
STA A2H
MD8CHK: LDA A1L
AND #$07
BNE DATAOT
XAM: JSR PRA1
DATAOT: LDA #$20
JSR TPCHR
LDA (A1L),Y
JSR PRBYTE
JSR NXTA1
BCC MD8CHK
RTS4C: RTS
PRBYTE: PHA
LSR A
LSR A
LSR A
LSR A
JSR PRHEXZ
PLA
PRHEX: AND #$0F
PRHEXZ: CLC
ADC #'0
CMP #':
BCC PRHEXC
ADC #$06
PRHEXC: JMP TPCHR
BL1: DEC YSAV
BEQ XAM8
BLANK: DEX
BNE SETMDZ
CMP #':
BNE XAM
STOR: STA MODE
LDA A2L
STA (A3L),Y
INC A3L
BNE RTS5
INC A3H
RTS5: RTS
SETMOD: LDY YSAV
LDA LINARY-1,Y
SETMDZ: STA MODE
RTS
.PAGE
LT: LDX #$01
LT2: LDA A2L,X
STA A4L,X
STA A5L,X
DEX
BPL LT2
RTS
MOVE: LDA (A1L),Y
STA (A4L),Y
JSR NXTA4
BCC MOVE
RTS
VFY: LDA (A1L),Y
CMP (A4L),Y
BEQ VFYOK
JSR PRA1
LDA (A1L),Y
JSR PRBYTE
LDA #$20
JSR TPCHR
LDA #'(
JSR TPCHR
LDA (A4L),Y
JSR PRBYTE
LDA #')
JSR TPCHR
VFYOK: JSR NXTA4
BCC VFY
RTS
A1PC: TXA
BEQ A1PCRT
A1PCLP: LDA A1L,X
STA PCL,X
DEX
BPL A1PCLP
A1PCRT: RTS
SETFLS: LDY #$40
BNE SETIFL ;(Always)
SETINV: LDY #$00
BEQ SETIFL ;(Always)
SETNRM: LDY #$80 ;(Negative flag ignored)
SETIFL: STY INVFLG
RTS
.PAGE
SETKBD: LDA #$00
STA A2L
INPRT: LDY #KEYIN&$FF
LDA #KEYIN^
LDX #KSWL
BNE IOPRT ;(Always)
SETVID: LDA #$00
STA A2L
OUTPRT: LDY #COUT&$FF
LDA #COUT^
LDX #CSWL
IOPRT: STA $01,X
LDA A2L
AND #$0F
BEQ IOPRT1
ORA #IOADR^
STA $01,X
LDY #$00
IOPRT1: STY $00,X
RTS
GO: JSR A1PC
JSR RESTOR
LDA #$00
STA MONFLG
JMP (PCL)
BSWTCH: LDA BANK4K
BNE BSW1
INC BANK4K
LDA GETRM2
LDA GETRM2
LDA #'2
JSR TPCHR
JMP BREAK1
BSW1: DEC BANK4K
LDA GETRM1
LDA GETRM1
LDA #'1
JSR TPCHR
JMP BREAK1
.PAGE
XMON: LDA KILRAM
LDA #$4C ;(JMP instruction code)
STA USRADR
LDA #MONBRK&$FF
STA USRADR+1
LDA #MONBRK^
STA USRADR+2
JMP SYSMON ;User can re-enter this monitor with control-Y
CRMON: JSR BL1
PLA
PLA
JMP MONZ
RESTOR: LDA STATUS
PHA
LDA A5H
RESTR1: LDX XREG
LDY YREG
PLP
RTS
SAVE: STA ACC
SAV1: STX XREG
STY YREG
PHP
PLA
STA STATUS
TSX
STX SPNT
CLD
RTS
.PAGE
BELL: LDA #$40
JSR WAIT
LDY #$C0
BELL1: LDA #$0C
JSR WAIT
LDA SPKR
DEY
BNE BELL1
BRTS: RTS
;HOME - Home the cursor and clear the screen
HOME: LDA WNDTOP
STA CV
LDY #$00
STY CH
BEQ CLEOP1 ;(always branches)
;COUT - Output the character in A to the screen
COUT: PHA
STY YSAV1
JSR COUT1
PLA
LDY YSAV1
RTS
;CROUT - Output a Carriage return; suppress output if necessary
CROUT: JSR CLREOL
JSR TSTCHR
BCC CR
CMP #LSTKEY
BNE CR
BIT KPCLR
JSR RWAIT
JMP CR
;CLREOP - Clear to end-of-page
CLREOP: LDY CH
LDA CV
CLEOP1: PHA
JSR BCALCA
JSR CLEOL1
LDY #$00
PLA
ADC #$00
CMP WNDBTM
BCC CLEOP1
BCS BCALC ;(Always)
.PAGE
COUT1: CMP #$0D
BEQ CROUT
CMP #$07
BEQ BELL ;bell on output of ^G
ORA #$80 ;Assume normal first
CMP #$E0
BCC COUTZ ;See if it's lower case
AND #$DF ;Make it uppercase if so
COUTZ: LDY INVFLG ;Flash or Invert if set
BMI COUTZ1
AND #$3F ;Flash or invert - strip top bits
ORA INVFLG ;and OR in flag
COUTZ1: LDY CH
STA (BASLIN),Y
INC CH ;Advance Horizontally
LDA CH
CMP WNDWTH
BCC BRTS
CR: LDA #$00
STA CH
LF: INC CV
LDA CV
CMP WNDBTM
BCC BCALCA ;Finish if scrolling unnecessary
DEC CV
SCROLL: LDA WNDTOP
PHA
JSR BCALCA
SCRL1: LDA BASLIN
STA BSLTMP
LDA BASLIN+1
STA BSLTMP+1
LDY WNDWTH
DEY
PLA
ADC #$01
CMP WNDBTM
BCS SCRL3
PHA
JSR BCALCA
SCRL2: LDA (BASLIN),Y ;Shift a line up one, character by character
STA (BSLTMP),Y
DEY
BPL SCRL2 ;Next character
BMI SCRL1 ;Next line
SCRL3: LDY #$00
JSR CLEOL1 ;Clear the bottom line, then calculate new base
;falls through
.PAGE
;falls in
BCALC: LDA CV
BCALCA: PHA
LSR A
AND #$03
ORA #$04
STA BASLIN+1
PLA
AND #$18
BCC BCALC2
ADC #$7F
BCALC2: STA BASLIN
ASL A
ASL A
ORA BASLIN
ADC WNDLFT
STA BASLIN
RTS
;CLREOL - Clear to end-of-line
CLREOL: LDY CH
CLEOL1: LDA #$A0 ;(Space, non-flashing, non-inverted)
CLEOL2: STA (BASLIN),Y
INY
CPY WNDWTH
BCC CLEOL2
RTS
RDKEY: JSR GTBUF ;Get character from the buffer if non-empty
CMP #$00
BNE KRTS
JMP (KSWL)
KEYIN: LDY CH
LDA (BASLIN),Y
PHA
AND #$7F
ORA #$40
STA (BASLIN),Y ;Make cursor position flash
JSR RDKEY1
STA BSLTMP
PLA
STA (BASLIN),Y
LDA BSLTMP
KRTS: RTS
RDKEY1: INC RNDL
BNE RDKEY2
INC RNDH
RDKEY2: JSR TSTCHR
BCC RDKEY1
BIT KPCLR
RTS
.PAGE
;Check for input character. Return with carry set and character in A if
;character pending, else carry clear. Supplies "[" for replacement character.
TSTCHR: BIT KPFLAG ;KBD device, check special locations
BPL KNONE
LDA KPFLAG
AND #$7F
CMP #LBRAK
BNE TRTS
LDA #'[
TRTS: SEC
RTS
KNONE: CLC ;Return carry clear if no character
RTS
;SETTXT - Set text mode
SETTXT: LDA $C054 ;Primary page
LDA $C051 ;Set text mode
LDA #$00
STA WNDTOP
STA WNDLFT
LDA #$18
STA WNDBTM
LDA #$28
STA WNDWTH
LDA #$17
STA CV
JMP BCALCA
.PAGE
;GETLN - Gets a line of input from the keyboard. Looks for LOGO interrupt
; characters, and recognizes the left-bracket alias character. Returns
; number of characters (not including terminator) in X.
GETLN: LDX #$00 ;X is LINARY index
JSR RDKEY ;Get an ascii value from keyboard
CMP #PULCHR ;(Pull back last line), Check at first character
BNE NPRVLN
PREVLN: LDA LINARY,X ;get char from line-array
BEQ GNXTX ;done if null char
CMP #$0D
BEQ GNXTX ;or carriage-return encountered
JSR TPCHR ;output char to screen
INX ;next char
BNE PREVLN ;(Always)
NPRVLN: TAY
TXA ;If first character, clear line array
GTLN1L: DEX
STA LINARY,X
BNE GTLN1L
TYA
BNE GTLN1X ;(Always)
NEXTC: JSR RDKEY ;Get an ascii value from keyboard
GTLN1X: CMP #$1B ;(ESC)
BEQ GRUBOT ;do a getln rubout
CMP #$04 ;(^D)
BEQ GDELET ;do a getln delete
CMP #$15 ;(Forward arrow)
BNE GTLN1C
LDA LINARY,X ;Get character under cursor
BEQ GTLNX1
CMP #$0D
BNE GTLNX2
GTLNX1: LDA #$20
GTLNX2: STA LINARY,X
JSR TPCHR ;Echo character
CPX #$F8
BCC GETLN3
JSR BELL
GETLN3: INX
BNE NEXTC
JMP CANCEL
GRUBOT: TXA
BEQ NEXTC
DEX
DEC CH
BPL GDELET
LDA WNDWTH
STA CH
DEC CH
LDA WNDTOP
CMP CV
BCS GDELET
DEC CV
JSR BCALC
JMP GDELET
GTLN1C: CMP #$08 ;(Back arrow)
BEQ BCKSPC
JMP GTLN1D
BCKSPC: TXA
BEQ NEXTC
DEX
DEC CH
BPL NEXTC
LDA WNDWTH
STA CH
DEC CH
LDA WNDTOP
CMP CV
BCS NEXTC
DEC CV
JSR BCALC
GNXTX: CPX #$00
BEQ GNXTC
LDA #$00
STA LINARY+1,X
GNXTC: JMP NEXTC
GDELET: TXA
PHA ;save location in LINARY
LDA CH ;and location on screen
PHA
LDA CV
PHA
GDLTLP: INX ;get next char in LINARY
LDA LINARY,X
STA LINARY-1,X ;store in previous location
BEQ GDLDON ;if null done
CMP #$0D
BEQ GDLTLP
JSR TPCHR ;type out
JMP GDLTLP
GDLDON: LDA #$20 ;found a null, print a space at line
JSR TPCHR ;end
PLA
STA CV
PLA
STA CH
JSR BCALC
PLA
TAX
JMP NEXTC
CANCEL: LDA #'\
JSR TPCHR
JSR BREAK1
JMP GETLN
GTLN1D: CMP #$18 ;(Cancel line)
BEQ CANCEL
LDY MONFLG
BNE GTLN2A ;Don't check for interrupt characters if in monitor
LDY INDEV
BNE GTLN2A ;or if evaluating the edit buffer
CMP #STPKEY
BEQ GTLNR1
CMP #PAUSKY
BEQ GTLNR2
CMP #FULCHR
BEQ GTLNR3
CMP #MIXCHR
BNE GTLN2A
JSR STPMIX
JMP NEXTC
GTLNR3: JSR STPFUL
JMP NEXTC
GTLN2A: LDY LINARY,X
STA LINARY,X
CMP #$0D
BEQ GCR
JSR TPCHR
TXA
PHA ;save location in LINARY
LDA CH ;and location on screen
PHA
LDA CV
PHA
GINSL1: LDA LINARY+1,X ;get next location
PHA ;Save value
TYA ;Get previous location
BEQ GINSDN ;if null done
CMP #$0D
BEQ GINSDN
STA LINARY+1,X ;store in next location
JSR TPCHR ;type out
PLA
TAY
CPX #$F8
BCC GINSL2
JSR BELL
GINSL2: INX
BNE GINSL1
JMP CANCEL
GINSDN: PLA ;Discard null
PLA
STA CV
PLA
STA CH
PLA
TAX
INX
JSR BCALC
JMP NEXTC
GCR: JMP BREAK1
GTLNR1: JMP STPPK1
RWAIT: JSR RDKEY
CMP #STPKEY
BEQ GTLNR1
CMP #PAUSKY
BNE WRTS
GTLNR2: JMP STPPKZ
WAIT: SEC
WAIT1: PHA
WAIT2: SBC #$01
BNE WAIT2
PLA
SBC #$01
BNE WAIT1
WRTS: RTS
.PAGE
.SBTTL Argument Passing Routines:
;Gets a numerical argument. Returns with carry set if flonum.
GT1NUM: LDX #NARG1
JSR VPOP
GT1NMX: JSR GTNUM1 ;Alt. entry
BCC GTERR1
CMP #FLO ;(Sets carry if Flonum)
RTS
;Gets two numerical arguments. Coerces one to Real if not same type.
;Returns with carry set if Flonum results.
GT2NUM: LDX #TEMPX2
JSR VPOP
LDX #NARG1
JSR VPOP
JSR GETNUM ;GETNUM returns carry clear if argument non-numerical
BCC GTERR1
STA ANSN3 ;Save first type
JSR GTNUM2 ;Special GETNUM for NARG2
BCC GTERR2
CMP ANSN3
BNE GT2NM1
CMP #FLO ;(Sets carry if Flonum)
RTS
GT2NM1: CMP #FIX ;Assume ARG1 is the integer
BNE GT2NM2
JSR FLOTN2 ;Nope, it was NARG2, convert to flt. pt.
SEC
RTS
GT2NM2: JSR FLOTN1 ;Convert NARG1 to floating pt.
SEC
RTS
GTERR1: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
GTERR2: JMP SFPT1 ;(ERROR XWTA,ARG2,CURTOK)
;Gets a numerical argument, changes to integer if Real.
;Give an error if high bytes not zero.
GT1FIX: LDX #NARG1
JSR VPOP
JSR GETNUM
BCC GTERR1
CMP #FIX
BEQ GT1FX1
JSR XINT1
GT1FX1: LDX #NARG1
JSR CHKINT
BCS GTERR1
RTS
;Gets two numerical arguments, changes either or both to integer if Real.
;Gives an error if either arg. has high bytes non-zero.
GT2FIX: LDX #TEMPX2
JSR VPOP
LDX #NARG1
JSR VPOP
JSR GETNUM
BCC GTERR1
CMP #FIX
BEQ GT2FX1
JSR XINT1
LDX #NARG1
JSR CHKINT
BCS GTERR1
GT2FX1: JSR GTNUM2 ;Special GETNUM for NARG2
BCC GTERR2
CMP #FIX
BEQ GT2FX2
JSR XINT2
GT2FX2: LDX #NARG2
JSR CHKINT
BCS GTERR2
RTS
CHKINT: LDA $02,X
BNE CHKIN2
LDA $03,X
BNE CHKNNT
CHKIOK: CLC
RTS
CHKIN2: CMP #$FF
BNE CHKNNT
CMP $03,X
BEQ CHKIOK
CHKNNT: SEC
RTS
;GETNM2 saves NARG1 before calling GETNUM with NARG2, then restores NARG1.
GTNUM2: LDY #A3L
JSR XN1TOY ;Save NARG1
LDA TEMPX2
STA NARG2
LDA TEMPX2+1
STA NARG2+1
LDX #NARG2
JSR GETNUM
PHA ;Save type
LDY #A3L
JSR XYTON1 ;Restore NARG1
PLA ;Get type back
RTS
;Gets a numerical argument if possible. Returns with carry clear if successful.
;Returns with type of argument (Fix/Flo) in A.
;(Note: ATMTFX destroys previous values of NARG1 and NARG2. Call with NARG1 first,
; then save it, then call with NARG2, then restore NARG1.)
GTNUM1: LDX #NARG1
GETNUM: STX ANSN1 ;Address of argument
JSR GETTYP
LDX ANSN1
CMP #ATOM
BEQ ATMTXX
CMP #STRING
BEQ ATMTXX
CMP #FIX
BEQ GTNM2
CMP #FLO
BEQ GTNM2
GTNMNO: CLC ;Carry clear means argument not OK
RTS
GTNM2: PHA ;Save type
LDA $00,X
STA TEMPNH
LDA $01,X
STA TEMPNH+1
LDY #$03
GTNML: LDA (TEMPNH),Y
STA $03,X
DEX
DEY
BPL GTNML
PLA ;Retrieve type
SEC ;Carry set means argument OK
RTS
.PAGE
;Convert an atom to a Fixnum or Flonum if possible. Sets the carry
;if successful. Returns type of number (Fix/Flo) in A.
;(Note: Destroys previous values of NARG1 and NARG2.)
ATMTFX: STX ANSN1 ;ANSN1 points to argument
ATMTXX: LDY #TEMPN4 ;TEMPN4 becomes PNAME (Entry point for GETNUM)
JSR GETPNM
LDA TEMPN4+1
BEQ GTNMNO
JSR CLRNG1 ;Initialize number to 0
LDY #$01
LDA (TEMPN4),Y
STA TEMPN7+1
DEY
STY ANSN2 ;ANSN2 is SIGN
LDA (TEMPN4),Y
STA TEMPN7 ;(CAR) a pair of digits to TEMPN7
CMP #'-
BNE ATMT3
INC ANSN2 ;ANSN2 is SIGN
BNE ATMT4A ;(Always)
ATMT3: JSR GOBDIG
ATMT4: LDX TEMPN4+1
BEQ ATMT4E
ATMT4A: LDY #$02
LDA (TEMPN4),Y
TAX
INY
LDA (TEMPN4),Y
STA TEMPN4+1
STX TEMPN4 ;(CDR) PNAME to next two characters
LDA TEMPN7+1
BEQ ATMT4
JSR GOBDIG
LDX TEMPN4+1
BEQ ATMT4E
LDY #$01
LDA (TEMPN4),Y
STA TEMPN7+1
DEY
LDA (TEMPN4),Y ;(CAR) next two characters
JSR GOBDIG
JMP ATMT4
ATMT4E: JSR CNUML2
BCC NOTNM2
PHA ;Save type
LDX ANSN2
BEQ ATMT5
LDX #NARG1
TAY ;(Type of number is in A)
BNE ATMT41
JSR COMPL
JMP ATMT5
ATMT41: JSR FCOMPL
ATMT5: LDY ANSN1 ;ANSN1 is argument pointer
LDX #$FC
ATMT5L: LDA NARG1+4,X ;NARG1 is NUMBER
STA $00,Y
INY
INX
BMI ATMT5L
PLA ;Retrieve type
SEC ;Carry set means argument is a number
RTS
GOBDIG: JSR CNUML1
BCS GBDGR
NOTNM1: PLA ;Return back past ATMTFX
PLA
NOTNM2: CLC ;Carry clear means argument non-numeric
GBDGR: RTS
.PAGE
GTBOOL: STX ANSN1
JSR GETTYP
LDX ANSN1
CMP #STRING
BNE GTBOL1
LDY #TEMPX1
JSR INTERN ;Intern it if it's a String, in case it's a boolean word
LDX #TEMPX1
GTBOL1: LDA $00,X
LDY #$00
CMP LTRUE
BNE GTBL1
LDA $01,X
CMP LTRUE+1
BNE GTBL1
GTRTS: RTS
GTBL1: INY
LDA $00,X
CMP LFALSE
BNE GTBL2
LDA $01,X
CMP LFALSE+1
BEQ GTRTS
GTBL2: LDY ANSN
JSR PTRYOK
LDA #XNTF
JMP ERROR
.PAGE
MAKPNM: STY ANSN2 ;ANS
STX ANSN1 ;ARG
JSR GETTYP
LDX ANSN1
CMP #ATOM
BEQ MKPN1
CMP #SATOM
BEQ MKPN1
CMP #STRING
BEQ MKPN1
PHA ;Save type
LDA $00,X ;Assume it's a fixnum or flonum
STA TEMPN2
LDA $01,X
STA TEMPN2+1
LDX #$03
LDY #$00
MKP2L1: LDA (TEMPN2),Y
STA NARG1,Y
INY
DEX
BPL MKP2L1
PLA ;Retrieve type
TAX
LDA ANSN2
PHA ;Save ANS pointer
CPX #FIX
BEQ MKPN2
CPX #FLO
BEQ MKPN3
JMP STTLR4 ;(ERROR XWTA,CURTOK)
MKPN1: LDY ANSN2
JMP GETPNM
MKPN2: JSR CVBFIX ;Get string on PDL
JMP CNSPDL ;CONS string from PDL
MKPN3: JSR CVFLO ;Get the string on PDL
;falls through
;CONS a string from the characters on the PDL, ANSN1 holds counter, ANS on stack.
;falls in
CNSPDL: LDX #$00
STX MARK1
STX MARK1+1
LDA ANSN1
ROR A
BCC CSPD1
JSR PUSH ;If odd no. characters, push a 0 to make it even
INC ANSN1
CSPD1: JSR POPB ;Pop two characters
STA TEMPN+1
JSR POPB
STA TEMPN
LDX #MARK1
STX ANSN
LDY #TEMPN
LDA #STRING
JSR CONS ;Cons a node
DEC ANSN1
DEC ANSN1
BNE CSPD1 ;Continue if not done
PLA ;Retrieve ANS pointer
TAX
LDA MARK1
STA $00,X
LDA MARK1+1
STA $01,X
LDA #$00
STA MARK1
STA MARK1+1
RTS
.PAGE
GETPNM: STY TEMPN1+1 ;TEMPN1.H is returned PNAME pointer
STX TEMPN1 ;TEMPN1.L is ATOMM pointer
LDA $00,X
AND #$FC
STA $00,X
JSR GETTYP
LDY TEMPN1
CMP #STRING
BNE GTPNM1
STY TEMPN1+1
LDA $00,Y
TAX
AND #$FC
STA $00,Y
TXA
AND #$01
RTS
GTPNM1: LDX $00,Y
STX TEMPNH ;TEMPNH becomes ATOMM
LDX $01,Y
STX TEMPNH+1
LDY #$02
CMP #SATOM
BEQ GTPN2
GTPN1: LDA (TEMPNH),Y ;(Y is $02)
TAX
INY
LDA (TEMPNH),Y
STA TEMPNH+1
STX TEMPNH ;(CDR)
LDX TEMPN1+1 ;PNAME ptr.
DEY
LDA (TEMPNH),Y
PHA
INY
LDA (TEMPNH),Y
STA $01,X
PLA
GTPN1A: TAY ;(CDR)
AND #$FC
STA $00,X
TYA
AND #$01
RTS
GTPN2: LDA (TEMPNH),Y ;(Y is $02)
STA TEMPN ;TEMPN is INDEX
INY
LDA (TEMPNH),Y
STA TEMPN+1 ;(CDR)
LDA #$03
STA TEMPN1
LDA #$00
STA ANSN1 ;Character counter
GTPNW: LDY TEMPN1
LDA (TEMPN),Y ;Gets INDEX + 3 (SA_PNAME)
BEQ GTPNWE
TAX
JSR PUSH
INC ANSN1
INC TEMPN1
BNE GTPNW ;(Always)
GTPNWE: LDA TEMPN1+1 ;ANS pointer
PHA
JSR CNSPDL
LDA #$00 ;No Funny-pname SATOMs
RTS
;Converts a two-byte fixnum to a string on the PDL
CVFIX: LDA $00,X
STA NARG1
LDA $01,X
STA NARG1+1 ;NARG1 is the number to type
LDA #$00
STA ANSN1 ;Character counter
CVFIXX: STA NARG1+2 ;(Alternate entry point)
STA NARG1+3
BEQ CVFX2 ;(Always)
;Get 4-byte fixnum in NARG1 to string on PDL
CVBFIX: LDA #$00
STA ANSN1 ;Character counter
LDA NARG1+3
BPL CVFX1
LDX #NARG1
JSR COMPL
LDX #'-
JSR PUSH
INC ANSN1
CVFX1: LDA #$00
CVFX2: STA ANSN ;ANSN is digit counter
CVBNMR: JSR XDVD10 ;Divide NARG1 by ten and get remainder
PHA ;Push remainder digit
INC ANSN ;Increment digit counter
LDX #$03
CVBL1: LDA NARG1,X
BNE CVBNMR
DEX
BPL CVBL1
CVBNMF: PLA ;Pop a digit
TAX
JSR PUSH ;Push it
INC ANSN1
DEC ANSN
BNE CVBNMF
RTS
;Converts flonum NARG1 to characters on PDL
CVFLO: LDA ANSNX
PHA
LDA #$00
STA ANSN1 ;Counts number of characters pushed
STA ANSN2 ;ODE
LDX #$03
TPFLL1: LDA NARG1,X
BNE TPFL1
DEX
BPL TPFLL1
INC ANSN1
LDX #'0 ;If NARG1 = 0, push "0." and return
JSR PUSH
INC ANSN1
LDX #'.
JSR PUSH
PLA
STA ANSNX
RTS
TPFL1: LDA NARG1+1
BPL TPFL2 ;If NARG1 negative, invert and push "-"
JSR FCOMPL
INC ANSN1
LDX #'-
JSR PUSH
TPFL2: LDA NARG1 ;Now get 1 <= NARG1 < 10
BPL TPFLS1 ;Exponent too small, so multiply number
CMP #$84
BCS TPFLG1 ;Exponent greater than 3, so too big
CMP #$83
BNE GINTP1 ;Ok if 0,1, or 2
LDA NARG1+1 ;Else if 3,
CMP #$50 ;Make sure X < 10 (01.01 0000 Bin)
BCC GINTP1
TPFLG1: LDY #A1L
JSR XN1TOY ;Save NARG1, so it's now XNUM
TPFLL2: JSR FDVD10 ;So divide by 10
INC ANSN2 ;Increment ODE
LDA NARG1
CMP #$84
BCS TPFLL2
CMP #$83
BNE GINTP2
LDA NARG1+1
CMP #$50
BCS TPFLL2
BCC GINTP2
TPFLS1: JSR MULN10 ;NARG1 too small, so multiply by 10
DEC ANSN2 ;Decrement ODE
LDA NARG1
BPL TPFLS1
GINTP1: LDY #A1L
JSR XN1TOY
GINTP2: JSR GETINT
LDY #A1L
JSR XYTON1
LDA ANSN2
STA ANSNX ;NDE
BPL TPFLG2
CMP #$FF
BCC TPFLF1 ;NARG1 < 0.1, use floating pt. format (N)
;falls through
;falls in
TPFLR: STA ANSN3 ;Counter for Exp+1 iterations
INC ANSN3
BEQ TPFLR1
TPFLL5: JSR GTDECH
DEC ANSN3
BNE TPFLL5
TPFLR1: LDX #'.
JSR PUSH ;Push decimal pt.
INC ANSN1
SEC
LDA #$06
SBC ANSN2
STA ANSN3 ;Counter for 6-Exp iterations
BEQ POPTZS
TPFLL6: JSR GTDECH
DEC ANSN3
BNE TPFLL6
POPTZS: JSR POPB ;Pop all trailing zeroes
DEC ANSN1
CMP #'0
BEQ POPTZS
TAX
INC ANSN1
JSR PUSH ;Done
PLA
STA ANSNX
RTS
TPFLG2: CMP #$07
BCC TPFLR ;NARG1 < 10000000, use regular format
TPFLF1: JSR GTDECH ;Floating pt. format, call Get-Decimal-Char for digit
LDX #'.
JSR PUSH ;Push a "."
INC ANSN1
LDA #$06 ;Counter for six iterations
STA ANSN3
TPFLL3: JSR GTDECH ;Get another decimal digit
DEC ANSN3
BNE TPFLL3
JSR POPTZS ;Pop all trailing zeros
LDA ANSN2
BPL TPFLEP
EOR #$FF ;If Exp negative, invert
STA ANSN2
INC ANSN2 ;(Complement and increment)
LDX #'N ;and push "N"
BNE TPFLEX ;(Always)
TPFLEP: LDX #'E ;Exp positive, push "E"
TPFLEX: JSR PUSH
INC ANSN1
LDA ANSN2
STA NARG1
LDA #$00
STA NARG1+1
JSR CVFIXX ;Routine converts (2-byte) ARG1 into string on PDL
PLA
STA ANSNX
RTS
GETINT: LDA #$00 ;Gets the integer part of NARG1
STA TEMPN1 ;INTP
GETL1: LDA NARG1
BEQ GTDR
CMP #$80 ;Done if Binary-exp is 0
BEQ GTD1
ASL NARG1+1 ;Rotate NARG1 mantissa into TEMPN1
ROL TEMPN1
DEC NARG1 ;Decrement Binary-exp
BNE GETL1 ;(Always)
GTD1: ASL NARG1+1
ROL TEMPN1 ;Shift two more bits into TEMPN1
ASL NARG1+1
ROL TEMPN1
GTDR: RTS
;Gets the most significant decimal digit of NARG1, then positions it for next one.
GTDECH: CLC
LDA TEMPN1
ADC #'0
TAX
JSR PUSH
INC ANSN1
LDA ANSNX
BMI GTDC1
BEQ GTDC1
STA TEMPN1+1
LDY #A1L
JSR XN1TOY
LDA TEMPN1
STA NARG1
LDA #$00
STA NARG1+1
STA NARG1+2
STA NARG1+3
JSR FLOTN1
GTDL1: JSR MULN10
DEC TEMPN1+1
BNE GTDL1
LDY #A1L
JSR XYTON2
JSR FSUBX
LDY #A1L
JSR XN1TOY
DEC ANSNX
BEQ GTDL3E
LDA ANSNX
STA TEMPN1+1
GTDL3: JSR FDVD10
DEC TEMPN1+1
BNE GTDL3
GTDL3E: JSR GETINT
LDY #A1L
JMP XYTON1
GTDC1: LDA TEMPN1
STA NARG2
LDA #$00
STA NARG2+1
STA NARG2+2
STA NARG2+3
JSR FLOTN2
JSR FSUB
JSR MULN10
LDY #A1L
JSR XN1TOY
JSR GETINT
LDY #A1L
JMP XYTON1
;Execution diagram, flonum-to-string conversion:
;ODE := 0
;IF NUM <= 1 THEN DO NUM := NUM * 10, ODE := ODE - 1, UNTIL NUM >= 1, INTP = INT(NUM)
; ELSE IF NUM >= 10 THEN XNUM := NUM, DO XNUM := XNUM / 10, ODE := ODE + 1, UNTIL XNUM < 10,
; INTP := INT(XNUM)
;NDE := ODE
;IF ODE > 6 OR ODE < -1 THEN GET-DIG, PUSH("."), REPEAT 6 GET-DIG, POP-TZS, PR-EXP
; ELSE REPEAT ODE+1 GET-DIG, PUSH("."), REPEAT 6-ODE GET-DIG, POP-TZS
;
;GET-DIG:
; PUSH(INTP)
; IF NDE > 0 THEN REPEAT NDE INTP := INTP * 10, NDE := NDE - 1,
; NUM := NUM - INTP, XNUM := NUM, REPEAT NDE XNUM := XNUM / 10,
; INTP := INT(XNUM)
; ELSE NUM := NUM - INTP, NUM := NUM * 10, INTP := INT(NUM)
.PAGE
OTPFX1: LDA #TEMPN ;Output a two-byte fixnum value (Y is ptr.)
STA ANSN
LDX #$00
LDA #FIX
JSR CONS
LDX #TEMPN
JSR VPUSHP
INC OTPUTN
JMP POPJ
OTPFL1: LDY #NARG1
OTPFLO: LDA #FLO
BNE OTPNUM ;(Always)
OTPFIX: LDA $03,X
CMP #$80
BNE OTPFXA
LDA $02,X
BNE OTPFXA
LDA $01,X
BNE OTPFXA
LDA $00,X
BNE OTPFXA
JMP ROFLOW ;Attempted to output -2^15, so Overflow Error
OTPFXA: LDA #FIX
OTPNUM: PHA ;Save type
LDA #TEMPN ;Entered with type (Fix/Flo) in A
STA ANSN
TYA
TAX
INX
INX
PLA ;Retrieve type
JSR CONS
LDX #TEMPN
JSR VPUSHP
INC OTPUTN
JMP POPJ
.PAGE
.SBTTL System Functions
; Arithmetic Functions:
SUNDIF: LDA INFDIF
STA CURTOK ;(For possible error message in GT1NUM)
LDA INFDIF+1
STA CURTOK+1
JSR GT1NUM
BCS SNDIF2
LDX #NARG1
JSR COMPL
LDY #NARG1
JMP OTPFIX
SNDIF2: JSR FCOMPL ;Complements flonum in NARG1.
JMP OTPFL1
SSUM: JSR GT2NUM
BCS SSUMF
LDA NARG1+3
STA TEMPN1
CLC
LDX #$FC
SSMLP1: LDA NARG1+4,X
ADC NARG2+4,X
STA NARG1+4,X
INX
BMI SSMLP1
LDA NARG2+3
EOR TEMPN1
BMI SSUMOK ;Different signs, never an overflow
LDA NARG1+3
EOR NARG2+3
BPL SSUMOK ;Overflow if result not same sign as one argument
ROFLOW: LDA #XOFLOW
JMP ERROR
SSUMF: JSR FADD ;Floating pt. addition
BCS ROFLOW
JMP OTPFL1
SSUMOK: LDY #NARG1
JMP OTPFIX
SDIF: JSR GT2NUM
BCS SDIFF
LDA NARG1+3
STA TEMPN1
SEC
LDX #$FC
SDIFL1: LDA NARG1+4,X
SBC NARG2+4,X
STA NARG1+4,X
INX
BMI SDIFL1
LDA TEMPN1
EOR NARG2+3
BPL SSUMOK ;Same signs, never an overflow
LDA NARG1+3
EOR TEMPN1
BMI ROFLOW ;Different signs, overflow
BPL SSUMOK ;(Always)
SDIFF: JSR FSUB ;Floating pt. subtraction
BCS ROFLOW
JMP OTPFL1
.PAGE
SPROD: JSR GT2NUM
BCS SPRODF
LDA NARG1+3
EOR NARG2+3
STA ANSN
LDA NARG1+3
BPL SPRD1
LDX #NARG1
JSR COMPL
SPRD1: LDA NARG2+3
BPL SPRD2
LDX #NARG2
JSR COMPL
SPRD2: LDA #$00
LDX #$03
SPRDL1: STA TEMPN,X
DEX
BPL SPRDL1
LDY #$20 ;Bit counter
MUL2: LSR NARG2+3
ROR NARG2+2
ROR NARG2+1
ROR NARG2
BCC MUL4
CLC
LDX #$FC
SPRDL2: LDA TEMPN+4,X ;Add multiplicand (NARG1) to partial product (TEMPN, TEMPN1)
ADC NARG1+4,X
STA TEMPN+4,X
INX
BMI SPRDL2
TAX
BMI SPRODR
MUL4: ASL NARG1
ROL NARG1+1
ROL NARG1+2
ROL NARG1+3
BPL MUL4A
LDX #$03 ;Sig. bit dropped from NARG1, so bit counter better be 0
MUL4B: LDA NARG2,X
BNE SPRODR ;It isn't, error
DEX
BPL MUL4B
BMI MUL4C ;(Always) It is, so we're done
MUL4A: DEY
BNE MUL2 ;Next bit
MUL4C: LDA ANSN
BPL MULEND
LDX #TEMPN
JSR COMPL
MULEND: LDY #TEMPN
JMP OTPFIX
SPRODF: JSR FMUL ;Floating pt. multiply
BCS SPRODR
JMP OTPFL1
SPRODR: JMP ROFLOW
.PAGE
SDIVID: JSR GT2NUM
BCS SDIVF
LDX #$03
SDVLP1: LDA NARG2,X
BNE SDVD1
DEX
BPL SDVLP1
LDA #XDBZ
JMP ERROR
SDIVF: JSR FDIV ;Floating pt. divide
BCS SPRODR
JMP OTPFL1
SDVD1: LDX #$03
SDVLP2: LDA NARG1,X
BNE SDVD1A
DEX
BPL SDVLP2
LDY #NARG1
JMP OTPFIX ;Answer is zero if numerator is zero
SDVD1A: LDA #$00
STA ANSN ;SIGN
LDA NARG1+3
BPL SDVD2
LDX #NARG1
JSR COMPL
INC ANSN
SDVD2: LDA NARG2+3
BPL SDVD3
LDX #NARG2
JSR COMPL
LDA ANSN
EOR #$01
STA ANSN
SDVD3: JSR XDIVID ;NARG2 is divisor, NARG1 is dividend, then quotient
LDA ANSN
BEQ SDVD4
LDX #NARG1
JSR COMPL
SDVD4: LDY #NARG1
JMP OTPFIX
SUNSUM: LDA INFSUM
STA CURTOK ;(For possible error message in GT1NUM)
LDA INFSUM+1
STA CURTOK+1
JSR GT1NUM
BCS SNSM1
LDY #NARG1
JMP OTPFIX
SNSM1: JMP OTPFL1
SINT: JSR GT1NUM
BCC SINT1
JSR XINT1
SINT1: LDY #NARG1
JMP OTPFIX
.PAGE
; Boolean Functions:
SGRTR: JSR GT2NUM
SGRTRX: BCS SGRTRF
SGRTR1: LDA NARG1+3
BMI SGRTRM
LDA NARG2+3
BMI JTRU ;POS > NEG
SGRTRP: LDX #$03
SGRLP1: LDA NARG2,X
CMP NARG1,X
BCC JTRU
BNE JFLS
DEX
BPL SGRLP1
JFLS: JMP VPLFLS
SGRTRM: LDA NARG2+3
BPL JFLS ;NEG not > POS
AND #$7F ;Both negative, strip sign bit and compare
STA NARG2+3
LDA NARG1+3
AND #$7F
STA NARG1+3
JMP SGRTRP
JTRU: JMP VPLTRU
SGRTRF: LDA NARG1+1
BMI SGRTFM
LDA NARG2+1
BMI JTRU ;POS > NEG
BPL SGRTF1
SGRTFM: LDA NARG2+1
BPL JFLS ;NEG not > POS
SGRTF1: JSR FSUBX ;Both same sign - subtract NARG1 from NARG2
LDA NARG1+1 ;If NARG1 negative, then it was larger
BMI JTRU
BPL JFLS
SLESS: JSR GT2NUM
JSR SWAP ;Switch the args and call S_GREATER
JMP SGRTRX
SNOT: LDX #ARG1
JSR VPOP
JSR GTBOOL
TYA
BNE VPLTRU
JMP VPLFLS
.PAGE
SBOTH: LDX #ARG2
JSR VPOP
LDX #ARG1
JSR VPOP
JSR GTBOOL
STY ANSNX
LDX #ARG2
JSR GTBOOL
TYA
BNE VPLFLS
LDA ANSNX
BNE VPLFLS
JMP VPLTRU
SEITHR: LDX #ARG2
JSR VPOP
LDX #ARG1
JSR VPOP
JSR GTBOOL
STY ANSNX
LDX #ARG2
JSR GTBOOL
TYA
BEQ VPLTRU
LDA ANSNX
BNE VPLFLS
;falls through
;falls in
VPLTRU: LDX #LTRUE
JSR VPUSHP
INC OTPUTN
JMP POPJ
VPLFLS: LDX #LFALSE
JSR VPUSHP
INC OTPUTN
JMP POPJ
.PAGE
SFPUT: LDX #ARG2
JSR VPOP
LDX #ARG1
JSR VPOP
LDX #ARG2
JSR GETTYP
CMP #LIST
BNE SFPT1
LDX #ARG1
JSR GETTYP
LDY #ARG1
CMP #STRING
BNE SFPT2
LDX #ARG1
LDY #TEMPX1
JSR INTERN ;If String, intern before FPUTting
LDY #TEMPX1
SFPT2: LDX #ARG2
STY ANSN
JSR CONS
JMP OTPRG1
SFPT1: LDX #ARG2
LDY #CURTOK
LDA #XWTA
JMP ERROR
.PAGE
SLPUT: LDX #ARG2
JSR VPOP
LDX #ARG1
JSR VPOP
LDX #ARG2
JSR GETTYP
CMP #LIST
BNE SFPT1
SLPUT1: LDA ARG2+1
BNE SLPUT2
LDX #ARG1
JSR GETTYP
LDY #ARG1
CMP #STRING
BNE SLPT1A
LDX #ARG1
LDY #TEMPX1
JSR INTERN ;Intern it if it's a String
LDY #TEMPX1
SLPT1A: STY ANSN
TYA
LDX #$00
TXA ;(Type LIST)
JSR CONS
JMP OTPRG1
SLPUT2: LDA ARG1
STA MARK2 ;Protect the last element
LDA ARG1+1
STA MARK2+1
LDA ARG2
STA MARK3 ;Protect the original list (or what's left of it)
LDA ARG2+1
STA MARK3+1
LDY #$00
LDA (MARK3),Y
STA TEMPN1
INY
LDA (MARK3),Y
STA TEMPN1+1 ;(CAR) First element
INY
LDA (MARK3),Y
TAX
INY
LDA (MARK3),Y
STA MARK3+1
STX MARK3 ;(CDR)
LDA #MARK1 ;Pointer to start of new list
STA ANSN
LDX #$00
TXA
LDY #TEMPN1
JSR CONS
LDA MARK1
STA TEMPN2 ;Pointer to newest node
LDA MARK1+1
STA TEMPN2+1
SLPTW: LDA MARK3+1 ;Make a new list, element by element
BEQ SLPT2
LDY #$00
LDA (MARK3),Y
STA TEMPN1 ;Get an element
INY
LDA (MARK3),Y
STA TEMPN1+1 ;(CAR)
INY
LDA (MARK3),Y
TAX
INY
LDA (MARK3),Y
STA MARK3+1
STX MARK3 ;(CDR) Advance element pointer
LDA #TEMPN ;New pointer to newest node
STA ANSN
LDX #$00
TXA ;(Type LIST)
LDY #TEMPN1
JSR CONS
LDY #$02
LDA TEMPN
STA (TEMPN2),Y ;Pointer to last node
TAX
INY
LDA TEMPN+1
STA (TEMPN2),Y ;(CDR) Link new node onto list
STA TEMPN2+1
STX TEMPN2
JMP SLPTW
SLPT2: LDX #ARG1
JSR GETTYP
LDY #ARG1
CMP #STRING
BNE SLPT2A
LDX #ARG1
LDY #TEMPX1
JSR INTERN ;Intern it if it's a string
LDY #TEMPX1
SLPT2A: LDA #TEMPN
STA ANSN
LDX #$00
TXA ;(Type LIST)
JSR CONS ;Get a pointer to first argument
LDY #$02
LDA TEMPN
STA (TEMPN2),Y
INY
LDA TEMPN+1
STA (TEMPN2),Y ;(RPLACD) Link final node on
JMP SSN2 ;MARK1 points to our new list
.PAGE
SSNTNC: LDA #$00
STA MARK1
STA MARK1+1
LDA NARGS
BPL SSN1
EOR #$FF ;NARGS := - NARGS - 1
STA NARGS
SSNW: LDA NARGS
SSN1: BNE SSNWA
SSN2: LDA MARK1
STA ARG1
LDA MARK1+1
STA ARG1+1
LDA #$00
JSR CLMK3
JMP OTPRG1
SSNWA: LDX #MARK2
JSR VPOP
JSR GETTYP
CMP #LIST
BEQ SSNW1
LDY #MARK2
CMP #STRING
BNE SSNWA1
LDX #MARK2
LDY #TEMPX1
JSR INTERN ;Intern it if it's a String
LDY #TEMPX1
SSNWA1: LDX #MARK1
STX ANSN
LDA #LIST
JSR CONS
JMP SSNW2
SSNW1: LDA VSP
STA TEMPN1
LDA VSP+1
STA TEMPN1+1
LDA #SSNERR&$FF
STA ERRRET
LDA #SSNERR^
STA ERRRET+1
TSX
STX RETADR ;Save all necessary return addresses
SSNX: LDA MARK2+1
BEQ SSNY
LDY #$00
LDA (MARK2),Y
STA MARK3
INY
LDA (MARK2),Y
STA MARK3+1 ;(CAR)
INY
LDA (MARK2),Y
TAX
INY
LDA (MARK2),Y
STA MARK2+1
STX MARK2 ;(CDR)
LDX #MARK3
JSR VPUSHP
JMP SSNX
SSNY: LDA TEMPN1
CMP VSP
BNE SSNY1
LDA TEMPN1+1
CMP VSP+1
BEQ SSNW2
SSNY1: LDX #MARK3
JSR VPOP
LDX #MARK1
STX ANSN
LDY #MARK3
LDA #LIST
JSR CONS
JMP SSNY
SSNERR: LDA TEMPN1
STA VSP
LDA TEMPN1+1
STA VSP+1
JMP ERROR1
SSNW2: DEC NARGS
JMP SSNW
.PAGE
; Miscellaneous Functions:
SMAKE: LDX #ARG2
JSR VPOP
LDX #ARG1
JSR VPOP
JSR GETTYP
LDY #ARG1
CMP #ATOM
BEQ SMAKE1
CMP #SATOM
BEQ SMAKE2
CMP #STRING
BNE SMAKE2
LDX #ARG1
LDY #TEMPX1
JSR INTERN ;Intern the Name if it's a string
LDY #TEMPX1
SMAKE1: LDX #ARG2
JSR PUTVAL
JMP POPJ
SMAKE2: LDX #ARG1
LDY #CURTOK
LDA #XWTA
JMP ERROR
SOUTPT: LDA LEVNUM
BNE SOTPT2
LDA LEVNUM+1
BEQ SOTPT1
SOTPT2: LDA #$01
STA STPFLG
STA OTPUTN
JMP POPJ
SOTPT1: LDY #CURTOK
LDA #XNTL
JMP ERROR
.PAGE
SSTOP: LDA LEVNUM
BNE SSTOP1
LDA LEVNUM+1
BEQ SOTPT1
SSTOP1: LDA #$01
STA STPFLG
JMP POPJ
SCOMMT: LDA #$00
STA TOKPTR
STA TOKPTR+1
LDA EXPOUT
BNE SCMMT1
JMP POPJ
SCMMT1: LDA #XEOL
JMP ERROR
SCNTIN: LDA #$01
STA STPFLG
STA DCOFLG
JMP POPJ
.PAGE
SIF: INC IFLEVL
BNE SIFA
INC IFLEVL+1
BNE SIFA
JMP EXCED
SIFA: JSR GTNXTK
LDA NEXTOK
CMP LTHEN
BNE SIF1
LDA NEXTOK+1
CMP LTHEN+1
BNE SIF1
LDX #TOKPTR
JSR TTKADV
SIF1: LDX #ARG1
JSR VPOP
JSR GTBOOL
CPY #$00
BNE SIF2
SIF3A: JMP POPJ
SIF2: LDX #NEXTOK
JSR EXIFSC
LDA TOKPTR
BNE SIF3
LDA TOKPTR+1
BEQ SIF3A
SIF3: LDA NEXTOK
CMP LELSE
BNE SIF3A
LDA NEXTOK+1
CMP LELSE+1
BNE SIF3A
LDX #TOKPTR
JSR TTKADV
JMP POPJ
.PAGE
SELSE: SEC
LDA IFLEVL
SBC #$01
STA IFLEVL
LDA IFLEVL+1
SBC #$00
STA IFLEVL+1
BCC SELSE1
LDA IFLEVL
BNE SELSE2
LDA IFLEVL+1
BNE SELSE2
STA TOKPTR
STA TOKPTR+1
JMP POPJ
SELSE2: LDX #TEMPN2
JSR EXIFSC
JMP POPJ
SELSE1: LDA #XELS
JMP ERROR
.PAGE
SGO: JSR STPPEK
LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #ATOM
BEQ SGO1
CMP #SATOM
BEQ SGO1
JMP SRUN1
SGO1: LDA #LATOM
LDX #ARG1
JSR PUTTYP
LDA FBODY
STA GOPTR
LDA FBODY+1
STA GOPTR+1
LDX #GOPTR
JSR ULNADV
SGOW: LDA GOPTR
BNE SGOW1
LDA GOPTR+1
BEQ SGOR
SGOW1: LDX #TEMPN1
LDY #GOPTR
JSR GTTULN
LDY #$00
LDA (TEMPN1),Y
STA TEMPN
INY
LDA (TEMPN1),Y
STA TEMPN+1 ;(GETTOK)
LDX #TEMPN1
JSR TTKADV
LDY #$00
LDA (TEMPN1),Y
TAX
INY
LDA (TEMPN1),Y
STA TEMPN1+1
STX TEMPN1 ;(GETTOK)
LDA ARG1
CMP TEMPN1
BNE SGOW2
LDA ARG1+1
CMP TEMPN1+1
BEQ SGOE1
SGOW2: LDX #GOPTR
JSR ULNADV
JMP SGOW
SGOE1: LDA TEMPN
STA LINNUM
LDA TEMPN+1
STA LINNUM+1
JMP POPJ
SGOR: LDY #ARG1
LDA #XLNF
JMP ERROR
.PAGE
SRPEAT: LDX #ARG2
JSR VPOP
JSR GT1FIX
LDA ARG1+1
BMI SRUN1
JSR SWAP ;Swap ARG1 and ARG2
LDX #ARG1
JSR GETTYP
CMP #LIST
BNE SRUN1
SRPLOP: LDA ARG2
BNE SRPLP1
LDA ARG2+1
BNE SRPLP1
JMP POPJ
SRPLP1: SEC
LDA ARG2
SBC #$01
STA ARG2
BCS SRPLP2
DEC ARG2+1
SRPLP2: JSR STPPEK
LDX #ARG2
JSR PUSHP
LDX #ARG1
JSR PUSHP
LDX #SREPT1&$FF
LDY #SREPT1^
JSR PUSH
JMP RUNHAN
SREPT1: LDX #ARG1
JSR POP
LDX #ARG2
JSR POP
JMP SRPLOP
.PAGE
SRUN: JSR STPPEK
LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #LIST
BNE SRUN1
JMP RUNHAN
SRUN1: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
STHING: LDX #ARG2
JSR VPOP
JSR GETTYP
LDY #ARG2
CMP #ATOM
BEQ STH1
CMP #SATOM
BEQ STH1
CMP #STRING
BNE STH2
LDX #ARG2
LDY #TEMPX1
JSR INTERN ;Intern the Name if it's a string
LDY #TEMPX1
STH1: LDX #ARG1
JSR GETVAL
LDA ARG1+1
BNE OTPRG1
LDA ARG1
BEQ OTPRG1
LDY #ARG2
LDA #XHNV
JMP ERROR
STH2: LDX #ARG2
JMP STLR4A
OTPRG1: INC OTPUTN
LDX #ARG1
JSR VPUSHP
JMP POPJ
SPTHNG: LDX #ARG2
JSR VPOP
JSR GETTYP
CMP #ATOM
BEQ SPTH1
CMP #SATOM
BEQ SPTH1
SPTH2: JMP VPLFLS
SPTH1: LDX #ARG1
LDY #ARG2
JSR GETVAL
LDA ARG1+1
BNE SPTH3
LDA ARG1
BNE SPTH2
SPTH3: JMP VPLTRU
.PAGE
SPWRDP: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #ATOM
BEQ SPTH3
CMP #SATOM
BEQ SPTH3
CMP #FIX
BEQ SPTH3
CMP #FLO
BEQ SPTH3
JMP VPLFLS
SNODES: SEC
LDA #TYPLEN&$FF
SBC NNODES
STA TEMPN1
LDA #TYPLEN^
SBC NNODES+1
STA TEMPN1+1
LDY #TEMPN1
JMP OTPFX1
SREQU: LDA #RPRMPT
JSR TPCHR
LDX #ILINE
JSR VPUSHP ;Save ILINE
LDX #ILINE
JSR READLN
TYA
BEQ SREQU1 ;Y zero means OK
JMP ERROR1
SREQU1: LDA ILINE ;Restore ILINE
STA ARG1
LDA ILINE+1
STA ARG1+1
LDX #ILINE
JSR VPOP
JMP OTPRG1
SGCOLL: JSR GARCOL
SGCE: JMP POPJ
.PAGE
SRETRV: LDA INDEV
BNE SRTRE
LDA ENDBUF
CMP #EDBUF&$FF
BNE SCHG1
LDA ENDBUF+1
CMP #EDBUF^
BEQ SGCE ;Buffer never used, so ignore
SCHG1: LDA #BUFFER
STA INDEV
JSR CHGX1
JMP CHGIN3
SRTRE: LDA #XEDT
JMP ERROR
SCHNGE: LDA GRPHCS
BEQ SCHNG2
JSR RESETT ;Nodisplay, get the text page back
LDX #SCS&$FF
LDY #SCS^
JSR PUSH ;So we return to graphics mode when done
SCHNG2: JMP CHGSTP ;get arg to CHG
.PAGE
STITLE: LDA EDSW
BEQ STTLR1
LDA LEVNUM
BNE STTLR2
LDA LEVNUM+1
BNE STTLR2
LDA TOKPTR+1
BNE STTL1
JMP POPJ
STTLR1: LDA #XNED
JMP ERROR
STTLR2: LDA #XETL
JMP ERROR
STTLR3: LDY #TEMPN3
JSR PTRYOK
LDA #XUBL
JMP ERROR
STTLR4: JSR PTRXOK
STLR4A: LDY #CURTOK
LDA #XWTA
JMP ERROR
STTL1: LDY #$00
LDA (TOKPTR),Y
STA TEMPN3 ;(ATOMM)
INY
LDA (TOKPTR),Y
STA TEMPN3+1 ;(CAR)
INY
LDA (TOKPTR),Y
TAX
INY
LDA (TOKPTR),Y
STA TOKPTR+1
STA TEMPN1+1 ;(ARGLIST)
STX TOKPTR ;(CDR)
STX TEMPN1
LDX #TEMPN3
JSR GETTYP
CMP #SATOM
BEQ STTLR3
CMP #ATOM
BNE STTLR4
LDA TEMPN3
CMP EDTATM
BNE STTL2
LDA TEMPN3+1
CMP EDTATM+1
BEQ STTL3
STTL2: LDX #EDTATM
LDA #TEMPN2 ;(FUN)
JSR GETFUN
LDX #EDTATM
JSR UNFUNC
LDA TEMPN3
STA EDTATM
STA PODEFL
LDA TEMPN3+1
STA EDTATM+1
STA PODEFL+1
LDY #TEMPN2
LDX #EDTATM
JSR PUTFUN
STTL3: LDA #$00
STA ANSN1
STTLW: LDA TOKPTR+1
BEQ STTLWE
LDY #$00
LDA (TOKPTR),Y
STA TEMPN
INY
LDA (TOKPTR),Y
STA TEMPN+1 ;(CAR)
INY
LDA (TOKPTR),Y
TAX
INY
LDA (TOKPTR),Y
STA TOKPTR+1
STX TOKPTR ;(CDR)
LDA TEMPN
CMP COMMNT
BNE STTLW2
LDA TEMPN+1
CMP COMMNT+1
BEQ STTLW
STTLW2: LDX #TEMPN
JSR GETTYP
CMP #ATOM
BEQ STTLW3
CMP #SATOM
BEQ STTLW3
LDX #TEMPN
JMP STTLR4
STTLW3: INC ANSN1
JMP STTLW
STTLWE: LDY #$00
STY TOKPTR
STY TOKPTR+1
LDA TEMPN1
STA (EDBOD),Y
INY
LDA TEMPN1+1
STA (EDBOD),Y ;(RPLACA)
LDX #EDTATM
LDA #TEMPN1
JSR GETFUN
LDY #$04
LDA ANSN1
STA (TEMPN1),Y ;(PUTNGS)
SERR4: JMP POPJ
.PAGE
SPRINT: JSR SPRNT
JSR BREAK1
JMP POPJ
STYPE: JSR SPRNT
JMP POPJ
.PAGE
SDEFIN: LDX #ARG2
JSR VPOP
LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #ATOM
BNE SDFNR1
LDX #ARG2
JSR GETTYP
CMP #LIST
BNE SDFNR2
LDY #$00
LDA (ARG2),Y
STA TEMPN
INY
LDA (ARG2),Y
STA TEMPN+1 ;(CAR)
LDX #TEMPN
JSR GETTYP
CMP #LIST
BNE SDFNR2
LDY #ARG1
LDA ARG2+1
BNE DEFUN1
LDX ARG2
JSR UNFUNC
JMP POPJ
SDFNR1: JMP SMAKE2
SDFNR2: JMP SFPT1
DEFUN1: JSR VPUSHP
LDA #LININC
STA TEMPN4 ;TEMPN4 is NUMBER
LDA #$00
STA TEMPN4+1
LDA VSP
STA TEMPN1 ;TEMPN1 is PTR
LDA VSP+1
STA TEMPN1+1
LDA ARG2
STA TEMPN
LDA ARG2+1
STA TEMPN+1
LDY #$00
LDA (TEMPN),Y
STA TEMPN2
INY
LDA (TEMPN),Y
STA TEMPN2+1 ;(CAR)
LDX #TEMPN2
JSR VPUSHP
LDY #$02
LDA (TEMPN),Y
STA TEMPN2 ;TEMPN2 is TLIST
INY
LDA (TEMPN),Y
STA TEMPN2+1 ;(CDR)
DEFUNW: LDA TEMPN2+1
BEQ DEFNWE
LDY #$00
LDA (TEMPN2),Y
STA TEMPN3 ;TEMPN3 is T1
INY
LDA (TEMPN2),Y
STA TEMPN3+1 ;(CAR)
LDX #TEMPN3
JSR GETTYP
CMP #LIST
BNE DEFNER
LDX #TEMPN3
STX ANSN
LDY #TEMPN4
LDA #FLIST
JSR CONS
LDX #TEMPN3
JSR VPUSHP
LDY #$02
LDA (TEMPN2),Y
TAX
INY
LDA (TEMPN2),Y
STA TEMPN2+1
STX TEMPN2 ;(CDR)
CLC
LDA TEMPN4
ADC #LININC
STA TEMPN4
BCC DEFUNW
INC TEMPN4+1
BPL DEFUNW
JMP EDLERR
DEFNWE: LDA #$00
STA ARG2
STA ARG2+1
DEFUNX: LDA TEMPN1
CMP VSP
BNE DEFNX1
LDA TEMPN1+1
CMP VSP+1
BEQ DEFNXE
DEFNX1: LDX #TEMPN3
JSR VPOP
LDX #ARG2
STX ANSN
LDY #TEMPN3
LDA #LIST
JSR CONS
JMP DEFUNX
DEFNXE: LDX #ARG2
LDA #ARG1
JSR STUFF
JMP POPJ
DEFNER: LDX #ARG2
JMP STTLR4 ;(ERROR XWTA,CURTOK)
.PAGE
STEXT: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #ATOM
BNE STEXTR
LDX #ARG1
LDA #TEMPN5 ;FUN is TEMPN5
JSR GETFUN
LDA TEMPN5+1
BNE STEXT1
STA TEMPN6 ;BODY is TEMPN6
STA TEMPN6+1
JMP STEXT3
STEXTR: JMP SMAKE2
STEXT1: LDY #$02
LDA (TEMPN5),Y
STA TEMPN6
INY
LDA (TEMPN5),Y
STA TEMPN6+1 ;(CDR)
LDX #TEMPN6
JSR GETTYP
CMP #LIST
BEQ STXT1A
STXT1B: LDY #TEMPN6
LDX #TEMPN5
LDA #$01
JSR UNSTUF
JMP STEXT3
STXT1A: LDA TEMPN6
STA TEMPN5
LDA TEMPN6+1
STA TEMPN5+1
LDA VSP
STA TEMPN1 ;TEMPN1 is STACK
LDA VSP+1
STA TEMPN1+1
LDY #$00
LDA (TEMPN5),Y
STA TEMPN2 ;TEMPN2 is LINE
INY
LDA (TEMPN5),Y
STA TEMPN2+1 ;(CAR)
INY
LDA (TEMPN5),Y
TAX
INY
LDA (TEMPN5),Y
STA TEMPN5+1
STX TEMPN5 ;(CDR)
LDX #TEMPN2
JSR VPUSHP
STXTW: LDA TEMPN5+1
BEQ STXTWE
LDY #$00
LDA (TEMPN5),Y
STA TEMPN2
INY
LDA (TEMPN5),Y
STA TEMPN2+1 ;(CAR)
INY
LDA (TEMPN5),Y
TAX
INY
LDA (TEMPN5),Y
STA TEMPN5+1
STX TEMPN5 ;(CDR)
DEY
LDA (TEMPN2),Y
TAX
INY
LDA (TEMPN2),Y
STA TEMPN2+1
STX TEMPN2 ;(CDR)
LDX #TEMPN2
JSR VPUSHP
JMP STXTW
STXTWE: LDA #$00
STA MARK1
STA MARK1+1
STXTX: LDA TEMPN1
CMP VSP
BNE STXTX1
LDA TEMPN1+1
CMP VSP+1
BEQ STXTXE
STXTX1: LDX #TEMPN2
JSR VPOP
LDX #MARK1
STX ANSN
LDY #TEMPN2
LDA #LIST
JSR CONS
JMP STXTX
STXTXE: LDA MARK1
STA TEMPN6
LDA MARK1+1
STA TEMPN6+1
LDA #$00
STA MARK1
STA MARK1+1
STEXT3: LDX #TEMPN6
JSR VPUSHP
INC OTPUTN
JMP POPJ
.PAGE
SFIRST: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #LIST
BEQ SFRST1
CMP #ATOM
BEQ SFRST2
CMP #SATOM
BEQ SFRST2
CMP #FIX
BEQ SFRST2
CMP #FLO
BEQ SFRST2
CMP #STRING
BEQ SFRST2
SDFNRR: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
SFRST1: LDY #$00
LDA (ARG1),Y
TAX
INY
LDA (ARG1),Y
STA ARG1+1
STX ARG1 ;(CAR)
JMP OTPRG1
SFRST2: LDA ARG1+1
BEQ SDFNRR
SFRST3: LDY #TEMPN6 ;TEMPN6 is TEMP
LDX #ARG1
JSR MAKPNM
LDY #$00
LDA (TEMPN6),Y
STA TEMPN5
LDX #$00
STX TEMPN5+1
LDA #ARG1
STA ANSN
LDY #TEMPN5
LDA #STRING
JSR CONS
JMP OTPRG1
.PAGE
SLAST: LDX #ARG2
JSR VPOP
JSR GETTYP
CMP #LIST
BEQ SLST1
CMP #ATOM
BEQ SLST2
CMP #SATOM
BEQ SLST2
CMP #FIX
BEQ SLST2
CMP #FLO
BEQ SLST2
CMP #STRING
BEQ SLST2
JMP SDFNR1
SLST1: LDX #ARG2
JSR GTLSTC
LDY #$00
LDA (ARG2),Y
STA ARG1
INY
LDA (ARG2),Y
STA ARG1+1 ;(CAR)
JMP OTPRG1
SLST2: LDY #ARG1
LDX #ARG2
JSR MAKPNM
LDX #ARG1
JSR GTLSTC
LDY #$01
LDA (ARG1),Y
BEQ SLST3
STA TEMPN ;(CAR)
DEY
STY TEMPN+1
LDA #ARG1
STA ANSN
LDX #$00
LDY #TEMPN
LDA #STRING
JSR CONS
SLST3: JMP OTPRG1
.PAGE
SEQUAL: LDA LTRUE
STA TEMPX2 ;TEMPX2 is PRED
LDA LTRUE+1
STA TEMPX2+1
LDX #ARG2
JSR VPOP
LDX #ARG1
JSR VPOP
INC OTPUTN
LDA SP
STA TEMPN8
LDA SP+1
STA TEMPN8+1
LDX #SEQEND&$FF
LDY #SEQEND^
JSR PUSH
;falls through
.PAGE
;falls in
EQ: LDX #ARG2
JSR GETTYP
STA ANSN
LDX #ARG1
JSR GETTYP
STA ANSNX
CMP #LIST
BEQ EQL
CMP #FIX
BEQ EQF
CMP #FLO
BEQ EQF
CMP #ATOM
BEQ EQA
EQO: LDA ANSNX
CMP ANSN
BNE EQFF
EQO1: LDA ARG1
CMP ARG2
BNE EQFF
LDA ARG1+1
CMP ARG2+1
BEQ EQPOP
EQFF: LDA LFALSE
STA TEMPX2 ;PRED
LDA LFALSE+1
STA TEMPX2+1
JMP SEQEND
EQPOP: JMP POPJ
EQL: LDA ANSN
CMP #LIST
BNE EQFF
JMP EQLIST
EQF: LDX #ARG1 ;ARG1 is a Fixnum
JSR GTNM2 ;(GETNUM) Get first arg in NARG1
LDX #ARG2
JSR GETNUM ;Get second arg in NARG2
BCC EQFF ;Not a number
EQFC: CMP ANSNX ;See if same type...
BEQ EQF1 ;Yes, skip conversion
CMP #FLO ;If NARG2 is Flonum,
BEQ EQF2 ;then correct
JSR FLOTN2 ;Else NARG2 is Fixnum, convert to flt. pt.
JMP EQF1
EQF2: JSR FLOTN1 ;Convert NARG1 to floating pt.
EQF1: LDX #$03
EQFLP: LDA NARG1,X
CMP NARG2,X
BNE EQFF
DEX
BPL EQFLP
JMP POPJ
EQA: LDA ANSN
CMP #FIX
BEQ EQA1
CMP #FLO
BNE EQO
EQA1: STA ANSNX
LDX #NARG2
JSR GTNM2
JSR GTNUM1
BCC EQFF
CMP ANSNX
JMP EQFC
EQLIST: LDA ARG1+1
BNE EQLST1
LDA ARG2+1
BNE EQFF
JMP POPJ
EQLST1: LDA ARG2+1
BEQ EQFF
LDX #ARG1
JSR PUSHP
LDX #ARG2
JSR PUSHP
LDY #$00
LDA (ARG1),Y
TAX
INY
LDA (ARG1),Y
STA ARG1+1
STX ARG1 ;(CAR)
DEY
LDA (ARG2),Y
TAX
INY
LDA (ARG2),Y
STA ARG2+1
STX ARG2 ;(CAR)
JSR STKTST
LDX #EL1&$FF
LDY #EL1^
JSR PUSH
JMP EQ
EL1: LDX #ARG2
JSR POP
LDX #ARG1
JSR POP
LDY #$02
LDA (ARG1),Y
TAX
INY
LDA (ARG1),Y
STA ARG1+1
STX ARG1 ;(CDR)
LDX #ARG1
JSR GETTYP
CMP #LIST
BNE EL1R
LDY #$02
LDA (ARG2),Y
TAX
INY
LDA (ARG2),Y
STA ARG2+1
STX ARG2 ;(CDR)
LDX #ARG2
JSR GETTYP
CMP #LIST
BNE EL1R
JMP EQLIST
EL1R: JSR SYSBUG
SEQEND: LDX #TEMPX2 ;PRED
JSR VPUSHP
LDA TEMPN8
STA SP
LDA TEMPN8+1
STA SP+1
JMP POPJ
.PAGE
STO: LDA GRPHCS
BEQ STO2
JSR RESETT
LDX #SCS&$FF
LDY #SCS^
JSR PUSH ;So we return to graphics mode when done
STO2: LDA INDEV
BNE STO1
JMP CHGST1 ;Not in EDIT-eval loop, so call screen editor
STO1: JSR EDTSTP ;In edit-eval loop
LDA #BUFFER
STA EDSW
LDA #TEMPX2 ;FUN is TEMPX2
LDX #ARG1
JSR GETFUN
LDA TEMPX2+1
BEQ STO1A
LDX #ARG1
JSR UNFUNC
STO1A: LDA #$00
STA NARGS
LDA TOKPTR
STA MARK1
LDA TOKPTR+1
STA MARK1+1
BEQ STOWE
STOW: LDA TOKPTR+1
BEQ STOWE
LDY #$00
LDA (TOKPTR),Y
STA TEMPX2 ;TEMPX2 is TOKEN
INY
LDA (TOKPTR),Y
STA TEMPX2+1 ;(GETTOK)
STOW2: LDX #TEMPX2
JSR GETTYP
CMP #ATOM
BEQ STOW3
CMP #SATOM
BEQ STOW3
CMP #DATOM
BEQ STOW3
LDX #TEMPX2
JMP STLR4A
STOW3: LDX #TOKPTR
JSR TTKADV
INC NARGS
BNE STOW
JMP EXCED
STOWE: LDX #$00
STX TEMPX1+1
LDA #EDBOD
STA ANSN
TXA ;(Type LIST)
LDY #MARK1
JSR CONS
LDY #EDBOD
LDX #EDTATM
LDA NARGS
STA TEMPX1
LDA #TEMPX1
JSR PTFTXT
JMP POPJ
STOERR: LDA #XDEF
LDY #ARG1
JMP ERROR
.PAGE
SEDIT: JSR EDTSTP
LDA #$01
STA EDSW
LDA #TEMPN5 ;FUN
LDX #ARG1
JSR GETFUN
LDA TEMPN5+1
BNE SEDIT1
LDA #XUDF
LDY #ARG1
JMP ERROR
SEDIT1: LDA #$00
LDX #TEMPN5
LDY #EDBOD
JSR UNSTUF
LDY #$00
LDA (EDBOD),Y
STA TEMPN1 ;ARGS
INY
LDA (EDBOD),Y
STA TEMPN1+1 ;(CAR)
LDX #TEMPX1
LDY #TEMPN1
JSR GETLEN
LDA #TEMPX1
LDY #EDBOD
LDX #ARG1
JSR PTFTXT
JSR RSTERR
JMP POPJ
.PAGE
SEND: LDA EDSW
BNE SEND1 ;if edit switch off, give
JMP STTLR1 ;(ERROR XNED)
SEND1: LDA LEVNUM ;if not at top level, complain.
BNE SENDR
LDA LEVNUM+1
BNE SENDR
LDA #EDTATM
LDX #EDBOD
JSR STUFF ;try to put the function def together
LDA #$00
LDX #EDTATM
JSR LTYPE
LDX #SENDM&$FF ;" DEFINED"
LDY #SENDM^
JSR PRTSTR
SEND2: JSR EXTEDT
JMP POPJ
SENDR: JMP STTLR2 ;(ERROR XETL)
.PAGE
SPO: LDA TOKPTR+1
BNE SPO1
LDA PODEFL+1
BNE SPO1A
JMP POPJ
SPO1: LDY #$00
LDA (TOKPTR),Y
STA ARG1
INY
LDA (TOKPTR),Y
STA ARG1+1 ;(GETTOK)
LDX #TOKPTR
JSR TTKADV
LDX ARG1
LDY ARG1+1
CPX ALL
BNE SPO2
CPY ALL+1
BNE SPO2
LDA #$01
JSR POFUNS
SPON: LDA #$01
JSR PONAMS
JMP POPJ
SPO2: CPX NAMES
BNE SPO3
CPY NAMES+1
BEQ SPON
SPO3: CPX TITLES
BNE SPO4
CPY TITLES+1
BNE SPO4
SPOTS: LDA #$00
JSR POFUNS
JMP POPJ
SPO5A: LDA ARG1
STA PODEFL
LDA ARG1+1
STA PODEFL+1
SPO1A: LDX #PODEFL
LDA #TEMPN1
JSR GETFUN
LDA TEMPN1+1
BEQ PFERR
LDX #$01
LDA #PODEFL
JSR POTEXT
JMP POPJ
SPO4: CPX PROCS
BNE SPO5
CPY PROCS+1
BNE SPO5
LDA #$01
JSR POFUNS
JMP POPJ
SPO5: LDX #ARG1
JSR GETTYP
CMP #ATOM
BEQ SPO5A
CMP #SATOM
BEQ SPO5S
JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
SPO5S: LDY #ARG1
LDA #XUBL
JMP ERROR
PFERR: LDY #PODEFL
LDA #XNDF
JMP ERROR
.PAGE
STRCBK: LDA FRAME+1
BNE TCBK1
LDX #TBMSG1&$FF
LDY #TBMSG1^
JSR PRTSTR
JMP TCBKWE
TCBK1: LDX #TBMSG2&$FF
LDY #TBMSG2^
JSR PRTSTR
LDA #$01
STA ANSN1 ;ANSN1 is FIRST
LDA FRAME
STA TEMPX1 ;TEMPX1 is FR
LDA FRAME+1
STA TEMPX1+1
LDA XFRAME
STA TEMPX2 ;TEMPX2 is XFR
LDA XFRAME+1
STA TEMPX2+1
TCBKW: LDA TEMPX1+1
BNE TCBKW1
JMP TCBKWE
TCBKW1: CLC
LDA TEMPX1
ADC #$12 ;(SF_BINDINGS = 18.)
STA TEMPN6 ;TEMPN6 is PTR
LDA TEMPX1+1
ADC #$00
STA TEMPN6+1
SEC
LDA TEMPX2
SBC #$02 ;PTR1 (TEMPN7) points to top binding (name)
STA TEMPN7
LDA TEMPX2+1
SBC #$00
STA TEMPN7+1
TCBKX: LDA TEMPN7+1
CMP TEMPN6+1
BCC TCBKXE
BNE TCBKX1
LDA TEMPN7
CMP TEMPN6
BCC TCBKXE
TCBKX1: LDY #$00
LDA (TEMPN7),Y
STA TEMPNH
INY
LDA (TEMPN7),Y
STA TEMPNH+1 ;(GETBAR)
LDA TEMPNH
ROR A
BCC TCBKX2
LDA ANSN1
BNE TCBKX3
LDA #',
JSR TPCHR
LDA #$20
JSR TPCHR
JMP TCBKX4
TCBKX3: DEC ANSN1
TCBKX4: LDY #$05
LDA (TEMPNH),Y
STA TEMPN8
INY
LDA (TEMPNH),Y
STA TEMPN8+1 ;(GETBAR)
LDA #$00
LDX #TEMPN8
JSR LTYPE
TCBKX2: SEC
LDA TEMPN7
SBC #$04
STA TEMPN7
BCS TCBKX
DEC TEMPN7+1
JMP TCBKX
TCBKXE: LDY #$03 ;(SF_XFRAME = 2.)
LDA (TEMPX1),Y
STA TEMPX2+1
DEY
LDA (TEMPX1),Y
STA TEMPX2 ;(GETBAR)
DEY ;(SF_PREV_FRAME = 0)
LDA (TEMPX1),Y
TAX
DEY
LDA (TEMPX1),Y
STA TEMPX1
STX TEMPX1+1 ;(GETBAR)
JMP TCBKW
TCBKWE: JSR BREAK1
JMP POPJ
.PAGE
SERASE: LDA TOKPTR+1
BNE SERAS1
JMP SCMMT1 ;(ERROR XEOL)
SERAS1: LDY #$00
LDA (TOKPTR),Y
STA ARG1
INY
LDA (TOKPTR),Y
STA ARG1+1 ;(GETTOK)
LDX #TOKPTR
JSR TTKADV
LDA EDSW
BNE SERASB
LDX ARG1
LDY ARG1+1
CPX ALL
BNE ECMP2
CPY ALL+1
BNE ECMP2
JSR REINIT
JMP TOPLOP
ECMP2: CPX NAMES
BNE ECMP3
CPY NAMES+1
BNE ECMP3
JSR ERNAMS
JMP POPJ
ECMP3: CPX TITLES
BNE ECMP4
CPY TITLES+1
BEQ SERPS
ECMP4: CPX PROCS
BNE SERAP
CPY PROCS+1
BNE SERAP
SERPS: JSR ERPROS
JMP POPJ
SERAP: LDX #ARG1
JSR GETTYP
CMP #ATOM
BNE SERAR1
LDX #ARG1
JSR UNFUNC
JMP POPJ
SERAR1: CMP #FIX
BNE SERAR2
JMP STTLR1 ;(ERROR XNED)
SERAR2: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
SERASB: LDX #ARG1
JSR GETTYP
CMP #FIX
BNE SERAR3
LDY #$00
LDA (ARG1),Y
TAX
INY
LDA (ARG1),Y
STA ARG1+1
STX ARG1 ;(CAR)
LDA EDBOD
STA TEMPN ;TEMPN is LASTLINE
LDA EDBOD+1
STA TEMPN+1
LDY #$02
LDA (TEMPN),Y
STA TEMPN1 ;TEMPN1 is LINE
INY
LDA (TEMPN),Y
STA TEMPN1+1 ;(CDR)
DLTW: LDA TEMPN1+1
BEQ DLTWE
DLTW2: LDY #$00
LDA (TEMPN1),Y
STA TEMPNH ;TEMPNH is TEMP
INY
LDA (TEMPN1),Y
STA TEMPNH+1 ;(CAR)
DEY
LDA (TEMPNH),Y
TAX
INY
LDA (TEMPNH),Y
STA TEMPNH+1
STX TEMPNH ;(CAR)
CMP ARG1+1
BCC DLTW1
BNE DLTWE
LDA TEMPNH
CMP ARG1
BEQ DLTWF
BCS DLTWE
DLTW1: LDA TEMPN1
STA TEMPN
LDA TEMPN1+1
STA TEMPN+1
LDY #$02
LDA (TEMPN1),Y
TAX
INY
LDA (TEMPN1),Y
STA TEMPN1+1
STX TEMPN1 ;(CDR)
JMP DLTW
DLTWF: LDY #$02
LDA (TEMPN1),Y
STA TEMPNH
INY
LDA (TEMPN1),Y
STA TEMPNH+1 ;(CDR)
DEY
LDA TEMPNH
STA (TEMPN),Y
INY
LDA TEMPNH+1
STA (TEMPN),Y ;(RPLACD)
DLTWE: JMP POPJ
SERAR3: LDA #XNWE
JMP ERROR
ERPROS: LDA OBLIST
STA TEMPN
LDA OBLIST+1
STA TEMPN+1
ERPRSW: LDA TEMPN+1
BEQ RTS30
LDY #$00
LDA (TEMPN),Y
STA TEMPN1
INY
LDA (TEMPN),Y
STA TEMPN1+1 ;(CAR)
INY
LDA (TEMPN),Y
TAX
INY
LDA (TEMPN),Y
STA TEMPN+1
STX TEMPN ;(CDR)
LDX #TEMPN1
JSR UNFUNC
JMP ERPRSW
RTS30: RTS
.PAGE
ERNAMS: LDA OBLIST
STA TEMPN
LDA OBLIST+1
STA TEMPN+1 ;TEMPN is OBLIST pointer
LDX #$00
STX TEMPN1+1 ;TEMPN1 is NOVALUE
INX
STX TEMPN1
ERNMSW: LDA TEMPN+1
BEQ ERNMWE
LDY #$00
LDA (TEMPN),Y
STA TEMPN2 ;TEMPN2 is NAME
INY
LDA (TEMPN),Y
STA TEMPN2+1 ;(CAR)
INY
LDA (TEMPN),Y
TAX
INY
LDA (TEMPN),Y
STA TEMPN+1
STX TEMPN ;(CDR)
LDX #TEMPN1
LDY #TEMPN2
JSR PUTVAL
JMP ERNMSW
ERNMWE: LDA SOBLST
STA TEMPN
LDA SOBLST+1
STA TEMPN+1
ERNMX: LDA TEMPN
CMP SOBTOP
BNE ERNMX1
LDA TEMPN+1
CMP SOBTOP+1
BEQ RTS30
ERNMX1: LDX #TEMPN1
LDY #TEMPN
JSR PUTVAL
CLC
LDA TEMPN
ADC #$04
STA TEMPN
BCC ERNMX
INC TEMPN+1
JMP ERNMX
.PAGE
SBTFST: LDX #ARG2
JSR VPOP
JSR GETTYP
CMP #LIST
BEQ SBFL
CMP #SATOM
BEQ SBFA
CMP #ATOM
BEQ SBFA
CMP #FIX
BEQ SBFA
CMP #FLO
BEQ SBFA
CMP #STRING
BEQ SBFA
SBFR: JMP SMAKE2 ;(ERROR XWTA,ARG1,CURTOK)
SBFL: LDA ARG2+1
BEQ SBFR
LDY #$02
LDA (ARG2),Y
STA ARG1
INY
LDA (ARG2),Y
STA ARG1+1 ;(CDR)
JMP OTPRG1
SBFA: LDX #ARG2
LDY #ARG1 ;ARG1 is OLD_PTR
JSR MAKPNM
LDX #ARG1
JSR VPUSHP
LDY #$00
STY ANSN1
LDA (ARG1),Y
STA TEMPN1 ;TEMPN1 is OLD_CAR
INY
LDA (ARG1),Y
STA TEMPN1+1 ;(CAR)
BNE SBFA1A
LDA TEMPN1
BEQ SBFR
SBFA1: LDA TEMPN1+1
BEQ SBFB
SBFA1A: LDX #$00
LDA TEMPN1+1
STA TEMPN1
STX TEMPN1+1
LDY #TEMPN1
LDA #TEMPN2
STA ANSN
TXA ;(LIST)
JSR CONS
LDA ANSN1
BNE SBFC
LDX #TEMPN2
JSR VPUSHP
INC ANSN1 ;BEG_OF_PNAME
BNE SBFC1 ;(Always)
SBFC: LDY #$02
LDA TEMPN2
STA (TEMPN),Y ;TEMPN is NEW_PTR
INY
LDA TEMPN2+1
STA (TEMPN),Y ;(RPLACD)
SBFC1: LDA TEMPN2
STA TEMPN
LDA TEMPN2+1
STA TEMPN+1
SBFB: LDY #$02
LDA (ARG1),Y
TAX
INY
LDA (ARG1),Y
STX ARG1
STA ARG1+1 ;(CDR)
BEQ SBFD
SBFB1: LDA TEMPN1
TAX
LDY #$00
LDA (ARG1),Y
STA TEMPN1 ;(OLD_CAR)
INY
LDA (ARG1),Y
STA TEMPN1+1 ;(CAR)
DEY
TXA
STA (TEMPN),Y
INY
LDA TEMPN1
STA (TEMPN),Y
JMP SBFA1
SBFD: LDX #ARG1
JSR VPOP
LDA ANSN1
BNE SBFD1
LDA #$00
STA ARG1
STA ARG1+1
BEQ SBFD2 ;(Always)
SBFD1: LDX #TEMPN ;(OLD_CAR, discard)
JSR VPOP
SBFD2: JMP OTPRG1
.PAGE
SPEEK: JSR GT1FIX
LDY #$00
LDA (NARG1),Y
STA NARG1
STY NARG1+1
LDY #NARG1
JMP OTPFX1
SPOKE: JSR GT2FIX ;First argument is location
LDY #$00
LDA NARG2+1
BNE SPKERR
LDA NARG2
STA (NARG1),Y
JMP POPJ
SPKERR: JMP SFPT1 ;Error, ARG2 too big
SRANDM: LDA #$00
STA NARG1 ;Zero running total
STA NARG1+1
LDA #RANDA&$FF ;Multiply 16-bit Random number by
STA TEMPNH ;transform constant "A"
LDA #RANDA^
STA TEMPNH+1
LDY #$10
RMUL2: LSR RANDOM+1
ROR RANDOM
BCC RMUL4
CLC
RMUL3: LDA NARG1
ADC TEMPNH
STA NARG1
LDA NARG1+1
ADC TEMPNH+1
STA NARG1+1
RMUL4: ASL TEMPNH
ROL TEMPNH+1
DEY
BNE RMUL2
CLC
LDA NARG1
ADC #RANDC&$FF ;Add transform constant "C"
STA RANDOM
STA NARG1
LDA NARG1+1
ADC #RANDC^
STA RANDOM+1
STA NARG1+1
JSR CVFIX ;Convert to string on PDL
RNDLP1: JSR POPB
DEC ANSN1
BNE RNDLP1 ;Pop all characters, just use last one
STA TEMPN1
LDA #$00
STA TEMPN1+1
LDY #TEMPN1
JMP OTPFX1
.PAGE
SRNDMZ: LDA RNDL
STA RANDOM
LDA RNDH
STA RANDOM+1
JMP POPJ
SCTYI: LDA #$00
STA TEMPN+1
JSR RDKEY
STA TEMPN
LDA #ARG1
STA ANSN
LDY #TEMPN
LDX #$00
LDA #STRING ;(String typecode)
JSR CONS ;Cons a cell with the character in it
JMP OTPRG1 ;And output it
SCURSR: JSR GT2FIX
LDA NARG1+1 ;Horizontal position 0 - 39.
BNE SCRSR1
LDA NARG1
CMP #$29
BCS SCRSR1
LDA NARG2+1 ;Vertical position 0 - 23.
BNE SCRSR1
LDA NARG2
CMP #$19
BCS SCRSR1
LDA NARG1
STA CH
LDA NARG2
STA CV
JSR BCALCA
SCALL1: JMP POPJ
SCRSR1: LDA #XCRSR ;"Position off of screen"
JMP ERROR
.PAGE
SCALLR =SCALL1-1
SCALL: JSR GT1FIX
LDA #SCALLR^
PHA ;Push return address for RTS
LDA #SCALLR&$FF
PHA
JMP (NARG1)
.PAGE
SWORD: LDA NARGS
BPL SWRD1
EOR #$FF
STA NARGS
SWRD1: LDA #$00
STA MARK5
STA MARK5+1
LDA NARGS
ASL A
STA ANSNX
CLC
LDA VSP
ADC ANSNX
STA TEMPN6
LDA VSP+1
ADC #$00
STA TEMPN6+1
SWRDW: LDA NARGS
BEQ SWRD2
LDY #$00
LDA (TEMPN6),Y
STA MARK3
INY
LDA (TEMPN6),Y
STA MARK3+1
SEC
LDA TEMPN6
SBC #$02
STA TEMPN6
BCS SWRDW1
DEC TEMPN6
SWRDW1: DEC NARGS
LDY #MARK4
LDX #MARK3
JSR MAKPNM
LDA MARK4+1
BEQ SWRDW
JSR CONCAT ;MARK5 := (Concatenate MARK5 MARK4)
JMP SWRDW
SWRD2: CLC
LDA VSP
ADC ANSNX
STA VSP
BCC SWRD3
INC VSP+1
SWRD3: LDX #MARK5
JSR VPUSHP
INC OTPUTN
LDA #$00
JSR CLMK5
JMP POPJ
.PAGE
CONCAT: LDA MARK5+1
BNE CNCT1
LDA MARK4 ;MARK5 is Lnil, so make
LDX MARK4+1 ;MARK5 a copy of second word and return
LDY #MARK5
JMP COPY
CNCT1: LDA MARK5
LDX MARK5+1
LDY #TEMPN3 ;Make TEMPN3 a copy of MARK5
JSR COPY
LDA TEMPN3
STA TEMPN4 ;Save the first word's pointer in TEMPN4
LDA TEMPN3+1
STA TEMPN4+1
LDX #TEMPN3 ;Get the last cell of first word (TEMPN3)
JSR GTLSTC
LDY #$01
LDA (TEMPN3),Y
BEQ CNCODD
LDA MARK4 ;Even no. chars. in first word
LDX MARK4+1
LDY #TEMPN5 ;Make TEMPN5 a copy of second word
JSR COPY
LDY #$02
LDA TEMPN5
STA (TEMPN3),Y ;Link second word onto first
INY
LDA TEMPN5+1
STA (TEMPN3),Y
CNCTWE: LDA TEMPN4 ;Restore pointer to new word
STA MARK5
LDA TEMPN4+1
STA MARK5+1
RTS
CNCODD: LDY #$00 ;Odd no. chars. in first word
STY TEMPN1+1
LDA (MARK4),Y ;Get first char. of second word
INY
STA (TEMPN3),Y ;Append it to end of first word
LDA (MARK4),Y
STA TEMPN1 ;TEMPN1 holds second char. of second word
CNCTW: LDA MARK4+1
BEQ CNCTWE
LDY #$02
LDA (MARK4),Y
TAX
INY
LDA (MARK4),Y
STA MARK4+1 ;Advance second word char-ptr
STX MARK4
LDA TEMPN1 ;If even-numbered char. of second word nil, exit
BEQ CNCTWE ;(already appended odd-numbered char. preceeding)
LDA MARK4+1
BNE CNCTW1
STA TEMPN1+1 ;Zero last character (because odd no.)
BEQ CNCTW2 ;(Always) Just add last char. if end of second word
CNCTW1: LDY #$00
LDA (MARK4),Y
STA TEMPN1+1 ;Get odd-numbered (3,5,...) char.
INY
LDA (MARK4),Y
STA ANSN1 ;Get next even-numbered (4,6,...) char.
CNCTW2: LDA #TEMPN
STA ANSN
LDY #TEMPN1
LDA #$00
TAX
LDA #STRING
JSR CONS ;Cons new cell
LDY #$02
LDA TEMPN
STA (TEMPN3),Y
TAX
INY
LDA TEMPN+1
STA (TEMPN3),Y ;Append to new word
STA TEMPN3+1
STX TEMPN3 ;New new-word end pointer
LDA ANSN1
STA TEMPN1 ;Last even char. becomes new odd char.
JMP CNCTW
.PAGE
COPY: STY ANSN1 ;Y is STR1
STA TEMPN1 ;Make (ANSN1) point to a copy of (vXA)
STX TEMPN1+1
TXA
BNE COPY1
STA $00,Y ;If (vAX) is Lnil, make (ANSN1) Lnil
STA $00,Y
RTS
COPY1: STY ANSN ;Cons up an empty cell
LDA #$00
TAX
TAY
LDA #STRING
JSR CONS
LDX ANSN1
JSR VPUSHP ;Vpush forming string
COPYW: LDX ANSN1
LDA $00,X
STA TEMPN2
LDA $01,X
STA TEMPN2+1 ;TEMPN2 points to empty last cell of copy
LDY #$00
LDA (TEMPN1),Y
STA (TEMPN2),Y ;Copy two characters into cell
INY
LDA (TEMPN1),Y
STA (TEMPN2),Y
INY
LDA (TEMPN1),Y
TAX
INY
LDA (TEMPN1),Y
STA TEMPN1+1 ;Advance char-ptr of original
STX TEMPN1
TAX
BEQ COPYWE ;Exit if end of original
LDA #TEMPN
STA ANSN
LDA #$00
TAX
TAY
LDA #STRING
JSR CONS ;Cons a new cell
LDY #$02
LDX ANSN1
LDA TEMPN
STA (TEMPN2),Y
STA $00,X
INY
LDA TEMPN+1
STA (TEMPN2),Y ;Link new cell on to end of copy
STA $01,X ;Advance copy's last-cell ptr
JMP COPYW
COPYWE: LDX ANSN1 ;Vpop copy's beginning pointer
JMP VPOP
.PAGE
SBTLST: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #LIST
BEQ BTLSTL
CMP #ATOM
BEQ BTLSTA
CMP #SATOM
BEQ BTLSTA
CMP #FIX
BEQ BTLSTA
CMP #FLO
BEQ BTLSTA
CMP #STRING
BEQ BTLSTA
BTLSTR: JMP SMAKE2
BTLSTA: LDY #TEMPN5
LDX #ARG1
JSR MAKPNM
LDA #ATOM
STA ANSN2
LDY #$00
LDA (TEMPN5),Y
BEQ BTLSTR
LDA TEMPN5
STA ARG1
LDA TEMPN5+1
STA ARG1+1
JMP BTLSTX
BTLSTL: STA ANSN2
LDA ARG1+1
BEQ BTLSTR
BTLSTX: LDA #$00
STA ANSN1 ;NEW_LIST
LDX #ARG1
JSR VPUSHP
BTLSW: LDY #$03
LDA (ARG1),Y
BEQ BTLSWE
LDY #$00
LDA (ARG1),Y
STA TEMPN1 ;TEMP_CAR
INY
LDA (ARG1),Y
STA TEMPN1+1
LDA #TEMPN ;TEMP
STA ANSN
LDY #TEMPN1
LDA #$00
TAX
JSR CONS
LDA ANSN2
CMP #ATOM
BNE BTLSW1
LDX #TEMPN
LDA #STRING
JSR PUTTYP
BTLSW1: LDA ANSN1
BNE BTLSW2
LDX #TEMPN
JSR VPUSHP
LDX TEMPN
LDA TEMPN+1
INC ANSN1
BNE BTLSW3 ;(Always)
BTLSW2: LDY #$02
LDA TEMPN
STA (TEMPN2),Y
TAX
INY
LDA TEMPN+1
STA (TEMPN2),Y
BTLSW3: STA TEMPN2+1
STX TEMPN2
LDY #$02
LDA (ARG1),Y
TAX
INY
LDA (ARG1),Y
STA ARG1+1
STX ARG1
JMP BTLSW
BTLSWE: LDA ANSN2
CMP #LIST
BNE BTLWE1
LDA ANSN1
BNE BTLWL1
LDA #$00
STA ARG1
STA ARG1+1
BEQ BTLWL2 ;(Always)
BTLWL1: LDX #ARG1
JSR VPOP
BTLWL2: LDX #TEMPN1
JSR VPOP
JMP OTPRG1
BTLWE1: LDY #$00
LDA (ARG1),Y
STA TEMPN1
INY
LDA (ARG1),Y
STA TEMPN1+1
BEQ BTLWE2
LDA #TEMPN
STA ANSN
LDA #$00
TAX
STA TEMPN1+1
LDY #TEMPN1
JSR CONS
LDA ANSN1
BNE BTLWE3
LDA TEMPN
STA ARG1
LDA TEMPN+1
STA ARG1+1
JMP BTLWE5
BTLWE3: LDY #$02
LDA TEMPN
STA (TEMPN2),Y
INY
LDA TEMPN+1
STA (TEMPN2),Y
JMP BTLWE4
BTLWE2: LDA ANSN1
BNE BTLWE4
LDA #$00
STA ARG1
STA ARG1+1
BEQ BTLWE5 ;(Always)
BTLWE4: LDX #ARG1
JSR VPOP
BTLWE5: LDX #TEMPN
JSR VPOP
JMP OTPRG1
.PAGE
SLISTP: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #LIST
BNE NTLST
YESLST: JMP VPLTRU
SNMBRP: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #FIX
BEQ YESLST
CMP #FLO
BEQ YESLST
CMP #ATOM
BNE NTLST
LDX #ARG1
JSR ATMTFX
BCS YESLST
NTLST: JMP VPLFLS
.PAGE
SEMPTP: LDX #ARG1
JSR VPOP
JSR GETTYP
CMP #LIST
BEQ SEMPT1
CMP #ATOM
BNE NTLST
LDY #$02
LDA (ARG1),Y
TAX
INY
LDA (ARG1),Y
STA ARG1+1
STX ARG1
LDA (ARG1),Y
BNE NTLST
BEQ YESLST
SEMPT1: LDA ARG1+1
BNE NTLST
BEQ YESLST
.PAGE
SLIST: LDA NARGS
BPL SLIST1
EOR #$FF
STA NARGS
SLIST1: LDA #MARK1
STA ANSN
LDA #$00
STA MARK1
STA MARK1+1
LDA NARGS
BEQ SLSTWE
SLISTW: LDX #MARK2
JSR VPOP
JSR GETTYP
LDY #MARK2
CMP #STRING
BNE SLSTWA
LDX #MARK2
LDY #TEMPX1
JSR INTERN ;Intern it if it's a String
LDY #TEMPX1
SLSTWA: LDX #MARK1
STX ANSN
LDA #$00 ;(Type LIST)
JSR CONS
DEC NARGS
BNE SLISTW
SLSTWE: LDA MARK1
STA ARG1
LDA MARK1+1
STA ARG1+1
LDA #$00
JSR CLMK2
JMP OTPRG1
SCLINP: JSR CLRCBF ;Clear input buffer and character strobe
JMP POPJ
SCLEAR: JSR HOME
JMP POPJ
.PAGE
; Turtle-Graphics Primitives:
SCS: LDA INDEV
BNE SCS2
LDA GRPHCS
BNE SCS1
LDA #EDBUF&$FF ;Tell RETRIEVE that buffer is not retrievable
STA ENDBUF
LDA #EDBUF^
STA ENDBUF+1
LDA $C054 ;INIT Routine, set for primary page
LDA $C057
LDA $C053
LDA $C050
LDA #$14
STA WNDTOP ;Set for 4 lines text
JSR HOME
INC GRPHCS ;Indicate Graphics mode
LDA #$7F
STA COLR ;Color is "White1"
SCS1: LDA #$01
STA PEN
STA TSHOWN ;turtle shown
JSR TTLHOM
JSR GETX
JSR GETY
JSR GPOSN ;Set initial POSN point for future GLINE's
JSR GCLEAR
JSR GSHWT1
SCS2: JMP POPJ
SNDSPL: JSR RESETT ;Nodisplay, get the text page back
LDA #$00
STA GRPHCS
JMP POPJ
SPENUP: JSR GCHK
LDA #$00 ;Penup
STA PEN
JMP POPJ
SPENDN: JSR GCHK
LDA #$01 ;Pendown
STA PEN
JMP POPJ
SHOME: JSR GCHK
JSR GSHWT1 ;Erase turtle if it's there
JSR TTLHOM
JSR GETX
JSR GETY
JSR GDLINE
JMP POPJ
SXCOR: JSR GCHK ;Xcor
LDY #XCOR
JMP OTPFLO
SYCOR: JSR GCHK ;Ycor
LDY #YCOR
JMP OTPFLO
SHDING: JSR GCHK ;Heading
LDY #HEADNG
JMP OTPFLO
SRT: JSR GCHK
JSR GSHWT1
LDX #NARG1 ;Right
JSR VPOP
JSR GT1NMX
BCS SRT1
JSR FLOTN1
SRT1: JSR SRTX
JSR GSHWT1 ;Show it again if necessary
JMP POPJ
SLT: JSR GCHK
JSR GSHWT1
LDX #NARG1 ;Left
JSR VPOP
JSR GT1NMX
BCS SLT1
JSR FLOTN1
SLT1: LDY #HEADNG
JSR XYTON2
JSR FSUBX
JSR GSETHX
JSR GSHWT1
JMP POPJ
STS: JSR GCHK ;Turtlestate
LDA #$00
STA MARK1
STA MARK1+1
LDA TSHOWN
JSR CONSTF
LDA PEN
JSR CONSTF
LDA #HEADNG
JSR CONSNM
LDA #YCOR
JSR CONSNM
LDA #XCOR
JSR CONSNM
LDX #MARK1
JSR VPUSHP
INC OTPUTN
LDA #$00
STA MARK1
STA MARK1+1
JMP POPJ
SSETX: JSR GCHK
JSR GSHWT1
LDX #NARG1 ;Setx
JSR VPOP
JSR GSETX
JSR GETY
JSR GDLINE
JMP POPJ
SSETY: JSR GCHK
JSR GSHWT1
LDX #NARG1 ;Sety
JSR VPOP
JSR GSAVX
JSR GSETY
JSR GETX
JSR GDLINE
JMP POPJ
SSETXY: JSR GCHK
JSR GSHWT1
LDX #TEMPX2
JSR VPOP
LDX #NARG1
JSR VPOP
JSR GSETX
LDA TEMPX2
STA NARG1
LDA TEMPX2+1
STA NARG1+1
JSR GSETY
JSR GDLINE
JMP POPJ
SSETH: JSR GCHK
JSR GSHWT1
LDX #NARG1
JSR VPOP
JSR GSETH
JSR GSHWT1
JMP POPJ
SSETT: JSR GCHK
JSR GSHWT1
LDX #TEMPX2
JSR VPOP ;Setturtle
JSR GETTYP
CMP #LIST
BNE SSETTR
LDA #$FB ;Index for dispatching
STA ANSNX
SSETTL: LDA TEMPX2+1
BEQ SSETTD
LDA ANSNX
BEQ SSETTD
JSR SSTTLL
INC ANSNX
JMP SSETTL
SSETTD: JSR GDLINE
JMP POPJ
SSETTR: JMP SMAKE2 ;Error XWTA,ARG1,CURTOK
.PAGE
SSHOWT: JSR GCHK
LDA TSHOWN
BNE SSHWTR
INC TSHOWN
JSR XORDRW
SSHWTR: JMP POPJ
SHIDET: JSR GCHK
LDA TSHOWN
BEQ SSHWTR
DEC TSHOWN
JSR XORDRW
JMP POPJ
SFULL: JSR GCHK
LDA $C052
JMP POPJ
SMIX: JSR GCHK
LDA $C053
JMP POPJ
.PAGE
SBK: JSR GCHK
JSR GSHWT1
LDX #NARG1
JSR VPOP ;Forward
JSR GT1NMX
BCS SBK1
JSR FLOTN1
SBK1: JSR FCOMPL
JSR SFDX
JSR GDLINE
JMP POPJ
SFD: JSR GCHK
JSR GSHWT1
LDX #NARG1
JSR VPOP ;Forward
JSR GT1NMX
BCS SFD1
JSR FLOTN1
SFD1: JSR SFDX
JSR GDLINE
JMP POPJ
.PAGE
.SBTTL Turtle-Graphics Utility Routines:
SRTX: LDY #HEADNG
JSR XYTON2
JSR FADD
JMP GSETHX
CONSTF: BNE CNSTF1
LDY #LFALSE
BNE CNSNM1 ;(Always)
CNSTF1: LDY #LTRUE
BNE CNSNM1 ;(Always)
CONSNM: TAX
TAY
INX
INX
LDA #TEMPX1
STA ANSN
LDA #FLO
JSR CONS ;CONS the number
LDY #TEMPX1
CNSNM1: LDX #MARK1
STX ANSN
LDA #LIST
JMP CONS ;CONS the node
SSTTLL: LDY #$00
LDA (TEMPX2),Y
STA ARG1
INY
LDA (TEMPX2),Y
STA ARG1+1
INY
LDA (TEMPX2),Y
TAX
INY
LDA (TEMPX2),Y
STA TEMPX2+1
STX TEMPX2
LDX #ARG1
LDY ANSNX
INY
BEQ SSTTS
INY
BEQ SSTTP
INY
BEQ GSETH
INY
BEQ GSETY
BNE GSETX
SSTTS: JSR GTBOL1 ;(GTBOOL doesn't have to Intern, since arg is from a list)
TYA
EOR #$FF
STA TSHOWN
RTS
SSTTP: JSR GTBOL1
TYA
EOR #$FF
STA PEN
RTS
GSETX: JSR GT1NMX ;Set X
BCS GSTX1
JSR FLOTN1
GSTX1: JSR XCHK
JMP GSAVX
GSETY: JSR GT1NMX ;Set Y
BCS GSTY1
JSR FLOTN1
GSTY1: JMP YCHK
GSETH: JSR GT1NMX ;Setheading
BCS GSETHX
JSR FLOTN1
GSETHX: LDA NARG1
CMP #$8F
BCS GSETHR
LDA #$00
STA ANSN1
LDA NARG1+1 ;Normalize to within +/- 180.
BPL SSETDL ;Go to decrement-loop if positive
JSR FCOMPL
INC ANSN1
SSETDL: LDA NARG1
CMP #$87
BCC SSETH2
BNE SSETD
LDA NARG1+1
BMI SSETH2 ;If negative, OK
CMP #$5A ;Check the high byte
BCC SSETH2
BNE SSETD
LDA NARG1+2
BNE SSETD
LDA NARG1+3
BEQ SSETH2
SSETD: LDX #$03
SETHL: LDA FCIRC,X ;Constant, 360.
STA NARG2,X
DEX
BPL SETHL
JSR FSUB ;Subtract 360 degrees
JMP SSETDL
SSETH2: LDA ANSN1
BEQ SSETH3
JSR FCOMPL
SSETH3: LDY #HEADNG
JMP XN1TOY
GSETHR: LDA #XOFLOW
JMP ERROR
GDLINE: LDA PEN
BNE GDLIN1
JSR GPOSN ;Just do a GPOSN if pen is up
JMP GSHWT1
GDLIN1: LDA #$00
STA ANSNX
JSR GLINE
GSHWT1: LDA TSHOWN
BNE XORDRW
RTS
XORDRW: JSR GSAVX ;Save new value of X, in case turtle is out-of-bounds
LDX #$13 ;Draw the turtle, XOR mode
XRDRL1: LDA XCOR,X ;Save XCOR,YCOR,HEADNG,hires vars on stack
PHA
DEX
BPL XRDRL1
LDA #$01
STA ANSNX ;Set up XOR mode
LDA #TTLC1 ;Move to tip
JSR SETARG
JSR SFDX
JSR GPOSN
LDA #TTLA1 ;Turn right to draw first side
JSR SETARG
JSR SRTX
LDA #TTLC2 ;Draw first side
JSR SETARG
JSR SFDX
JSR GLINE
LDA #TTLA2 ;Turn right to draw rear
JSR SETARG
JSR SRTX
LDA #TTLC3 ;Draw rear
JSR SETARG
JSR SFDX
JSR GLINE
LDA #TTLA2 ;Turn right to draw second side
JSR SETARG
JSR SRTX
LDA #TTLC2 ;Draw second side
JSR SETARG
JSR SFDX
JSR GLINE
DEC ANSNX
LDX #$EC
XRDRL2: PLA ;Restore XCOR,YCOR,HEADNG,hires vars from stack
STA XCOR+20,X
INX
BMI XRDRL2
XRDR: RTS
SETARG: STA NARG1
LDA #$00
STA NARG1+1
STA NARG1+2
STA NARG1+3
JMP FLOTN1
GCHK: LDA GRPHCS ;Checks to see if Graphics mode
BNE XRDR
LDA #XYNT
LDY #CURTOK
JMP ERROR ;If not, error "You need a turtle"
TTLHOM: LDX #XCOR
JSR CLRFLT
JSR CLRFLT
CLRFLT: LDA #$00 ;Clear a 4-byte argument
LDY #$03
TTLL1: STA $00,X
INX
DEY
BPL TTLL1
RTS
SFDX: LDY #TEMPX1
JSR XN1TOY ;Save Length in TEMPX1,2
JSR GETHED
LDA NARG1
PHA ;Save table index
JSR MULSIN
LDY #TEMPN7
JSR XYTON2 ;Restore interpolation fraction
JSR FMUL ;Get interpolation correction
LDY #TEMPN5
JSR XYTON2 ;Get uncorrected table value...
JSR FADD ;and correct it!
LDY #TEMPX1
JSR XYTON2 ;Get length back
JSR FMUL ;Multiply Length by fraction
LDA ANSN1 ;X-Incr. sign
BEQ SFDP1
JSR FCOMPL
SFDP1: LDY #XCOR ;Get XCOR in NARG2
JSR XYTON2
JSR FADD ;Add XCOR and NARG1 (X-incr.)
JSR XCHK
PLA ;Retrieve NARG1
STA NARG1
JSR MULCOS
LDY #TEMPN7
JSR XYTON2 ;Restore interpolation fraction
JSR FMUL ;Get interpolation correction
LDY #TEMPN3
JSR XYTON2 ;Get uncorrected table value...
JSR FSUBX ;and correct it!
LDY #TEMPX1
JSR XYTON2 ;Get length back
JSR FMUL ;Multiply Length by fraction
LDA ANSN2 ;Y-Incr. sign
BEQ SFDP2
JSR FCOMPL
SFDP2: LDY #YCOR
JSR XYTON2 ;Get YCOR in NARG2
JSR FADD ;Add YCOR and NARG1 (Y-incr.)
JMP YCHK
GETHED: LDA #$00
STA ANSN1
STA ANSN2
LDY #HEADNG
JSR XYTON2 ;Get HEADING in NARG2
LDY #HEADNG
JSR XYTON1 ;And in NARG1
JSR XINT1 ;Make it integer...
JSR FLOTN1 ;then floating again, zapping fraction bits
JSR FSUBX ;which remain after subtract
LDY #TEMPN7
JSR XN1TOY ;Save fraction for interpolating
LDY #HEADNG
JSR XYTON1 ;Get heading back for munching
LDA NARG1+1
BPL HDPOS
JSR FCOMPL
INC ANSN1 ;Sign of X incr.
HDPOS: LDA NARG1 ;See if it's > 90.
CMP #$86
BCC HDYPOS
BNE HDYNEG
LDA NARG1+1
CMP #$5A
BCC HDYPOS
BNE HDYNEG
LDA NARG1+2
BNE HDYNEG
LDA NARG1+3
BEQ HDYPOS
HDYNEG: LDX #$03
HDYNL: LDA FCIRC1,X
STA NARG2,X
DEX
BPL HDYNL
JSR FSUBX ;Subtract from 180. if > 90.
INC ANSN2
HDYPOS: JMP XINT1 ;Make Heading integer
MULCOS: CLC ;Indexes 90-ANGLE-1 entry and following entry
LDA #$5A
SBC NARG1
MULSIN: ASL A ;Multiply by 2 for offset
PHA ;Save index
TAY
INY
INY
LDA GETRM2
INC BANK4K ;Enable bank 2 ghost-memory
LDA SINTB1,Y ;Get the table's entry
STA NARG1
LDA SINTB1+1,Y
STA NARG1+1
LDA SINTB2,Y
STA NARG1+2
LDA SINTB2+1,Y
STA NARG1+3
LDY #TEMPN5
JSR XN1TOY ;Save table value
PLA ;Retrieve index
TAY
INY
INY
LDA SINTB1+2,Y ;Get the next entry for interpolating
STA NARG2
LDA SINTB1+3,Y
STA NARG2+1
LDA SINTB2+2,Y
STA NARG2+2
LDA SINTB2+3,Y
STA NARG2+3
LDY #TEMPN3
JSR XN2TOY ;Save table value
JSR FSUBX ;Get difference of entries in NARG1
LDA GETRM1
LDA GETRM1
DEC BANK4K ;Re-enable bank 1 ghost-memory
RTS
GCLEAR: LDA #$00 ;CLEAR Routine
STA TEMPN3
LDA #$20
STA TEMPNH+1
LDY #$00
STY TEMPNH
D01B: LDA TEMPN3
STA (TEMPNH),Y
JSR D0A2
INY
BNE D01B
INC TEMPNH+1
LDA TEMPNH+1
AND #$1F
BNE D01B
RTS
GPOSN: JSR GNORM
LDA COLR
STA ANSN1
LDX NARG2+2
LDY NARG2+3
LDA NARG2
;falls through
;falls in
D02E: STA GRP2
STX GRP0
STY GRP1
PHA
AND #$C0
STA GTMP4
LSR A
LSR A
ORA GTMP4
STA GTMP4
PLA
STA GTMP4+1
ASL A
ASL A
ASL A
ROL GTMP4+1
ASL A
ROL GTMP4+1
ASL A
ROR GTMP4
LDA GTMP4+1
AND #$1F
ORA #$20
STA GTMP4+1
TXA
CPY #$00
BEQ D063
LDY #$23
ADC #$04
D062: INY
D063: SBC #$07
BCS D062
STY GRP5
TAX
LDA D1EA-256,X
STA GANSN2
TYA
LSR A
LDA ANSN1
D075: STA TEMPN3
BCS D0A2
RTS
D088: BPL D0AE
LDA GANSN2
LSR A
BCS D094
EOR #$C0
D091: STA GANSN2
RTS
D094: DEY
BPL D099
LDY #$27
D099: LDA #$C0
D09B: STA GANSN2
STY GRP5
LDA TEMPN3
D0A2: ASL A
CMP #$C0
BPL D0AD
LDA TEMPN3
EOR #$7F
STA TEMPN3
D0AD: RTS
D0AE: LDA GANSN2
ASL A
EOR #$80
BMI D091
LDA #$81
INY
CPY #$28
BCC D09B
LDY #$00
BCS D09B ;(Always taken)
D0F9: BMI D12B
CLC
LDA GTMP4+1
BIT D1EA
BNE D125
ASL GTMP4
BCS D121
BIT D0F3
BEQ D111
ADC #$1F
SEC
BCS D123 ;(Always taken)
D111: ADC #$23
PHA
LDA GTMP4
ADC #$B0
BCS D11C
ADC #$F0
D11C: STA GTMP4
PLA
BCS D123
D121: ADC #$1F
D123: ROR GTMP4
D125: ADC #$FC
D127: STA GTMP4+1
RTS
D12B: LDA GTMP4+1
D12D: ADC #$04
BIT D1EA
BNE D127
ASL GTMP4
BCC D151
ADC #$E0
CLC
BIT D12D+1
BEQ D153
LDA GTMP4
ADC #$50
EOR #$F0
BEQ D14A
EOR #$F0
D14A: STA GTMP4
LDA #$20
BCC D153
D151: ADC #$E0
D153: ROR GTMP4
BCC D127 ;(Always branches)
D164: PHA
SEC
SBC GRP0
PHA
TXA
SBC GRP1
STA TEMPN6+1
BCS D17C
PLA
EOR #$FF
ADC #$01
PHA
LDA #$00
SBC TEMPN6+1
D17C: STA TEMPN5+1
STA TEMPN7+1
PLA
STA TEMPN5
STA TEMPN7
PLA
STA GRP0
STX GRP1
TYA
CLC
SBC GRP2
BCC D197
EOR #$FF
ADC #$FE
D197: STA TEMPN6
STY GRP2
ROR TEMPN6+1
SEC
SBC TEMPN5
TAX
LDA #$FF
SBC TEMPN5+1
STA TEMPN3+1
LDY GRP5
BCS D1B2 ;(Always taken)
D1AD: ASL A
JSR D088
SEC
D1B2: LDA TEMPN7
ADC TEMPN6
STA TEMPN7
LDA TEMPN7+1
SBC #$00
D1BC: STA TEMPN7+1
LDA ANSNX
BEQ XORHK1
LDA #$FF
BNE XORHK2
XORHK1: LDA (GTMP4),Y
EOR TEMPN3
XORHK2: AND GANSN2
EOR (GTMP4),Y
STA (GTMP4),Y
INX
BNE D1CF
INC TEMPN3+1
BNE D1CF
RTS
D1CF: LDA TEMPN6+1
BCS D1AD
JSR D0F9
CLC
LDA TEMPN7
ADC TEMPN5
STA TEMPN7
LDA TEMPN7+1
ADC TEMPN5+1
BVC D1BC ;(Always taken)
$81
$82
$84
$88
$90
$A0
$C0
D1EA: $1C
D1EB: $FF
D1EC: $FE
$FA
$F4
$EC
$E1
$D4
$C5
$B4
$A1
$8D
$78
$61
$49
$31
$18
$FF
D0F3: $03
GLINE: JSR GNORM
LDA GRP5
LSR A
LDA COLR
JSR D075
LDX NARG2+3
LDA NARG2+2
LDY NARG2
JMP D164
XCHK: LDY #A1L
JSR XN1TOY
JSR XINT1
LDX #NARG1
JSR CHKINT
BCS D3AC1
LDA NARG1+1
BMI XCHKM
BNE D3AC1
LDA NARG1
CMP #$8C
BCS D3AC1
BCC XRTS
XCHKM: CMP #$FF
BNE D3AC1
LDA NARG1
CMP #$74
BCC D3AC1
XRTS: LDX #$03
XCHL: LDA A1L,X
STA XCOR,X
DEX
BPL XCHL
STOX: LDA NARG1
STA EPOINT
LDA NARG1+1
STA EPOINT+1
RTS
D3AC: LDX #$03
D3ACL: LDA A3L,X
STA XCOR,X
DEX
BPL D3ACL
D3AC1: LDA #XOOB ;Error "Out of Bounds"
JMP ERROR
YCHK: LDY #A1L
JSR XN1TOY
LDX #$03
YCHL1: LDA GRPHK1,X
STA NARG2,X
DEX
BPL YCHL1
JSR FMUL ;First multiply by 0.8
JSR XINT1
LDX #NARG1
JSR CHKINT
BCS D3AC
LDA NARG1+1
BMI YCHKM
BNE D3AC
LDA NARG1
CMP #$60
BCC YRTS
BCS D3AC
YCHKM: CMP #$FF
BNE D3AC
LDA NARG1
CMP #$A0
BCC D3AC
YRTS: LDX #$03
YCHL: LDA A1L,X
STA YCOR,X
DEX
BPL YCHL
STOY: LDA NARG1
STA A5L
RTS
GETX: LDY #XCOR
JSR XYTON1
JSR XINT1
JMP STOX
GETY: LDY #YCOR
JSR XYTON1
JSR XINT1
JMP STOY
GSAVX: LDX #$03
GSVXL: LDA XCOR,X
STA A3L,X
DEX
BPL GSVXL
RTS
GNORM: SEC
LDA #$5F
SBC A5L ;Subtract Ycoord from 95.
STA NARG2
GNORM2: CLC
LDA EPOINT
ADC #$8C ;Add 140. to Xcoord
STA NARG2+2
LDA EPOINT+1
ADC #$00
STA NARG2+3
GNORM1: RTS
ZZZZZZ=. ;(Label quickly noticeable in symbol table)
.PAGE
.SBTTL Stored Interpreter Data:
; Monitor data:
CHRTBL: .ASCII "VM<NIG S:."
$05 ;^E
$0D ;(Carriage-return)
$10 ;^P
$0B ;^K
$02 ;^B
SUBTBL: .ADDR VFY
.ADDR MOVE
.ADDR LT
.ADDR SETNRM
.ADDR SETINV
.ADDR GO
.ADDR BLANK
.ADDR BSWTCH
.ADDR SETMOD
.ADDR SETMOD
.ADDR REGDSP
.ADDR CRMON
.ADDR OUTPRT
.ADDR INPRT
.ADDR XMON
RTBL: .ASCII "AXYPS"
; Constants:
FLT10: $83 ;Floating-point constant, 10.0
$50
$00
$00
FCIRC: $88 ;Floating-point constant, 360.0
$5A
$00
$00
FCIRC1: $87 ;Floating-point constant, 180.0
$5A
$00
$00
GRPHK1: $7F ;Floating-point constant, 0.8
$66
$66
$66
.PAGE
; Primitive Address Dispatch Table:
.=SYSTAB*$100 ;Original load area
; System Function address table:
; (Ghost-memory bank 2)
.ADDR SYSBUG ;For INULL, in case of indexing error
.ADDR SPTHNG
.ADDR SWORD
.ADDR SPWRDP
.ADDR SUNSUM
.ADDR SUNDIF
.ADDR SMAKE
.ADDR SOUTPT
.ADDR SSTOP
.ADDR SPRINT
.ADDR STYPE
.ADDR SDEFIN
.ADDR SCLEAR
.ADDR SCNTIN
.ADDR STPPKZ
.ADDR SELSE
.ADDR SSNTNC
.ADDR SBOTH
.ADDR SEITHR
.ADDR XXSFR1 ;Then
.ADDR SNOT
.ADDR PARLOP ;Left-parenthesis
.ADDR XXSFR2 ;Right-parenthesis
.ADDR SIF
.ADDR SRUN
.ADDR SGO
.ADDR SBPT
.ADDR LOGO1 ;Goodbye
.ADDR SGCOLL
.ADDR SNODES
.ADDR SBTFST
.ADDR SFIRST
.ADDR SBTLST
.ADDR SLAST
.ADDR STO
.ADDR SEDIT
.ADDR SEND
.ADDR STEXT
.ADDR SFD
.ADDR SBK
.ADDR SRT
.ADDR SLT
.ADDR SLIST
.ADDR SCS
.ADDR SHOME
.ADDR SPENUP
.ADDR SPENDN
.ADDR SEMPTP
.ADDR SSHOWT
.ADDR SHIDET
.ADDR STS
.ADDR STITLE
.ADDR SFPUT
.ADDR SPO
.ADDR XXSFR3 ;All
.ADDR XXSFR3 ;Names
.ADDR SERASE
.ADDR SREAD
.ADDR SSAVE
.ADDR SREQU
.ADDR STHING
.ADDR SRETRV
.ADDR SSUM
.ADDR SDIF
.ADDR SPROD
.ADDR SDIVID
.ADDR SGRTR
.ADDR SLESS
.ADDR SCOMMT
.ADDR SEQUAL
.ADDR STRCBK
.ADDR SPOTS
.ADDR XXSFR3 ;Titles
.ADDR XXSFR3 ;Procedures
.ADDR SPEEK
.ADDR SPOKE
.ADDR SSUM
.ADDR SDIF
.ADDR SPROD
.ADDR SDIVID
.ADDR SGRTR
.ADDR SLESS
.ADDR SEQUAL
.ADDR SLPUT
.ADDR SRANDM
.ADDR SCTYI
.ADDR SCURSR
.ADDR SRNDMZ
.ADDR SCALL
.ADDR SLISTP
.ADDR SNMBRP
.ADDR SCLINP
.ADDR SCHNGE
.ADDR SRPEAT
.ADDR SSETX
.ADDR SSETY
.ADDR SSETXY
.ADDR SSETH
.ADDR SSETT
.ADDR SXCOR
.ADDR SYCOR
.ADDR SHDING
.ADDR SNDSPL
.ADDR SINT
.ADDR SFULL
.ADDR SMIX
.ADDR SDELET
.ADDR SCATLG
.PAGE
; Error-string address table:
ERRTBL=.+TDIFF-2 ;(Ghost-memory bank 2)
.ADDR XXUOP+TDIFF
.ADDR XXEOL+TDIFF
.ADDR XXUDF+TDIFF
.ADDR XXHNV+TDIFF
.ADDR XXNIP+TDIFF
.ADDR XXNOP+TDIFF
.ADDR XXRPN+TDIFF
.ADDR XXIFX+TDIFF
.ADDR XXVNA+TDIFF
.ADDR XXTIP+TDIFF
.ADDR XXWTA+TDIFF
.ADDR XXUBL+TDIFF
.ADDR XXNTL+TDIFF
.ADDR XXNTF+TDIFF
.ADDR XXELS+TDIFF
.ADDR XXBRK+TDIFF
.ADDR XXLAB+TDIFF
.ADDR XXTHN+TDIFF
.ADDR XXLNF+TDIFF
.ADDR XXEDT+TDIFF
.ADDR XXDEF+TDIFF
.ADDR XXETL+TDIFF
.ADDR XXNED+TDIFF
.ADDR XXOPO+TDIFF
.ADDR XXTML+TDIFF
.ADDR XXDBZ+TDIFF
.ADDR XXNWE+TDIFF
.ADDR XXLNT+TDIFF
.ADDR XXILN+TDIFF
.ADDR XXOFL+TDIFF
.ADDR XXNDF+TDIFF
.ADDR XXCRS+TDIFF
.ADDR XXYNT+TDIFF
.ADDR XXOOB+TDIFF
.ADDR XXIOR+TDIFF
.ADDR XXWTP+TDIFF
.ADDR XXFNF+TDIFF
.ADDR XXDKF+TDIFF
.ADDR XXLKF+TDIFF
.PAGE
; Error Messages:
; (Ghost-memory bank 2)
XXUOP: .ASCII "You don't say what to do with "
$00
$FF
XXEOL: .ASCII "Unexpected end of line"
$FF
XXUDF: .ASCII "You haven't told me how to "
$00
$FF
XXHNV: $00
.ASCII " has no value"
$FF
XXNIP: .ASCII "Nothing inside parenthesis"
$FF
XXNOP: $00
.ASCII " didn't output"
$FF
XXRPN: .ASCII "Unexpected )"
$FF
XXIFX: .ASCII "There's nothing before the "
$00
$FF
XXVNA: .ASCII "You need ( )'s around "
$00
$FF
XXTIP: .ASCII "Too much inside parenthesis"
$FF
XXWTA: $00
.ASCII " doesn't like "
$01
.ASCII " as input"
$FF
XXUBL: $00
.ASCII " is used by LOGO"
$FF
XXNTL: $00
.ASCII " should only be called inside a procedure"
$FF
XXNTF: $00
.ASCII " was given instead of TRUE or FALSE"
$FF
XXELS: .ASCII "ELSE is out of place"
$FF
XXBRK: .ASCII "I was told to pause"
$FF
XXLAB: .ASCII "There's a label in the middle of a line"
$FF
XXTHN: .ASCII "THEN is out of place"
$FF
XXLNF: .ASCII "I can't find the label "
$00
$FF
XXEDT: .ASCII "You're already editing something"
$FF
XXDEF: $00
.ASCII " is already defined"
$FF
XXETL: .ASCII "You can only edit at top level"
$FF
XXNED: .ASCII "You're not in Edit mode"
$FF
XXOPO: .ASCII "You can only say "
$00
.ASCII " to PO, ER, etc."
$FF
XXTML: .ASCII "Too many display commands"
$FF
XXDBZ: .ASCII "You tried to divide by zero"
$FF
XXNWE: .ASCII "You can't do that while in Edit mode"
$FF
XXLNT: .ASCII "Line number too big"
$FF
XXILN: .ASCII "Illegal line number"
$FF
XXOFL: .ASCII "Arithmetic overflow"
$FF
XXNDF: $00
.ASCII " is not defined"
$FF
XXCRS: .ASCII "Cursor coordinates off of screen"
$FF
XXYNT: .ASCII "You need a turtle to do "
$00
$FF
XXOOB: .ASCII "Turtle Out-of-Bounds"
$FF
XXIOR: .ASCII "I/O Error"
$FF
XXWTP: .ASCII "The file is write-protected"
$FF
XXFNF: .ASCII "File not found"
$FF
XXDKF: .ASCII "You have a write-protected disk"
$FF
XXLKF: .ASCII "The file is locked"
$FF
.PAGE
; Primitive table:
; (Ghost-memory bank 2)
PRMTAB =.+TDIFF
0
0
IALL
.ASCII "ALL "
1
0
IBACK
.ASCII "BACK "
1
5
IBTFST
.ASCII "BF "
1
0
IBACK
.ASCII "BK "
1
5
IBTLST
.ASCII "BL "
2
1
IBOTH
.ASCII "BOTH "
1
5
IBTFST
.ASCII "BUTFIRST "
1
5
IBTLST
.ASCII "BUTLAST "
0
0
ICATLG
.ASCII "CATALOG "
0
0
IEDIT
.ASCII "CHANGE "
0
0
IEDIT
.ASCII "CHG "
0
0
ICLEAR
.ASCII "CLEAR "
0
0
ICLINP
.ASCII "CLEARINPUT "
0
0
ICS
.ASCII "CLEARSCREEN "
0
0
ICNTIN
.ASCII "CO "
0
0
ICNTIN
.ASCII "CONTINUE "
0
0
ICS
.ASCII "CS "
2
5
ICURSR
.ASCII "CURSOR "
2
0
IDEFIN
.ASCII "DE "
2
0
IDEFIN
.ASCII "DEFINE "
1
0
IDELET
.ASCII "DELETE "
2
6
IDIF
.ASCII "DIFFERENCE "
0
0
ICHNGE
.ASCII "ED "
0
0
ICHNGE
.ASCII "EDIT "
2
1
IEITHR
.ASCII "EITHER "
0
1
IELSE
.ASCII "ELSE "
1
5
IEMPTP
.ASCII "EMPTY? "
0
0
IEND
.ASCII "END "
2
3
IEQUAL
.ASCII "EQUAL? "
0
0
IERASE
.ASCII "ER "
0
0
IERASE
.ASCII "ERASE "
1
5
IFIRST
.ASCII "F "
1
0
IFORWD
.ASCII "FD "
1
5
IFIRST
.ASCII "FIRST "
1
0
IFORWD
.ASCII "FORWARD "
2
0
IFPUT
.ASCII "FPUT "
0
0
IFULL
.ASCII "FULL "
1
0
IGO
.ASCII "GO "
0
0
IGDBYE
.ASCII "GOODBYE "
2
4
IGREAT
.ASCII "GREATER? "
0
0
IHIDET
.ASCII "HIDETURTLE "
0
0
IHDING
.ASCII "HEADING "
0
0
IHOME
.ASCII "HOME "
0
0
IHIDET
.ASCII "HT "
1
0
IIF
.ASCII "IF "
1
8
IINT
.ASCII "INT "
1
8
IINT
.ASCII "INTEGER "
1
5
ILAST
.ASCII "L "
1
5
ILAST
.ASCII "LAST "
1
0
ILEFT
.ASCII "LEFT "
2
4
ILESS
.ASCII "LESS? "
-3
5
ILIST
.ASCII "LIST "
1
5
ILISTP
.ASCII "LIST? "
2
0
ILPUT
.ASCII "LPUT "
1
0
ILEFT
.ASCII "LT "
2
0
IMAKE
.ASCII "MAKE "
0
0
IMIX
.ASCII "MIX "
0
0
INAMES
.ASCII "NAMES "
0
0
INDSPL
.ASCII "ND "
0
0
INDSPL
.ASCII "NODISPLAY "
1
2
INOT
.ASCII "NOT "
1
5
INMBRP
.ASCII "NUMBER? "
1
0
IOTPUT
.ASCII "OP "
1
0
IOTPUT
.ASCII "OUTPUT "
0
0
IPAUSE
.ASCII "PAUSE "
0
0
IPENDN
.ASCII "PD "
0
0
IPENDN
.ASCII "PENDOWN "
0
0
IPENUP
.ASCII "PENUP "
0
0
IPO
.ASCII "PO "
0
0
IPOTS
.ASCII "POTS "
-2
0
IPRINT
.ASCII "PR "
-2
0
IPRINT
.ASCII "PRINT "
-2
0
ITYPE
.ASCII "PRINT1 "
0
0
IPO
.ASCII "PRINTOUT "
0
0
IPROCS
.ASCII "PROCEDURES "
2
7
IPROD
.ASCII "PRODUCT "
0
0
IPENUP
.ASCII "PU "
2
7
IQUOT
.ASCII "QUOTIENT "
0
0
IRANDM
.ASCII "RANDOM "
0
0
IRNDMZ
.ASCII "RANDOMIZE "
0
0
ICTYI
.ASCII "RC "
1
0
IREAD
.ASCII "READ "
0
0
ICTYI
.ASCII "READCHARACTER "
2
0
IRPEAT
.ASCII "REPEAT "
0
0
IREQST
.ASCII "REQUEST "
0
0
IRETRV
.ASCII "RETRIEVE "
1
0
IRIGHT
.ASCII "RIGHT "
0
0
IREQST
.ASCII "RQ "
1
0
IRIGHT
.ASCII "RT "
1
0
IRUN
.ASCII "RUN "
1
0
ISAVE
.ASCII "SAVE "
-3
5
ISNTNC
.ASCII "SE "
-3
5
ISNTNC
.ASCII "SENTENCE "
1
0
ISETH
.ASCII "SETH "
1
0
ISETH
.ASCII "SETHEADING "
1
0
ISETT
.ASCII "SETT "
1
0
ISETT
.ASCII "SETTURTLE "
1
0
ISETX
.ASCII "SETX "
2
0
ISETXY
.ASCII "SETXY "
1
0
ISETY
.ASCII "SETY "
0
0
ISHOWT
.ASCII "SHOWTURTLE "
0
0
ISHOWT
.ASCII "ST "
0
0
ISTOP
.ASCII "STOP "
2
6
ISUM
.ASCII "SUM "
0
0
ITRCBK
.ASCII "TB "
1
5
ITEXT
.ASCII "TEXT "
0
0
ITHEN
.ASCII "THEN "
1
5
ITHING
.ASCII "THING "
1
5
ITHNGP
.ASCII "THING? "
0
0
ITITLE
.ASCII "TI "
0
0
ITITLE
.ASCII "TITLE "
0
0
ITITLS
.ASCII "TITLES "
0
0
ITO
.ASCII "TO "
0
0
ITRCBK
.ASCII "TRACEBACK "
0
0
ITSTAT
.ASCII "TS "
0
0
ITSTAT
.ASCII "TURTLESTATE "
-3
5
IWORD
.ASCII "WORD "
1
5
IWORDP
.ASCII "WORD? "
0
0
IXCOR
.ASCII "XCOR "
0
0
IYCOR
.ASCII "YCOR "
0
0
ILPAR
.ASCII "( "
0
0
IRPAR
.ASCII ") "
2
7
INPROD
.ASCII "* "
2
6
INSUM
.ASCII "+ "
2
6
INDIF
.ASCII "- "
0
0
IBPT
.ASCII ".BPT "
1
5
ICALL
.ASCII ".CALL "
2
0
IPOKE
.ASCII ".DEPOSIT "
1
0
IPEEK
.ASCII ".EXAMINE "
0
0
IGCOLL
.ASCII ".GCOLL "
0
0
INODES
.ASCII ".NODES "
2
7
INQUOT
.ASCII "/ "
0
0
ICOMNT
.ASCII "; "
2
4
INLESS
.ASCII "< "
2
3
INEQUL
.ASCII "= "
2
4
INGRTR
.ASCII "> "
.PAGE
; V-Primitive table:
; (Ghost-memory bank 2)
VPRMTB =.+TDIFF
INSUM
.WORD INFSUM
1
INDIF
.WORD INFDIF
1
ILPAR
.WORD LPAR
1
IRPAR
.WORD RPAR
1
IIF
.WORD LIF
1
IELSE
.WORD LELSE
1
ITHEN
.WORD LTHEN
1
INAMES
.WORD NAMES
1
IALL
.WORD ALL
1
ITITLS
.WORD TITLES
1
IPROCS
.WORD PROCS
1
IEND
.WORD LEND
1
IPO
.WORD PO
1
IPO
.WORD PRNTOT
2
IPOTS
.WORD POTS
1
IERASE
.WORD ER
1
IERASE
.WORD ERASE
2
ITITLE
.WORD TI
1
ITITLE
.WORD LTITLE
2
ISTOP
.WORD LSTOP
1
ICOMNT
.WORD COMMNT
1
VPRMTE =.+TDIFF
.PAGE
; Miscellaneous text strings:
; (Ghost-memory page 2)
HELSTR=.+TDIFF
.ASCII "Welcome to Apple Logo!"
$0D
.ASCII "Preliminary Version"
$0D
.ASCII "Assembled 8/06/80" ;(Use correct date when assembling)
$0D
$00
LBUG1=.+TDIFF
.ASCII "LOGO bug; exiting..."
$0D
$00
RDRER1=.+TDIFF
.ASCII "Reader error: Too many sublists"
$0D
$00
RDRER2=.+TDIFF
.ASCII "You have mismatched brackets"
$0D
$00
ZPMSG1=.+TDIFF
.ASCII "No storage left!"
$0D
$00
ZPMSG2=.+TDIFF
.ASCII "Stopped!"
$0D
$00
ZPMSG3=.+TDIFF
.ASCII "Evaluator overflow!"
$0D
$00
WRNMSG=.+TDIFF
.ASCII "Please ERASE something:"
$0D
$00
ERRM1=.+TDIFF
.ASCII "At level "
$00
ERRM2=.+TDIFF
.ASCII " in line "
$00
ERRM3=.+TDIFF
.ASCII " of "
$00
ERRM4=.+TDIFF
.ASCII " is too big for "
$00
SENDM=.+TDIFF
.ASCII " defined"
$0D
$00
PNMSG1=.+TDIFF
.ASCII " is "
$00
PNMSG2=.+TDIFF
.ASCII "MAKE "
$00
TBMSG1=.+TDIFF
.ASCII "We're now at top-level."
$0D
$00
TBMSG2=.+TDIFF
.ASCII "We're currently inside "
$00
CHGMSG=.+TDIFF
.ASCII " APPLE LOGO SCREEN EDITOR "
$00
TOMSG=.+TDIFF
.ASCII "TO "
$00
ENDMSG=.+TDIFF
.ASCII "END"
$0D
$00
WAITM=.+TDIFF
.ASCII "Please wait..."
$0D
$00
SAVEM=.+TDIFF
$8D
$84 ;^D for DOS
$C2 ;B these have their high
$D3 ;S bits turned on because
$C1 ;A that's the way that
$D6 ;V Apple does it and DOS
$C5 ;E understands it.
$00
SAVEM2=.+TDIFF
$AC ;,
$C1 ;A
$A4 ;$
$B2 ;2
$B0 ;0
$B0 ;0
$B0 ;0
$AC ;,
$CC ;L
$A4 ;$
$00
LOADM=.+TDIFF
$8D
$84 ;^D for DOS
$C2 ;B
$CC ;L
$CF ;O
$C1 ;A
$C4 ;D
$00
DELETM=.+TDIFF
$8D
$84
$C4 ;D
$C5 ;E
$CC ;L
$C5 ;E
$D4 ;T
$C5 ;E
$00
CATLGM=.+TDIFF
$8D
$84
$C3 ;C
$C1 ;A
$D4 ;T
$C1 ;A
$CC ;L
$CF ;O
$C7 ;G
$8D
$00
LOGOM=.+TDIFF
$AE
$CC
$CF
$C7
$CF
$00
;Start of Sine table (91 4-byte flonums, first 2 bytes only)
SINTB1=.-2+TDIFF
$00
$00
$7A
$47
$7B
$47
$7B
$6B
$7C
$47
$7C
$59
$7C
$6B
$7C
$7C
$7D
$47
$7D
$50
$7D
$58
$7D
$61
$7D
$6A
$7D
$73
$7D
$7B
$7E
$42
$7E
$46
$7E
$4A
$7E
$4F
$7E
$53
$7E
$57
$7E
$5B
$7E
$5F
$7E
$64
$7E
$68
$7E
$6C
$7E
$70
$7E
$74
$7E
$78
$7E
$7C
$7F
$40
$7F
$41
$7F
$43
$7F
$45
$7F
$47
$7F
$49
$7F
$4B
$7F
$4D
$7F
$4E
$7F
$50
$7F
$52
$7F
$53
$7F
$55
$7F
$57
$7F
$58
$7F
$5A
$7F
$5C
$7F
$5D
$7F
$5F
$7F
$60
$7F
$62
$7F
$63
$7F
$64
$7F
$66
$7F
$67
$7F
$68
$7F
$6A
$7F
$6B
$7F
$6C
$7F
$6D
$7F
$6E
$7F
$6F
$7F
$71
$7F
$72
$7F
$73
$7F
$74
$7F
$74
$7F
$75
$7F
$76
$7F
$77
$7F
$78
$7F
$79
$7F
$79
$7F
$7A
$7F
$7B
$7F
$7B
$7F
$7C
$7F
$7C
$7F
$7D
$7F
$7D
$7F
$7E
$7F
$7E
$7F
$7E
$7F
$7F
$7F
$7F
$7F
$7F
$7F
$7F
$7F
$7F
$7F
$7F
$7F
$7F
$80
$40
$80 ;Extra entry for interpolation routine
$40
;Start of Sine table (91 4-byte flonums, second 2 bytes only)
SINTB2=.-2+TDIFF
$00
$00
$7C
$2D
$79
$63
$2F
$1D
$6E
$3E
$3F
$5B
$09
$82
$CB
$51
$41
$B2
$18
$2E
$E8
$6A
$B1
$B7
$73
$67
$2C
$C9
$DD
$30
$41
$F7
$90
$2B
$D8
$DF
$1B
$BD
$58
$6F
$8E
$A2
$BE
$01
$E6
$38
$06
$F5
$1F
$E5
$30
$B6
$39
$17
$38
$B9
$2F
$4A
$1C
$7C
$00
$00
$EC
$C5
$D4
$65
$B6
$BB
$93
$A2
$6A
$F4
$3C
$8C
$08
$46
$CD
$FF
$8D
$92
$46
$DD
$F9
$BE
$A6
$12
$4B
$B9
$EA
$91
$82
$7A
$13
$54
$9D
$00
$1F
$5F
$9A
$53
$0D
$BF
$79
$85
$DD
$89
$39
$B0
$8D
$DE
$D9
$F9
$1D
$E7
$59
$8F
$8C
$D7
$B7
$A8
$D9
$EC
$F3
$8A
$04
$6D
$0C
$80
$0B
$AF
$01
$E5
$EF
$0F
$D3
$1A
$AD
$F6
$7F
$90
$47
$D9
$06
$C1
$BC
$38
$68
$32
$0A
$A0
$A3
$75
$32
$A6
$B8
$29
$33
$F1
$A5
$F6
$0E
$2E
$6C
$92
$C1
$1B
$0B
$C1
$4C
$7E
$83
$4F
$B0
$2E
$D3
$18
$EC
$0A
$FB
$02
$00
$00
$00 ;Extra entry for interpolation routine
$00
ENDTAB=. ;End of Ghost-memory bank 2 storage
.=SYSTAB*$100-$1006
JMP LOGO ;Vector for BRUN to work from DOS
JMP LOGO1 ;Re-entry point for crash or GOODBYE
.=$95F5 ;(Causes assembler to signal error if program crashes into DOS)
$00
.END
Reference in New Issue View Git Blame Copy Permalink