;LISP.MAC, 9-Apr-81 21:51, Edit by FRICK
;
;NUMVAL redefined. It now gives error if given anything but INUM or FIXNUM.
;LISP.MAC, 26-Sep-80 10:44, Edit by FRICK
;
;%FSLID defined as support for PRELOAD facility.
;LISP.MAC, 25-Aug-80 12:06, Edit by FRICK
;
;Make ^Z comments work inside other comments.
;Corrected bug in initial dialogue. SYLO+1 is CAILE C,"z" instead
; of CAIG C,"z"
;<FRICK>LISP.MAC.28, 22-Nov-79 15:31:17, Edit by FRICK
;
;Define ERJMP for Tenex. Don't include RSCAN for Tenex.
;<FRICK>LISP.MAC.27, 21-Nov-79 11:21:50, Edit by FRICK
;
;Corrected bug in FUNARG. APFNG+6 is MOVN R,APFNG1 instead of HRRZ R,APFNG1.
;<FRICK>LISP.MAC.26, 13-Nov-79 19:48:53, Edit by FRICK
;
;Convert lower case to upper case on answer to start up questions
;<FRICK>LISP.MAC.24, 11-Nov-79 16:46:11, Edit by FRICK
;
;REMD now returns NIL or the removed type . function, as in Standard Lisp.
;Corrected bug in errormessage for index error in GETV, PUTV.
;PROG2 is again a defined function.
;<FRICK>LISP.MAC.20, 8-Nov-79 19:33:42, Edit by FRICK
;
;Added code for new FASLOD. Switches OFLD and NFLD controls assembling
; of new FASLOD and old FASLOAD. Both might be on at the same time.
;<FRICK>LISP.MAC.3, 1-Nov-79 16:26:25, Edit by FRICK
;
;For high core BPS in Tops-10 now computes start of high core.
;
;Fix bug in XEQ by guaranteeing 0 at end of RSCAN string.
;<FRICK>LISP.MAC.1, 28-Oct-79 16:06:56, Edit by FRICK
;
;An atom as first argument to FILEP means a filename for a file on DSK:
; with blank extension.
;
;XEQnow clears the terminal input buffer before simulating terminal
; input.
;<FRICK>LISP.MAC.4, 26-Oct-79 12:32:56, Edit by FRICK
;
;The charcters "+", "-" and "'" are now preceded by a "!" in PRIN1 and
; EXPLODE.
;<FRICK>LISP.MAC.2, 9-Oct-79 12:59:52, Edit by FRICK
;
;EOF is now signaled by returning the value of the interned id $EOF$.
;This value is originally the uninterned id $EOF$, but it can be
; changed.
;
;Cange of edit of 27-Mar-79. TYI (and READCH) now ignores null.
;<FRICK>LISP.MAC.16, 12-Sep-79 13:07:31, Edit by FRICK
;
;READ does now read negative bignums without dropping the minus sign
;
;When using high core in Tops-10, preserves high core data area.
;<FRICK>LISP.MAC.12, 16-Aug-79 16:13:29, Edit by FRICK
;
;BPS in high core now allowed also in Tops-10.
;Assembler switch SZBPS decides whether size of BPS is user settable.
;SZBPS is allways on if HCBPS is off. EXCORE only defined when SZBPS is
;on.
;
;Function EVLIS now defined.
;<FRICK>LISP.MAC.29, 2-Jul-79 15:11:01, Edit by FRICK
;
;Corrected bug in EQUAL so that EQUAL may return T for vectors.
;<FRICK>LISP.MAC.26, 15-Jun-79 19:08:49, Edit by FRICK
;
;The UUO handler changed to allow UUOs to be executed via a XCT.
;The MAPping functions have been changed to use this.
;<FRICK>LISP.MAC.19, 9-Jun-79 13:39:56, Edit by FRICK
;
;Included "T" and "?" in IDCHTAB.
;<FRICK>LISP.MAC.16, 29-May-79 18:40:20, Edit by FRICK
;
;Corrected error at XTYO so that character count now is reset at CR when
; echoing and TYO treats ascii 37 correctly.
;<FRICK>LISP.MAC.12, 23-May-79 23:07:49, Edit by FRICK
;
;The assembler switch APPL is defined. When on (off by default), EVAL
; return its arg when undefined function or unbound variable.
;<FRICK>LISP.MAC.11, 21-May-79 10:22:03, Edit by FRICK
;
;%SOSSWAP is now under assembler switch SOSSW that is off by default
;<FRICK>LISP.MAC.9, 17-May-79 15:29:09, Edit by FRICK
;
;%SOSSWAP and %SWAP only defined if OPSYS is > 0 (TENEX)
;
;If switch JSYXEQ is on then functions JSYS, %XEQ, ERRSTR and GETAB$ are defined
;<FRICK>LISP.MAC.7, 10-May-79 14:43:10, Edit by FRICK
;
;EOL conversion is now only done on input, not in READ0 routine used by
; COMPRESS or internal string reader READP1.
;The EOL conversion has further been changed so that CR, LF and FF are
; converted as follows:
; a CR is ignored if the next character is LF, FF or CRLF,
; a LF is converted to CRLF,
; a FF is converted to CRLF followed by FF.
;<FRICK>LISP.MAC.3, 4-May-79 18:12:32, Edit by FRICK
;
;Change unsafe BLT in ARGPDL
;<FRICK>LISP.MAC.16, 17-Apr-79 13:52:39, Edit by FRICK
;Call GET jsys as JSYS 200 to avoid name clash. Use SAV or EXE depending
; on OPSYS switch.
;<FRICK>LISP.MAC.15, 9-Apr-79 13:48:00, Edit by FRICK
;
;Removed <ht> in macro ML1 that gives problems in older MACRO versions
;<FRICK>LISP.MAC.14, 1-Apr-79 16:15:23, Edit by FRICK
;
;This file has been renumbered.
;<FRICK>LISP.MAC.13, 29-Mar-79 15:14:41, Edit by FRICK
;
;If the argument to FREEZE is true then the special stack is unbound
; to top level before halting. FREEZE checks if memory allocation is
; necessary when restarting if the argument is true.
;<FRICK>LISP.MAC.12, 27-Mar-79 18:00:20, Edit by FRICK
;
;The TYI routine now reads all characters exept ^Z but including % and
; null. This means that READCH reads % and null.
;<FRICK>LISP.MAC.5, 13-Mar-79 17:37:43, Edit by FRICK
;
;RDSLSH now knows about %. (RDSLSH T) sets % to be a normal letter,
; (RDSLSH NIL) sets % to be comment start.
;<FRICK>LISP.MAC.4, 12-Mar-79 16:31:30, Edit by FRICK
;
;Corrected bug in sixbit messages generated by prevoious edit, now
; generates EOL output again.
;
;*ECHO flag is now tested before *RAISE flag so that the status of
; *RAISE doesn't affect the echoed character.
;
;Corrected bug in MAPCAN, MAPCON: They now work also when NIL is
; returned as value by the applied function.
;<FRICK>LISP.MAC.26, 13-Feb-79 15:25:31, Edit by FRICK
;
;The character strings CR LF and CR FF are now replaced with the single
; character CRLF (ascii 37) in the routine TYID that does all input.
;CRLF is converted back to CR and LF in the internal routine TYO that
; does all output. The only exeption to this is the Lisp function TYO,
; (TYO 37) still will output a ascii 37.
;$EOL$ has as value the character id CRLF, so that READCH now returns
; the value of $EOL$ at end of line and PRINC $EOL$ is equivalent to
; TERPRI.
;SCAN now returns an interned character id in SCNVAL when seeing a
; delimiter. Because of this, UNTYI is replaced with UNREADCH that is
; similar but takes a character id as argument instead of ascii code.
;
;% now indicates start of a comment that ends with CRLF. Everything from
; % to (but not including) CRLF will be transparent to READ but not to
; READCH. SCAN has initially the same start and end of comment as READ
; and it will also not ignore the comment end character. As a consequence
; a comment can only be placed where a CRLF is legal. The special
; comment that starts with a ^Z and ends with CRLF does ignore the CRLF
; so that it can be placed anywhere.
;
;(AND) returns T.
;<FRICK>LISP.MAC.6, 31-Jan-79 14:03:36, Edit by FRICK
;
;READCH and EXPLODE are speeded up by maintaining an array of all
; interned character ids. This array is initially zero, but it is
; updated by INTERN and REMOB.
;<FRICK>LISP.MAC.4, 29-Jan-79 17:37:09, Edit by FRICK
;
;EXPLODE, READ (and COMPRESS) checks that they have the right scanner
; table and temporarily switches table if necessary. If an error occurs,
; this will leave the tables as if (SCANSET NIL) had been executed.
;<FRICK>LISP.MAC.1, 25-Jan-79 14:41:23, Edit by FRICK
;
;Corrected bug in EVAL when calling compiled EXPR with more than 5 args.
;<FRICK>LISP.MAC.13, 3-Jan-79 17:48:17, Edit by FRICK
;
;The use of L as indicator of octal numbers is now controlled by the
; switch ROCT. If ROCT is on then the change in edit of 26-Nov-78 is
; implemented, otherwise it is not.
;
;The symbol ILLAD is defined as the illegal address that generates a garbage
; collection. Setting it to 775777 (-2001) instead of 777777 (-1) seems to
; allewiate the problems mentioned in edit 25-Oct-78. For this reason
; CNSPRB is off by default in all versions of the system.
;
;The ^Z that indicates an ignored cr-lf is now not output if output is
; going to the terminal.
;
;The HALT that ended FREEZE in the Tops-10 version, is changed to EXIT 1, .
;<FRICK>LISP.MAC.7, 26-Nov-78 19:55:50, Edit by FRICK
;
;A number ended by the letter L, is read as an octal number also when
; the value of IBASE is not 8. When the value of BASE is 8, then end
; integers whith L when printed by PRIN1 but not when printed by PRIN2.
;<FRICK>LISP.MAC.1, 8-Nov-78 18:59:12, Edit by FRICK
;
;An atom as first argument to OPEN means a filename for a file on DSK:
; with blank extension.
;<FRICK>LISP.MAC.29, 3-Nov-78 17:15:24, Edit by FRICK
;
;Define SYM entry LMKSTR to make a Lisp string from top of SPDL
;<FRICK>LISP.MAC.28, 1-Nov-78 18:11:11, Edit by FRICK
;
;Make SETPCHAR return previous prompter as a non-interned identifier
;<FRICK>LISP.MAC.25, 25-Oct-78 19:10:13, Edit by FRICK
;
;Define an assembler switch CNSPRB, that when on will insert two instructions
; in the cons routine. These instructions will check explicitly for end
; of the free list instead of detecting the need for garbage collection
; by an illegal memory reference that occurs when the free list is empty.
; Explicit checking is slightly slower, but there seems to be some problems
; with the illegal memory reference mechanism on some virtual memory
; versions of the Tops-10 monitor.
;<FRICK>LISP.MAC.24, 26-Sep-78 16:38:51, Edit by FRICK
;
;Garbage collector now marks from reg REL also.
;<FRICK.SLSHEEP>LISP.MAC.2, 24-Sep-78 16:38:49, Edit by FRICK
;
;Declare some more symbols internal.
;<FRICK>LISP.MAC.17, 18-Sep-78 19:22:04, Edit by FRICK
;
;Fix bug in GCGAG output, so that it works also when number of cells
; collected are more than an INUM.
;<FRICK>LISP.MAC.11, 3-Sep-78 17:11:44, Edit by FRICK
;
;LINELENGTH now checks that its argument is NIL or greater than 0.
;PAGELENGTH now checks that its argument is NIL or greater than or equal to 0.
;
;DIGIT and LITER now returns NIL if their argument is not an
; interned id with a one character print name.
;<FRICK>LISP.MAC.7, 27-Aug-78 15:44:35, Edit by FRICK
;
;The ERROR print routine (also used by WARNING) doesn't relay any
;more on register T being saved. The stack is used instead.
;<FRICK>LISP.MAC.6, 24-Aug-78 16:53:44, Edit by FRICK
;(EQUAL 1 1.0) now returns NIL instead of T.
;
;The first argument to REMFLAG is a list whose elements now not
; have to be ids. REMFLAG does nothing for those that aren't ids.
;
;SUBR and FSUBR are now completely replaced by EXPR and FEXPR.
;For compatibility reason FASLOD will convert (F)SUBR to (F)EXPR and
;give a message about it the end of each load.
;
;Digits in DIGIT, EXPLODE and READCH are now character ids, not INUMs.
;
;The initialization file LISP.LSP is renamed to LISP.SL.
;<FRICK>LISP.MAC.2, 20-Aug-78 18:10:26, Edit by FRICK
;
;Make PATOM available as a SUBR.
;<FRICK>LISP.MAC.254, 1-Aug-78 17:49:50, Edit by FRICK
;
;Define Fasload type 11 to be similar to 13 but the codepointer
; is put on the property list with PUT instead of PUTD.
;<FRICK>LISP.MAC.252, 27-Jul-78 18:53:43, Edit by FRICK
;
;Make ERREx print the left half of register A if it isn't 0.
;This involves a change to PRINL also.
;Make a small change to PRINEL and remove PRIN1B that now is unnecessary.
;<FRICK>LISP.MAC.250, 25-Jul-78 23:52:04, Edit by FRICK
;
;Include this list of changes and renumber pages.
;<FRICK>LISP.MAC.245, 22-Jul-78 19:46:45, Edit by FRICK
;
;Set *ERRMSG to T on toplevel only if it is NIL.
;
;Make the OP routine (i.e. all binary numerical routines) check
;first that the arguments are numbers so that the error message
;"x IS NOT A NUMBER" gets the right "x".
;
;The garbage collector now also marks from the top element of
;the SPDL.
;<FRICK>LISP.MAC.238, 14-Jul-78 13:50:27, Edit by FRICK
;
;RETURN and GO now works in other than the last statement in
;a PROGN.
;
;SKIPTO now initialize register AR4 so that it doesn't think
;everything is EDIT or SOS line numbers.
;<FRICK>LISP.MAC.237, 10-Jul-78 01:21:58, Edit by FRICK
SUBTTL HISTORY OF CHANGES --- PAGE 1
;
;COPYRIGHT (C) 1979 University of Utah.
;
;Permission to copy without fee all or part of this material is granted
;provided that copies are not made or distributed for direct commercial
;advantage, the Utah copyright notice and the title of the program and
;its date appear, and notice is given that copying is by permission of
;the University of Utah. To copy otherwise, or to republish, requires a
;fee and/or specific permission.
;
SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 2
TITLE LISP INTERPRETER
COMMENT TABLE OF CONTENTS
1. History of changes
2. Assembling switches, AC Definitions, Symbols and Externals
3. Top Level and Initialization
4. APR Interrupt routines
5. UUO Handler and SUBR-call routines
6. ERROR Handler and Backtrace
7. TYI and TYO
8. INPUT and OUTPUT initialization and control
9. PRINT
10. READ and SCANner tables
11. Interpretive routines of LISP
12. Arithmetic routines
13. Bignum routines
14. Gfpak. Galois field package
15. EXPLODE, READLIST, FLATSIZE, etc.
16. EVAL and APPLY and bindings
17. ARRAY, EXARRAY, STORE
18. EXAMINE, DEPOSIT, BOOLE
19. Garbage Collector
20. GETSYM, PUTSYM and R50MAK
21. FASLOAD, FASLOD
22. ED - Alvine
LOAD
EXCISE, MORCOR, MOVSYM, etc.
23. FILEP
SOSSWAP
JSYS, GETAB#, XEQ
24. RBLK, WBLK
25. CORE, ALLOC
26. SETSYS, LSSAVE
27. Re-allocate code after a ST
REHASH
28. Lisp atoms and initial OBLIST
BPS, FS, FWS
29. Once-only Lisp Storage Allocator
PAGE
COMMENT General differences from Stanford's 1.6 are:
1) Octal ppns,
2) Explicit i/o for SOS-linkage,
3) The '*' prompt-char can be dynamically changed, to
consist of up to 4 characters;
4) The subr CORE(n) is used to increase (or partially cut) core;
5) The subr ALLOC() just goes to LISPGO to alloc new core;
6) Altmode can be typed as 33 or 175.
7) Binary-I/O (36-bit) by INBIN,OUTBIN,BINI,BINO.
8) BPS & EXAMINE,DEPOSIT may address to 256K, vs old 64K limit.
9) RBLK,WBLK can manipulate overlay-blocks in BPS as files.
Assembles for TOPS-20, TENEX or TOPS-10, operating systems
depending on the setting of the variable OPSYS.
N.B. Code for TENEX and TOPS-20 in CHKACS, CHKAC0, SETAPR
makes assumptions about PA1050's acc and ^O handler locations.
OPSYS is set here
;OPSYS==0 ;Assembles for TOPS-10.
;OPSYS==1 ;Assembles for TENEX
OPSYS==-1 ;Assembles for TOPS-20.
IFNDEF OPSYS,<OPSYS==-1> ;TOPS-20 is default
;When OPSYS not is zero, this has the following effects:
; 1) The 10x psi is enabled for 10/50 ^O (simulated);
; 2) The swapout for the SOS-link is done as an inferior fork,
; which returns to LISPGO, unless using LISP.TNX patchs.
; 3) The initial start-up questions are slightly changed.
;SYDEV==1 ;When on has the following effects:
; 1) An initial question for system device or directory
; to use as SYS: device:
; For TENEX version asks for system directory number
; (default: number for <REDUCE>, or if that not
; exists, the users directory).
; For TOPS-10 or -20 version asks for system device
; name (default: SYS: ).
; 2) The subr SETSYS is used to dynamically change SYS: .
;CNSPRB==1 ;When on, will check explicitly for the end of the free list,
; instead of detecting it by an illegal memory reference.
;STL==0 ;When on, will assemble for Standard Lisp
;OCTPPN==0 ;When off, will assemble for SU-AI's PPNs.
MOD==1 ;When on, will assemble GFPAK modular arithmetics
;ALOD==1 ;When on will assemble LOAD, *PUTSYM and *GETSYM.
;AED==1 ;When on will assemble ED and GRINDEF interface.
;NFLD==0 ;When off dont assemble new FASLOD
OFLD==1 ;When on, assemble old FASLOAD
;RWB==1 ;When on will assemble WBLK and RBLK.
;ASARY==1 ;When on will assemble array routines
EPDL==0 ;When on, will create a 3rd pdl pointed to by EP
;FNRG==0 ;When on, will assemble funarg features
;HCBPS==1 ;When on puts BPS in high core
;SZBPS==1 ;When on, size of BPS is user decidable, and EXCORE defined.
;ROCT==1 ;When on will read an integer followed by L as octal
;JSYXEQ==0 ;When off, will not define JSYS, %XEQ, ERRSTR and GETAB$
;SOSSW==1 ;When on assembles %SOSSWAP, used by SOSLINK
;APPL==1 ;When on, EVAL returns arg when undefined
PAGE
;Default values for switches
IFE OPSYS,<IFNDEF HCBPS,HCBPS==0 ;(Default low core for 10/50)
IFNDEF SZBPS,SZBPS==1
IF1,PRINTX Note: being assembled for TOPS-10, not TENEX or TOPS-20.
SEARCH UUOSYM
JSYXEQ==0 ; JSYSes not defined in TOPS-10
IFNDEF OCTPPN,<
OCTPPN==1
IF1,PRINTX Note: if for SU-AI, reassemble with OCTPPN==0 >>
IFN OPSYS,<IFNDEF HCBPS,HCBPS==1 ;(Default high core 400000:676776)
IFNDEF SZBPS,SZBPS==0
OCTPPN==1 > ;Permit (0,nnn) format if desired.
IFL OPSYS,<SEARCH MONSYM
IF1,PRINTX Note: being assembled for TOPS-20, not TENEX or TOPS-10. >
IFG OPSYS,<SEARCH STENEX
OPDEF ERJMP [JUMP 16,]
IF1,PRINTX Note: being assembled for TENEX, not TOPS-10 or TOPS-20. >
IFNDEF STL,<STL==1>
IFN STL,<
IFNDEF AED,AED==0
IFNDEF ALOD,ALOD==0
IFNDEF RWB,RWB==0
IFNDEF ASARY,ASARY==0>
IFNDEF SYDEV,<SYDEV==1> ;Default: SYDEV is on.
IFNDEF CNSPRB,<CNSPRB==0>
IFNDEF MOD,<MOD==0>
IFNDEF ALOD,<ALOD==1>
IFNDEF AED,<AED==1>
IFNDEF RWB,<RWB==1>
IFNDEF ASARY,<ASARY==1>
IFNDEF NFLD,<NFLD==1>
IFNDEF OFLD,<OFLD==0>
IFNDEF EPDL,<EPDL==0>
IFNDEF APPL,<APPL==0>
IFNDEF FNRG,<FNRG==1>
IFNDEF HCBPS,HCBPS==1
IFNDEF SZBPS,SZBPS==1
IFE HCBPS,SZBPS==1
IFNDEF ROCT,<ROCT==0>
IFNDEF JSYXEQ,<JSYXEQ==1>
IFNDEF SOSSW,<SOSSW==0>
PAGE
TEN==^D10
INUMIN=377777 ;Lower limit of INUMs.
BCKETS==77
INITBPS== 2000 ;Initial (default) size of BPS.
INITCORE==^D12*2000-1 ;Initial (default) size of Lisp core .
MAXCORE==^D124 ;Maximum size of Lisp core, to allow for I/O buffers.
MINFBPS==1000 ;Necessary BPS for Fap bootstrap fisltable
BOTBPS==1320 ;Necessary BPS for Fap loaded functions
ILLAD==775777 ;Illegal address to generate interrupt when free list exhausted.
;Atom type tags
ID=1000000-1 ;identifier
CODE=ID-1 ;code pointer
CODMIN==CODE
VECT=CODE-1 ;vector
STRNG=VECT-1 ;string
FLONU=STRNG-1 ;floating point number
FIXNU=FLONU-1 ;single word integer
POSNU=FIXNU-1 ;positive bignum. Must be odd
NEGNU=POSNU-1 ;negative bignum
ATMIN=NEGNU-1 ;addresses bigger than this, are atom tags.
INUM0=1+<INUMIN+ATMIN>/2
IFN <ATMIN+INUMIN-2*INUM0>,<INUMIN=INUMIN+1>
DEFINE PR%%IN (XX)<
PRINTX Maximum INUM modulus is XX
>
IF1,<XX==ATMIN-INUM0
PR%%IN \XX >
PAGE
;Accumulator definitions
;'sacred' means sacred to the interpreter
;'marked' means marked from right and left half by the garbage collector
;'protected' means protected during garbage collection
NIL=0 ;sacred, marked, protected ;atom head of NIL
A=1 ;marked, protected ;results of functions and first arg of subrs
B=A+1 ;marked, protected ;second arg of subrs
C=B+1 ;marked, protected ;third arg of subrs
AR4=4 ;marked, protected ;fourth arg of subrs (old AR1)
AR5=5 ;marked, protected ;fifth arg of subrs (old AR2A)
T=6 ;marked, protected ;minus number of args internaly
TT=7 ;marked, protected
REL=10 ;marked, protected ;rarely used
IFE EPDL,<
EP==14
S=11 >
IFN EPDL,<
S==11
EP=11 ;sacred, protected ;exp push down stack pointer >
D=12
R=13 ; protected
P=14 ;sacred, protected ;regular push down stack pointer
F=15 ;sacred ;free storage list pointer
FF=16 ;sacred ;full word list pointer
SP=17 ;sacred, protected ;special pushdown stack pointer
NACS==5 ;number of argument acs
NSUA==16 ;maximum number of subr arguments
X==0 ;X indicates impure (modified) code locations
; Added Inst-definitions for legibility...
OPDEF PCALL [PUSHJ P,]
OPDEF PRET [POPJ P,]
OPDEF PSAVE [PUSH P,]
OPDEF PREST [POP P,]
OPDEF PSKPRT [AOS (P)]
OPDEF P1DROP [SUB P,[1,,1]]
OPDEF P2DROP [SUB P,[2,,2]]
OPDEF P3DROP [SUB P,[3,,3]]
OPDEF PXDROP [SUB P,]
OPDEF CARA [HLRZ ]
OPDEF CDRA [HRRZ ]
OPDEF RPLCA [HRLM ]
OPDEF RPLCD [HRRM ]
PAGE
;UUO definitions
;UUOs used to call functions from compiled code
;the number of arguments is given by the ac field
;the address is a pointer either to the function
;name or the code of the function
OPDEF FCALL [34B8] ;ordinary function call-may be changed to PCALL
OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
OPDEF CALLF [36B8] ;like FCALL but may not be changed to PCALL
OPDEF JCALLF [37B8] ;like JCALL but may not be changed to JRST
;error UUOs
UOERRE==1
UOERRL==10
UOERRG==20
UOERRI==21
USTRTP==22
;ERRL and ERRE spans more than one UUO, to allow for larger ac-field
;Ac-field contains error number.
OPDEF ERRE1 [1B8] ; 1 ;print expression, ordinary lisp error, bactrace
OPDEF ERRE2 [2B8] ; 2
OPDEF ERRE3 [3B8] ; 3
OPDEF ERRE4 [4B8] ; 4
OPDEF ERRE5 [5B8] ; 5
OPDEF ERRE6 [6B8] ; 6
OPDEF ERRE7 [7B8] ; 7
OPDEF ERRL0 [10B8] ; 8 ;ordinary lisp error ;gives backtrace
OPDEF ERRL1 [11B8] ; 9
OPDEF ERRL2 [12B8] ; 10
OPDEF ERRL3 [13B8] ; 11
OPDEF ERRL4 [14B8] ; 12
OPDEF ERRL5 [15B8] ; 13
OPDEF ERRL6 [16B8] ; 14
OPDEF ERRL7 [17B8] ; 15
OPDEF ERRG [20B8] ; 16 ;space overflow error ;no backtrace
OPDEF ERRI [21B8] ; 17 ;ill. mem. ref.
OPDEF STRTIP [22B8] ; 18 ;print error message and continue
PAGE
;system UUOs
OPDEF TTYUUO [51B8]
OPDEF INCHRW [TTYUUO 0,]
OPDEF OUTCHR [TTYUUO 1,]
OPDEF OUTSTR [TTYUUO 3,]
OPDEF INCHWL [TTYUUO 4,]
OPDEF INCHSL [TTYUUO 5,]
OPDEF CLRBFI [TTYUUO 11,]
OPDEF SKPINC [TTYUUO 13,]
OPDEF TALK [PCALL TTYCLR] ;this is to turn off control O.
;when ttyser lets you do this
;easily, change me
;system uuos
DEVCHR==4
CORE==11
RESET==0
APRINI==16
MSTIME==23
STIME==27
SETUWP==36
PAGE
;I/O bits and constants
LNPRVT==6 ;lines per vertical tab
TTYPL==0 ;teletype pagelength. No paging
LPTPL==0 ;line printer pagelength. No paging
TTYLL==105 ;teletype linelength
LPTLL==160 ;line printer linelength
MLIOB==203 ;max length of I/O buffer
NIOB==2 ;no of I/O buffers per device
NIOCH==17 ;number of I/O channels
FSTCH==1 ;first I/O channel
TTCH==0 ;teletype I/O channel
BLKSIZE==NIOB*MLIOB+COUNT+1
INB==2
OUTB==1
AVLB==40
DIRB==4
;special ASCII characters
ALTMOD==175 ;LISP'S ALTMODE (TENEX-PA1050 & SU-AI) 33'S CONVERTED.
IGCRLF==32 ;ignored cr-lf
RUBOUT==177
CRLF==37 ;TYID converts the sequence CR LF or CR FORMF to CRLF. TYO converts back.
LF==12
CR==15
TAB==11
BELL==7
DBLQT==42 ;double quote "
VT==13 ;vertical tab
FORMF==14 ;form feed
;byte pointer field definitions
ACFLD==^D12 ;ac field
XFLD== ^D17 ;index field
OPFLD==^D8 ;opcode field
SIGN==400000 ;sign marker for bignums
PAGE
;external and internal symbols
EXTERNAL .JB41 ;instruction to be executed on UUO
EXTERNAL .JBAPR ;address of APR interupt routines
EXTERNAL .JBCNI ;interupt condition flags
EXTERNAL .JBFF ;first location beyond program
EXTERNAL .JBREL ;address of last legal instruction in core image
EXTERNAL .JBREN ;reentry address
EXTERNAL .JBSA ;starting address
EXTERNAL .JBSYM ;address of symbol table
EXTERNAL .JBTPC ;program counter at time of interupt
EXTERNAL .JBUUO ;uuo is put here with effective address computed
EXTERNAL .JBHRL ;RH= High-segment .JBREL, LH set 0.
;apr flags
PDOV==200000 ;push down list overflow
MPV==20000 ;memory protection violation
NXM==10000 ;non-existant memory referenced
APRFLG==PDOV+MPV+NXM ;any of the above
;foolst macros: these get relocated (RH addr) relative to FS.
DEFINE FOO <
XLIST
BAZ (\FOOCNT)
LIST
>
DEFINE BAZ (X)
<FOOCNT=FOOCNT+1
FOO'X:!
SUPPRESS FOO'X
>
FOOCNT=0
SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 3
LISPGO: SETOM RETFLG# ;enter via INITFN
JRST STRT ;go to re-allocator
DEBUGO: SETZM RETFLG ;clear return flag to allow INITFN to be changed
JSR CHKACS ;entry point to get into read-eval-print loop
JUMPN A,LSPRT2 ; without unbinding spec pdl...
;If NIL looks like an atomheader, we skip
; reseting the ACCs, etc, else refresh...
START: CALLI RESET ;Initializations for lisp interrupts...
JSR APRSET ;Set up APRs and Tenex ^chars.
JSR CHKAC0 ;Reset NIL if necessary, else retain any user additions.
IFN AED,SETZM PSAV1
FOO SETZB 1,VERMSG
MOVE 17,[1,,2]
BLT 17,17 ;clear acs, other than NIL.
MOVEI F,ILLAD ;empty fs list
LSPRT1: MOVE P,C2# ;Initialize regular PDL.
IFN EPDL,MOVE EP,EC2# ;initialize EPDL
SKIPE SP,SPSAV#
PCALL TUNBIND ;Unbind spec pdl to top
MOVE SP,SC2# ;Initialize special PDL.
PUSH SP,[0] ;mark for unbind
FOO MOVEI B,TRUTH
FOO SKIPN ERRSW ;only change if NIL
FOO MOVEM B,ERRSW ;print error messages
SETZM ERRTN ;return to top level on errors
SETOM PRVCNT# ;initialize counter for errio
IFN OPSYS,SETZM KBINTF
SETZM EXARG ;Delete content of
MOVE A,[EXARG,,EXARG+1] ; extended ascs to
BLT A,EXARG+NSUA-NACS-1 ; allow gc
LSPRT2: PCALL TTYRET ;Return output for gc msg.
JSR CHKNIL ;initialize nil
SKIPE HASHFG#
JRST REHASH ;rehash if necessary
SKIPN FF
PCALL AGC2 ;garbage collect only if necessary
SETZM GCFFLG#
SKIPN BSFLG# ;initial bootstrap for macros
JRST BOOTS
SKIPE BPSFLG#
JRST BINER2 ;BPS OVERFLOW DURING A (LOAD T).
SKIPN RETFLG ;test for error return
JRST LISP2
FOO SKIPE A,INITF
CALLF 0,(A) ;evaluate initialization function
SETZM RETFLG
LISP2: PCALL TTYRET ;return all i/o to tty
PCALL TERPRI
SKIPE GOBF# ;garbaged oblist flag
STRTIP [SIXBIT /_***** GARBAGED OBLIST_!/]
SETZM GOBF
LISP1: PCALL READ ;this is the top level of lisp
PCALL EVAL
PCALL TERPRI
PCALL PRINT
PCALL TERPRI
JRST LISP1
PAGE
;return from lisp error
LSPRE: CLRBFI ;clear input buffer
FOO SKIPE RSTSW
JRST LISP2 ;(*rset t) goes to read-eval-print loop without unbind
LSPRET: MOVE P,C2 ;return from bell
PCALL TERPRI
IFN AED,<SKIPE P,PSAV1# ;bell from alvine?
JRST [HRRZ REL,ED ;yes, return to alvine
JRST 1(REL)]> ;improved magic
MOVEM SP,SPSAV ;force unbinding of spec pdl
SETOM RETFLG ;set return flag
JRST LSPRT1
;bootstrapper for macro definitions & Lisp extensions...
BOOTS: SETOM BSFLG
MOVEI A,BSTYI
PCALL READP1
PCALL EVAL
PCALL READ ;last prog calls ERR, back to LISP1.
JRST .-2
BSTYI: ILDB A,[POINT 7,[ASCII /(RDS(OPEN '(SYS:(LISP.SL)) 'INPUT))/]]
PRET
PAGE
;Verify that NIL is a good atom, perhaps with user properties,
; else reset it (AC0) to be the Urlisp atomheader...
IFN OPSYS,<
CHKACS: X ;Tenex-Pa1050 needs to be clever about ^C's.
CALLI A,MSTIME ;Do a simple op to ensure PA1050 exists.
JSR CHKNIL
JUMPN A,@CHKACS ;Didn't have to fix it,
MOVE NIL,@700032 ; else check last ac0 saved in PA1050.
JSR CHKNIL
JUMPE A,@CHKACS ; Not ok either, have to refresh all accs.
HRLZ 17,700032 ;Was ok, so grab the save-acc blk
BLT 17,17 ; from PA1050's area.
JRST CHKACS+2 ;Set ac1 non0 and return successfully.
CHKAC0: X ;Setup 0 without worrying about 1:17.
JSR CHKNIL
JUMPN A,@CHKAC0 ;Tenex's was ok,
MOVE NIL,@700032
JSR CHKNIL
JRST @CHKAC0 > ; or PA1050's, else CNIL2 reset.
CHKNIL: X ;Yet another impure loc, for JSRing.
JSP TT,CHKNI1
JUMPN A,@CHKNIL ; o.k.
MOVE NIL,CNIL3 ; refresh NIL
MOVEI A,NIL ;Return 0 if have to reset...
JRST @CHKNIL
CHKNI1: HLRO A,NIL
AOJN A,SETNIL ;LH not -1.
CDRA A,NIL
CAILE A,@GCPP1 ;(base of FS)
CAIL A,@GCP1 ;(base of FWS)
JRST SETNIL ; proplist addr not in FS.
FOO MOVEI B,VALUE
GETNIL: MOVS C,(A) ;Make sure it has a VALUE cell,
MOVS A,(C)
CAIN B,(A) ; else EVAL would say "#0 Unbound Variable".
JRST GOTNIL
CARA A,C
JUMPN A,GETNIL
JRST (TT)
GOTNIL: HLRZS A ;We don't require this to be UrLisp's VNIL cell.
SKIPE (A) ;Check that it points back to NIL tho,
SETNIL: MOVEI A,NIL ; else reset it.
JRST (TT) ;Return non0: didn't have to reset.
IFE OPSYS,<CHKACS==CHKNIL ;Don't have to worry about separate
CHKAC0==CHKNIL> ; PA1050 accs being present after a ^C.
SUBTTL APR INTERRUPT ROUTINES --- PAGE 4
;arithmetic processor interupts
;mem. protect. violation, nonex. mem. or pdl overflow
APRINT: MOVEM R,ACSAV+R
MOVE R,.JBCNI ;get interrupt bits
SETZM .JBCNI ;Clear for compiled-code Pdl check: <JUMPGE P,@.JBAPR>
TRNE R,MPV+NXM ;what kind
JRST ILLMEM
JUMPN NIL,MES21 ;a pdl overflow
STRTIP [SIXBIT /_***** PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
JRST START
MES21: SETZM .JBUUO
SKIPL P
ERRG ^D256,[SIXBIT /REG PUSHDOWN CAPACITY EXCEEDED!/]
SKIPL SP
SPDLOV: ERRG ^D257,[SIXBIT /SPEC PUSHDOWN CAPACITY EXCEEDED!/]
IFN EPDL,<SKIPL EP
ERRG ^D258,[SIXBIT /EXP PUSHDOWN CAPACITY EXCEEDED!/] >
TRNN R,PDOV
HALT ;lisp should not be here
BINER2: SETZM BPSFLG
ERRG ^D259,[SIXBIT /BINARY PROGRAM SPACE EXCEEDED!/]
ILLMEM: LDB R,[POINT 4,@.JBTPC,XFLD] ;get index field of bad word
CAIN R,F ;is it F ?
CAIE F,ILLAD
ERRI 2,@.JBTPC ;no! error
PSAVE .JBTPC ;yes! save return address
MOVEI R,APRFLG
CALLI R,APRINI ; reset interupt,
MOVEI R,AGC1
JRSTF @R ; garbage collect and continue
PAGE
APRSET: 0 ;SET UP NECESSARY INTERRUPTS.
MOVE A,[JSR UUOH]
MOVEM A,.JB41
MOVEI A,APRINT
MOVEM A,.JBAPR
MOVEI A,APRFLG
CALLI A,APRINI ;THIS DOES THE 10/50 SETUP.
IFE OPSYS,<
IFN HCBPS,<
SETZ A,
CALLI A,SETUWP ;Necessary as RESET resets high core write bit.
HALT >
JRST @APRSET>
IFN OPSYS,< ; and for TENEX (Accs 1&2 are free):
MOVEI 1,400000 ;FORK HANDLE FOR THIS FORK.
RIR ;GET THE PA1050 FILE'S LEVTAB,,CHNTAB.
IFG OPSYS,<
MOVE 1,[XWD 1,CHANL0]
EXCH 1,^D30(2) ;Set channel addresses...
HRRZS 1 ; Normally would just use chn 0 for ^O
CAIL 1,700000 ; but PA1050 also diddles on chn 30,
HRRM 1,CHANL0 > ; so do local CHANL0 then PA1050's CFOBF.
MOVE 1,[XWD 1,CHANL1]
MOVEM 1,1(2)
MOVE 1,[XWD 1,CHANL2]
MOVEM 1,2(2)
MOVE 1,[XWD 1,CHANL3]
MOVEM 1,3(2)
IFG OPSYS,<
MOVE 1,["O"-100,,^D30];Set terminal-characters...
ATI >
MOVE 1,["P"-100,,1]
ATI
MOVE 1,["E"-100,,2]
ATI
MOVE 1,["K"-100,,3]
ATI
MOVEI 1,400000
IFG OPSYS,<MOVSI 2,(1B0+1B1+1B2+1B3)>
IFL OPSYS,<MOVSI 2,(1B1+1B2+1B3)>
AIC
IFG OPSYS,SETZM CTRLOF# ;Init.
SETZM KBINTF# ;Init.
JRST @APRSET
IFG OPSYS,<
CHANL0: SETCMM CTRLOF ;Flip-flop the ^O flag.
DEBRK >
PAGE
CHANL1: PSAVE 1 ; ^P HANDLER...
PSAVE 2 ; Prints current file's <Line>/<Page>.
PSAVE 3
MOVEI 1," "
PBOUT
SKIPG LINUM
JRST [MOVM 2,LINUM
PCALL IPNUM
JRST .+3]
HRROI 1,LINUM
PSOUT
MOVEI 1,"/"
PBOUT
MOVE 2,PGNUM
PCALL IPNUM
IFG OPSYS,MOVEI 1,37
IFL OPSYS,<MOVEI 1,CR
PBOUT
MOVEI 1,LF >
PBOUT
PREST 3
PREST 2
PREST 1
DEBRK
IPNUM: MOVEI 1,101
ADDI 2,1
MOVEI 3,^D10
NOUT
PRET
PRET
CHANL2: PSAVE 1
HRROI 1,[ASCIZ /^E
/]
PSOUT
PREST 1
HLLOS KBINTF ;Flag RH -- next UUO becomes (ERR).
DEBRK
CHANL3: PSAVE 1
HRROI 1,[ASCIZ /^K
/]
PSOUT
PREST 1
HRROS KBINTF ;Flag LH -- next UUO breaks out to top.
DEBRK
KBINTH: MOVE A,KBINTF ;Handle KB ^char now -- from UUOH, AGC, etc.
SETZM KBINTF
IFG OPSYS,SETZM CTRLOF
TLNE A,-1 ;Which was it?
JRST LSPRET ; ^K - escape to top-level.
MOVEI A,NIL
JRST ERR ; ^E - (ERR NIL) to ERRSET or top.
> ;end of IFN OPSYS
SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 5
UUOH: X ;jsr location
MOVEM T,TSV#
MOVEM TT,TTSV#
LDB T,[POINT 9,.JBUUO,OPFLD] ;get opcode
CAIGE T,34 ;is it a function call?
JRST ERROR ;or a LISP error?
IFN OPSYS,<
SKIPE KBINTF ;Has user hit ^Chars on KB?
JRST KBINTH ; Yes, handle it. >
HRRZ TT,UUOH
SOSA TT
MOVEI TT,@(TT)
LDB T,[POINT 9,(TT),OPFLD]
CAIN T,256 ;Is it XCT
JRST .-3
HRRM TT,UUOCL-1
LDB T,[POINT 5,.JBUUO,ACFLD]
TRZN T,20
PSAVE UUOH ;call|callf -- return addr.
CARA R,@.JBUUO
CAIE R,ID
JRST UUOS ;if wasn't an id head, else...
CAIE T,17
TDZA R,R
MOVEI R,1 ;R=0 if T=0-16, else 1(17).
CDRA T,@.JBUUO
FOO MOVEI D,FUNCELL
UUOH1: JUMPE T,UUOH3
MOVS TT,(T)
MOVS T,(TT)
CAIN D,(T)
JRA T,UUOH2
CARA T,TT
JRST UUOH1
PAGE
UUOH2: CARA TT,T
HRL T,.JBUUO ;name of function, for backtrace
;FOO CAIN TT,SUBR
; JRST @UUST(R)
;FOO CAIN TT,FSUBR
; JRST @UUFST(R)
CARA D,(T)
CAIE D,ID
CAIGE D,CODMIN
JRST .+2
SUBI R,4 ;its a subr or fsubr
FOO CAIN TT,EXPR
JRST @UUET(R)
FOO CAIN TT,FEXPR
JRST @UUFET(R)
UUOH4: HRRZ A,.JBUUO
ERRE1 ^D16,[SIXBIT /UNDEFINED UUO!/] ;e.g., a MACRO or no def.
UUOH3: PSAVE A
PSAVE B
HRRZ A,.JBUUO
FOO MOVEI B,VALUE
PCALL GET
JUMPE A,UUOH4
CDRA T,(A)
HRL T,.JBUUO ;name of function, for backtrace
PREST B
PREST A
JRST UUOEXP
PAGE
UUOSC: CDRA T,(T)
UUOSBR:
FOO SKIPE NOUUOF
JRST UUOCL
MOVE TT,.JBUUO
HRLI T,(PCALL)
TLNE TT,1000 ;1000 means no push
HRLI T,(JRST)
TLNN TT,2000 ;2000 means no clobber
MOVEM T,X
UUOCL: MOVE TT,TTSV
MOVE R,T
MOVE T,TSV
JRST (R)
UUOS: HRRZ T,.JBUUO ;If not an atomheader, what?
CAIL R,CODMIN
JRST UUOSC ; code pointer
CAILE T,@GCPP1 ; Base of FS,
CAIL T,@GCP1 ; FWS...
JRST UUOSBR
UUOEXP: PSAVE T ;<fn name or NIL,,func def>
LDB T,ARGFLD
JUMPE T,IAPPLY
CAIN T,17
MOVEI T,1
MOVEI TT,IAPPLY
SKIPA R,T
ARGPDL: LDB R,ARGFLD
ARGP1: HRLZ T,R
ADD P,T
JUMPGE P,MES21 ;check for stack overflow
MOVEI T,1(P)
HRLI T,A
CAIG R,NACS
JRST .+4
BLT T,NACS(P)
MOVEI T,NACS+1(P)
HRLI T,EXARG
ADDI P,(R)
BLT T,(P)
MOVNI T,(R)
JRST (TT)
EXARG: BLOCK NSUA-NACS+1
ARGFLD: POINT 4,.JBUUO,ACFLD
PAGE
;R=0 => compiler calling a -
;R=1 => compiler calling f type
;for an expr or fexpr that has a code pointer, 4 is subtracted
; from R, to map expr into subr and fexpr into fsubr
UUST: UUOSC
UUOS2 ;calling f (page 15 - EVAL).
UUFST: UUOS9 ;calling - its a f
UUOSC
UUET: UUOEXP
UUOS6 ;calling f its an expr (page 15 - EVAL).
UUFET: UUOS3 ;calling - its a fexpr
UUOEXP
UUOSFE: HRRZ A,.JBUUO
ERRE1 ^D17,[SIXBIT /CALLED AS EXPR!/]
UUOS9: PSAVE T
JSP TT,ARGPDL
MOVEI TT,UUOCL
QTLFY: MOVEI A,0 ;If AGC and GCGAG(T), can clobber
QTLFY1: JUMPE T,(TT) ; .JBUUO and UUOH, so saved in GC.
EXCH A,(P)
PCALL QTIFY
PREST B
PCALL CONS
AOJA T,QTLFY1
UUOS3: PSAVE T
JSP TT,ARGPDL
JSP TT,QTLFY
JRST UUOS3I
SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 6
ERRSUB: HRRZ A,.JBUUO ;Print SIXBITed messages (errors)...
JUMPE A,CPOPJ
HRLI A,(POINT 6,0)
MOVEM A,ERRPTR#
ERRORB: ILDB A,ERRPTR
CAIN A,01 ;conversion from sixbit
PRET
CAIN A,77
HRREI A,CRLF-40
ADDI A,40
PCALL TYO
JRST ERRORB
WHEAD: PCALL ERRIO
MOVEI B,3
JRST ERHED+2
ERHED: PCALL ERRIO
MOVEI B,5
PCALL TERPRI
MOVEI R,TYO
XCT "*",CTY
SOJG B,.-1
XCT " ",CTY
PRET
TOURET: PCALL TERPRI
;subroutine to return output to previously selected device
OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect
SOSL PRVCNT ;when prvcnt goes negative, then reselect
PRET
PSAVE PRVSEL# ;previously selected output
PREST TYOD
PRET
;subroutine to force error messages out on tty
ERRIO:
FOO CDRA B,ERRSW
CAIE B,INUM0 ;inum0 => print message on selected device
AOSLE PRVCNT ;Deselected iff PRVCNT already <0.
PRET
TALK ;undo control o
MOVE B,[JRST TTYO]
EXCH B,TYOD
MOVEM B,PRVSEL
PRET
ERRTN: 0 ;0 => top level *
;- => pdl to reset to - stored by errorset
;+ => string tyo pout rtn flag
PAGE
;subroutine to search oblist for closest function to address in R
ERSUB3:
JSR CHKNIL ;Reset AC0 if need be.
FOO MOVEI A,QST
HRLZ B,INT1
MOVNS B
SETZB AR5,GOBF
CAIL R,STRT
MOVEI AR5,STRT
FOO CAIL R,FS
MOVEI A,NIL
PSAVE .JBAPR
MOVEI C,[SETOM GOBF ;Intercept ill-mem-refs, flag
JRST ERRO2G] ; "garbaged OBLIST" for LISP2.
HRRM C,.JBAPR
HLRZ C,@RHX5
ERRO2B: JUMPE C,[AOBJN B,.-1
PREST .JBAPR ;oblist done, restore
JRST PRIN2D] ;print closest match
CARA TT,(C)
CDRA TT,(TT)
JRST ERRO2C+1
ERRO2C: CARA TT,TT
JUMPE TT,ERRO2G
MOVS TT,(TT)
CARA AR4,(TT)
FOO CAIE AR4,FUNCELL
JRST ERRO2C
CDRA TT,(TT)
CDRA TT,(TT)
CARA AR4,(TT)
CAIE AR4,ID
CAIGE AR4,CODMIN
JRST ERRO2G
CDRA TT,(TT)
CAMLE TT,AR5 ;LE to prefer car to quote
CAMLE TT,R
JRST ERRO2G
MOVE AR5,TT
CARA A,(C)
ERRO2G: CDRA C,(C)
JRST ERRO2B
PAGE
;dispatcher for error message uuos
ERROR: MOVEI B,APRFLG ;Enable 10/50 interrupts.
CALLI B,APRINI
LDB B,[POINT 9,.JBUUO,OPFLD] ;get opcode
CAIL B,UOERRE ;what
CAILE B,USTRTP ;is it?
JRST ILLUUO ; an illegal opcode
LDB R,[POINT 9,.JBUUO,ACFLD] ;error number
ADDI R,INUM0
CAIL B,USTRTP
JRST STRTYP ;print message and continue
FOO SETZM VERMSG
CAIL B,UOERRI
JRST ERROR2 ;illegal memory reference
HRRM R,ERRX ;error number
CAIL B,UOERRG
JRST ERRORG ;space overflow error
CAIL B,UOERRL
JRST ERROR1 ;ordinary LISP error
FOO HRRZM A,VERMSG ;set EMSG* to expression
PSAVE A ;save it
FOO SKIPN ERRSW
JRST ERREND ;dont print message, call (err nil)
PCALL ERHED ;print message on tty
PREST A
PCALL PRIN1 ;print expression
XCT " ",CTY
JRST ERRORA ;then ordinary Lisp error
ERRORG: SKIPN P,ERRTN ;if in errset, restore p to that level
MOVE P,C2 ;else to top level
ERROR1: ;and attempt to print message
FOO SKIPN ERRSW
JRST ERREND ;dont print message, call (err nil)
PCALL ERHED ;print message on tty
ERRORA: PCALL ERRSUB ;print the message
JRST ERRBK ;go the backtrace
;STRTYP uses acs A, B and R
STRTYP: PCALL ERRIO
PCALL ERRSUB ;print message and continue
PCALL OUTRET
JRST @UUOH
ERROR2: HRRZ A,.JBUUO
MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
SUBI R,420
JRST ERSUB2
PAGE
ILLUUO: HRRZ A,UUOH
MOVEI B,[SIXBIT / ILL UUO FROM !/]
MOVEI R,INUM0+1
FOO SETZM VERMSG
ERSUB2: HRRM R,ERRX
FOO SKIPN ERRSW
JRST ERREND ;dont print message
PSAVE A
PSAVE B
PCALL ERHED
PCALL PRINL2 ;print number
PREST A
PCALL ERRSUB+1 ;print message
PREST R
PCALL ERSUB3 ;print nearest oblist match
ERRBK:
FOO SKIPE BACTRF
PCALL BKTRC ;print backtrace
PCALL TOURET ;return to previous device
ERREND: JSR CHKNIL ;Insure NIL is set properly.
ERRX: MOVEI A,X ;(ERR x) error number
ERR2: SKIPN ERRTN
JRST LSPRE
ERR: SKIPN P,ERRTN
JRST LSPRET ;not in an errset, or bad error -- go to top level
ERR1: PREST B
PCALL UBD ;unbind to previous errset
IFN EPDL,PREST EP
FOO PREST ERRSW
PREST ERRTN
JRST ERRP4 ;and proceed
ERRORSET:PSAVE PA3
PSAVE PA4
PSAVE ERRTN
FOO EXCH B,ERRSW ;INUM0 -> print on selected device (not nec TYO).
PSAVE B
IFN EPDL,PSAVE EP
PSAVE SP
MOVEM P,ERRTN
PUSH SP,[0] ;mark for unbind
FOO EXCH C,BACTRF ;bind BACTRF on spdl to save from error
FOO HRLI C,BACTRF
PUSH SP,C
PCALL EVAL
PCALL NCONS
JRST ERR1
PAGE
.ERROR:
FOO HRRZM B,VERMSG
PSAVE A
FOO SKIPN ERRSW
JRST .ERR1
MOVE A,B
PCALL ERRIO
JUMPE A,.ERRO
PCALL ERHED+1
PCALL PRINEL
.ERRO:
FOO SKIPE BACTRF
PCALL BKTRC
PCALL TOURET
.ERR1: JSR CHKNIL
PREST A
JRST ERR2
PRINEL: JSP D,PATMTP
JRST PRIN2
PSAVE A
CARA A,(A)
PCALL PRIN1
PRINE1: CDRA T,@(P)
MOVEM T,(P)
JUMPE T,POPAJ
XCT " ",CTY
CARA A,(T)
PCALL PRIN2
JRST PRINE1
;WARNING prints a warning message on the tty
WARNING:
FOO SKIPN %MSG
JRST FALSE
PCALL WHEAD
PCALL PRINEL
JRST TOURET
PAGE
BKTRC: ;backtrace subroutine
FOO CDRA A,BACTRF ;Nil or non-Nil or 0 or +-n...
BKTRA: SETZM RVAL ;No stack-args printed, unless 0 or neg.
CAIG A,INUMIN
JRST BKTR0A
HRREI B,-INUM0(A)
SKIPG B
SETOM RVAL ;0 or neg also prints stack args.
MOVM B,B
HRRZ A,P
SUB A,B ;Just the top n items or
JUMPN B,BKTR0B ;0 == T otherwise.
BKTR0A: SKIPN A,ERRTN ;backtrace to previous errset
MOVE A,C2 ;or top level
BKTR0B: HRRZM A,BAKLEV#
STRTIP [SIXBIT /_BACKTRACE_!/]
FOO MOVE A,VBPORG
PCALL NUMVAL
MOVEM A,HVAL
MOVEI D,-1(P)
BKTR2: CAMG D,BAKLEV
JRST FALSE ;done
HRRZ A,(D) ;get pdl element
FOO CAIGE A,FS
JUMPN A,BKTR2B ;this is (hopefully) a true program address
IFN HCBPS,<
CAML A,HVAL ;Check for High BPS subrs,
JRST BKTR2A ; else an INUM.
CAILE A,400000 ;PCALL from location 377777 is illegal
JRST BKTR1B ;Test it.
>
IFE HCBPS,<
CAILE A,INUMIN ;Check for Excore BPS subrs,
JRST BKTR2A ; else an INUM.
CAML A,HVAL
SOJA D,BKTR2
CAMLE A,JRELO
JRST BKTR1B ;Test it.
>
CAIGE A,@GCP1 ;Within FS or NIL?
BKTR2A: SKIPN RVAL ;Want to print args on stack?
SOJA D,BKTR2 ; Unknown, neither prog nor sexpr, so skip.
MOVEI A,"="
PCALL TYO
HRRZ A,(D)
BKTR2C: PCALL PRIN2D
JRST BKTR1C
PAGE
BKTR2B: CAIE A,ILIST3 ;evaluating arguments ?
JRST BKTR1B ;no
HRRZ B,-1(D) ;maybe
CAIE B,EXP2
CAIN B,ESB1
JRST BKTR1A ;yes
BKTR1B: CAIN A,CPOPJ
JRST [HLRZ A,(D) ;calling a function
PCALL PRIN2D
STRTIP [SIXBIT /-ENTER !/]
SOJA D,BKTR2]
HLRZ B,-1(A)
CAILE B,(JCALLF 17,@(17))
CAIN B,(PCALL) ;tests for various types of calls
CAIGE B,(FCALL)
JRST [CAIG A,INUMIN
SOJA D,BKTR2 ;Not a proper function call.
JRST BKTR2A ];This could print as a INUM.
PSAVE -1(A) ;save object of function call
MOVEI R,-1(A) ;location of function call
PCALL ERSUB3 ;print closest oblist match
XCT "-",CTY
PREST R
TLNE R,17
HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
HRRZS R
CARA B,(R)
CAIN B,ID
JRST [CDRA A,R ;was calling an atomic function
JRST BKTR2C] ;print its name
CAIL B,CODMIN ;code pointer ?
CDRA R,(R) ;yes
PCALL ERSUB3 ;was calling a code location; print closest match
BKTR1C: XCT " ",CTY
BKTR1: SOJA D,BKTR2 ;continue
BKTR1A: HLRE B,-1(D)
ADD B,D
HLRZ A,-3(B)
JUMPE A,BKTR1
PCALL PRIN2D
STRTIP [SIXBIT /-EVALARGS !/]
SOJA D,BKTR2
PRIN2D: PSAVE D
PCALL PRIN2
PREST D
PRET
SUBTTL TYI & TYO --- PAGE 7
;Input routines...
BINI: PCALL TYID
JRST FIX1A
ITYI: PCALL TYI
FIXI: ADDI A,INUM0
PRET
TYICC: PCALL COMIGN
TYI: MOVEI AR4,1
TYIC: PCALL TYID1
JUMPE A,.-1 ;Ignore null
CAIN A,IGCRLF ;start of ignored cr-lf
JRST TYICC ;read comment
PRET
TYIA: CAIN A,LF ;If it is LF
JRST RETCRLF ; then return CRLF
CAIN A,FORMF ; else if it is FORMF
JRST RCRLFFF ; then return CRLF FF
CAIE A,CR
PRET
PCALL TYID ;Read next character
CAIN A,CRLF ;If it is CRLF
PRET ; then return it
MOVEM A,OLDCH ; else backup character
MOVEI A,CR ; and return CR
PRET
RCRLFFF:MOVEM A,OLDCH ;Backup FF
RETCRLF:MOVEI A,CRLF
PRET
TYID1: SKIPE A,OLDCH
JRST TYI1
TYID: JRST TTYI+X ;<SOSG X> for other device input...
JRST TYI2X
TYI3: ILDB A,X ;pointer
SKIPGE INCH ;IF BINARY-MODE INPUT,
PRET ; SKIP LINUM &FECHO & RAISE CODE.
TYI3A: TDNN AR4,@X ;pointer
JRST TYI4
MOVE A,@TYI3A
CAMN A,[<ASCII / />+1] ;page mark for stopgap
AOSA PGNUM ;increment page number
MOVEM A,LINUM
MOVNI A,5
ADDM A,@TYID ;adjust character count for line number
AOS @TYI3 ;increment byte pointer over line number and tab
JRST TYID
PAGE
TYI4: SKIPLE LINUM
JRST TYI4A
CAIN A,LF
JRST TYI4L
CAIE A,FORMF
JRST TYI4A
SETZM LINUM
AOSA PGNUM
TYI4L: SOS LINUM
TYI4A:
FOO SKIPN VFECHO
JRST TYI4E
CAIN A,"D"-100 ;On! File-input echoed to TTY.
JRST TYI4W
PCALL XTYO
JRST TYI4E
TYI4W:
IFN OPSYS,<
PSAVE 2 ;Unless ^D encountered in file...
MOVEI 1,100 ; want to pause during echo,
RFMOD ; e.g., demo on a CRT.
PSAVE 2
TRZ 2,776000 ;Clear wakeup,echo.
TRO 2,020000 ;Set just punctuation,
SFMOD
WAITSP: PBIN ;Wait til user types a space on KB.
CAIE 1," "
JRST WAITSP
MOVEI 1,100
PREST 2
SFMOD ;Restore old TTYmodes.
PREST 2
JRST TYID ;Get next file-character.
>
IFE OPSYS,<
SETSTS TTCH,1+1B28 ;OFF ECHO TO TTY, TO GET <sp>...
WAITSP: INCHRW A
CAIE A," "
JRST WAITSP
SETSTS TTCH,1
JRST TYID
>
PAGE
TYI2X: INPUT X,0
TYI2Y: STATZ X,740000
ERRL0 ^D128,AIN.8 ;input error
TYI2Z: STATO X,20000
JRST TYI3 ;continue with file
PSAVE T ;end of file
PSAVE C
PSAVE R
PSAVE AR4
MOVE A,INCH
HLRZ T,CHTAB(A) ;inlst -- remaining files to input
JUMPE T,TYI2E ;none left -- stop
HRRZ C,CHTAB(A) ;get location of data for this channel
MOVE R,CHDEV(C)
MOVEM R,DEV
MOVE R,CHPPN(C)
MOVEM R,PPN
PCALL SETIN ;start next input
PREST AR4
PREST R
PREST C
PREST T
JRST TYI
TYI2E: PCALL INCNT ;(CLOSE (RDS NIL))
TALK ;turn off control o
FOO MOVE A,V$EOF$ ;we are done
JRST ERR
PGLINE: MOVM A,LINUM
SKIPG LINUM
AOJA A,.+3
MOVE C,[POINT 7,LINUM]
PCALL NUM10 ;convert ascii line number to an integer
PCALL FIX1A ;(may be larger than INUM size - 99999).
SKIPG LINUM ;If not line numbered file
PCALL NCONS ; then (pg line)
MOVE B,PGNUM
HRLI A,INUM0+1(B)
JRST DCONSA ; else (pg . line)
OLDCH: 0 ; *
PGNUM: 0 ; *
LINUM: 0 ; *
0 ;zero to terminate num10
PAGE
;teletype input
TTYI:
FOO SKIPE DDTIFG
JRST TTYID
INCHSL A ;single char if line has been typed
JRST [TALK ;turn off control o.
OUTSTR PCHAR ;output THE PROMPT-CHAR(S).
INCHWL A ;wait for a line
JRST .+1]
TTYXIT: CAIN A,BELL
JRST LSPRET ;bell returns to top level
CAIN A,33
MOVEI A,ALTMOD ;<esc> becomes <alt> (DECUS tty input).
TYI4E:
FOO SKIPE VRAISE
CAIGE A,"A"+40
JRST TYIA
CAIG A,"Z"+40
TRZ A,40 ;If flag on, make lowercase into upper.
PRET
TTYID: TALK ;turn off control o, remove this when ttyser works
INCHRW A ;single character input ddt submode style
CAIE A,RUBOUT
JRST TTYXIT
OUTCHR ["\"] ;echo backslash
SKIPE PSAV
JRST RDRUB ;rubout in read resets to top level of read
PRET
PCHAR: ASCIZ /*/ ;INITIAL (DEFAULT) PROMPT-CHAR.
SETPCH: PCALL GT1PNM
TRZ A,377 ;(INSURE NULL AT END OF STRING).
EXCH A,PCHAR ;1-4 CHARS.
JRST PNGNK2 ;return previous promter as non-interned id
PAGE
;output ROUTINES.
BINO: PSAVE A
PCALL NUMVAL
PCALL TYOD
JRST POPAJ
ITYO: SUBI A,INUM0
PSAVE CFIXI ;go to FIXI after TYO
XTYO: CAIN A,CRLF ;is it CRLF
JRST TYO+2 ;yes! output as is, do not convert to CR LF
TYO: CAIG A,CRLF
JRST TYO3
SOSGE CHCT
JRST TYO1
TYOD: JRST TTYO+X ;sosg x for other device
JRST TYO2X
TYO5: IDPB A,X
PRET
TYO2X: OUT X,0
JRST TYO5
ERRL0 ^D129,[SIXBIT /OUTPUT ERROR!/]
TYO3: CAIE A,CRLF
JRST TYO3X
MOVEI A,CR
PCALL TYO3XX
MOVEI A,LF
TYO3X: CAIG A,CR
CAIGE A,TAB
JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
TYO3XX: PSAVE B
MOVE B,LINL
CAIN A,TAB
JRST [SUB B,CHCT
IORI B,7 ;simulate tab effect on chct
SUB B,LINL
SETCAM B,CHCT
JRST TYO4]
CAIN A,CR
MOVEM B,CHCT ;reset chct after a cr
CAIN A,VT
JRST [PSAVE C
MOVE B,LNCT
IDIVI B,LNPRVT
ADDI B,1
IMULI B,LNPRVT
MOVEM B,LNCT
PREST C
JRST TYO6]
CAIN A,FORMF
TYO7: SETZM LNCT
CAIE A,LF
JRST TYO4
AOS LNCT
TYO6: SKIPE B,PAGL
CAMLE B,LNCT
JRST TYO4
MOVEI A,FORMF
JRST TYO7
PAGE
TYO1: SKIPN OUTCH
JRST TYO11 ;don't print a IGCRLF to terminal
PSAVE A ;linelength exceeded
MOVEI A,IGCRLF ;ignored cr-lf
PCALL TYOD
PREST A
TYO11: PCALL TERPRI
SOSA CHCT
TYO4: PREST B
JRST TYOD
LINELENGTH:
JUMPE A,LINEL1
CAIG A,INUM0
ERRE2 ^D36,[SIXBIT /ILLEGAL ARG TO LINELENGTH!/]
SUBI A,INUM0
HRRM A,LINL
HRRM A,CHCT
LINEL1: HRRZ A,LINL
CFIXI: JRST FIXI
PAGELENGTH:
JUMPE A,PAGEL1
CAIGE A,INUM0
ERRE2 ^D37,[SIXBIT /ILLEGAL ARG TO PAGELENGTH!/]
SUBI A,INUM0
HRRM A,PAGL
JUMPE A,PAGEL1
SKIPE LNCT
PCALL EJECT
PAGEL1: HRRZ A,PAGL
JRST FIXI
POSN: SKIPA A,LINL
LPOSN: SKIPA A,LNCT
SUB A,CHCT
JRST FIX1A
LINL: TTYLL ;*
CHCT: TTYLL ;*
PAGL: TTYPL
LNCT: 0
;teletype output
TTYO: ;Output 1 char from A...
IFG OPSYS,SKIPN CTRLOF ; unless ^O on.
OUTCHR A
PRET
PAGE
TTYRET: PCALL OUTCNT
JRST INCNT
TTYCLR: ;Turn off ^O, in a way such that msg
IFLE OPSYS, < ; or promptchar will print.
SKPINC
PRET
PRET >
IFG OPSYS, <
PSAVE A
MOVEI 1,101
DOBE
SETZM CTRLOF
JRST POPAJ >
TTOCH: 0 ;*
0 ;tty page number -- always zero
0 ;tty line number -- always zero
TTOLL: TTYLL ;*
TTOHP: TTYLL ;*
TTOPL: TTYPL
TTOVP: 0
SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 8
;convert ascii to sixbit for device initialization routines
SIXMAK: SETZM SIXMK2#
MOVE AR4,[POINT 6,SIXMK2]
HRROI R,SIXMK1
PCALL PRINTA ;use print to unpack ascii characters
MOVE A,SIXMK2
PRET
SIXMK1: ADDI A,40
TLNN AR4,770000
PRET ;last character position -- ignore remaining chars
CAIN A,"."+40
MOVEI A,0 ;ignore dots at end of numbers for decimal base
CAIN A,":"+40
HRLI AR4,(POINT 6,0,29) ;deposit : in last char position
IDPB A,AR4
PRET
;subroutine to process next item in file name list
INXTIO: JUMPE T,FALSE
CDRA T,(T)
NXTIO: CARA A,(T)
PCALL ATOM
JUMPE A,CPOPJ ;non-atomic
CARA A,(T)
JRST SIXMAK ;make sixbit if atomic
IFN OCTPPN,<IOPPNX==NUMVAL>
PAGE
IOSUB: PCALL NXTIO
MOVEM T,DEVDAT#
LDB B,[POINT 6,A,35]
JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
CAIE B,":"-40
JRST IOFIL ;not a device name -- must be file name
TRZ A,77 ;clear out the :
IFN OPSYS,PCALL CHKDIR
IODEV2: MOVEM A,DEV
PCALL INXTIO
JUMPN A,IOFIL2 ;not ppn or (fil.ext)
IOPPN: JUMPE T,FIL
PCALL PPNEXT
JUMPN A,IOEXT ;(fil.ext)
CARA A,(T)
CARA A,(A) ;caar is project number
PCALL IOPPNX
HRLM A,PPN ;project number
CARA A,(T)
PCALL CADR ;cadar is programmer number
PCALL IOPPNX
HRRM A,PPN ;programmer number
MOVSI A,(SIXBIT /DSK/) ;disk is assumed
JRST IODEV2
IOFIL: JUMPN A,IOFIL3 ;was it an atom
JUMPE T,FIL ;no, was it nil (end)
PCALL PPNEXT
JUMPE A,CPOPJ ;see a ppn, no file named
IOEXT: CARA A,(T) ;(file.ext)
CDRA A,(A) ;get cdr == extension
PCALL SIXMAK
HLLZM A,EXT
CARA A,(T)
CARA A,(A) ;get car = file name
PCALL SIXMAK
FIL: JUMPE T,.+2
CDRA T,(T)
SKIPE DEV
PRET
PSAVE A ;no device named
MOVSI A,(SIXBIT /DSK/)
MOVEM A,DEV
JRST POPAJ
IOFIL2: LDB B,[POINT 6,A,35]
CAIN B,":"-40
JRST FALSE ;saw a :,not file name
IOFIL3: SETZM EXT ;file name -- clear extension
JRST FIL
PAGE
PPNEXT: CARA A,(T)
CDRA A,(A) ;cdar
JRST ATOM ;ppn iff (not(atom(cdar l)))
IFE OCTPPN,<
IOPPNX: PCALL SIXMAK
TRNE A,77
PRET
LSH A,-6
JRST .-3 >
IFN OPSYS,<
CHKDIR: CAME A,[SIXBIT /DIR/] ;i.e., (... DIR: directory filename ...)
PRET
PSAVE T
PCALL INXTIO
JUMPE A,NIXDIR ;NON-ATOMIC.
CARA A,(T)
PCALL PNAMUK
SETZM 1(C)
IFG OPSYS ,<
MOVSI A,400000
HRROI B,1(SP)
STDIR
JRST NIXDIR
JRST NIXDIR
HRRZM A,PPN >
IFL OPSYS, <
HRLI A,440700 ; MAKE UP A
HRRI A,1(SP) ; BYTE POINTER
MOVE B,A
MOVEI C,"<"
LP1: ILDB 4,A
IDPB C,B
MOVE C,4
JUMPN C,LP1
MOVEI C,">" ; PUT IN LEFT BRACKET
IDPB C,B
IDPB 4,B
MOVEI A,0
HRROI B,1(SP)
RCDIR
ERJMP NIXDIR
SYSNU: HRLI C,X
MOVEM C,PPN >
P1DROP ;SLUFF.
USEDSK: MOVSI A,(SIXBIT /DSK/)
PRET
NIXDIR: PREST T ;TRY AS FILENAME INSTEAD.
JRST USEDSK
> ;end of IFN OPSYS
PAGE
;subroutine to reset all i/o channels -- used by excise and realloc
IOBRST: X ;jsr location
HRRZ A,.JBREL
HRLM A,.JBSA
MOVEM A,CORUSE
MOVEM A,.JBSYM
SETZM CHTAB+FSTCH
MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
JRST @IOBRST
CHTAB=.-FSTCH ;GC'D BY GCMKL AS AN ARRAY, SINCE LH=LIST,
BLOCK NIOCH ;[1-17] RH=ADDR OF .JBFF DATA BLK. ;*
;channel data
CHNAM==0 ;name of channel
CHDEV==1 ;name of device
CHPPN==2 ;ppn for input channel
CHOCH==3 ;oldch for input channels
CHPAGE==4 ;page number for input
CHLINE==5 ;line number for input
CHDAT==6 ;device data
POINTR==7 ;byte pointer for device buffer
COUNT==10 ;character count for device buffer
CHLL==2 ;linelength for output channel
CHHP==3 ;hposit for output channels
CHPL==4 ;pagelength for output channel
CHVP==5 ;vposit for output channels
;flags in left half of CHNAM
BINM==400000 ;binary I/O
OUTM==1 ;output
PAGE
OPEN: JUMPE A,.+3
JSP D,ATMTYP
PCALL NCONS
MOVE T,A
SETZB A,DEV
FOO CAIE B,INBIN
FOO CAIN B,OUTBIN
TLO A,BINM ;binary I/O
FOO CAIE B,OUTPUT
FOO CAIN B,OUTBIN
TLO A,OUTM ;output
FOO CAIE B,INPUT
JUMPE A,[MOVE A,B
ERRE1 ^D18,[SIXBIT /NOT A KEYWORD FOR OPEN!/]]
MOVE B,[-NIOCH,,FSTCH]
OPEN1: SKIPN C,CHTAB(B)
JRST OPEN2 ;found free channel without buffer
SKIPN CHNAM(C)
JRST DEVCLR ;found free channel with buffer
AOBJN B,OPEN1 ;try next channel
ERRL0 ^D130,[SIXBIT "NO I/O CHANNELS LEFT!"]
OPEN2: PSAVE A
MOVEI A,BLKSIZ
PCALL MORCOR ;expand core for buffer if necessary
MOVE C,A
PREST A
HRRM C,CHTAB(B)
DEVCLR: HRRZ C,CHTAB(B)
HRR A,B
HLLOM A,CHNAM(C)
MOVEI B,INUM0(B)
PSAVE B
SETZM PPN
TLNE A,OUTM
JRST SETOUT
PCALL SETIN
JRST POPAJ
PAGE
SETIN: PSAVE A ;CHANNEL #.
PCALL IOSUB ;get device and file name
MOVEM A,LOOKIN ;file name
MOVE A,DEV
CALLI A,DEVCHR
TLNN A,INB
JRST AIN.2 ;not input device
TLNN A,AVLB
JRST AIN.4 ;not available
PREST A
HLLZS ININIT
MOVEI B,13
SKIPGE A
HRRM B,ININIT ;BINARY-INBIN.
DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
DPB A,[POINT 4,INLOOK,ACFLD]
DPB A,[POINT 4,ININBF,ACFLD]
HRRZ B,CHTAB(A)
HRLM T,CHTAB(A) ;save remaining file name list
MOVEI A,CHDAT(B)
MOVEM A,DEV+1 ;pointer to bufdat
IFN SYDEV,<PCALL SYSDEV> ;Check for SYS:
ININIT: INIT X,X ;INIT CHN#,STATUS
DEV: X ;SIXBIT /DEV/
X ;XWD 0,IBUF
JRST AIN.7 ;cant init
PUSH B,DEV
PUSH B,PPN
INLOOK: LOOKUP X,LOOKIN
JRST AIN.7 ;cant find file
PUSH B,[0] ;oldch
PUSH B,[0] ;line number
PUSH B,[0] ;page number
ADDI B,4
HRRM B,.JBFF
ININBF: INBUF X,NIOB
JRST TRUE
PAGE
IFN SYDEV, < ;shunt SYS: to <LISP>'s dir (or wherever).
SYSDEV: MOVSI A,(SIXBIT /SYS/)
CAME A,DEV
PRET
IFG OPSYS,<MOVSI A,(SIXBIT /DSK/)>
IFLE OPSYS,<MOVE A,SYSNUM>
MOVEM A,DEV
IFG OPSYS,<PSAVE SYSNUM
PREST PPN >
PRET
>
ENTR:
LOOKIN: BLOCK 4
EXT=LOOKIN+1
PPN=LOOKIN+3
PAGE
SETOUT: PSAVE A
PCALL IOSUB ;get device and file name
MOVEM A,ENTR ;file name
SETZM ENTR+2 ;zero creation date
PREST A
DPB A,[POINT 4,OUINIT,ACFLD] ;setup channel numbers
DPB A,[POINT 4,OUTENT,ACFLD]
DPB A,[POINT 4,OUTOBF,ACFLD]
HRRZ B,CHTAB(A)
MOVEI A,CHDAT(B)
HRLM A,DEVO+1
MOVE A,DEV
MOVEM A,DEVO
CALLI A,DEVCHR
TLNN A,OUTB
JRST AOUT.2 ;not output device
TLNN A,AVLB
JRST AOUT.4 ;not available
HLLZS OUINIT
MOVEI A,13
SKIPGE CHNAM(B)
HRRM A,OUINIT ;BINARY-OUTBIN.
OUINIT: INIT X,X ;INIT CHN#,STATUS
DEVO: X ;SIXBIT /DEV/
X ;XWD OBUF,0
JRST AOUT.4 ;cant init
PUSH B,DEV
OUTENT: ENTER X,ENTR
JRST OUTERR ;cant enter
PUSH B,[LPTLL] ;linelength
PUSH B,[LPTLL] ;chrct
PUSH B,[LPTPL] ;pagelength
PUSH B,[0] ;linct
ADDI B,4
HRRM B,.JBFF
OUTOBF: OUTBUF X,NIOB
JRST POPAJ
OUTERR: MOVE A,DEVDAT
LDB B,[POINT 3,ENTR+1,35]
CAIE B,2
ERRE1 ^D19,[SIXBIT /DIRECTORY FULL!/]
ERRE1 ^D20,[SIXBIT /FILE IS WRITE PROTECTED!/]
PAGE
INCNT: MOVEI A,NIL ;(CLOSE (RDS NIL))
PSAVE [JRST CLOSE]
RDS: PSAVE INCH#
PCALL IOSEL
TLNE A,OUTM ;test to see if it is an input channel
ERRL0 ^D131,[SIXBIT/NO INPUT - RDS!/]
SKIPN TT
MOVEI TT,TTOCH-CHOCH ;tty deselect
MOVEI D,CHOCH(TT)
HRLI D,OLDCH
BLT D,CHLINE(TT) ;save channel data
JUMPE A,ITTYRE ;select tty
DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
DPB A,[POINT 4,TYI2Y,ACFLD]
DPB A,[POINT 4,TYI2Z,ACFLD]
HRRM B,TYI3 ;set up tyi parameters
HRRM B,TYI3A
MOVSI B,CHOCH(C)
INC3: HRRI B,OLDCH
BLT B,LINUM ;restore channel data
MOVEM T,TYID
FOO PREST VINC
EXCH A,INCH ;flags,,channel#.
IOEND: HRRZS A
JUMPN A,FIXI
PRET
ITTYRE: MOVE T,[JRST TTYI] ;reselect tty
MOVSI B,TTOCH
JRST INC3
PAGE
OUTCNT: MOVEI A,NIL ;(CLOSE (WRS NIL))
PSAVE [JRST CLOSE]
WRS: PSAVE OUTCH#
PCALL IOSEL
TLNN A,OUTM ;is it output channel
JUMPN A,[ERRL0 ^D132,[SIXBIT /NO OUTPUT - WRS!/]]
SKIPN TT
MOVEI TT,TTOLL-CHLL ;tty deselect
MOVEI D,CHLL(TT)
HRLI D,LINL
BLT D,CHVP(TT) ;save channel data
JUMPE A,OTTYRE ;return to tty
DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
HRRM B,TYO5 ;set up tyo2 parameters
MOVSI B,CHLL(C)
OUTC3: HRRI B,LINL
BLT B,LNCT ;get channel data
MOVEM T,TYOD
FOO PREST VOUTC
EXCH A,OUTCH ;flags,,channel#.
JRST IOEND
OTTYRE: MOVE T,[JRST TTYO]
MOVSI B,TTOLL ;tty reselect
JRST OUTC3
PAGE
IOSEL: PCALL GCHNO ;convert into channel number
SKIPE TT,A
ADDI TT,INUM0
EXCH TT,-1(P)
SKIPE TT
HRRZ TT,CHTAB(TT)
JUMPE A,CPOPJ
SKIPE C,CHTAB(A)
SKIPN T,CHNAM(C)
JRST CPOPJ1
HLL A,T
MOVEI B,POINTR(C)
MOVEI T,COUNT(C)
HRLI T,(SOSG)
PRET
CLOSE: PCALL GCHNO ;convert into channel number
ICLOSE: JUMPE A,CPOPJ ;don't close terminal cannel
SKIPE D,CHTAB(A)
SETZM CHNAM(D) ;blast channel name
DPB A,[POINT 4,.+1,ACFLD]
RELEASE X, ;release channel
HRRZS CHTAB(A) ;release channel table entry
JRST FIXI
;convert A into channel number
GCHNO: SKIPE A
SUBI A,INUM0
CAIG A,NIOCH
JUMPGE A,CPOPJ
ADDI A,INUM0
ERRE1 ^D21,[SIXBIT /IS NOT A CHANNEL NAME!/]
AOUT.2:
AIN.2: MOVE A,DEVDAT
ERRE1 ^D22,[SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4: MOVE A,DEVDAT
ERRE1 ^D23,[SIXBIT /DEVICE NOT AVAILABLE!/]
AIN.7: MOVE A,DEVDAT
ERRE1 ^D24,[SIXBIT /CAN'T FIND FILE!/]
SUBTTL PRINT --- PAGE 9
PRINT: MOVEI R,TYO
PCALL PRIN1
TERPRI: PSAVE A
MOVEI A,CRLF
TERPR1: PCALL TYO
CPOPAJ: JRST POPAJ
EJECT: MOVEI A,CR
PCALL TYO
MOVEI A,FORMF
PCALL TYO
JRST FALSE
PRINC: PSAVE A
PCALL GTFCH
JRST TERPR1
PRIN2: SKIPA R,.+1
PRIN1: HRRZI R,TYO ;<HRRZI> = <551>, NEGATIVE FOR PRIN2.
PSAVE A
PCALL PRINTA
JRST POPAJ
PRINTA: HLRZ B,SLSH ;PRIN3 OR PRIN3C SET BY SCANSET
SKIPGE R
MOVEI B,PRIN4
HRRM B,PRIN5
PRINT4: PSAVE A
JSP D,PATMTP
JRST PRINT1
XCT "(",CTY
PRINT3: MOVE A,TT ;[if 0 --> NIL's 777777 --> ill mem ref].
PCALL PRINT4
CDRA A,@(P)
JUMPE A,PRINT2
MOVEM A,(P)
XCT " ",CTY
JSP D,PATMTP
JRST .+2
JRST PRINT3
XCT ".",CTY
XCT " ",CTY
PCALL PRIN1A
PRINT2: XCT ")",CTY
JRST POPAJ
PAGE
PRINT1: PSAVE CPOPAJ
PRIN1A: JUMPE TT,PRINIC ;inum
JUMPL TT,PRINL ;not a Lisp expression
CDRA A,(A)
CAIN TT,ID
JUMPN A,PRINN
CAIL TT,CODMIN
JRST PCODE
JUMPN A,@PRITAB-ATMIN-1(TT) ;go to print routine for the given type
PRINL: XCT "#",CTY
HLRZ A,-1(P)
JUMPE A,.+3 ;usually there is no left half
PCALL PRINL1
XCT ",",CTY
HRRZ A,-1(P)
PRINL1: MOVEI C,8
PRINI3: JUMPL A,[MOVE B,0 ;case of -2^35
MOVEI A,1
DIVI A,(C)
JRST .+2]
IDIVI A,0(C)
HRLM B,(P)
SKIPE A
PCALL .-3
JRST FP7A1
PRITAB: BPRI ;negative bignum
BPRI+1 ;positive bignum
PRINI1 ;integer
PRINO ;floating point number
PSTR ;string
PVEC ;vector
PAGE
PRINL2: MOVEI R,TYO
JRST PRINL1
PRINI1: SKIPA A,(A)
PRINIC: SUBI A,INUM0
FOO CDRA C,VBASE
SUBI C,INUM0
JUMPGE A,PRINI2
XCT "-",CTY
MOVNS A
PRINI2: PCALL PRINI3
PRINI4:
IFN ROCT,<CAIN C,10
JRST POCTNM>
CAIN C,TEN
FOO SKIPE %NOPOINT
PRET
MOVEI A,"."
JRST (R)
IFN ROCT,<
POCTNM: JUMPL R,CPOPJ
MOVEI A,"L"
JRST (R) >
PVEC: PSAVE -1(A)
HRLI A,(POINT 18)
PSAVE A
MOVEI A,"["
PCALL (R)
JRST PVECL+1
PVECL: XCT ",",CTY
ILDB A,(P)
PCALL PRINT4
SOSL -1(P)
JRST PVECL
MOVEI A,"]"
P2DROP
JRST (R)
PCODE: XCT "#",CTY
XCT "#",CTY
JRST PRINL1
CTY: JSA A,TYOI
TYOI: X
PSAVE A
LDB A,[POINT 6,-1(A),ACFLD]
PCALL (R)
PREST A
JRA A,(A)
PAGE
PRINN:
FOO MOVEI B,PNAME
PCALL GET4
JUMPE A,PRINL
CARA A,D
PCALL PRIDST
ILDB A,C
JUMPE A,CPOPJ ;special case of null character
PRIN2X: JUMPL R,PRIN4 ;never slash
LDB B,SL1FLD
JRST PRIN2N(B) ;1 for no slash
PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
PRIN2N: PCALL SLSHPR ;slashify
PRIN4: PCALL (R)
ILDB A,C
PRIN5: JUMPN A,PRIN3+X ;prin4 for never slash
PRET
PSTR: PCALL PRIDST
MOVE A,STRBEG
JRST PSTR3
PSTREC: PCALL (R)
MOVE A,STREND
PSTR3: SKIPL R ;dont print " if no slashify
PSTR2: PCALL (R)
ILDB A,C
CAMN A,STREND
JRST PSTREC
JUMPN A,PSTR2
MOVE A,STREND
JUMPGE R,(R)
PRET
PRIDST: MOVEI C,2(SP)
PCALL PNAMU3
PUSH C,[0]
HRLI C,(POINT 7,0,35)
HRRI C,2(SP)
PRET
SLSHPR: PSAVE A
HRRZ A,SLSH
PCALL (R)
JRST POPAJ
PAGE
PRINO: MOVE A,(A)
SETZB B,C
JUMPG A,FP1
JUMPE A,FP3
MOVNS A
XCT "-",CTY
FP1: CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP3: MULI A,400
ASHC B,-243(A)
MOVE A,B
SETZM FPTEM#
PCALL FP7
XCT ".",CTY
MOVNI T,8
ADD T,FPTEM
MOVE B,C
FP3A: MOVE A,B
MULI A,TEN
PCALL FP7B
SKIPE B
AOJL T,FP3A
PRET
FP4: MOVNI C,6
MOVEI TT,0
FP4A: ADDI TT,1(TT)
XCT FCP(B)
TRZA TT,1
FMPR A,@FCP+1(B)
AOJN C,FP4A
PSAVE TT
MOVNI B,-2(B)
DPB B,[POINT 2,FP4C,11]
PCALL FP3
MOVEI A,"E"
PCALL (R)
FP4C: XCT "+"+X,CTY
PREST A
FP7: JUMPE A,FP7B
IDIVI A,TEN
AOS FPTEM
HRLM B,(P)
JUMPE A,FP7A1
PCALL FP7
FP7A1: HLRE A,(P)
FP7B: ADDI A,"0"
JRST (R)
PAGE
353473426555 ;1e32
266434157116 ;1e16
FT8: 1.0E8
1.0E4
1.0E2
1.0E1
FT: 1.0E0
026637304365 ;1e-32
113715126246 ;1e-16
146527461671 ;1e-8
163643334273 ;1e-4
172507534122 ;1e-2
FT01: 175631463146 ;1e-1
FT0:
FCP: CAMLE A,FT0(C)
CAMGE A,FT(C)
XWD C,FT0
SUBTTL SUPER FAST TABLE DRIVEN READ --- PAGE 10
;magic scanner table bit definitions
;bit 0=0 iff slashified as nth id character
;bit 1=0 iff slashified as 1st id character
;bits 2-5 ratab index
;bits 6-8 dotab index
;bits 9-10 strtab index
;bits 11-13 idtab index
;bits 14-16 exptab index
;bits 17-19 rdtab index
;bits 20-25 ascii to radix 50 conversion
;bits used by the alternative SCANner
;bits 26-29 ratab index
;bits 30-31 strtab index
;bits 32-34 idtab index
;bit 35=0 iff slashified as 1st id character
;bit 32=0 iff slashified as nth id character
;The following 8 words are modified by SCANSET and SCANRESET
IGEND: CRLF
STRBEG: DBLQT ;string start
STREND: DBLQT ;string end
SLSH: XWD PRIN3,"!" ;slashtest,slashifier
SL1FLD: POINT 1,CHRTAB(A),1
RATFLD: POINT 4,CHRTAB(A),5
STRFLD: POINT 2,CHRTAB(A),10
IDFLD: POINT 3,CHRTAB(A),13
DOTFLD:
NUMFLD: POINT 3,CHRTAB(A),8
EXPFLD: POINT 3,CHRTAB(A),16
RDFLD: POINT 3,CHRTAB(A),19
R50FLD: POINT 6,CHRTAB(A),25
;magic state flags in t
EXP==1 ;exponent
NEXP==2 ;negative exponent
SAWDOT==4 ;saw a dot (.)
MINSGN==10 ;negative number
IFN ROCT,<OCTNM==20 ;octal number (saw a L)
RDIG==6 >
IFE ROCT,RDIG==5
;atom type in R for SCAN
IDCLS==0 ;identifier
STRCLS==1 ;string
NUMCLS==2 ;number
DELCLS==3 ;delimiter
PAGE
;macros for scanner table
DEFINE RAD50 (X)<
IFB <X>,<R50VAL=0>
IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
IFIDN <"X"><".">,<R50VAL=45>
IFIDN <"X"><"$">,<R50VAL=46>
IFIDN <"X"><"%">,<R50VAL=47>
IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
DEFINE TABIN (SN,S1,R,D,S,I,E,RD,R50,RE<2>,SE<3>,IE<2>,S1E<0>)<
XLIST
IRPC R50< RAD50 (R50)
BYTE (1)SN,S1(4)R(3)D(2)S(3)I,E,RD(6)R50VAL(4)RE(2)SE(3)IE(1)S1E>
LIST>
DEFINE LET (X)<
TABIN (0,0,5,2,3,4,2,0,X)>
DEFINE SCNLET (X)<
TABIN (1,1,5,2,3,4,2,0,X,5,3,4,1)>
DEFINE DELIMIT (X,Y)<
TABIN (0,0,2,2,3,2,2,Y,X)>
DEFINE IGNORE (X)<
TABIN (0,0,3,2,3,2,2,0,X,3)>
PAGE
CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >,1,1,1)
;null
LET (< >)
IGNORE (< >)
;tab,lf,vtab,ff,cr
LET (< >)
;16 to 31
TABIN (0,0,0,0,0,0,0,0,< >,0,0,0)
;igmrk
LET (< >)
;33 -- <ESC> JUST A LETTER WHEN IN A FILE.
LET (< >)
;34 to 36
IGNORE (< >)
;37 (EOL) and space
TABIN (0,0,4,2,3,3,2,0,< >,4,3,3)
;! the new slashifier
TABIN (0,0,9,2,2,2,2,0,< >,9,2)
;"
LET (< $>)
;#$
TABIN (0,0,0,0,3,0,0,0,<%>,0,3,0)
;% is comment start
LET (< >)
;&
TABIN (0,0,2,2,3,4,2,5,< >)
;' the new quote character
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)
;*
TABIN (0,0,3,2,3,4,2,0,< >)
;+
TABIN (0,0,3,2,3,2,2,0,< >)
;, ignored for READ, delimit for SCAN
TABIN (0,0,6,2,3,4,2,0,< >)
;-
TABIN (0,0,7,3,3,2,2,4,<.>,7)
LET (< >)
;/ old slashifyer is just a letter now
TABIN (1,0,8,RDIG,3,4,3,0,<0123456789>,8,3,4)
LET (< >)
;:;
DELIMIT (< >,2)
;< super paranthesis
LET (< >)
;=
DELIMIT (< >,3)
;> super paranthesis
LET (< >)
;?
LET (< >)
;@ old quote character is just a letter now
SCNLET (<ABCD>)
TABIN (1,1,5,4,3,4,2,0,<E>,5,3,4,1)
;E exponent for floating point number
SCNLET (<FGHIJK>)
IFE ROCT,SCNLET(<L>)
IFN ROCT,<
TABIN (1,1,5,5,3,4,2,0,<L>,5,3,4,1)
;L ends an octal number >
SCNLET (<MNOPQRSTUVWXYZ>)
DELIMIT (< >,6)
;[ vector start
LET (< >)
;\
DELIMIT (< >,3)
;] vector end
LET (< >)
;^_`
SCNLET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
;lower case
LET (< >)
;{
DELIMIT (< >,3)
;175 -- ALTMODE (ALSO DECUS' 33 CONVERTED DURING TTI INPUT).
LET (< >)
;~
DELIMIT (< >,6)
;rubout
PAGE
IDCHTAB:BLOCK "?" ;table of character ids. updated by INTERN and
FOO XWD 0,QST
BLOCK 100-"?"-1 ; REMOB. refered to by READCH and EXPLODE.
READCH: PCALL TYI
RECH1: TRNN A,100
SKIPA C,IDCHTAB(A)
HLRZ C,IDCHTAB-100(A)
TRNE C,-1 ;is it in character id table ?
JRST RETC ;yes! return it
PSAVE TT ;save TT and
PSAVE T ; T for EXPLODE
LSH A,35
MOVE C,SP
PUSH C,A
PCALL INTER0
PREST T
PREST TT
PRET
READP1: SETZM NOINFG
READ0: PSAVE TYID
PSAVE OLDCH
SETZM OLDCH#
HRLI A,(JRST)
MOVEM A,TYID
PCALL READ+1
PREST OLDCH
PREST TYID
PRET
RDRUB: MOVEI A,CR
PCALL TTYO
MOVEI A,LF
PCALL TTYO
SKIPA P,PSAV#
READ: SETZM NOINFG# ;0 means intern
SKIPN OLSCNV
JRST READD
SETZ A,
PCALL SCANSET
PSAVE A
PCALL READD
EXCH A,(P)
PCALL SCANSET
JRST POPAJ
READD: MOVEM P,PSAV
PCALL READ1
SETZM PSAV
PRET
READ1: PCALL RATOM
PRET ;atom
XCT RDTAB2(B)
JRST READ1 ;try again
RDTAB2: JRST READ2 ;0 (
JFCL ;1 )
JRST READ4 ;2 <
JFCL ;3 ],>,$
JFCL ;4 .
JRST RDQT ;5 '
JRST READVC ;6 [
READ2: PCALL RATOM
JRST READ2A ;atom
XCT RDTAB(B)
READ2A: PSAVE A
PCALL READ2
PREST B
JRST XCONS
RDTAB: PCALL READ2 ;0 (
JRST FALSE ;1 )
PCALL READ4 ;2 <
JRST READ5 ;3 ],>,$
JRST RDT ;4 .
PCALL RDQT ;5 '
PCALL READVC ;6 [
RDTX: PCALL RATOM
PRET ;atom
XCT RDTAB2(B)
DOTERR: SETZM OLDCH
ERRL0 ^D133,[SIXBIT /DOT CONTEXT ERROR!/]
RDT: PCALL RDTX
PSAVE A
PCALL RATOM
JRST DOTERR
CAIN B,1
JRST POPAJ
CAIE B,3
JRST DOTERR
MOVEM A,OLDCH
JRST POPAJ
READ4: PCALL READ2
MOVE B,OLDCH
CAIE B,ALTMOD
TYI1: SETZM OLDCH ;kill the > or ]
PRET
READ5: MOVEM A,OLDCH ;save > or ] or $
JRST FALSE ;and return nil
RDQT: PCALL READ1
QTIFY: PCALL NCONS
FOO HRLI A,CQUOTE
JRST DCONSA
;skip a comment
COMENT: CAIN A,IGCRLF ;^Z ?
JRST COMIGN ;yes. end on CRLF
MOVE A,IGEND ;no. end on IGEND
HRRM A,COMM+1 ;set end char
COMM: PCALL TYIC ;AR4 must contain 1 here
CAIE A,CRLF+X
JRST COMM
PRET
;skip a super (^Z) comment
COMIGN: PCALL TYID1 ;AR4 must contain 1 here
CAIE A,CRLF
JRST COMIGN
PRET
PAGE
READVC: PCALL READ2
MOVE B,OLDCH
ENDVC: CAIN B,"]"
SETZM OLDCH
LTOVEC: JUMPE A,CPOPJ
PSAVE A ;save list
CDRA A,(A)
PCALL LENGTH
PCALL MKVECT ;make a vector
CDRA B,(A)
EXCH A,(P)
MOVSI C,(POINT 18,(B))
MOVS A,(A)
IDPB A,C
CARA A,A
JUMPN A,.-3
JRST POPAJ
PAGE
;atom parser
RATOM: SETZB T,R ;IDCLS in R
HRLI C,(POINT 7,0,35)
HRRI C,(SP)
SETZM 1(C) ;clear first word
MOVEI AR4,1
RATOM2: PCALL TYID1
LDB B,RATFLD
JRST RATAB(B)
RATAB: PCALL COMENT ;0 comment
JRST RATOM2 ;1 null
JRST RATOM3 ;2 delimit
JRST RATOM2 ;3 ignore
PCALL TYIC ;4 !
JRST RDID ;5 letter
JRST RDNMIN ;6 -
JRST RDOT ;7 .
JRST RDNUM ;8 digit
JRST RDSTR ;9 string
;a real dotted pair
RDOT2: MOVEM A,OLDCH
MOVEI A,"."
RATOM3: LDB B,RDFLD
HRRI R,DELCLS ;delimiter
CPOPJ1: PSKPRT ;non-atom (ie a delimiter)
PRET
;dot handler
RDOT: PCALL TYID1
LDB B,DOTFLD
JRST DOTAB(B)
DOTAB: PCALL COMENT ;0 comment
JRST RDOT ;1 null
JRST RDOT2 ;2 delimit
JRST RDOT2 ;3 dot
JRST RDOT2 ;4 E
IFN ROCT,JRST RDOT2 ;5 L
MOVEI B,0 ;6 (5) digit
IDPB B,C
TLO T,SAWDOT
JRST RDNUM
PAGE
;string scanner
STRTAB: PCALL COMENT ;0 comment
JRST RDSTR ;1 null
JRST STR2 ;2 delimit
IDPB A,C ;3 string element
RDSTR: PCALL TYID1
LDB B,STRFLD ;A huge string (e.g. missing close-quote)
JRST STRTAB(B) ; will overflow SPDL and clobber I/O bufs.
STR2: PCALL TYID1
LDB B,STRFLD
CAIN B,2
JRST RDSTR-1
MOVEM A,OLDCH
HRRI R,STRCLS ;string
LMKSTR: PCALL IDEND
MSTR1: PCALL IDSUB
PCALL PNAMAK
HRLI A,STRNG
JRST DCONSA
;identifier scanner
IDTAB: PCALL COMENT ;0
JRST RDID+1 ;1 null
JRST MAKID ;2 delimit
PCALL TYIC ;3 !
RDID: IDPB A,C ;4 letter or digit
PCALL TYID1
LDB B,IDFLD
JRST IDTAB(B)
PAGE
;number scanner
NUMTAB: PCALL COMENT ;0 comment
JRST RDNUM+1 ;1 null
JRST NUMAK ;2 delimit
JRST RDNDOT ;3 dot
JRST RDE ;4 e
IFN ROCT,JRST OCTNUM ;5 L
RDNUM: IDPB A,C ;6 (5) digit
PCALL TYID1
LDB B,NUMFLD
JRST NUMTAB(B)
RDNDOT: TLOE T,SAWDOT
JRST NUMAK ;two dots - delimit
MOVEI A,0
JRST RDNUM
RDNMIN: TLO T,MINSGN
JRST RDNUM+1
;exponent scanner
RDE: TLO T,EXP
MOVEI A,0
IDPB A,C
PCALL TYID1
CAIN A,"-"
TLOA T,NEXP
CAIN A,"+"
JRST RDE2+1
JRST RDE2+2
EXPTAB: PCALL COMENT ;0
JRST RDE2+1 ;1 null
JRST NUMAK ;2 delimit
RDE2: IDPB A,C ;3 digit
PCALL TYID1
LDB B,EXPFLD
JRST EXPTAB(B)
IFN ROCT,<
OCTNUM: TLO T,OCTNM
PCALL TYID1
LDB B,NUMFLD
SOJG B,NUMAK
JUMPL B,OCTNUM+1
PCALL COMENT
JRST B,OCTNUM+1 >
PAGE
;semantic routines
;identifier interner and builder
IDEND: TDZA A,A
IDEND1: IDPB A,C
TLNE C,760000
JRST IDEND1
PRET
MAKID: MOVEM A,OLDCH
PCALL IDEND
SKIPE NOINFG
JRST NOINTR ;dont intern it
INTER0: PCALL INTER2 ;is it in oblist
PRET ;found
PCALL PNAIMK ;not there
MAKID2: SKIPGE C,IDCHPO# ;character id ?
JRST MKID2 ;no!
TRNN C,100
JRST .+3
HRLM A,IDCHTAB-100(C)
JRST MKID2
HRRM A,IDCHTAB(C)
MKID2: MOVE C,CURBUC
HLRZ B,@RHX2
PCALL CONS ;cons it into the oblist
HRLM A,@RHX2
JRST CAR
CURBUC: 0
;pname unmaker
PNAMUK: MOVE C,SP
PNAMUD: PCALL GETPNM
PNAMU3: CARA B,(A)
PUSH C,(B)
CDRA A,(A)
JUMPN A,PNAMU3
PRET
;idsub constructs a iowd pointer for a print name
IDSUB: HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVNS C
ADDI C,(SP)
HRLZS C
HRRI C,1(SP)
MOVEM C,IDPTR#
MOVEI B,1
ANDCAM B,(C) ;clear low bit
AOBJN C,.-1
PRET
NOINTR: PCALL IDSUB
PNAIMK: PCALL PNAMAK
JRST PNGNK1
PAGE
;identifier interner
INTERT: PCALL PNAMUK
INTER2: PCALL IDSUB
INTER1: MOVE B,1(SP) ;get first word of pname
LSH B,-1 ;right justify it
SETOM IDCHPO ;indicate no character id
TDNE B,[1777,,777777] ;character id ?
JRST INT1 ;no!
MOVE T,B
LSH T,-12
HLRZM T,IDCHPO ;is a character id
INT1: IDIVI B,BCKETS+X ;compute hash code
RHX2:
FOO HLRZ T,OBTBL(B+1) ;get bucket
MOVEM B+1,CURBUC ;save bucket number
MOVE C,T
JRST MAKID1
MAKID3: MOVE C,T ;save previous atom
CDRA T,(T) ;get next atom
MAKID1: JUMPE T,CPOPJ1 ;not in oblist
CARA A,(T) ;next id in oblist
FOO MOVEI B,PNAME
PCALL IGET
JUMPE A,[ERRL2 ^D167,[SIXBIT \MISSING PRINT NAME IN OBLIST!\]]
MOVE D,IDPTR ;found pname
MAKID5: JUMPE A,MAKID3 ;not the one
MOVS A,(A)
MOVE B,(A)
CAME B,(D)
JRST MAKID3 ;not the one
CARA A,A ;ok so far
AOBJN D,MAKID5
JUMPN A,MAKID3 ;not the one
CARA A,(T) ;this is it
CARA B,(C)
RPLCA A,(C)
RPLCA B,(T)
PRET
;pname builder
PNAMAK: MOVE T,IDPTR
MOVEI TT,C
PNAMB: MOVE A,(T)
PCALL FWCONS
PCALL NCONS
RPLCD A,(TT)
MOVE TT,A
AOBJN T,PNAMB
RETC: HRRZ A,C
PRET
PAGE
;number builder
NUMAK: MOVEM A,OLDCH
HRRI R,NUMCLS ;number
MOVEI A,0
IDPB A,C
IDPB A,C
HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVSI C,(POINT 7,0,35)
HRRI C,(SP)
TLNE T,SAWDOT+EXP
JRST NUMAK2 ;decimal number or flt pt
FOO MOVE A,VIBASE ;ibase integrer
SUBI A,INUM0
IFN ROCT,<TLNE T,OCTNM
MOVEI A,10 ;octal number >
PCALL NUM
NUMAK4:
MOVEI B,FIXNU
NUMAK6: TLNE T,MINSGN
MOVNS A
JRST MAKNUM
NUMAK2: PCALL NUM10
MOVEM A,TT
TLNN T,SAWDOT
JRST [PCALL FLOAT1 ;flt pt without fraction
MOVE TT,A
JRST NUMAK3]
PCALL NUM10 ;fraction part
EXCH A,TT
TLNN T,EXP
JUMPE AR5,NUMAK4 ;no exponent and no fraction
PCALL FLOAT1
EXCH A,TT
PCALL FLOAT1
MOVEI AR4,FT01
PCALL FLOSUB
FMPR A,B
FADRM A,TT
NUMAK3: PCALL NUM10 ;exponent part
MOVE AR5,A
MOVEI AR4,FT-1
TLNE T,NEXP
MOVEI AR4,FT01 ;-exponent
PCALL FLOSUB
FMPR TT,B ;positive exponent
MOVEI B,FLONU
MOVE A,TT
JFCL 10,FLOOV
JRST NUMAK6
PAGE
FLOSUB: MOVSI B,(1.0)
TRZE AR5,1
FMPR B,(AR4)
JUMPE AR5,CPOPJ
LSH AR5,-1
SOJA AR4,FLOSUB+1
;variable radix integer builder
NUM10: MOVEI A,TEN
NUM: HRRM A,NUM1
JFCL 10,.+1 ;clear carry0 flag
SETZB A,AR5
NUM2: ILDB B,C
JUMPE B,CPOPJ ;done
NUM1: IMULI A,X
ADDI A,-"0"(B)
NUM3: JFCL 10,RDBNM
AOJA AR5,NUM2
PAGE
INTERN: MOVEM A,AR5
PCALL INTERT ;is it in oblist
PRET ;found it
MOVE A,AR5 ;not there
CARA B,(A)
CAIE B,STRNG
JRST MAKID2 ;put it there
CDRA A,(A)
PCALL PNGNK1 ;make an id of it
JRST MAKID2
REMOB: JUMPE A,CPOPJ ;never remove NIL
JSP D,NILID ;return NIL if not an id
PSAVE A
PCALL INTERT
SKIPA B,CURBUC
JRST POPAJ ;not on oblist
RHX5:
FOO HLRZ C,OBTBL+X(B)
CARA T,(C)
CAMN T,A
JRST [CDRA TT,(C)
HRLM TT,@RHX5
JRST POPAJ]
REMOB3: MOVE TT,C
CDRA C,(C)
CARA T,(C)
CAME T,A
JRST REMOB3
CDRA T,(C)
RPLCD T,(TT)
SKIPGE C,IDCHPO ;character id ?
JRST POPAJ ;no!
TRNN C,100
JRST .+3
HRRZM IDCHTAB-100(C)
JRST POPAJ
HLLZM IDCHTAB(C)
POPAJ: PREST A
PRET
;Get print name for identifier or string. Return with skip if sucessful.
GETPNM: JSP D,ATMTYP
JRST .+2
NOPNAM: ERRL0 ^D134,[SIXBIT /NO PRINT NAME!/]
CDRA A,(A)
CAIN TT,STRNG ;is it a string?
JUMPN A,CPOPJ ;yes
CAIE TT,ID
JRST NOPNAM
FOO MOVEI B,PNAME
PCALL GET4
JUMPE A,NOPNAM ;didn't find it
CARA A,D
PRET
PAGE
;return NIL if argument is not on the oblist
.INTERNP:JSP D,NILID ;return NIL if not an id
MOVE AR5,A
PCALL GT1PNM ;get first word of pname
MOVE B,A
LSH B,-1
XCT INT1 ;compute hash code
XCT INT1+1 ;get bucket
EXCH A,T
MOVE B,AR5
JRST FLAGP1
;SKIPTO subr 1 arg. Skips reading until found character that matches
; first character in the argument
SKIPTO: MOVEI AR4,1
PSAVE A
PCALL GTFCH
PCALL COMM-1 ;read as comment
JRST POPAJ
RDSLSH: MOVE D,[POINT 18,NQUOT]
MOVE R,[POINT 7,[ASCIZ "%'!@/<>["]]
MOVEI B,(5B3+2B6+3B8+4B11+2B14) ;Letter
JUMPN A,RDSL2
MOVEI B,(3B8) ;Comment
AOJA D,RDSL2
RDSL1: DPB B,[POINT 18,CHRTAB(A),19]
ILDB B,D
RDSL2: ILDB A,R
JUMPN A,RDSL1
JRST SCANSET
NQUOT: <5B3+2B6+3B8+4B11+2B14+0B17>+<5B21+2B24+3B26+4B29+2B32+0B35>
<2B3+2B6+3B8+4B11+2B14+5B17>+<4B21+2B24+3B26+3B29+2B32+0B35>
<5B3+2B6+3B8+4B11+2B14+0B17>+<5B21+2B24+3B26+4B29+2B32+0B35>
<2B3+2B6+3B8+2B11+2B14+2B17>+<2B21+2B24+3B26+2B29+2B32+3B35>
<2B3+2B6+3B8+2B11+2B14+6B17>
PAGE
; SCAN -- GENERAL PURPOSE ADAPTER FOR LISP SCANNER
OLDSCN: CRLF ;IGEND
DBLQT ;STRBEG
DBLQT ;STREND
XWD PRIN3,"!" ;SLSH
POINT 1,CHRTAB(A),1 ;SL1FLD
POINT 4,CHRTAB(A),5 ;RATFLD
POINT 2,CHRTAB(A),10 ;STRFLD
POINT 3,CHRTAB(A),13 ;IDFLD
IGEND2: CRLF+X ;IGEND
STRBE2: DBLQT ;STRBEG
STREN2: DBLQT ;STREND
SLSH2: XWD PRIN3C,"!"+X ;SLSH
SL1F2: POINT 1,CHRTAB(A),35 ;SL1FLD
RATF2: POINT 4,CHRTAB(A),29 ;RATFLD
STRF2: POINT 2,CHRTAB(A),31 ;STRFLD
IDF2: POINT 3,CHRTAB(A),34 ;IDFLD
LETFLD: POINT 1,CHRTAB(A),32 ;ON IF LETTER OR DIGIT
ALLFLD: POINT 10,CHRTAB(A),35 ;ALL NEW FIELDS
SCANSET:JUMPN A,.+2
SKIPA B,[XWD OLDSCN,IGEND]
MOVE B,[XWD IGEND2,IGEND]
BLT B,IDFLD
EXCH A,OLSCNV# ;Get previous setting
PRET
PRIN3C: LDB B,LETFLD
JRST PRIN2N(B)
PAGE
SCAN: SETOM NOINFG
PCALL RATOM
SKIPA
PCALL READCH+1
FOO MOVEM A,SCNV
MOVEI A,INUM0(R)
PRET
UNREADCH:
PSAVE A
PCALL GTFCH
MOVEM A,OLDCH
JRST POPAJ
LETTER: MOVEI B,5B29+3B31+4B34+1B35
LET2: SUBI A,INUM0
DPB B,ALLFLD
JRST FALSE
DELIMITER:
SKIPA B,[2B29+3B31+2B34+0B35] ;A DELIMITER, NOT A LETTER.
IGNORE: MOVEI B,3B29+3B31+2B34+0B35
JRST LET2
PAGE
SCANINIT: SUBI A,INUM0
SUBI B,INUM0
HRRM A,IGST2 ;IGSTRT
MOVEM B,IGEND2 ;IGEND
MOVEI B,2B29+3B31+2B34+0B35 ;DELIMITER
MOVEI A,177
DPB B,ALLFLD
SOJG A,.-1
MOVE A,[XWD "A"-"Z"-1,"A"]
MOVEI B,5B29+3B31+4B34+1B35 ;LETTER
DPB B,ALLFLD
AOBJN A,.-1
MOVE A,[XWD "a"-"z"-1,"a"]
DPB B,ALLFLD
AOBJN A,.-1
MOVE A,[XWD "0"-"9"-1,"0"]
MOVEI B,8B29+3B31+4B34+0B35 ;DIGIT
DPB B,ALLFLD
AOBJN A,.-1
IGST2: MOVEI A,X
MOVEI B,0 ;IGSTRT
DPB B,ALLFLD
MOVEI A,-INUM0(AR4) ;STREND
MOVEM A,STREN2
MOVEI B,2
DPB B,STRF2
MOVEI A,-INUM0(C) ;STRBEG
MOVEM A,STRBE2
MOVEI B,9
DPB B,RATF2
MOVEI A,-INUM0(AR5)
HRRM AR5,SLSH2 ;SLASHIFIER
MOVEI B,4B29+3B31+3B34+0B35 ;SLASHIFIER
DPB B,ALLFLD
MOVEI A,0 ;NULL
MOVEI B,1B29+1B31+1B34+0B35 ;NULL
DPB B,ALLFLD
MOVEI A,"."
MOVEI B,7
DPB B,RATF2
SETZM CHRTAB+IGCRLF ;^Z IS ALWAYS A COMMENT-CHAR.
JRST FALSE
SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 11
IF1,PURGE CDR
CADDDR: SKIPA A,(A)
CADDAR: CARA A,(A)
CADDR: SKIPA A,(A)
CADAR: CARA A,(A)
CADR: SKIPA A,(A)
CAAR: CARA A,(A)
CAR: CARA A,(A)
PRET
CDDDDR: SKIPA A,(A)
CDDDAR: CARA A,(A)
CDDDR: SKIPA A,(A)
CDDAR: CARA A,(A)
CDDR: SKIPA A,(A)
CDAR: CARA A,(A)
CDR: CDRA A,(A)
PRET
CAADDR: SKIPA A,(A)
CAADAR: CARA A,(A)
CAADR: SKIPA A,(A)
CAAAR: CARA A,(A)
JRST CAAR
CDADDR: SKIPA A,(A)
CDADAR: CARA A,(A)
CDADR: SKIPA A,(A)
CDAAR: CARA A,(A)
JRST CDAR
CAAADR: SKIPA A,(A)
CAAAAR: CARA A,(A)
JRST CAAAR
CDDADR: SKIPA A,(A)
CDDAAR: CARA A,(A)
JRST CDDAR
CDAADR: SKIPA A,(A)
CDAAAR: CARA A,(A)
JRST CDAAR
CADADR: SKIPA A,(A)
CADAAR: CARA A,(A)
JRST CADAR
RPLACA: RPLCA B,(A)
PRET
RPLACD: RPLCD B,(A)
PRET
PAGE
QUOTE: CARA A,(A) ;car and quote duplicated for backtrace
PRET
AASCII: PCALL NUMVAL
LSH A,^D29
PNGNK2: PCALL BNCONS
PNGNK1:
FOO HRLI A,PNAME
PCALL DCONSA
PCALL NCONS
IDCONS: HRLI A,ID
JRST DCONSA
NCONS: HRLZS A
JRST DCONSA
CONS: EXCH B,A
XCONS: HRL A,B
DCONSA:
IFN CNSPRB,<
CAIN F,ILLAD
PCALL AGC>
EXCH A,(F)
EXCH A,F
AOS CONSVAL
PRET
FW0CNS: MOVEI A,0
FWCONS: JUMPN FF,FWC1
EXCH A,FWC0#
PCALL AGC
EXCH A,FWC0
FWC1: EXCH A,(FF)
EXCH A,FF
PRET
PAGE
IFE STL,<
SASSOC: PCALL SAS1
JCALLF 0,(C)
PRET
SAS0: CARA B,T
SAS1: JUMPE B,CPOPJ
MOVS T,(B)
MOVS TT,(T)
CAIE A,(TT)
JRST SAS0
CDRA A,T
JRST CPOPJ1
ATSOC: PCALL SAS1
JRST FALSE > ;end of IFE STL
IFN STL,<
ATSOC: EXCH A,B
PCALL GET4
SKIPE A
CDRA A,TT >
PRET
REVERSE:SKIPN T,A
PRET
MOVEI A,NIL
HLL A,(T)
CDRA T,(T)
PCALL DCONSA
JUMPN T,.-3
CPOPJ: PRET
LENGTH: MOVEI B,0
LNGTH1: JSP D,ATMTYP
JRST FIX1
CDRA A,(A)
AOJA B,LNGTH1
LAST: MOVE C,A
CDRA A,(A)
JSP D,NATMTYP
JRST LAST
JRST RETC
NATMTYP:SETZ TT,
CAILE A,INUMIN
JRST 1(D)
CARA TT,(A)
CAILE TT,ATMIN
JRST 1(D)
JRST (D)
PAGE
PATOM: MOVEI D,TRFA
PATMTP: JUMPE A,NILIN
SETZ TT,
CAILE A,INUMIN
JRST (D) ;inum
CAIGE A,@GCP1 ;Base of FWS
CAIGE A,@GCPP1 ;Base of FS
SOJA TT,(D) ;not a Lisp cell
NILIN: CARA TT,(A)
CAILE TT,ATMIN
JRST (D) ;atom
JRST 1(D)
ATOM: MOVEI D,TRFA
ATMTYP: SETZ TT,
CAILE A,INUMIN
JRST (D) ;inum
CARA TT,(A)
CAILE TT,ATMIN
JRST (D) ;atom
JRST 1(D)
PAIRP: JSP D,ATMTYP
MOVEI A,NIL
PRET
CONSTANTP:JSP D,ATMTYP
CAIN TT,ID
MOVEI A,NIL
PRET
STRINGP:JSP D,ATMTYP
CAIE TT,STRNG
MOVEI A,NIL
PRET
NUMBERP:JSP D,ATMTYP
CAILE TT,FLONU
FALSE: MOVEI A,NIL
PRET
FIXP: JSP D,ATMTYP
CAILE TT,FIXNU
MOVEI A,NIL
PRET
FLOATP: JSP D,ATMTYP
CAIE TT,FLONU
MOVEI A,NIL
PRET
INUMP: CAIG A,INUMIN
MOVEI A,NIL
PRET
PAGE
BIGP: JSP D,ATMTYP
CPOSNU: CAILE TT,POSNU
JRST FALSE
JUMPE TT,FALSE
PRET
IDP: MOVEI D,TRUE
NILID: CAILE A,INUMIN
JRST FALSE
HLLE TT,(A)
AOJE TT,(D)
JRST FALSE ;return NIL if not an id
;give error if not id
CHKID: CAILE A,INUMIN
JRST NOID
HLLE TT,(A)
AOJE TT,(D)
NOID: ERRE1 ^D25,[SIXBIT /IS NOT AN IDENTIFIER!/]
EQ: CAMN A,B
TRFA: JRST TRUE
JRST FALSE
ZEROP: JSP D,ONUMV
JRST FALSE ;BIGNUM CAN'T BE ZERO
NOT:
NULL: JUMPN A,FALSE
TRUE:
FOO MOVEI A,TRUTH
PRET
LITER: PCALL .INTERNP
JUMPE A,CPOPJ
ROT T,7
CAIL T,"A"
CAILE T,"z"
JRST FALSE
CAILE T,"Z"
CAIL T,"a"
JRST RETB
JRST FALSE
DIGIT: PCALL .INTERNP
JUMPE A,CPOPJ
ROT T,7
CAIL T,"0"
CAILE T,"9"
JRST FALSE
JRST RETB
PAGE
IF1,<PURGE GET> ;MONSYM has defined GET, so purge it.
GETD:
FOO MOVEI B,FUNCELL
GET: JSP D,NILID ;return NIL if not id
IGET: PCALL GET1
SKIPE A
GET2: CARA A,D
PRET
GET1: CDRA A,(A)
GET4: JUMPE A,CPOPJ
GET0: MOVS TT,(A)
MOVS D,(TT)
CAIN B,(D)
PRET
CARA A,TT
JUMPN A,GET0
PRET
IFE STL,<
GETL: CDRA A,(A)
GETL0: CARA T,(A)
CARA T,(T)
MOVE C,B
GETL1: MOVS TT,(C)
CAIN T,(TT)
JRST CAR
CARA C,TT
JUMPN C,GETL1
CDRA A,(A)
JUMPN A,GETL0
PRET >
REMD:
FOO MOVEI B,FUNCELL
REMPROP:JSP D,NILID ;return NIL if not id
REMP1: MOVE T,A
CDRA A,(T)
JUMPE A,CPOPJ ;we are done if it is not there
MOVS TT,(A)
MOVS D,(TT)
CAIE B,(D)
JRST REMP1
HLRM TT,(T)
JUMPN T,GET2
HLROM TT,CNIL3 ;reset NIL
JRST GET2
PAGE
PUTD: EXCH A,C
IPUTD: PCALL XCONS
EXCH A,C
FOO MOVEI B,FUNCELL
PUT: JSP D,CHKID
MOVE T,A
MOVE A,B
JSP D,CHKID
MOVE A,T
PCALL GET1
JUMPN A,CSET1
MOVE A,C
PCALL XCONS
CDRA B,(T)
PCALL CONS
RPLCD A,(T)
JUMPN T,CDAR
RPLCD A,CNIL3 ;set NIL
JRST CDAR
CSET1:
FOO CAIN B,VALUE
CARA TT,D
RPLCD C,(TT)
JRST RETC
IFE STL,<
DEFPROP:
CDRA C,(A)
CDRA B,(C)
CARA A,(A)
CARA B,(B)
CARA C,(C)
PSAVE A
PCALL PUT
JRST POPAJ >
MKCODE: PCALL NUMVAL
IMKCODE:HRLI A,CODE
JRST DCONSA
CODEP: JSP D,ATMTYP
CAIGE TT,CODMIN
JRST FALSE
CAIL TT,ID
MOVEI A,NIL
PRET
PAGE
FLAGP: JSP D,NILID
CDRA A,(A)
FLAGP1: PCALL MEMQ+1
JUMPN A,TRUE
PRET
FLAG: MOVEI D,FLAG1
FLAGO: HRRM D,FLAGX
MOVE T,A
MOVE A,B
JSP D,CHKID ;flag indicator must be id
FLAGL: JUMPE T,FALSE
CARA A,(T)
FLAGX: PCALL X
CDRA T,(T)
JRST FLAGL
FLAG1: JSP D,CHKID ;may only flag id
CDRA A,(A)
PCALL MEMQ+1
JUMPN A,CPOPJ
CARA C,(T)
CDRA A,(C)
PCALL XCONS
FLAG2: RPLCD A,(C)
JUMPN C,CPOPJ
RPLCD A,CNIL3
PRET
REMFLAG:JSP D,FLAGO
JSP D,NILID
FLAG3: MOVE C,A
CDRA A,(C)
JUMPE A,CPOPJ
CARA D,(A)
CAIE B,(D) ;B is preserved by XCONS
JRST FLAG3
CDRA A,(A)
JRST FLAG2
PAGE
EQUAL: MOVE C,P ;Unfortunately, if BIGNUMs are involved here,
EQUAL1: CAMN A,B ; potential AGC so save your variables.
JRST TRUE
JSP D,PATMTP
SKIPA T,TT ;ATOM
HRROI T,(TT)
EXCH A,B
JSP D,PATMTP
JRST EQLATM ;ATOM
AOJGE T,NOEQL ;not atom but first arg was
PSAVE A
PSAVE B
CDRA A,TT
CARA B,(B)
PCALL EQUAL1
PREST B
PREST A
CDRA A,(A)
CDRA B,(B)
JRST EQUAL1
EQLATM: CAME T,TT ;same atom type ?
JRST NOEQL ;no, try for floating point
JUMPLE TT,NOEQL ;Inum and non lisp cell adresses must be EQ
CAILE TT,POSNU ;Bignum
CAIN TT,STRNG
JRST EQS
CAIN TT,VECT
JRST EQV
CDRA A,(A)
CDRA B,(B)
MOVE A,(A)
CAMN A,(B)
JRST TRUE
NOEQL: MOVE P,C
JRST FALSE
PAGE
EQS: CDRA D,(A)
CDRA TT,(B)
EQS2: JUMPE D,NOEQL
MOVS D,(D)
MOVS TT,(TT)
MOVE B,(TT)
CAME B,(D)
JRST NOEQL
HLRZS D
HLRZS TT
JUMPN TT,EQS2
JUMPN D,NOEQL
JRST TRUE
EQV: CDRA TT,(A)
CDRA D,(B)
MOVE B,-1(TT)
CAME B,-1(D)
JRST NOEQL ;different size
PSAVE B
HRLI TT,(POINT 18)
PSAVE TT
HRLI D,(POINT 18)
PSAVE D
EQV2: ILDB A,(P)
ILDB B,-1(P)
PCALL EQUAL1
SOSL -2(P)
JRST EQV2
P3DROP
JRST TRUE
PAGE
SUBAS==EXARG
SUBBS==EXARG+1
SUBST: MOVEM A,SUBAS# ;Recurse..find subportion in C =B, and
MOVEM B,SUBBS# ; re-CONS with A instead.
SUBS0: MOVE A,SUBAS
MOVE B,SUBBS
PSAVE C
MOVE A,C
PCALL EQUAL
PREST C
JUMPN A,SUBS3
CAILE C,INUMIN
JRST SUBS1
CARA T,(C)
CAILE T,ATMIN
JRST SUBS1
PSAVE C
CARA C,(C)
PCALL SUBS0
EXCH A,(P)
CDRA C,(A)
PCALL SUBS0
PREST B
JRST XCONS
SUBS1: SKIPA A,C
SUBS3: HRRZ A,SUBAS
PRET
PAGE
NCONC: JUMPE A,PROG2
MOVE TT,A
MOVE C,TT
CDRA TT,(C)
JUMPN TT,.-2
RPLCD B,(C)
PRET
APPEND: JUMPE A,PROG2
MOVEI C,AR4
MOVE TT,A
APP1: CARA A,(TT)
PSAVE B
PCALL CONS ;saves b
PREST B
RPLCD A,(C)
MOVE C,A
CDRA TT,(TT)
JUMPN TT,APP1
JRST RETAR4
PROGN: SKIPN B,A
PRET
PROGN1: PSAVE B
CARA A,(B)
PCALL EVAL
PREST B
COND2: SKIPL C,PA4
JRST RETC ;exit if a RETURN was found
CDRA B,(B)
SKIPL PA3 ;exit if a GO was found
JUMPN B,PROGN1
PRET
PAGE
MEMBER: MOVEM A,SUBAS
MEMB1: JUMPE B,FALSE
MOVE A,SUBAS
PSAVE B
CARA B,(B)
PCALL EQUAL
AJMN: JUMPN A,POPAJ
PREST B
CDRA B,(B)
JRST MEMB1
MEMQ: EXCH A,B
JUMPE A,CPOPJ
MOVS C,(A)
CAIN B,(C)
PRET
CARA A,C
JUMPN A,MEMQ+2
PRET
AND: JUMPE A,TRUE
SKIPA C,AJMN
OR: MOVSI C,(JUMPE A,)
JUMPE A,CPOPJ
HRRI C,ANDOR
PSAVE A
PSAVE C
JRST ANDORI
ANDOR: EXCH A,-1(P)
CDRA A,(A)
JUMPE A,POP1AJ
MOVEM A,-1(P)
ANDORI: CARA A,(A)
PCALL EVAL
XCT (P)
POP2J: P2DROP
PRET
POP1AJ: P1DROP
JRST POPAJ
PAGE
GENSYM: MOVE B,[POINT 7,GNUM,34]
MOVNI C,4
MOVEI TT,"0"
GENSY2: LDB T,B
AOS T
DPB T,B
CAIG T,"9"
JRST GENSY1
DPB TT,B
ADD B,[XWD 70000,0]
AOJN C,GENSY2
GENSY1: MOVE A,GNUM
PCALL FWCONS
PCALL NCONS
JRST PNGNK1
GNUM: ASCII /G0000/ ;*
IFE STL,<
CSYM: CARA A,(A)
PSAVE A
PCALL GT1PNM
MOVEM A,GNUM
JRST POPAJ >
GT1PNM: PCALL GETPNM
CARA A,(A)
MOVE A,(A)
PRET
PAGE
LIST:
FOO MOVEI B,CEVAL
JRST MAPCAR
ILIST: MOVEI T,0
JUMPE A,ILIST2
ILIST1: PSAVE A ;Evals list, leaving on P, & neg # in T.
CARA A,(A)
PSAVE TT
HRLM T,(P)
PCALL EVAL
ILIST3: PREST TT
HLRE T,TT
EXCH A,(P)
CDRA A,(A)
SOS T
JUMPN A,ILIST1
ILIST2: JRST (TT)
MAPCAN: TLO B,400000
MAPCON: TLOA B,100000
MAPCAR: TLO B,400000
MAPLIST:TLOA B,200000
MAPC: TLO B,400000
MAP: JUMPE A,FALSE
PSAVE A
HLLM B,(P)
HRLI B,(FCALL 1,)
PSAVE B
PSAVE A
HRLZM P,(P)
MAPL2: SKIPGE -2(P)
CARA A,(A) ;MAPC or MAPCAR.
XCT -1(P)
LDB C,[POINT 2,-2(P),2]
JUMPE C,MAP1
TRNN C,1
PCALL NCONS
JUMPE A,MAP1 ;Case of NIL returned in MAPCAN, MAPCON
HLR B,(P)
RPLCD A,(B)
TRNE C,1
PCALL LAST
HRLM A,(P)
MAP1: CDRA A,@-2(P)
HRRM A,-2(P)
JUMPN A,MAPL2
PREST AR4
P2DROP
JRST RETAR4
PAGE
PA3: 0 ;lh=0=>rh =next prog statement *
;lh - =>rh = tag to go to
PA4: -1,,0 ;lh=-1,rh=pntr to prog less bound var list *
;lh=+,rh return value
PROG: PSAVE PA3
PSAVE PA4
CARA T,(A)
CDRA A,(A)
HRROM A,PA4
MOVEM A,PA3
PUSH SP,[0] ;mark for unbind
JUMPE T,PG0
PG7A: CARA A,(T)
MOVEI AR4,NIL
PCALL BIND
CDRA T,(T)
JUMPN T,PG7A
PG0: SKIPA T,PA3
PG5A: MOVE T,A
PG1: JUMPE T,PG2
CARA A,(T)
CDRA T,(T)
CARA B,(A)
CAILE B,ATMIN
JRST PG1
MOVEM T,PA3
PCALL EVAL
SKIPL A,PA4
JRST PG4 ;return
SKIPL T,PA3
JRST PG1
PG5: JUMPE A,EG1
CARA TT,(A)
CDRA A,(A)
CAIN TT,(T)
JRST PG5A ;found tag
JRST PG5
PG2: TDZA A,A
PG4: HRRZS A
PCALL UNBIND
ERRP4: PREST PA4
PREST PA3
PRET
GO: CARA A,(A)
HRROM A,PA3
IFE STL,<CARA B,(A)
CAILE B,ATMIN>
JRST FALSE
IFE STL,<PCALL EVAL
JRST GO+1>
PAGE
RETURN: HRRZM A,PA4
PRET
SETQ: CARA B,(A)
PSAVE B
PCALL CADR
PCALL EVAL
MOVE B,A
PREST A
SET: MOVE AR4,B
PCALL BIND
SUB SP,[XWD 1,1]
RETAR4: CDRA A,AR4
PRET
CON2: CDRA A,(T)
COND: JUMPE A,CPOPJ ;entry
PSAVE A
CARA A,(A)
CARA A,(A)
PCALL EVAL
PREST T
JUMPE A,CON2
CARA B,(T)
JRST COND2
EG1: HRRZ A,T
ERRE1 ^D26,[SIXBIT /UNDEFINED PROG TAG-GO!/]
SUBTTL ARITHMETIC SUBROUTINES --- PAGE 12
IFE STL,<
;macro expander -- (foo a b c) is expanded into (*foo (*foo a b) c)
EXPAND: MOVE C,B
CDRA A,(A)
PCALL REVERSE
JRST EXPA1
EXPN1: MOVE C,B
EXPA1: CDRA T,(A)
CARA A,(A)
JUMPE T,CPOPJ
PSAVE A
MOVE A,T
PCALL EXPA1
EXCH A,(P)
PCALL NCONS
PREST B
PCALL XCONS
HRL A,C
JRST DCONSA >
PAGE
ADD1: CAILE A,INUMIN
CAILE A,ATMIN-1
SKIPA B,[INUM0+1]
AOJA A,CPOPJ
.PLUS: JSP C,OP
ADD A,TT
FADR A,TT
JRST BPLUS
SUB1: CAILE A,INUMIN+1
CAILE A,ATMIN
SKIPA B,[INUM0+1]
SOJA A,CPOPJ
.DIF: JSP C,OP
SUB A,TT
FSBR A,TT
JRST BDIF
.TIMES: JSP C,OP
IMUL A,TT
FMPR A,TT
JRST BTIMES
.QUO: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
IDIV A,TT
FDVR A,TT
JRST BQUO
.GREAT: EXCH A,B
JUMPE B,FALSE
.LESS: JUMPE A,CPOPJ
CAIN B,INUM0
JRST MINUSP
JSP C,OP
JRST COMP2
JRST COMP2
JRST BCMPR
COMP2: CAML A,TT
JRST FALSE
JRST TRUE
PAGE
MAKNUM: CAIN B,FIXNU
JRST FIX1A
FLO1A: MOVEI B,FLONU
JRST FQCONS
FIX1B: SUBI A,INUM0
MOVEI B,FIXNU
FQCONS: PCALL FWCONS
JRST XCONS
IF1,PURGE NUMVAL ;To avoid confusion with NUMVAL in STENEX
NUMVLX: JFCL 17,.+1
ONUMV: MOVEI B,FIXNU
CAILE A,INUMIN
JRST ONUMV1
CARA B,(A)
CAILE B,ATMIN
CAILE B,FLONU
NUMV2: ERRE1 ^D27,[SIXBIT /IS NOT A NUMBER!/]
CDRA A,(A)
CAIG B,POSNU
JRST (D) ;Normal return if bignum
SKIPA A,(A)
ONUMV1: SUBI A,INUM0
JRST 1(D) ;Return with skip if fixnum or flonum
NUMVAL: CAILE A,INUMIN
JRST FIXV1
CARA D,(A)
CAIE D,FIXNU
ERRE2 ^D46,[SIXBIT /IS NOT A WORD SIZE INTEGER/]
CDRA A,(A)
FIXV2: SKIPA A,(A)
FIXV1: SUBI A,INUM0
PRET
PAGE
FLOAT: PSAVE A
JSP D,ONUMV
JRST BFLOT
CAIN B,FLONU
JRST POPAJ
MOVEI D,FLO1A
MOVEM D,(P)
FLOAT1: IDIVI A,400000
SKIPE A
TLC A,254000
TLC B,233000
FADR A,B
PRET
FIX: PSAVE A
JSP D,ONUMV
JRST POPAJ ;BIGNUM
CAIE B,FLONU
JRST POPAJ
MOVEM A,(P)
MULI A,400
TSC A,A
JFCL 17,.+1
ASH B,-243(A)
FIX2: JFCL 10,BFIX
P1DROP
FIX1: MOVE A,B
JRST FIX1A
MINUSP: JSP D,ONUMV
JRST MINSP2 ;BIGNUM
JUMPGE A,FALSE
JRST TRUE
MINUS: JSP D,NUMVLX
JRST MINS2 ;BIGNUM
MOVNS A
ABS2IN: JFCL 10,FIXOV3
JRST MAKNUM
ABS: JSP D,NUMVLX
JRST ABS2
MOVMS A
JRST ABS2IN
PAGE
DIVIDE: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
JRST RDIV
JRST ILLNUM
JRST BDIV
RDIV: JFCL 17,.+1
IDIV A,TT
JFCL 10,DIVMB ;FREAK CASE OF -2**35 IN A.
PSAVE B
PCALL FIX1A
EXCH A,(P)
PCALL FIX1A
PREST B
JRST XCONS
REMAINDER:
PCALL DIVIDE
JRST CDR
FIXOV: ERRL0 ^D135,[SIXBIT /INTEGER OVERFLOW!/]
ZERODIV:ERRL0 ^D136,[SIXBIT /ZERO DIVISOR!/]
FLOOV: ERRL0 ^D137,[SIXBIT /FLOATING OVERFLOW!/]
ILLNUM: ERRL0 ^D138,[SIXBIT /NON-INTEGRAL OPERAND!/]
GCD: JSP C,OP
JRST GCD2
JRST ILLNUM
JRST BGCD
GCD2: JFCL 17,.+1
MOVMS A
MOVMS TT
JFCL 10,DIVMB ;FREAK CASE OF -2**35 IN A OR TT.
;euclid's algorithm
GCD3: CAMG A,TT
EXCH A,TT
JUMPE TT,FIX1A
IDIV A,TT
MOVE A,B
JRST GCD3
DIVMB: MOVEI B,FIXNU
PCALL BIGTSB
JRST @2(C)
PAGE
;general arithmetic op code routine for mixed types
OP: CAIG A,INUMIN
JRST OPA1
SUBI A,INUM0
CAIG B,INUMIN
JRST OPA2
HRREI TT,-INUM0(B)
XCT (C) ;inum op (cannot cause overflow)
FIX1A: ADDI A,INUM0
CAILE A,INUMIN
CAILE A,ATMIN
JRST FIX1B
PRET
NONUM1: MOVE A,TT
OPA1: CARA T,(A)
CAILE T,ATMIN
CAILE T,FLONU
JRST NUMV2 ;A is not a number
CDRA A,(A)
CAIE T,FIXNU
JRST OPA6
SKIPA A,(A)
OPA2: ;first arg is a FIXNUM
MOVEI T,FIXNU
CAILE B,INUMIN
JRST OPB2
MOVE TT,B
CARA B,(B)
CAILE B,ATMIN
CAILE B,FLONU
JRST NONUM1 ;TT is not a number
CDRA TT,(TT)
CAIE B,FIXNU
JRST OPA5
SKIPA TT,(TT)
OPB2: HRREI TT,-INUM0(B)
MOVE AR4,A ;<MOVEI B,FIXNU> supplied by DIVMB.
JFCL 17,.+1
XCT (C) ;fixed pt op
OPOV: JFCL 10,FIXOVL
JRST FIX1A
OPA6: CAILE B,INUMIN ;first arg is not FIXNUM
JRST OPB7
CDRA TT,(B)
CARA B,(B)
CAIE B,FLONU
JRST OPB3 ;second arg is not a FLONUM
CAIN T,FLONU ;second arg is FLONUM; test first arg
SKIPA A,(A)
PCALL BFLT ;not a FLONUM, must be BIGNUM; float it
MOVE TT,(TT)
OPR: JFCL 17,.+1
XCT 1(C) ;flt pt op
JFCL 10,FLOOV
JRST FLO1A
PAGE
OPA5: ;first arg is FIXNUM but second arg is not
CAIE B,FLONU ;is second arg a FLONUM
JRST BIGOP ;no. it must be a bignum
PCALL FLOAT1
JRST OPR-1
OPB3: ;first arg is not fixnum, second arg is not flonum
CAIE B,FIXNU ;is second arg FIXNUM ?
JRST OPB9 ;no. it must be bignum
SKIPA TT,(TT)
OPB7: HRREI TT,-INUM0(B)
MOVEI B,FIXNU
CAIE T,FLONU
JRST BIGOP
MOVE A,(A)
EXCH A,TT
PCALL FLOAT1
OPB8: EXCH A,TT
JRST OPR
OPB9: ;second arg is bignum
CAIE T,FLONU ;is first arg a FLONUM ?
JRST BIGOP ;no
MOVE A,(A)
EXCH A,TT
EXCH B,T
PCALL BFLT
JRST OPB8
BIGOP: PCALL BIGTST
JRST @2(C)
SUBTTL BIGNUM ARITHMETIC ROUTINES --- PAGE 13
;Power of ten
PWR10: MOVEM B,BASEX#
MOVE C,B
IMUL B,B ;BASE^2
IMUL B,B ;BASE^4
IMUL B,C ;BASE^5
IMUL B,B ;BASE^ten
MOVEM B,BASE10#
PRET
B0CONS: MOVEI A,0
BNCONS: MOVEI B,0
BCONS: PCALL FWCONS
JRST CONS
;Bignum PRINT
BPRI: XCT "-",CTY
PCALL COPY
FOO MOVE B,VBASE
SUBI B,INUM0
PCALL PWR10
PCALL BPRJ
MOVE C,BASEX
JRST PRINI4
BPRJ: MOVE B,BASE10
PCALL Q1
JUMPE B,BPR2 ;zero quotient
PSAVE A ;remainder
MOVE A,B ;quotient
PCALL BPRJ
PREST A ;remainder
BPR1: MOVEI C,TEN ;print ten digits
SOJL C,CPOPJ
IDIV A,BASEX
HRLM B,(P)
PCALL BPR1+1
JRST FP7A1 ;particular TYO for digit
;Ignore leading zero digits for first word
BPR2: JUMPE A,CPOPJ
IDIV A,BASEX
HRLM B,(P)
PCALL BPR2
JRST FP7A1 ;particular TYO for digit
PAGE
;Divides bignum in A by integer in B
;Destroys original bignum
;Returns remainder in A, quotient in B
.Q1:
Q1: MOVEM B,Y#
PSAVE A
CDRA A,(A)
JUMPE A,Q1A
PCALL Q1+1
PREST C
RPLCD B,(C)
CARA T,(C)
MOVE B,(T)
DIV A,Y
Q1B: MOVEM A,(T) ;replace old digit
MOVE A,B
MOVE B,C
PRET
Q1A: PREST C
CARA T,(C)
MOVE A,(T)
IDIV A,Y
JUMPN A,Q1B ;non-zero quotient - keep it
HRRZM FF,(T) ;reclaim full word
MOVE FF,T
HRRZM F,(C) ;reclaim free word
HRRZ F,C
MOVEI C,0
JRST Q1B+1
PAGE
;Bignum READ
RDBNM: PSAVE [NIL] ;initial value of bignum
MOVSI C,700
HRRI C,(SP) ;byte pointer to spec pdl
MOVEM T,TSAV#
MOVEM C,RDPTR#
HRRZ B,NUM1 ;base of number
PCALL PWR10
RDNM1: MOVEI C,TEN ;ten digits at a time
MOVEI A,0
ILDB B,RDPTR
JUMPE B,RDNM2 ;end of bignum
IMUL A,BASEX
ADDI A,-"0"(B)
SOJG C,.-4
MOVE B,BASE10
PCALL RDSUB
JRST RDNM1
RDNM2: CAIN C,TEN ;no digits in last superdigit
JRST RDNM3
HRREI C,-TEN(C) ;number of digits in last
MOVEI B,1
IMUL B,BASEX
AOJL C,.-1 ;compute basex^(number of digits)
PCALL RDSUB
RDNM3: LDB B,[POINT 1,TSAV,14] ;MINSGN
TRC B,POSNU ;sign of bignum
PREST A
P1DROP
JRST XCONS
RDSUB: MOVE C,-1(P)
PCALL BTIME1 ;bignum(C)*int(B)+int(A)
MOVEM A,-1(P)
PRET
PAGE
BTIME0: PSAVE B
PCALL COPY
MOVE C,A
PREST B
MOVEI A,0
;big(C)*int(B)+int(A)
BTIME1: JUMPE C,BNCONS ;end of bignum
MOVEM B,MULR# ;multiplier
PSAVE C ;bignum
BT1B: MOVEM A,CARRY#
MOVS T,(C)
MOVE A,(T)
MUL A,MULR
ADD B,CARRY
TLZE B,SIGN
ADDI A,1
BT1E: MOVEM B,(T) ;store low order product+carry in bignum
HLRZS T ;(CDR bignum)
JUMPE T,BT1C ;end of bignum
MOVE C,T
JRST BT1B
BT1C: JUMPE A,POPAJ ;no high order part
PCALL BNCONS ;conses for remaining high order part
RPLCD A,(C) ;RPLACD end of bignum
JRST POPAJ
PAGE
;Bignum copy
.COPY:
COPY: JUMPE A,CPOPJ
CARA B,(A)
PSAVE (B)
CDRA A,(A)
PCALL COPY
MOVE B,A
PREST A
JRST BCONS
;Bignum reclaim
RECLAIM:CAILE A,INUMIN
PRET
EXCH A,F
EXCH A,(F)
HLRZ B,A ;type
HRRZS A
CAIE B,POSNU
CAIN B,NEGNU
JRST UNCONS
PRET
;BIGNUM UNCONS
UNCONS: JUMPE A,CPOPJ
CARA B,(A)
MOVEM FF,(B)
MOVE FF,B
EXCH A,F
EXCH A,(F)
HRRZS A
JRST UNCONS
;BIGNUM MINUSP
MINSP2: CAIN B,POSNU
JRST FALSE
JRST TRUE
;BIGNUM MINUS
MINS2: TRCA B,1
ABS2: MOVEI B,POSNU ;BIGNUM ABS
JRST XCONS
;compare two bignums A<B
BCMPR: PCALL BDIF
PSAVE A
PCALL MINUSP
EXCH A,(P)
PCALL RECLAIM
JRST POPAJ
PAGE
;DIFFERENCE of two bignums
BDIF: TRC TT,1 ;complement sign of bignum in B
;sum of two bignums
;bignums in A and B; sign(A) in T, sign(B) in TT
BPLUS: PSAVE B
PCALL COPY
EXCH A,(P)
PCALL COPY
PREST C
MOVE B,A
MOVEI A,0
CAME T,TT
JRST BDIF1 ;signs different
PSAVE T ;sign of result
PCALL BADD
PREST B
JRST XCONS
BDIF1:
CAIN TT,POSNU
EXCH B,C
PCALL BSUB ;posnum in C, negnum in B
JUMPL B,BDIF3
PCALL SUPRSS
JRST MAKPOS
BDIF3: PCALL COMPLM
MOVEI B,NEGNU
JRST MAKBIG
BSUB: MOVNI TT,1
MOVSI T,(SUB TT,(B))
JRST BAS
BADD: MOVEI TT,1
MOVSI T,(ADD TT,(B))
PAGE
;cry(A)(+ or -) big(B) + big(C) into A, sign into B.
;destroys both bignums
BAS: HRRM TT,BCRY
PSAVE B
BP2A: HRRM B,BTMP
MOVS B,(B)
CARA TT,(C)
EXCH TT,FF
EXCH TT,(FF) ;reclaim full word
EXCH C,F
EXCH C,(F) ;reclaim free word
ADD TT,A
XCT T ;big(C) (+ or -) big (B)
MOVEI A,0
TLZE TT,SIGN ;turn off high bit
BCRY: HRREI A,. ;set carry if overflow or negative
BP2B: MOVEM TT,(B)
HLRZS B
HRRZS C
JUMPE B,BP2F ;end of B
JUMPN C,BP2A
JRST BP2D ;finish with carry (+ or -) big(B)
BP2F: JUMPE C,BP2H ;end of C also
EXCH B,C
RPLCD B,@BTMP ;RPLACD end of big(B) with rest of C
MOVSI T,(ADD TT,(B)) ;finish with big(C) + carry
BP2D: HRRM B,BTMP
MOVS B,(B)
MOVE TT,A
XCT T ;carry (+ or -) integer
JUMPL TT,BP2K
MOVEM TT,(B)
CAME T,[SUB TT,(B)]
JRST POSXIT ;can quit now
MOVEI A,0 ;turn off carry
JRST BP2L ;continue to negate
BP2K: HRRE A,BCRY
TLZ TT,SIGN ;make high bit zero
MOVEM TT,(B)
BP2L: HLRZS B
JUMPN B,BP2D
BP2H: JUMPLE A,XIT ;no carry
PCALL BNCONS
BTMP: HRRM A,. ;RPLACD end of bignum with carry
POSXIT: MOVEI B,0 ;sign positive
JRST POPAJ
XIT: MOVE B,A ;sign in B
JRST POPAJ
PAGE
;suppress leading zeros from bignum
SUPRSS: SKIPA C,[JRST COMPL7]
;complement bignum (2^35 complement)
COMPLM: MOVSI C,(SUBM T,(B))
JUMPE A,CPOPJ
PSAVE A
HRLZI T,SIGN
MOVEI TT,0
COMPL4: MOVS B,(A)
SKIPN (B)
JUMPE TT,COMPL3
XCT C
HRLOI T,SIGN-1
COMPL7: SKIPE (B)
MOVEM A,TT
COMPL3: HLRZ A,B
JUMPN A,COMPL4 ;continue
JUMPE TT,COMPL5 ;all zeros
CDRA A,(TT)
HLLZS (TT) ;RPLACD high order non-zero with NIL
COMPL6: PCALL UNCONS ;UNCONS leading zeros
JRST POPAJ
COMPL5: EXCH A,(P)
JRST COMPL6
;sign(TT)*sign(T) into TT
MQSIGN: CAIE T,POSNU
TRC TT,1
PRET
PAGE
;bignum multiply
;big (A) * big (B) into A, signs in T,TT
BTIMES: PCALL MQSIGN
PSAVE TT ;save sign of result
PCALL BMUL
PREST B
JRST MAKBIG
;0(P) is partial result
;-1(P) is remaining reversed multiplier
;-2(P) is multiplicand
BMUL: PSAVE B
PCALL REVERSE
PSAVE A
MOVEI A,0
PSAVE A
BTLOOP: SKIPN C,-1(P)
JRST BTEND ;end of multiplier
JUMPE A,BTLP2 ;first time
MOVE B,A
PCALL FWCONS-1
PCALL CONS ;increase length of product
BTLP2: MOVEM A,(P)
MOVE A,-2(P)
PCALL COPY
MOVS B,(C) ;next multiplier digit
MOVE C,A
HLRZM B,-1(P)
MOVE B,(B)
MOVEI A,0
PCALL BTIME1
MOVE C,(P)
JUMPE C,BTLOOP ;no add needed on first time
MOVE B,A
MOVEI A,0
PCALL BADD
JRST BTLOOP
BTEND: P3DROP
JRST SUPRSS
PAGE
;extensions of interpreter routines and tests
REPEAT 0,<
;ONUMVAL for bignums goes here
NUMVD2: HRRZ C,0(P) ;address of <PCALL ONUMVAL> +1
FOO CAIL C,FS ;LISP-system area of code?
PRET ; No, user or BPS gets a BIGNUM-pntr back.
P1DROP
CAIN C,ZEROP+1
JRST FALSE
CAIN C,MINUSP+1
JRST MINSP2
CAIN C,MINUS+1
JRST MINS2
CAIN C,ABS+1
JRST ABS2
CAIN C,FIX+2
JRST POPAJ
CAIN C,FLOAT+2
JRST BFLOT
IFN MOD,<CAIN C,CMOD+1
JRST CMOD1 >
PAGE
>
;number overflow, use bignums
FIXOVL: MOVEI C,(C)
CAIN C,.TIMES+1
JRST REMUL ;TIMES overflowed. Recompute.
JUMPE A,FIXOV2 ;PLUS(mbeta mbeta) overflows 2 bits.
FIXOV3: TLC A,SIGN ;all other cases just overflowed 1 bit
MOVM B,A
MOVE TT,A
MOVEI A,1
FIXOVX: PCALL MKBG
JRST XCONS
FIXOV2: SETZ B,
SETO TT, ;(NEGATIVE).
MOVEI A,2 ;== -2*beta.
JRST FIXOVX
REMUL: MOVE A,AR4
MOVEI T,FIXNU
PCALL BIGTSB
JRST BTIMES ;use the bignum multiplication
MAKPOS: MOVEI B,POSNU
;Make a LISP number from bignum -- A is list, B is sign
MAKBIG: JUMPE A,FIX1A ;NULL list produces zero
CDRA C,(A)
JUMPN C,XCONS ;a real bignum
CARA C,(A) ;only one word of precision
MOVE C,(C)
CAIE B,POSNU
MOVNS C ;negative
PCALL UNCONS
MOVE A,C
JRST FIX1A
PAGE
BIGTSB: MOVEI B,FIXNU
;Transforms general numbers in (A,T),(TT,B)
;into bignums in (A,T),(B,TT), values in A,B; signs in T,TT.
BIGTST: EXCH B,T ;funny ac usage in lisp
PSAVE T
PSAVE TT
PCALL BIGSUB ;convert number originally in A,T
EXCH B,-1(P)
EXCH A,(P)
PCALL BIGSUB ;convert number originally in TT,B
MOVE TT,B
MOVE B,A
PREST A
PREST T
PRET
BIGSUB: CAIE B,POSNU
CAIN B,NEGNU
PRET ;no conversion necessary
CAIE B,FIXNU
JRST NUMV2 ;already checked for flonum
MOVEI B,0
MOVE TT,A ;get value of number
MOVM A,TT
JUMPGE A,BIGSRT
MOVEI A,1 ;bastard case of -2^35
MKBG: PCALL MKBIG
JRST BIGSND
BIGSRT: PCALL BCONS
BIGSND: SKIPGE TT
SKIPA B,[NEGNU]
MOVEI B,POSNU
PRET
MKBIG: PSAVE B
PCALL BNCONS
MOVE B,A
PREST A
JRST BCONS
PAGE
BFLOT: MOVEI T,FLO1A
MOVEM T,(P)
MOVE T,B
;Make a floating pt number out of a bignum
BFLT: PSAVE C
PSAVE T
CAIE T,POSNU
CAIN T,NEGNU
SKIPA T,[-200]
JRST NUMV2
BFLT2: MOVE C,B
CARA B,(A)
CDRA A,(A)
ADDI T,43
JUMPN A,BFLT2 ;find last two words of bignum
MOVE B,(B)
MOVE C,(C)
BFLT3: TLNE B,SIGN/2
JRST BFLT4
ASHC B,1
SOJA T,BFLT3 ;normalize B,C
BFLT4: JUMPGE T,FLOOV
ASH B,-10
DPB T,[POINT 8,B,8]
MOVE A,B
PREST T
PREST C
CAIE T,POSNU
MOVNS A
PRET
;Make a bignum from a flt pt number
BFIX: MOVM A,(P)
MULI A,400
MOVEI C,-243(A) ;#left shifts needed
IDIVI C,43 ;C_#extra words-1, D_#shifts
MOVEI A,0
ASHC A,(C+1)
PSAVE B
PCALL BNCONS
MOVE B,A
PREST A
PCALL BCONS
SOJL C,BFIX2
MOVE B,A
MOVEI A,0
PCALL BCONS
SOJGE C,.-3
BFIX2: PREST TT
PCALL BIGSND
JRST XCONS
PAGE
;Bignum divide
BDIV: PCALL MQSIGN ;complement sign of TT if T is negnum
PSAVE T ;sign of remainder
PSAVE TT ;sign of quotient
PCALL DIVSUB
BDIV2: EXCH B,(P)
PCALL MAKBIG ;quotient
MOVE B,-1(P)
MOVEM A,-1(P)
PREST A
PCALL MAKBIG ;remainder
PREST B
JRST XCONS
BQUO: PCALL MQSIGN
PSAVE TT
PCALL DIVSUB
PSAVE A
MOVE A,B
PCALL UNCONS
PREST A
PREST B
JRST MAKBIG
DIVSUB: CDRA C,(B)
JUMPN C,DIV1
;NULL(CDR B) means single length divisor
BQUO1: PSAVE B
PCALL COPY
PREST B
CARA B,(B)
MOVE B,(B)
PCALL Q1
PSAVE B ;quotient
PCALL BNCONS
MOVE B,A
JRST POPAJ
PAGE
;DIV1 does long division of X/Y
;enter with x in A, Y in B.
DIV1: PSAVE A ;X
PSAVE B ;Y
MOVE A,B
PCALL HIDIG
HRLOI A,SIGN/2-1
IDIV A,(C) ;(beta/2-1)/Y[N-1]+1
ADDI A,1
MOVEM A,SCALE#
MOVE B,A
MOVE A,(P) ;Y - divisor
PCALL BTIME0 ;SCALE*Y
MOVEM A,V ;scaled divisor
MOVEM A,(P) ;protect V from GC
PCALL HIDIG
POP C,VH ;V[N-1]
POP C,VH1 ;V[N-2]
MOVE A,-1(P) ;X - numerator
PCALL COPY
PCALL EXTND
MOVE B,SCALE
MOVE C,A
PCALL BTIME1-1 ;SCALE*X -- scaled numerator
MOVEM A,-1(P) ;U
PSAVE [NIL]
HRRZM P,QUO# ;pointer to quotient list
PCALL LENGTH
PSAVE A
MOVE A,V#
PCALL LENGTH
PREST B
SUB B,A ;LENGTH(U)-LENGTH(V)
MOVE A,-2(P) ;U
JUMPLE B,DIV1X ;special case of U<V
PCALL DIV2 ;carry out division with parameters
DIV1X: PCALL SUPRSS ;suppress leading zeros of remainder
JUMPE A,DIV1Y ;zero remainder
MOVE B,SCALE
PCALL Q1 ;U/SCALE - final remainder in B
MOVE A,B
DIV1Y: EXCH A,(P)
PCALL SUPRSS ;suppress leading zeros in quotient
PREST B
JRST POP2J
PAGE
;Recursive function to position V properly with respect to U.
; on successive calls to DIV3 which calculates quotient digits.
;Enter DIV2 with U in A, N in B. N= LENGTH(U)-LENGTH(V)-1.
DIV2: SOJLE B,DIV3
PSAVE A ;U
CDRA A,(A)
PCALL DIV2
RPLCD A,@(P) ;(RPLACD U,(DIV3(CDR U)))
PREST A
JRST DIV3
;Enter with U[J] in A
DIV3: PSAVE A ;UJ
PCALL HIDIG
POP C,A ;UH
CAML A,VH#
JRST DIVCS1 ;strange case when UH>=VH
POP C,B ;UH1
DIV A,VH ;(UH*beta+UH1)/VH
PSAVE A ;quotient digit
L1: MOVEM B,REM# ;remainder
MUL A,VH1#
SUB A,REM ;(VH1*QUO)-beta*REM
CAMGE B,(C) ;UH2
SUBI A,1
JUMPG A,DIVCS2 ;quotient too big
L4: MOVE A,V
MOVE B,(P) ;quotient digit
PCALL BTIME0 ;Q*V
MOVE C,-1(P) ;UJ
MOVE B,A
MOVEI A,0
PCALL BSUB ;UJ-Q*V
JUMPL B,DIVCS3 ;quotient too big
L3: MOVEM A,-1(P) ;new UJ
PREST A ;quotient digit
MOVE B,@QUO
PCALL BCONS
MOVEM A,@QUO ;new quotient list
MOVE A,(P)
PCALL DIVSRT ;shorten UJ by one digit
JRST POPAJ
PAGE
;Special case of UH>=VH
DIVCS1: HRLOI A,SIGN-1 ;BETA-1
PSAVE A
POP C,B ;UH1
JRST DIVC2A ;R_UH1+VH
;Special case correction for quotient
DIVCS2: SOS A,(P) ;quotient_quotient-1
MOVE B,REM
DIVC2A: ADD B,VH ;R_R+VH
JUMPL B,L4 ;overflow ... R >= beta.
JRST L1
;Special case of quotient too large
DIVCS3: SOS (P) ;quotient_quotient-1
PSAVE A
MOVE A,V
PCALL COPY
MOVE C,A
PREST B
MOVEI A,0
PCALL BADD ;U_U+V
MOVEM A,-1(P)
PCALL DIVSRT ;shorten overflowed digit
JRST L3+1
PAGE
;Pushes successive digits of list in A onto pdl
;Returns C pointing to pdl location of last digit
HIDIG: MOVE C,P
MOVS B,(A)
PSAVE (B)
HLRZ A,B
JUMPN A,HIDIG+1
EXCH C,P
PRET
;Shorten list by one
DIVSRT: MOVE C,A
CDRA A,(A)
CDRA B,(A) ;CDDR
JUMPN B,.-3
HLLZS (C) ;NULL (CDDR C) => RPLACD(C NIL)
CARA B,(A)
JRST UNCONS
;Lengthen list by one
EXTND: PSAVE A
PCALL LAST
MOVE T,A
PCALL B0CONS
RPLCD A,(T)
JRST POPAJ
PAGE
TA==4
TB==5
TC==6
TD==7
UP==10
VP==11
Q==12
;Bignum GCD
BGCD: PSAVE B
PCALL COPY
EXCH A,(P) ;V
PCALL COPY
PSAVE A ;U
PCALL COPY
MOVE C,A
MOVE A,-1(P)
PCALL COPY
MOVE B,A ;U
MOVEI A,0
PCALL BSUB ;V-U
PSAVE B
PCALL BSUBND
JUMPE A,GCDSC1 ;U=V
PCALL UNCONS
PREST B
JUMPGE B,BGCD2 ;U>=V
MOVE A,(P)
EXCH A,-1(P)
MOVEM A,(P)
PAGE
;Now V<U V in -1(P), U in (P)
BGCD2: MOVE A,-1(P)
JUMPE A,GCDEND ;V is zero
CDRA B,(A)
JUMPE B,GCDSING ;V is single precision
PCALL LENGTH ;LENGTH (V)
MOVE T,A
MOVE A,(P) ;U
PCALL LENGTH
SUB A,T ;L(U)-L(V)
JUMPE A,GCD4
SOJN A,GCD7A ;>1
MOVE A,-1(P) ;V
PCALL EXTND ;lengthen V by one high order zero
GCD4: MOVE A,(P) ;U
PCALL HIDIG
HRLOI A,SIGN/2-1 ;BETA/2-1
IDIV A,(C) ;(BETA/2-1)/U[N-1]+1
ADDI A,1
MOVEM A,SCALE
PCALL GCSB
MOVE UP,A ;SCALE*UH
MOVE A,-1(P) ;V
PCALL HIDIG
PCALL GCSB
MOVE VP,A ;SCALE*VH
MOVEI TA,1
MOVEI TD,1
SETZB TC,TB
PAGE
GCD5: MOVE A,UP
ADD A,TA
MOVE B,VP
ADD B,TC
JUMPE B,GCD7
JUMPL A,GCD5X ;overflow case
IDIV A,B ;(U'+A)/(V'+C)
GCD5A: MOVE Q,A
MOVE A,UP
ADD A,TB
MOVE B,VP
ADD B,TD
JUMPE B,GCD7
SKIPG B
TDZA A,A ;special case of V'+D = BETA
IDIV A,B ;(U'+B)/(V'+D)
CAME A,Q
JRST GCD7
MOVE A,TC
EXCH TA,TC ;A'_C
IMUL A,Q
SUB TC,A ;C'_A-Q*C
MOVE A,TD
EXCH TB,TD ;B'_D
IMUL A,Q
SUB TD,A ;D'_B-Q*D
MOVE A,VP
EXCH UP,VP ;UP'_VP
IMUL A,Q
SUB VP,A ;VP'_UP-Q*VP
JRST GCD5
PAGE
;Special case when U'+A=BETA
GCD5X: MOVEI A,1
MOVE C,B
MOVEI B,0
DIV A,C
JRST GCD5A
GCD7: JUMPE TB,GCD7A
MOVE A,(P) ;U
MOVE B,-1(P) ;V
PSAVE TC
PSAVE TD
PCALL GCDSB ;A*U+B*V
PREST TB
PREST TA
EXCH A,(P) ;U
MOVE B,-1(P)
PCALL GCDSB ;C*U+D*V
MOVEM A,-1(P) ;V
JRST BGCD2
GCDSB: PSAVE TA
PSAVE TB
PSAVE B
MOVM B,TA
PCALL BTIME0
EXCH A,(P) ;B
MOVM B,-1(P) ;TB
PCALL BTIME0
PREST B ;A*TA
PREST TA
PREST TB
XOR TA,TB
MOVE C,A
MOVEI A,0
JUMPGE TA,BADD ;signs same
PCALL BSUB ;signs different
BSUBND: JUMPGE B,SUPRSS
JRST COMPLM
GCD7A: MOVE A,-1(P)
PCALL SUPRSS
MOVE B,A
MOVE A,(P)
PCALL DIV1 ;U/V
EXCH B,-1(P) ;V_REMAINDER
MOVEM B,(P) ;U_V
PCALL UNCONS ;dont need quotient
JRST BGCD2
PAGE
GCDSING:
PREST A ;U
MOVE B,(P) ;V - single precision
CARA B,(B)
MOVE B,(B)
MOVEM B,(P)
PCALL Q1 ;U MOD V into A
PREST B ;A < B
JUMPE A,GCDS2
;Single precision GCD
IDIV B,A
MOVE B,A
MOVE A,C
JUMPN A,.-3
GCDS2: MOVE A,B
JRST FIX1A
GCSB: MOVE A,-1(C)
MUL A,SCALE
MOVE B,A
MOVE A,(C)
IMUL A,SCALE
ADD A,B
PRET
GCDSC1: P2DROP
PREST A
JRST MAKPOS
GCDEND: PREST A ;U is result
P1DROP
JRST MAKPOS
SUBTTL GENERALIZED GFPAK, FOR BIGNUMS --- PAGE 14
IFN MOD,< ;THE REST OF THIS PAGE IS UNDER THIS SWITCH
;TITLE GFPAK4 -- GALOIS FIELD PACKAGE
; THE MODULUS CANNOT BE A BIGNUM, WITH THIS VERSION OF GFPAK;
; THE ARG TO CMOD CAN BE, THOUGH.
; Every other arg is assumed to be FIXNUM or INUM !!!
; THE MODULUS SHOULD ALWAYS BE SET OR RESET BY THE FUNCTION SETMOD;
; IT SHOULD NOT BE SET BY A SETQ IN LISP/REDUCE.
; THE MODULUS CAN BE INTERROGATED FOR ITS CURRENT VALUE BY:
; 1) THE VALUE RETURNED FROM THE FUNCTION (SETMOD 0),
; WHICH DOESN'T ALTER THE CURRENT VALUE; OR BY
; 2) THE VALUE OF THE EXTERNAL VARIABLE MOD*.
; (SETMOD NIL) IS LEGITIMATE, AND IS == (SETQ MOD* NIL).
GFP: 0 ;STRICTLY LOCAL: THE SINGLE-PRECISION MODULUS.
;VBIGP IS THE VALUE-CELL OF THE VARIABLE MOD*,
; AND PERMITS EXTERNAL-INTERROGATION.
;VBIGP IS ALSO USED IN CMOD, AS A FIXNUM,
; (TO AVOID RE-FIX1A-ING GFP EACH TIME).
; IT IS THUS PROTECTED DURING A GC.
PAGE
;(SETMOD A) SETS P, THE NUMBER OF ELEMENTS OF THE FIELD, TO A IF A.NE.0
; AND RETURNS P AS A RESULT IN ANY CASE.
; DOES NOT CHECK TO SEE IF P IS PRIME, WHICH IT SHOULD BE.
INTERNAL SETMOD
SETMOD: MOVE C,A ;Preserve pntr around NUMVAL.
JUMPE A,SETM2 ;If NIL, just reset cells.
PCALL NUMVAL
JUMPE A,SETM3 ;If "0", interrogate old value.
SETM2: MOVMM A,GFP ;Internal cell (for local use).
FOO MOVEM C,VBIGP ;External pntr (for users and CMOD).
SETM3:
FOO MOVE A,VBIGP ;Return current value.
PRET
;(CMOD A) NORMALIZES A MOD P, REGARDLESS +/- SIZE
INTERNAL CMOD
CMOD: JSP D,ONUMV
JRST CMOD1
CAIN B,FLONU
JRST ILLNUM ;FLOATING POINT NUMBERS ARE ILLEGAL
IDIV A,GFP
SKIPGE A,B ;IF A WAS NEG, REMAINDER IS NEG
ADD A,GFP
JRST FIX1A ;CONVERT & EXIT
CMOD1: PSAVE B
PCALL COPY
MOVE B,GFP
PCALL Q1
PREST B
CAIE B,POSNU
MOVNS A
JRST CDIF1
PAGE
;(CPLUS A B) RETURNS THE SUM OF A AND B IN THE CURRENT GALOIS FIELD
; ASSUMES A & B ALREADY NORMALIZED.
INTERNAL CPLUS
CPLUS: MOVEM B,TMP ;SAVE B
PCALL NUMVAL ;CONVERT A
EXCH A,TMP ;SAVE A
PCALL NUMVAL ;CONVERT B
ADD A,TMP ;ADD
CAML A,GFP ;SKIP IF LESS, ELSE
SUB A,GFP ; NORMALIZE
JRST FIX1A ;CONVERT AND EXIT
TMP: 0
;CDIF(A,B) RETURNS A-B MOD P, A,B ARE ELEMENTS OF GF(P)
INTERNAL CDIF
CDIF: MOVEM B,TMP ;SAVE B
PCALL NUMVAL ;CONVERT A
EXCH A,TMP ;SAVE A
PCALL NUMVAL ;CONVERT B
EXCH A,TMP
SUB A,TMP ;SUBTRACT
CDIF1: SKIPGE A ; SKIP IF GREATEQ 0,ELSE
ADD A,GFP ; NORMALIZE
JRST FIX1A ;CONVERT AND EXIT
;(CTIMES A B) RETURNS THE PRODUCT OF A AND B IN THE CURRENT GALOIS FIELD
; ASSUMES A & B NON-NEG ... NORMALIZED.
INTERNAL CTIMES
CTIMES: MOVEM B,TMP ;SAVE B
PCALL NUMVAL ;CONVERT A
EXCH A,TMP ;SAVE A
PCALL NUMVAL ;CONVERT B
MUL A,TMP ;MULTIPLY
DIV A,GFP ;DIVIDE BY P TO GET IN RANGE
MOVE A,B ;MOVE REMAINDER
JRST FIX1A ;WHICH WE CONVERT AND EXIT
PAGE
;(CRECIP A) RETURNS THE INVERSE OF A IN THE CURRENT GALOIS FIELD.
; COMPUTATION USES EXTENDED EUCLIDEAN ALGORITHM, WHEREBY
; (GCD P A) IS COMPUTED, AND NUMBERS X AND Y ARE FOUND SUCH THAT
; P*X + A*Y = (GCD P A) = 1 BECAUSE P IS PRIME (WE HOPE).
; SINCE P*X O (MOD P) WE DO NOT IN FACT COMPUTE X.
; Y IS OF COURSE THE MULTIPLICATIVE INVERSE OF A.
;ALGORITHM:
; A(I)=A(I+1)*Q(I)+A(I+2)
; Y(I+2)=Y(I)-Q(I)*Y(I+1)
; A(1)=P, A(2)=A, Y(1)=0, Y(2)=1
; A(N+2)=0, Y(N+1)=Y
;STORAGE ALLOCATION:
; A: A(I+1)
; B: A(I)
; C: A(I+2) (BECAUSE OF THE WAY IDIV WORKS)
; AR4: Y(I)
; AR5: Y(I+1)
INTERNAL CRECIP
CRECIP: PCALL NUMVAL ;GET VALUE OF ARGUMENT IN A(2)
SETZM AR4 ;Y(1)=0
MOVEI AR5,1 ;Y(2)=1
MOVE B,GFP ;A(1)=P
LOOP: IDIV B,A ;C=A(I+2), B=Q(I)
JUMPE C,EXIT ;IF A(I+2)=0, WE ARE THROUGH
IMUL B,AR5 ;Q(I)*Y(I+1)
EXCH AR4,AR5
SUB AR5,B ;Y(I+2)
MOVE B,A
MOVE A,C
JRST LOOP ;NEXT ITERATION
EXIT: SKIPGE A,AR5 ;A_Y(N+1). IF NEGATIVE
ADD A,GFP ;ADD P TO GET 0.LT.Y.LT.P
JRST FIX1A ;CONVERT TO LISP NUMBER AND EXIT
> ;END OF IFN MOD
SUBTTL EXPLODE, COMPRESS AND FRIENDS --- PAGE 15
IFE STL,<
FLATSIZE:HLLZS FLAT1
MOVEI R,FLAT2
PCALL PRINTA
FLAT1: MOVEI A,X ;*
JRST FIX1A
FLAT2: AOS FLAT1
PRET >
%EXPLODE:SKIPA R,.+1 ;LIKE PRIN2 & PRIN1,
EXPLODE: HRRZI R,EXPL1 ; <HRRZI>=551, negative R trick.
SKIPN OLSCNV ;READ scanner?
JRST EXPLO1 ;Yes!
PSAVE A
MOVEI A,NIL
PCALL SCANSET
EXCH A,(P)
PCALL EXPLO1
EXCH A,(P)
PCALL SCANSET
JRST POPAJ
EXPLO1: MOVSI AR4,AR4
PCALL PRINTA
JRST RETAR4
EXPL1: PSAVE B
PSAVE C
ANDI A,177
PCALL RECH1
PCALL NCONS
HLR B,AR4
RPLCD A,(B)
RPLCA A,AR4
PREST C
JRST POPBJ
PAGE
IFE STL,<
READLIST:TDZA T,T
COMPRESS:MOVNI T,1
MOVEM T,NOINFG >
IFN STL,<
COMPRESS:SETOM NOINFG >
PSAVE OLDCH
SETZM OLDCH
JUMPE A,[ERRL0 ^D141,[SIXBIT /NO LIST-COMPRESS!/]]
HRRM A,MKNAM3
MOVEI A,MKNAM2
PCALL READ0
CDRA T,MKNAM3
CAIE T,-1
JUMPN T,[ERRL0 ^D142,[SIXBIT /MORE THAN ONE S-EXPRESSION-COMPRESS!/]]
PREST OLDCH
PRET
MKNAM2: PSAVE B
PSAVE TT
MKNAM3: MOVEI TT,X
JUMPE TT,MKNAM6
CAIN TT,-1
ERRL0 ^D143,[SIXBIT /READ UNHAPPY-COMPRESS!/]
CDRA B,(TT)
HRRM B,MKNAM3
CARA A,(TT)
PCALL GTFCH
MKNAM4: PREST TT
JRST POPBJ
MKNAM6: MOVEI A," "
HLLOS MKNAM3
JRST MKNAM4
GTFCH: CAILE A,INUMIN
JRST GTFINV
GTFCH2: PCALL GETPNM
CARA A,(A)
LDB A,[POINT 7,(A),6]
PRET
GTFINV: SUBI A,INUM0-"0"
CAIG A,"9"
CAIGE A,"0"
ERRL1 ^D144,[SIXBIT /NUMBER NOT DIGIT!/]
PRET
SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 16
EV3: CARA A,(AR4)
FOO MOVEI B,VALUE
PCALL GET+1 ;don't need to check for id
JUMPE A,UNDFUN ;function object has no definition
CDRA A,(A)
CARA B,(AR4)
CAIE A,(B) ;Error if same id
UBDPTR:
FOO CAIN A,UNBOUND
JRST UNDFUN
CDRA B,(AR4) ;eval (cons a (cdr AR4))
PCALL CONS
EVAL: HRRZM A,AR4
CAILE A,INUMIN
JRST CPOPJ
CARA T,(A)
CAILE T,ATMIN
JRST EE1 ;x is atomic
CAILE T,INUMIN
JRST UNDFUN
CARA TT,(T)
CAIN TT,ID
JRST EE2 ;car (x) is an id
CAIL TT,CODMIN
JRST EVCOD
CAIG TT,ATMIN
JRST EXP3
IFE APPL,<
UNDFUN: CARA A,(AR4)
ERRE1 ^D28,[SIXBIT /UNDEFINED FUNCTION - EVAL!/] >
IFN APPL,<
JRST RETAR4
UNDFUN==RETAR4 >
EE1: CAIE T,ID
PRET ;constant
FOO MOVEI B,VALUE
PCALL IGET
EXCH A,AR4
JUMPE AR4,UNBVAR
CDRA AR4,(AR4)
IFE APPL,<
FOO CAIN AR4,UNBOUND
UNBVAR: ERRE1 ^D29,[SIXBIT /UNBOUND VARIABLE - EVAL!/] >
IFN APPL,<
FOO CAIE AR4,UNBOUND
UNBVAR==CPOPJ >
MOVEM AR4,A
PRET
PAGE
IFN FNRG,<
ALIST: SKIPE A,-1(P)
PCALL NUMBERP
PUSH SP,[0] ;mark for unbind
JUMPN A,AEVAL7 ;number
MOVE C,SC2 ;bottom of spec pdl
MOVEM C,AEVAL5#
SETOM AEVAL2
AEVAL8: MOVE C,SP
AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
JRST AEVAL1 ;done
AEVAL4: POP C,AR4
JUMPE AR4,AEVAL6 ;thru with block
MOVSS AR4
PUSH SP,(AR4) ;save value cell
HLRZM AR4,(AR4) ;store previous value in value cell
HRLM AR4,(SP) ;save pointer to spec pdl loc
JRST AEVAL4
FNGUBD: EXCH A,(P) ;spec pdl pointer
PCALL NUMVAL
MOVE D,A
FNGUB2: POP SP,T
JUMPE T,POPAJ ;done
MOVSS T ;pointer to value cell
RPLCA T,(T)
SKIPN 1(D)
AOBJN D,.-1 ;skip over spec pdl marker
PUSH D,(T) ;put value cell in spec pdl
HLRZM T,(T) ;restore value cell
JRST FNGUB2
%EVAL: PSAVE A
PSAVE B
PCALL ALIST
PREST A
MOVEI A,UNBIND
EXCH A,(P)
JRST EVAL
PAGE
AEVAL1: SKIPGE AEVAL2
SKIPN B,-1(P)
PRET ;done with binding
MOVE A,B ;ALIST binding...
PCALL REVERSE
SKIPA
ABIND2: MOVE A,B
CDRA B,(A)
CARA A,(A)
CDRA AR4,(A)
CARA A,(A)
PCALL BIND
JUMPN B,ABIND2
PRET
;spec pdl binding
AEVAL7: MOVE A,-1(P)
PCALL NUMVAL
SETZM AEVAL2
MOVEM A,AEVAL5 ;point to unbind to
JRST AEVAL8
AEVAL2: 0 ;0 for number, -1 for a-list *
> ;end of IFN FNRG
PAGE
EE2: CDRA T,(T)
FOO MOVEI D,FUNCELL
EE21: JUMPE T,EV3
MOVS TT,(T)
MOVS T,(TT)
CAIN D,(T)
JRA T,EE3
CARA T,TT
JRST EE21
EE3: CARA TT,T
CARA D,(T)
;FOO CAIN TT,SUBR
; JRST EVCOD
FOO CAIN TT,EXPR
JRST AEXPQ
;FOO CAIN TT,FSUBR
; JRST EFS
FOO CAIN TT,MACRO
JRST EFM
FOO CAIE TT,FEXPR
JRST UNDFUN
CAIE D,ID
CAIGE D,CODMIN
JRST AFEXP
EFS: CDRA T,(T)
CDRA A,(AR4)
JRST (T)
AFEXP: HLL T,(AR4)
PSAVE T
CDRA A,(A)
UUOS3I: TLO A,400000
PSAVE A
MOVNI T,1
JRST IAPPLY
AEXP: HLL T,(AR4)
EXP3: CDRA A,(AR4)
UUOS6: PSAVE T
CILIST: JSP TT,ILIST
EXP2: JRST IAPPLY
PAGE
AEXPQ: CAIE D,ID
CAIGE D,CODMIN
JRST AEXP
EVCOD: CDRA A,(AR4)
HLL T,(AR4)
UUOS2: CDRA T,(T)
PSAVE T ;For POPJ below --> call this addr.
JSP TT,ILIST
ESB1: MOVEI TT,CPOPJ
PDLARG: HRREI R,NACS(T)
JUMPGE R,PDLA1(R)
MOVMS R
CAILE R,NSUA-NACS
ERRL1 ^D145,[SIXBIT /TOO MANY ARGS FOR EXPR!/]
HRLI R,(R)
PXDROP R
MOVEI A,EXARG
HRLI A,1(P)
BLT A,EXARG-1(R)
PDLA1: PREST A+4
PREST A+3
PREST A+2
PREST A+1
PREST A
JRST (TT)
EFM: CALLF 1,(T)
JRST EVAL
PAGE
IFN FNRG,<
%APPLY: MOVEI R,3
JSP TT,ARGP1
MOVEM T,APFNG1#
PCALL ALIST
MOVE T,APFNG1
JSP TT,PDLARG
PSAVE C ;spec pdl pointer
PSAVE [FNGUBD] >
APPLY: PSAVE A
MOVEI T,0
AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
CARA C,(B)
PSAVE C ;push arg
CDRA B,(B)
SOJA T,AP3
IFN FNRG,<
IAP4: JUMPGE D,TOOFEW ;special case for fexprs
AOJN R,TOOFEW
PSAVE B
MOVE A,SP
PCALL FIX1A
EXCH A,(P)
MOVE B,A
MOVNI R,2
SOJA T,IAP5
FUNCT: PSAVE A
MOVE A,SP
PCALL FIX1A
PREST B
HLL A,(B)
PCALL DCONSA
FOO HRLI A,FUNARG
JRST DCONSA
PAGE
APFNG: SOS T
MOVEM T,APFNG1
JSP TT,PDLARG ;get args and funarg list
CDRA A,(A)
CDRA D,(A) ;a-list pointer
CARA A,(A) ;function
MOVN R,APFNG1 ;Positive no. of args
PSAVE D
PSAVE [FNGUBD]
JSP TT,ARGP1 ;replace args and fn name
PSAVE D ;a-list pointer
PCALL ALIST ;set up spec pdl
PREST D
AOS T,APFNG1
> ;end of IFN FNRG
IAPPLY: MOVE C,T ;state of world at entrance
ADDI C,(P) ;t has - number of args on pdl
ILP1A: CDRA B,(C) ;next pdl slot has function- poss fun name in lh
CAILE B,INUMIN
JRST UNDTAG
CARA TT,(B)
CAILE TT,ATMIN
JRST IAP1 ;fn is atomic
FOO CAIN TT,LAMBDA
JRST IAPLMB
IFN FNRG,<
FOO CAIN TT,FUNARG
JRST APFNG >
FOO CAIN TT,LABEL
JRST APLBL
PSAVE T
MOVE A,B
PCALL EVAL
PREST T
MOVE C,T
ADDI C,(P)
ILP1B: MOVEM A,(C)
JRST ILP1A
UNDTAG: MOVE A,(C) ;FN NAME,,FN
TLNE A,-1 ;Any function name ?
HLRZS A ;Yes!
ERRE1 ^D30,[SIXBIT /UNDEFINED FUNCTION - APPLY!/]
PAGE
IAP1: CAIGE TT,CODMIN
JRST UNDTAG
CAIE TT,ID
JRST APCOD
FOO MOVEI D,FUNCELL
CDRA B,(B)
IAPL1: JUMPE B,IAP2
MOVS TT,(B)
MOVS B,(TT)
CAIN D,(B)
JRA B,IAPL2
CARA B,TT
JRST IAPL1
IAPL2: CARA TT,B
;FOO CAIN TT,SUBR
; JRST APCOD
FOO CAIE TT,EXPR
ERRE1 ^D31,[SIXBIT /NOT EXPR - APPLY!/]
CARA D,(B)
CAIE D,ID
CAIGE D,CODMIN
JRST IAPXPR
APCOD: CDRA B,(B)
HRRZM B,(C)
JRST ESB1
IAPXPR: CDRA A,B
JRST ILP1B
PAGE
IAPLMB: CDRA B,(B)
CARA TT,(B)
CDRA B,(B)
CARA D,(TT)
CAIN D,ID
JUMPN TT,[ERRL1 ^D146,[SIXBIT /ILLEGAL LAMBDA FORMAT!/]]
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;no more args
JUMPE TT,TOMANY ;too many args supplied
IAP5: CARA A,(TT)
MOVEI AR4,1(T)
ADD AR4,P
HLLZ D,(AR4) ;tested in IAP4
RPLCA A,(AR4)
CDRA TT,(TT)
AOJA T,IPLMB1
IFE FNRG,IAP4==TOFEW
IPLMB2: JUMPN TT,IAP4 ;too few args supplied
PUSH SP,[0] ;mark for unbind
JUMPE R,IAP69
IPLMB4: PREST AR4
CARA A,AR4
PCALL BIND
AOJL R,IPLMB4
IAP69: PREST AR4
TLNE AR4,-1
FOO SKIPN BACTRF
JRST .+3
HRRI AR4,CPOPJ
PSAVE AR4
PCALL PROGN1
JRST UNBIND
TOMANY: ERRL1 ^D147,[SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW: ERRL1 ^D148,[SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
PAGE
APLBL: PUSH SP,[0] ;mark for unbind
CDRA B,(B)
CARA A,(B)
CDRA B,(B)
CARA AR4,(B)
MOVEM AR4,(C)
PCALL BIND
MOVEI A,APLBL1
EXCH A,-1(C)
EXCH A,LBLAD#
HRLI A,LBLAD
PUSH SP,A
JRST IAPPLY
APLBL1: PSAVE LBLAD
JRST SPECSTR
IAP2: CDRA A,(C)
FOO MOVEI B,VALUE
PCALL GET+1 ;don't need to check for id
JUMPE A,UNDTAG
CDRA A,(A)
CDRA B,(C)
CAIE A,(B)
FOO CAIN A,UNBOUND
JRST UNDTAG
JRST ILP1B
RETB:
PROG2: HRRZ A,B
PRET
PAGE
BIND: JSP D,CHKID
FOO CAIE A,TRUTH
JUMPN A,BIND4
ERRE2 ^D32,[SIXBIT /MAY NOT BE CHANGED!/]
BIND4: PSAVE B
PCALL BIND1 ;get value cell
PUSH SP,(A)
RPLCA A,(SP)
HRRZM AR4,(A)
POPBJ: PREST B
PRET
BIND1: HRRZM A,BIND3#
FOO MOVEI B,VALUE
PCALL GET+1
JUMPN A,CPOPJ
FOO MOVEI A,UNBOUND
PCALL DCONSA
MOVE TT,A
FOO HRLI A,VALUE
PCALL DCONSA
CDRA B,@BIND3
PCALL CONS
RPLCD A,@BIND3
MOVE A,TT
PRET
TUNBIND:SETZM SPSAV
MOVE B,SC2
UBD: CAMN SP,B
PRET
PCALL UNBIND
JRST UBD
SPECSTR: ;LAP...<PCALL SPECSTR>
UNBIND: POP SP,T
JUMPE T,CPOPJ
MOVSS T
HLRZM T,(T)
JRST UNBIND
PAGE
PROGBIND:MOVEI D,PROGB1 ;LAP...<CALL 0,PROGBIND><0 0 (FLUID --)>
SPEC1: PREST T
PUSH SP,[0] ;mark for unbind
SPEC2: LDB R,[POINT 13,(T),ACFLD]
CAIG R,377
JRST (D) ;prog- or lam-bind
JRST (T) ;next is opcode, so quit.
LAMBIND:JSP D,SPEC1 ;LAP...<CALL 0,LAMBIND><0 x (FLUID --)>
JUMPE R,SPEC3 ;Init = NIL
CAIG R,NACS
JRST LAMB1
CAIG R,NSUA ;Extended regs.
JRST LAMB2 ;Yes
MOVNI R,(R) ;From pdl
ADDI R,NSUA+1(P)
LAMB1: SKIPA R,(R)
PROGB1: SETZ R,
SPEC3: EXCH R,@(T)
HRL R,(T)
PUSH SP,R ;<address,,old-value>.
AOJA T,SPEC2
LAMB2: MOVE R,EXARG-NACS-1(R)
JRST SPEC3
;Miscellaneous special case compiler run time routines
%AMAKE: PSAVE A ;make alist for fsubr that requires it
MOVE A,SP
PCALL FIX1A
MOVE B,A
JRST POPAJ
IFE STL,<
%UDT: PCALL ERHED ;error print for undefined computed go tag
PCALL PRIN1
STRTIP [SIXBIT / UNDEFINED COMPUTED GO TAG IN !/]
MOVEI R,INUM0+17
HRRM R,ERRX
CDRA R,(P)
PCALL ERSUB3
JRST ERREND-1
%LCALL: MOVN A,T ;set up routine for compile lsubr
ADDI A,INUM0
ADDI T,(P)
PSAVE T
PCALL (3)
PREST T
SUBI T,(P)
HRLI T,-1(T)
ADD P,T
PRET >
SUBTTL ARRAY SUBROUTINES --- PAGE 17
IFN ASARY,<
ARRERR=-1
ARRAY: PCALL ARRAYS
HRRI AR5,1(R)
MOVE A,AR5
PUSH R,[0]
AOBJN A,.-1
ARREND: MOVE A,BPPNR#
MOVEM AR5,-1(A)
MOVEI A,1(R)
PCALL FIX1A ;MOVEI A,INUM0+1(R)
FOO MOVEM A,VBPORG
PRET
ARRAYS: PSAVE A
FOO MOVE A,VBPORG
PCALL NUMVAL ;SUBI A,INUM0
MOVEM A,BPPNR
FOO MOVE A,VBPEND
PCALL NUMVAL ;MOVNI A,-INUM0-2(A)
MOVN A,A
ADDI A,2
ADD A,BPPNR ;bporg-bpend+2
HRLM A,BPPNR
HRRZ A,BPPNR
ADDI A,2
PCALL IMKCODE
FOO MOVEI B,EXPR
PREST A
CDRA AR4,(A) ;(cdr l)
CARA A,(A) ;(car l)name
PCALL IPUTD
CARA A,(AR4) ;(cadr l)mode
PSAVE AR4
PCALL EVAL ;eval mode
PREST AR4
MOVEM A,AMODE#
MOVEI C,44
JUMPE A,ARRY1
MOVEI C,-INUM0(A)
CAILE A,INUMIN
JRST ARRY1
MOVEI C,22
MOVE A,GCMKL
HRL A,BPPNR
PCALL DCONSA ;IFF Lisp-pntrs requested,
MOVEM A,GCMKL ;record for GC marking of arrays.
ARRY1: MOVEM C,BSIZE#
MOVEI A,44
IDIV A,C
MOVEM A,NBYTES#
CDRA A,(AR4) ;(cddr l)bound pair list
JSP TT,ILIST
AOS R,BPPNR
MOVEI AR4,1 ;AR4 is array size
MOVEI AR5,0 ;AR5 is cumulative residue
AOJGE T,ARRYS ;single dimension
MOVEI D,A-1
SUB D,T ;D is next ac for array code generation
ARRY2: PCALL ARRB0
TLC TT,(IMULI)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
CAIN D,A
JRST ARRY3
MOVSI TT,(ADD)
ADDI TT,1(D)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
SOJA D,ARRY2
ARRB0: PREST TT ;E.G., after ARRAY XX(5,6),
EXCH TT,(P) ; extents= (0:5,0:6), =42, = 0:41,
CAILE TT,INUMIN ; generates SUBR #22002, say, and
JRST ARRB1 ;22000/ -25,,22016 ;-N/2,,data
CARA A,(TT) ; 001/ 5,,-10 ;INUM0*8
CDRA TT,(TT) ; 002/ IMULI A,7
SUBI TT,(A) ; 003/ ADD A,B
ADDI TT,1 ; 004/ SUB A,22001
JRST ARRB2 ; 005/ JUMPL A,ARRERR;indexing .LT. (0,0)
; 006/ CAIL A,^D42
ARRB1: MOVEI A,INUM0 ; 007/ JRST ARRERR
SUB TT,A ; 010/ IDIVI A,2 ;half-word pntrs.
ARRB2: IMUL A,AR4 ; 011/ IMULI B,-^D18_12 ;bytesize.
IMULB AR4,TT ; 012/ HRLZI C,(POINT 18,0(B),17)
ADDM A,AR5 ; 013/ ADDI C,22016(A)
PRET ; 014/ LDB A,C ;proper halfword.
; 015/ PRET ;returning pntr, etc.
ARRY3: PUSH R,[ADD A,B] ; 016/ ...,,... ;INITIALLY 0 or NIL.
ARRYS: PCALL ARRB0
HRRZ TT,BPPNR
MOVEM AR5,(TT) ;SUBR-1, e.g. 22001.
HRLI TT,(SUB A,)
PUSH R,TT
PUSH R,[JUMPL A,ARRERR]
MOVE TT,AR4
HRLI TT,(CAIL A,)
PUSH R,TT
PUSH R,[JRST ARRERR]
IDIV AR4,NBYTES ;calc #words in array
SKIPE AR5 ;correct for remainder non-zero
ADDI AR4,1
MOVE TT,NBYTES
SOJE TT,ARRY6
ADDI TT,1
HRLI TT,(IDIVI A,)
PUSH R,TT
MOVN TT,BSIZE
LSH TT,14
HRLI TT,(IMULI B,)
PUSH R,TT
MOVEI TT,44+200
SUB TT,BSIZE
LSH TT,6
ARRY6: ADD TT,BSIZE
LSH TT,6
SKIPE AR5,AMODE
CAIL AR5,INUMIN
ADDI TT,40 ;mode not = T
TLC TT,(MOVSI C,)
PUSH R,TT
MOVEI TT,4(R)
HRLI TT,(ADDI C,(A))
PUSH R,TT
PUSH R,[LDB A,C]
MOVSI AR5,(PRET)
SKIPN TT,AMODE
MOVE AR5,[JRST FLO1A]
CAIL TT,INUMIN
MOVE AR5,[JRST FIX1A]
PUSH R,AR5
MOVS AR5,AR4
MOVNS AR5
PRET
STORE: PSAVE A
PCALL CADR
PCALL EVAL ;value to store
EXCH A,(P)
CARA A,(A)
PCALL EVAL ;byte pointer returned in c
PREST A
NSTR: PSAVE A
TLNE C,40
JSP D,ONUMV ;numerical array
JRST BIGNER ;BIGNUM IS ERROR
DPB A,C
PREST A
PRET > ;end of IFN ASARY from line 300
PAGE
IFN ALOD&ASARY,<
EXARRAY:PSAVE A
CARA A,(A)
PCALL GETSYM
JUMPE A,POPAJ
PCALL NUMVAL
EXCH A,(P)
PCALL ARRAYS
PREST A
HRRM A,-2(R)
HRR AR5,A
JRST ARREND > ;end of IFN ALOD&ASARY
DLVECT:
IFN ASARY,SETZ AR4, ;To reduce GC overhead, or GCing of
JSP D,ATMTYP
CAIE TT,VECT
IFN ASARY,<
JRST .+2
JRST ISVC ; obsolete array in BPS overlays, e.g.
MOVE AR4,A
PCALL GETD
JUMPE A,FALSE ;Gone.
CARA D,(A)
FOO CAIE D,EXPR >
JRST FALSE
ISVC: CDRA A,(A)
MOVEI TT,GCMKL ;Delete a Lisp array from the GC list,
DLARRLP:CDRA T,(TT) ; If done with it, tho can't reclaim core yet.
CARA C,(T)
CAIN C,-2(A)
JRST DLFOUND
CDRA TT,(TT)
JUMPN TT,DLARRLP
JRST FALSE ;Not found.
DLFOUND:CDRA T,(T)
RPLCD T,(TT) ;Cut out of list.
IFN ASARY,<SKIPE A,AR4
PCALL REMD> ;Delete the SUBR pointer from the Lisp array
JRST TRUE
PAGE
MKVECT: PCALL NUMVAL
JUMPL A,VECOV+1
PSAVE A
LSH A,-1
PSAVE A
FOO MOVE A,VBPORG
PCALL NUMVAL
EXCH A,(P)
ADD A,(P)
ADDI A,3
PCALL FIX1A
PSAVE A
FOO MOVE B,VBPEND
PCALL .GREAT
JUMPN A,VECOV
FOO PREST VBPORG ;set new bporg
MOVE A,GCMKL
HRL A,(P)
PCALL DCONSA
HRRM A,GCMKL
PREST A ;old bporg, i.e. beginning of vector
MOVE B,(P)
LSH B,-1
ADDI B,1
MOVNS B
HRLM B,(A)
ADDI A,2
HRRM A,-2(A)
MOVE B,-2(A)
SETZM (B) ;fill vector with NIL
AOBJN B,.-1
PREST -1(A) ;Upper limit for vector
HRLI A,VECT
JRST DCONSA
PAGE
GETV: JSP T,OPV
CARA A,(B)
CDRA A,(B)
PUTV: JSP T,OPV
RPLCA A,(B)
RPLCD A,(B)
OPV: JSP D,ATMTYP
CAIE TT,VECT
ERRE2 ^D33,[SIXBIT /IS NOT A VECTOR!/]
CDRA TT,(A)
MOVE A,C
SUBI B,INUM0
JUMPL B,INXOV
CAMLE B,-1(TT) ;compare with upper limit
JRST INXOV ;too big
TRNE B,1 ;odd or eaven
ADDI T,1 ;odd
LSH B,-1
ADDI B,(TT)
XCT (T)
PRET
VECTORP:
UPBV: JSP D,ATMTYP
CAIE TT,VECT
JRST FALSE
CDRA A,(A)
MOVE A,-1(A)
JRST FIX1A
INXOV: MOVEI A,INUM0(B)
ERRE2 ^D34,[SIXBIT /SUBSCRIPT IS OUT OF RANGE!/]
VECOV: MOVE A,-2(P)
ADDI A,INUM0
ERRE2 ^D35,[SIXBIT /TOO BIG VECTOR!/]
SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 18
BOOLE: SUBI A,INUM0
DPB A,[POINT 4,BOOLI,OPFLD-2]
MOVE A,B
PCALL NUMVAL
EXCH C,A
BOOLL: PCALL NUMVAL
BOOLI: SETZB C,A
JRST FIX1A
EXAMINE:PCALL NUMVAL ;<MOVE A,-INUM0(A)>
MOVE A,(A)
JRST FIX1A
DEPOSIT:MOVE C,B
PCALL NUMVAL ;<MOVEI C,-INUM0(A)
EXCH A,C ; MOVE A,B >
JSP D,ONUMV
BIGNER: ERRL0 ^D139,[SIXBIT /BIGNUM UNSUITABLE AS ARG!/] ;AASCII,BOOLE,etc.
MOVEM A,(C)
JRST MAKNUM
LSH: MOVEI C,-INUM0(B)
PCALL NUMVAL
LSH A,(C)
JRST FIX1A
SUBTTL GARBAGE COLLECTOR --- PAGE 19
GC: PCALL AGC
JRST FALSE
AGC2: SKIPE GCFFLG ;did we just do a GC from top ?
PRET ;yes, don't do it again
SETOM GCFFLG ;indicate GC from top
AGC: MOVEM R,ACSAV+R
AGC1: MOVEM SP,SPSAV ;save in case of ^C
MOVE NIL,CNIL3 ;set NIL
PSAVE .JBUUO
PSAVE UUOH
GCPK1: PSAVE PA3
PSAVE PA4
PSAVE UBDPTR ;special atom UNBOUND; not on OBLIST
PSAVE MKNAM3
PSAVE GCMKL ;i/o channel input lists and arrays
PSAVE BIND3
GCPK2: PSAVE [XWD 0,GCP6] ;this is a return address
MOVEI D,ACSAV
BLT D,ACSAV+11 ;save ACs 0 through 11
GCP2: SETZB NIL,X ;gc indicator, init. for bit table zero
MOVE A,C3GC
GCP5: BLT A,X ;zero bit tables, .=top of bit tables
FOO SKIPN GCGAGV
JRST GCP5A
CAIN F,ILLAD
STRTIP [SIXBIT /_*** FREE STG EXHAUSTED_!/]
SKIPN FF
STRTIP [SIXBIT /_*** FULL WORD SPACE EXHAUSTED_!/]
GCP5A: MOVEI TT,1
MOVEI A,0
CALLI A,STIME ;time
MOVEM A,GCTIMT#
GCP3: MOVEI C,X ;.=bottom of reg pdl
GCP6B: MOVE S,P
HLL C,P
MOVEI B,0
GC1: CAMN C,S
PRET
HRRZ A,(C)
GCP: CAIGE A,X ;.=bottom of bit tables
GCPP1:
FOO CAIGE A,FS
JRST GCEND
GCP1: CAIL A,X ;.=bottom of full word space (fws)
JRST GCMFWS
MOVE F,(A)
LSHC A,-5
ROT B,5
MOVE AR4,GCBT(B)
GCBTP2: TDOE AR4,X(A) ;bit tab- (fs_-5), .=magic number for sync
JRST GCEND
GCBTP1: MOVEM AR4,X(A) ;bit tab- (fs_-5)
PSAVE F
CARA A,F
JRST GCP
GCMFWS: MOVEI AR4,X(A) ;.=- bottom of fws
IDIVI AR4,44
MOVNS AR5
LSH AR5,36
ADD AR5,C2GC
DPB TT,AR5
GCEND: CAMN P,S
AOJA C,GC1
PREST A
HRRZS A
JRST GCP
CNIL3:
FOO XWD ID,CNIL2 ;NIL header to refresh ac 0
GCMKL: XWD 0,.+1+X ;Appended to, for each Lisp-pntr array.
XWD .+1,.+2
XWD -NSUA+NACS-1,EXARG
XWD .+1,.+2
XWD -11,ACSAV ;Reg 0 - 10 are saved from gc this way
XWD .+1,NIL
XWD -NIOCH,CHTAB+FSTCH
C2GC: XWD 430100+AR4,X ;.=bottom of fws bit table
C3GC: 0 ;<bottom bit table,,bottom bit table+1>
GCBT: XWD 400000,0
ZZ==1B1
XLIST
REPEAT ^D31,<ZZ
ZZ==ZZ/2>
LIST
PAGE
GCP6: HRRZ R,SC2
GCP6C: CAILE R,(SP) ;mark sp
JRST GCP6A
PSAVE (R)
HRRZ C,P
PCALL GCP6B
P1DROP
AOJA R,GCP6C
GCP6A: HRRZ R,GCMKL ;mark arrays
GCP6D: JUMPE R,GCSWP
CARA A,(R)
MOVE D,(A) ;<-N,,ADDR>
GCP6E: PSAVE (D)
CDRA C,P
PSAVE (D)
MOVSS (P)
PCALL GCP6B
P2DROP
AOBJN D,GCP6E
CDRA R,(R)
JRST GCP6D
GFSWPP:
PHASE 0
GFSP1==.
JUMPL S,.+3
HRRZM F,(R)
HRRZ F,R
ROT S,1
AOBJN R,.-4
MOVE S,(D)
HRLI R,-40
AOBJN D,GFSP1
LPROG==.
JRST GFSPR
DEPHASE
PAGE
;garbage collector sweep
GCSWP: MOVSI R,GFSWPP
BLT R,LPROG
MOVEI F,ILLAD
MOVE D,C3GCS
FOO MOVEI R,FS
GCBTL1: HRLI R,X ;-(32-<fs&37>
MOVE S,(D)
GCBTL2: ROT S,X ;fs&37
AOBJN D,GFSP1
GFSPR: MOVE A,C1GCS
MOVE B,C2GCS
PCALL GCS0
FOO SKIPN GCGAGV
JRST GCSP1
PCALL WHEAD
MOVE A,F
PCALL GCPNT
STRTIP [SIXBIT / FREE STG,!/]
MOVE A,FF
PCALL GCPNT1
STRTIP [SIXBIT / FULL WORDS AVAILABLE!/]
PCALL TOURET
GCSP1: PXDROP [XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
PREST UUOH
PREST .JBUUO
MOVE NIL,ACSAV
SETZM SPSAV
CAIN F,ILLAD
ERRG ^D260,[SIXBIT /NO FREE STG LEFT!/]
JUMPE FF,[ERRG ^D261,[SIXBIT /NO FULL WORDS LEFT!/]]
MOVEI A,0
CALLI A,STIME ;time
SUB A,GCTIMT
ADDM A,GCTIM#
MOVSI D,ACSAV
BLT D,S ;reload ac's
MOVE R,ACSAV+R
IFN OPSYS,<
SKIPE KBINTF ;Any user ^char interrupts from KB?
JRST KBINTH > ; Yes, process.
PRET
PAGE
GCS0: MOVEI FF,0
GCS1: ILDB C,B
JUMPN C,GCS2
HRRZM FF,(A)
HRRZ FF,A
GCS2: AOBJN A,GCS1
PRET
C1GCS: 0 ;<- length of fws,,bottom of fws>
C2GCS: POINT 1,X,35 ;.=bottom of fws bit table
C3GCS: 0 ;-n wds in bt,,bt
GCTIME: MOVE A,GCTIM
JRST FIX1A
TIME: MOVEI A,0
CALLI A,STIME
JRST FIX1A
SPEAK: MOVE A,CONSVAL#
JRST FIX1A
GCPNT1: MOVEI B,0
JUMPE A,LOOP0
HRRZ A,(A)
AOJA B,.-2 ; B:=LENGTH(A)
GCPNT: MOVEI B,0
JRST .+2
HRRZ A,(A)
CAIE A,ILLAD
AOJA B,.-2
LOOP0: PCALL FIX1
JRST PRIN1
SUBTTL GETSYM,PUTSYM --- PAGE 20
IFN ALOD,< ;this entire page
R50MAK: PCALL PNAMUK
PUSH C,[0]
HRLI C,700
HRRI C,(SP)
MOVEI B,0
MK3: ILDB A,C
LDB A,R50FLD
CAMGE B,[50*50*50*50*50]
SKIPN A
PRET
IMULI B,50
ADD B,A
JRST MK3
GETSYM: PCALL R50MAK
TLO B,040000 ;04 for globals
MOVE C,.JBSYM
MK7: CAMN B,(C)
JRST MK10 ;found
AOBJP C,.+2
AOBJN C,MK7
TLC B,140000 ;10 for locals
TLNN B,100000
TLON B,400000 ;Suppressed to DDT
JRST MK7-1
JRST FALSE
MK10: MOVE A,1(C) ;value
JRST FIX1A
PUTSYM: PSAVE B
PCALL R50MAK
MOVE A,B
TLO A,040000 ;make global
SKIPL .JBSYM
AOS .JBSYM ;increment initial symbol table pointer
PSAVE A
MOVEI A,2
PCALL EXPND2
MOVN B,[XWD 2,2]
ADDB B,.JBSYM
PREST (B) ;Name
PREST 1(B) ;value
JRST FALSE
> ;end of IFN ALOD
SUBTTL FASLOAD --- PAGE 21
;From MIT-ML, converted to LISP 1.6 of Utah
;By KRK, Last edit: 09 Aug 76
IFN OFLD,<
LDFNM2==137 ;Address of Lisp version number (if any).
LDGPRO==0 ;Address (relative to reg P) of internal QLIST
LDPRLS==-1 ; - " - P.URCLOBRL
LDAAOB: 0 ;Currently highest index in Atomtable
LDAGCM: 0 ;Address of GCMKL word for Atomtable
LDAPTR: 0(TT) ;Base address for Atomtable. Index in TT
LDBYTS: 0 ;Holds word being unpacked into bytes
LDEOFJ: 0 ;Error index
LDF2DP: 0 ;XOR between current and file version number
LDGROW: 0 ;For extended Atomtable. Not used
LDHLOC: 0 ;Not used
LDOFST: 0(TT) ;Start of currently loaded routine. Relocation base
;LDPRDF: 0 ;Internal !*PREDEF flag
;Error indices
LOOK==-1
EMPTYF==0
FORMAT==1
GCPROT==2
BPFULL==3
FTFULL==4
PAGE
; FASLOD('ArrayForFisl);
FASLOD: ;MOVEM B,LDPRDF ;"Print redefined funcs".
FOO SKIPN C,VPURIFY
TLOA C,(1B0)
FOO CDRA C,VP.URCLOBRL
PSAVE C ;- to omit; 0 or old-addr to purify.
PSAVE C ;LDGPRO zeroed below.
SETZM LDEOFJ ;An EOF is erroneous until LDBEND byte.
JSP D,ATMTYP
CAIE TT,VECT
JRST LDFERR
CDRA A,(A) ;Lookup ATOMTABLE's access addr...
MOVEI B,-2(A)
MOVEM B,LDAGCM ;Addr of array's allocation-wd (GCMKL).
MOVE B,-2(A)
HRRM B,LDAPTR ;Addr of array's data base-wd.
SETZ TT,
SETZM @LDAPTR ;0th is NIL [N.B. indirection-addr uses TT].
LDMORE: JSP T,LDGTWD ; ...except that can get empty file.
JUMPE TT,.-1 ;Sluff leading/trailing 0 words.
SETZM LDEOFJ ;(Reset after a new file's LDMORE).
AOS LDEOFJ ;Now 1 for "Format error".
CAME TT,[ASCII /FASLP/]
JSP D,LDFERR ;Improper format for FASL file.
JSP T,LDGTWD ;Get 2nd word of each file.
XOR TT,LDFNM2 ;Compare to Lisp's version&flags.
MOVEM TT,LDF2DP ;Nonzero if different.
SETZM FFFSUB#
SETZM LDGPRO(P) ;Internal QLIST effectively.
HLLZ A,@LDAGCM ;[-length,,0]
AOBJN A,.+1
MOVEM A,LDAAOB ;Commence with 1th cell; NIL is 0th.
FOO MOVE A,VBPORG
PCALL NUMVAL
HRRM A,LDOFST ;Also a TT indirection pntr.
HRRZM A,R ;Form AOBJP wd in R for BPS storage...
MOVE B,LDAGCM ; [Use this rather than BPEND1].
SUBI A,-1(B)
JUMPL A,USE.IT
FOO MOVE A,VBPEND
PCALL NUMVAL
MOVE B,A
MOVE A,R
SUBI A,(B)
JUMPGE A,FASLNC
USE.IT: HRLI R,(A) ; [-<available BPS>,,<starting BPORG>]
SETZM LDHLOC ;Initialize for the BPS section.
MOVE AR4,[000400,,LDBYTS] ;Initialize for accessing each
JRST LDBIN ; 9*4 series of bytes.
PAGE
;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED,
;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES:
;;; AR4 BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES
;;; R AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE
LDREL: HRRI TT,@LDOFST ;[RELOCATABLE WORD]
LDABS: MOVEM TT,(R) ;[ABSOLUTE WORD]
LDABS1: AOBJP R,FASLNC ;EXCEEDED AVAILABLE BPS -- NO CORE.
LDBIN: TLNN AR4,770000
JRST LDBIN2 ;OUT OF RELOCATION BYTES - GET MORE.
LDBIN1: JSP T,LDGTWD ;GET WORD FROM INPUT FILE
ILDB T,AR4 ;GET CORRESPONDING RELOCATION BYTE
JSP D,@LDTTBL(T) ; - IT TELLS US WHERE TO GO
LDTTBL: LDABS ; 0 ABSOLUTE
LDREL ; 1 RELOCATABLE
LDSPC ; 2 SPECIAL
LDPRC ; 3 PURIFIABLE CALL
LDQAT ; 4 QUOTED ATOM
LDQLS ; 5 QUOTED LIST
LDGLB ; 6 GLOBALSYM PATCH
LDGET ; 7 GET DDT SYMBOL PATCH
LDAREF ; 10 ARRAY REFERENCE
LDPEN ; 11 PUT ENTRY POINT
LDATM ; 12 ATOMTABLE ENTRY
LDENT ; 13 ENTRY POINT INFO
LDLOC ; 14 LOC TO ANOTHER PLACE
LDPUT ; 15 PUT DDT SYMBOL
LDEVAL ; 16 EVALUATE MUNGEABLE
LDBEND ; 17 END OF BINARY
LDBIN2: JSP T,LDGTWD ;GET WORD OF RELOCATION BYTES
MOVEM TT,LDBYTS
SOJA AR4,LDBIN1 ;INIT BYTE POINTER AND GO GET DATA WORD
PAGE
LDSPC: MOVE T,TT ;[SPECIAL]
MOVE A,@LDAPTR
HLR TT,A ;GET ADDRESS OF SPECIAL CELL
TRNE TT,777000 ;WAS SUCH AN ADDRESS REALLY THERE?
JRST LDABS ; YES, WIN
TRNE TT,6 ; NO, IS THIS ATOM A NUMBER?
JSP D,LDFERR ; YES - LOSE!!!
TRZE TT,20 ;IS IT NON INTERNED ID ?
PCALL %GCPRO ;YES. PROTECT IT
MOVE TT,T
HRRZ A,@LDAPTR
SKIPN A
JSP D,LDFERR ;NO, LOSE IF NIL...ELSE
PCALL BIND1 ;GET VALUE CELL
MOVE TT,T
HRLM A,@LDAPTR ;SAVE VC ADDR IN ATOMTABLE (LH).
HRR TT,A ;AT LAST WE WIN
JRST LDABS
LDQAT: MOVE D,@LDAPTR ;[QUOTED ATOM]
TLNN D,777001 ;SKIP IF SPECIAL OR ALREADY USED
TLO D,1 ;ELSE TURN ON REFERENCE BIT
MOVEM D,@LDAPTR
HRRI TT,(D) ;GET ADDRESS OF ATOM
JRST LDABS
LDGLB: JSP D,LDFERR
REPEAT 0,<
SKIPL TT ;[GLOBALSYM PATCH]
SKIPA TT,LSYMS(TT) ;GET VALUE OF GLOBAL SYMBOL
MOVN TT,LSYMS(TT) ;OR MAYBE NEGATIVE THEREOF
ADD TT,-1(R) ;ADD TO ADDRESS FIELD OF
HRRM TT,-1(R) ; LAST WORD LOADED
JRST LDBIN
>
PAGE
LDQLS: MOVSI C,11 ;[QUOTED LIST]
PCALL LDLIST ;GOBBLE UP A LIST
JUMPE C,.+2
MOVEM TT,(R) ;PUT WORD IN BPS
PSAVE A
JSP T,LDGTWD ;GET HASH KEY FOR LIST
PREST A
PCALL %GCPRO ;PROTECT NEW LIST FROM GC.
JUMPE C,LDEVL7 ;IF -2, THIS LIST GOES INTO ATOMTABLE.
JRST LDABS1 ;OR -1, JUST INTO BPS.
LDLIS0: JSP T,LDGTWD
LDLIST: LDB T,[POINT 2,TT,2] ;[CONSTRUCT LIST]
JRST @LDLTBL(T)
LDLTBL: LDLATM ;ATOM
LDLLST ;LIST
LDLDLS ;DOTTED LIST
LDLEND ;END OF LIST
LDLATM: MOVE A,@LDAPTR
TLNN A,777011
IOR A,C
MOVEM A,@LDAPTR
PSAVE A
JRST LDLIS0
LDLLST: TDZA A,A
LDLDLS: PREST A
HRRZS TT
JUMPE TT,LDLLS3
LDLLS1: PREST B
PCALL XCONS
SOJG TT,LDLLS1
LDLLS3: PSAVE A
JRST LDLIS0
LDLEND: HLRZ C,TT
TRC C,777776 ;-1 to 1, -2 to 0.
TRNE C,777776 ;Any other?
JSP D,LDFERR ; is error.
PREST A
MOVSS TT
HRRI TT,(A)
PRET
PAGE
LDPRC: MOVE D,@LDAPTR ;[PURIFIABLE CALL]
TLNE D,777000
JRST LDPRC1 ;JUMP IF ATOM HAS SPECIAL CELL
TLNE D,6
JSP D,LDFERR ;LOSE IF NUMBER
TLO D,1 ;ELSE TURN ON REFERENCE BIT
MOVEM D,@LDAPTR
LDPRC1: TRNN D,-1 ;MUST HAVE NON-NIL ATOM TO CALL
JSP D,LDFERR
HRR TT,D ;PUT ADDRESS OF ATOM IN CALL
SKIPGE T,LDPRLS(P) ;SKIP FOR PURIFYING HACKERY
JRST LDABS ; Not active...DONE.
MOVEM TT,(R) ;Store the call-word,
HRRZ C,R ; and get its address...
JSP AR5,TRYSMSH ;NOW TRY TO SMASH IT
JRST LDABS1 ;SMASHED
HRLI A,(R) ;NOT SMASHED ...
HRR A,LDPRLS(P) ; APPEND ADDR TO PURE LIST
PCALL DCONSA ; TO RE-TRY AT LDFEND.
MOVEM A,LDPRLS(P)
JRST LDABS1
IFN 0,<
LDSMSH: LDB T,[POINT 9,(AR5),8]
CAIL T,34 ;CALL
CAILE T,35 ;JCALL
PRET
HRRZ A,(AR5) ;Pntr to atomhead.
PCALL GETD ;TRY TO GET EXPR, FEXPR PROP
LDB D,[POINT 4,(AR5),12] ;Destroys A,B,C,T,TT
JUMPE A,CPOPJ1 ;Can't be smashed since undefined yet.
CARA B,(A)
MOVE T,APOPJ1
FOO CAIN B,EXPR
MOVE T,[CAILE D,NSUA]
FOO CAIN B,FEXPR
MOVE T,[CAIE D,17]
XCT T
APOPJ1: JRST CPOPJ1 ;Don't smash if wrong # args wanted.
CDRA A,(A) ;ELSE WIN - SMASH THE CALL
CARA TT,(A)
CAIE TT,ID
CAIGE TT,CODMIN
JRST CPOPJ1
CDRA A,(A)
MOVE TT,(AR5)
MOVSI T,(PCALL) ;FCALL BECOMES PCALL
TLNE TT,1000
MOVSI T,(JRST) ;JCALL BECOMES JRST
IOR T,A
MOVEM T,(AR5) ;***SMASH!***
PRET > ;End of IFN 0
PAGE
LDGET: JSP D,LDFERR
REPEAT 0,<
CAMN TT,XC-1
JRST LDLHRL
MOVE D,TT ;[GET DDT SYMBOL PATCH]
TLNN D,200000 ;MAYBE THE ASSEMBLER LEFT US A VALUE?
JRST LDGET2
JSP T,LDGTWD ;FETCH IT THEN
SKIPE LDF2DP
JRST LDGET2 ;CAN'T USE IT IF VERSIONS DIFFER
LDGET1: TLNE D,400000 ;MAYBE NEGATE SYMBOL?
MOVNS TT
LDB D,[400200,,D] ;GET FIELD NUMBER
XCT LDXCT(D) ;HASH UP VALUE FOR FIELD
MOVE T,LDMASK(D) ;ADD INTO FIELD
ADD TT,-1(R) ; MASKED APPROPRIATELY
AND TT,T
ANDCAM T,-1(R)
IORM TT,-1(R)
JRST LDBIN
LDGET2: PSAVE . ;RANDOM P SLOT
PSAVE AR4 ;SAVE UP ACS
PSAVE D
PSAVE R
PSAVE F
MOVEI R,0
TLZ D,740000
CAME D,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
JRST LDGT5A ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS
LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
LSH F,-42
LDB TT,LDGET6(F)
MOVE TT,LSYMS(TT)
JRST LDGT5B
LDGT5A: MOVEI TT,R70
CAMN D,[SQUOZE 0,R70]
JRST LDGT5B
PCALL UNSQOZ ;CONVERT SQUOZE TO A LISP SYMBOL
MOVEI C,(A)
MOVEI B,QSYM ;TRY TO FIND SYM PROPERTY
PCALL GET
JUMPN A,LDGETJ ;WIN
SKIPN JOBSYM
JRST LDGETX
LDB D,[004000,,-2(P)]
LDGET4: MOVE TT,D
IDIVI D,50
JUMPE R,LDGET4
PCALL GETDD0
JRST LDGETX
PAGE
LDGT5B: MOVEM TT,-4(P) ;WIN, WIN - USE RANDOM P SLOT
MOVEI A,-4(P) ; TO FAKE UP A FIXNUM
JRST LDGETJ
LDGETX: MOVEI A,(C)
PCALL NCONS
MOVEI B,QGETDDTSYM ;DO A FAIL-ACT
PCALL XCONS
PCALL LDGETQ
LDGETJ: PREST F ;RESTORE ACS
PREST R
PREST D
PREST AR4
MOVE TT,(A)
PCALL TYPEP ;FIGURE OUT WHAT WE GOT BACK
PREST -1(P) ;POP RANDOM SLOT (REMEMBER THE LOCKI!)
CAIN A,FIXNU
JRST LDGET1
LDGETV: CAIN A,FLONU ;USE A FLONUM IF WE GET ONE
JRST LDGET1
LDGETW: SKIPE TT,JOBSYM
MOVSI TT,1
MOVEM TT,LDDDTP(P)
JRST LDGET2
LDGETQ:; FAC [CAN'T GET DDT SYMBOL - FASLOAD!]
LDGET6: REPEAT 4,<<11_^D24>+<<<3-.RPCNT>*11>_^D30> LAP5P(R)
>
LDXCT: MOVSS TT ;INDEX FIELD
HRRZS TT ;ADDRESS FIELD
LSH TT,^D23 ;AC FIELD
JFCL ;OPCODE FIELD
LDMASK: -1 ;INDEX FIELD
0,,-1 ;ADDRESS FIELD
0 17, ;AC FIELD
-1 ;OPCODE FIELD
LDLHRL: HRLZ TT,LDOFST
ADDM TT,-1(R)
JRST LDBIN
>
PAGE
LDAREF: JSP D,LDFERR
REPEAT 0,<
PSAVE TT ;[ARRAY REFERENCE]
MOVE D,@LDAPTR
TLNN D,777001
TLO D,11
MOVEM D,@LDAPTR
MOVEI A,(D)
PCALL TTSR+1 ;NCALL TO TTSR
HLL TT,(P)
PXDROP R70+1
JRST LDABS
>
LDATM: LDB T,[POINT 3,TT,3] ;[ATOMTABLE ENTRY]
JRST @LDATBL(T)
LDATBL: LDATPN ;INTERNED ID
LDATPI ;NON INTERNED ID
LDATPS ;STRING
LDATFX ;FIXNUM
LDATFL ;FLONUM
LDATBP ;POSNUM (POSITIVE BIGNUM)
LDATBN ;NEGNUM (NEGATIVE BIGNUM)
LDAREF ;TO GET ERROR
LDATPB: MOVSI C,(TT)
MOVN C,C
HRRI C,0(SP)
JSP T,LDGTWD
MOVEM TT,1(C)
AOBJN C,LDGTWD ; T still has return address
PRET
LDATPN: PCALL LDATPB ;[ATOMTABLE INTERNED ID ENTRY]
PCALL INTER0
LDATP8: MOVE TT,LDAAOB
MOVEM A,@LDAPTR
AOBJP TT,LDAEXT
MOVEM TT,LDAAOB
JRST LDBIN
LDATPI: PCALL LDATPB ;[ATOMTABLE NON INTERNED ID ENTRY]
PCALL NOINTR
TLO A,20 ;Mark for saving
JRST LDATB2
PAGE
LDATPS: PCALL LDATPB ;[ATOMTABLE STRING ENTRY]
PCALL MSTR1
JRST LDATB2
LDATFX: JSP T,LDGTWD ;[ATOMTABLE FIXNUM ENTRY]
PCALL FIX1A
CAILE A,INUMIN
TLOA A,12 ;INUM -- doesn't need GC pro.
TLO A,2
JRST LDATP8
LDATFL: JSP T,LDGTWD ;[ATOMTABLE FLONUM ENTRY]
PCALL FLO1A
TLO A,4
JRST LDATP8
LDATBN: SKIPA C,[NEGNU] ;[ATOMTABLE NEGNUM ENTRY]
LDATBP: MOVEI C,POSNU ;[ATOMTABLE POSNUM ENTRY]
PSAVE C
MOVEI C,(TT)
MOVEI B,NIL
LDATB1: JSP T,LDGTWD
PCALL FWCONS
PCALL CONS
MOVE B,A
SOJG C,LDGTWD ;T STILL HAS RETURN ADDRESS
PREST B
PCALL XCONS
LDATB2: TLO A,6
JRST LDATP8
LDAEXT: MOVEI T,FTFULL
JRST LDERRT
REPEAT 0,<
MOVM T,LDGROW ;[ATOMTABLE EXTEND]
MOVNS T
HRL TT,T
MOVEM TT,LDAAOB ; Another page or so.
MOVS TT,@LDAGCM
ADD TT,T ; and protect the extension.
MOVSM TT,@LDAGCM
JRST LDBIN
>
PAGE
LDENT: PCALL LDEPIN ;[ENTRY POINT INFO]
FOO SKIPN VPREDEF
JRST LDNRDF
MOVE A,-1(P)
PCALL GETD
JUMPE A,LDNRDF
MOVE A,-1(P)
PSAVE R
PSAVE AR4
PCALL WHEAD
PCALL PRIN1
STRTIP [SIXBIT / REDEFINED!/]
PCALL TOURET
PREST AR4
PREST R
LDNRDF: PREST B
PREST C
PREST A
FOO CAIE B,SUBR
JRST .+3
FOO MOVEI B,EXPR
JRST .+4
FOO CAIE B,FSUBR
JRST .+3
FOO MOVEI B,FEXPR
SETOM FFFSUB
PCALL IPUTD ;USES T,TT
JRST LDBIN
LDPEN: PCALL LDEPIN ;[PUT ENTRY POINT]
PREST B
PREST A
PREST C
PCALL PUT
JRST LDBIN
LDEPIN: HRRZ C,@LDAPTR ;[ENTRY POINT INFO]
MOVSS TT
HRRZ A,@LDAPTR
PSAVE A ;ENTRY NAME.
PSAVE C ;SUBR TYPE.
JSP T,LDGTWD ;TT_<ARGS,,ENTRY-RELOC>...
MOVEI A,@LDOFST
CAILE A,(R)
JSP D,LDFERR
PCALL IMKCODE
EXCH A,-2(P)
JRST (A)
PAGE
LDLOC: JSP D,LDFERR
REPEAT 0,<
MOVEI TT,@LDOFST
MOVEI D,(R)
CAMLE D,LDHLOC
MOVEM D,LDHLOC
CAMG TT,LDHLOC
JRST LDLOC5
MOVE D,LDHLOC
SUBI D,(R)
MOVSI D,(D)
ADD R,D
HRR R,LDHLOC
SETZ TT,
ADD AR4,[040000,,]
JRST LDABS
LDLOC5: HRRZ D,LDOFST
CAIGE TT,(D)
JSP D,LDFERR
MOVEI D,(TT)
SUBI D,(R)
MOVSI D,(D)
ADD R,D
HRRI R,(TT)
JRST LDBIN >
PAGE
LDPUT: JSP D,LDFERR
REPEAT 0,<
SKIPN A,V$SYMBOLS ;[PUT DDT SYMBOLS]
JRST LDPUT3
CAIE A,SYMBOLS
JRST LDPUT7
TLNN TT,40000
JRST LDPUT3
LDPUT7: SKIPN JOBSYM
JRST LDPUT3
PSAVE AR4
JUMPL TT,LDPUT2
MOVE D,R
LDPUT0: PSAVE D
PSAVE F
TLZ TT,740000
LDPUT1: MOVE T,TT
IDIVI TT,50
JUMPE D,LDPUT1
MOVEI B,-1(P)
MOVSI R,400000
PCALL PUTDD0
JRST LDRSTX
LDPUT2: MOVE D,TT
JSP T,LDGTWD
EXCH TT,D
TLNN TT,100000
JRST LDPT2A
MOVE T,LDOFST
ADD T,D
HRRM T,D
LDPT2A: TLNN TT,200000
JRST LDPUT0
HRLZ T,LDOFST
ADD D,T
JRST LDPUT0
LDPUT3: JUMPGE TT,LDBIN ;DON'T WANT TO PUT DDT SYM, BUT
JSP T,LDGTWD ; MAYBE NEED TO FLUSH EXTRA WORD
JRST LDBIN
>
PAGE
LDEVAL: SETZ C, ;[EVALUATE MUNGEABLE]
PCALL LDLIST
PSAVE A
PSAVE C
PSAVE AR4
PSAVE R
MOVEI A,(R)
PCALL FIX1A
FOO MOVEM A,VBPORG ;Permit the mungeable to alter BPORG.
SKIPL A,LDPRLS-4(P)
FOO HRRZM A,VP.URCLOBRL ;Save us in case of ERR.
MOVE A,-3(P)
PCALL EVAL
EXCH A,-3(P) ;Save value, retrieve S-expr.
PSAVE A
FOO CDRA A,VP.URCLOBRL
HRRM A,LDPRLS-5(P)
FOO MOVE A,VBPORG
PCALL NUMVAL
PREST B
PREST R
SUBI A,(R) ;If BPORG unchanged,
JUMPE A,LDEVL5 ; then leave R & FARRAY alone.
JUMPLE A,LDEVL4 ; If lowered, keep R, just fix FARRAY.
ADDM A,LDOFST ;Hence can't do future LDLOC **********
HRLI A,(A)
ADD R,A ;Else decrease space-avail left.
LDEVL4:
FOO MOVE A,VFARRY ;Save S-exprs which change BPORG.
PCALL XCONS
FOO HRRZM A,VFARRY
LDEVL5: PREST AR4
PREST C
PREST A
JUMPN C,LDBIN ;IF -1, THROW AWAY VALUE;
PCALL %GCPRO ;OR -2, PROTECT & ENTER IN ATOMTABLE.
LDEVL7: TLO A,16 ;FROM LDQLS, IS ALREADY PROTECTED
JRST LDATP8
%GCPRO: HRRZ B,LDGPRO-1(P)
PCALL CONS
HRRM A,LDGPRO-1(P)
CARA A,(A) ;RETURN WHAT WE JUST APPENDED.
PRET
PAGE
LDBEND: CAME TT,[ASCII \FASLP\] ;[END OF BINARY]
JSP D,LDFERR
AOS LDEOFJ ;Now have seen End-of-Data in a file...
; Update BPS bounds and protect atoms
; from GC, then try for next file.
LDFEND: ;[END OF FILE]
HRRZ A,R
CAMGE A,LDHLOC
MOVE A,LDHLOC
PCALL FIX1A
FOO MOVEM A,VBPORG ;UPDATE BPORG
HRRZ R,LDAAOB
LDGCPR: SOJLE R,LDSDPL ;[GC PROTECT AS YET UNPROTECTED ATOMS]
MOVEI TT,(R)
MOVE AR5,@LDAPTR
HRRZ A,AR5
TLNN AR5,777010 ;IF VALUE-CELL OR ALREADY PROTECTED,
TLNN AR5,1 ;OR NO NEED (NEVER REF'D),
JRST LDGCPR ; PASS BY.
TLNE AR5,26
JRST LDGCP1 ;FIX,FLO,BIG,string or non-interned id
JRST LDGCPR
LDGCP1: HRRZ A,AR5
PCALL %GCPRO
JRST LDGCPR
LDSDPL: SKIPGE TT,LDPRLS(P) ;[RE-TRY SMASHING DOWN PURE LIST]
JRST LDEOMM
FOO MOVEM TT,VP.URCLOBRL ;Following retains locs unsmashed.
FOO MOVEI R,VP.URCLOBRL
LDSDP1: SKIPN TT,LDPRLS(P)
JRST LDEOMM
LDSDP2: CDRA T,(TT)
MOVEM T,LDPRLS(P)
CARA C,(TT)
JSP AR5,TRYSMSH
JRST LDSDP3
CDRA R,(R)
JRST LDSDP1
LDSDP3: MOVE TT,LDPRLS(P)
RPLCD TT,(R)
JRST LDSDP1
PAGE
LDEOMM: SKIPN A,LDGPRO(P) ;Have processed a FASL file completely,
JRST LDFNIL
FOO MOVE B,VF.LIST ; and protected internal Lisp node refs
PCALL CONS ; off the PDL with this final save.
FOO MOVEM A,VF.LIST
LDFNIL: MOVE A,LDAGCM
MOVE A,(A) ;Now clear array (so won't be SSAVEd),
SETZM 0(A) ; and read til true EOF does ERR $EOF$
AOBJN A,.-1 ; or see start of next FASL in series.
;However, doesn't clear access routine.
SETOM LDEOFJ ;EOF will be okay, or start of next file.
JRST LDMORE ;Continue, with the extra PDL cells.
LDGTWD: PCALL TYID ;This is BINI w/o Lisp # conversion...
MOVE TT,A ; so inputting a 36-bit word or $EOF$.
JRST 0(T)
FASLNC: MOVEI T,BPFULL
JRST LDERRT
LDFERR: SKIPGE T,LDEOFJ ;Externally invoked after any ERRSET.
JRST LDFSUB ; OK - return after proper EOF.
MOVE T,LDEOFJ
LDERRT: MOVEI A,LDERRN ;Change...
MOVEM A,LDEOFJ ; Avoid doubly-printed LERRs.
CAILE T,LDERRN
ERRL1 ^D149,[SIXBIT \FASLOAD BUG!\]
JRST .+1(T) ;Else dispatch to the various errs...
LDERR0: ERRL1 ^D150,[SIXBIT \FASLOAD EMPTY FILE!\]
ERRL1 ^D151,[SIXBIT \FASLOAD FORMAT ERR!\]
ERRL1 ^D152,[SIXBIT \FASLOAD GC-PRO ERR!\]
ERRL1 ^D153,[SIXBIT \FASLOAD EXCEEDS BPS!\]
ERRL1 ^D154,[SIXBIT \FISLTABLE FULL!\]
LDERRN==.-LDERR0
ERRL1 ^D155,[SIXBIT \NOGO!\]
LDFSUB: SKIPN FFFSUB
PRET
SETZM FFFSUB
FOO SKIPE %MSG
STRTIP [SIXBIT /_*** (F)SUBR CONVERTED TO (F)EXPR_!/]
PRET
> ;End of IFN OFLD
IFN OFLD!NFLD,<
;Try convert slow link to fast link
TRYSMSH:HRRZ A,(C) ;right half of instruction
HLRZ T,(C) ;left half
CAIL T,(FCALL) ;is it FCALL or
CAILE T,777(JCALL) ; JCALL
JRST (AR5) ;No! Treat as sucessful, i.e. never smash
PCALL GETD ;get function definition
JUMPE A,1(AR5) ; unsucessful if wasn't there
MOVSI TT,(PCALL) ; replacement FCALL - PCALL
TRNE T,1000
MOVSI TT,(JRST) ; JCALL - JRST
ANDI T,740 ;Now check EXPR - FEXPR
FOO MOVEI D,EXPR
CAIN T,740
FOO MOVEI D,FEXPR ;argcount 17 means call a FEXPR
CARA B,(A) ;get function type
CAIE B,(D) ;is it right type for the call?
JRST 1(AR5) ;No! unsucessful
CDRA A,(A) ;code part
CARA D,(A) ;check tag
CAIE D,ID
CAIGE D,CODMIN
JRST 1(AR5) ;not a code pointer! unsucessful
HRR TT,(A) ;get code address into new instruction
MOVEM TT,(C) ;change instruction
JRST (AR5) ;sucessful
> ;End of IFN OFLD!NFLD
IFN NFLD,<
;New version of FASLOD
FASLOAD:PSAVE [0] ;internal F.LIST
HRRM P,LDQLIS ;save its pointer
FOO SKIPE VPURIFY ;want to try converting slow links to fast?
TDZA B,B ;yes
SETO B, ;no! make negative to indicate that
PSAVE B ;internal P.URCLOBRL
HRRM P,LDPURC ;save its pointer
MOVEM P,LDSTCK# ;save for stack check at end
JSP D,ATMTYP ;check F.ISLTABLE
CAIE TT,VECT ;is it a vector?
ERRL2 ^D168,[SIXBIT /NO TABLE FOR FASL!/] ;no! error
CDRA A,(A) ;get its base address
SETZM (A) ;first element is NIL
HRRM A,CTOPAT ;current top of table
HRRM A,LDATBAS ;base of table
JSP T,RSTBPO ;set internal BPORG and BPEND
SETZM CALHLF ;indicate need new word in half word buffer
MOVEI D,LDLOP+1 ;return address for LDBYT
LDNWD: PCALL TYID ;byte buffer is empty. get new word
MOVEM A,LDBTWD ;save word in buffer
MOVE A,[POINT 6,LDBTWD] ;get byte pointer
MOVEM A,LDBTPO# ;save it
LDBYT: ILDB A,LDBTPO ;get a byte
JUMPN A,(D) ;not 0 means not empty buffer
HRRZ TT,LDBTPO ;buffer might be empty
CAIN TT,LDBTWD ;does pointer still point to buffer?
JRST (D) ;yes! 0 byte
JRST LDNWD ;no! buffer empty
LDID: JSP D,LDHLF ;Get length of id
PCALL %FSLID+1 ;make interned id
LDPUTA: AOS .+1 ;update top of table
CTOPAT: MOVEM A,X ;move object into table
;this is the loader loop
LDLOP: JSP D,LDBYT ;get new loader code byte
CAIG A,LDBTMX ;is it a legal code
JRST @LDJTAB(A) ;Yes! Dispatch
ERRL2 ^D169,[SIXBIT /FASL FORMAT ERROR!/] ;No! Error
LDJTAB: LDEND
LDID
LDGENSYM
LDSTRNG
LDPOSN
LDNEGN
LDFIXN
LDFLON
LDQUO
LDCAL
LDRLO
LDAXCON
LDXCON
LDOFFSET
LDENTRY
LDXPR
LDLAPBLOCK
LDNCON
LDPUTV
LDMKVCT
.LDABS
LDPUSH
.LDEVAL
LDFLUID
LDSYM
LDEVID
LDSETQ
LDIPUT
.LDPUT
LDIPTD
LDPUTD
LDNUMP
LDXPRS
LDPOP
LDEVIX
.LDLIST
LDPOPN
LDPROTECT
LDBTMX==.-LDJTAB-1
LDGENSYM: ;make non interned id
FOO MOVEI C,PNAME
PCALL MKFWLIS ;make print name list
PCALL IDCONS-1 ;make into id
JRST LDPUTA ;put into table
LDPOSN: SKIPA C,CPOSNU ;positive bignum
LDNEGN: MOVEI C,NEGNU ;negative bignum
JRST LDSTRNG+1
LDSTRNG:MOVEI C,STRNG ;string
PCALL MKFWLIS ;read and make full word list
JRST LDPUTA ;put into table
MKFWLIS:JSP D,LDHLF ;read length of list
MOVE TT,A ;save count
SKIPA B,[0] ;start with NIL
MOVE B,A ;current list
PCALL TYID ;read a word
PCALL BCONS ;cons into list
SOJG TT,.-3 ;go back for more
HRL A,C ;get tag
JRST DCONSA ;cons it
LDFIXN: PCALL BINI ;read a fixnum
JRST LDPUTA ;put into table
LDFLON: PCALL TYID ;read a word
PCALL FLO1A ;tag as floating point number
JRST LDPUTA ;put into table
LDMKVCT:JSP T,SAVBPO ;allow BPORG to be changed
JSP D,LDHLF ;get uplim for vector
PCALL MKVECT+1 ;make vector
HRRZ C,(A) ;vector address
HRRM C,CLIPTV ;update "current vector base"
MOVE C,A
JSP T,RSTBPO ;update internal BPORG
MOVE A,C
JRST LDPUTA ;put vector into table
LDPUSH: MOVEI T,LDPU1 ;return address, push on stack
LGETVX: JSP D,LDHLF ;get table index
HRRZ A,@LDATBAS ;get element from table
JRST (T)
.LDABS: MOVEI D,LDPU1 ;push on stack
LDHLF: SETZ A,
EXCH A,CALHLF#
JUMPN A,.+3
PCALL TYID ;half word buffer empty. read new word
HLROM A,CALHLF ;save in buffer, -1 in lh make non-zero
MOVEI A,(A) ;get right half (get rid of -1)
JRST (D) ;return
LDAXCON:MOVEI D,.+3 ;make list ending with absolute
JRST LDHLF
LDXCON: JSP T,LGETVX ;make list ending with table element
SKIPA TT,A ;save table element in TT
LDNCON: SETZ TT, ;end with NIL (ordinary list)
JSP D,LDHLF ;length of list
EXCH A,TT ;get end into A
PREST B ;get element from stack
PCALL XCONS ;cons into list
SOJG TT,.-2 ;maybee more
LDPU1: PSAVE A ;save on stack
JRST LDLOP ;return to loop
;execute EXPR, arguments are on stack. put result on stack
LDXPR: JSP T,LGETVX ;get function id from table
PSAVE A ;save it
LDXPRS: JSP T,SAVBPO ;function is on stack
JSP D,LDBYT ;number of args
PREST REL ;function
DPB A,[POINT 4,LDCALL,ACFLD] ;update call instruction
MOVN T,A
JSP TT,PDLARG ;put args into regs
LDCALL: CALLF X,(REL) ;call function
PSAVE A ;save result on stack
MOVEI T,LDLOP ;return address
RSTBPO: ;Update internal BPORG and BPEND as the might have been changed
FOO HRRZ A,VBPEND
PCALL NUMVAL
HRRM A,LDBPEN ;update internal BPEND
FOO HRRZ A,VBPORG
PCALL NUMVAL
HRRM A,LDBPOR ;update internal BPORG
JRST (T)
.LDEVAL:JSP T,SAVBPO
JSP T,LGETVX ;get fexpr id
PREST B ;argument list
PCALL CONS
PCALL EVAL ;evaluate fexpr
JRST LDCALL+1
LDPOP: P1DROP ;remove top of stack
JRST LDLOP
LDEVID: JSP T,LGETVX ;get id from table
PCALL EVAL ;get its value
JRST LDPU1 ;push it on stack
LDSETQ: JSP T,LGETVX ;get id from table
PCALL BIND1 ;get its value cell
PREST (A) ;update value cell from stack
JRST LDLOP
LDIPUT: JSP T,LGETVX ;get id from table
HRRM A,CLIPUT ;update "current property indicator"
JRST LDLOP
LDIPTD: JSP T,LGETVX
HRRM A,CLIPTD ;update "current function type"
JRST LDLOP
.LDPUT: JSP T,LGETVX
PREST C ;property value
CLIPUT: MOVEI B,X ;property indicator
PCALL PUT
JRST LDLOP
LDPUTD: JSP T,LGETVX
PSAVE A ;save function id
FOO MOVEI B,TRACE ;remove TRACE property
PCALL REMP1
FOO SKIPN VPREDEF ;want to warn for redefined function
JRST NOPRDF ;no!
MOVE A,(P) ;is function
PCALL GETD ; already defined
JUMPE A,NOPRDF
MOVE A,(P) ;yes!
PCALL WHEAD ;warning header
PCALL PRIN1 ;print function name
STRTIP [SIXBIT / REDEFINED!/]
PCALL TOURET ;return to current output
NOPRDF: PREST C ;function id
PREST A ;function body
CLIPTD: MOVEI B,X ;function type
PCALL IPUTD ;define it
JRST LDLOP
LDPUTV: JSP D,LDHLF ;get vector index
PREST C ;value to put into vector
SETZ B,
LSHC A,-1
JUMPN B,.+3 ;B = 0 means even index
CLIPTV: HRLM C,X(A) ;X is current vector base. updated by LDMKVCT
JRST LDLOP
HRRM C,@CLIPTV ;odd index. value goes into right half
JRST LDLOP
LDLAPBLOCK: ;load a block of code
JSP D,LDHLF ;no of words to load
LDBPORG:MOVEI R,X ;internal BPORG
MOVEI C,(R)
ADDI C,(A) ;new BPORG
LDBPEND:CAILE C,X ;compare with internal BPEND
JRST BINER2 ;error if bigger
HRRM C,LDBPOR ;update BPORG
HRRM R,LDRLBAS ;set block base addres for relocation
SOJ R,
HRRM R,LDRSTRT ;set patch address base
HLLZS MPAFUN ;no patch function seen
MOVNI C,(A) ;make
HRL R,C ; iowd
PCALL TYID ;read a word
MOVEM A,1(R) ;deposit in BPS
AOBJN R,.-2 ;maybee more
JRST LDLOP
MAPAT: MOVEI C,X ;old patch address
ADDI C,77
MOVEI T,(T) ;patching function
CAIE T,@MPAFUN ;same as old
LDRSTRT: MOVEI C,X ;no! use patch base address. set by LDLAPBLOCK
HRRM T,MPAFUN ;set current patch function
MPARET: JSP D,LDBYT ;Get relative patch address. Patch funs return here
JUMPE A,[HRRM C,MAPAT ;0 byte means save patch address
JRST LDLOP] ; and end patching
ADDI C,(A) ;update patch address
HRRZ A,(C) ;get index or address
MPAFUN: JRST X ;go patch
LDRLO: JSP T,MAPAT ;enter patch loop
LDRLBAS:ADDI A,X ;relocation base
HRRM A,(C) ;put into instruction
JRST MPARET ;return to patch loop
LDQUO: JSP T,MAPAT ;enter patch loop
HRRZ A,@LDATBAS ;get element from table
HRRM A,(C) ;put in instruction
JRST MPARET
LDCAL: JSP T,MAPAT ;enter patch loop
HRRZ A,@LDATBAS ;get table element
HRRM A,(C) ;put in instruction
LDPURC: SKIPL REL,X ;If iternal PURIFY switch is on
JSP AR5,TRYSMSH+1 ; try to convert slow link to fast
JRST MPARET ;did it or no PURIFY! return to patch loop
MOVE A,REL ;couldn't do it. get internal P.URCLOBRL
HRLI A,(C) ;cons instruction address
PCALL DCONSA ; into list
MOVEM A,@LDPURC ; and move into P.URCLOBRL
JRST MPARET ;return to loop
LDFLUID:JSP T,LGETVX ;get id from table
PCALL BIND1 ;get its value cell
JRST LDPUTA ;put it into table
LDEVIX: MOVE A,(P) ;top of stack
JSP D,NATMTYP ;check if it needs to be gc-protected
JRST LDEPRO ;not atom! needs protection
JUMPE TT,.LDLIST ;INUM doesn't need potection
CAIE TT,ID ;is an id?
JRST LDEPRO ;no! protect
PCALL .INTERNP ;is it interned
JUMPN A,.LDLIST ;if yes, don't protect
MOVE A,(P) ;get top of stack
LDEPRO: CDRA B,@LDQLIS ;internal F.LIST
PCALL CONS
HRRM A,@LDQLIS ;update internal F.LIST
.LDLIST:PREST A ;take top of stack
JRST LDPUTA ;put it into table
LDSYM: JSP T,LGETVX ;get id from table
MOVE T,A ;save in case of error
FOO MOVEI B,SYM ;get SYM
PCALL GET ; property
JUMPE A,[MOVE A,T ;if none
ERRE2 ^D38,[SIXBIT / IS NOT A SYM!/]] ;error
PCALL NUMVAL ;get address
JRST LDPUTA ;put into table
LDOFFSET:
JSP T,LGETVX ;get address from table
MOVE T,A ;save it
JSP D,LDHLF ;get offset
ADDI A,(T) ;update address
JRST LDPUTA ;put it into table
LDNUMP: JSP T,LGETVX ;get object from table
PCALL FIX1A ;convert to number
JRST LDPU1 ;put on stack
LDPOPN: PREST A ;get top of stack
PCALL NUMVAL ;convert to address
JRST LDPUTA ;put into table
LDPROTECT: ;protect objects by consing them into internal F.LIST
LDQLIS: CDRA B,X ;get internal F.LIST
JRST .+3 ;enter loop
PCALL CONS ;cons object into list
MOVE B,A ;save list
JSP T,LGETVX ;get new object
JUMPN A,.-3 ;if not NIL go back
HRRM B,@LDQLIS ;update internal F.LIST
JRST LDLOP
LDENTRY:HRRZ C,LDRLBAS ;get start of lap block
JSP D,LDHLF ;get relative address
ADDI C,(A) ;get real address
JSP D,LDBYT ;no of args
EXCH A,C
PCALL IMKCODE ;make code pointer
JRST LDPU1 ;push on stack
LDEND: CAME P,LDSTCK ;end of loading. check stack consistency
ERRL2 ^D170,[SIXBIT /FASL STACK OUT OF SYNC!/]
PREST B ;internal P.URCLOBRL
JUMPL B,NOPURC ;negative if PURIFY is off
FOO MOVEI A,VP.URCLOB
PCALL NCONC ;concatenate to P.URCLOBRL
MOVE REL,A ;try smash instructions on list
CDRA AR4,(REL)
JRST SMSHLE ;enter loop
SMSHLP: CARA C,(AR4) ;get instruction address
JSP AR5,TRYSMSH ;try smash instruction
JRST .+2 ;Smashed!
MOVE REL,AR4 ;Not smashed! keep address in list
CDRA AR4,(AR4) ;next element
HRRM AR4,(REL) ;this will remove address of smashed instruction
SMSHLE: JUMPN AR4,SMSHLP ;if more go back
NOPURC: PREST B ;internal F.LIST
FOO HRRZ A,VF.LIST ;F.LIST
PCALL XCONS ;save internal F.LIST on F.LIST
FOO HRRM A,VF.LIST ;update F.LIST
MOVEI T,CPOPJ ;return address
SAVBPO: HRRZ A,LDBPEN
PCALL FIX1A
FOO HRRZM A,VBPEND
HRRZ A,LDBPOR
PCALL FIX1A
FOO HRRZM A,VBPORG ;Allow change of BPORG
JRST (T)
LDBTWD: X
LDATBAS:Z X(A) ;First six bits of this word must be 0 to make LDBYT correct
;%FSLID is an EXPR that reads an id from a FSL file, it is used by
; the PRELOAD device.
%FSLID: PCALL TYID ;Get length of id
MOVN C,A ;make
HRLZI C,(C) ;
HRRI C,(SP) ; iowd
PCALL TYID ;get a word
MOVEM A,1(C) ;put in buffer
AOBJN C,.-2 ;get more if not finished
JRST INTER0 ;intern it
> ;End of IFN NFLD
SUBTTL ALVINE AND LOADER INTERFACES --- PAGE 22
;interface to alvine
IFN AED,<
ED: MOVEI REL,X ;Reset to EDP2 by: STRT, EXCISE, EXCORE.
JRST (REL)
EDP2: PSAVE A
HRRZ A,CORUSE
HRRM A,LST
AOS A
HRRM A,ED
MOVSI A,(SIXBIT /ED/)
PCALL SYSINI
HRLM A,LST
MOVNS A
PCALL MORCOR
PCALL SYSINQ
PREST A
JRST ED
GRINDEF:PSAVE A
PCALL ED
PREST A
JRST 2(REL)
> ;end of IFN AED
EXCISE: MOVE A,JRELO
IFN AED,<MOVEI B,EDP2
HRRM B,ED>
IFN ALOD,SETZM LDFLG ;initial loader symbol table flag
CALLI A,CORE
JRST .+1
JSR IOBRST
IFE HCBPS,PCALL CHKVBP ;Ensure BPORG and BPEND in low BPS.
JRST TRUE
PAGE
VAR
LIT
PAGE
; lisp loader interface
IFN ALOD,<
LOAD: AOS B,CORUSE
MOVEM B,OLDCU#
MOVEM A,LDPAR#
JUMPE A,LOAD2 ;If NIL, @.JBREL+1
FOO MOVE A,VBPORG ; else into BPS @BPORG.
PCALL NUMVAL
MOVE B,A
LOAD2: MOVEM B,RVAL ;final destination of loaded code
MOVSI A,(SIXBIT /LOD/)
PCALL SYSINI
SUBI A,150 ;extra room for locations 0 to 137 and slop
MOVNS A ;length(loader) = 5400 approx.
HRRZM A,LODSIZ#
ADDI A,10 ;Space for start of symbol table etc.
PCALL MORCOR ;expand core for loader
MOVEM A,LOWLSP# ;location of blt'ed low lisp
MOVE B,LODSIZ
ADD B,A
MOVEM B,HVAL ;temporary destination of loaded code
HRLI A,0 ;<0,,LOWLSP> -- HVAL.
BLT A,(B) ;blt up low lisp
HLL A,NAME+3 ;IOWD length(loader),137 .
HRRI A,137-1
PCALL SYSINP
SKIPE LDFLG#
JRST LOAD3 ;If already have them, skip SYMs.
MOVSI A,(SIXBIT /SYM/)
PCALL SYSINI
MOVNS A ;length symbols
PCALL MORCOR ;expand core for symbols
SKIPGE B,.JBSYM
SOS B ;if no symbol table, use original jobsym.
HLRZ A,NAME+3 ;-length(symbols)
ADDB A,B
HLL A,NAME+3 ;symbol table iowd
PCALL SYSINP
HRRM B,.JBSYM
HLLZ A,NAME+3
ADDM A,.JBSYM
SETOM LDFLG ;Lisp symbols loaded, until next EXCISE.
SKIPA
LOAD3: SOS .JBSYM ;want jobsym to point one below 1st symbol
MOVE 3,HVAL ;h
MOVE 5,RVAL ;r
MOVE 2,3
SUB 2,5 ;x=h-r
HRLI 5,12 ;(w) -- LH index needed because
HRLI 2,11 ;(v) uses @X, etc.
SETZB 1,4 ;(N,S)
IFN SYDEV,<MOVE 4,SYSNUM> ;Tell Loader current SYS: used by Lisp.
JSP 0,140 ;call the loader
LOAD4: HRRZM 5,RLAST# ;last location loaded(in final area)
MOVE T,OLDCU
MOVE A,.JBSYM
MOVEM A,.JBSYM(T)
MOVE A,.JBREL
MOVEM A,.JBREL(T) ;update jobrel
HRLZ 0,LOWLSP
SOS LODSIZ
AOBJN 0,.+1 ;<LOWLSP+1,,A> -- LODSIZ.
BLT 0,@LODSIZ ;blt down low lisp
MOVE 0,@LOWLSP ;<LOWLSP,,NIL> -- all accs now restored.
MOVE B,RLAST
MOVE A,RVAL
HRL A,HVAL ;<HVAL,,RVAL> -- RLAST.
SKIPE LDPAR
JRST BINLD ;If into BPS, check room first.
MOVE C,RLAST ;new coruse
LDRET2: BLT A,(B) ;blt down loaded code
HRRZM C,CORUSE ;top of code loaded
MOVEI B,1
ANDCAM B,.JBSYM
SUB C,.JBSYM ;length of free core
ORCMI C,776000
AOJGE C,START ;no contraction
ADD C,.JBREL ;new top of core
MOVE B,C
PCALL MOVDWN
HRLM C,.JBSA
CALLI C,CORE ;contract core
JRST .+1
JRST START
BINLD: PSAVE A ;Check for BPS exceeded...
PSAVE B ;<MOVEI C,INUM0(B)
CDRA A,B ; CAML C,VBPEND
PCALL FIX1A ; JRST BPSERR
PSAVE A ; MOVEM C,VBPORG>
FOO MOVE B,VBPEND
PCALL .LESS
JUMPE A,[SETOM BPSFLG ;Flag "BPS exceeded" for LISP2 check.
JRST START ]
FOO PREST VBPORG ;Update it; loading fits.
PREST B
PREST A
SOS C,OLDCU ;old top of core
JRST LDRET2
> ;end of IFN ALOD
PAGE
IFN AED!ALOD,<
SYSINI: MOVEM A,NAME+1
IFLE <OPSYS+SYDEV-1>,<SETZM NAME+3 >
IFN SYDEV,<PSAVE SYSNUM
IFLE OPSYS,<PREST .+2>
IFG OPSYS,<PREST NAME+3> >
INIT 17
IFE SYDEV,<SIXBIT /SYS/ >
IFN SYDEV,<
IFLE OPSYS,< X >
IFG OPSYS,<SIXBIT /DSK/ > >
0
JRST AIN.4+1
LOOKUP NAME
JRST SYSINER ;error
INPUT [IOWD 1,NAME+3 ;input size of file
0]
HLRO A,NAME+3
PRET
SYSINER:RELEASE
IFE ALOD,<ERRL1 ^D156,[SIXBIT /LISP.ED MISSING!/]>
IFN ALOD,<
MOVSI B,(SIXBIT /SYM/)
CAME A,B ;Are we in LOAD mode?
IFN AED,ERRL1 ^D156,[SIXBIT /LISP.ED OR LOD MISSING!/] ;No, safe to use
IFE AED,ERRL1 ^D156,[SIXBIT /LISP.LOD MISSING!/] ; low core routines.
OUTSTR [ASCIZ /
LISP.SYM not found!! No load.
/] ; Yes -- Loader in low core, though,
MOVE 5,RVAL ; so have to fake the BLT
JRST LOAD4 ; with original RVAL.
> ;end of IFN ALOD
NAME: SIXBIT /LISP/ ;Filename of system,
0 ; .* auxiliaries (e.g. SYM, LOD, ED).
0
0
> ;end of IFN ALOD!AED
PAGE
IFN ALOD,<
SYSINP: MOVEM A,LST> ;LOAD
IFN ALOD!AED!RWB,<
SYSINQ: ;ED, RBLK
IFN OPSYS,< ;KLUDGE to circumvent bug in PA1050...
MOVS A,LST ; to wit: uses SIN which plants a nul,
SUB A,LST ; which clobbers wd after input-blk.
HLRZ A,A
IFN HCBPS,<CAIGE A,400000>
CAMGE A,.JBREL
PSAVE 1(A)
INPUT LST
IFN HCBPS,<CAIGE A,400000>
CAMGE A,.JBREL
PREST 1(A) >
IFE OPSYS,<INPUT LST> ;ELSE just input it.
STATZ 740000
ERRL1 ^D157,AIN.8
RELEASE
PRET
LST: 0
0
> ;end of IFN ALOD!AED!RWB
AIN.8: SIXBIT /INPUT ERROR!/
PAGE
IFN ALOD,<
MOVDWN: HLRZ A,.JBSYM
JUMPE A,MOVS1
ADDI A,1(B)
HRL A,.JBSYM
HRRM A,.JBSYM
BLT A,(B) ;downward blt
PRET
MOVSYM: MOVE B,.JBREL
HRLM B,.JBSA
HLRE A,.JBSYM
JUMPE A,MOVS1
ADDI B,1(A) ;new bottom of symbol table
MOVNI A,1(A)
ADD A,.JBSYM ;last loc of old symbol table
HRRM B,.JBSYM
PSAVE C
MOVE B,.JBREL ;last loc of new symbol table
MOVE C,(A) ;simulated upward blt
MOVEM C,(B)
SUBI B,1
ADDI A,-1 ;lf+1,rt-1
JUMPL A,.-4
PREST C
PRET
MOVS1: HRRZM B,.JBSYM
PRET> ;end of IFN ALOD
;enter with size needed in a
;exit with pointer in a to core
MORCOR: PSAVE B
PCALL EXPND2
MOVE B,CORUSE#
ADDM A,CORUSE
MOVE A,B
PREST B
PRET
EXPND2: HRRZ B,.JBSYM
SUB B,CORUSE
SUBM A,B
JUMPL B,EXPND3
ADD B,.JBREL ;new core size
CALLI B,CORE ;expand core
TCORE3: ERRL1 ^D158,[SIXBIT /CAN'T EXPAND CORE!/]
IFN ALOD,<PSAVE A
PCALL MOVSYM
PREST A>
IFE ALOD,<MOVE B,.JBREL
HRRZM B,.JBSYM
HRLM B,.JBSA>
EXPND3: PRET
SUBTTL SOSLINK INLINE WITH LISP MAIN --- PAGE 23
%FPAGE: SUBI A,INUM0 ;FIND-PAGE N, IN THE FILE.
PSAVE A
%FP.LP: SOSG A,0(P)
JRST POPAJ ;Stop when get there, returning 0=NIL.
PCALL TYI ;(ERR $EOF$) if too few <ff>.
CAIE A,14
JRST .-2
JRST %FP.LP
%NEXTTYI: PCALL TYI ;Doing a PEEKC().
MOVEM A,OLDCH
JRST FIX1A
FILEP: PCALL FILEPX
RELEASE 0,
PRET
FILEPX: PSAVE A ;Test for a file's existence.
MOVSI B,(SIXBIT /DSK/);Clear any left over.
MOVEM B,DEV
SETZM PPN
JUMPE A,.+3
JSP D,ATMTYP
PCALL NCONS
MOVE T,A ;Permit @((F.E)) or full @(DIR: D F.E)) .
PCALL IOSUB
MOVEM A,LOOKIN
IFN SYDEV,<PCALL SYSDEV > ;Change SYS: if necessary.
MOVE A,DEV
MOVEM A,DEV2
INIT 0,17
DEV2: X
0
JRST AIN.7
PREST A
LOOKUP 0,LOOKIN ;Using chan 0 (no INC or INPUT needed).
MOVEI A,NIL ; file not found.
PRET
PAGE
IFN SOSSW,<
%SOSSWAP:
SUBI 2,INUM0 ;(PAGE # .LT. 2^16, OF COURSE).
SUBI 4,INUM0
LSH 4,^D16 ;ERGO, 2 BECOMES 400000
PSAVE 4
PSAVE 2
PSAVE 1 ;FILE SPECIFICATION
MOVE 1,3
PCALL NUMVAL ;(LINE # .LT. 99999).
MOVE 4,[POINT 7,T,34]
MKLIN1: IDIVI 1,^D10
ADDI 2,60
DPB 2,4
ADD 4,[XWD 70000,0]
TLNN 4,400000
JRST MKLIN1
TRO T,1
EXCH T,(P) ;T WILL NOW CONTAIN FILE SPECIFICATION
SETZM DEV
PCALL IOSUB ;RETURNS FILENM IN A
MOVEM 17,ACSAV+17
MOVEI 17,ACSAV
BLT 17,ACSAV+16 ;SAVE ACCS 0-17 for return from subr.
PREST 15
PREST 16
PREST 13 ;00/01/02 == GET,R-O,CREATE.
MOVEM P,ACSAV+P
MOVE 14,A
HLL 13,EXT ;SET BY IOSUB
IFGE OPSYS,<CALLI 11,24 ;GETPPN UUO
SETZ 11,
HRRZS 11 >
IFL OPSYS,<GJINF
MOVE 11,2 >
SETZB 1,12
;HIGH ACCS FOR SOS ARE NOW SET ... TO WIT:
;
;ACC 11 = PPN
; 12 = (UNUSED).
; 13 = EXT,,FLAGS ;BITS 18-19 = 0 (GET FILE), 1 (READ-ONLY), 2 (CREATE IT)
; 14 = FILENM
; 15 = LINE #, IN ASCID FORM (BIT 35 ON);
; 16 = PAGE #.
PAGE
IFE OPSYS, < ;USE LABORIOUS METHOD OF MAKING CORE-IMAGE.
; == FOR 10/50 SYSTEMS...VESTIGIAL.
;SWAP IS NOT DECLARED INTERNAL/SUBR (THO IT COULD BE).
;FIRST SAVES ALL ACCUMULATORS AS FILE 'QQSVAC.TMP'
;SAV -- SWAPS OUT (EFFECTIVELY) 116 THRU MIN(LH(E+2),.JBREL)
; -- MUST GO TO THE DISK (& WILL, REGARDLESS OF DEVICE).
; -- USES 1; DOES NOT SAVE ANY HIGH SEGMENT !!!
; -- THE FORMAT IS A NON-ZERO-COMPRESS (75--END).
; -- THE ACCS ARE RESTORED IF A RUN IS NOT DONE.
;RUN -- USES THE DEC RUN-UUO WHICH DESTROYS THE ACCUMULATORS
; -- THEREFORE, IF YOU WISH TO PASS ARGUMENTS (IN THE ACCS)
; -- TO THE NEW PROGRAM, PICK THEM UP FROM THE TMP FILE.
EXTERNAL .JBCOR,.JBS41,.JBDDT
SLOC==74
.JBSDD==114
SWAP: MOVEI 1,ACBLK
BLT 1,ACBLK+17 ;CAN'T OUTPUT FROM BELOW LOC 115
MOVE 1,[XWD ACSAV,6] ;RESTORE UNCLOBBERED HI-ACCS
BLT 1,17
CALLI 1,30 ;PJOB
IDIVI 1,^D10
LSH 1,6
OR 1,2
LSH 1,^D24
OR 1,[SIXBIT/00SVAC/]
MOVEM 1,ACHEAD
ADDI 1,5460-4143 ;'LP' - 'AC'
INIT 17 ;DUMP MODE
SIXBIT /DSK/
0 ;NO BUFFERS
JRST AOUT.4+1
SETZM ACHEAD+2
SETZM ACHEAD+3
ENTER ACHEAD
ERRL1 ^D159,SWOUT2
OUTPUT [IOWD 20,ACBLK
0]
STATZ 740000
ERRL2 ^D160,SWOUT2
CLOSE
STATZ 740000
ERRL2 ^D161,SWOUT2
MOVEM 1,IOFILE
SETZM IOFILE+2
SETZM IOFILE+3
ENTER IOFILE
ERRL2 ^D162,SWOUT2
HRRZ 2,.JBCOR
MOVEM 2,OLDCOR
MOVE 2,.JBREL
HRRM 2,.JBCOR
SUBI 2,SLOC ;NOT OUTPUTTING FIRST 0-SLOC LOCS
MOVEM 2,1 ;N WORDS OF DATA
MOVN 2,2
SUBI 2,1 ;-(N+1) == DATA + NULL HEADER WORD
HRLM 2,OLIST
MOVE 2,.JBREL
HRRM 2,MVX+^D9 ;HIGHEST LOC BEFORE RELOC = DITTO BLT
ADDI 2,2000
CALLI 2,CORE ;SPACE TO RELOCATE INTO
ERRL2 ^D163,SWOUT2
MOVE 3,[XWD MVX,MV]
BLT 3,MVE
MOVE 3,[XWD 216,116]
JRST MV
MVX: PHASE 4
MV: MOVE 2,SLOC(1)
MOVEM 2,SLOC+100(1) ;MOVE 100 UPWARD
SOJG 1,MV
SETZM SLOC+100 ;NULL HEADER WORD
MOVE 2,.JBDDT
MOVEM 2,.JBSDD+100
MOVE 2,.JB41
MOVEM 2,.JBS41+100
OUTPUT OLIST+100 ;AT RELOCATED IOWD
BLT 3,0-0 ;MOVE BACK DOWN
MVE: JRST MVY
DEPHASE
MVY: MOVE 2,[XWD ACSAV,6]
BLT 2,17 ;RESTORE AGAIN OVER CODE
HRRZ 2,MVX+^D10
CALLI 2,CORE ;REDUCE CORE BY 1K TO PREVIOUS
STRTIP [SIXBIT /_*** WOULDN'T REDUCE CORE_!/]
STATZ 740000 ;NOW CHECK FOR OUTPUT ERRORS
ERRL2 ^D164,SWOUT2
CLOSE 0,
STATZ 740000
ERRL2 ^D165,SWOUT2
RELEAS 0,
MOVE 2,OLDCOR
HRRM 2,.JBCOR
RUNUUO: SETZM NEWCOR
MOVSI 1,1 ;SA INC
HRRI 1,DEVC2
CLRBFI ;DELETE CR,LF IF ANY...DISTURB SOS.
CALLI 1,35 ;RUN UUO
HALT ; POSSIBLY RECOVERABLE, BUT EXIT ANYWAY
ACBLK: BLOCK 20
DEVC2: SIXBIT/SYS/
SIXBIT/SOS/
SIXBIT/SAV/
0
0
NEWCOR:
OLDCOR: 0-0
IOFILE:
ACHEAD: SIXBIT/QQSVAC/
SIXBIT/TMP/
0
0
OLIST: XWD 0-0,SLOC+100-1
0
SWOUT2: SIXBIT /COULDN'T SWAP SUCCESSFULLY_!/
> ;******** CLOSE OF IFE OPSYS, FROM SWAP: ********.
PAGE
IFN OPSYS, < ;EASIER WITH TENEX
%SWAP:
MOVSI 1,1 ;SET B17
MOVE 2,[POINT 7,FILSOS]
GTJFN
JRST SOSER1
HRRZ 3,1 ;AC1(RH) NOW HAS DESIRED JFN.
MOVSI 1,(1B1+1B3) ;Spec. cap. & use AC2.
MOVEI 2,0 ;VIRTUAL ADDRESS OF ACCS.
CFORK ;CREATE INFERIOR FORK.
JRST SOSER2
EXCH 1,3
HRL 1,3 ;SET UP (LH) WITH HANDLE
JSYS 200 ;GET JSYS
HRRZ 1,3
MOVEI 2,2 ;INDEX INTO ENTRY-VEC
SFRKV ;START THAT FORK
;AC1 HAS INFERIOR-F HANDLE!
WFORK ;CURRENT FORK WAITS UNTIL THE
; INFERIOR FORK TERMINATES.
KFORK ;INF-FORK STILL EXISTS, SO!
SWAPEX: MOVSI 17,ACSAV
BLT 17,17 ;Restore accs
PRET ; and return.
FILSOS: ASCIZ /<SUBSYS>SOS.SAV/
SOSER1: OUTSTR FILSOS
OUTSTR [ASCIZ / NOT FOUND
/]
SOSER2: OUTSTR [ASCIZ /COULDN'T SOSSWAP/]
JRST SWAPEX
> ;CLOSE OF IFN OPSYS.
> ;******* Close of IFN SOSSW, from %SOSSWAP: ****
%ACSAV:
ACSAV: BLOCK 20
PAGE
IFN JSYXEQ,< ;The rest of this page is under this switch
COMMENT
The JSYS function executes a JSYS and returns the result. It is
called as JSYS(jsysno,arg1,arg2,arg3,retreg) where jsysno is the
number of the JSYS, retreg is the number of the register in which the
executed JSYS will return its value and argN is loaded into register
N as argument to the JSYS. The value of the global variable JSYSAR4
is taken as arg4 (initial value is 0).
If argN is a number then that number is converted to machine-
representation and loaded into reg N.
If argN is not the list (BUF) then it must be a string or an id.
This string or id is written in a buffer as a ASCIZ string and a
pointer to that string is loaded into reg N.
If argN is (BUF) then a pointer to a stringbuffer is loaded into reg
N. Only one of the argN may be (BUF).
If there is a (BUF) this indicates that the JSYS will write a string
into the string buffer, using retreg as updated string- pointer and
return as value the string converted into a LISP string.
If there is no (BUF) among the arguments, then the content of the
retreg register is converted into a LISP number and returned as value
of JSYS.
%JSYS: PSAVE B ; A1 arg.
PSAVE C ; A2 arg.
PSAVE AR4 ; A3 arg.
FOO PSAVE VJSYSAR4 ; A4 arg.
CAIG A,INUM0+777 ; JSYS number
CAIGE A,INUM0+1
ERRE2 ^D39,[SIXBIT /NOT A JSYS!/]
SUBI A,INUM0
HRRM A,JSY ; Set which JSYS.
MOVE A,AR5
CAIG A,INUM0+4
CAIGE A,INUM0+1
ERRE2 ^D40,[SIXBIT /NOT A RETURN REGISTER!/]
SUBI A,INUM0
HRRM A,RETREG ; Set which register contains the value
MOVEI AR5,1
HRRM AR5,RBUFAR ; No string returned.
MOVEM SP,STRST# ;Start of string buffer. Special stack is used
HRREI B,-3
JSARLP: HRRM B,NJSAR
NJSAR: MOVE A,X(P) ; Get arg.
JSP D,ATMTYP ; What type is it?
CAIE TT,FIXNU ; If not a fixnum
JUMPN TT,JSASTB ; or an Inum must be string or buffer
PCALL NUMVAL ; A number. Convert to machine format
MOVEM A,@NJSAR ; and set arg.
JRST JSARLE
JSASTB: CAIE TT,ID ; An id
CAIN TT,STRNG ; or a string ?
JRST JSASTR ; Yes!
FOO CAIE TT,BUF ; Return string buffer?
ERRE2 ^D41,[SIXBIT /ILLEGAL JSYS ARG!/] ; No! Error.
HRRM B,RBUFAR ; Arg no for return string pointer.
JRST JSARLE
JSASTR: MOVE C,STRST ; String buffer position.
MOVEI B,1(C)
HRROM B,@NJSAR ; Set arg to string pointer.
PCALL PNAMUD ; Unpack into buffer
PUSH C,[0] ; Deposit zero at end of string.
MOVEM C,STRST ; Update string buffer.
JSARLE: HRRE B,NJSAR ; Next arg.
AOJLE B,JSARLP
HRRZ B,RBUFAR ; Return string?
SOJE B,NORST ; No!
MOVE B,STRST ; String buffer position.
PUSH B,[0] ; Zero first word.
RBUFAR: HRROM B,X(P) ; Set arg to string pointer for return string.
NORST: HRRZM B,STRST ; 0 or address of output string.
PREST 4 ; A4 arg.
PREST 3 ; A3 arg.
PREST 2 ; A2 arg.
PREST 1 ; A1 arg.
JSY: JSYS X
ERJMP JSYERR
ERJMP JSYERR
RETREG: MOVE A,X ; Load return value into register 1.
SKIPE B,STRST ; Return string?
JRST MKSTR ; Yes! Convert to Lisp string.
JRST FIX1A ;No! Convert to LISP number and return
;JSYS error return
JSYERR: PCALL ERRSTR
ERRE2 ^D42,[SIXBIT /JSYS ERROR!/]
; ERRSTR returns the last system error message as a Lisp string;
ERRSTR: HRROI A,1(SP) ; Pointer to buffer for string.
HRLOI B,400000 ; .FHSLF
SETZ 3,
ERSTR
ERJMP EER
ERJMP EER
MKSTR1: MOVEI B,1(SP)
MKSTR: SKIPG C,A ; Convert from ASCII string to LISP string.
JRST FALSE ; Return NIL if no string.
LDB AR4,A ; Last character.
JUMPN AR4,NOBCKP ; O.k. if not null.
CAIN B,(A) ; Only one word?
JRST NOBCKP ; Yes! Never step back pointer.
HLRZ AR4,A
CAIN AR4,350700 ; Null in beginning of word?
MOVEI C,-1(A) ; Yes! Step back pointer.
NOBCKP: HRL A,B ; Start of string.
SUBI B,1(SP) ; - expected start of string.
JUMPE B,LMKSTR ; Don't need to move string if start is o.k..
HRRI A,1(SP) ; Expected start of string.
SUBI C,(B) ; Updated end of string.
BLT A,(C) ; Move string.
JRST LMKSTR ; Make into LISP string.
EER:
FOO MOVEI A,QST ;Couldn't get error string return ?
PRET
GETAB$: PCALL NUMVAL
HRRM A,GETALO
HLLZ B,A
MOVE C,SP
GETALO: MOVEI A,X
HRL A,B
GETAB
JRST GERR
PUSH C,A
AOBJN B,GETALO
GERR: MOVSI A,700
HRR A,3
JRST MKSTR1
; !%XEQ generates inferior forks
%XEQ: MOVEM A,FORKH# ; FILENAME OR PREVIOUS FORK HANDLE #.
MOVEM B,STAD# ; T=START, NIL=RESUME, 0-N = EVEC POS.
MOVEM C,KILL# ; T=KFORK, NIL=KEEP FOR A RESUME-FORK.
MOVEM AR4,ACSADR# ; NIL=NONE, N=ADDR OF ACCBLK
MOVEM AR5,ARGSTR# ; NIL=NONE, RSCAN . TTYINP Tops20, TTYINP Tenex
IFL OPSYS,< ;RSCAN not defined in TENEX
JUMPE AR5,NORTYI
CARA A,(AR5)
JUMPE A,NRSCN ; NO RSCAN
PCALL PNAMUK
PUSH C,[0] ; Must end with 0
HRROI A,1(SP)
RSCAN
JRST FAIL6
NRSCN: MOVE A,FORKH > ;END OF IFL OPSYS
NORTYI: PCALL NUMBERP ; IF NUMBERP FILE/FORKH
JUMPN A,OLDFORK ; THEN GOTO OLDFORK;
MOVE A,FORKH
PCALL PNAMUK
PUSH C,[0] ; Must end with 0
MOVSI A,100001 ; OLD FILES ONLY.
HRROI B,1(SP)
GTJFN ; GTJFN OF STRING ON SP STACK.
JRST FAIL1
MOVEM A,SAVJFN#
MOVSI A,200000 ; 1B1
SETZ B, ; SETUP ACS BELOW, IF ANY.
CFORK
JRST FAIL2
MOVEM A,FORKH
HRRZ A,SAVJFN
HRL A,FORKH
JSYS 200 ; GET OF FORK,,JFN.
SKIPN A,STAD
FOO MOVEI A,TRUTH ; START, NOT RESUME.
MOVEM A,STAD
JRST TRYIT
OLDFORK:MOVE A,FORKH
PCALL NUMVAL
CAIL A,400001
CAIL A,400035
ERRE2 ^D43,[SIXBIT /NOT A FORK HANDLE!/]
MOVEM A,FORKH
RFSTS
TLNN A,777777
ERRL2 ^D168,[SIXBIT /DEAD FORK IN XEQ!/]
MOVEM B,FORKPC#
TRYIT: MOVEI A,100 ;PRIMARY INPUT
CFIBF ;Flush buffer to be safe
RFMOD
MOVEM B,OTTMOD#
SKIPN A,ACSADR
JRST NOACS
PCALL NUMVAL
MOVE B,A
MOVE A,FORKH
SFACS
NOACS: MOVE A,FORKH
SKIPN C,STAD
JRST DOSFORK ; IF NULL STAD THEN START FORK
FOO CAIN C,TRUTH
TDZA C,C ; IF STAD=T THEN START AT EVEC+0
SUBI C,INUM0 ; UNBOX NUMBER
GEVEC
ADD B,C
MOVEM B,FORKPC
HLRZ AR4,B ; CHECK LH LENGTH VERSUS STAD
CAIE AR4,(JRST)
JRST ITENEX
CAIL C,2
JRST FAIL5 ; 10/50 CAN ONLY ST/REE 0/1.
JRST DOSFORK
ITENEX: CAIL C,(AR4)
JRST FAIL5
DOSFORK:HRRZ B,FORKPC
SFORK ; SFORK AT PC, RATHER THAN RFORK
IFG OPSYS,<SKIPN A,ARGSTR
JRST NTAR>
IFL OPSYS,<SKIPN C,ARGSTR
JRST DOWFORK
CDRA A,(C)
JUMPE A,NTAR>
PCALL PNAMUK
HRRZ C,SP
HRLI C,700
MOVEI A,100 ;Primary output designator;
XL1: MOVEI AR4,127
XL2: ILDB B,C
JUMPE B,NTAR
STI
SOJG AR4,XL2
DIBE
JRST XL1
NTAR: MOVE A,FORKH
DOWFORK:WFORK
MOVEI A,100
MOVE B,OTTMOD
SFMOD
MOVE A,FORKH
SKIPN B,KILL
JRST FIX1A ; RETURN FORKH# FOR FUTURE RESUME.
KFORK ; KFORK IF NON-NIL FLAG.
JRST FALSE
FAIL1: PSAVE FORKH
PCALL ERRSTR
PCALL NCONS
PRET B
PCALL XCONS
MOVE B,A
MOVEI A,INUM0
JRST .ERROR
FAIL6: CARA A,ARGSTR
PSAVE A
JRST FAIL1+1
FAIL2: MOVE A,SAVJFN
RLJFN
JFCL
PCALL ERRSTR
ERRE2 ^D44,[SIXBIT /ERROR IN XEQ!/]
FAIL5: MOVE A,STAD
ERRE2 ^D45,[SIXBIT /BAD ENTRY VECTOR IN XEQ!/]
> ;End of IFN JSYXEQ
SUBTTL BPS SWAPPING ROUTINES --- PAGE 24
IFN RWB,< ;to end of page
INTERNAL RBLK, WBLK
RBLK: PCALL FILEPX ; (RBLK <FILE>) no 2nd arg anymore.
JUMPE A,RBLK0 ; Not found.
INPUT [IOWD 1,LST
0]
JRST SYSINQ
RBLK0: RELEASE 0,
JRST AIN.7
WBLK: INIT 17 ; (WBLK <file> <start-addr> <end-addr>)
SIXBIT /DSK/
0
JRST AOUT.4+1
HRLZM A,DEV
MOVE A,B ;IN CASE ADDRESSES OVER 64K.
PCALL NUMVAL
EXCH A,C
PCALL NUMVAL
SUBI C,1
SUBM C,A ;A_ -(A-(C-1)) == ARG1:ARG2 INCLUSIVE
HRL C,A
MOVEM C,LST
MOVEI T,DEV
PCALL IOSUB
MOVEM A,ENTR
SETZM ENTR+2 ;CREATION DATE
ENTER ENTR
JRST OUTERR+1
OUTPUT [IOWD 1,LST
0]
OUTPUT LST
CLOSE
STATZ 740000
JRST TYO2X+2 ;"OUTPUT ERROR".
PRET
> ;end of IFN RWB
SUBTTL CORE EXPANDING ROUTINES --- PAGE 25
INTERNAL TCORE
TCORE: SUBI A,INUM0 ;== ^C, CORE N, START EXCEPT FOR N =<0
JUMPL A,TCORE0 ;JUST RETURN CURRENT LISP-ALLOC SIZE
JUMPE A,TCORE0+1 ;JUST RETURN CURRENT CORE SIZE
CAILE A,MAXCORE ;LIMIT .LT. 124K OR SO, ALLOWING FOR I/O BUFFS
JRST TCORE3
LSH A,^D10
SUBI A,1
CAMGE A,JRELO
JRST TCORE1 ;Smaller than current Lisp area alloc.
CAML A,.JBREL
JRST TCORE2 ;LARGER THAN CURRENT CORE, SO EXPAND.
IFE HCBPS,<
SKIPN VXCORE
JRST TCORE4
STRTIP [SIXBIT /_*** CAN'T EXCISE_!/]
JRST TCORE0+1
>
TCORE4: CAMG A,JRELO
PCALL TCORE5
TCORE2: CALLI A,CORE
JRST TCORE3
JRST LISPGO ;GO ALLOCATE CORE
TCORE1: STRTIP [SIXBIT /_*** CAN'T CUT CORE INTO ALLOCATED SPACE_!/]
TCORE0: SKIPA A,JRELO ;-1 GIVES CURRENT LISP-ALLOC AREA
HRRZ A,.JBREL ; 0 GIVES CURRENT TOTAL CORE ASSIGNED
ADDI A,1777
LSH A,-^D10
JRST FIXI
TCORE5: MOVE B,JRELO
CAME B,CORUSE
FOO SKIPN %MSG
PRET
; OUTSTR [ASCIZ /
;*** EXCISED
;/]
PRET
PAGE
; EXCORE( n ) permits arbitrary expansion of BPS above Lisp spaces,
; by: 1) flagging STRT allocator not to alloc extra core,
; 2) creating or extending a high BPS area of nK,
; 3) setting BPORG and BPEND up there appropriately,
; 4) doing an I/O reset, to get the buffers above BPS,
; permitting future LOADs, EDs, etc.
; EXCORE( 0 ) forces the BPORG and BPEND pntrs down to their last
; positions in low BPS, but doesn't clear the high...which
; is retained indefinitely or until an EXCISE.
; EXCORE(NIL) permits ALLOC() or ST to allocate extra core as usual.
; Has also the effect of EXCORE(0).
IFN SZBPS,< ;Only defined when not maximal BPS.
EXCORE:
IFE HCBPS,< ;Only when BPS in low core
MOVEM A,VXCORE# ;If NIL, flag for STRT allocation,
JUMPE A,CHKVBP
HRREI C,-INUM0(A) ;else
JUMPL C,EXCORT
LSH C,^D10 ; Convert nK to n*1024 words.
JUMPE C,CHKVBP ; If arg=0, put BP pntrs back to low BPS.
FOO MOVE A,VBPEND
PCALL NUMVAL
CAML A,FSO ;Are the pntrs in low BPS still?
JRST EXCOR2 ; No, extend from this BPEND.
MOVEM A,OBPEND# ; Yes, save positions for a later CHKVBP.
FOO MOVE A,VBPORG
PCALL NUMVAL
MOVEM A,OBPORG#
SKIPA A,JRELO ;Start BPS. [Could use CORUSE instead]
EXCOR2: SETZ B, ;If 0, pntrs were already in high BPS.
ADD A,C ;Extend by amt of arg.
IORI A,777 ; End of page.
CAIGE A,MAXCORE*^D1024 ;More than 124K requested,
CALLI A,CORE ; or can't get it?
JRST TCORE3 ; Say so.
JUMPE B,EXCOR3 ;Got it -- set pntrs to it.
MOVE A,JRELO ;[or CORUSE]
ADDI A,1
PCALL FIX1A
FOO MOVEM A,VBPORG
EXCOR3: MOVE A,.JBREL
PCALL FIX1A
FOO MOVEM A,VBPEND
JSR IOBRST ;Set JOBSA and clear I/O pntrs.
CALLI RESET ;Set JOBFF.
JSR APRSET
PCALL TTYRET
EXCORT: MOVE A,VXCORE
PRET
PAGE
CHKVBP:
FOO MOVE A,VBPEND ;Ensure BP pntrs to low BPS.
PCALL NUMVAL
CAMGE A,FSO
JRST EXCORT ;Already low, no change needed.
MOVE A,OBPEND
PCALL FIX1A
FOO MOVEM A,VBPEND
MOVE A,OBPORG
PCALL FIX1A
FOO MOVEM A,VBPORG
JRST EXCORT
>
IFN HCBPS,<
JUMPE A,CPOPJ ;Do nothing if argument NIL.
PCALL NUMVAL
JUMPLE A,CPOPJ
LSH A,^D10
MOVE AR5,A
FOO MOVE A,VBPEND
PCALL NUMVAL
ADD AR5,A
IORI AR5,777
HRLZ A,AR5
TLNN AR5,-1
CALLI A,CORE
JRST TCORE3
MOVE A,AR5
PCALL FIX1A
FOO MOVEM A,VBPEND
PRET
>
> ;End of IFN SZBPS
PAGE
FREEZE: SKIPE A ;If going to toplevel, then
PCALL TUNBIND ; unbind to toplevel
MOVEM 17,ACSAV+17 ;This routine halts Lisp in a manner
MOVEI 17,ACSAV ; that can be later re-started.
BLT 17,ACSAV+16
IFL OPSYS,<
MOVE 1,VBPORG
PCALL NUMVAL
MOVEM 1,.JBHRL >
IFN OPSYS,<
MOVEI 1,400000
MOVE 2,[2,,ENTFRZ]
SEVEC > ;Tell it where to start or continue.
MOVEI 1,NEWST ;Unfortunately, need to do this
MOVEI 2,NEWREE ; in order to thwart PA1050,
HRRM 1,.JBSA ; if ST or REE w/o clearing it.
HRRM 2,.JBREN
IFN OPSYS,< HALTF >
IFE OPSYS,<EXIT 1,>
NEWST: TDZA NIL,NIL
NEWREE: SETO NIL,
IFN OPSYS,<
MOVEI 1,400000 ;Tell it the normal Lisp entries.
MOVE 2,[2,,ENTVEC]
SEVEC >
IFL OPSYS,<
MOVE 1,.JBREL
HRLI 1,676777
CALLI 1,CORE
JRST .+1 >
MOVEI 1,LISPGO
MOVEI 2,DEBUGO
HRRM 1,.JBSA
HRRM 2,.JBREN
JSR IOBRST ;Clear I/O bufs.
JUMPN NIL,[MOVE NIL,ACSAV
SETZM RETFLG
JRST START ] ;REE to get past INITFN.
CALLI RESET
JSR APRSET ;Reset 10/50 or Tenex interrupts.
MOVSI 17,ACSAV
BLT 17,17
PCALL TTYRET
SKIPN A,ACSAV+1 ;Test arg of FREEZE...
PRET ; NIL -- Return, no files open.
MOVE A,.JBREL ; Non-NIL -- GOTO top-level INITFN.
CAMN A,JRELO
JRST LSPRET ;Unexpanded core. G.c. not necessary.
JRST LISPGO
IFN OPSYS,<
ENTVEC: JRST LISPGO
JRST DEBUGO
ENTFRZ: JRST NEWST
JRST NEWREE >
SUBTTL AUXILIARY ROUTINES --- PAGE 26
IFN OPSYS,<
LSSAVE: MOVEM 17,ACSAV+17 ;This routine SSAVEs Lisp in a manner
MOVEI 17,ACSAV ; that can be later run, no files open.
BLT 17,ACSAV+16
MOVE 17,ACSAV+17 ;Restore it.
MOVEI 1,400000
MOVE 2,[2,,ENTFRZ]
SEVEC
MOVSI 1,(1B0+1B17)
HRROI 2,LSSFIL
GTJFN
JRST LSSER1
HRLI 1,400000
MOVEI 2,LSSTBL
SETZ 3,
SSAVE
HRRZS 1
RLJFN
JRST LSSER1
MOVEI 1,400000
MOVE 2,[2,,ENTVEC]
SEVEC
JRST TRUE ;Distinguish from a NEWST's NIL!
LSSER1: MOVEI 1,400000
MOVE 2,[2,,ENTVEC]
SEVEC
ERRL2 ^D166,[SIXBIT /COULDN'T SSAVE/]
LSSFIL:
IFL OPSYS,ASCIZ /LSSAVE.EXE/
IFG OPSYS,ASCIZ /LSSAVE.SAV/
LSSTBL: -700,,520B26+0 ;Pages 0-677 below PA1050.
0
>
PAGE
IFN SYDEV,<
SETSYS:
IFG OPSYS,<SUBI A,INUM0 ;CHANGE SYS: <DIR> NUMBER.
CAIGE A,0 ; Permit 0 ... user's dir.
SKIPA A,SYSNUM#
MOVEM A,SYSNUM
JRST FIXI>
IFLE OPSYS,<MOVE T,A
PCALL ATOM
JUMPE A,GVDV
MOVE A,T
PCALL SIXMAK
TRC A,":"-40
TRNE A,77
JRST GVDV
HLLZM A,SYSNUM#
MOVE A,T
PRET
GVDV: SETZB A,B
SKIPA AR4,[POINT 6,SYSNUM]
ADDI A,40(B)
LSH A,7
ILDB B,AR4
JUMPN B,.-3
ADDI A,":"
LSH A,1
SKIPA AR4,[1]
LSH A,7
TLNN A,774000
JRST .-2
MOVEM A,1(SP)
MOVEI C,1(SP)
JRST MSTR1 >
>
SUBTTL REALLOC CODE --- PAGE 27
STRT: MOVE P,C2
SKIPE SP,SPSAV
PCALL TUNBIND
MOVE A,.JBREL ;New top of core -- becomes JRELO below.
HRLM A,.JBSA
SUB A,JRELO# ;length of extra core
JUMPE A,RREL4 ;no expansion
SKIPG A
HALT ;smaller core -- bitch.
IFN AED,<MOVEI B,EDP2
HRRM B,ED>
IFE HCBPS,<SKIPE VXCORE ;If XCORE(Nil), go ahead and allocate,
JRST RREL4 > ; else retain as is...usually expanded BPS.
MOVE A,.JBREL
TRO A,1777
CALLI A,CORE
SKIPA A,.JBREL
MOVE A,.JBREL
HRLM A,.JBSA
SUB A,JRELO
PCALL TCORE5
IFN ALOD,SETZM LDFLG ;initial loader symbol table flag
MOVE F,EFWSO#
SUB F,FWSO# ;old length of fws
HRRZS B,A
ACHLOC: ASH A,-2+X ;1/4 of new core to fws * User-patchable *
ADD A,F ;new length of fws
MOVE C,B
STKLOC: ASH C,-6 ;1/64 of new core to each pdl
MOVE AR4,C
HRL AR4,C
HLRZ AR5,SC2 ;-old length of spec pdl
ADD AR5,.JBREL ;new bottom of spec pdl
HLL AR5,SC2 ;old length of spec pdl
SUB AR5,AR4 ;new pointer for spec pdl
MOVEM AR5,SC2
IFN EPDL,<
HLRZ EP,EC2 ;-old length of exp pdl
ADD AR5,EP ;new bottom of exp pdl
HLL AR5,EC2 ;old length of exp pdl
SUB AR5,AR4 ;new pointer for exp pdl
MOVEM AR5,EC2 >
MOVNS C2 ;old reg pdl pointer
HLRZ AR4,C2 ;old length of reg pdl
ADD C,AR4 ;new length of reg pdl
HRRZ B,AR5 ;new bottom of reg pdl
SUB B,FSO#
MOVEI T,44 ;1/36 space for fws bit tables
IDIVM A,T ;new length of fws bit tables
AOS T
SUB B,T ;B:=SPL-FSO-(FWS/36+1)-FWS-PL, then
SUB B,A ;B:=B-(B/33+1)+FSO
SUB B,C
MOVEI TT,41 ;1/33 space for fs bit table
IDIVM B,TT ;new length of fs bit table
SUBI B,1(TT) ;new length of fs
ADD B,FSO ;new bottom of fs
HRRM B,GCP1
MOVN SP,B ;- new bottom of fws
HRRM SP,GCMFWS
HRLZM A,C1GCS
MOVNS C1GCS ;- new length of fws
HRRM B,C1GCS
ADDI B,-1(A) ;new top of fws
AOS B
MOVE SP,FSO
LSH SP,-5
SUBM B,SP
HRRM SP,GCBTP2 ;magic number for bit table references
HRRM SP,GCBTP1
HRLM B,C3GC ;bottom of bit tables --- for bit table zeroing
HRRM B,GCP2
HRRM B,GCP
MOVNI SP,-1(TT)
HRLM SP,C3GCS
HRRM B,C3GCS ;iowd for FS bit table sweep
AOS B
MOVE SP,FSO
ANDI SP,37
HRRM SP,GCBTL2 ;magic number to position bit table word
SUBI SP,^D32
HRRM SP,GCBTL1
HRRM B,C3GC ;bottom of bit table
ADDI B,-1(TT)
HRRM B,C2GCS ;bottom of fws bit table
AOS B
HRRM B,C2GC
ADDI B,-1(T)
HRRM B,GCP5 ;top of bit tables
AOS B ;bottom of reg pdl
HRRZ A,RHX2 ;oblist pointer
MOVEM A,(B)
HRRM B,GCP3 ;room for acs
AOS B
HRRM B,C2 ;reg pdl bottom
MOVNI A,-10(C)
HRLM A,C2 ;reg pdl size
HRRZ A,.JBREL
HRRZM A,JRELO ;new top of core
MOVE A,GCP1
HRRM A,.+4 ;To...
MOVE A,FWSO
HRRM A,.+1 ;From...
MOVE A,.(F) ;old bottom of fws *
MOVEM A,.(F) ;new bottom of fws *
SOJGE F,.-2 ;f has length (old) of fws
HRRZ AR4,GCP1
SUB AR4,FWSO ;displacement for fws
MOVE AR5,FSO ;bottom of fs
RREL1: CARA A,(AR5) ;Adjust pntrs in new FS to new FWS...
CAMG A,EFWSO
CAMGE A,FWSO
JRST RREL2
ADD A,AR4
RPLCA A,(AR5) ;fix car pointer
RREL2: CDRA A,(AR5)
CAMG A,EFWSO
CAMGE A,FWSO
JRST RREL3
ADD A,AR4
RPLCD A,(AR5) ;fix cdr pointer
RREL3: CAMGE AR5,FWSO
AOJA AR5,RREL1
MOVE A,GCP1 ;bottom of fws
HRRZM A,FWSO
MOVE A,C3GC ;bottom of bit table + 1
HRRZM A,EFWSO
RREL4:
FOO SETZB FF,DDTIFG ;Flag for AGC.
JSR IOBRST
JRST START
;--------------------------------------------------------------------
RLOCA: MOVE B,AR4 ;= FS+BPS LENGTHS.
HRLI AR4,BFWS
HRRI AR4,FS(B)
MOVEI AR5,EFWS-BFWS(AR4)
BLT AR4,(AR5)
MOVEI AR4,FS-BFWS(B)
MOVEI AR5,BFWS-1
REL1: CARA A,(AR5)
CAILE A,EFWS
JRST REL2
CAIGE A,BFWS
JSP R,REL4
ADD A,AR4
REL2: RPLCA A,(F)
CDRA A,(AR5)
CAILE A,EFWS
JRST REL3
CAIGE A,BFWS
JSP R,REL4
ADD A,AR4
REL3: RPLCD A,(F)
SOS F
CAILE AR5,FS
SOJA AR5,REL1
JRST RREL4 ;Now do the IOBRST and START.
REL4: CAIL A,FS
ADD A,FF
JRST 1(R)
PAGE
REHASH: ;ONCE ONLY, per HASHFG.
FOO MOVEI A,BFWS
PSAVE A
HRRM A,RHX2
HRRM A,RHX5
RH4: MOVSI B,X ;*
FOO MOVEI A,BFWS+1(B)
FOO MOVEM A,BFWS(B)
AOBJN B,.-2
FOO SETZM BFWS(B)
MOVSI AR5,-BCKETS
RH1:
FOO HLRZ C,OBTBL(AR5)
RH3: JUMPE C,RH2
CARA A,(C)
PSAVE C
PSAVE AR5
PCALL INTERN
PREST AR5
PREST C
CDRA C,(C)
JRST RH3
RH2: AOBJN AR5,RH1
SETZM HASHFG
PREST A
HRRM A,@GCP3
FOO MOVEM A,OBLIST
JRST START
SUBTTL LISP ATOMS AND OBLIST --- PAGE 28
RVAL: 0
HVAL: 0
VAR
LIT
PAGE
FS:
DEFINE MAKBUC (A,%B)
<DEFINE OBT'A <%B=.>
IFN <BCKETS-1-A>,<XWD %B,.+1>
IFE <BCKETS-1-A>,<XWD %B,NIL>
IF1 <%B=0>>
DEFINE ADDOB (A,C,%B)
<OBT'A
DEFINE OBT'A<%B=.>
IF1 <%B=0>
XWD C,%B>
DEFINE PUTOB (A,B)
<ZZ==<ASCII /A/>_<-1>
ZZ==-ZZ/BCKETS*BCKETS+ZZ
ADDOB \ZZ,B>
DEFINE PSTRCT (A)
<ZZ==[ASCII /A/]
LENGTH ZY,A
REPEAT <ZY-1>/5,<XWD ZZ,.+1
ZZ==ZZ+1>
XWD ZZ,0>
DEFINE MKAT (A,B,C,D)
<XLIST
IRP A< PUTOB A,.+1
D XWD ID,.+1
XX==<B-EXPR>*<B-FEXPR>
IFN XX,<XWD .+1,.+2
XWD B,C'A>
IFE XX,<XWD .+1,.+4
XWD FUNCELL,.+1
XWD B,.+1
XWD CODE,C'A>
XWD .+1,NIL
XWD PNAME,.+1
PSTRCT A>
LIST>
PAGE
DEFINE MKAT1 (A,B,C,D)
<XLIST
IRP C <PUTOB C,.+1
XWD ID,.+1
XX==<B-EXPR>*<B-FEXPR>
IFN XX,<XWD .+1,.+2
XWD B,D'A>
IFE XX,<XWD .+1,.+4
XWD FUNCELL,.+1
XWD B,.+1
XWD CODE,D'A>
XWD .+1,NIL
XWD PNAME,.+1
PSTRCT C>
LIST>
DEFINE LENGTH (A,B)
<A==0
IRPC B,<A==A+1>>
DEFINE ML1 (A)<XLIST
IRP A,<XLIST
INTERNAL A
V'A= INUM0+A
MKAT A,SYM,V>
LIST> ;These SYMs are for direct access from LAP code (e.g. LISP.TNX)
DEFINE ML (A)<
XLIST
IRP A,<PUTOB A,.+1
A: XWD ID,.+1
XWD .+1,NIL
XWD PNAME,.+1
PSTRCT A>
LIST>
OBTBL:
OBLIST: ZZ==0 ;Base of array or linear-list of hash buckets.
XLIST ;REPEAT BCKETS,<MAKBUC \ZZ
REPEAT BCKETS,<MAKBUC \ZZ
ZZ==ZZ+1>
LIST ; ZZ==ZZ+1>
PAGE
ML <LAMBDA,EXPR,FEXPR,SYM,FUNCELL,VALUE,PNAME,TRACE>
ML <LABEL,MACRO,INPUT,OUTPUT,INBIN,OUTBIN>
ML <SUBR,FSUBR>
MKAT <RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,EXPR
MKAT <CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,EXPR
MKAT <CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,EXPR
MKAT <CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,CONS>,EXPR
MKAT <PROG2,ATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,ATSOC,PATOM>,EXPR
MKAT <POSN,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,EXPR
MKAT <COMPRESS,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,EXPR
IFN AED,<MKAT <ED,GRINDEF>,EXPR>
MKAT <TIME,FIX,SET,LENGTH,ADD1,SUB1,LAST,WARNING>,EXPR
MKAT <GCTIME,REVERSE,SPEAK,MAPLIST,MEMQ>,EXPR
MKAT <PUT,PRIN2,ERR,MAPCAR,EXAMINE,DEPOSIT,LSH,MAPCAN,MAPCON>,EXPR
MKAT <NCONS,XCONS,REMPROP,MINUSP,MAP,MAPC>,EXPR
MKAT <WRS,RDS,OPEN,CLOSE,EXCISE,REMAINDER,ABS,BKTRA>,EXPR
MKAT <PGLINE>,EXPR
MKAT <%FSLID,%FPAGE,%NEXTTYI,SETPCHAR,DLVECT>,EXPR
IFN SOSSW,MKAT %SOSSWAP,EXPR
IFN RWB,<MKAT <RBLK,WBLK>,EXPR>
MKAT <FILEP,FREEZE>,EXPR
IFN SZBPS,MKAT <EXCORE>,EXPR
MKAT <CORE>,EXPR,T
MKAT <BINI,BINO,TYID,TYOD>,EXPR
MKAT1 VINC,VALUE,INC*
VINC:NIL
MKAT1 VOUTC,VALUE,OUTC*
VOUTC:NIL
IFN OPSYS,MKAT LSSAVE,EXPR
IFN JSYXEQ,<MKAT <%XEQ,GETAB$,ERRSTR>,EXPR
MKAT1 VJSYSAR4,VALUE,JSYSAR4
VJSYSAR4: INUM0
ML BUF
MKAT JSYS,EXPR,%>
IFN SYDEV,<MKAT SETSYS,EXPR>
MKAT EXPLODEC,EXPR,%
MKAT TYO,EXPR,I
MKAT TYI,EXPR,I
MKAT EVAL,EXPR,,CEVAL:
MKAT <LIST,COND,PROG,SETQ>,FEXPR
MKAT1 LIST,EXPR,EVLIS
MKAT <OR,AND,GO,PROGN>,FEXPR
IFN ASARY,<MKAT <ARRAY,STORE>,FEXPR
ML1 NSTR
IFN ALOD,<MKAT EXARRAY,FEXPR> >
MKAT1 QUOTE,FEXPR,FUNCTION
IFN FNRG,<
ML FUNARG
MKAT1 FUNCT,FEXPR,*FUNCTION
MKAT <%EVAL,%APPLY>,EXPR >
MKAT <APPEND,NCONC,APPLY,REMOB,ERRORSET,FIXP,FLOATP,INUMP,BIGP>,EXPR
MKAT <PUTD,GETD,REMD,PRINC,FLAG,FLAGP,REMFLAG,MKCODE,FLOAT,DIGIT>,EXPR
MKAT <BOOLE,LITER,IDP,PAIRP,CONSTANTP,STRINGP,VECTORP,CODEP>,EXPR
MKAT <MKVECT,UPBV,GETV,PUTV>,EXPR
MKAT INTERNP,EXPR,.
MKAT ASCII,EXPR,A
MKAT QUOTE,FEXPR,,CQUOTE:
MKAT1 FIX1A,EXPR,*BOX
ML1 <EXARG,ATMTYP,NATMTYP,INTER0,FWCONS,ACHLOC,CHRTAB>
MKAT INUM0,SYM,S
INTERN INUM0
SINUM0: XWD FIXNU,VINUM0
IFN OPSYS,ML1 <READP1,PNAMUK,%ACSAV,LMKSTR>
IFN OPSYS*SOSSW,ML1 %SWAP
PUTOB T,.+1
TRUTH: XWD ID,.+1
XWD .+1,.+2
XWD VALUE,VTRUTH
XWD .+1,NIL
XWD PNAME,.+1
PSTRCT T
VTRUTH: TRUTH
PUTOB NIL,0
CNIL2: XWD .+1,.+2
XWD VALUE,VNIL
XWD .+1,NIL
XWD PNAME,.+1
PSTRCT NIL
VNIL: NIL
IFE STL,<
MKAT <SASSOC,SETARG,GETL,ARG,READLIST,FLATSIZE>,EXPR
MKAT <CSYM,DEFPROP>,FEXPR
MKAT1 EXPN1,EXPR,*EXPAND1
MKAT1 EXPAND,EXPR,*EXPAND
MKAT1 LCALL,SYM,*LCALL,INUM0+%
MKAT1 UDT,SYM,*UDT,INUM0+% >
MKAT1 AMAKE,SYM,*AMAKE,INUM0+%
MKAT1 %NOPOINT,VALUE,*NOPOINT
%NOPOINT: NIL
MKAT1 BACTRF,VALUE,*BAKGAG
BACTRF:NIL
MKAT1 ERRSW,VALUE,*ERRMSG
ERRSW:TRUTH
MKAT1 V$EOF$,VALUE,$EOF$
V$EOF$: $EOF$
$EOF$: XWD ID,.+1
XWD .+1,NIL
XWD PNAME,.+1
PSTRCT $EOF$
MKAT1 GCGAGV,VALUE,*GCGAG
GCGAGV:NIL
MKAT1 VFECHO,VALUE,*ECHO
VFECHO:NIL
MKAT1 VRAISE,VALUE,*RAISE
VRAISE:NIL
MKAT1 DDTIFG,VALUE,*DDTIN
DDTIFG:TRUTH
MKAT1 NOUUOF,VALUE,*NOUUO
NOUUOF:NIL
MKAT1 %MSG,VALUE,*MSG
%MSG: TRUTH
MKAT1 GC,EXPR,RECLAIM
MKAT1 INITF,VALUE,INITFN*
INITF:NIL
MKAT1 %SYSTM,VALUE,SYSTEM*
%SYSTM: OPSYS+INUM0
MKAT <SCANINIT,SCANSET,SCAN,UNREADCH>,EXPR
MKAT <LETTER,DELIMITER,IGNORE,RDSLSH>,EXPR
MKAT1 SCNV,VALUE,SCNVAL
SCNV: NIL
MKAT SKIPTO,EXPR
MKAT <LPOSN,PAGELENGTH,EJECT,NUMVAL>,EXPR
MKAT ERROR,EXPR,.
MKAT1 VERMSG,VALUE,EMSG*
VERMSG: NIL
IFN OFLD!NFLD,<
MKAT1 VPURIFY,VALUE,*PURIFY
VPURIFY: NIL
MKAT1 VPREDEF,VALUE,*PREDEF
VPREDEF: NIL
MKAT1 VF.LIST,VALUE,F.LIST
VF.LIST: NIL
MKAT1 VP.URCLOBRL,VALUE,P.URCLOBRL
VP.URCLOBRL: NIL >
IFN OFLD,<
MKAT <FASLOD,LDFERR>,EXPR
MKAT1 VFARRY,VALUE,FARRY
VFARRY: NIL >
IFN NFLD,MKAT FASLOAD,EXPR
;UNBOUND is a non-interned identifier
UNBOUND:XWD ID,.+1
XWD .+1,NIL
XWD PNAME,.+1
PSTRCT UNBOUND
IFN MOD,<
MKAT <SETMOD,CMOD,CPLUS,CDIF,CTIMES,CRECIP>,EXPR
MKAT1 VBIGP,VALUE,MOD*
VBIGP: NIL >
MKAT1 LAMBIND,EXPR,*LAMBIND*
MKAT1 PROGBIND,EXPR,*PROGBIND*
MKAT1 SPECSTR,EXPR,*SPECRSTR*
MKAT1 PLUS,EXPR,PLUS2,.
MKAT1 DIF,EXPR,DIFFERENCE,.
MKAT1 QUO,EXPR,QUOTIENT,.
MKAT1 TIMES,EXPR,TIMES2,.
MKAT1 RSTSW,VALUE,*RSET
RSTSW:NIL
MKAT1 GREAT,EXPR,GREATERP,.
MKAT1 LESS,EXPR,LESSP,.
IFN ALOD,<MKAT LOAD,EXPR
MKAT1 PUTSYM,EXPR,*PUTSYM
MKAT1 GETSYM,EXPR,*GETSYM>
MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
VOBLIST: OBLIST
VBASE: 8+INUM0
VIBASE: 8+INUM0
VBPORG: XWD 0,.+1
XWD FIXNU,VBPORX
VBPEND: XWD 0,.+1
XWD FIXNU,VBPENX
PUTOB ?,.+1
QST: XWD ID,.+1
XWD .+1,NIL
XWD PNAME,.+1
PSTRCT ?
BFWS: ;All the FWS LITerals from above atoms, etc.
XLIST ; includes VBPORX,VBPENX datums.
LIT
VINUM0: INUM0
VBPORX: 400000
VBPENX: 700000-1000-2 ;676776 --> 1 for SYSINP and 1000 for slop.
LIST
EFWS: 0
SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 29
ALLOC:! CALLI RESET ;Later IOBRST & another RESET.
MOVEI P,ALLPDL-1
IFN OPSYS, < ;LISP.EXE SIZE LT DESIRED STARTING SIZE.
MOVEI A,INITCORE
PCALL ALCORH >
IFL OPSYS,<GETPPN A,
HLRM A,SYSNU>
IFN SYDEV, <
IFG OPSYS, <
MOVEI 1,1 ;MATCH EXACTLY
HRROI 2,[ASCIZ /REDUCE/]
STDIR
JFCL
GJINF ;IN DESPERATION, USE HIS LOGIN DIR #.
HRRZM 1,SYSNUM >
IFLE OPSYS,<
MOVEI A,(SIXBIT /SYS/)
HRLZM A,SYSNUM >
> ;End of IFN SYDEV
OUTSTR [ASCIZ /
Allocate? /]
INCHRW C
CAIE C,"n"
CAIGE C,"O"
JRST ALLC00
IFN OPSYS,<
OUTSTR [ASCIZ /
Core (K): /]
PCALL ALLNUM
JUMPLE A,ALLTNX
CAIG A,MAXCORE ;Asking for too much core ?
JRST .+3 ;No
OUTSTR [ASCIZ /
Will give you maximum allowed/]
MOVEI A,MAXCORE
LSH A,^D10
SUBI A,1
PCALL ALCORE
ALLTNX:! MOVEI A,^D8
HRRM A,ALLRDX ;Remaining inputs are octal.
>
IFN SYDEV, <
IFG OPSYS, <
OUTSTR [ASCIZ /
SYS: dir# /]
PCALL ALLNUM
SKIPN A
GJINF ;If user said "0", use his dir.
SKIPL A
HRRM A,SYSNUM >
IFLE OPSYS,<
OUTSTR [ASCIZ /
SYS: /]
SETZ A,
SYLO:! INCHRW C
CAILE C,"z"
JRST SYLE
CAIL C,"a"
TRZ C,40 ;Convert lower case to upper
CAIL C,"A"
CAILE C,"Z"
JRST SYLE
LSH A,6
ADDI A,-40(C)
JRST SYLO
INCHRW C
SYLE:! CAIN C,RUBOUT
JRST [OUTSTR [ASCIZ /XXX /]
JRST SYLO-1]
CAILE C," "
JRST SYLE-1
CAIN C,15
INCHRW C ;<lf> assumed.
JUMPE A,.+2
HRLZM A,SYSNUM >
> ;End of IFN SYDEV
OUTSTR [ASCIZ /
FWDS= /]
PCALL ALLNUM
JUMPL A,.+2
HRRM A,ALLC02
IFN SZBPS,<
OUTSTR [ASCIZ /
BPS.= /]
PCALL ALLNUM
JUMPL A,.+5 ;USE DEFAULT ?
CAIGE A,MINFBPS
MOVEI A,MINFBPS
ADDI A,BOTBPS
HRRZM A,SBPS >
OUTSTR [ASCIZ /
SPDL= /]
PCALL ALLNUM
JUMPL A,.+4
HRRM A,ALLC20
MOVNS A
HRRM A,ALLC21
IFN EPDL,<
OUTSTR [ASCIZ /
EPDL= /]
PCALL ALLNUM
JUMPL A,.+4
HRRM A,ALLC40
MOVNS A
HRRM A,ALLC41 >
OUTSTR [ASCIZ /
RPDL= /]
PCALL ALLNUM
JUMPL A,.+2
HRRM A,ALLC30
OUTSTR [ASCIZ /
HASH= /]
PCALL ALLNUM
CAIG A,BCKETS
JRST ALLC00
HRRM A,INT1
MOVNS A
HRRM A,RH4
SETOM HASHFG ;ONCE ONLY.
ALLC00:!
MOVE A,.JBREL
HRRZM A,JRELO
HRLM A,.JBSA
MOVEI A,DEBUGO
HRRM A,.JBREN
MOVEI A,LISPGO
HRRM A,.JBSA
IFN OPSYS,<
MOVEI 1,400000
MOVE 2,[2,,ENTVEC]
SEVEC
>
OUTSTR [ASCIZ /
/]
IFE HCBPS,<
MOVEI A,FS
PCALL FIX1A
MOVEM A,VBPORG
MOVEI A,FS
ADD A,SBPS
HRRZM A,FSO ;SET ONCE AND FOR EVER!!!
SOS A
PCALL FIX1A
MOVEM A,VBPEND
>
IFN HCBPS,<
MOVEI A,FS
MOVEM A,FSO
IFN OPSYS,MOVEI A,400000 ;First loc of high-segment.
IFE OPSYS,<
HRRZ B,.JBREL ;highest address in low core
TRNN B,400000 ;is low core higher than 128k
MOVEI B,377777 ;no, assume high core start at 400000
MOVE A,[XWD -2,.GTUPM] ;get high core orig. from monitor
GETTAB A, ;.GTUPM indexed by current high core number
HRLI A,1(B) ;table or call not present, use assumed value
LSH A,-^D18 ;convert to address of high segment
ANDI A,777000 ;clear any low bits
ADDI A,.JBHDA> ;Add space for vestigial job data area
MOVEM A,VBPORX
IFE SZBPS,MOVEI A,700000-1000-2 ;PA1050 - 1 page.
IFN SZBPS,ADD A,SBPS
MOVEM A,VBPENX
MOVSS A
PCALL ALCORH
SETZ A,
CALLI A,SETUWP
HALT
>
MOVE A,JRELO
ALLC20:! SUBI A,1000+X
ALLC21:! HRLI A,-1000+X
MOVEM A,SC2
IFN EPDL,<
ALLC40:! SUBI A,100+X
ALLC41:! HRLI A,-100+X
MOVEM A,EC2 >
SUB A,FSO
HRRZS B,A
ASH A,-4
ALLC02:! ADDI A,400+X
MOVE C,B
ASH C,-6
ALLC30:! ADDI C,1000+X
;Stg order= prgm bps fs fws bt btf pdl epdl sp
MOVEI T,44
IDIVM A,T
AOS T ;size of btf
SUB B,T
SUB B,A
SUB B,C ;remaining storage
MOVEI TT,^D32+1
IDIVM B,TT ;bt size -1
SUBI B,1(TT) ;free storage size
IFE HCBPS,<ADD B,SBPS>
HRRZ AR4,B
ADDI B,FS
HRRZM B,FWSO
HRRM B,GCP1 ;b hac top of fs
MOVN SP,B
HRRM SP,GCMFWS
HRLZM A,C1GCS ;length of fws
MOVNS C1GCS
HRRM B,C1GCS
ADDI B,-1(A) ;bottom of bt-1
AOS B
MOVE SP,FSO
LSH SP,-5
SUBM B,SP
HRRM SP,GCBTP2
HRRM SP,GCBTP1
HRLM B,C3GC
HRRM B,GCP2
HRRM B,GCP
HRRZM B,EFWSO
MOVNI SP,-1(TT)
HRLM SP,C3GCS
HRRM B,C3GCS
AOS B
MOVE SP,FSO
ANDI SP,37
HRRM SP,GCBTL2
SUBI SP,^D32
HRRM SP,GCBTL1
HRRM B,C3GC
ADDI B,-1(TT)
HRRM B,C2GCS
AOS B
HRRM B,C2GC
ADDI B,-1(T)
HRRM B,GCP5
AOS B
MOVEI A,OBTBL
IFE HCBPS,<ADD A,SBPS>
MOVEM A,(B)
HRRM B,GCP3
AOS B
HRRM B,C2
MOVNI A,-10(C)
HRLM A,C2
IFE HCBPS,<MOVE FF,SBPS>
IFN HCBPS,<SETZ FF, >
MOVEI F,BFWS-1(FF)
JUMPE FF,RLOCA
MOVEI C,FOOLST
REL5:! MOVE B,(C) ;Relocate all FS refs w/i system code,
CDRA A,(B) ; by length of alloc'd BPS, iff HCBPS=0.
ADD A,FF
RPLCD A,(B)
HLR B,B
CDRA A,(B)
ADD A,FF
RPLCD A,(B)
CAIGE C,EFOLST-1
AOJA C,REL5
MOVEI A,TRUTH
ADD A,FF
HRLM A,IDCHTAB+"T"-100
JRST RLOCA ;Uses values in AR4,F,FF.
PAGE
ALLNUM:! MOVSI A,400000 ;high bit on for no-digits-seen.
INCHRW C
CAIN C,15
INCHRW C ;<lf> assumed.
CAIN C,RUBOUT
JRST [OUTSTR [ASCIZ /XXX /]
JRST ALLNUM]
CAIL C,"0"
CAILE C,"9"
PRET
TLZ A,400000 ;turn off hi bit on digit
ALLRDX:!
IFN OPSYS,IMULI A,^D10+X ;first a decimal number
IFE OPSYS,IMULI A,^D8 ;only octal
ADDI A,-"0"(C)
JRST ALLNUM+1
ALCORE:! CAMG A,.JBREL
PRET ;Already bigger.
ALCORH:! CALLI A,CORE
HALT
PRET
ALLPDL:! BLOCK 10
IFN SZBPS,<SBPS:! INITBPS+BOTBPS>
PAGE
I=0
DEFINE GARP (A,B)
<XWD FOO'A,FOO'B>
FOO 0
FOOLST:!
XLIST
REPEAT <FOOCNT/2>,<
GARP (\I,\<I+1>)
I=I+2>
LIST
EFOLST:!
DEFINE MKENT (A)<
INTERNAL A>
;These are for BIGNUMs (in ARITH)...
MKENT <NUMV2,FLOOV,FS>
MKENT <LAST,FIX1A,NUMVAL,REVERSE,LENGTH,XCONS,CONS,CTY,MINUSP>
MKENT <NUM1,NUM3,FWCONS,FALSE,TRUE,NCONS,IDCONS>
;These are for GFPAK
MKENT <.PLUS,REMAINDER,.COPY,.Q1,MAKBIG,POPAJ>
;These are for SCAN...
MKENT <CHRTAB,RATOM,OLDCH,NOINFG,TYI>
;Most of the rest are for ALVINE...
MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,EQUAL,SUBST>
MKENT <LNCT,PAGL,CHCT,LINL,POSN,TYOD,TYID>
MKENT <GET,INTERN,REMOB,COMPRESS,GENSYM,FIX,LENGTH,PATOM>
MKENT <MAPLIST,GC,PUT,FIXP,FLOATP,ATMTYP,NATMTYP,IPUTD,IMKCODE>
MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRORSET,%APPLY>
MKENT <SPECSTR,LAMBIND,PROGBIND,INTER0,ATOM,READCH,SET,PRIN2>
MKENT <FP7A1,TERPRI,LSPRET,BKTRC>
MKENT <TYO,ITYO,EVAL,APPLY,%EVAL,INPUT,OUTPUT>
IFE STL,MKENT <READLIST,GETL,SASSOC,SAS1,FLATSIZE>
IFN AED,MKENT PSAV1
;SOME MORE FOR FRICK'S "SHEEP" SYSTEM...
IFN ASARY,MKENT <ARRAY,ARRAYS,ARREND>
MKENT <GCMKL,PRINT1,EJECT,OPEN,RDS,WRS,CLOSE,PRINC,GETD,PUTD,DCONSA>
MKENT <PCHAR,FIXOV,ZERODIV,ILLNUM,STKLOC,ATSOC,EXARG,MKVECT>
SUPPRESS FOOCNT,I
END ALLOC