From d536b228ac5fbff30c8c2e22f51911b21a1f5a03 Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Sun, 16 Sep 2018 20:04:10 +0200 Subject: [PATCH] Apple II Logo. Written by: - Stephen L. Hain - Patrick G. Sobalvarro - Leigh L. Klotz. --- Makefile | 5 +- build/misc.tcl | 7 + doc/aplogo/apldoc.1 | 790 +++ doc/aplogo/apple.help | 14 + doc/aplogo/doc.187 | 510 ++ doc/aplogo/usage.doc | 186 + doc/programs.md | 1 + src/aplogo/logo.958 | 13450 ++++++++++++++++++++++++++++++++++++++++ 8 files changed, 14961 insertions(+), 2 deletions(-) create mode 100644 doc/aplogo/apldoc.1 create mode 100644 doc/aplogo/apple.help create mode 100644 doc/aplogo/doc.187 create mode 100644 doc/aplogo/usage.doc create mode 100644 src/aplogo/logo.958 diff --git a/Makefile b/Makefile index 506f9628..8eb809cd 100644 --- a/Makefile +++ b/Makefile @@ -25,11 +25,12 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ tensor transl wgd zz graphs lmlib pratt quux scheme gsb ejs mudsys \ draw wl taa tj6 budd sharem ucode rvb kldcp math as imsrc gls demo \ macsym lmcons dmcg hack hibou agb gt40 rug maeda ms kle aap common \ - fonts zork 11logo kmp info + fonts zork 11logo kmp info aplogo DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ - kldcp libdoc lisp _mail_ midas quux scheme manual wp chess ms macdoc + kldcp libdoc lisp _mail_ midas quux scheme manual wp chess ms macdoc \ + aplogo BIN = sys1 sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys \ moon graphs draw datdrw fonts fonts1 fonts2 games macsym maint imlac \ _www_ hqm diff --git a/build/misc.tcl b/build/misc.tcl index 5ea80d20..8057c2dc 100644 --- a/build/misc.tcl +++ b/build/misc.tcl @@ -1160,6 +1160,13 @@ respond "*" ":plx143 /H/M/CL BIN,N CREF_SYSTEM,TYI,READ,EVAL,TURTLE,ZEND\r" respond "ASSSW=" "0\r" expect ":KILL" +# Apple II Logo +respond "*" ":cwd aplogo\r" +respond "*" ":cross\r" +respond "*" "logo,logo=logo\r" +respond "*" "\003" +respond "*" ":kill\r" + # TENTH, toy Forth for KS10. respond "*" ":midas .; @ tenth_aap; tenth\r" expect ":KILL" diff --git a/doc/aplogo/apldoc.1 b/doc/aplogo/apldoc.1 new file mode 100644 index 00000000..6fe390f2 --- /dev/null +++ b/doc/aplogo/apldoc.1 @@ -0,0 +1,790 @@ +New documentation for Apple Logo: + +Switches and modes and who uses them: + +DEFFLG Defining a Ufun if nonzero. Set by TO when it + is called from an eval-buffer. When set, the + EVLBUF loop conses lines onto the procedure + definition DEFATM, unless the first token in + the line is END. Reset by EXTDEF and REINIT. + +DEFATM Atom (name) of Ufun currently being defined. Reset to nil by EXTDEF. + Set by DEFSTP (called by TO). TO links DEFBOD to DEFATM, END tries + to create a packed body and link it to DEFATM. + +DEFBOD Body of Ufun currently being defined. Reset to nil by EXTDEF, REINIT. + EDLINE appends ufun lines onto it. TO inits it to the arglist and links + it to the DEFATM. END calls STUFF to try and create a packed body from + it. + +OTPFLG Type-outer-quotes if nonzero. Set during print-to-buffer mode, + and elsewhere. TYPE prints outer funny-pname quotes if set. + PONAME uses MAKE in place of IS if set. Reset by RSTIO, RSTIO1. + +INPFLG Indicates eval-buffer mode if nonzero. POPLST won't print anything + if set; EVLBUF exits eval-buffer mode if reset. EDDONE, SREAD set + it. Various graphics and filing commands and END check it. + +PRSFLG Indicates that the parser is running if nonzero. Used to lift node + allocation limit. Parser sets and resets it when done; RSTIO, RSTIO1 + reset it. REQUEST sets it negative before calling the parser, so the + parser will parse input as a list. + +Sort-of-shared variables: + +ERRRET Error handler routine address. Set to default by REINIT, and ERROR + (which dispatches from prior setting). GARCOL sets to GCLERR at start, + then resets to ERROR1 when done. + +ERRY (Really ANSN3) Error code temporary, used between ERROR and ERROR1, + so any ERRRET routines shouldn't bash it. + +YSAV1 Very low-level temporary. Here's who uses it: + CRUNP, CRUNP1, EDOUT, COUT (all for Y-reg temp.), HLINE + (dot counter). + +PLINE Index into parse-string. Used by the parser, PARSEL, EDIN (to set + the point to the next line), GETLN. + +How to add new primitives: + +Index entry +Primitive-table entry +Primitive address entry + +How to add new error messages: + +Index entry +Message-table entry +Message text entry + +Subroutines which hack flags: + +RSTIO Resets INPFLG, OTPFLG, I/O device drivers, PRSFLG. + Called by: + EVLBUF (when finished evalling buffer) + REINIT + SYSBUG, DERROR, ERROR + All Filing commands + SETUP (monitor re-entry) + GTPRV (line editor previous-line function) + +RSTIO1 Resets OTPFLG, I/O device drivers, PRSFLG. + Called by: + PARSEL (parse a list, for RUN, REPEAT, and DEFINE). + +EXTDEF Resets OTPFLG, DEFBOD, DEFATM. + Called by: + ERROR (except for XBRK) + END + +Graphics structure (shared variables, etc.) + +I/O Structure (Drivers, interfaces, etc.) + +Special variable usage: + +MARK1: Parser + PTFTXT + UNSTUF + CNSPDL + LPUT, LIST, SE, DEFINE, TEXT, TO, TS + +MARK2: UNSTUF + WORD, LPUT, LIST, SE + +MARK3: WORD, LPUT, SE + +MARK4: WORD + +NARG1: Parser + Number-parsing + Number-typing + Arithmetic + Number-passing + Numerical conversions + Arithmetic primitives + +NARG2: Number-parsing + Number-typing + Arithmetic + Number-passing + Numerical conversions + Arithmetic primitives + +NARGX: Number-parsing + Arctangent routine + +A1L: Editor, Infix operations, Number-parsing +A2L: Editor, Infix operations +A3L: Editor, Infix operations +A4L: Editor, Infix operations +A5L: Graphics + +Changes to make: + +WORD should use MARK1-3 instead of MARK2-4 +Graphics/editor/music-only vars can use same p.z. locations + (XSCR would be a real p.z. variable, then) + + Old doc: + +Reference Documentation for Apple-Logo Interpreter Source Code + +Written by Stephen L. Hain, Patrick G. Sobalvarro, and Leigh L. Klotz +Massachusetts Institute of Technology + + (Program structure developed by + the M.I.T. Logo Group) + + + +List of Subroutines for Apple Logo interpreter: + +DSPTYP Type in A, table in XY; dispatches off of type and table +EDLINE Add line ILINE to current procedure definition +MKSFUN Make system function entry A with pointer X + +POPFRM Pops a frame, restoring bindings +RSTBND Restores bindings of procedure from PDL + +PUSHP Push X on PDL +PUSH Push value/pointer XY on PDL +PUSHB Push byte A on PDL +VPUSH Push value/pointer XY on the VPDL +VPUSHP Push X on the VPDL +POP Pop X from PDL, don't change X +VPOP Pop X from the VPDL, don't change X +POPB Pop A from VPDL +STKTS1 Tests for stack collision, if so error +TSTPOL Tests for stack collision, if so error, else polls (POLL) +POLL Polls for interrupts/buffer characters (except Pause) +POLLZ Polls for interrupts/buffer characters, including Pause + +GETVAL Get value from atom Y into X +PUTVAL Put value X in binding Y +GETFUN Get function A (NIL if not found) from object X, returning type in Y +GETCFN GETFUN(FUNCT,CURTOK) +GTCFN1 GETFUN(FUNCT,(X)) +GETPRC Get precedence in A of function X +GETNGS Get number of args in A of function X +INFIXP Return Carry Set if FUNCT infix, with index in A +PTFTXT Put function text with text Y, atom X, and no. args A +UNFUNC Delete function X +UNFNC1 UNFUNC(ARG1) +ERNAMS Erase all value bindings. +ERPROS Erase all ufuns. + +CONS Get new node pointer ANSN, with car Y, cdr X, and type A +PUTTYP Put type A in node X +GETTYP Get type of node X in A +TYPACS Return the type of node TEMPNH (from the typebase, i.e. no Q,D,LATOMs) +GETWDS Gets a pointer to a block of Y contiguous words in X (NIL if none) + +GETULN Get uline X (NIL if comments) from body Y +GETALN GETULN(ARGLST,FBODY) +ULNADV Advance function line X +GLNADV ULNADV(GOPTR) + +GTNXTK Get NEXTOK from TOKPTR +TTKADV Advance token pointer X (NIL if comments) +TOKADV TTKADV(TOKPTR) +TFKADV Advance token pointer X +SKPPTH Skips past a token or parenthesized expression +EXIFSC Skip an IF clause, returning with next token in X + +DEFSTP Checks mode and argument token (error if not OK) for procedure definition +EXTDEF Cleans up from edit mode + +STUFF Associates function body X with atom A +UNSTUF Unstuff Body of function X into Y + +INTERN Intern string X, returning atom Y +INTRNX Intern string X (known to be unique), returning atom Y + +GETLEN Get number of elements of list Y in X +GTLSTC Get last element of list X in X + +PRTSTR Print string pointed to by XY +LTYPE Type X, with A zero if toplevel brackets to be typed (for lists) +TYPATM Types an atom for LTYPE +TPSATM Types an Satom for LTYPE +TYPFIX Type 2-byte fixnum X +TPBFIX Type 4-byte fixnum NARG1 +TYPFLO Type flonum NARG1 +PRTPDL Type the string on the PDL of length ANSN1 +PONAMS Print out names +PONAME Print out name for PONAMS +POFUNS Print out procedures, titles only if A zero +POFUN Print out function A, title only if X zero +POFUNX Print out function A, title only if FULL zero + +LODNUM Loads number pointed to by X into address X +GETNUM Gets number and type A from X, returning Carry Clear if successful. +GTNUM1 Gets number and type A from NARG1, returning Carry Clear if successful. +GTNUM2 Gets number and type A from ARGSAV into NARG2, Carry clear if successful. +GTNM2X Gets number and type A from NARG2, returning Carry Clear if successful. +GT1NUM Gets a number NARG1 from the VPDL, else error, returns Carry Set if flonum +GT1NMX Gets a number from NARG1, else error, returns Carry Set if flonum +GT2NUM Gets two numbers NARG1 and NARG2 from VPDL, else error, coercing to real + if not both integers, returns Carry Set if flonums +GT1FIX Gets an integer NARG1 from the VPDL, else error +GT2FIX Gets two integers NARG1, NARG2 from the VPDL, else error +CHKINT Returns Carry Set if integer X is larger than two bytes; sign of A is sign of no. +CHKPBN Returns Carry clear if integer is two bytes max. and positive, else carry set +CHKPIN Returns Carry clear if integer is one byte max. and positive, else carry set +ATMTNM Get number NARG1 from X +ATMTNX Get number NARG1 from ANSN1 +GOBDIG Processes the next character for ATMTNM/NX. +GTBOOL Checks if X is boolean, error if not, returns Y zero if TRUE +MAKPNM Get pname Y from X +GETPNM Get pname Y from atom X +CNSPDL Makes String from PDL, given length ANSN1 and pointer in A +CNSPD1 Makes String from PDL, given length ANSN1 and pointer on proc. stack (so JMP to only) + +CVFIX Converts four-byte fixnum NARG1 to characters on PDL +CVFIXX Used by CVFLO to get the exponent (like CVFIX) +CVBFIX Converts two-byte fixnum X to characters on PDL +CVFLO Converts flonum NARG1 to characters on PDL +GTDECH Gets the next decimal digit for CVFLO +GETINT Gets the next digit for GTDECH, CVFLO + +OTFXS1 Output two-byte fixnum NARG1 to VPDL +OTPFXS Output two-byte fixnum Y to VPDL +OTPFL1 Output flonum NARG1 to VPDL +OTPFX1 Output fixnum NARG1 to VPDL +OTPFLO Output flonum Y to VPDL +OTPFIX Output fixnum Y to VPDL + +IMULT Multiply fixnums NARG1 and NARG2 (bashed), result in TEMPN,1, sets carry if overflow +IDIVID Divide fixnum NARG1 by fixnum NARG2, result in NARG1 +XDIVID Divide pos. fix. NARG1 by pos. fix. NARG2, res. in NARG1, rem. in NARG2, A (low byte) +OTPRG1 Output ARG1 to the PDL + +PTRXOK Makes X suitable for ERROR (which should be called immediately) +PTRYOK Makes Y suitable for ERROR (which should be called immediately) +ERROR Error break of type A with optional args Y (first) and X (second) +SYSBUG System Bug error, breaks to monitor, calling point in $00,$01 + +GARCOL Does a garbage-collect +CLRMRK Clear all the mark bits in from Nodespace +MARKA Mark contiguous area of size X pointed to by Y +MARK Mark node X +MARKX Mark node TEMPN +SWAPT1 Swaps temporaries out for GARCOL +SWAPT2 Swaps temporaries in for GARCOL + +GETLIN Read a line into the LINARY and set PLINE +PGTLIN Type the prompt in A, read a line into the LINARY and set PLINE +PARSTR Parse a line starting at Y, with list pointer X, Y nonzero if error +PRSLIN Parse a line starting at PLINE, with list pointer X, Y nonzero if error +ALLSTC Allocates a new list cell for the parser +POPLST Pops and discards the pushed list pointers for the parser +SELFDL Returns Carry Set if A (returned same) is self-delimiter +PARSEL Dump and reparse the list ARG1 to TOKPTR + +Number utility routines: + +CNUML0 Initializes pname-to-number processing +CNUML1 Processes a new digit A of a pname-to-number, returns Carry clear if illegal +CNUML2 Finishes processing a pname-to-number, returns Carry clear if overflow +XN1TOY Transfer NARG1 to Y. +XYTON1 Transfer Y to NARG1. +XN2TOY Transfer NARG2 to Y. +XYTON2 Transfer Y to NARG2. +DIGITP Returns Carry Set if A is a digit +NMROL1 Multiply NARG1 by 2. +NMROR1 Divide NARG1 by 2. +MULN10 Multiply flonum NARG1 by 10. +FDVD10 Divide flonum NARG1 by 10. +XDVDX Divide fixnum NARG1 by A. +ADDDIG Add ascii digit A to fixnum NARG1. +FADDIG Add ascii digit A to flonum NARG1, breaks out with Carry Clear if overflow. +FADDGX Add ascii digit A to flonum NARG1, returns Carry Set if overflow. +FADDGN Add numerical decimal (<1) digit A to flonum NARG1. +ADDNUM Add fixnum A1L to fixnum NARG1. +INCEXP Process an exponent character A. + +Floating-point Arithmetic routines: +FLOTN1 Make integer NARG1 floating-point. +FLOTN2 Make integer NARG2 floating-point. +XFLOAT Make positive integer NARG1 floating-point. +INTN1 Make flonum NARG1 a fixnum, don't round +XINTN1 Round up positive flonum NARG1 to a fixnum. +RNDN1 Make flonum NARG1 a fixnum (rounds), error if overflow +RNDN2 Make flonum NARG2 a fixnum (rounds), error if overflow +SWAP Swap NARG1 and NARG2. +FADD Floating point add, NARG1 gets NARG1 + NARG2. +FSUB Floating point subtract, NARG1 gets NARG1 - NARG2 +FSUBX Floating point subtract, NARG1 gets NARG2 - NARG1. +FMUL Floating point multiply, NARG1 gets NARG1 * NARG2. +FDIV Floating point divide, NARG1 gets NARG1/NARG2. +FDIVX Floating point divide, NARG1 gets NARG2/NARG1. +XDIVID Integer divide, NARG1 gets NARG1/NARG2. +COMPL Complements fixnum X. +FCOMPL Complements flonum NARG1. + +Screen Editor/Filing routines: +CHGSTP Checks mode and argument for screen editor and dispatches to proper set-up + routine (error if not OK) CHGNON, CHGNEW, or CHGOLD. +CHGIN1 Initialize buffer-filling. +CHGIN2 Initialize screen and editor. +CHGIN3 Display buffer and call editor top-loop. +CHGOLD Starts screen editor with a procedure in the buffer. +CHGNEW Starts screen editor with TO definition line in buffer. +CHGNON Starts screen editor with an empty buffer. +INCPNT Increments the point +DECPNT Decrements the point +PNTBEG Sets the point to beginning of buffer +TOPSCR Sets cursor at top left of screen. +CHGLOP Top level screen editor loop. +EDOUT Set up to output character A to buffer. +EDSPBF Display page of buffer from point on. +EDDONE Evaluates edit buffer and returns to Logo. +CHGNYM Displays "Apple Logo Screen Editor" indicator. + +DOSSTP Initializes DOS and tells it to listen to our output. +STDERR Tells DOS that error-return routine is DERROR. +SAPOUT Tells DOS to listen to our output. +DOSEAT Internal DOS subroutine which initializes output-listening. +DERROR Gives appropriate filing error. +DTPATM Type atom ARG1 coded for DOS. +DPRLEN Type buffer length as DOS-coded hexadecimal digits. + +Temporary Variable Usage Table: + +Routines which use no temporary variables: + +CHKINT +COMPL +DIGITP +EXTDEF +GTNXTK +POLL +POLLZ +POP +POPB +PUSH +PUSHB +PUSHP +TSTPOL +TSTSTK +VPOP +VPUSH +VPUSHP +(All Monitor Routines) + +First-level Routines: + +GETLEN TNH TN +GETNGS TNH +GETPRC TNH +GETTYP TNH +GETULN TNH +GETVAL TNH +GTLSTC AN TNH +INFIXP TNH +PRTPDL CCOUNT +PRTSTR TNH +PUTTYP TNH +PUTVAL TNH +TFKADV TNH +TTKADV TNH +TYPACS TNH +ULNADV TNH +UNFUNC TNH + +Second-level Routines: + +CONS AN TNH + PUTTYP: TNH +DEFSTP RG1 + GETTYP: TNH + TTKADV: TNH +GETFUN AN TN + GETTYP: TNH +PUTFUN AN AN1 TNH + GETTYP: TNH + +Third-level Routines: + +CNSPDL: AN1 TN MK1 + CONS: AN TNH +CNSPD1: AN1 TN MK1 + CONS: AN TNH +EDLINE TN TN1 + CONS: AN TNH +UNSTUF AN1 TNH TN TN1 TN2 TN3 TN4 + GETTYP: TNH + PUTTYP: TNH + CONS: AN TNH + +Sixth-level Routines: + +GTBOOL AN1 TX1 + INTERN: AN AN1 AN2 TNH TN TN1 TN2 TN4 TN5 + +Seventh-level Routines: + +POFUN AN1 AN4 TN6 TN7 TN8 TX1 + GETFUN: AN TNH TN + PRTSTR: TNH + GETTYP: TNH + LTYPE: AN AN1 AN2 AN3 TNH TN TN1 TN4 TN5 NG1 NG2 A1L A2L MK1 +POFUNX AN1 AN4 TN6 TN7 TN8 TX1 + GETFUN: AN TNH TN + PRTSTR: TNH + GETTYP: TNH + LTYPE: AN AN1 AN2 AN3 TNH TN TN1 TN4 TN5 NG1 NG2 A1L A2L MK1 +PONAME TN7 + GETVAL: TNH + GETTYP: TNH + PRTSTR: TNH + LTYPE: AN AN1 AN2 AN3 TNH TN TN1 TN4 TN5 NG1 NG2 A1L A2L MK1 + +Eighth-level Routines: + +GETNUM AN1 TNH NG1 + GETTYP: TNH + ATMTNX: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 +GTNUM1 AN1 TNH NG1 + GETTYP: TNH + ATMTNX: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 +POFUNS AN4 TX2 + POFUNX: AN AN1 AN2 AN3 AN4 TNH TN TN1 TN4 TN5 TN6 TN7 TN8 TX1 NG1 NG2 A1L A2L MK1 +PONAMS TN6 TN8 + PONAME: AN AN1 AN2 AN3 TNH TN TN1 TN4 TN5 TN7 NG1 NG2 A1L A2L MK1 + +Ninth-level Routines: + +GTNUM2 TX1 NG2 A3L A4L + GETNUM: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 +GT1FIX GETNUM: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 + RNDN1: AN TNH TN NG1 NG2 +GT1NUM NG1 + GTNUM1: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 +GT1NMX GTNUM1: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 + +Tenth-level Routines: + +GT2FIX TX1 NG1 + RNDN1: AN TNH TN NG1 NG2 + RNDN2: AN TNH TN NG1 NG2 + GETNUM: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 + GTNUM2: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 +GT2NUM AN3 TX2 NG1 + FLOTN1: NG1 + FLOTN2: NG1 NG2 + GETNUM: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 + GTNUM2: AN AN1 AN2 TNH TN TN1 TN4 TN5 TN6high TX1low NG1 NG2 NGX A1L A2L MK1 + +Bottom-level Routines (not called as subroutines): + +AL2 ANSN +ARGLOP ANSN +EVAL TEMPN (GETVAL: ) +EVLINE TEMPN (GETTYP: ) (TTKADV: ) +EVWRAP ANSN2 (TTKADV: ) +INITLZ TEMPN (CLRMRK: ) +SBOTH ANSN1 (GTBOOL: ANSN) +SBTFST ANSN1* TEMPN* TEMPN1* TEMPN2* (CONS: ANSN) (GETTYP: ) (INTERN: ANSN ANSN1 ANSN2 TEMPN + TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) (MAKPNM: ANSN ANSN1 ANSN2 ANSN3 TEMPN TEMPN1 + TEMPN2 TEMPN3 TEMPN4) +SBTLST ANSN1* ANSN2* TEMPN* TEMPN1* TEMPN2* TEMPN5 (CONS: ANSN) (GETTYP: ) (INTERN: ANSN + ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) (MAKPNM: ANSN ANSN1 ANSN2 + ANSN3 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) +SDEFIN TN1 TN2 TN3 TN5 RG1 RG2 + GETTYP: TNH + CONS: AN TNH + UNFUNC: TNH + STUFF: AN AN1 AN2 AN3 AN4 TNH TN TN1 TN2 TN3 TN4 TN5 TN6 TN7 TN8 TX1 TX2 + INTERN: AN AN1 AN2 TNH TN TN1 TN2 TN4 TN5 +SDIF TEMPN1* (GT2NUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6) + (OTPNUM: ANSN TEMPN) +SDIVID ANSN* (GT2NUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 + TEMPN6) (OTPNUM: ANSN TEMPN) (XDIVID: TEMPN TEMPN1) +SEDIT TEMPN1* TEMPN5* TEMPX1 (DEFSTP: ) (GETFUN: ANSN TEMPN) (GETLEN: TEMPN) + (PTFTXT: ANSN ANSN1 ANSN2 ANSN3 ANSNX TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 + TEMPN7 TEMPN8) (UNSTUF: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) +SEITHR ANSN1 (GTBOOL: ANSN) +SELSE TEMPN2 (EXIFSC: ANSN ANSN1 TEMPN TEMPN1) +SEQUAL ANSN* ANSN1* TEMPN7 TEMPN8 (GETNUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 + TEMPN5 TEMPN6) (GETTYP: ) +SFIRST TEMPN5* TEMPN6 (CONS: ANSN) (GETTYP: ) (INTERN: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 + TEMPN3 TEMPN4 TEMPN5) (MAKPNM: ANSN ANSN1 ANSN2 ANSN3 TEMPN TEMPN1 TEMPN2 TEMPN3 + TEMPN4) +SGO TEMPN TEMPN1 (GETTYP: ) (GTTULN: ) (PUTTYP: ) (TTKADV: ) (ULNADV: ) +SLAST TEMPN* (CONS: ANSN) (GETTYP: ) (GTLSTC: ANSN) (INTERN: ANSN ANSN1 ANSN2 TEMPN TEMPN1 + TEMPN2 TEMPN3 TEMPN4 TEMPN5) (MAKPNM: ANSN ANSN1 ANSN2 ANSN3 TEMPN TEMPN1 TEMPN2 + TEMPN3 TEMPN4) +SLPUT TEMPN TEMPN1 TEMPN2 (CONS: ANSN) (GETTYP: ) +SNODES TEMPN1 (OTPNUM: ANSN TEMPN) +SPO TEMPN1* (GETFUN: ANSN TEMPN) (GETTYP: ) (POFUNS: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 + TEMPN3 TEMPN4 TEMPN5 TEMPN6 TEMPN7 TEMPN8 TEX1 TEMPX2) (PONAMS: ANSN TEMPN TEMPN1 + TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 TEMPN7 TEMPN8) (POTEXT: ANSN ANSN1 ANSN2 TEMPN + TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 TEMPN7 TEMPN8 TEMPX1) (TTKADV: ) +SPROD ANSN* TEMPN1* (GT2NUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 + TEMPN5 TEMPN6) (OTPNUM: ANSN TEMPN) +SREAD1 TEMPN (GETTYP: ) +SSUM TEMPN1* (GT2NUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6) + (OTPNUM: ANSN TEMPN) +STEXT TEMPN1* TEMPN2* TEMPN5 TEMPN6 (CONS: ANSN) (GETFUN: ANSN TEMPN) (GETTYP: ) + (UNSTUF: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) +STITLE ANSN1* TEMPN* TEMPN1 TEMPN2 TEMPN3 (GETFUN: ANSN TEMPN) (GETTYP: ) (PUTFUN: ANSN ANSN1) + (UNFUNC: ANSN) +STO TEMPX1 TEMPX2 (CONS: ANSN) (EDTSTP: ) (EXTEDT: ) (GETFUN: ANSN TEMPN) (GETTYP: ) + (PTFTXT: ANSN ANSN1 ANSN2 ANSN3 ANSNX TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 + TEMPN7 TEMPN8) (TFKADV: ) +STRCBK ANSN1 TEMPN6 TEMPN7 TEMPN8 TEMPX1 TEMPX2 + (LTYPE: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) +SWORD ANSNX TEMPN6 (CONCAT: ANSN ANSN1 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) + (COPY: ANSN1 TEMPN TEMPN1 TEMPN2 (CONS: ANSN)) + (CONCAT: ANSN1* TEMPN* TEMPN1* TEMPN3 TEMPN4 TEMPN5 (GTLSTC: ANSN) + (COPY: ANSN ANSN1 TEMPN TEMPN1 TEMPN2)) + (INTERN: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) + (MAKPNM: ANSN ANSN1 ANSN2 ANSN3 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) +TOPLOP TEMPN (GETTYP: ) +XSFNCL TEMPN +XTAIL TEMPN2 TEMPN3 TEMPN4 TEMPN5 (GETVAL: ) (GTTULN: ) (INCVSP:) (PTRDEC: TEMPN5) + (INCVSP: ) + (PTRDEC: TEMPN5) + (PTVTST: TEMPN5) + (STPTR1: TEMPN5) + (PTVTST: TEMPN5) (PUTVAL: ) (STPTR1: TEMPN5) (TTKADV: ) +XUFNCL TEMPN TEMPN1 TEMPN2 TEMPN5 (GETVAL: ) (GETTYP: ) (GTTULN: ) (INCVSP:) + (PTRDEC: TEMPN5) (PTVTST: TEMPN5) (PUTVAL: ) + (STPTR1: TEMPN5) (TTKADV: ) +GARCOL ANSN1 TEMPN* TEMPN3 TEMPN4 (CLRMRK: ) (MARK: ANSN TEMPN TEMPN1 TEMPN2) (MARKA: TEMPN) + (TYPACS: ) (MARKX: ANSN TEMPN TEMPN1 TEMPN2) +MARK ANSN TEMPN TEMPN1 TEMPN2 (TYPACS: ) +MARKX " +MARKA TEMPN (TYPACS: ) +CLRMRK TNH +SOBST1 TEMPN (PUTTYP: ) +REINIT ANSN* ANSN2* ANSN3 TEMPN* TEMPN1* TEMPN2* TEMPN3 (CONS: ANSN) + (INTRNX: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2) (MKSFUN: ANSN TEMPN1) (SOBST1: TEMPN) + (MKSFUN: TEMPN1 (CONS: ANSN)) + (SOBST1: TEMPN) + +Parser: + +ALLSTC TN TX2 MK1 +POPLST TN1 TN8 +SELFDL AN3 TN4high TN7high TN8 +GETLIN AN3 AN4 TN TN1 TN2 TN4high TN5 TN6 TN7high TN8 TX1 TX2 MK1 + POPLST: TN1 TN8 + ALLSTC: TN TX2 MK1 + SELFDL: AN3 TN4high TN7high TN8 + CONS: AN TNH + PRTSTR: TNH + CNUML0: TN5 TN6high TX1low NG1 + CNUML1: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + CNUML2: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + INTERN: AN AN1 AN2 TNH TN TN1 TN2 TN4 TN5 + PUTTYP: TNH +PARSTR AN3 AN4 TN TN1 TN2 TN4high TN5 TN6 TN7high TN8 TX1 TX2 MK1 + POPLST: TN1 TN8 + ALLSTC: TN TX2 MK1 + SELFDL: AN3 TN4high TN7high TN8 + CONS: AN TNH + PRTSTR: TNH + CNUML0: TN5 TN6high TX1low NG1 + CNUML1: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + CNUML2: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + INTERN: AN AN1 AN2 TNH TN TN1 TN2 TN4 TN5 + PUTTYP: TNH +PGTLIN AN3 AN4 TN TN1 TN2 TN4high TN5 TN6 TN7high TN8 TX1 TX2 MK1 + POPLST: TN1 TN8 + ALLSTC: TN TX2 MK1 + SELFDL: AN3 TN4high TN7high TN8 + CONS: AN TNH + PRTSTR: TNH + CNUML0: TN5 TN6high TX1low NG1 + CNUML1: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + CNUML2: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + INTERN: AN AN1 AN2 TNH TN TN1 TN2 TN4 TN5 + PUTTYP: TNH +PRSLIN AN3 AN4 TN TN1 TN2 TN4high TN5 TN6 TN7high TN8 TX1 TX2 MK1 + POPLST: TN1 TN8 + ALLSTC: TN TX2 MK1 + SELFDL: AN3 TN4high TN7high TN8 + CONS: AN TNH + PRTSTR: TNH + CNUML0: TN5 TN6high TX1low NG1 + CNUML1: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + CNUML2: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + INTERN: AN AN1 AN2 TNH TN TN1 TN2 TN4 TN5 + PUTTYP: TNH + +Number-parsing routines: + +SWAP NG1 NG2 +MULN10 NG2 + FMUL: AN TNH TN NG1 NG2 +FDVD10: NG2 + FDIV: AN TNH TN NG1 NG2 +FADDGN NG1 NG2 NGX A1L A2L + MULN10: AN TNH TN NG1 NG2 + FLOTN2: NG1 NG2 + FDIVX: AN TNH TN NG1 NG2 +FADDGX NG2 + FLOTN2: NG1 NG2 + FADD: AN TNH TN NG1 NG2 +FADDIG FADDGX: AN TNH TN NG1 NG2 +CNUML0 TN5 TN6high TX1low NG1 +CNUML2 TN5 TN6high TX1low NG1 NGX A1L A2L + MULN10: AN TNH TN NG1 NG2 + FDIVX: AN TNH TN NG1 NG2 + FMUL: AN TNH TN NG1 NG2 +CNUML1 TN5 TN6high TX1low A1L A2L + NMROL1: NG1 + ADDNUM: NG1 A1L A2L + ADDDIG: NG1 + NMROR1: NG1 + FLOTN1: NG1 + MULN10: AN TNH TN NG1 NG2 + FADDIG: AN TNH TN NG1 NG2 + FADDGN: AN TNH TN NG1 NG2 NGX A1L A2L + INCEXP: TX1low + FMDC1: NGX + +Arithmetic routines: + +XDIVID TN TN1 NG1 NG2 A1L A2L +XDVDX TN TN1 NG1 NG2 A1L A2L +FADD1 AN TNH TN NG1 NG2 +FCOMPL NG1 +FDIVD AN TNH TN NG1 NG2 +FMULT AN TNH TN NG1 NG2 +FSUB1 AN TNH TN NG1 NG2 +FADD FADD1: AN TNH TN NG1 NG2 +FDIV SWAP: NG1 NG2 + FDIVD: AN TNH TN NG1 NG2 +FDIVX FDIVD: AN TNH TN NG1 NG2 +FLOTN1 NG1 + FCOMPL: NG1 +FLOTN2 SWAP: NG1 NG2 + FLOTN1: NG1 +FMUL FMULT: AN TNH TN NG1 NG2 +FSUB SWAP: NG1 NG2 + FSUB1: AN TNH TN NG1 NG2 +FSUBX FSUB1: AN TNH TN NG1 NG2 +INTN1 AN NG1 + FCOMPL: NG1 +XINTN1 NG2 + FADD: AN TNH TN NG1 NG2 + INTN1: AN NG1 +RNDN1 NG1 + FCOMPL: NG1 + XINTN1: AN TNH TN NG1 NG2 +RNDN2 SWAP: NG1 NG2 + RNDN1: AN TNH TN NG1 NG2 + +Stuffing routines: + +GETWDS AN AN1 AN2 TNH TN TN1 TN2 TN3 TN4 +PTFTXT AN3 AN4 TNH TN5 TN6 TN7 TN8 + GETTYP: TNH + GETWDS: AN AN1 AN2 TNH TN TN1 TN2 TN3 TN4 + PUTTYP: TNH +STUFF AN3 AN4 TNH TN TN1 TN3 TN5 TN6 TN7 TX1 TX2 + GETLEN: TNH TN + GETWDS: AN AN1 AN2 TNH TN TN1 TN2 TN3 TN4 + PUTTYP: TNH + PTFTXT: AN AN1 AN2 AN3 AN4 TNH TN TN1 TN2 TN3 TN4 TN5 TN6 TN7 TN8 + +Number-printing routines: + +CVFIX AN AN1 TN TN1 NG1 NG2 A1L A2L +CVFIXX AN AN1 TN TN1 NG1 NG2 A1L A2L +CVBFIX AN AN1 NG1 + XDVDX: TN TN1 NG1 NG2 A1L A2L +GETINT TN1 NG1 +GTDECH AN1 TN1 NG2 + FSUB: AN TNH TN NG1 NG2 + FLOTN2: NG1 NG2 + MULN10: AN TNH TN NG1 NG2 +CVFLO AN1 AN2 AN3 TN1 NG1 + FCOMPL: NG1 + FADD: AN TNH TN NG1 NG2 + MULN10: AN TNH TN NG1 NG2 + FDVD10: AN TNH TN NG1 NG2 + GETINT: TN1 NG1 + GTDECH: AN AN1 TNH TN TN1 NG1 NG2 + CVFIXX: AN AN1 TN TN1 NG1 NG2 A1L A2L +TPBFIX CVBFIX: AN AN1 TN TN1 NG1 NG2 A1L A2L + PRTPDL: AN1 +TYPFIX CVFIX: AN AN1 TN TN1 NG1 NG2 A1L A2L + PRTPDL: AN1 +TYPFLO CVFLO: AN AN1 AN2 AN3 TNH TN TN1 NG1 NG2 A1L A2L + PRTPDL: AN1 + +General typeout routines: + +TPSATM AN TN5 +TYPATM AN TNH TN5 + GETPNM: AN AN1 TNH TN TN1 MK1 +LTYPE TN4 TN5 NG1 + GETTYP: TNH + TYPATM: AN TNH TN TN1 TN5 MK1 + TPSATM: AN TN5 + TPBFIX: AN AN1 TN TN1 NG1 NG2 A1L A2L + TYPFLO: AN AN1 AN2 AN3 TNH TN TN1 NG1 NG2 A1L A2L + +Semi-dedicated primitive routines: + +ERNAMS TN TN1 TN2 + PUTVAL: TNH +ERPROS TN TN1 + UNFUNC: TNH + +Pname routines: + +GETPNM TNH TN TN1 + GETTYP: TNH + CONS: AN TNH + CNSPDL: AN AN1 TNH TN MK1 +MAKPNM AN1 AN2 TNH NG1 + GETTYP: TNH + GETPNM: AN AN1 TNH TN TN1 MK1 + CVBFIX: AN AN1 TN TN1 NG1 NG2 A1L A2L + CVFLO: AN AN1 AN2 AN3 TNH TN TN1 NG1 NG2 A1L A2L + CNSPD1: AN AN1 TNH TN MK1 + +Interning routines: + +INTRNX AN2 TN1 + CONS: AN TNH +INTERN AN1 AN2 TNH TN TN1 TN2 TN4 TN5 + CONS: AN TNH + GETPNM: AN AN1 TNH TN TN1 MK1 + INTRNX: AN2 TNH TN1 + +Frame-popping routines: + +RSTBND AN TN TN1 + PUTVAL: TNH +POPFRM RSTBND: AN TNH TN TN1 + +If-then routines: + +EXIFSC AN1 TN1 + TTKADV: TNH +SKPPTH AN TN + TTKADV: TNH + +Atom-to-number routines: + +GOBDIG CNUML1: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L +ATMTNM AN1 AN2 TN4 TN7 NG1 + FCOMPL: NG1 + GETPNM: AN AN1 TNH TN TN1 MK1 + CNUML0: TN5 TN6high TX1low NG1 + CNUML2: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + GOBDIG: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L +ATMTNX AN1 AN2 TN4 TN7 NG1 + FCOMPL: NG1 + GETPNM: AN AN1 TNH TN TN1 MK1 + CNUML0: TN5 TN6high TX1low NG1 + CNUML2: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L + GOBDIG: AN TNH TN TN5 TN6high TX1low NG1 NG2 NGX A1L A2L diff --git a/doc/aplogo/apple.help b/doc/aplogo/apple.help new file mode 100644 index 00000000..64608710 --- /dev/null +++ b/doc/aplogo/apple.help @@ -0,0 +1,14 @@ +LOGO BOOT DISK: + +1. Boot DOS 3.2.1 Master, as normally done +2. Enter monitor +3. do 9E42: 34 (Should print out 06) to tell DOS to do BRUN instead of RUN on boot. +4. do 3D0G (Enters BASIC) +5. Type in 1 END or somesuch dummy program. +6. Type INIT LOGO with any otpions desired (Volume, Drive, etc.). Do not type . +7. Put in blank disk that you want to be LOGO Boot disk. +8. Press to initialize new disk. +9. Do DELETE LOGO to delete BASIC dummy program. +10. Do BSAVE LOGO with specified adresses. + +Booting the Boot disk will now run LOGO automatically. diff --git a/doc/aplogo/doc.187 b/doc/aplogo/doc.187 new file mode 100644 index 00000000..a9f82203 --- /dev/null +++ b/doc/aplogo/doc.187 @@ -0,0 +1,510 @@ +Reference Documentation for Apple-Logo Assembly Code + +Written by Stephen L. Hain and Patrick G. Sobalvarro +Massachusetts Institute of Technology + + (Program structure developed by + the M.I.T. LOGO Group) + + + CORRECTIONS and ADDITIONS: + +BUGS: Garbage collection with recursive WORDs + Filing system w/numbers, end of file. + (SAVE gives I/O error w/out spinning disk) + (READ shouldn't clear screen) + Overly large integers crash (9999999999999 etc.) + Boolean args of SETT don't work. + +Fix unary minus parsing in lists. + +Put in a line-oriented editor, and make the toplevel editor a subsection. + (Line editor bugs: ^D, insert with multiple screen lines) + +Put in TTYP, XORMODE, pencolors. + +Fix turtle out-of-bounds conditioning. + +Put in OBLIST collection of garbage (no bindings, not pointed to). (??) + +Improve color graphics lines. + +Put in advanced arithmetic functions. + +Get rid of line numbers, period! (Except dummy numbers for CHANGE.) + (Get rid of line numbers in error messages) + +Make CARs, CDRs macros or subroutines. + + STORAGE and INDEX PARAMETERS: + +SYSTAB (Ptr. to first Systable entry) +ERRTBL (Ptr. to start of Error-table) +PRMTAB (Ptr. to first Primitive-table entry) +VPRMTB (Ptr. to first V-Primitive-table entry) +VPRMTE (Ptr. to byte after V-Primitive-table) + +Primitive-table format: 16 bytes/entry maximum, each terminated by a space + SFINDEX NARGS PREC L0 L1 L2 L3 L4 L5 L6 L7 L8 L9 L10 L11 + (Abbreviations use a separate entry) + +V-Primitive-table format: 3 bytes/entry + INDEX VARNAM INSTANCE (VARNAM is a pointer to the Variable pointer) + +Error-table format: + $FF terminates + $00 indicates "LTYPE ()" + $01 indicates "LTYPE ()" + Anything else is printed as an Ascii character + +Type-table Format: + 1 Node per byte: + Bits 0-6: Type code + Bits 7: Mark bit (assumed 0 before and after G.C.) + +Argument passing table for APPLE LOGO: + +(X,Y or A indicates that the page zero address of the argument is in + that register. XY indicates that registers X and Y hold a sixteen + bit address. "vN" indicates that register N holds an absolute + value, "vXY" indicates that registers X and Y hold a sixteen bit + absolute value. "vMMM" indicates that the variable MMM holds the + value, while "MMM" indicates that the variable MMM holds a pointer + to the value. For input-output designations of parameters, see the PLOGO + listing. Sixteen-bit values stored in XY have low-byte in X, high-byte + in Y.) + + +CHKLNN Returns typecode of TOKPTR +EDLINE Add line X to current procedure definition, Y nonzero for default line number +MKSFUN Make system function entry vA with pointer X + +POPFRM Pops a frame, restoring bindings +RSTBND Restores bindings of procedure from PDL + +PUSHP Push X on PDL +PUSH Push value/pointer vXY on PDL +VPUSH Push value/pointer vXY on the VPDL +VPUSHP Push X on the VPDL +POP Pop X from PDL +VPOP Pop X from the VPDL +POPB Pop vA from VPDL +STKTS1 Tests for stack collision, if so error +STKTST Tests for stack collision, if so error, else polls for interrupts/buffer +STPPEK Polls for interrupts/buffer + +GETVAL Get value from atom Y into X +PUTVAL Put value X in binding Y +GETFUN Get function A (NIL if not found) from object X, returning type in vA +PUTFUN Put function Y in atom X +GETPRC Get precedence in vA of function X (if Sfun), given type vY +GETNGS Get number of args in vA of function X, given type vA +INFIXP Given type in vA and function in X, return Carry Set if infix, with index in vA +PTFTXT Put function text with text Y, atom X, and no. args A +UNFUNC Delete function X + +CONS Get new node pointer ANSN, with car Y, cdr X, and type vA +PUTTYP Put type vA in node X +GETTYP Get type of node X in vA +TYPACS Return the type of node TEMPNH (from the typebase, i.e. no Q,D,LATOMs) +PTSPNM Make atom X have a funny-pname +GETWDS Gets a pointer to a block of Y contiguous words in X (NIL if none) + +FNDLIN Gets line with number Y in A, with Carry Set if found +LINPEK Get line-number X from body Y +GTFULN Get uline X from body Y +GTTULN Get uline X (NIL if comments) from body Y +ULNADV Advance function line X + +TTKADV Advance token pointer X (NIL if comments) +TFKADV Advance token pointer X +SKPPTH Skips past a token or parenthesized expression +EXIFSC Skip an IF clause, returning with next token in X + +EDTSTP Checks mode and argument token (error if not OK) for procedure definition +EXTEDT Cleans up from edit mode + +STUFF Associates function body X with atom A +UNSTUF Unstuff Body Y of function X into text A + +INTERN Intern string X, returning atom Y +INTRNX Intern string X (known to be unique), returning atom Y + +GETLEN Get number of elements of list Y in X +GTLSTC Get last element of list X in X + +PRTSTR Print string pointed to by XY +LTYPE Type X, with vA zero if toplevel brackets to be typed (for lists) +TYPFIX Type 2-byte fixnum X +TPBFIX Type 4-byte fixnum NARG1 +TYPFLO Type flonum NARG1 +PRTPDL Type the string on the PDL of length vANSN1 +PONAMS Print out names +POFUNS Print out procedures, titles only if vA zero +POTEXT Print out function A, title only if vX zero +PTEXTX Print out function A, title only if ANSN2 zero + +GTNUM2 Gets number and type vA from NARG2, returning Carry Clear if successful. +GTNUM1 Gets number and type vA from NARG1, returning Carry Clear if successful. +GTNXTK Get NEXTOK from TOKPTR +GT1NUM Gets a number NARG1 from the VPDL, else error, returns Carry Set if flonum +GT1NMX Gets a number from NARG1, else error, returns Carry Set if flonum +GT2NUM Gets two numbers NARG1 and NARG2 from VPDL, else error, coercing to real + if not both integers, returns Carry Set if flonums +GT1FIX Gets an integer NARG1 from the VPDL, else error +GT2FIX Gets two integers NARG1, NARG2 from the VPDL, else error +CHKINT Returns Carry Set if integer X is larger than two bytes +ATMTFX Get number NARG1 from X +ATMTXX Get number NARG1 from ANSN1 +GTBOOL Checks if X is boolean, error if not, returns vY zero if TRUE +MAKPNM Get pname Y from X +CNSPDL Makes String from PDL, given length vANSN1 and return pointer on Proc. stack +GETPNM Get pname Y from atom X +CVFIX Converts four-byte fixnum NARG1 to characters on PDL +CVBFIX Converts two-byte fixnum X to characters on PDL +CVFLO Converts flonum NARG1 to characters on PDL +OTPFX1 Output two-byte fixnum Y to VPDL +OTPFL1 Output flonum NARG1 to VPDL +OTPFLO Output flonum Y to VPDL +OTPFIX Output fixnum X to VPDL + +PTRXOK Makes X suitable for ERROR (which should be called immediately) +PTRYOK Makes Y suitable for ERROR (which should be called immediately) +ERROR Error break of type vA with optional args Y (first) and X (second) +ZAPMSG Types the error with code vANSN3 +SYSBUG System Bug error, breaks to monitor, calling point in $00,$01 + +GARCOL Does a garbage-collect +CLRMRK Clear all the mark bits in from Nodespace +MARKA Mark contiguous area of size X pointed to by Y +MARK Mark node X +MARKX Mark node TEMPN +SWAPT1 Swaps temporaries out for GARCOL +SWAPT2 Swaps temporaries in for GARCOL + +READLN Read and parse a line (no prompt) with pointer X, vY nonzero if error +PRDLIN Read and parse a line with pointer X, vY nonzero if error +DIGITP Returns Carry Set if vA is a digit +SLFDLP Returns Carry Set if vA (returned same) is self-delimiter; modifies char index vX + +Number utility routines: + +CNUML1 Parses a character vA of a number, returns Carry Clear if non-numeric. +CNUML2 Finishes parsing of a number, returns Carry Clear if non-numeric. +CLRNG1 Initializes parsing of a number. +XN1TOY Transfer NARG1 to Y. +XYTON1 Transfer Y to NARG1. +XN2TOY Transfer NARG2 to Y. +XYTON2 Transfer Y to NARG2. +NMROL1 Multiply NARG1 by 2. +NMROR1 Divide NARG1 by 2. +MULN10 Multiply flonum NARG1 by 10. +FDVD10 Divide flonum NARG1 by 10. +XDVD10 Divide fixnum NARG1 by 10. +ADDDIG Add ascii digit vA to fixnum NARG1. +FADDIG Add ascii digit vA to flonum NARG1, breaks out with Carry Clear if overflow. +FADDGX Add ascii digit vA to flonum NARG1, returns Carry Set if overflow. +FADDGN Add numerical decimal (<1) digit vA to flonum NARG1. +ADDNUM Add fixnum A1L to fixnum NARG1. +INCEXP Process an exponent character vA. + +Floating-point Arithmetic routines: +FLOTN1 Make integer NARG1 floating-point. +FLOTN2 Make integer NARG2 floating-point. +XFLOAT Make positive integer NARG1 floating-point. +XINT1 Make flonum NARG1 a fixnum, error if overflow +XINT2 Make flonum NARG2 a fixnum, error if overflow +SWAP Swap NARG1 and NARG2. +FADD Floating point add, NARG1 gets NARG1 + NARG2. +FSUB Floating point subtract, NARG1 gets NARG1 - NARG2 +FSUBX Floating point subtract, NARG1 gets NARG2 - NARG1. +FMUL Floating point multiply, NARG1 gets NARG1 * NARG2. +FDIV Floating point divide, NARG1 gets NARG1/NARG2. +XDIVID Integer divide, NARG1 gets NARG1/NARG2. +COMPL Complements fixnum X. +FCOMPL Complements flonum NARG1. + +Screen Editor/Filing routines: +CHGSTP Checks mode and argument for screen editor and dispatches to proper set-up + routine (error if not OK) CHGNON, CHGNEW, or CHGOLD. +CHGIN1 Initialize buffer-filling. +CHGIN2 Initialize screen and editor. +CHGIN3 Display buffer and call editor top-loop. +CHGOLD Starts screen editor with a procedure in the buffer. +CHGNEW Starts screen editor with TO definition line in buffer. +CHGNON Starts screen editor with an empty buffer. +INCPNT Increments the point +DECPNT Decrements the point +PNTBEG Sets the point to beginning of buffer +TOPSCR Sets cursor at top left of screen. +CHGLOP Top level screen editor loop. +EDOUT Set up to output character vA to buffer. +EDSPBF Display page of buffer from point on. +EDDONE Evaluates edit buffer and returns to Logo. +CHGNYM Displays "Apple Logo Screen Editor" indicator. + +DOSSTP Initializes DOS and tells it to listen to our output. +STDERR Tells DOS that error-return routine is DERROR. +SAPOUT Tells DOS to listen to our output. +DOSEAT Internal DOS subroutine which initializes output-listening. +DERROR Gives appropriate filing error. +DTPATM Type atom ARG1 coded for DOS. +DPRLEN Type buffer length as DOS-coded hexadecimal digits. + +Temporary Variable Usage Table: + + @ - indicates possible temporary-variable conflict + * - indicates apparent but nonexistent conflict + TEMPNH is the lowest-level temporary; there are no TEMPNH conflicts + GARCOL swaps temporary variables; there are no conflicts with GARCOL + () indicates dedicated subroutines; no temporary variable optimizations + +First Level Routines: + +BREAK1 +CLRMRK +COMPL +DELETE ANSN TEMPN TEMPN1 +DIGITP +EXTEDT +FNDLIN ANSN ANSN1 TEMPN TEMPN1 +GETLEN TEMPN +GETNGS +GETPRC +GETVAL +GTFULN +GTLSTC ANSN +GTNXTK +INFIXP +LINPEK +POP +POPB +PTSPNM TEMPN +PUSH +PUSHP +PUTVAL +RESETT +STPPEK +TFKADV +TPCHR +TYPACS +XDIVID TEMPN TEMPN1 +ULNADV +UNFUNC ANSN +VPOP +VPSTST +VPUSH +VPUSHP + +Second-level Routines: + +BREAK (BREAK1: ) +ERNAMS TEMPN TEMPN1 TEMPN2 (PUTVAL: ) +ERPROS TEMPN TEMPN1 (UNFUNC: ANSN) +GETTYP (TYPACS: ) + + (GW1: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) + +GETWDS ANSN* ANSN1* (GARCOL: ) (GW1: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) +GTBOOL ANSN (VPOP: ) +GTTULN (GTFULN: ) +MARK ANSN TEMPN TEMPN1 TEMPN2 (POP: ) (PSHTST: ) (PUSH: ) (TYPACS: ) +MARKX " +MARKA TEMPN (TYPACS: ) +OTPRG1 (VPUSHP: ) +PRTSTR (TPCHR: ) +PSHTST (STPPEK: ) +PUTTYP (TYPACS: ) +RSTBND ANSN TEMPN TEMPN1 (POP: ) (PUTVAL: ) +SOBST1 TEMPN (PUTTYP: ) +TTKADV (TFKADV: ) +TYPNUM ANSN TEMPN2 (POPB: ) (PUSH: ) (TPCHR: ) (XDIVID: TEMPN TEMPN1) +VPLFLS (VPUSHP: ) +VPLTRU (VPUSHP: ) +ZAPMSG ANSN3 (BREAK1: ) (PRTSTR: ) +ZPC1 (BREAK1: ) (PRTSTR: ) + +Third-level Routines: + +CONS ANSN (GARCOL: ) (PUTTYP: ) (VPUSHP: ) +EDTSTP (GETTYP: ) (TFKADV: ) +GARCOL ANSN1 TEMPN* TEMPN3 TEMPN4 (CLRMRK: ) (MARK: ANSN TEMPN TEMPN1 TEMPN2) (MARKA: TEMPN) + (TYPACS: ) (MARKX: ANSN TEMPN TEMPN1 TEMPN2) +GETFUN ANSN TEMPN (GETTYP: ) +POPFRM (POP: ) (POPB: ) (RSTBND: ANSN TEMPN TEMPN1) +PTFTXT ANSN3 ANSNX TEMPN5 TEMPN6 TEMPN7 TEMPN8 (GETTYP: ) + (GETWDS: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) (PUTTYP: ) +PUTFUN ANSN ANSN1 (GETTYP: ) +SKPPTH ANSN TEMPN (TTKADV: ) + +Fourth-level Routines: + +EXIFSC ANSN1 TEMPN1 (SKPPTH: ANSN TEMPN) (TTKADV: ) +GETPNM TEMPN TEMPN1 TEMPN2 TEMPN3 (CONS: ANSN) (GETTYP: ) (POP: ) (PSHTST: ) (PUSH: ) +INTRNX ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 (CONS: ANSN) +OTPNUM TEMPN (CONS: ANSN) (VPUSHP: ) +STUFF ANSN3* ANSNX* TEMPN* TEMPN1* TEMPN2* TEMPN3* TEMPN5* TEMPN6* TEMPN7* TEMPX1 TEMPX2 + (GETLEN: TEMPN) (GETWDS: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) + (PTFTXT: ANSN ANSN1 ANSN2 ANSN3 ANSNX TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 + TEMPN6 TEMPN7 TEMPN8) (PUTTYP: ) +PUTLIN ANSN2 TEMPN2 TEMPN3 (BREAK1: ) (CONS: ANSN) (FNDLIN: ANSN ANSN1 TEMPN TEMPN1) (ZPC1: ) +UNSTUF ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 (CONS: ANSN) (GETTYP: ) (POP: ) + (PSHTST: ) (PUSHP: ) (PUTTYP: ) + +Fifth-level Routines: + + (GOBDIG: TEMPN6) + +ATMTFX ANSN1 ANSN2 TEMPN4 TEMPN5 TEMPN6 (COMPL: ) (GETPNM: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3) + (GOBDIG: TEMPN6) +ATMTXX " +DEFUN ANSN1* ANSN2* TEMPN1* TEMPN2* TEMPN3* TEMPN4* (CONS: ANSN) (GETTYP: ) + (STUFF: ANSN ANSN1 ANSN2 ANSN3 ANSNX TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 + TEMPN6 TEMPN7 TEMPN8 TEMPX1 TEMPX2) (UNFUNC: ANSN) (VPOP: ) (VPUSHP: ) +EDLINE ANSN1* TEMPN2* TEMPN3* TEMPN4 (PUTLIN: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3) + (PUTTYP: ) +INTERN ANSN1 ANSN2 TEMPN1* TEMPN4 TEMPN5 (CONS: ANSN) + (GETPNM: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3) (VPUSHP: ) (VPOP: ) + + (MKPNAD: ANSN2 TEMPN3 TEMPN4 (CONS: ANSN)) + +MAKPNM ANSN* ANSN1 ANSN2 ANSN3 TEMPN2* TEMPN3* TEMPN4 (CONS: ANSN) + (GETPNM: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3) (GETTYP: ) + (MKPNAD: ANSN ANSN2 TEMPN3 TEMPN4) (VPOP: ) (VPUSHP: ) (XDIVID: TEMPN TEMPN1) + + (MKSFUN: TEMPN1 (CONS: ANSN)) + (SOBST1: TEMPN) + +REINIT ANSN* ANSN2* ANSN3 TEMPN* TEMPN1* TEMPN2* TEMPN3 (CONS: ANSN) + (INTRNX: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2) (MKSFUN: ANSN TEMPN1) (SOBST1: TEMPN) + +Sixth-level Routines: + +GETNUM ANSN1* (ATMTXX: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6) + (GETTYP: ) + + (TPSATM: ANSN TEMPN5 (TPCHR: )) + (TYPATM: ANSN* TEMPN5 (GETPNM: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3) (TPCHR: )) + +LTYPE TEMPN4 TEMPN5 (BREAK: ) (PSHTST: ) (POP: ) (PUSH: ) (PUSHP: ) (TPCHR: ) + (TPSATM: ANSN TEMPN5) (TYPATM: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN5) + (TYPNUM: ANSN TEMPN TEMPN1 TEMPN2) + + (ALLSTC: TEMPN TEMPX2 (CONS: ANSN)) + (DIGITP: ) + (GETLIN: ) + (SLFDLP: ANSN3 TEMPN4.H TEMPN8.L) + +PRDLIN ANSN3 ANSNX TEMPN1 TEMPN4.H TEMPN5 TEMPN6 TEMPN7 TEMPN8 TEMPX1 TEMPX2 + (ALLSTC: ANSN TEMPN TEMPX2) (BREAK1: ) (CONS: ANSN) (DIGITP: ) (GETLIN: ) + (INTERN: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) + (POP: ) (PRTSTR: ) (PTSPNM: TEMPN) (PUSH: ) (PUTTYP: ) + (SLFDLP: ANSN3 TEMPN4.H TEMPN8.L) (TPCHR: ) +READLN " + +Seventh-level Routines: + +ERROR ANSN1 ANSN2 ANSN3* TEMPN8 (BREAK1: ) (LTYPE: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 + TEMPN5) (PRTSTR: ) (TPCHR: ) (TYPNUM: ANSN TEMPN TEMPN1 TEMPN2) (ZAPMSG: ANSN3) +GT1NUM (GETNUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6) (VPOP: ) +GT2NUM ANSN3 (GETNUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6) + (VPOP: ) (XFLOAT) +POTEXT ANSN1 ANSN2 TEMPN6 TEMPN7 TEMPN8 TEMPX1 (BREAK1: ) (GETFUN: ANSN TEMPN) (GETTYP: ) + (LTYPE: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) + (PRTSTR: ) (TPCHR: ) (TYPNUM: ANSN TEMPN TEMPN1 TEMPN2) +PTEXTX " + +Eighth-level Routines: + +POFUNS ANSN2* TEMPX2 (PTEXTX: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 + TEMPN6 TEMPN7 TEMPN8 TEMPX1) + + (PON1: TEMPN6 TEMPN7 (BREAK1: ) (GETTYP: ) (GETVAL: ) + (LTYPE: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) (PRTSTR: ) (TPCHR: )) + +PONAMS TEMPN6 TEMPN8 (PON1: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 TEMPN7) + +Bottom-level Routines (not called as subroutines): + +AL2 ANSN (POP: ) (POPB: ) +ARGLOP ANSN (PUSH: ) (PUSHP: ) +EVAL TEMPN (GETVAL: ) +EVLINE TEMPN (GETTYP: ) (TTKADV: ) +EVWRAP ANSN2 (GTNXTK: ) (PUSH: ) (PUSHP: ) (TTKADV: ) +INITLZ TEMPN (CLRMRK: ) +POPJ (POP: ) +SBOTH ANSN1 (GTBOOL: ANSN) (VPLFLS: ) (VPLTRU: ) +SBTFST ANSN1* TEMPN* TEMPN1* TEMPN2* (CONS: ANSN) (GETTYP: ) (INTERN: ANSN ANSN1 ANSN2 TEMPN + TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) (MAKPNM: ANSN ANSN1 ANSN2 ANSN3 TEMPN TEMPN1 + TEMPN2 TEMPN3 TEMPN4) (OTPRG1: ) (VPOP: ) (VPUSHP: ) +SBTLST ANSN1* ANSN2* TEMPN* TEMPN1* TEMPN2* TEMPN5 (CONS: ANSN) (GETTYP: ) (INTERN: ANSN + ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) (MAKPNM: ANSN ANSN1 ANSN2 + ANSN3 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) (POPJ: ) (VPOP: ) (VPUSHP: ) +SDEFIN TEMPN* (DEFUN: ANSN ANSN1 ANSN2 ANSN3 ANSNX TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 + TEMPN6 TEMPN7 TEMPN8 TEMPX1 TEMPX2) (GETTYP: ) (VPOP: ) +SDIF TEMPN1* (GT2NUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6) + (OTPNUM: ANSN TEMPN) +SDIVID ANSN* (COMPL: ) (GT2NUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 + TEMPN6) (OTPNUM: ANSN TEMPN) (XDIVID: TEMPN TEMPN1) +SEDIT TEMPN1* TEMPN5* TEMPX1 (EDTSTP: ) (GETFUN: ANSN TEMPN) (GETLEN: TEMPN) + (PTFTXT: ANSN ANSN1 ANSN2 ANSN3 ANSNX TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 + TEMPN7 TEMPN8) (UNSTUF: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) +SEITHR ANSN1 (GTBOOL: ANSN) (VPLFLS: ) (VPLTRU: ) +SELSE TEMPN2 (EXIFSC: ANSN ANSN1 TEMPN TEMPN1) +SEQUAL ANSN* ANSN1* TEMPN7 TEMPN8 (GETNUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 + TEMPN5 TEMPN6) (GETTYP: ) (POP: ) (PSHTST: ) (PUSH: ) (PUSHP: ) (VPOP: ) (VPUSHP: ) +SFIRST TEMPN5* TEMPN6 (CONS: ANSN) (GETTYP: ) (INTERN: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 + TEMPN3 TEMPN4 TEMPN5) (MAKPNM: ANSN ANSN1 ANSN2 ANSN3 TEMPN TEMPN1 TEMPN2 TEMPN3 + TEMPN4) (OTPRG1: ) (VPOP: ) +SGO TEMPN TEMPN1 (GETTYP: ) (GTTULN: ) (PUTTYP: ) (STPPEK: ) (TTKADV: ) (ULNADV: ) (VPOP: ) +SLAST TEMPN* (CONS: ANSN) (GETTYP: ) (GTLSTC: ANSN) (INTERN: ANSN ANSN1 ANSN2 TEMPN TEMPN1 + TEMPN2 TEMPN3 TEMPN4 TEMPN5) (MAKPNM: ANSN ANSN1 ANSN2 ANSN3 TEMPN TEMPN1 TEMPN2 + TEMPN3 TEMPN4) (OTPRG1: ) (VPOP: ) +SLPUT TEMPN TEMPN1 TEMPN2 (CONS: ANSN) (GETTYP: ) (OTPRG1: ) (VPOP: ) (VPUSHP: ) +SNODES TEMPN1 (OTPNUM: ANSN TEMPN) +SPO TEMPN1* (GETFUN: ANSN TEMPN) (GETTYP: ) (POFUNS: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 + TEMPN3 TEMPN4 TEMPN5 TEMPN6 TEMPN7 TEMPN8 TEX1 TEMPX2) (PONAMS: ANSN TEMPN TEMPN1 + TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 TEMPN7 TEMPN8) (POTEXT: ANSN ANSN1 ANSN2 TEMPN + TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 TEMPN7 TEMPN8 TEMPX1) (TTKADV: ) +SPROD ANSN* TEMPN1* (COMPL: ) (GT2NUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 + TEMPN5 TEMPN6) (OTPNUM: ANSN TEMPN) +SREAD1 TEMPN (GETTYP: ) +SSUM TEMPN1* (GT2NUM: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6) + (OTPNUM: ANSN TEMPN) +STEXT TEMPN1* TEMPN2* TEMPN5 TEMPN6 (CONS: ANSN) (GETFUN: ANSN TEMPN) (GETTYP: ) + (UNSTUF: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) (VPOP: ) (VPUSHP: ) +STITLE ANSN1* TEMPN* TEMPN1 TEMPN2 TEMPN3 (GETFUN: ANSN TEMPN) (GETTYP: ) (PUTFUN: ANSN ANSN1) + (UNFUNC: ANSN) +STO TEMPX1 TEMPX2 (CONS: ANSN) (EDTSTP: ) (EXTEDT: ) (GETFUN: ANSN TEMPN) (GETTYP: ) + (PTFTXT: ANSN ANSN1 ANSN2 ANSN3 ANSNX TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5 TEMPN6 + TEMPN7 TEMPN8) (TFKADV: ) +STRCBK ANSN1 TEMPN6 TEMPN7 TEMPN8 TEMPX1 TEMPX2 (BREAK1: ) + (LTYPE: ANSN TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) (PRTSTR: ) (TPCHR: ) + + (COPY: ANSN1 TEMPN TEMPN1 TEMPN2 (CONS: ANSN) (VPOP: ) (VPUSHP: )) + (CONCAT: ANSN1* TEMPN* TEMPN1* TEMPN3 TEMPN4 TEMPN5 (GTLSTC: ANSN) + (COPY: ANSN ANSN1 TEMPN TEMPN1 TEMPN2)) + +SWORD ANSNX TEMPN6 (CONCAT: ANSN ANSN1 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) + (INTERN: ANSN ANSN1 ANSN2 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4 TEMPN5) + (MAKPNM: ANSN ANSN1 ANSN2 ANSN3 TEMPN TEMPN1 TEMPN2 TEMPN3 TEMPN4) (OTPRG1: ) + +TOPLOP TEMPN (GETTYP: ) +XSFNCL TEMPN + + (INCVSP: ) + (PTRDEC: TEMPN5) + (PTVTST: TEMPN5) + (STPTR1: TEMPN5) + +XTAIL TEMPN2 TEMPN3 TEMPN4 TEMPN5 (GETVAL: ) (GTTULN: ) (INCVSP:) (PTRDEC: TEMPN5) + (PTVTST: TEMPN5) (PUSH: ) (PUSHP: ) (PUTVAL: ) (STPTR1: TEMPN5) (TTKADV: ) +XUFNCL TEMPN TEMPN1 TEMPN2 TEMPN5 (GETVAL: ) (GETTYP: ) (GTTULN: ) (INCVSP:) (LINPEK: ) + (PSHTST: ) (PTRDEC: TEMPN5) (PTVTST: TEMPN5) (PUSH: ) (PUSHP: ) (PUTVAL: ) + (STPTR1: TEMPN5) (TTKADV: ) + +Other Routines (unwritten, etc.): + +XFLOAT +XINT +XFCOMP diff --git a/doc/aplogo/usage.doc b/doc/aplogo/usage.doc new file mode 100644 index 00000000..af2c3e4e --- /dev/null +++ b/doc/aplogo/usage.doc @@ -0,0 +1,186 @@ +APPLE LOGO Usage documentation: + +Arguments: + +{word} must evaluate to a (quoted) word or a number +{list} must evaluate to a list +{word/list} must evaluate to either a {word} or a {list} as defined above +{number} must evaluate to a number or a word which is a legal number +{boolean} must evaluate to "TRUE or "FALSE + +Categories: + +Quantifier Graphics Editor Screen Editor +Word/List Control System Workspace +Comment Input Output Boolean +Infix Boolean Filing Exit Arithmetic +Infix Arithmetic Prefix Arithmetic + +Command/Abbreviation/Inputs/Type: + +ALL Quantifier +BACK BK {number} Graphics +BOTH {boolean} {boolean} Boolean +BUTFIRST BF {word/list} Word/List +BUTLAST BL {word/list} Word/List +CHANGE CHG Editor + This is the original procedure editor. It gives the ">" prompt + and requires END to terminate. Commands such as PO and ER are + executed immediately, unless they are on numbered lines. +CLEAR Output + Clears the text screen and homes the input cursor. +CLEARINPUT Input + Clears the input character buffer. Useful for programs which use + real-time keyboard input. +CLEARSCREEN CS Graphics + Clears the graphics screen, homes and shows the turtle. Inititates + graphics mode if necessary (mixed text/graphics). +CONTINUE CO Control +CURSOR {number} {number} Output + Takes column, row as input and positions the input cursor there. + Columns are 0-39, rows are 0-23. +DEFINE DE {word} {list} Workspace +DELETE {word} Filing + Deletes a file from the disk. +DIFFERENCE {number} {number} Arithmetic +EDIT ED Screen Editor + Enters the screen editor with a given procedure. +EITHER {boolean} {boolean} Boolean +ELSE Control +EMPTY? {word/list} Boolean +END Editor +EQUAL? {word/list} {word/list} Boolean +ERASE ER Workspace +FIRST {word/list} Word/List +FORWARD FD {number} Graphics +FPUT Word/List +FULL Graphics + In graphics mode, gives full graphics screen. Complementary to MIX. + Equivalent to interrupt character Control-F. +GO {word} Control +GOODBYE Exit +GREATER? {number} {number} Boolean +HEADING Graphics +HIDETURTLE HT Graphics +HOME Graphics +IF Control +INTEGER INT {number} Arithmetic +LAST {word/list} Word/List +LEFT LT {number} Graphics +LESS? {number} {number} Boolean +LIST Variable number of {word/list}'s - 2 default Word/List +LIST? {word/list} Boolean +LPUT {word/list} {list} Word/List +MAKE {word} {word/list} Workspace +MIX Graphics + In graphics mode, gives mixed text/graphics screen. Complementary to + FULL. Equivalent to interrupt character Control-L. +NAMES Quantifier +NODISPLAY ND Graphics + Exits graphics mode, giving a clear text page with the cursor homed. +NOT {boolean} Boolean +NUMBER? {word/list} Boolean +OUTPUT OP {word/list} Control +PAUSE Control + Stops execution and allows input to be evaluated. Equivalent to interrupt + character Control-Z. Execution is resumed with CONTINUE, provided no errors + have occured. +PENDOWN PD Graphics +PENUP PU Graphics +POTS Workspace +PRINT PR Variable number of {word/list}'s - 1 default Output +PRINT1 Variable number of {word/list}'s - 1 default Output + Like PRINT, but does not terminate the output line. +PRINTOUT PO Workspace +PROCEDURES Quantifier +PRODUCT {number} {number} Arithmetic +QUOTIENT {number} {number} Arithmetic +RANDOM Arithmetic + Returns a random number 0-9. Identical seeds will give repeatable + sequences of random numbers. See RANDOMIZE. +RANDOMIZE Arithmetic + Randomizes the seed for RANDOM. The seed can also be initialized + in certain cases by depositing into the RNDL and RNDH memory locations. +READ {word} Filing + Reads a file from disk. See the Filing comments. Destroys any graphics + display. +READCHARACTER RC Input + Outputs the least recent character in the character buffer, or if empty, + waits for an input character. +REPEAT {number} {list} Control +REQUEST RQ Input +RETRIEVE Screen Editor + Re-enters the editor with the previous buffer's contents if they are still + retrievable (i.e., no graphics or filing has been done since the last + screen editor session, provided there was a previous one). Useful if + an error occurred while the contents of the edit buffer were being evaluated. +RIGHT RT {number} Graphics +RUN {list} Control +SAVE {word} Filing + Saves the contents of the workspace on disk. See the Filing comments. Destroys + any graphics display. +SENTENCE SE Variable number of {word/list}'s - 2 default Word/List +SETHEADING SETH {number} Graphics +SETTURTLE SETT {list} Graphics + Sets the turtle according to a variable-length list of elements. First + element is XCOR, then YCOR, then HEADING, then "TRUE or "FALSE for + show or hide turtle, then "TRUE or "FALSE for pen down or pen up. + Complementary to TURTLESTATE. +SETX {number} Graphics +SETXY {number} {number} Graphics +SETY {number} Graphics +SHOWTURTLE ST Graphics +STOP Control +SUM {number} {number} Arithmetic +TEXT {word} Workspace +THEN Control +THING {word} Workspace +THING? {word} Boolean +TITLE TI Editor +TITLES Quantifier +TO Screen Editor + Procedure definition primitive. Enters the Screen Editor. Destroys + any graphics display. +TRACEBACK TB Debugging +TURTLESTATE TS Graphics + Returns a list of five elements. First is XCOR, then YCOR, then HEADING, + then "TRUE or "FALSE for shown or hidden turtle, then "TRUE or "FALSE for + pen down or pen up. Complementary to SETTURTLE. +WORD Variable number of {word}'s - 2 default Word/List +WORD? {word/list} Boolean +XCOR Graphics +YCOR Graphics +( Syntax +) Syntax +* {number} * {number} Infix Arithmetic ++ {number} + {number} Infix Arithmetic + + {number} Prefix Arithmetic +- {number} - {number} Infix Arithmetic + - {number} Prefix Arithmetic +.BPT System + Breaks out of LOGO into the LOGO monitor. See the LOGO Monitor comments. + Control-B breaks from LOGO monitor into ROM Monitor, and then another + Control-B will enter BASIC. The RESET key should be pressed upon entering + BASIC after using LOGO, to reinitialize certain BASIC parameters. +.CALL {number} System + Calls a machine language subroutine anyplace in memory, which is expected + to do an RTS or a JMP to the POPJ label. +.DEPOSIT {number} {number} System + Deposits byte of data at a memory location. +.EXAMINE {number} System + Returns the value of the byte at the specified address. +.GCOLL System +.NODES System +/ {number} / {number} Infix Arithmetic +; Comment +< {number} < {number} Infix Boolean += {word/list} = {word/list} Infix Boolean +> {number} > {number} Infix Boolean + +Interrupt characters: + +Control-G Stops execution and returns control to toplevel. +Control-Z Stops execution and allows input to be evaluated (see PAUSE). +Control-S Stops screen output - typing any character will resume output. +Control-F In graphics mode, displays a full screen of graphics (see FULL). +Control-L In graphics mode, displays a mixed text/graphics screen (see MIX). diff --git a/doc/programs.md b/doc/programs.md index 16c89575..34186c53 100644 --- a/doc/programs.md +++ b/doc/programs.md @@ -13,6 +13,7 @@ - ADV350, 350-point Adventure. - ADV448, 448-point Adventure. - ANIMAL, an animal guessing game. +- APLOGO, Apple II Logo. - AR, PDP-11 debugger. - ARCCPY, copies an old-format archive, converting to new format. - ARCDEV, transparent file system access to archive files. diff --git a/src/aplogo/logo.958 b/src/aplogo/logo.958 new file mode 100644 index 00000000..ab2bad53 --- /dev/null +++ b/src/aplogo/logo.958 @@ -0,0 +1,13450 @@ +;-*-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 " +.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