Trailing-Edge
-
PDP-10 Archives
-
decuslib10-04
-
43,50322/ucilsp.mac
There are no other files named ucilsp.mac in the archive.
TITLE LISP INTERPRETER 3A(1)-2
SUBTTL NOTES TO SYSTEM PROGRAMMERS
;%% VERSION DEFINITIONS:
LSPWHO==2 ;%% UCI
LSPVER==3 ;%% MAJOR VERSION
LSPMIN==1 ;%% MINOR VERSION
LSPEDT==1 ;%% EDIT LEVEL
; ASSEMBLY SWITCHES OF INTEREST
;
; SWITCH EXPLANATION, COMMENTS ETC.
; ALTMOD FOR ALTMODE CHARACTER. OLD WAS 175
; NOW IT'S 33 FOR 506
; QALLOW ENABLES ACCESS TO QMANGR, ONLY IF YOUR
; SYSTEM SUPPORTS QUEUE. SEVERAL SWITCHES
; ASSOCIATED WITH THE CODE
; OLDNIL OLD STANFORD NIL. CODE TO MAKE CAR AND CDR
; OF NIL INCOMPLETE AS OF 8/30/73
; NONUSE OLD STANFORD VERSIONS OF MEMQ, AND ETC.
; THAT RETURNED T OR NIL.
; REALLC PROGRAM-CONTROLLED DYNAMIC REALLOCATION
; ROUTINE AND RELATED FUNCTIONS
; SYSPRG PROJECT NUMBER IF NOT ON SYS:.
; SYSPN PROGRAMMER NUMBER IF NOT ON SYS:
; SYSDEV DEVICE LOCATION OF SYSTEM.
; NOTE THAT THE ABOVE THREE ARE WHERE LISP
; EXPECTS TO FIND THE LOADER,THE
; SYMBOL TABLE AND THE NORMAL HI-SEGMENT.
; THE FUNCTION (SETSYS ...) ONLY CHANGES THE
; EXPECTED LOCATION OF THE HI-SEG
;%% SYSNAM NAME OF EXPECTED HIGH SEGMENT
;%% AND LISP LOADER AND SYMBOL TABLE
;%% INUMIN LOWEST ADDRESS AVAILABLE FOR USE AS
;%% AN INUM
;%% BCKETS NUMBER OF HASH BUCKETS
;%% SHRST LOWEST ADDRESS IN HIGH SEGMENT
;%% SYSUNV SEARCH SYSTEM UNIVERSAL LIBRARIES
; **USE FOLLOWING AT OWN RISK**
; HASH NUMBER OF HASH BUCKETS WHEN STARTING
; ALVINE STANFORD EDITOR (WHO WOULD WANT IT?)
; 1 FOR ALVINE, 0 FOR NO ALVINE
; STPGAP ANOTHER STANFORD EDITOR
; COMMENTS:
;
; THERE ARE BASICALLY TWO SETS OF COMMENTS IN THE CODE:
; THOSE IN LOWER CASE ARE ORIGINAL STANFORD COMMENTS;
; THOSE OF A SEMI-COLON FOLLOWED BY TWO $'S,
; TWO #'S, OR TWO %'S ARE UCI ADDITIONS,
; CHANGES, OR ADDITIONAL COMMENTS
; ($'S ARE USUALLY DARYLE LEWIS,
; #'S ARE GENERALLY JEFF JACOBS,
; AND %'S ARE GENERALLY BILL EARL).
PAGE
SUBTTL AC DEFINITIONS AND EXTERNALS
IFNDEF SYSUNV,<SYSUNV==1> ;[1]
IFNDEF SHRST <SHRST==400000> ;[1]
TWOSEG SHRST ;[1]
IFN SYSUNV,< ;[1]
SEARCH MACTEN
SEARCH UUOSYM ;[1]
.JBVER==137 ;%% SYSTEM VERSION LOCATION ;[1]
LOC .JBVER ;%% SET STANDARD SYSTEM VERSION ;[1]
VRSN. (LSP) ;%% GENERATE VERSION> ;[1]
RELOC SHRST ;[1]
OLDNIL==1 ;## NOT COMPLETE
IFNDEF NONUSE <NONUSE==0>
IFN SHRST-400000 <QALLOW==0>
IFNDEF QALLOW <QALLOW==1>
IFNDEF REALLC <REALLC==0> ;%% NORMALLY OFF TO SAVE SPACE
;%% CHANGE FOR EXTENDED SYSTEM
;SYSPRG==667 ;PPN OF LISP SYSTEM - SET TO 0 FOR SYS:
;SYSPN==2 ;SAME HERE
IFNDEF SYSPRG,<SYSPRG==0
SYSPN==0>
IFNDEF SYSPN,<SYSPN==1>
;ALVINE==1 ;1 FOR ALVINE, 0 FOR NO ALVINE
IFNDEF ALVINE,<ALVINE==0>
;HASH==1 ;1 FOR SETTING # OF HASH BUCKETS AT SYS. INIT. TIME
IFNDEF HASH,<HASH==0>
;STPGAP==1 ;1 FOR STOPGAP, 0 TO DELETE IT
IFNDEF STPGAP,<STPGAP==0>
IF1,<PURGE CDR,DF>
MLON
IFNDEF INUMIN, <INUMIN=SHRST-1> ;%% [1]
INUM0=777777-<<777777-INUMIN>/2> ;%% [1]
IFNDEF BCKETS,<BCKETS==177>
IFE SYSPRG,<
IFNDEF SYSDEV<DEFINE SYSDEV <SIXBIT /SYS/>>
>
IFN SYSPRG,<
IFNDEF SYSDEV<DEFINE SYSDEV <SIXBIT /DSK/>>
>
IFNDEF SYSNAM,<DEFINE SYSNAM <SIXBIT /LISP/>>
;accumulator definitions
;`sacred' means sacred to the interpreter
;`marked' means marked from 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
AR1=4 ;marked, protected ;fourth arg of subrs
AR2A=5 ;marked, protected ;fifth arg of subrs
T=6 ;marked, protected ;minus number of args in LSUBR call
TT=7 ;marked, protected
REL=10 ;marked, protected
S=11 ;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
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
X==0 ;X indicates impure (modified) code locations
TEN==^D10
;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 PUSHJ
OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
;error UUOs
OPDEF ERR1 [1B8] ;ordinary lisp error ;gives backtrace
OPDEF ERR2 [2B8] ;space overflow error ;no backtrace
OPDEF ERR3 [3B8] ;ill. mem. ref.
OPDEF STRTIP [4B8] ;print error message and continue
;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 SKPINL [TTCALL 14,] ;## BETTER FOR TALK THAN SKPINC
OPDEF TALK [PUSHJ P,TTYCLR] ;## TURN OF CONTROL O
;I/O bits and constants
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
;channel data
CHNAM==0 ;name of channel
CHDEV==1 ;name of device
CHPPN==2 ;ppn for input channel
CHOCH==3 ;oldch for input channels
IFN STPGAP,<
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
>
IFE STPGAP,<
CHDAT==4
POINTR==5
COUNT==6
>
CHLL==2 ;linelength for output channel
CHHP==3 ;hposit for output channels
;special ASCII characters
IFNDEF ALTMOD,<ALTMOD==33>
SPACE==40 ;space
IGCRLF==31 ;ignored cr-lf
RUBOUT==177
LF==12
CR==15
TAB==11
BELL==7
DBLQT==42 ;double quote "
;byte pointer field definitions
ACFLD==14 ;ac field
XFLD==21 ;index field
OPFLD==10 ;opcode field
ADRFLD==43 ;adress field
;external and internal symbols
EXTERNAL JOB41 ;instruction to be executed on UUO
EXTERNAL JOBAPR ;address of APR interupt routines
EXTERNAL JOBCNI ;interupt condition flags
EXTERNAL JOBFF ;first location beyond program
EXTERNAL JOBREL ;address of last legal instruction in core image
EXTERNAL JOBREN ;reentry address
EXTERNAL JOBSA ;starting address
EXTERNAL JOBSYM ;address of symbol table
EXTERNAL JOBTPC ;program counter at time of interupt
EXTERNAL JOBUUO ;uuo is put here with effective address computed
EXTERNAL JOBOPC ;$$FOR NEW REENTER FEATURES
EXTERNAL JOBHRL ;HIGH SEGMENT BOUNDARY
;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
;RE-ENTER CONTROL CHARACTERS
CNTLH==10
CNTLE==5
CNTLB==2
CNTLZ==32
CNTLG==7
CNTLR==22 ;CH TO RESTORE SYSTEM OBLIST 3/28/73
;system uuos
APRINI==16
RESET==0
STIME==27
DEVCHR==4
EXIT==12
CORE==11
SETUWP==36
GETSEG==40
;REMOTE MACRO
DEFINE REMOTE (TX)
< HERE1 <TX>>
DEFINE HERE1 (NEW,OLD,%G)
< DEFINE %G
< NEW>
DEFINE REMOTE (TX)
< HERE1 <TX>,<OLD
%G
>>>
DEFINE HERE
< DEFINE HERE1 (XX,YY)
< YY>
REMOTE>
SALL
PAGE
SUBTTL TOP LEVEL AND INITIALIZATION
REMOTE<
LISPGO: SKIPE GCFLG ;$$CHECK FO GARBAGE COLLECTION
PUSHJ P,GCING ;$$QUEUE THE REQUEST
CAME 0,STNIL ;$$UNBIND STACK IF REGS LOOK OK
JRST GETHGH ;GO GET HIGH SEGMENT
MOVE B,SC2
PUSHJ P,UBD ;$$UNBIND STACK
JRST STRT ;go to re-allocator
GETHGH: CALLI RESET
MOVSI A,1
CALLI A,CORE ;ELIMINATE ANY OLD HIGH SEGS.
HALT
MOVEI A,HGHDAT
CALLI A,GETSEG ;GET THE PROPER HIGH SEG
HALT
MOVEI A,DEBUGO ;SET THE REE ADDRESS
HRRM A,JOBREN
JRST STRT ;GO TO ALLOCATE STORAGE
HGHDAT: SYSDEV
SYSNAM
0
0
XWD SYSPRG,SYSPN
0>
DDT: SETOM ERINT ;$$SET CONTROL H WITHOUT GOING THRU REE
JRST @JOBOPC ;$$AND CONTINUE
DEBUGO: SKIPE GCFLG# ;CHECK GARBASE COLLECT.
PUSHJ P,GCING ;QUEUE INTERRUPT
INCHRW 0 ;READ THE CONTROL CHARACTER
CAIN 0,CNTLR
; RESTORES SYSTEM OBLIST
JRST [HRRI 0,OBTBL(S)
HRRM 0,VOBLIST(S)
JRST DEBUGO+2]
; AND TRIES FOR ANOTHER CONTROL CHARACTER
CAIN 0,CNTLH
JRST [MOVE 0,STNIL
JRST DDT]
CAIN 0,CNTLE
JRST [MOVE 0,STNIL
MOVEI 1,NIL
JRST ERR]
CAIN 0,CNTLB
JRST [MOVE 0,STNIL
SETOM ERINT
PUSHJ P,SPDLPT
PUSHJ P,SPREDO
JRST LSPRET]
CAIN 0,CNTLZ
JRST [MOVE 0,STNIL
JRST LSPRET]
CAIN 0,CNTLG
JRST [MOVE 0,STNIL
JRST RERX]
JRST DEBUGO+2 ;NOT A CONTROL CHARACTER
;MUST BE SOMETHING IN THE BUFFER SO TRY AGAIN
START: CALLI RESET ;random initializations for lisp interupts
MOVE [JSR UUOH]
MOVEM JOB41
MOVEI APRINT
MOVEM JOBAPR
MOVEI APRFLG
CALLI APRINI
SETZM GCFLG
HRRZI 17,1
IFN ALVINE,<SETZB 0,PSAV1>
IFE ALVINE,<SETZ 0,>
BLT 17,17 ;clear acs
MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
LSPRT1: SETZM BIOCHN(S) ;$$CLEAR VARS FOR BREAK PACKAGE
SETZM BPMPT(S) ;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
MOVEI A,INUM0
MOVEM A,BINDNT(S)
SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
SETOM ERRSW ;print error messages
CLEARM ERRTN# ;return to top level on errors
SETOM PRVCNT# ;initialize counter for errio
MOVE P,C2# ;initial reg pdl ptr
MOVE SP,SC2# ;initial spec pdl ptr
MOVE A,LSPRMP# ;$$INITIALIZE TO TOP LEVEL PROMPT
;$$CAN BE CHANGED BY INITPROMPT
PUSHJ P,PROMPT ;$$
SETZM SMAC ;$$CLEAR SPLICE LIST (JUST IN CASE)
MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
IFN OLDNIL <HRROI 0,CNIL2(S)> ;INITIALIZE NIL
IFE OLDNIL <SETZ 0, >
MOVEM 0,STNIL# ;$$SAVE FOR REG CHECK AT START TIME
MOVEI A,CNIL2(S) ;## GET PROP LIST OF NIL
MOVEM A,NILPRP# ;## AND SAVE IT FOR GET ETC.
IFN HASH,<
SKIPE HASHFG#
JRST REHASH ;rehash if necessary>
SKIPN F
PUSHJ P,AGC ;garbage collect only if necessary
SKIPN BSFLG# ;initial bootstrap for macros
JRST BOOTS
SKIPE A,INITF
CALLF (A) ;evaluate initialization function
PUSHJ P,TTYRET ;return all i/o to tty
PUSHJ P,TERPRI
SKIPE GOBF# ;garbaged oblist flag
STRTIP [SIXBIT /GARBAGED OBLIST_!/]
SETZM GOBF
SKIPE BPSFLG#
JRST BINER2 ;binary program space exceeded by loader
LISP1: MOVE S,ATMOV# ;$$MAKE SURE REL STAYS
;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
PUSHJ P,READ ;this is the top level of lisp
PUSHJ P,EVAL
PUSHJ P,PRINT
PUSHJ P,TERPRI
JRST LISP1
INITFL: EXCH A,INITF1# ;## NEW INIT FILE LIST
POPJ P, ;## RETURN THE OLD ONE
INITFN: EXCH A,INITF#
POPJ P,
;return from lisp error
LSPRET: PUSHJ P,TERPRI
MOVE B,SC2 ;RETURN FROM BELL
PUSHJ P,UBD ;unbind specpdl
JRST LSPRT1
.RSET: EXCH A,RSTSW#
POPJ P,
COMMENT %
;## OLD BOOTSTRAP CODE FOR INIT FILE, REPLACED BELOW
;BOOTSTRAPPER FOR USER'S INIT FILE
BOOTS: SETOM BSFLG
MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
MOVEM A,BOOPT#
MOVEI A,BSTYI
PUSHJ P,READP1
PUSHJ P,EVAL
JUMPE A,BOOTOT
MOVEI A,BSTYI
PUSHJ P,READP1
PUSH P,A
MOVE A,(P)
PUSHJ P,ERRSET
CAIE A,$EOF$(S)
JRST .-3
BOOTOT: PUSHJ P,EXCISE
JRST ERR
BSTYI: ILDB A,BOOPT
POPJ P,
%
;## NEW IMPROVED BOOTSTRAPPER FOR USER'S INITFILE(S)
;## ALLOWS MORE THAN ONE FILE. FIRST FILE IS READ IN
;## OR IF NOT FOUND BEHAVES AS BEFORE (I.E. NO ERROR MESSAGE)
;## REMAINING FILES WILL CAUSE AN ERROR MESSAGE IF NOT FOUND.
;## THUS IF THE USER IS USING THIS TO REALLY SET UP HIS OWN
;## SYSTEM, HE WILL KNOW ABOUT A FAILURE, BUT THE FIRST
;## FILES EXISTENCE IS STILL OPTIONAL
BOOTS: SETOM BSFLG# ;## INDICATE BOOTSTRAP DONE
SKIPN T,INITF1# ;## GET INIT FILE LIST IF IT EXISTS
JRST BOOTOT ;## NOPE, EXCISE AND RETURN
MOVEI A,TRUTH(S) ;## USE CHANNEL T
PUSHJ P,INPUT2 ;## SET UP
PUSHJ P,ININIT ;## LOOK UP
JUMPN A,BOOTOK ;## IT'S THERE, GO TO IT
JUMPE T,BOOTOT ;## NOT THERE AND NO OTHERS REQUESTED
PUSHJ P,SETINA ;## SET UP FOR THE REST
PUSHJ P,ININIT ;## LOOK UP (SECOND FILE IN LIST)
JUMPE A,AIN.7 ;## NOT THERE, ERROR MESSAGE
BOOTOK: MOVEI A,TRUTH(S) ;##(INC T NIL)
SETZ B,
PUSHJ P,INC ;## SELECT
MOVEI A,READAT(S) ;## SET UP [(EVAL (READ))]
PUSHJ P,NCONS ;## (READ)
PUSHJ P,NCONS ;## ((READ))
MOVEI B,EVALAT(S)
PUSHJ P,XCONS ;##(EVAL(READ))
PUSHJ P,NCONS ;## [(EVAL(READ))]
PUSH P,A
MOVE A,(P)
PUSHJ P,ERRSET ;## AN EVAL-READ LOOP. PROTECTED AGAINST
CAIE A,$EOF$(S) ;## ALL ERRS EXCEPT $EOF$ AND ERRORX
JRST .-3 ;## LOOP
BOOTOT: PUSHJ P,EXCISE
JRST ERR
PAGE
SUBTTL APR INTERRUPT ROUTINES
;arithmetic processor interupts
;mem. protect. violation, nonex. mem. or pdl overflow
APRINT: MOVE R,JOBCNI ;get interupt bits
TRNE R,MPV+NXM ;what kind
ERR3 @JOBTPC ;an ill mem ref-will become JRST ILLMEM
JUMPN NIL,MES21 ;a pdl overflow
STRTIP [SIXBIT /_PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
JRST START
MES21: SETZM JOBUUO
SKIPL P
STRTIP [SIXBIT /_REG !/]
SKIPL SP
STRTIP [SIXBIT /_SPEC !/]
SKIPE JOBUUO
SPDLOV: ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
TRNE R,PDOV
SKIPE JOBUUO
HALT ;lisp should not be here
BINER2: SETZM BPSFLG
ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
ILLMEM: LDB R,[POINT 4,@JOBTPC,XFLD] ;get index field of bad word
CAIE R,F ;does it contain f
ERR3 @JOBTPC ;no! error
PUSHJ P,AGC ;yes! garbage collect
JRST @JOBTPC ;and continue
PAGE
SUBTTL UUO HANDLER AND SUBR CALL ROUTINES
UUOMIN==1
UUOMAX==4
REMOTE<UUOH: X ;jsr location
JRST UUOH2>
UUOH2: MOVEM T,TSV#
MOVEM TT,TTSV#
LDB T,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIGE T,34 ;is it a function call
JRST ERROR ;or a LISP error
HLRE R,@JOBUUO
AOJN R,UUOS
LDB T,[POINT 4,JOBUUO,ACFLD]
CAILE T,15
MOVEI R,-15(T)
HRRZ T,@JOBUUO
UUOH1: HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,SUBR(S)
JRST @UUST(R)
CAIN TT,FSUBR(S)
JRST @UUFST(R)
CAIN TT,LSUBR(S)
JRST @UULT(R)
CAIN TT,EXPR(S)
JRST @UUET(R)
CAIN TT,FEXPR(S)
JRST @UUFET(R)
HRRZ T,(T)
JUMPN T,UUOH1
PUSH P,A
PUSH P,B
HRRZ A,JOBUUO
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPN A,[ HRRZ TT,(A)
POP P,B
POP P,A
JRST UUOEX1]
HRRZ A,JOBUUO
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED UUO!/]
SKIPA T,TT
UUOSBR: HLRZ T,(T)
MOVE TT,JOBUUO
HRLI T,(PUSHJ P,)
TLNE TT,1000 ;1000 means no push
TLCA T,34600 ;<PUSHJ P,>xor<JRST>
PUSH P,UUOH
SOS UUOH
HRRZ D,UUOH
CAIG D,SHRST
JRST .+3
SKIPE WRTSTS
JRST .+3
REMOTE<UUOCL: TLNN TT,2000> ;2000 means no clobber
XCT UUOCL
MOVEM T,@UUOH
MOVE TT,TTSV
EXCH T,TSV
JRST @TSV
UUOS: HRRZ TT,JOBUUO
CAILE TT,@GCPP1
CAIL TT,@GCP1
JRST UUOSBR-1
JRST .+2
UUOEXP: HLRZ TT,(T)
UUOEX1: LDB T,[POINT 5,JOBUUO,ACFLD]
TRZN T,20
PUSH P,UUOH
PUSH P,TT
JUMPE T,IAPPLY
CAIN T,17
MOVEI T,1
MOVNS T
HRLZ TT,T
PUSH P,A(TT)
AOBJN TT,.-1
JRST IAPPLY
PAGE
ARGPDL: LDB T,[POINT 4,JOBUUO,ACFLD]
MOVNS T
HRLZ R,T
ARGP1: JUMPE R,(TT)
PUSH P,A(R)
AOBJN R,.-1
JRST (TT)
QTIFY: PUSHJ P,NCONS
MOVEI B,CQUOTE(S)
JRST XCONS
QTLFY: MOVEI A,0
QTLFY1: JUMPE T,(TT)
EXCH A,(P)
PUSHJ P,QTIFY
POP P,B
PUSHJ P,CONS
AOJA T,QTLFY1
PDLARG: JRST .+NACS+2(T)
POP P,A+5
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POP P,A
JRST (TT)
NOUUO: MOVSI B,(TLNN TT,)
SKIPE A
MOVSI B,(TLNA)
HLLM B,UUOCL
EXCH A,NOUUOF#
POPJ P,
PAGE
;r=0 => compiler calling a -
;r=1 => compiler calling a lsubr
;r=2 => compiler calling f type
UUST: UUOSBR
UUOS1 ;calling l its a subr
UUOS2 ;calling f
UUFST: UUOS9 ;calling - its a f
UUOS10 ;calling l
UUOSBR
UULT: UUOS7 ;calling - its a l
UUOSBR
UUOS8
UUET: UUOEXP
UUOS5 ;calling l its an expr
UUOS6 ;calling f its an expr
UUFET: UUOS3 ;calling - its a fexpr
UUOS4 ;calling l
UUOEXP
UUOS1: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
JRST (R)
UUOS3: PUSH P,(T)
JSP TT,ARGPDL
UUOS4A: JSP TT,QTLFY
MOVEI TT,1
DPB TT,[POINT 4,JOBUUO,ACFLD]
UUOS6A: POP P,TT
HLRZS TT
JRST UUOEX1
UUOS4: PUSH P,(T)
MOVE T,TSV
JRST UUOS4A
PAGE
UUOS5: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
MOVNS T
DPB T,[POINT 4,JOBUUO,ACFLD]
MOVE TT,R
JRST UUOEX1
UUOS6: PUSH P,(T)
PUSH P,UUOH
PUSH P,JOBUUO
JSP TT,ILIST
JSP TT,PDLARG
POP P,JOBUUO
POP P,UUOH
JRST UUOS6A
UUOS8: SKIPA TT,CILIST
UUOS7: MOVEI TT,ARGPDL
HRRM TT,UUOS7A
MOVE TT,JOBUUO
TLNN TT,1000
PUSH P,UUOH
HLRZ TT,(T)
JRST @UUOS7A ;OR ILIST
REMOTE<UUOS7A: ARGPDL>
UUOS9: PUSH P,T
JSP TT,ARGPDL
UUS10A: JSP TT,QTLFY
MOVSI T,2000
IORM T,JOBUUO
POP P,T
JRST UUOSBR
UUOS10: PUSH P,T
MOVE T,TSV
JRST UUS10A
PAGE
SUBTTL ERROR HANDLER AND BACKTRACE
;subroutine to print sixbit error message
ERRSUB: MOVSI A,(POINT 6,0)
HRR A,JOBUUO
MOVEM A,ERRPTR#
ERRORB: ILDB A,ERRPTR
CAIN A,01 ;conversion from sixbit
POPJ P,
CAIN A,77
JRST [ PUSHJ P,TERPRI
JRST ERRORB]
ADDI A,40
PUSHJ P,TYO
JRST ERRORB
;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
POPJ P,
PUSH P,PRVSEL# ;previously selected output
POP P,TYOD
POPJ P,
;subroutine to force error messages out on tty
ERRIO: MOVE B,ERRSW
CAIE B,INUM0 ;inum0 specifies to print message on selected device
AOSLE PRVCNT ;only if prvcnt already <0 does deselection occur
POPJ P,
TALK ;undo control o
MOVE B,[JRST TTYO]
EXCH B,TYOD
MOVEM B,PRVSEL
POPJ P,
;ERRTN: 0 ;0 => top level *
;- => pdl to reset to - stored by errorset
;+ => string tyo pout rtn flag
REMOTE<ERRSW: -1> ;0 means no prnt on error *
PAGE
;subroutine to search oblist for closest function to address in r
ERSUB3:
MOVEI A,QST(S)
IFN OLDNIL< HRROI NIL,CNIL2(S)>
IFE OLDNIL< SETZ NIL, >
HRLZ B,INT1
MOVNS B
SETZB AR2A,GOBF
PUSH P,JOBAPR
MOVEI C,[ SETOM GOBF
JRST ERRO2G]
HRRM C,JOBAPR
HRRZ C,VOBLIST(S) ;## GET CURRENT OBLIST
HRRM C,RHX5
HRRM C,RHX2 ;## AND UPDATE LOCATIONS WHICH REF OBLIST
HLRZ C,@RHX5
ERRO2B: JUMPE C,[ AOBJN B,.-1
POP P,JOBAPR ;oblist done, restore
JRST PRINC] ;print closest match
HLRZ TT,(C)
ERRO2C: HRRZ TT,(TT)
JUMPE TT,ERRO2G
HLRZ AR1,(TT)
CAIN AR1,LSUBR(S)
JRST ERRO2H
CAIE AR1,SUBR(S)
CAIN AR1,FSUBR(S)
JRST ERRO2H
HRRZ TT,(TT)
JRST ERRO2C
ERRO2H: HRRZ TT,(TT)
HLRZ TT,(TT)
CAMLE TT,AR2A ;le to prefer car to quote
CAMLE TT,R
JRST ERRO2G
MOVE AR2A,TT
HLRZ A,(C)
ERRO2G: HRRZ C,(C)
JRST ERRO2B
PAGE
;dispatcher for error message uuos
ERROR: MOVEI A,APRFLG
CALLI A,APRINI ;enable interupts
LDB A,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIL A,UUOMIN ;what
CAILE A,UUOMAX ;is it?
JRST ILLUUO ;an illegal opcode
JRST @ERRTAB-UUOMIN(A) ;or LISP error
ERRTAB: ERROR1 ;1 ;ordinary LISP error
ERRORG ;2 ;space overflow error
ERROR2 ;3 ;ill. mem. ref.
STRTYP ;4 ;print error message and continue
ERRORG: MOVE P,ERRTN ;IF IN ERRSET, RESTORE P TO THAT LEVEL
SKIPN P
MOVE P,C2 ;else to top level
SETOM UUO2# ;$$ AND DON'T ENTER ERRORX
ERROR1: SKIPN ERRSW
JRST ERREND ;dont print message, call (err nil)
PUSHJ P,ERRIO ;print message on tty
PUSHJ P,TERPRI
PUSHJ P,ERRSUB ;print the message
JRST ERRBK ;go the backtrace
STRTYP: PUSHJ P,ERRIO
PUSHJ P,ERRSUB ;print message and continue
PUSHJ P,OUTRET
JRST @UUOH
;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
.ERROR: JUMPE A,ERREND
SKIPN ERRSW
JRST ERREND
PUSHJ P,ERRIO
PUSHJ P,TERPRI
PUSHJ P,PRINC
JRST ERREND
PAGE
ERROR2: HRRZ A,JOBUUO
MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
JRST ERSUB2
ILLUUO: HRRZ A,UUOH
MOVEI B,[SIXBIT / ILL UUO FROM !/]
ERSUB2: SKIPN ERRSW
JRST ERREND ;dont print message
PUSH P,A
PUSH P,B
PUSHJ P,ERRIO
PUSHJ P,TERPRI
PUSHJ P,PRINL2 ;print number
POP P,A
STRTIP (A) ;print message
POP P,R
PUSHJ P,ERSUB3 ;print nearest oblist match
ERRBK:
IFN ALVINE,<
SKIPE BACTRF
PUSHJ P,BKTRC ;print backtrace
>
PUSHJ P,OUTRET ;return to previous device
ERREND: SETZ A, ;## %CLRBFI USED TO BE HERE(FOR ERR NIL)
SKIPN UUO2 ;$$NO ERRORX IF OVERFLOW ERROR
JRST .+3
SETZM UUO2 ;$$RESET TO ZERO
JRST RERX ;$$BOUNCE BACK TO ERRORX
SKIPN RSTSW ;$$NEW *RSET FEATURE
JRST ERR ;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
SKIPN ERRSW ;$$NO ERRORX IF NO MESSAGE
JRST ERR ;$$
PUSHJ P,%CLRBFI ;## CLEAR TTY BUFFER. ELIMINATE FLUSHING
;## OF TYPE AHEAD
MOVEI A,ERRORX(S) ;$$ELSE SET TO CALL ERROR HANDLER
MOVEI B,NIL ;$$CREATE FORM (ERRORX)
CEV: PUSHJ P,CONS ;$$
JRST EVAL ;$$AND EVALUATE IT
ERR: SETZM INHERR ;CLEAR RERX FLAG JUST IN CASE
CAIN A,ERRORX(S) ;$$BOUNCE TO ERRORX IF A=ERRORX
JRST RERX
ERR2: SKIPN ERRTN
JRST LSPRET ;not in an errset, or bad error -- go to top level
MOVE P,ERRTN
ERR1: POP P,B
PUSHJ P,UBD ;unbind to previous errset
POP P,ERRSW
POP P,ERRTN
SKIPN INHERR#
JRST ERRP4 ;and proceed
RERX: SETZM INHERR ;$$ POP TO A BREAK ERRSET
MOVE B,ERRSW
CAIE B,ERRORX(S)
SETOM INHERR
JRST ERR2
ERRSET: PUSH P,PA3
PUSH P,PA4
PUSH P,ERRTN
PUSH P,ERRSW
PUSH P,SP
MOVEM P,ERRTN
HRRZ C,(A)
HLRZ C,(C)
MOVEM C,ERRSW
HLRZ A,(A)
PUSHJ P,EVAL
PUSHJ P,NCONS
SETZM INHERR ;CLEAR RERX FLAG
JRST ERR1
SYSCLR: SETZM BSFLG ;FUNCTION TO MAKE SYSTEM LOOK NEW
SETZM CONSVA ;## RESET CONS COUNT
SETZM GCTIM ;## RESET GC TIME
JRST EXCISE ;## EXCISE
PAGE
;error messages
RMERR: MOVE A,T ;$$ BAD READ MACRO, GET THE NAME
PUSHJ P,EPRINT ;$$
ERR1 [SIXBIT /UNDEFINED READ MACRO!/]
BNDERR: PUSHJ P,EPRINT ;$$ATTEMPT TO REBIND NIL OR T
ERR1 [SIXBIT /CANNOT BE RE-BOUND!/]
RPAERR: PUSHJ P,EPRINT ;$$PRINT OUT OFFENDING ITEM
ERR1 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
RPDERR: PUSHJ P,EPRINT ;$$
ERR1 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
DOTERR: SETZM OLDCH
ERR1 [ SIXBIT /DOT CONTEXT ERROR!/]
UNDFUN: HLRZ A,(AR1)
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
UNBVAR: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
NOPNAM: ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
NOLIST: ERR1 [SIXBIT /NO LIST-MAKNAM!/]
TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
UNDTAC: HRRZ A,(C)
UNDTAG: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
SETERR: PUSHJ P,EPRINT ;$$BAD SET OR SETQ
ERR1 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
EG1: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
EG2: PUSHJ P,EPRINT
ERR1 [SIXBIT /GO WITH NO PROG!/]
EG3: ERR1 [SIXBIT /RETURN WITH NO PROG!/]
PAGE
IFN ALVINE,<
;backtrace subroutine
BKTRC: MOVEI D,-1(P)
MOVN A,BACTRF
ADDI A,INUM0
JUMPL A,[ ADD A,P ;backtrace specific number
JRST .+3]
SKIPN A,ERRTN ;backtrace to previous errset
MOVE A,C2 ;or top level
HRRZM A,BAKLEV#
STRTIP [SIXBIT /_BACKTRACE_!/]
BKTR2: CAMG D,BAKLEV
JRST FALSE ;done
HRRZ A,(D) ;get pdl element
CAIGE A,FS(S)
JUMPN A,.+2 ;this is (hopefully) a true program address
SOJA D,BKTR2 ;not a program address, continue
CAIN A,ILIST3
JRST BKTR1A ;argument evaluation
BKTR1B: CAIN A,CPOPJ
JRST [ HLRZ A,(D) ;calling a function
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /ENTER !/]
SOJA D,BKTR2]
HLRZ B,-1(A)
CAILE B,(JCALLF 17,@(17))
CAIN B,(PUSHJ P,) ;tests for various types of calls
CAIGE B,(FCALL)
SOJA D,BKTR2 ;not a proper function call
PUSH P,-1(A) ;save object of function call
MOVEI R,-1(A) ;location of function call
PUSHJ P,ERSUB3 ;print closest oblist match
MOVEI A,"-"
PUSHJ P,TYO
POP P,R
TLNE R,17
HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
HRRZS R
HLRO B,(R)
AOSN B
JRST [ HRRZ A,R ;was calling an atomic function
PUSHJ P,PRINC ;print its name
JRST .+2]
PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
MOVEI A," "
PUSHJ P,TYO
BKTR1: SOJA D,BKTR2 ;continue
BKTR1A: HRRZ B,-1(D)
CAIE B,EXP2
CAIN B,ESB1
JRST .+2
JRST BKTR1B ;hum, not really evaluating arguments
HLRE B,-1(D)
ADD B,D
HLRZ A,-3(B)
JUMPE A,BKTR1
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /EVALARGS !/]
JRST BKTR1
>
BAKGAG: EXCH A,BACTRF#
POPJ P,
PAGE
SUBTTL TYI AND TYO
;input
ITYI: PUSHJ P,TYI ;## RETURN ASCII VALUE OF INPUT CH
FIXI: ADDI A,INUM0
POPJ P,
TYI: MOVEI AR1,1 ;## TO TEST FOR LINED TYPESEQUENCE #, ETC
PUSHJ P,TYIA
JUMPE A,.-1
CAME A,IGSTRT ;start of comment or ignored cr-lf
POPJ P,
PUSHJ P,COMMENT
JRST TYI+1
TYIA: SKIPE A,OLDCH ;## IF CH IN OLDCH
JRST TYI1 ;## TAKE CARE OF IT
TYID: XCT TYI2 ;## INPUT A CHARACTER
REMOTE<TYI2: JRST TTYI> ;sosg x for other device input
;other device input
JRST TYI2X
TYI3B: ILDB A,@TYI3# ;pointer
XCT TYI3A ;## SEE IF LINED TYPE WORD
REMOTE<TYI3A: TDNN AR1,@X> ;pointer
POPJ P, ;## NO, OK
IFN STPGAP,<
MOVE A,@TYI3A
CAMN A,[<ASCII / />+1] ;page mark for stopgap
AOSA PGNUM ;increment page number
MOVEM A,LINUM
>
MOVNI A,5
ADDM A,@TYI2 ;adjust character count for line number
AOS @TYI3 ;increment byte pointer over line number and tab
JRST TYID
REMOTE< TYI2X: INPUT X,
TYI2Y: STATZ X,740000
ERR1 AIN.8 ;input error
TYI2Z: STATO X,20000
JRST TYI3B ;continue with file
TYIEOF: JRST TYI2Q ;END OF FILE>
TYI2Q: PUSH P,T
PUSH P,C
PUSH P,R
PUSH P,AR1
MOVE A,INCH
HRRZ C,CHTAB(A) ;get location of data for this channel
HLRZ T,CHTAB(A) ;inlst -- remaining files to input
JUMPE T,TYI2E ;none left -- stop
PUSHJ P,SETIN ;start next input
PUSHJ P,ININIT ;## INIT THE FILE
JUMPE A,AIN.7 ;## CAN'T FIND FILE, ERROR
POP P,AR1
POP P,R
POP P,C
POP P,T
JRST TYI
TYI2E: PUSHJ P,INCNT ;(inc nil t)
TALK
MOVEI A,$EOF$(S) ;we are done
JRST ERR
IFN STPGAP,<
PGLINE: MOVE C,[POINT 7,LINUM]
PUSHJ P,NUM10 ;convert ascii line number to a integer
ADDI A,INUM0
MOVE B,PGNUM
ADDI B,INUM0+1
JRST XCONS>
REMOTE< OLDCH: 0
IFN STPGAP,<
PGNUM: 0
LINUM: 0
0>> ;zero to terminate num10
;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
; IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
; - TAKES NO ARGUMENTS
ECHO: SETO A,
TTYUUO 6,A ;GET STATUS BITS
TLC A,4 ;COMPLEMENT THE ECHO BIT
TTYUUO 7,A ;RESTORE THE BITS
TLNE A,4 ;TEST TO GET FINAL VALUE
JRST FALSE
JRST TRUE
;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
; - 0 ARGS AND RETURNS NIL
%CLRBFI:CLRBFI ;CLEAR BUFFER
SETZM SMAC ;CLEAR SPLICE LIST
SETZM OLDCH ;CLEAR LAST CHAR.
JRST FALSE
PAGE
;teletype input
ERRCH: MOVEI A,-INUM0(A) ;## CHANGE BELL CHARACTER
EXCH A,ERRCHR ;## RETURN OLD CHARACTER
JRST FIX1A ;## CONVERT IT
REMOTE <
ERRCHR: BELL
>
TTYI: SKIPE DDTIFG ;## DDT MODE?
JRST TTYID
INCHSL A ;single char if line has been typed
JRST [OUTCHR PROMCH# ;$$OUTPUT PROMPT CHARACTER
INCHWL A ;wait for a line
JRST .+1]
TTYXIT: CAME A,ERRCHR ;## BELL, NEED NOT BE ^G
POPJ P,
IFN ALVINE,<
SKIPE PSAV1# ;bell from alvine?
JRST [ MOVE P,PSAV1 ;yes, return to alvine
JRST @ED1];$$DOUBLY IMPROVED MAGIC>
MOVEI A,NIL ;$$ RETURN NIL AS THE VALUE
JRST RERX ;$$ RETURN TO AN ERRORX ERRSET
TTYID: 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
MOVEI A,RUBOUT
POPJ P,
PROMPT: SKIPN A
SKIPA A,PROMCH
MOVEI A,-INUM0(A) ;$$CHANGE FROM INUM
EXCH A,PROMCH# ;$$CHANGE PROMPT CHARACTER AND RETURN OLD ONE
MOVEI A,INUM0(A) ;$$CHANGE TO INUM
POPJ P, ;$$
INTPRP: SKIPN A
SKIPA A,LSPRMP
EXCH A,LSPRMP# ;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
POPJ P, ;$$
READP: SKPINC ;$$ T IFF A CHARACTER HAS BEEN TYPED
JRST FALSE ;$$ (DOES NOT CHECK OLDCH)
JRST TRUE
UNTYI: MOVEI B,-INUM0(A) ;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
MOVEM B,OLDCH
POPJ P, ;$$ RETURN ARG AS VALUE
PAGE
;output
ITYO: SUBI A,INUM0
PUSHJ P,TYO
JRST FIXI
TYO: CAIG A,CR
JRST TYO3
SOSGE CHCT
JRST TYO1
JRST TYOD
REMOTE<TYOD: JRST TTYO+X ;sosg x for other device
;other device output
JRST TYO2X
TYO5: IDPB A,X
POPJ P,
TYO2X: OUT X,
JRST TYO5
ERR1 [SIXBIT /OUTPUT ERROR!/]>
TYO1: PUSH P,A ;linelength exceeded
MOVEI A,IGCRLF ;inored cr-lf
PUSHJ P,TYOD
PUSHJ P,TERPRI ;force out a cr-lf, with special mark
POP P,A
SOSA CHCT
TYO4: POP P,B
JRST TYOD
TYO3: CAIGE A,TAB
JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
PUSH P,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
JRST TYO4
LINELENGTH:
JUMPE A,LINEL1
SUBI A,INUM0
HRRM A,LINL
HRRM A,CHCT
LINEL1: HRRZ A,LINL
JRST FIXI
CHRCT: MOVE A,CHCT
JRST FIXI
REMOTE<
LINL: TTYLL
CHCT: TTYLL>
;teletype output
TTYO: OUTCHR A ;output single character in a
POPJ P,
PAGE
REMOTE<DDTIFG: TRUTH>
DDTIN: EXCH A,DDTIFG
POPJ P,
TTYRET: PUSHJ P,OUTCNT
JRST INCNT
;THIS IS THE NEW, FAST, AND SHORT ROUTINE TO TURN OFF CONTROL O
TTYCLR: SKPINL ;## SKPINL FIXES RUBOUT PROBLEM IN TYPE AHEAD
JFCL
POPJ P,
REMOTE<
TTOCH: 0
IFN STPGAP,<
0 ;tty page number always zero
0 ;tty line number -- always zero
>
TTOLL: TTYLL
TTOHP: TTYLL>
PAGE
SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL
;convert ascii to sixbit for device initialization routines
SIXMAK: SETZM SIXMK2#
MOVE AR1,[POINT 6,SIXMK2]
HRROI R,SIXMK1
PUSHJ P,PRINTA ;use print to unpack ascii characters
MOVE A,SIXMK2
POPJ P,
SIXMK1: ADDI A,40
TLNN AR1,770000
POPJ P, ;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 AR1,(POINT 6,0,29) ;deposit : in last char position
IDPB A,AR1
POPJ P,
;subroutine to process next item in file name list
INXTIO: JUMPE T,NXTIO
HRRZ T,(T)
NXTIO: HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,CPOPJ ;non-atomic
HLRZ A,(T)
JRST SIXMAK ;make sixbit if atomic
;right normalize sixbit
LSH A,-6
SIXRT: TRNN A,77
JRST .-2
POPJ P,
PAGE
;## SUBROUTINE TO TEST FOR A DEVICE OR QUEUE. USED BY I/O ROUTINES
;## AND THE QUEUE ROUTINES. LEAVES A=0 IF NOT AN ATOM AND B=0
;## DEVICE OR QUEUE.
DEVCHK: PUSHJ P,NXTIO ;## MAKE SIXBIT IF AN ATOM
LDB B,[POINT 6,A,35];## GET LAST CHAR
CAIN B,':' ;## DEVICE?
TRZA A,77 ;## YES, CLEAR CHAR BUT LEAVE B INTACT
SETZ B, ;## NO, CLEAR B
POPJ P, ;## DONE, IF A=0 OR B=0, NOT A DEVICE
;## SUBROUTINE TO PARSE THE I/O SPECIFICATION. DEFAULT IS DSK IF
;## NO DEVICE SPECIFIED.
IOSUB: MOVEM T,DEVDAT# ;## SAVE ARG FOR ERRORS
SKIPE DEV ;## DEVICE ALREADY SPECIFIED?
JRST IOSUB1 ;## YES, FORGET DEFAULT
SETZM PPN ;## CLEAR PPN
MOVSI A,'DSK' ;## STORE DSK AS DEFAULT
MOVEM A,DEV
IOSUB1: PUSHJ P,DEVCHK ;## SEE IF DEVICE SPECIFIED
JUMPE A,IOPPN ;## NON-ATOMIC ARG, MUST BE PPN OR (FILE.EXT)
JUMPE B,IOFIL ;## NOT A DEVICE, MUST BE FILE NAME
SETZM PPN
IODEV2: MOVEM A,DEV
IODEV3: PUSHJ P,INXTIO
IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
PUSHJ P,PPNEXT
JUMPN A,IOEXT ;(fil.ext)
HLRZ A,(T)
PUSHJ P,CNVPPN ;## CONVERT PPN
MOVEM A,PPN
JRST IODEV3 ;%% DON'T ZAP DEVICE NAME FOR PPN
IOFIL: JUMPN A,IOFIL2 ;was it an atom
JUMPE T,CPOPJ ;no, was it nil (end)
PUSHJ P,PPNEXT
JUMPE A,CPOPJ ;see a ppn, no file named
IOEXT: HLRZ A,(T) ;(file.ext)
HRRZ A,(A) ;get cdr == extension
PUSHJ P,SIXMAK
HLLM A,EXT
HLRZ A,(T)
HLRZ A,(A) ;get car = file name
PUSHJ P,SIXMAK
FIL: PUSH P,A
PUSHJ P,INXTIO
JRST POPAJ
IOFIL2: CAIN B,":"-40
POPJ P, ;saw a :,not file name
SETZM EXT ;file name -- clear extension
JRST FIL
PPNEXT: JUMPE T,CPOPJ ;end of file name list
HLRZ A,(T)
HRRZ A,(A) ;cdar
JRST ATOM ;ppn iff (not(atom(cdar l)))
CHNSUB: MOVE T,A
HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,TRUE ;non-atomic head of list -- no channel named
HLRZ A,(T)
PUSHJ P,SIXMAK
ANDI A,77
CAIN A,":"-40
JRST TRUE ;device name, assume channel name t
HLRZ A,(T) ;channel name -- return it
HRRZ T,(T)
POPJ P,
;## LEFT HALF OF A CHANNEL TABLE ENTRY IS THE REMAINING
;## FILE LIST. RH POINTS TO EXTENDED HEADER.
REMOTE<
CHTAB=.-FSTCH
BLOCK NIOCH>
PAGE
;search for channel name in chtab
TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
MOVE C,CHTAB(A)
CAME B,CHNAM(C)
AOBJN A,.-2
CAMN B,CHNAM(C)
POPJ P, ;found it!!!
JRST FALSE ;lost
;search for channel name in chtab, and if not there find a free channel, and
;if no free channel, allocate a new buffer and channel
TABSRC: MOVE B,A
PUSHJ P,TABSR1
JUMPN A,DEVCLR ;found the channel
PUSH P,B
MOVE B,0
PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
POP P,B
JUMPN C,DEVCLR ;found free channel which had buffer space previously
PUSH P,A ;must allocate new buffer
MOVEI A,BLKSIZ
SETZ D, ;SPECIAL RELOCATION - SEE LOAD
PUSHJ P,MORCOR ;expand core for buffer if necessary
MOVE C,A
POP P,A
HRRM C,CHTAB(A)
DEVCLR: HRRZ C,CHTAB(A)
HRRZM B,CHNAM(C) ;store name
HRRZM A,CHANNEL#
POPJ P,
;subroutine to reset all i/o channels -- used by excise and realloc
IOBRST: HRRZ A,JOBREL
HRLM A,JOBSA
MOVEM A,CORUSE#
MOVEM A,JOBSYM
SETZM CHTAB+FSTCH
MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
JRST (R)
PAGE
INPUT1: PUSHJ P,CHNSUB ;determine channel name
MOVEI AR1,(A) ;## SAVE CH NAME
EXCH AR1,(P) ;## EXHANGE WITH RETURN ADDR
PUSH P,AR1 ;## AND STUFF THE RETURN ADDR. IN
INPUT2: PUSHJ P,TABSRC ;## GET PHYSICAL CHANNEL NUMBER
MOVEM A,CHANNEL ;## SAVE IT
SETZM DEV ;## CLEAR DEV SO THAT WE CAN
;## DEFAULT IF APPROPRIATE
JRST SETIN1 ;## SET UP FOR INITIALIZTION
INPUT: PUSHJ P,INPUT1
PUSHJ P,ININIT
INFAIL: JUMPE A,AIN.7 ;## CAN'T FIND FILE
JRST POPAJ
BINPUT: PUSHJ P,INPUT1 ;## IMAGE BINARY INPUT
PUSHJ P,BNINIT
JRST INFAIL
ISFILE: JUMPE A,.+5 ;## ROUTINE TO TELL USER IF A FILE EXISTS
PUSH P,A ;## SAVE A IF NON-NIL
MOVEI A,(B) ;## GET THE FILE NAME
PUSHJ P,NCONS ;## (FILNAM)
POP P,B ;## GET THE DEVICE BACK
PUSHJ P,XCONS ;## (DEV FILNAM) OR (FILNAM) WHEN HERE
PUSH P,A ;## SAVE IT FOR RETURN
PUSHJ P,RENSUB ;## SEE IF IT'S THERE
PUSH P,A ;## SAVE THE ANSWER
PUSHJ P,RENCLR ;## CLEAR THE CHANNEL
POP P,A ;## ANSWER IN A
JUMPN A,POPAJ ;## IF NON-NIL, THEN IT'S THERE
POP P,B ;## POP ANSWER OFF
POPJ P, ;## AND RETURN NIL
RENSUB: MOVEM A,DEVDAT ;## SAVE IT FOR ERROR MSGS
PUSHJ P,GENSYM ;## DON'T CLOBBER CURRENT CHANNELS
MOVE T,DEVDAT ;## GET IT BACK
PUSHJ P,INPUT2 ;## SET UP AND OPEN
JRST ININIT ;## AND INIT
RENAME: PUSHJ P,RENSUB ;## RENAME SETUP
JUMPE A,RENCLR ;## NIL IF CAN'T FIND FILE
PUSHJ P,SETINA ;## PROCESS THE NEW NAME
XCT RNAME ;## EXECUTE
JRST RENCLR ;## RETURN NIL IF FAILURE
PUSHJ P,RENCLR ;## CLEAR CHANNEL
JRST TRUE ;## AND RETURN T IF GOOD
REMOTE <
RNAME: RENAME X,LOOKIN ;## RENAME FILE
>
DELERR: PUSHJ P,AIOP
PUSHJ P,RENCLR ;## KILL THE CHANNEL
ERR1 [SIXBIT /CAN'T DELETE FILE !/]
DELETE: PUSHJ P,RENSUB ;## FIRST SETUP(ALLOWS DEFAULT TO DSK:)
JRST .+2 ;## ALREADY INIT'ED
DELET1: PUSHJ P,ININIT ;## INIT AND LOOKUP
JUMPE A,DELET2 ;## IF FILE NOT THERE IGNORE
SETZM LOOKIN ;## BLAST FILE NAME
SETZM EXT ;## AND EXTENSION
XCT RNAME ;## AND RENAME OUT OF EXISTENCE
JRST DELERR ;## RENAME FAILURE
DELET2: JUMPE T,RENCLR ;## DONE
MOVEM T,DEVDAT ;## SAVE REST OF LIST FOR MSGS.
PUSHJ P,SETINA ;## PROCESS NEXT FILE
JRST DELET1 ;## AND DO IT AGAIN
RENCLR: PUSH P,CHANNEL ;## CLEAR CHANNEL
SETO B, ;## FAKE (INC RENCHANNEL T)
PUSHJ P,IOSEL ;## RELEASE THE CHANNEL
JRST POPAJ ;## RETURN NIL (IOSEL CHANGED THINGS)
;## TO LOOK UP A UFD FOR DIRECTORY FNS. SUBR
UFDINP: PUSH P,A
MOVEI T,(B)
PUSHJ P,TABSRC
MOVEM A,CHANNEL ;## HAVE A CHANNEL
MOVE A,[XWD 'DSK','UFD']
HRLZM A,EXT
HLLZM A,DEV
SETZ B,
AOBJP B,.+1 ;## UFD'S SHOULD BE ON [1,1]
MOVEM B,PPN
SKIPN A,T
PUSHJ P,MYPPN ;## IF B=NIL, DEFAULT TO USER'S PPN
MOVEM A,DEVDAT
PUSHJ P,CNVPPN ;## CONVERT PPN
SETZ T, ;## ZAP T (NO MORE FILES)
PUSHJ P,SETIN2 ;## SETUP
PUSHJ P,BNINIT ;## INIT AS BINARY
JUMPE A,ERR ;## ERR NIL IF NOT THERE
PUSHJ P,ININBF ;## SET UP BUFFERS
JRST POPAJ ;## RETURN CHANNEL
MYPPN: GETPPN A, ;## GET PPN
CAI ;## WIERD SKIP RETURN ON THIS UUO
HLRZ C,A ;## ASSUME PPN'S ARE INUMS
HRRZI A,INUM0(A) ;## CONVERT
PUSHJ P,NCONS
HRRZI B,INUM0(C)
JRST XCONS ;## (PROJ PRGRM)
CNVPPN: MOVS A,(A) ;## ASSUME PPNS INUMS
HRRI A,-INUM0(A) ;## LH=CDR, RH=CAR
MOVSS A ;## SWAP HALVES
HLR A,(A) ;## RH=CADR NOW
HRRI A,-INUM0(A)
POPJ P,
SETINA: MOVE A,CHANNEL ;## FOR ROUTINES THAT PROCESS MORE
HRRZ C,CHTAB(A) ;## AND KEEP THE CHANNEL IN CHANNEL
SETIN: MOVEM A,CHANNEL
MOVE A,CHDEV(C)
MOVEM A,DEV
MOVE A,CHPPN(C)
MOVEM A,PPN
SETIN1: PUSHJ P,IOSUB ;get device and file name
SETIN2: MOVEM A,LOOKIN ;file name
MOVE A,DEV
MOVEM A,BDEV ;## ALLOW IMAGE BINARY MODE
CALLI A,DEVCHR
TLNN A,INB
JRST AIN.2 ;not input device
TLNN A,AVLB
JRST AIN.4 ;not available
MOVE A,CHANNEL
DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
DPB A,[POINT 4,BNINIT,ACFLD] ;## FOR IMAGE BINARY
DPB A,[POINT 4,RNAME,ACFLD] ;## FOR RENAME
DPB A,[POINT 4,INLOOK,ACFLD]
DPB A,[POINT 4,ININBF,ACFLD]
HLLZS EXT ;%% CLEAR RIGHT HALF
SETZM LOOKIN+2 ;%% CLEAR THIRD WORD
HRRZ B,CHTAB(A)
HRLM T,CHTAB(A) ;save remaining file name list
MOVEI A,CHDAT(B)
MOVEM A,DEV1 ;pointer to bufdat
MOVEM A,BDEV1 ;## IMAGE BINARY MODE
POPJ P, ;## SET UP FOR INITIALIZTION
REMOTE<
BNINIT: INIT X,13 ;## INIT DEVICE IN IMAGE BINARY
BDEV: X
BDEV1: X
JRST AIN.7 ;## CAN'T INIT
JRST INITOK
ININIT: INIT X,
DEV: X
DEV1: X
JRST AIN.7 ;cant init
INITOK: PUSH B,DEV
PUSH B,PPN
INLOOK: LOOKUP X,LOOKIN
JRST FALSE ;## LET SOMEONE ELSE HANDLE THE ERROR
JRST IRET1>
IRET1: PUSH B,[0] ;oldch
IFN STPGAP,<
PUSH B,[0] ;line number
PUSH B,[0] ;page number
>
ADDI B,4
HRRM B,JOBFF
JRST ININBF
REMOTE<
ININBF: INBUF X,NIOB
JRST TRUE ;## RETURN FROM GOOD LOOKUP WITH T
ENTR:
LOOKIN: BLOCK 4
EXT=LOOKIN+1
PPN=LOOKIN+3
>
PAGE
OUTPUT: PUSHJ P,CHNSUB ;get channel name
PUSH P,A
TRO A,400000 ;set bit for output
PUSHJ P,TABSRC ;get physical channel nuber
SETZM DEV ;## CLEAR DEV FOR DEFAULT TO DSK:
PUSHJ P,IOSUB ;get device and file name
MOVEM A,ENTR ;file name
HLLZS ENTR+1 ;%% CLEAR RIGHT HALF
SETZM ENTR+2 ;zero creation date
MOVE A,CHANNEL
DPB A,[POINT 4,AOUT2,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,AOUT3+1
MOVE A,DEV
MOVEM A,AOUT3
CALLI A,DEVCHR
TLNN A,OUTB
JRST AOUT.2 ;not output device
TLNN A,AVLB
JRST AOUT.4 ;not available
JRST AOUT2
REMOTE<
AOUT2: INIT X,
AOUT3: X
X
JRST AOUT.4 ;cant init
PUSH B,DEV
OUTENT: ENTER X,ENTR
JRST OUTERR ;cant enter
JRST ORET1>
ORET1: PUSH B,[LPTLL] ;linelength
PUSH B,[LPTLL] ;chrct
IFE STPGAP,< ADDI B,4>
IFN STPGAP,< ADDI B,6>
HRRM B,JOBFF
XCT OUTOBF
REMOTE<
OUTOBF: OUTBUF X,NIOB
>
JRST POPAJ
OUTERR: PUSHJ P,AIOP
LDB A,[POINT 3,ENTR+1,35]
CAIE A,2
ERR1 [SIXBIT /DIRECTORY FULL !/]
ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
PAGE
IOSEL: MOVE C,-1(P)
JUMPE C,CPOPJ ;tty
JUMPE B,IOSELZ ;dont release
IOSEL1: DPB C,[POINT 4,RLS,ACFLD]
XCT RLS
REMOTE<
RLS: RELEASE X, ;release channel
>
HRRZS CHTAB(C) ;release channel table entry
MOVEM 0,@CHTAB(C) ;blast channel name
SETZM -1(P)
IOSELZ: HRRZ C,CHTAB(C)
POPJ P,
PAGE
INCNT: MOVEI A,NIL ;(INC NIL T)
MOVEI B,TRUTH(S)
INC: PUSH P,INCH#
PUSHJ P,IOSEL
JUMPN B,INC2 ;released channel
SKIPN C
MOVEI C,TTOCH-CHOCH ;tty deselect
IFN STPGAP,<
MOVEI B,CHOCH(C)
HRLI B,OLDCH
BLT B,CHLINE(C) ;save channel data
>
IFE STPGAP,<
MOVE B,OLDCH
MOVEM B,CHOCH(C)
>
JRST INC2+1
INC2: SETZM INCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
JUMPE A,ITTYRE ;select tty
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
HRRZM A,INCH
DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
DPB A,[POINT 4,TYI2Y,ACFLD]
DPB A,[POINT 4,TYI2Z,ACFLD]
HRRZ A,CHTAB(A)
MOVEI T,COUNT(A)
HRLI T,(SOSG)
MOVEI B,POINTR(A)
HRRM B,TYI3 ;set up tyi parameters
HRRM B,TYI3A
INC3:
IFN STPGAP,<
MOVSI B,CHOCH(A)
HRRI B,OLDCH
BLT B,LINUM ;restore channel data
>
IFE STPGAP,<
MOVE B,CHOCH(A)
MOVEM B,OLDCH
>
MOVEM T,TYI2
IOEND: POP P,A
JUMPE A,CPOPJ
MOVE A,CHTAB(A) ;get channel name
HRRZ A,(A)
TRZ A,400000 ;clear output bit
POPJ P,
ITTYRE: SETZM INCH
MOVE T,[JRST TTYI] ;reselect tty
MOVEI A,TTOCH-CHOCH
JRST INC3
PAGE
OUTCNT: MOVEI A,0 ;(outc nil t)
MOVEI B,1
OUTC: PUSH P,OUTCH#
PUSHJ P,IOSEL
JUMPN B,OUTC2 ;closed this file
SKIPN C
MOVEI C,TTOLL-CHLL ;tty deselect
MOVE B,CHCT
MOVEM B,CHHP(C) ;save channel data
MOVE B,LINL
MOVEM B,CHLL(C)
JRST OUTC2+1
OUTC2: SETZM OUTCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
JUMPE A,OTTYRE ;return to tty
TRO A,400000 ;set output bit
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
HRRZM A,OUTCH
HRRZ A,CHTAB(A)
MOVEI B,POINTR(A)
HRRM B,TYO5 ;set up tyo2 parameters
MOVEI T,COUNT(A)
HRLI T,(SOSG)
OUTC3: MOVE B,CHLL(A)
MOVEM B,LINL
MOVE B,CHHP(A)
MOVEM B,CHCT
MOVEM T,TYOD
JRST IOEND
OTTYRE: SETZM OUTCH
MOVE T,[JRST TTYO]
MOVEI A,TTOLL-CHLL ;tty reselect
JRST OUTC3
PAGE
AIN.1: PUSHJ P,AIOP
ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
AOUT.2:
AIN.2: PUSHJ P,AIOP
ERR1 [SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4: PUSHJ P,AIOP
ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
AIN.7: PUSHJ P,AIOP
ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
AIN.8: SIXBIT /INPUT ERROR!/
AIOP: MOVE A,DEVDAT
JRST EPRINT
PAGE
SUBTTL QMANGR INTERFACE
;## CODE TO ALLOW LISP USER'S TO CALL DEC'S QMANGR, ALLOWING
;## PRINTING OF FILES AND CREATION OF JOBS
;## SCANS ARG LIST SETTING UP THE APPROPRIATE PARAMETERS. IT
;## SAVE THE PDLS, SWAPS HI-SEGS FOR SYS:QMANGR AND
;## DOES A PUSHJ TO 400010. IT ALSO CHANGES JOBREN SO
;## THAT THE USER CAN RECOVER IN CASE OF QMANGR ERRORS.
;## ST WILL ALSO STILL WORK. REG 17 (SP) IS USED AS QMANGR'S
;## PDL. CORE IS CONTRACTED AFTER RETURN FROM QMANGR AND QUEUE
;## RESTORES APPROPRIATE REGS AND RETURNS NIL. ALTHOUGH
;## CODE FOR EXTENDED SWITCHES IS INCLUDED, MOST OF
;## IT IS TURNED OFF. USE AT YOUR OWN RISK. NOTE THAT
;## /LIST, /AFTER AND /DEAD REQUIRE SPECIAL CODE
;## THAT IS NOT INCLUDED. SEE APPROPRIATE
;## DEC DOCUMENTATION FOR FURTHER INFO. 6/12/73
IFN QALLOW <
IFNDEF QSWEXT <QSWEXT=0> ;## IF NOT DEFINED THEN DEFAULT IS NO EXTENDED
IFE QSWEXT <NSWS==QTABL1>;## NUMBER OF ALLOWED SWITCHES
IFN QSWEXT <NSWS==QTABL2>;## LENGTH OF EXTENDED TABLE
IFNDEF QLSTOK <QLSTOK==0>
IFNDEF QTIME <QTIME==0>
;%% THE FOLLOWING CODE IS AN ILLUSTRATION OF HOW
;%% EASY IT IS TO LOSE TRYING TO INTERFACE TO
;%% DEC SOFTWARE. THE FOLLOWING DEFINITIONS ALLOW
;%% TOO FEW WORDS FOR THE CURRENT FILE PARAMETER
;%% AREA; SEE THE DEFINITIONS AS COPIED FROM
;%% THE QMANGR SOURCE BELOW.
COMMENT &
INPPAR==32 ;## NUMBER OF WORDS IN INP AREA FOR INPUT REQUEST
OUTPAR==24 ;## NUMBER WORDS IN MAIN AREA FOR OUTPUT REQUEST
DIFPAR==INPPAR-OUTPAR ;## DIFFERENCE IN LENGTHS FOR MAIN AREA TYPES
FILPAR==14 ;## NUMBER WORDS IN FILE PARAMTER AREA
;## LOCATIONS IN PARAMETER AREAS
;## MAIN AREA
Q.MEM==0 ;## MEMORY FOR QMANGR
Q.OPR==1 ;## REQUESTED OPERATION
Q.LEN==2 ;## RH=NUMBER OF FILES IN REQUEST
Q.DEV==3 ;## REQUESTED QUEUE
Q.PPN==4 ;## PPN REQUESTING
Q.JOB==5 ;## JOB NAME
Q.SEQ==6 ;## JOB SEQUENCE #
Q.PRI==7 ;## EXTERNAL PRIORITY
Q.PDEV==10 ;##
Q.TIME==11 ;##
Q.CREA==12 ;##
Q.AFTR==13 ;## AFTER PARAMETER
Q.DEAD==14 ;## DEADLINE PARAMETER
Q.CNO==15
Q.USER==16 ;## AND 17
;## INPUT SECTION OF MAIN PARAMETER AREA
Q.IDEP==20 ;## RESTART AND DEPENDENCY PARAMTERS
Q.ILIM==21 ;## CORE AND CPU, +1 IS LPT LIMIT AND CDP LIMIT
;## +2 IS PTP LIMIT AND PLOT LIMIT
Q.IDDI==24 ;## THRU 31
Q.IEND==31 ;## LAST LOC OF INP AREA
;## OUTPUT SEECTION OF MAIN PARAMETER AREA
Q.OFRM==20 ;## FORM PARAMTER
Q.OSIZ==21 ;## LH=LIMIT
Q.ONOT==22
Q.OEND==23 ;## LAST LOC OF OUTPUT AREA
;## FILE PARAMETER AREA (ONE FOR EACH FILE)
Q.FSTR==0 ;## FILE STRUCTURE
Q.FDIR==1 ;## THRU 6, DIRECTORY
Q.FNAM==7 ;## FILE NAME
Q.FEXT==10 ;## FILE EXTENSION
Q.FRNM==11 ;## RENAME NAME (0)
Q.FBIT==12
Q.FMOD==13 ;## SPACING, FILE DISPOSAL, COPIES
& ;%% END OF DELETED DEFINITIONS
;%% THE FOLLOWING ARE AS COPIED FROM QMANGR (VERSION 34)
;%% ON 24 OCTOBER 1973
QDEFST==. ;%% WHERE TO RELOC TO AFTERWARDS
RELOC 0 ;%% TO SAVE CORE AND AVOID CONFUSION
;%% COMMENTS BELOW ARE AS COPIED
;%% FROM QMANGR
PHASE 0
Q.ZER:! ;START OF QUEUE PARAMETER AREA
Q.MEM:! BLOCK 1 ;HOLD XWD WINDOW BLOCK,WINDOW WORD INDEX
Q.OPR:! BLOCK 1 ;OPERATION CODE
QO.CRE==1 ;CREATION OPERATION
QO.LST==4 ;LIST OPERATION
QO.MOD==5 ;MODIFY OPERATION
QO.KIL==6 ;KILL OPERATION
QO.DEL==10 ;DELETE OPERATION
QO.REQ==11 ;REQUEUE OPERATION
QO.FLS==12 ;FAST LIST OPERATION
Q.LEN:! BLOCK 1 ;LENGTHS IN AREA
Q.DEV:! BLOCK 1 ;DESTINATION DEVICE
Q.PPN:! BLOCK 1 ;PPN ORIGINATING REQUEST
Q.JOB:! BLOCK 1 ;JOB NAME
Q.SEQ:! BLOCK 1 ;JOB SEQUENCE NUMBER
Q.PRI:! BLOCK 1 ;EXTERNAL PRIORITY
Q.PDEV:! BLOCK 1 ;PROCESSING DEVICE
Q.TIME:! BLOCK 1 ;PROCESSING TIME OF DAY
Q.CREA:! BLOCK 1 ;CREATION TIME
Q.AFTR:! BLOCK 1 ;AFTER PARAMETER
Q.DEAD:! BLOCK 1 ;DEADLINE TIMES
Q.CNO:! BLOCK 1 ;CHARGE NUMBER
Q.USER:! BLOCK 2 ;USER'S NAME
Q.I:! ;START OF INPUT QUEUE AREA
Q.IDEP:! BLOCK 1 ;DEPENDENCY WORD
Q.ILIM:! BLOCK 3 ;JOB LIMITS
Q.IL:! ;END OF AREA NEEDED TO READ FOR MASTER QUEUE
Q.IDDI:! BLOCK 6 ;JOB'S DIRECTORY
Q.II:! ;START OF INPUT FILES AREA
PHASE Q.I
Q.O:! ;START OF OUTPUT QUEUE AREA
Q.OFRM:! BLOCK 1 ;FORMS REQUEST
Q.OSIZ:! BLOCK 1 ;LIMIT WORD
Q.OL:! ;END OF AREA NEEDED TO READ FOR MASTER QUEUE
Q.ONOT:! BLOCK 2 ;ANNOTATION
Q.FF:!
PHASE 0
Q.F:! ;DUPLICATED AREA FOR EACH REQUESTED FILE
Q.FSTR:! BLOCK 1 ;FILE STRUCTURE
Q.FDIR:! BLOCK 6 ;ORIGINAL DIRECTORY
Q.FNAM:! BLOCK 1 ;ORIGINAL NAME
Q.FEXT:! BLOCK 1 ;ORIGINAL EXTENSION
Q.FRNM:! BLOCK 1 ;RENAMED FILE NAME (0 IF NOT)
Q.FBIT:! BLOCK 1 ;BIT 0=PRESERVED BY QUEUE, REST=STARTING BIT
Q.FMOD:! BLOCK 1 ;FILE SWITCHES
X.LOG==1B1 ;FILE IS LOG FILE
X.NEW==1B2 ;OK IF FILE DOESNT EXIST YET
Q.FRPT:!BLOCK 2 ;/REPORT
Q.FLEN==.-Q.F
DEPHASE
PHASE 0
Q.FDRM:! BLOCK 6 ;DIRECTORY MASK FOR MODIFY
Q.FNMM:! BLOCK 1 ;FILE NAME MASK FOR MODIFY
Q.FEXM:! BLOCK 1 ;EXTENSION MASK FOR MODIFY
Q.FMDM:! BLOCK 1 ;MODIFIER MASK FOR MODIFY
Q.FMLN==.-Q.F ;LENGTH OF MODIFY BLOCK
DEPHASE
RELOC QDEFST ;%% MAKE UP FOR INCREASE IN LOCATION
;%% COUNTER
INPPAR==Q.II ;%% SIZE OF MINIMUM INPUT AREA
OUTPAR==Q.FF ;%% SIZE OF MINIMUM OUTPUT AREA
OUTPR1==OUTPAR-1 ;%% MACRO DOESN'T LIKE EXPRESSIONS
DIFPAR==INPPAR-OUTPAR ;%% DIFFERENCE IN AREAS
FILPAR==Q.FLEN ;%% FILE DATA AREA
LOWLEN==^D110 ;## AREA NEED FOR PARAMETER
;## AREA TO QMANGR
LHLEN==OUTPR1*1B26+FILPAR ;## LH OF Q.LEN DEFAULTS
NQS==6 ;## NUMBER OF QUEUES
;## QUEUE ERRORS
QILLSW: HLRZ A,(T) ;## GET SWITCH THAT CAUSED ERROR
PUSHJ P,PRINT
STRTIP [SIXBIT / =ILL. SWITCH SPEC.!/]
PUSHJ P,CONCOR ;## SAVE THAT CORE
QERR1: ERR1 [SIXBIT /ERROR IN QUEUE REQUEST!/]
QUEUE: SKIPN T,A ;## ERROR IF NO ARGS
JRST QERR1
PUSHJ P,DEVCHK ;## SEE IF QUEUE SPECIFIED
JUMPE A,NOQUE ;## IF A=0 THEN NOT A QUEUE
JUMPE B,NOQUE ;## IF B=0 THEN NOT A QUEUE
MOVE AR2A,A
HLRZ B,A ;## GET FIRST THREEE LETTERS
MOVEI C,NQS ;## GET NUMBER OF PERMISSIBLE QUEUES
SOJL C,NOQUE ;## IF EXHAUSTED TABLE, THEN NO QUEUE
MOVE A,QSTABL(C) ;## PERMISSIBLE QUEUES
JSP R,CHKGO ;## JUMP TO ROUTINE THAT COMPARES RH AND GO
;## TO LH OF A IFF RH(A)=B
JRST .-3 ;## LOOP
;## TABLE OF PERMISSIBLE QUEUES AND WHERE TO GO ON EACH
QSTABL: XWD INPREQ, 'INP'
XWD OUTREQ, 'LPT'
XWD OUTREQ, 'PTP'
XWD OUTREQ, 'PTP'
XWD OUTREQ, 'CDP'
XWD OUTREQ, 'PLT'
OUTREQ: TDZA A,A ;## HERE TO PROCESS OUTPUT REQUEST(CLEAR A)
INPREQ: MOVEI A,DIFPAR ;## HERE TO PROCESS INPUT REQUEST
JRST QGOOD ;## FOUND A QUEUE
NOQUE: MOVSI AR2A,'LPT' ;## HERE IF NO QUEUE, DEFAULT=LPT
TDZA A,A ;## CLEAR A AND SKIP
QGOOD: HRRZ T,(T) ;## HERE IF QUEUE SPECIFIED
ADDI A,OUTPAR ;## A IS ZERO OR INPPAR
QSETUP: PUSH P,B ;## B CONTAINS THREE LETTERS(OR BLANK). SAVE IT
HRLZI TT,(A) ;## SAVE LNENGTH OF AREA
PUSHJ P,TEMCOR ;## EXPAND CORE
HRRI TT,(A) ;## START ADDR OF MAIN AREA
MOVE A,TT
PUSHJ P,CLRBLK ;## CLEAR AREA
MOVEM AR2A,Q.DEV(TT)
MOVEI C,LHLEN ;## GET LENGTHS FOR HEADER AND FILE AREAS
MOVE A,[XWD 500,500]
HRLZM A,Q.OSIZ(TT) ;## ASSUME OUTPUT HERE
POP P,B ;## RESTORE LEFT THREE LETTERS
CAIE B,'INP' ;## WAS IT AN INPUT REQUEST?
JRST QUEUE1 ;## NO SHOULD BE OK
ADDI C,DIFPAR_9 ;## UPDATE HEADER LENGTH
MOVEM A,Q.ILIM+1(TT) ;## MAX PAGES AND CARD PUNCH
MOVEM A,Q.ILIM+2(TT) ;## MAX PAPER TAPE AND PLOTTER
HRLI A,^D256
MOVEM A,Q.ILIM(TT) ;## MAX CORE AND CPU(CORMAX MAY HAVE TO BE
;## CHECKED HERE)
MOVSI A,400000 ;## SET BIT 0 FOR NOT RESTARTABLE
HLLZM A,Q.IDEP(TT) ;## NOT RESTARTABLE(NO DEPEND OR UNIQUENESS)
QUEUE1: MOVSM C,Q.LEN(TT) ;## SET HEADER AND FILE AREA LENGTHS
GETPPN A, ;## SET REQUESTING PPN
CAI ;## WEIRD SKIP RETURN ON THIS UUO
MOVEM A,Q.PPN(TT)
SETZ REL, ;## CLEAR REG FOR FILE AREA
MOVEI A,20 ;## PRIORITY DEFAULT
MOVEM A,Q.PRI(TT)
AOSA Q.OPR(TT) ;## SET DEFAULT FOR REQUEST TYPE=/CREATE
;## BASIC LOOP FOR HANDLING THE SWITCHES
QLOOP: HRRZ T,(T) ;## HERE IF ROUTINE DID NOT MOVE ARG
QSELF: JUMPE T,QDONE
PUSHJ P,DEVCHK ;## SEE IF DEVICE OR ATOMIC FILE NAME?
JUMPN B,QFILEA ;## IF B#0 THEN DEVICE
JUMPN A,QFILE ;## IF A#0 THEN ATOMIC FILE
HLRZ C,(T) ;## WELL, SEE IF SWITCH
HRRZ A,(C) ;## CDAR
PUSHJ P,ATOM ;## ATOM?
JUMPN A,QFILE ;## YES, THEREFORE(FILE.EXT)
HLRZ B,(C) ;## CAAR
SUBI B,(S) ;## STRIP OFF RELOCATION
HRRZI C,NSWS ;## GET NUMBER OF SWITCHES
QLOOP1: SOJL C,QFILE ;## IF NO SWITCH, GO QFILE
MOVE A,QTABLE(C) ;## GET MEMBER OF TABLE
JSP R,CHKGO
JRST .-3 ;## LOOP
;## DISPATCH TABLE FOR SWITCHES
QTABLE:
PHASE 1
XWD QCOPIE,COPIES ;## /COPIES
XWD QCPU,CPU ;## /CPU
XWD QFORMS,FORMS ;## /FORMS
XWD QLIMIT,LIMIT ;## /LIMIT
QTABL1: XWD QDISP,DISP ;## /DISP (FILE DISPOSITION)
;## EXTENDED SWITCHES
IFN QSWEXT <
IFE QLSTOK <XWD QILLSW, LISTAT>
IFN QLSTOK <XWD QLIST, LISTAT>
IFE QTIME <
XWD QILLSW,AFTER ;## /AFTER ILLEGAL (SEE ABOVE)
XWD QILLSW,DEAD ;## /DEAD (DEADLINE)
>
IFN QTIME <
XWD QAFTR,AFTER
XWD QDEAD,DEAD
>
XWD QCORE,COREAT
XWD QMOD,MODIFY ;## /MODIFY
XWD QKILL,KILL ;## /KILL
XWD QJOB,JOB ;## /JOB
XWD QDEPND,DEPEND ;## /DEPEND
XWD QRSTR,RSTRT ;## /RESTART
XWD QUNIQ,UNIQUE ;## /UNIQUE
XWD QCORE,COREAT ;## /COREE
XWD QPAGES,PAGES ;## /PAGES
XWD QPLOT,PLOT ;## /PLOT
XWD QPTAPE,PTAPE ;## /PTAPE
XWD QCARDS,CARDS ;## /CARDS
XWD QSEQ,SEQ ;## /SEQ
XWD QPRIOR,PRIOR ;## /PRIOR (PRIORITY)
XWD QSPACE,SPACE ;## /SPACE (SPACING)
XWD QLIMIT,LIMIT ;## /LIMIT
QTABL2: XWD QHEAD,HEAD ;## /HEAD (HEADERS)
>
DEPHASE
;## DISPATCHING THE VARIOUS SWITCHES
IFN QSWEXT <QLIST: HRRZI A,4 ;## HERE FOR LIST REQUEST
CAIA
QMOD: HRRZI A, 5 ;## /MODIFY
CAIA
QKILL: HRRZI A, 6 ;## /KILL
HRRZM A, Q.OPR(TT)
JRST QLOOP
>
;## INPUT QUEUE ONLY SWITCHES
;## PUTS BYTE POINTER INTO B AND THEN CHECKS TO SEE IF SWITCH VALID IN
;## THIS CONTEXT (I.E. ARE WE PROCESSING AN INPUT REQUEST?)
;## IF NOT VALID, SKIPS THE SWITCH(MAY BE CHANGED LATER)
IFN QSWEXT <
QPLOT: JSP R,RINPCH
AOJA B, QCARD+1
QPTAPE: JSP R, LINPCH
AOJA B, .+4
QCARDS: JSP R, RINPCH
AOJA B, .+4
QPAGES: JSP R, LINPCH
AOJA B, .+4
>
QCPU: JSP R, RINPCH
AOJA B,QARG
IFN QSWEXT <
QCORE: JSP R, LINPCH
AOJA B,QARG
QDEPND: JSP R, RINPCH
JRST QARG
>
;## OUTPUT QUEUE ONLY SWITCHES
QFORMS: JSP R, OUTCHK
PUSH P,QSXARG ;## CONVERT ARG TO SIXBIT
MOVEM A, Q.OFRM(TT) ;## MAKE SIXBIT IF FORMS
JRST QLOOP
QLIMIT: JSP R, OUTCHK
MOVE B,LINP
AOJA B,QARG
OUTCHK: HLRZ A,Q.DEV(TT) ;## GET REQUEST TYPE (THREE LETTERS)
CAIE A,'INP' ;## ERROR IF INPUT REQUEST
JRST (R)
JRST QILLSW
QCOPIE: JSP R, FILECH ;## CHECK IF WE HAVE SET UP A FILE AREA
MOVE B,[POINT 6,Q.FMOD(REL),35] ;## BYTE POINTER
JRST QARG
;## FOR DISPOSITION, 1=PRESERVE, 2=RENAME, 3=DELETE,
;## FIRST THREE LETTERS OF ARG TO SWITCH UNIQUELY IDENTIFY
;## ILLEGAL ARG CAUSES ERROR
QDISP: JSP R,FILECH ;## BE SURE FILE AREA SET UP
PUSHJ P,QSXARG ;## MAKE ARG SIXBIT
HLRZ C,A ;## GET FIRST THREE LETTERS
SETZ A, ;## CLEAR A
CAIN C,'DEL' ;## DELETE AFTER OUTPUT!
AOJA A,.+2 ;## YES!
CAIN C,'REN' ;## RENAME FILE OUT OF UFD?
AOJA A,.+3
CAIE C,'PRE' ;## PRESERVE IT
JRST QILLSW ;## HERE IF BAD ARGUMENT
ADDI A,1
MOVE B, [POINT 3, Q.FMOD(REL), 29]
JRST QARG+1 ;## ARG ALREADY IN A
;## HERE WHEN SWITCH DETERMINED AND BITE POINTER IN B
QGTARG: MOVEI A,(T)
PUSHJ P,CADAR
SUBI A,INUM0 ;## ARG SHOULD BE AN INUM
POPJ P,
QARG: PUSHJ P,QGTARG ;## GET ARGUMENT
DPB A,B ;##
JRST QLOOP ;## ALWAYS RETURN TO QLOOP
;## HERE TO SEE IF INP QUEUE FOR EXTENDED PART OF MAIN AREA
LINPCH: MOVE B,LINP ;## GET LH BITE POINTER
CAIA
RINPCH: MOVE B,RINP ;## GET RH BITE POINTER
HLRZ A,Q.DEV(TT) ;## GET QUEUE SPEC
CAIN A,'INP' ;## INP?
JRST (R) ;## YES
JRST QILLSW
LINP: POINT 18, Q.IDEP(TT),17 ;## BYTE POINTER FOR LEFT HALF OF EXTENDED MAIN AREA
RINP: POINT 18, Q.IDEP(TT),35 ;## BYTE POINT FOR RH OF EXTENDED MAIN AREA
;## HERE TO BE SURE FILE AREA HAS BEEN SET UP
FILECH: JUMPN REL,(R) ;## REL NONZERO IF FILE AREA SET UP
PUSH P,R
JRST FILARE
;## HERE TO FIND FILE SPECIFICATION
QFILEA: HRRZ T,(T) ;## GET CDR
SETZ B, ;## CLEAR B
JRST QFILEB
QFILE: MOVSI A,'DSK' ;## DEFAULT IS DSK
CAIE REL,0 ;## AREA SET UP?
SKIPA A,Q.FSTR(REL) ;## GET CURRENT DEVICE
SKIPA B,Q.PPN(TT) ;## GET USER'S PPN IF NOT SET UP
MOVE B,Q.FDIR(REL) ;## GET CURRENT PPN
QFILEB: MOVEM B,PPN ;## SET PPN
MOVEM A,DEV ;## HANG ON TO DEVICE
JUMPE T,QSELF ;## IF NIL THEN DONE
PUSHJ P,NXTIO ;## FAKE IOSUB SEQUENCE
PUSHJ P,IOPPN
PUSH P,A ;## IOPPN RETURNS FILE NAME IN A
CAIE REL,0 ;## AREA SET UP?
SKIPE Q.FNAM(REL) ;## AREA SET UP, BUT NO FILE NAME?(PRECEDING SWITCHES)
PUSHJ P,FILARE ;## SET UP AREA
MOVE A,DEV ;## GET DEVICEE
MOVEM A,Q.FSTR(REL) ;## SET FILE STRUCTURE
MOVE A,EXT ;## GET EXTENSION
MOVEM A,Q.FEXT(REL) ;## SET IT
MOVE A,PPN ;## GET PPN
MOVEM A,Q.FDIR(REL)
;## SET IT(DIRECTORY)
POP P,Q.FNAM(REL) ;## RESTORE NAME
JRST QSELF ;## T HAS BEEN RESET BY IO ROUTINES!
;## HERE TO SET UP FILE AREA
FILARE: AOS Q.LEN(TT) ;## ADD ONE TO NUMBER FILES IN REQUEST
HRLZI A,FILPAR
ADD TT,A ;## ADD TO LENGTH OF PARAMETER AREA
HRRZI A,FILPAR
PUSHJ P,EXPCOR
JUMPE REL,FILDEF ;## SET DEFAULST IF NO PREVIOUS FILE AREA
HRL A,REL
HRRZI B,(A) ;## SET UP FOR BLT OF PREVIOUS AREA
ADDI B,FILPAR-1 ;## FINAL DESTINATION ADDRESS
HRRZI REL,(A) ;## NEW FILE AREA
BLT A,(B)
SETZM Q.FNAM(REL)
POPJ P,
FILDEF: HRRZI REL,(A)
HRLI A,FILPAR
PUSHJ P,CLRBLK
HRLZI A,'DSK'
MOVEM A,Q.FSTR(REL)
MOVE A,[EXP 1B5+1B20+1B26+1B29+1] ;## DEFAULTS FOR Q.FMOD
MOVEM A,Q.FMOD(REL)
POPJ P,
;## HERE WHEN FINISHED
QDONE: MOVE AR1,OUTPAR+Q.FNAM(TT) ;## GET FIRST FILE NAME
HLRZ A,Q.DEV(TT) ;## GET FIRST THREE LETTERS OF Q AGAIN
CAIE A,'INP' ;## INPUT QUEUE?
JRST QDONEB ;## NO
MOVE AR1,INPPAR+Q.FNAM(TT) ;## GET CORRCT FILE NAME
HRRZ A,Q.LEN(TT) ;## GET NUMBER OF FILES SPECIFIED
SOJG A,QDONEC ;## GREATER THAN ONE MEANS THAT USER
;## SPECIFIED A LOG FILE
PUSHJ P,FILARE ;## WE HAVE TO SET UP LOG FILE
HRRZI A,'LOG' ;## CHANGE EXTENSION TO .LOG
HRLZM A,Q.FEXT(REL)
MOVEM AR1,Q.FNAM(REL) ;## SET TO INP FILE NAME
QDONEC: HRRI A,3
DPB A,[POINT 2,INPPAR+FILPAR+Q.FMOD(TT),2];## SET BITS
;## INDICATING LOG FILE AND DOESN'T EXIST
;## (AVOIDS ERROR MSGS FROM QMANGR)
;## IN SECOND FILE IN CASE USER STUPIDLY SET
;## UP MORE THAN TWO
QDONEB: SKIPE Q.JOB(TT) ;## SPECIFIED NAME
JRST QDONE1 ;## YES, DONE
MOVEM AR1,Q.JOB(TT)
QDONE1: MOVE C,[EXP 'QMANGR'];## SEGMENT NAME
MOVEI B,400010
MOVE A,TT
PUSHJ P,NEWHI
PUSHJ P,CONCOR ;## CONTRACT CORE
JRST FALSE ;## RETURN NIL
;## ROUTINE TO SWAP HI-SEGMENTS. REGISTER A CONTAINS ARG TO NEXT HI-SEG, B CONTAINS
;## LOCATION TO JUMP TO IN NEW HI-SEG. REGS ARE ARG BLOCK TO GETSEG UUO
;## TO THE GET SEG
NEWHI: PUSH P,SP ;## HAVE TO SAVE SP, SINCE MOST
;## SYSTEM PROGS USE 17 FOR THEIR PDL
MOVEM A,HIARGS# ;## SAVE ARG TO HI-SEG
HRRZM B,HIADDR# ;## SAVE ADDR TO HI-SEG
PUSH P,JOBFF ;%% SAVE OLD VALUE
;%% (DON'T ASK WHY)
HLRZ B,A ;%% CALCULATE NEW VALUE
ADDI B,1(A) ;%%
MOVEM B,JOBFF ;%% RESET SO QMANGR WON'T WRITE
;%% OVER ARGUMENT BLOCK.
;%% JUST BECAUSE LISP IGNORES JOBFF
;%% DOESN'T MEAN ANYONE ELSE DOES
MOVEM P,PSAVE# ;## SAVE P (CAN'T USE SP)
MOVE SP,P ;## USE RPDL
HRRZI A,OLDHI ;## REE WILL RESTORE AND CONTINUE
MOVEM A,JOBREN
MOVEM A,JOBREN ;## SET FAKE REE ADDRESS
HRLZI B,'SYS' ;## SYS: IS LOCATION OF NEW HI-SEG
MOVEI A,B ;## B IS STARTING LOCATION OF BLOCK TO GETSEG
SETZB AR1,AR2A ;## CLEAR REST OF BLOCK
SETZB T,TT ;## DITTO
MOVEM SP,SAVSP# ;## SAVE SP AROUND GETSEG (WHICH CLOBBERS ACS)
JRST NEWHI1 ;## GO DO IT
;## HERE TO GET THAT HI-SEG
REMOTE <
NEWHI1: CALLI A,GETSEG
JRST @JOBREN ;## FAILED JOBREN HAS LOC OF RESTORE LISP HI-SEG
MOVE SP,SAVSP
MOVE A,HIARGS
PUSHJ SP,@HIADDR ;## JUMP TO HI-SEG
OLDHI: MOVEI A,HGHDAT
CALLI A,GETSEG
HALT ;## YOU'RE DEAD IF YOU ARE HERE
ENDHI: JRST RESTOR ;## JUMP TO RESTORE THINGS
>
RESTOR: MOVE P,PSAVE
POP P,JOBFF ;%% RESTORE OLD VALUE
POP P,SP
MOVE 0,STNIL
MOVE S,ATMOV
HRRZI A,DEBUGO
MOVEM A,JOBREN
POPJ P,
TEMCOR: HRRZ B,CORUSE ;## GET CURRENT CORUSE. THIS ROUTINE EXPANDS CORE
;## BUT SAVE INFO SO THAT IT CAN BE CONTRACTED LATER
HRL B,JOBREL ;## GET CURRENT CORE EXTENT
MOVEM B,OLDCU ;## SAVE IT (SEE LOADER INTERFACE)
EXPCOR: SETZ D, ;## D IS A RELOC REG
JRST MORCOR ;## EXPAND CORE
CONCOR: MOVS B,OLDCU ;## CONTRACTS CORE, OPPOSITE TEMCOR
HLRZM B,CORUSE
HRRZI B,(B) ;## CLEAR LH
PUSHJ P,MOVDWN ;## MOVE SYMBOL TABLE
CALLI B,CORE ;## CONTRACT (B SHOULD BE UNCHANGED
CAI
POPJ P, ;## DONE
QSXARG: MOVEI A,(T)
PUSHJ P,CADAR ;## GET ARGUMENT TO SWITCH
JRST SIXMAK ;## CONVERT IT TO SIXBIT
CLRBLK: SETZM (A) ;## CLEAR FIRST WORD
HLRZ B,A ;## LH OF A CONTAINS LENGTH
ADD B,A
HRL A,A
AOJ A, ;## RH NOW CONTAINS SOURCE+1
BLT A,-1(B) ;## BLT CLEARS BLOCK
POPJ P,
;## PICKUP
CHKGO: CAIN B,(A) ;## SEE IF RH(A)=(B)
HLRZ R,A ;## WHERE TO GO
JRST (R) ;## NO, RETURN
>
PAGE
SUBTTL PRINT
EPRINT: SKIPN ERRSW
POPJ P,
PUSHJ P,ERRIO
PUSHJ P,PRINT
JRST OUTRET
PRINT: MOVEI R,TYO
PUSHJ P,TERPRI
PUSHJ P,PRIN1
XCT " ",CTY
POPJ P,
PRINC: SKIPA R,.+1
PRIN1: HRRZI R,TYO
PUSH P,A
PUSHJ P,PRINTA
JRST POPAJ
PRINTA: PUSH P,A
MOVEI B,PRIN3
SKIPGE R
MOVEI B,PRIN4
HRRM B,PRIN5
PUSHJ P,PATOM
JUMPN A,PRINT1
XCT "(",CTY
PRINT3: HLRZ A,@(P)
PUSHJ P,PRINTA
HRRZ A,@(P)
JUMPE A,PRINT2
MOVEM A,(P)
XCT " ",CTY
PUSHJ P,PATOM
JUMPE A,PRINT3
XCT ".",CTY
XCT " ",CTY
PUSHJ P,PRIN1A
PRINT2: XCT ")",CTY
JRST POPAJ
PRINT1: PUSHJ P,PRIN1A
JRST POPAJ
PAGE
PRIN1A: MOVE A,-1(P)
CAILE A,INUMIN
JRST PRINIC
JUMPE A,PRIN1B
CAIGE A,@GCP1
CAIGE A,@GCPP1
JRST PRINL
PRIN1B: HRRZ A,(A)
JUMPE A,PRINL
HLRZ B,(A)
HRRZ A,(A)
CAIN B,PNAME(S)
JRST PRINN
CAIN B,FIXNUM(S)
JRST PRINI1
CAIN B,FLONUM(S)
JRSTF @[XWD 0,PRINO] ; TURN OFF DIVIDE CHECK AND UNDERFLOW
BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
JRST PRIN1B
PRINL2: MOVEI R,TYO
JRST PRINL1
PRINL: XCT "#",CTY
HRRZ A,-1(P)
PRINL1: MOVEI C,8
JRST PRINI3
PRINI1: SKIPA A,(A)
PRINIC: SUBI A,INUM0
HRRZ C,VBASE(S)
SUBI C,INUM0
JUMPGE A,PRINI2
XCT "-",CTY
MOVNS A
PRINI2: MOVEI B,"."-"0"
HRLM B,(P)
CAIN C,TEN
SKIPE %NOPOINT(S)
JRST .+2
PUSH P,PRINI4
PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2^35
MOVEI A,1
DIVI A,(C)
JRST .+2]
IDIVI A,0(C)
HRLM B,(P)
SKIPE A
PUSHJ P,.-3
PRINI4: JRST FP7A1
PRINN: HLRZ A,(A)
MOVEI C,2(SP)
PUSHJ P,PNAMU3
PUSH C,[0]
HRLI C,(POINT 7,0,35)
HRRI C,2(SP)
ILDB A,C
JUMPE A,CPOPJ ;special case of null character
CAIN A,DBLQT
JRST PSTR ;string
PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
JUMPL R,PRIN4 ;never slash
JRST PRIN2(B) ;1 for no slash
PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
PRIN2: XCT "/",CTY
PRIN4: PUSHJ P,(R)
ILDB A,C
JUMPN A,@PRIN5#
POPJ P,
PSTR: MOVS B,(C)
CAIN B,(<ASCII /"/>)
JRST PRIN2X ;special case of /"
PSTR3: SKIPL R ;dont print " if no slashify
PSTR2: PUSHJ P,(R)
ILDB A,C
CAIE A,DBLQT
JUMPN A,PSTR2
JUMPN A,PSTR3
POPJ P,
TERPRI: PUSH P,A
MOVEI A,CR
PUSHJ P,TYO
MOVEI A,LF
PUSHJ P,TYO
JRST POPAJ
CTY: JSA A,TYOI
REMOTE<
TYOI: X
JRST TYOI2>
TYOI2: PUSH P,A
LDB A,[POINT 6,-1(A),ACFLD]
PUSHJ P,(R)
POP P,A
JRA A,(A)
PRINO: MOVE A,(A)
CLEARB 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
CLEARM FPTEM#
PUSHJ P,FP7
XCT ".",CTY
MOVNI T,8
ADD T,FPTEM
MOVE B,C
FP3A: MOVE A,B
MULI A,TEN
PUSHJ P,FP7B
SKIPE B
AOJL T,FP3A
POPJ P,
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
PUSH P,TT
MOVNI B,-2(B)
DPB B,[POINT 2,FP4C,34]
PUSHJ P,FP3
MOVEI A,"E"
PUSHJ P,(R)
MOVE A,FP4C#
IORI A,51
PUSHJ P,(R)
POP P,A
FP7: JUMPE A,FP7A1
IDIVI A,TEN
AOS FPTEM
HRLM B,(P)
JUMPE A,FP7A1
PUSHJ P,FP7
FP7A1: HLRE A,(P)
FP7B: ADDI A,"0"
JRST (R)
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
PAGE
SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69
;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
REMOTE<
IGSTRT: IGCRLF
IGEND: LF
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
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>
IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
XLIST
IRPC R50< RAD50 (R50)
BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
LIST>
DEFINE LET (X)<
TABIN (1,1,5,2,3,4,2,0,X)>
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)>
PAGE
REMOTE<CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >)
;null
LET (< >)
IGNORE (< >)
;tab,lf,vtab,ff,cr
LET (< >)
;16 to 30
TABIN (0,0,0,0,0,0,0,0,< >)
;igmrk
TABIN (0,0,0,0,0,0,0,0,< >)
;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
IFE ALTMOD-33 <
DELIMIT (< >,3)
> ;%% NEW ALTMODE (5S06 MONITOR)
IFN ALTMOD-33 <
LET (< >)
> ;%% OLD ALTMODE (5S04 OR EARLIER MONITOR)
LET (< >)
;## 34 TO 37
IGNORE (< >)
;space
LET (< >)
;!
TABIN (0,0,9,2,2,2,2,0,< >)
;"
LET (< $% >)
;#$%&'
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)
;*
TABIN (1,1,14,2,3,4,2,0,< >)
;+
IGNORE (< >)
;,
TABIN (1,1,6,2,3,4,2,0,< >)
;-
TABIN (0,0,7,3,3,2,2,4,<.>)
TABIN (0,0,4,2,3,3,2,0,< >)
;/
TABIN (1,0,8,5,3,4,3,0,<0123456789>)
LET (< >)
;:;<=>?
TABIN (1,0,2,2,3,4,2,5,< >)
;@
LET (<ABCD>)
TABIN (1,1,5,4,3,4,2,0,<E>)
LET (<FGHIJKLMNOPQRSTUVWXYZ>)
DELIMIT (< >,2)
;[
LET (< >)
;\
DELIMIT (< >,3)
;]
LET (< >)
;^_`
LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
;lower case
LET (< >)
;{|
IFE ALTMOD-175 <
DELIMIT (< >,3)
> ;%% OLD ALTMODE (5S04 MONITOR)
IFN ALTMOD-175 <
LET (< >)
> ;%% } - ORDINARY CHARACTER (5S06 MONITOR)
LET (< >)
;~
DELIMIT (< >,6)
;rubout
>
PAGE
READCH: PUSHJ P,TYI
MOVSI AR1,AR1
PUSHJ P,EXPL1
JRST CAR
READP1: SETZM NOINFG
READ0: PUSH P,TYI2
PUSH P,OLDCH
SETZM OLDCH#
HRLI A,(JRST)
MOVEM A,TYI2
PUSHJ P,READ+1
POP P,OLDCH
POP P,TYI2
POPJ P,
RDNAM: SETOM NOINFG ;## READ ROUTINE THAT DOES NOT INTERN
JRST READ+1 ;##
RDRUB: MOVEI A,CR
PUSHJ P,TTYO
MOVEI A,LF
PUSHJ P,TTYO
SKIPA P,PSAV#
READ: SETZM NOINFG# ;0 means intern
MOVEM P,PSAV
PUSHJ P,READ1
SETZM PSAV
POPJ P,
READ1: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST READ1 ;try again
RDTAB2: JRST READ2 ;0 (
JFCL ;1 )
JRST READ4 ;2 [
JFCL ;3 ],$
JFCL ;4 .
JRST RDQT ;5 @
READ2: PUSHJ P,RATOM
JRST READ2A ;atom
XCT RDTAB(B)
READ2A: PUSH P,A
PUSHJ P,READ2
POP P,B
JRST XCONS
RDTAB: PUSHJ P,READ2 ;0 (
JRST FALSE ;1 )
PUSHJ P,READ4 ;2 [
JRST READ5 ;3 ],$
JRST RDT ;4 .
PUSHJ P,RDQT ;5 @
RDTX: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST DOTERR ;dot context error
RDT: PUSHJ P,RDTX
PUSH P,A
PUSHJ P,RATOM
JRST DOTERR
CAIN B,1
JRST POPAJ
CAIE B,3
JRST DOTERR
MOVEM A,OLDCH
JRST POPAJ
READ4: PUSHJ P,READ2
MOVE B,OLDCH
CAIE B,ALTMOD
TYI1: SETZM OLDCH ;kill the ]
POPJ P,
READ5: MOVEM A,OLDCH ;save ] or $
JRST FALSE ;and return nil
RDQT: PUSHJ P,READ1
JRST QTIFY
PAGE
;atom parser
COMMENT: PUSHJ P,TYID
CAME A,IGEND
JRST COMMENT
POPJ P,
RATOM: SKIPE SMAC# ;$$ CHECK FOR A SPLICE MACRO LIST
JRST PSMAC ;$$ GET ITEM FROM SPLICE MACRO LIST
SETZB T,R
HRLI C,(POINT 7,0,35)
HRRI C,(SP)
MOVEM C,ORGSTK# ;SAVE FOR BACKING UP ON + AND -
MOVEI AR1,1
RATOM2: PUSHJ P,TYIA
LDB B,RATFLD
JRST RATAB(B)
RATAB: PUSHJ P,COMMENT ;0 comment
JRST RATOM2 ;1 null
JRST RATOM3 ;2 delimit
JRST RATOM2 ;3 ignore
PUSHJ P,TYI ;4 /
JRST RDID ;5 letter
JRST RDNMIN ;6 -
JRST RDOT ;7 .
JRST RDNUM ;8 digit
JRST RDSTR ;9 string
JRST RMACRO ;10 MACRO
JRST SMACRO ;11 SPLICE MACRO
JRST RDNPLS ;12 +
;a real dotted pair
RDOT2: MOVEM A,OLDCH
MOVE A,ORGSGN ;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
RATOM3: LDB B,RDFLD
HRRI R,DELCLS ;delimiter
AOS (P) ;non-atom (ie a delimiter)
POPJ P,
;dot handler
RDOT: MOVEM A,ORGSGN ;INCASE SOMETHING ELSE DEFINED AS "."
PUSHJ P,TYID
LDB B,DOTFLD
JRST DOTAB(B)
DOTAB: PUSHJ P,COMMENT ;0 comment
JRST RDOT+1 ;1 null
JRST RDOT2 ;2 delimit
JRST RDOT2 ;3 dot
JRST RDOT2 ;4 e
MOVEI B,0 ;5 digit
IDPB B,C
TLO T,SAWDOT
JRST RDNUM
PAGE
;string scanner
STRTAB: PUSHJ P,COMMENT ;0 comment
JRST RDSTR+1 ;1 null
JRST STR2 ;2 delimit
RDSTR: IDPB A,C ;3 string element
PUSHJ P,TYID
LDB B,STRFLD
JRST STRTAB(B)
STR2: MOVEI A,DBLQT
HRRI R,STRCLS ;string
IDPB A,C
NOINTR: PUSHJ P,IDEND ;no intern
PUSHJ P,IDSUB
JRST PNAMAK
;identifier scanner
IDTAB: PUSHJ P,COMMENT ;0
JRST RDID+1 ;1 null
JRST MAKID ;2 delimit
PUSHJ P,TYI ;3 /
RDID: IDPB A,C ;4 letter or digit
PUSHJ P,TYID
LDB B,IDFLD
JRST IDTAB(B)
PAGE
;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
;
LINRD: PUSHJ P,READ
HRRZ B,A
SKIPE SMAC ;CHECK THE SPLICE LIST
JRST LRMORE
SKIPN A,OLDCH
LRTY: PUSHJ P,TYID ;NEED A CHARACTER
MOVEM A,OLDCH ;SAVE IT
LDB C,RATFLD ;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
CAIN C,7 ;SPECIAL CHECK FOR "."
JRST LRTY1 ;IGNORE IT
CAILE C,3 ;ELIMINATE MOST POSSIBILITIES
JRST LRMORE ;MORE ON THE LINE
JUMPE C,LREND ;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
LDB C,RDFLD
JRST LR1(C)
LR1: JRST LPIG ;0 MORE TO FIGURE OUT
JRST LRTY1 ;1 IGNORE
JRST LRMORE ;2 MORE ON THE LINE
SUBI A,ALTMOD ;3 CHECK ALTMOD
JUMPN A,LRTY1 ;4 IGNORE "]" AND "."
JUMPN A,LRMORE ;5 MORE ON "@"
JRST LREND
LPIG: CAIN A,"(" ;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
JRST LRMORE
CAIE A,TAB
CAIL A,40 ;READ MORE IF SPACE, COMMA, OR TAB
JRST [ HRLI B,-1 ;SET SPQCE FLAG AND TRY AGAIN
JRST LRTY]
CAIE A,CR ;ALWAYS IGNORE CR.S
TLZE B,-1 ;EOL - IF SPACE FLAG THEN DO A PEEKC
JRST LRTY
LREND: HRRZ A,B ;FINALLY GOT THERE
JRST NCONS
LRMORE: HRLI B,0
PUSH P,B ;MORE TO GO, PUSH
PUSHJ P,LINRD ;AND CALL YOURSELF
POP P,B
JRST XCONS
LRTY1: HRLI B,0 ;CLEAR SPACE FLAG
JRST LRTY
PAGE
;## FUNCTIONS TO READ A FILE.EXT
;## READ A FILE.EXT FROM THE UFD
FLTYIA: XCT TYI2 ;## GET NEXT WORD, IGNORE OLDCH
JRST [SETZ AR1,
JRST TYI2X ] ;%% INPUT SOME MORE, CLEARING TEST REG.
ILDB A,@TYI3 ;## AND LOAD WORD
POPJ P,
RDFIL1: PUSHJ P,FLTYIA ;## FILE NAME NOT THERE, SKIP OVER EXT
RDFILE: SETZM NOINFG ;## ## INTERN
PUSHJ P,FLTYIA ;## GET FILE NAME WORD
PUSHJ P,SIXATM ;## MAKE IT AN ATOM
JUMPL A,RDFIL1 ;## A=-1 IF EMPTY
PUSH P,A
PUSHJ P,FLTYIA ;## GET EXTENSION
HRRI A,0 ;## CLEAR RH
PUSHJ P,SIXATM
JUMPL A,POPAJ ;## NO EXTENSION, RETURN
POP P,B ;## GET FILE BACK
JRST XCONS ;## RETURN FILE.EXT
;## ROUTINE TO TAKE ONE WORD OF SIXBIT AND MAKE IT AN ATOM
;## IGNORES TRAILING BLANKS, BUT INCLUDES INSERTED BLANKS. NO
;## READ MACROS, ETC.
SIXATM: SKIPN B,A
JRST SXATER ;## INDICATE WORD EMPTY
MOVEI T,5 ;## OF CHS PERMISSIBLE IN FULL WORD
;## NAME T=0 IF FIRST WORD DONE
MOVE AR1,[POINT 6,B,5] ;## AR1 HAS PTR TO LOAD BYTE
;## FROM B TO C
PUSHJ P,SIXAT1 ;## MAKE THE PNAME LIST
PUSHJ P,NCONS
MOVEI B,PNAME(S) ;## MAKE PNAME
PUSHJ P,XCONS
PUSHJ P,ACONS ;## VOILA, AN ATOM
SKIPE NOINFG ;## NOINFG=0 MEANS INTERN
POPJ P,
JRST INTERN
SXATER: SETO A, ;## RETURN -1 IN A IF B EMPTY
POPJ P,
SIXAT1: MOVE AR2A,[POINT 7,0,35] ;## POINTER TO MOVE C TO A
SETZ A, ;## CLEAR A
SIXAT2: SETZ C,
JUMPE B,SIXDON ;## DONE IF B EMPTY
LDB C,AR1
LSH B,6 ;## LEFT SHIFT B, REMAINING CH'S IN B
HRRI C,40(C) ;## ADD 40 TO C
IDPB C,AR2A ;## PUT IT IN A
SOJG T,SIXAT2 ;## IF T>0, STILL IN FIRST WORD OF PNAME
SIXAT3: PUSHJ P,FWCONS
PUSH P,A
JRST SIXAT1 ;## TRY FOR THAT SIXTH CH.
SIXDON: JUMPN A,SIXAT3 ;## IF A NOT EMTPY, DO ANOTHER FWCONS AND
;## END UP HERE WITH A=0.
POP P,A
PUSHJ P,NCONS
JUMPGE T,CPOPJ ;## IF T>=0, THEN ONLY ONE WORD
POP P,B
JRST XCONS ;## DONE
PAGE
;NEW AND SUPER BITCHEN READ MACROS
;
RMACRO:
IFN ALVINE,<
SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
JRST RATOM2 ;$$ YES, IGNORE>
RMAC2: IDPB A,C ;$$ CONVERT THE CHAR. TO AN ATOM
PUSHJ P,IDEND ;$$
PUSHJ P,INTER0 ;$$
MOVEM A,T ;$$ SAVE ATOM IN CASE OF ERROR
MOVEI B,READMACRO(S) ;$$ GET THE FUNCTION NAME
PUSHJ P,GET ;$$
JUMPE A,RMERR ;$$ UNDEFINED READ MACRO
PUSHJ P,NCONS ;$$ CONVERT TO A FORM
PUSH P,PSAV ;$$
PUSHJ P,EVAL ;$$ EVALUATE THE FORM
POP P,PSAV ;$$
POPJ P, ;$$ RETURN
;SPECIAL PROCESSING OF SPLICE MACROS
SMACRO:
IFN ALVINE,<
SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
JRST RATOM2 ;$$ YES, IGNORE>
PUSHJ P,RMAC2 ;$$ EVALUATE THE MACRO
MOVEM A,SMAC ;$$ SAVE THE SPLICE LIST
JRST RATOM ;$$ START OVER
;GET AN ITEM OFF OF THE SPLICE LIST
PSMAC: MOVE A,SMAC ;$$
PUSHJ P,ATOM ;$$ IS SPLICE LIST AN ATOM?
JUMPN A,[ MOVE A,SMAC ;$$ YES, SIMULATE . <ATOM>
PUSHJ P,NCONS ;$$
MOVEM A,SMAC ;$$
MOVEI B,4 ;$$
JRST RATOM3+1] ;$$
MOVE B,@SMAC ;$$
HLRZ A,B ;$$ RETURN NEXT ITEM OF SPLICE LIST
HRRZM B,SMAC ;$$ ADVANCE SPLICE LIST
POPJ P, ;$$ RETURN
PAGE
;number scanner
NUMTAB: PUSHJ P,COMMENT ;0 comment
JRST RDNUM+1 ;1 null
JRST NUMAK ;2 delimit
JRST RDNDOT ;3 dot
JRST RDE ;4 e
RDNUM: IDPB A,C ;5 digit
PUSHJ P,TYID
LDB B,NUMFLD
JRST NUMTAB(B)
RDNDOT: TLOE T,SAWDOT
JRST NUMAK ;two dots - delimit
MOVEI A,0
JRST RDNUM
RDNMIN: TLO T,MINSGN
RDNPLS: MOVEM A,ORGSGN# ;SAVE SIGN IN CASE OF BACKUP
JRST RDNUM+1
;exponent scanner
RDE: CAME C,ORGSTK ;FOR +E AND -E TYPE OF ATOMS
JRST .+3
MOVEM A,OLDCH
JRST KLDG1
TLO T,EXP
MOVEI A,0
IDPB A,C
PUSHJ P,TYID
CAIN A,"-"
TLOA T,NEXP
CAIN A,"+"
JRST RDE2+1
JRST RDE2+2
EXPTAB: PUSHJ P,COMMENT ;0
JRST RDE2+1 ;1 null
JRST NUMAK ;2 delimit
RDE2: IDPB A,C ;3 digit
PUSHJ P,TYID
LDB B,EXPFLD
JRST EXPTAB(B)
PAGE
;semantic routines
;identifier interner and builder
IDEND: TDZA A,A
IDEND1: IDPB A,C
TLNE C,760000
JRST IDEND1
POPJ P,
MAKID: MOVEM A,OLDCH
PUSHJ P,IDEND
SKIPE NOINFG
JRST NOINTR ;dont intern it
INTER0: PUSHJ P,IDSUB
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found
PUSHJ P,PNAMAK ;not there
MAKID2: MOVE C,CURBUC# ;
HLRZ B,@RHX2
PUSHJ P,CONS ;cons it into the oblist
HRLM A,@RHX2
JRST CAR
;pname unmaker
PNAMUK:
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,NOPNAM
MOVE C,SP
PNAMU3: HLRZ B,(A)
PUSH C,(B)
HRRZ A,(A)
JUMPN A,PNAMU3
POPJ P,
;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)
HRLI C,1(SP)
MOVSM C,IDPTR#
POPJ P,
PAGE
;identifier interner
INTER1: MOVE B,1(SP) ;get first word of pname
LSH B,-1 ;right justify it
IDIV B,INT1 ;compute hash code
REMOTE<
INT1: BCKETS
RHX2:
XXX1: XWD B+1,OBTBL>
PUSH P,C ;## SAVE C
HRRZ C,VOBLIST(S) ;## THIS GETS THE CURRENT VALUE OF OBLIST(THE ATOM)
HRRM C,RHX2 ;## ASSUMES THAT ALL REFERENCE TO OBLIST GOES
HRRM C,RHX5 ;## IE INTERN, REMOB ETC GOES THROUGH THIS SECTION.
POP P,C ;##RHX2 AND RHX5 ARE HOPEFULLY THE ONLY TWO WORDS
;##WHICH ARE USED TO REFERENCE TABLE 3/28/73
HLRZ TT,@RHX2 ;get bucket
MOVEM B+1,CURBUC ;save bucket number
MOVE T,TT
JRST MAKID1
MAKID3: MOVE TT,T ;save previous atom
HRRZ T,(T) ;get next atom
MAKID1: JUMPE T,CPOPJ1 ;not in oblist
HLRZ A,(T) ;next id in oblist
MAKID4: MOVEI B,PNAME(S) ;## USE GET FOR GETTING PNAME
PUSHJ P,GET ;## (GET ATOM @PNAME)
JUMPE A,NOPNAM ;## NO PRINT NAME
MOVE C,IDPTR ;found pname
MAKID5: JUMPE A,MAKID3 ;not the one
MOVS A,(A)
MOVE B,(A)
ANDCAM AR1,(C) ;clear low bit
CAME B,(C)
JRST MAKID3 ;not the one
HLRZ A,A ;ok so far
AOBJN C,MAKID5
JUMPN A,MAKID3 ;not the one
HLRZ A,(T) ;this is it
HLRZ B,(TT)
HRLM A,(TT)
HRLM B,(T)
POPJ P,
PAGE
;pname builder
PNAMAK: MOVE T,IDPTR
PUSHJ P,NCONS
MOVE TT,A
MOVE C,A
PNAMB: MOVE A,(T)
TRZ A,1 ;clear low bit!!!!!
PUSHJ P,FWCONS
PUSHJ P,NCONS
HRRM A,(TT)
MOVE TT,A
AOBJN T,PNAMB
MOVE A,C
HRLZS (A)
JRST PNGNK1+1
PAGE
;number builder
NUMAK: MOVEM A,OLDCH
HRRI R,NUMCLS ;number
CAME C,ORGSTK ;BIG KLUDGE FOR + AND -
JRST .+5
KLDG1: MOVE A,ORGSGN ;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
IDPB A,C
PUSHJ P,TYIA
JRST RDID+2
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
MOVE A,VIBASE(S) ;ibase integrer
SUBI A,INUM0
PUSHJ P,NUM
NUMAK4:
MOVEI B,FIXNUM(S)
NUMAK6: TLNE T,MINSGN
MOVNS A
JRST MAKNUM
NUMAK2: PUSHJ P,NUM10
MOVEM A,TT
TLNN T,SAWDOT
JRST [ PUSHJ P,FLOAT ;flt pt without fraction
MOVE TT,A
JRST NUMAK3]
PUSHJ P,NUM10 ;fraction part
EXCH A,TT
TLNN T,EXP
JUMPE AR2A,NUMAK4 ;no exponent and no fraction
PUSHJ P,FLOAT
EXCH A,TT
PUSHJ P,FLOAT
MOVEI AR1,FT01
PUSHJ P,FLOSUB
FMPR A,B
FADRM A,TT
NUMAK3: PUSHJ P,NUM10 ;exponent part
MOVE AR2A,A
MOVEI AR1,FT-1
TLNE T,NEXP
MOVEI AR1,FT01 ;-exponent
PUSHJ P,FLOSUB
FMPR TT,B ;positive exponent
MOVEI B,FLONUM(S)
MOVE A,TT
JFCL 10,FLOOV
JRST NUMAK6
FLOSUB: MOVSI B,(1.0)
TRZE AR2A,1
FMPR B,(AR1)
JUMPE AR2A,CPOPJ
LSH AR2A,-1
SOJA AR1,FLOSUB+1
;variable radix integer builder
NUM10: MOVEI A,TEN
NUM: HRRM A,NUM1
JFCL 10,.+1 ;clear carry0 flag
SETZB A,AR2A
NUM2: ILDB B,C
JUMPE B,CPOPJ ;done
IMUL A,NUM1#
ADDI A,-"0"(B)
NUM3: JFCL 10,FIXOV ;bignums change this to jfcl 10,rdbnm
AOJA AR2A,NUM2
PAGE
INTERN: MOVEM A,AR2A
PUSHJ P,PNAMUK
PUSHJ P,IDSUB
MOVEI AR1,1
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found it
MOVE A,AR2A ;not there
JRST MAKID2 ;put it there
REMOB: JUMPE A,FALSE
MOVEI AR1,1
PUSH P,A
HLRZ A,(A)
PUSHJ P,INTERN
HLRZ B,@(P)
CAME A,B
JRST REMOB2
HRRZ B,CURBUC
REMOTE<
RHX5:
XXX2: XWD B,OBTBL>
HLRZ C,@RHX5
HLRZ T,(C)
CAMN T,A
JRST [ HRRZ TT,(C)
HRLM TT,@RHX5
JRST REMOB2]
REMOB3: MOVE TT,C
HRRZ C,(C)
HLRZ T,(C)
CAME T,A
JRST REMOB3
HRRZ T,(C)
HRRM T,(TT)
REMOB2: POP P,A
HRRZ A,(A)
JRST REMOB
PAGE
;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
;READ CHARACTER-TABLE BY LISP FUNCTIONS
;TAKES TWO ARGUMENTS A,B
; IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
; LOCATION SPECIFIED BY A
; OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
; TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
; PREVIOUS VALUE
MODCHR: PUSH P,B ;$$SAVE BIT PATTERN FOR TABLE
PUSHJ P,NUMVAL ;$$GET POSITION IN TABLE
POP P,B ;$$
MOVE T,CHRTAB(A) ;$$GET OLD TABLE VALUE
JUMPE B,MCEXIT ;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
PUSH P,A ;$$SAVE TABLE POSITION
MOVEI A,(B) ;$$
PUSHJ P,NUMVAL ;$$GET NEW BIT PATTERN
POP P,B ;$$GET TABLE POSITION
MOVEM A,CHRTAB(B) ;$$CHANGE TABLE
MCEXIT: MOVE A,T ;$$RETURN OLD TABLE VALUE
JRST FIX1A ;$$CONVERT TO BINARY AND EXIT
;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
; CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
; CHARACTER OF THE PRINT NAME
CHRVAL: MOVEI B,PNAME(S) ;$$ GET PRINT NAME
PUSHJ P,GET ;$$
HLRZ A,(A) ;$$
MOVE A,(A) ;$$ FIRST WORD OF PRINT NAME
LSH A,-35 ;$$ SHIFT TO GET FIRST CHARACTER
JRST FIX1A ;$$ CONVERT TO INTEGER
;FUNCTION TO SET BITS FOR A READ MACRO
; A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
; IF B=NIL NO MODIFICATION IS MADE
; THE OLD STATUS BITS ARE RETURNED
SETCHR: MOVE TT,B ;$$
PUSHJ P,CHRVAL ;$$ CONVERT CHAR. TO INUM
MOVEI B,-INUM0(A) ;$$ CONVERT INUM TO BINARY
LDB A,[POINT 5,CHRTAB(B),5] ;$$ LOAD OLD BITS
JUMPE TT,FIX1A ;$$ NO CHANGE IF B = NIL
MOVEI TT,-INUM0(TT) ;$$ CONVERT STATUS TO BINARY
DPB TT,[POINT 5,CHRTAB(B),5] ;$$ SET NEW BITS
JRST FIX1A ;$$ RETURN
PAGE
SUBTTL LISP INTERPRETER SUBROUTINES
CADDDR: SKIPA A,(A)
CADDAR: HLRZ A,(A)
CADDR: SKIPA A,(A)
CADAR: HLRZ A,(A)
CADR: SKIPA A,(A)
CAAR: HLRZ A,(A)
CAR: HLRZ A,(A)
POPJ P,
CDDDDR: SKIPA A,(A)
CDDDAR: HLRZ A,(A)
CDDDR: SKIPA A,(A)
CDDAR: HLRZ A,(A)
CDDR: SKIPA A,(A)
CDAR: HLRZ A,(A)
CDR: HRRZ A,(A)
POPJ P,
CAADDR: SKIPA A,(A)
CAADAR: HLRZ A,(A)
CAADR: SKIPA A,(A)
CAAAR: HLRZ A,(A)
JRST CAAR
CDADDR: SKIPA A,(A)
CDADAR: HLRZ A,(A)
CDADR: SKIPA A,(A)
CDAAR: HLRZ A,(A)
JRST CDAR
CAAADR: SKIPA A,(A)
CAAAAR: HLRZ A,(A)
JRST CAAAR
CDDADR: SKIPA A,(A)
CDDAAR: HLRZ A,(A)
JRST CDDAR
CDAADR: SKIPA A,(A)
CDAAAR: HLRZ A,(A)
JRST CDAAR
CADADR: SKIPA A,(A)
CADAAR: HLRZ A,(A)
JRST CADAR
PAGE
QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
POPJ P,
AASCII: PUSHJ P,NUMVAL
LSH A,^D29
PUSHJ P,FWCONS
PUSHJ P,NCONS
PNGNK1: PUSHJ P,NCONS
MOVEI B,PNAME(S)
PUSHJ P,XCONS
ACONS: TROA B,-1
NCONS: TRZA B,-1
XCONS: EXCH B,A
CONS: AOS CONSVAL
HRL B,A
SKIPN A,F
JRST [ HLR A,B
PUSHJ P,AGC
JRST .-1]
MOVE F,(F)
MOVEM B,(A)
POPJ P,
;new consing routines-not finished yet
;acons: troa b,-1
;ncons: trz b,-1
;cons: exch b,a
;xcons: hrl a,b
; exch a,(f)
; exch a,f
; popj p,
CONSP: JUMPE A,CPOPJ ;## DONE IF NIL
CAILE A,INUMIN
JRST FALSE
HLLE B,(A)
AOJE B,FALSE
IFN NONUSE <JRST TRUE> ;## T IF NONUSEFUL DESIRED
IFE NONUSE <POPJ P,> ;## THE CELL OTHERWISE
PATOM: CAIL A,@GCP1
JRST TRUE
CAIL A,@GCPP1
ATOM: CAILE A,INUMIN
JRST TRUE
JUMPE A,TRUE ;## FAST CHECK FOR NIL
CAIGE A,@GCP1 ;## LO-END OF FWS, CAN'T ADD TO 0
HLLE A,(A)
AOJE A,TRUE
JRST FALSE
PAGE
NEQ: CAMN A,B
JRST FALSE
JRST TRUE
EQ: CAMN A,B
JRST TRUE
JRST FALSE
LENGTH: MOVEI B,0
LNGTH1: CAIE A,NIL ;## DONE IF NIL
CAIL A,@FWSO ;## FWSO IS FULL SPACE ORIGIN,
;## ELIMINATE ILL MEM REF
JRST FIX1
HLLE C,(A)
AOJE C,FIX1
HRRZ A,(A)
AOJA B,LNGTH1
LAST: HRRZ B,(A)
CAIE B,NIL ;## IF NIL DONE
CAIL B,@FWSO ;## ANOTHER POTENTIAL ILL MEM GONE
POPJ P,
HLLE B,(B)
AOJE B,CPOPJ
HRRZ A,(A)
JRST LAST
;(LITATOM X) = (AND (ATOM X) (NOT (NUMBERP X)))
LITATOM:MOVE B,A
PUSHJ P,ATOM
JUMPE A,CPOPJ
MOVE A,B
PUSHJ P,NUMBERP
JRST NOT
PAGE
;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO CLOBBER NIL AND ATOMS
RPLACA: CAIE A,NIL ;## TEST FOR NIL
CAILE A,INUMIN ;$$
JRST RPAERR ;$$ ATTEMPT TO RPLACA A SMALL NUMBER
HLL A,(A) ;$$TEST FOR OTHER ATOMS
TLC A,-1 ;$$
TLZN A,-1 ;$$ATOM CARS ARE -1
JRST RPAERR ;$$ATTEMPT TO RPLACA AN ATOM
HRLM B,(A) ;$$STANDARD CODE FOR RPLACA
POPJ P, ;$$
RPLACD: CAIG A,INUMIN ;$$CHECK FOR SMALL BER
JUMPN A,.+2 ;$$CHECK FOR NIL
JRST RPDERR ;$$ATTEMPT TO RPLACD NIL OR A SMALL NUMBER
HRRM B,(A) ;$$OLD RPLACD CODE
POPJ P, ;$$
ZEROP: PUSHJ P,NUMVAL
NOT:
NULL: JUMPN A,FALSE
TRUE:
MOVEI A,TRUTH(S)
POPJ P,
FW0CNS: MOVEI A,0
FWCONS: JUMPN FF,FWC1
EXCH A,FWC0#
PUSHJ P,AGC
EXCH A,FWC0
FWC1: EXCH A,(FF)
EXCH A,FF
POPJ P,
PAGE
SASSOC: PUSHJ P,SAS1
JCALLF 0,(C)
POPJ P,
SAS0: HLRZ B,T
SAS1: JUMPE B,CPOPJ
MOVS T,(B)
MOVS TT,(T)
CAIE A,(TT)
JRST SAS0
HRRZ A,T
CPOPJ1: AOS (P)
POPJ P,
ASSOC: PUSHJ P,SAS1
FALSE: MOVEI A,NIL
CPOPJ: POPJ P,
REVERSE: MOVE T,A
MOVEI A,0
JUMPE T,CPOPJ
HLRZ B,(T)
HRRZ T,(T)
PUSHJ P,XCONS
JUMPN T,.-3
POPJ P,
REMPROP: HRRZ T,(A)
MOVS TT,(T)
CAIN B,(TT)
JRA TT,REMP1
HLRZ A,TT
HRRZ T,(A)
JUMPN T,REMPROP+1
JRST FALSE
REMP1: HRRM TT,(A)
JRST TRUE
PAGE
;## IF WE ARE USING NEW NIL, THEN GET IS FOR SYSTEM ONLY AND
;## USRGET IS THE USERS. IF NEW NIL, THEN GET MUST GET NIL'S
;## PROPERTY LIST
IFE OLDNIL<
USRGET: JUMPE A,CPOPJ ;## ALWAYS NIL>
GET:
IFE OLDNIL< CAIE A,NIL
SKIPA A,NILPRP>
HRRZ A,(A)
GET1: MOVS D,(A)
CAIN B,(D)
JRST CADR
HLRZ A,D
HRRZ A,(A)
JUMPN A,GET1
POPJ P,
GETL: JUMPE B,FALSE ;$$ NIL LIST - NIL ANSWER
IFE OLDNIL <JUMPE A,CPOPJ> ;## TEST FOR NIL
HRRZ A,(A)
GETL0: HLRZ T,(A)
MOVE C,B
GETL1: MOVS TT,(C)
CAIN T,(TT)
POPJ P,
HLRZ C,TT
JUMPN C,GETL1
HRRZ A,(A)
HRRZ A,(A)
JUMPN A,GETL0
POPJ P,
NUMBERP: CAILE A,INUMIN
JRST TRUE
HLLE T,(A)
AOJN T,FALSE
HRRZ A,(A)
HLRZ A,(A)
CAIE A,FIXNUM(S)
CAIN A,FLONUM(S)
JRST TRUE
NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
STRINGP: MOVE B,A ;= T IF A IS A STRING
PUSHJ P,ATOM
JUMPE A,CPOPJ
MOVE A,B
PUSHJ P,NUMBERP ;MUST NO BE A NUMBER
JUMPN A,FALSE
MOVE A,B
PUSHJ P,CHRVAL ;GET THE FIRST CHARACTER
CAIE A,42+INUM0 ;CHECK FOR "
JRST FALSE
JRST TRUE
PAGE
PUTPROP:
IFN OLDNIL <MOVE T,A>
IFE OLDNIL <SKIPN T,A ;## CAN'T PUTPROP TO NIL
ERR1 [SIXBIT /CAN'T PUT PROP ON NIL !/]>
HRRZ A,(A)
CSET3: MOVS TT,(A)
HLRZ A,TT
CAIN C,(TT)
JRST CSET2
HRRZ A,(A)
JUMPN A,CSET3
HRRZ A,(T)
PUSHJ P,XCONS
HRRZ B,C
PUSHJ P,XCONS
HRRM A,(T)
JRST CADR
CSET2:
CAIE C,VALUE(S)
JRST CSET1
HRRZ T,(B)
HLRZ A,(A)
HRRM T,(A)
JRST PROG2
CSET1: HRLM B,(A)
PROG2: MOVE A,B
PROG1: POPJ P,
DEFPROP:
HRRZ B,(A)
HRRZ C,(B)
HLRZ A,(A)
HLRZ B,(B)
HLRZ C,(C)
PUSH P,A
PUSHJ P,PUTPROP
JRST POPAJ
PAGE
EQUAL: MOVE C,P
EQUAL1: CAMN A,B
JRST TRUE
MOVE T,A
MOVE TT,B
PUSHJ P,ATOM
EXCH A,B
PUSHJ P,ATOM
CAMN A,B
JRST EQUAL3
EQUAL4: MOVE P,C
JRST FALSE
EQUAL3: JUMPN A,EQ2
PUSH P,T
PUSH P,TT
HLRZ A,(T)
HLRZ B,(TT)
PUSHJ P,EQUAL1
JUMPE A,EQUAL4
POP P,B
POP P,A
HRRZ A,(A)
HRRZ B,(B)
JRST EQUAL1
EQ2: PUSH P,T
MOVE A,T
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,TT
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,(P)
MOVEM C,(P)
MOVE B,TT
JSP C,OP
JUMPL COMP3
JUMPL COMP3
COMP3: POP P,C
CAME A,TT
JRST EQUAL4
JRST TRUE
PAGE
COMMENT ?
;## OLD SUBST AND COPY CODE THAT DID NOT WORK AS IT WAS
;## NOT PROTECTED FROM THE GARBAGE COLLECTOR. NASTY, NASTY.
;## REPLACED BY COMPILED LISP CODE
SUBS5: HRRZ A,SUBAS
POPJ P,
SUBST: MOVEM A,SUBAS#
MOVEM B,SUBBS#
SUBS0A: MOVE A,SUBAS
MOVE B,SUBBS
PUSH P,C
MOVE A,C
PUSHJ P,EQUAL
POP P,C
JUMPN A,SUBS5
CAIE C,NIL ;## TEST FOR NIL
CAILE C,INUMIN
JRST EV6A
HLLE T,(C)
AOJN T,SUBS2
EV6A: MOVE A,C
POPJ P,
SUBS2: PUSH P,C
HLRZ C,(C)
PUSHJ P,SUBS0A
EXCH A,(P)
HRRZ C,(A)
PUSHJ P,SUBS0A
POP P,B
JRST XCONS
COPY: MOVEI B,INUM0 ;$$ (SUBST 0 0 A)
MOVEI C,INUM0
EXCH A,C
JRST SUBST
?
; NTHCHAR = THE BTH CHARACTER OF A.
NTHCHAR:MOVE T,B
SUBI T,INUM0
JUMPE T,FALSE ;FAIL IF = 0
PUSH P,A
MOVEM T,ORGSGN
JUMPG T,NTH3
PUSHJ P,%FLATSIZEC
MOVEI T,1-INUM0(A)
ADDB T,ORGSGN
NTH3: MOVE A,(P)
PUSHJ P,LITATOM
JUMPN A,NTH4
POP P,A
HRROI R,NTH5 ;I HOPE THIS IS RIGHT
PUSHJ P,PRINTA
HLRZ A,ORGSGN
JRST NTH6
NTH5: SOSN ORGSGN
HRLOM A,ORGSGN
POPJ P,
NTH4: MOVE T,ORGSGN
POP P,A
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,CPOPJ ;FAIL IF NO PRINT NAME
NTH1: CAIG T,5
JRST NTH2
HRRZ A,(A)
JUMPE A,FALSE ;FAIL IF NO NTH CHARACTER
SUBI T,5
JRST NTH1
NTH2: HLRZ A,(A)
IMULI T,-7
LSH T,14
ADDI T,440700
HRL A,T
LDB A,A
JUMPE A,FALSE
NTH6: PUSHJ P,AASCII+1 ;CONVERT TO AN ATOM
JRST INTERN ;INTERN IT
PAGE
NCONC: TDZA R,R
APPEND: MOVEI R,.APPEND-.NCONC
JUMPE T,FALSE
POP P,B
APP2: AOJE T,PROG2
POP P,A
PUSHJ P,.NCONC(R)
MOVE B,A
JRST APP2
.NCONC: JUMPE A,PROG2
MOVE TT,A
MOVE C,TT
HRRZ TT,(C)
JUMPN TT,.-2
HRRM B,(C)
POPJ P,
.APPEND: JUMPE A,PROG2
MOVEI C,AR1
MOVE TT,A
APP1: HLRZ A,(TT)
PUSH P,B
PUSHJ P,CONS ;saves b
POP P,B
HRRM A,(C)
MOVE C,A
HRRZ TT,(TT)
JUMPN TT,APP1
JRST SUBS4
PAGE
IFN NONUSE<MEMBER:
>
MEMB0: MOVEM A,SUBAS#
MEMB1: JUMPE B,FALSE
MOVEM B,SUBBS#
MOVE A,SUBAS
HLRZ B,(B)
PUSHJ P,EQUAL
JUMPN A,CPOPJ
MOVE B,SUBBS
HRRZ B,(B)
JRST MEMB1
IFE NONUSE<MEMQ:
>
MEMB: EXCH A,B ;## NEW MEMQ THAT RETURN TAIL
JUMPE A,FALSE
MOVS C,(A)
CAIN B,(C)
POPJ P,
HLRZ A,C
CAMGE A,FWSO ;##THIS WILL ELIMINATE MOST (MAYBE ALL)
;## ILLEGAL MEM REFS FROM MEMQ
;##AND ASSOCIATED ROUTINES. FWSO IS FWS ORIGIN
JUMPN A,MEMQ+1
POPJ P,
;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
; THE ELEMENT IS FOUND
IFE NONUSE<MEMBER:
>
MEMBR.: PUSHJ P,MEMB0
SKIPE A
MOVE A,SUBBS
POPJ P,
IFN NONUSE<
MEMQ: PUSHJ P,MEMB
SKIPE A
JRST TRUE
POPJ P,
;AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
; THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
AND.: PUSHJ P,AND
SKIPA
OR.: PUSHJ P,OR
HRRZ A,2(P)
POPJ P,
>
AND:
HRLI A,TRUTH(S)
OR: HLRZ C,A
PUSH P,C
ANDOR: HRRZ C,A
JUMPE C,AOEND
MOVSI C,(SKIPE (P))
TLNE A,-1
MOVSI C,(SKIPN (P))
XCT C
JRST AOEND
MOVEM A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
EXCH A,(P)
HRR A,(A)
JRST ANDOR
AOEND: POP P,A
IFN NONUSE <
SKIPE A
MOVEI A,TRUTH(S)
>
POPJ P,
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
PUSHJ P,FWCONS
PUSHJ P,NCONS
JRST PNGNK1
REMOTE<
GNUM: ASCII /G0000/>
CSYM: HLRZ A,(A)
PUSH P,A
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,NOPNAM
HLRZ A,(A)
MOVE A,(A)
MOVEM A,GNUM
JRST POPAJ
PAGE
LIST: MOVEI B,CEVAL(S)
PUSH P,B
PUSH P,A
MOVNI T,2
JRST MAPCAR
EELS: HLRZ TT,(T) ;interpret lsubr call
HRRZ A,(AR1)
ILIST: MOVEI T,0
JUMPE A,ILIST2
ILIST1: PUSH P,A
HLRZ A,(A)
PUSH P,TT
HRLM T,(P)
PUSH P,SP ;$$SAVE SP POINTER TO RESTORE AFTER ARGUMENT EVALUATED
PUSHJ P,EVAL ;EVALUATE ARGUMENT
POP P,SP ;$$RESTORE SP POINTER AFTER EVAL
ILIST3: POP P,TT
HLRE T,TT
EXCH A,(P)
HRRZ A,(A)
SOS T
JUMPN A,ILIST1
ILIST2: JRST (TT)
;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
.MAPC: PUSH P,A
JUMPE B,PRETB
HLRZ A,(B)
HRRZ B,(B)
PUSH P,B
CALLF 1,@-1(P)
POP P,B
JRST .MAPC+1
;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
.MAP: PUSH P,A
JUMPE B,PRETB
MOVE A,B
HRRZ B,(B)
PUSH P,B
CALLF 1,@-1(P)
POP P,B
JRST .MAP+1
PRETB: SUB P,[XWD 1,1]
JRST PROG2
PAGE
; NEW AND SUPER POWERFUL MAP FUNCTIONS
MAPCON: TLZ T,100000
JRST MAPLIST
MAPCAN: TLZA T,100000
MAPC: TLZA T,400000
MAPCAR: TLZA T,400000
MAP: TLZ T,200000
; INITIALIZE
MAPLIST:SETCA T,T
MOVEI A,(CALLF)
DPB T,[POINT 4,A,30]
MOVE B,P
MOVE AR1,T
HRL AR1,T
SUB B,AR1
PUSH P,B
HRLM A,(B)
PUSH P,T
PUSH P,
HRLZM P,(P)
; SET UP TO GET ARGUMENTS
MAPL2: HRRZ T,-1(P)
MOVEI TT,-3(P)
; MOVE ARGS TO REGS
MPL3: MOVE D,(TT)
JUMPE D,MPDN
MOVEM D,(T)
MOVE D,(D)
SKIPGE -1(P)
HLRZM D,(T)
HRRZM D,(TT)
SUBI TT,1
SOJG T,MPL3
XCT (TT) ; CALL THE FUNCTION
LDB C,[POINT 2,-1(P),2]
TRNE C,2
JRST MAPL2
; ATTACH TO OUTPUT LIST
SKIPN C
PUSHJ P,NCONS
JUMPE A,MAPL2
HLR B,(P)
HRRM A,(B)
SKIPE C
PUSHJ P,LAST
HRLM A,(P)
JRST MAPL2
; POP STACK AND RETURN
MPDN: POP P,AR1
MOVE P,-1(P)
POP P,B
SUBS4: HRRZ A,AR1
POPJ P,
;PA3: 0 ;THE REG. PDL POINTER
;PA4: 0 ;Lh=pntr to prog less bound var list
;RH=NEXT PROG STATEMENT
PROG: PUSH P,PA3#
PUSH P,PA4#
HLRZ TT,(A) ;## TT HAS VARIABLE LIST
HRRZ A,(A) ;## A HAS PROG BODY
HRRM A,PA4
HRLM A,PA4
MOVE T,SP ;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
SUB T,[XWD 2,2] ;$$SO PA3,PA4 CAN BE RESTORED
MOVEM T,SPSV# ;$$BY UNBIND
JRST PG7B ;$$GO CHECK IF ANY VARIABLES TO BIND
PG7A: HLRZ A,(TT)
MOVEI AR1,0
PUSHJ P,BIND
HRRZ TT,(TT)
PG7B: JUMPN TT,PG7A
PUSH SP,SPSV
MOVEM P,PA3
PG1: HRRZ T,PA4
JUMPE T,PG4 ;## IF END OF PROG, QUITE
HLRZ A,(T) ;## A HAS FIRST STATEMENT
HRRZ T,(T) ;## T KEEPS THE REST
CAIE A,NIL ;## TEST FOR NIL
CAILE A,INUMIN ;## ALLOW INUMS FOR PROG LABELS 3/28/73
JRST PG1+1 ;## NOW WE CAN SKIP OVER THIS TYPE OF ATOM
HLLE B,(A) ;## IS IT A ATOM?
AOJE B,PG1+1 ;## JA, SO JUMP
HRRM T,PA4 ;## SAVE REST OF BODY
PUSH P,SP ;$$SAVE SPDL TO RESTORE AFTER EVAL
PUSHJ P,EVAL ;## EVAL THE STATEMENT
POP P,SP ;$$RESTORE SPDL AFTER EVAL
JRST PG1
PGO: SKIPN PA3 ;## ERROR IF NO PROG
JRST EG2
MOVE P,PA3 ;## BACK UP ON RPDL
MOVE B,1(P) ;## GET FORM
PUSHJ P,UBD
HRLZI C,(POPJ P,) ;## NEW CODE TO ALLOW BREAKING
;## AND TRACING OF GO
PUSHJ P,DOSET ;##
HLRZ T,PA4
PG5: JUMPE T,EG1 ;## ERROR IF NO TAG FOUND
HLRZ TT,(T) ;## GET THE CAR
HRRZ T,(T) ;## SAVE UP THE REST OF THE BODY
CAIN TT,(A)
JRST PG1+1 ;FOUND TAG
JRST PG5 ;## TRY AGAIN
RETURN: SKIPN PA3
JRST EG3
MOVE P,PA3
MOVE B,1(P)
PUSHJ P,UBD
HRLZI C,(POPJ P,) ;## NEW CODE TO ALLOW BREAKING
;## AND TRACING OF RETURN
PUSHJ P,DOSET ;##
JRST PG4+1
PG4: SETZ A,
PUSHJ P,UNBIND
ERRP4: POP P,PA4
POP P,PA3
POPJ P,
GO: HLRZ A,(A)
CAIE A,NIL ;## TEST FOR NIL
CAILE A,INUMIN ;## IS IT AN INUM?(NOW VALID)
JRST PGO ;## SEE IF IT IS THE ONE
HLLE B,(A) ;## IS IT AN ATOM
AOJE B,PGO
PUSHJ P,EVAL
JRST GO+1
SETQ: HLRZ B,(A)
PUSH P,B
PUSHJ P,CADR
PUSHJ P,EVAL
MOVE B,A
POP P,A
SET: SKIPE A ;$$ MUST BE NON-NIL
CAILE A,INUMIN ;$$ AND NOT AN INUM
JRST SETERR ;$$
HLRE AR1,(A) ;$$ AND AN ATOM
AOJN AR1,SETERR ;$$
MOVE AR1,B
PUSHJ P,BIND
SUB SP,[XWD 1,1]
MOVE A,AR1
POPJ P,
CON2: HRRZ A,(T)
COND: JUMPE A,CPOPJ ;entry
PUSH P,A
HLRZ A,(A)
HLRZ A,(A)
PUSHJ P,EVAL
POP P,T
JUMPE A,CON2
HLRZ T,(T)
COND2: HRRZ T,(T)
JUMPE T,CPOPJ ;ENTRY FOR ALL TYPES OF PROGN'S
HLRZ A,(T)
HRRZ T,(T) ;$$
JUMPE T,EVAL ;$$ SAVE STACK SPACE IF NO IMPLIED PROG
PUSH P,T ;$$
PUSHJ P,EVAL
POP P,T
JRST COND2+2 ;$$ BECAUSE OF THE LAST CHANGE
;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
LEXORD: MOVE TT,A
PUSHJ P,NUMBERP
JUMPN A,LEX2 ;1ST ARG IS A NUMBER
MOVE A,B
PUSHJ P,NUMBERP
EXCH A,TT
JUMPN TT,FALSE ;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
MOVE T,B
MOVEI B,PNAME(S)
PUSHJ P,GET
EXCH A,T
PUSHJ P,GET
LEX1: JUMPE T,TRUE
JUMPE A,CPOPJ
HLRZ AR1,(A)
MOVE AR1,(AR1)
HLRZ AR2A,(T)
MOVE AR2A,(AR2A)
LSH AR1,-1
LSH AR2A,-1
CAMLE AR1,AR2A
JRST TRUE
CAME AR1,AR2A
JRST FALSE
HRRZ A,(A)
HRRZ T,(T)
JRST LEX1
LEX2: MOVE A,B
PUSHJ P,NUMBERP
EXCH A,TT
JUMPE TT,TRUE ;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
PUSHJ P,.GREAT ;BOTH NUMBERS, DO (NOT (*GREAT A B))
JRST NOT
PROGN: MOVE T,A ;$$ PROGN
MOVEI A,NIL
JRST COND2+1 ;$$ IMPLIED PROG DOES THE REST
PAGE
SUBTTL ARITHMETIC SUBROUTINES
;macro expander -- (foo a b c) => (*foo (*foo a b) c)
EXPAND: MOVE C,B
HRRZ A,(A)
PUSHJ P,REVERSE
JRST EXPA1
EXPN1: MOVE C,B
EXPA1: HRRZ T,(A)
HLRZ A,(A)
JUMPE T,CPOPJ
PUSH P,A
MOVE A,T
PUSHJ P,EXPA1
EXCH A,(P)
PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
MOVE B,C
JRST XCONS
PAGE
ADD1: CAILE A,INUMIN
CAIL A,-2
SKIPA B,[INUM0+1]
AOJA A,CPOPJ
.PLUS: JSP C,OP
ADD A,TT
FADR A,TT
SUB1: CAILE A,INUMIN+1
SOJA A,CPOPJ
MOVEI B,INUM0+1
.DIF: JSP C,OP
SUB A,TT
FSBR A,TT
.TIMES: JSP C,OP
IMUL A,TT
FMPR A,TT
.QUO: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
IDIV A,TT
FDVR A,TT
.GREAT: EXCH A,B
JUMPE B,FALSE
.LESS: JUMPE A,CPOPJ
JSP C,OP
JRST COMP2 ;bignums know about me
JRST COMP2
COMP2: CAML A,TT
JRST FALSE
JRST TRUE
.MAX: MOVEI D,.GREAT
SKIPA
.MIN: MOVEI D,.LESS
MOVE AR1,A
MOVE AR2A,B
PUSHJ P,(D)
SKIPN A
MOVE AR1,AR2A
MOVE A,AR1
POPJ P,
PAGE
MAKNUM:
CAIE B,FLONUM(S) ;## DEFAULT TO FIXNUM, NOT FLONUM
JRST FIX1A
FLO1A:
MOVEI B,FLONUM(S)
PUSHJ P,FWCONS
JRST ACONS-1
FIX1B: SUBI A,INUM0
MOVEI B,FIXNUM(S)
PUSHJ P,FWCONS
JRST ACONS-1
NUMVLX: JFCL 17,.+1
NUMVAL: CAIG A,INUMIN
JRST NUMAG1
SUBI A,INUM0
MOVEI B,FIXNUM(S)
POPJ P,
NUMAG1: MOVEM A,AR1
HRRZ A,(A)
HLRZ B,(A)
HRRZ A,(A)
CAIE B,FIXNUM(S)
CAIN B,FLONUM(S)
SKIPA A,(A)
NUMV4: SKIPA A,AR1
POPJ P,
NUMV2: PUSHJ P,EPRINT ;bignums know about me
JRST NONNUM
NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
PAGE
FLOAT: IDIVI A,400000
SKIPE A
TLC A,254000
TLC B,233000
FADR A,B
POPJ P,
FIX: PUSH P,A
PUSHJ P,NUMVAL
CAIE B,FLONUM(S)
JRST POPAJ
MULI A,400
TSC A,A
JFCL 17,.+1
ASH B,-243(A)
FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
POP P,A
FIX1: MOVE A,B
JRST FIX1A
MINUSP: PUSHJ P,NUMVAL
JUMPGE A,FALSE
JRST TRUE
MINUS: PUSHJ P,NUMVLX
MOVNS A
JFCL 10,@OPOV
JRST MAKNUM
ABS: PUSHJ P,NUMVLX
MOVMS A
JRST MINUS+2
NUMTYP: PUSHJ P,NUMVAL ;## NUMVAL LEAVES TYPE IN B
MOVEI A,(B) ;## GET THE TYPE
POPJ P,
INUMP: CAIG A,INUMIN ;## INUM IF > INUMIN
JRST FALSE ;## NO, RETURN NIL
POPJ P, ;## RETURN USEFUL VALUE
PAGE
DIVIDE: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
JUMPN RDIV ;bignums know about me
JRST ILLNUM
RDIV: IDIV A,TT
PUSH P,B
PUSHJ P,FIX1A
EXCH A,(P)
PUSHJ P,FIX1A
POP P,B
JRST XCONS
REMAINDER:
PUSHJ P,DIVIDE
JRST CDR
FIXOV: ERR1 [SIXBIT /INTEGER OVERFLOW!/]
ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
FLOOV: ERR1 [SIXBIT /FLOATING OVERFLOW!/]
ILLNUM: ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
GCD: JSP C,OP
JUMPA GCD2 ;bignums know about me
JRST ILLNUM
GCD2: MOVMS A
MOVMS TT
;euclid's algorithm
GCD3: CAMG A,TT
EXCH A,TT
JUMPE TT,FIX1A
IDIV A,TT
MOVE A,B
JRST GCD3
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
CAIL A,-1
JRST FIX1B
POPJ P,
OPA1: HRRZ A,(A)
HLRZ T,(A)
HRRZ A,(A)
CAIE T,FIXNUM(S)
JRST OPA6
SKIPA A,(A)
OPA2:
MOVEI T,FIXNUM(S)
CAILE B,INUMIN
JRST OPB2
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
CAIE B,FIXNUM(S)
JRST OPA5
SKIPA TT,(TT)
OPB2: HRREI TT,-INUM0(B)
JFCL 17,.+1
XCT (C) ;fixed pt op
OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
JRST FIX1A
OPA6: CAILE B,INUMIN
JRST OPB7
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
CAIE B,FLONUM(S)
JRST OPB3
CAIE T,FLONUM(S)
JRST NUMV3
MOVE A,(A)
MOVE TT,(TT)
OPR: JFCL 17,.+1
XCT 1(C) ;flt pt op
JFCL 10,FLOOV
JRST FLO1A
OPA5:
CAIE B,FLONUM(S)
JRST NUMV3
PUSHJ P,FLOAT
JRST OPR-1
OPB3:
CAIE B,FIXNUM(S)
JRST NUMV3
SKIPA TT,(TT)
OPB7: HRREI TT,-INUM0(B)
MOVEI B,FIXNUM(S)
CAIE T,FLONUM(S)
JRST NUMV3
MOVE A,(A)
EXCH A,TT
PUSHJ P,FLOAT
EXCH A,TT
JRST OPR
PAGE
SUBTTL EXPLODE, READLIST AND FRIENDS
%FLATSIZEC: SKIPA R,.+1 ;$$ FLATSIZEC - (LENGTH (EXPLODEC))
FLATSIZE: HRRZI R,FLAT2
SETZM FLAT1
PUSHJ P,PRINTA
MOVE A,FLAT1#
JRST FIX1A
FLAT2: AOS FLAT1
POPJ P,
%EXPLODE: SKIPA R,.+1
EXPLODE: HRRZI R,EXPL1
MOVSI AR1,AR1
PUSHJ P,PRINTA
JRST SUBS4
EXPL1: PUSH P,B
PUSH P,C
ANDI A,177
CAIL A,"0"
CAILE A,"9"
JRST EXPL2
ADDI A,INUM0-"0"
JRST EXPL4
EXPL2: PUSH P,AR1
PUSH P,TT
PUSH P,T
LSH A,35
MOVE C,SP
PUSH C,A
MOVEI AR1,1
PUSHJ P,INTER0
POP P,T
POP P,TT
POP P,AR1
EXPL4: PUSHJ P,NCONS
HLR B,AR1
HRRM A,(B)
HRLM A,AR1
POP P,C
JRST POPBJ
PAGE
READLIST: TDZA T,T
MAKNAM: MOVNI T,1
MOVEM T,NOINFG
PUSH P,OLDCH
SETZM OLDCH
JUMPE A,NOLIST
HRRM A,MKNAM3
MOVEI A,MKNAM2
PUSHJ P,READ0
HRRZ T,MKNAM3
CAIE T,-1
JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
POP P,OLDCH
POPJ P,
MKNAM2: PUSH P,B
PUSH P,T
PUSH P,TT
HRRZ TT,MKNAM3#
JUMPE TT,MKNAM6
CAIN TT,-1
ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
HRRZ B,(TT)
HRRM B,MKNAM3
HLRZ A,(TT)
CAIGE A,INUMIN
JRST MKNAM5
SUBI A,INUM0-"0"
MKNAM4: POP P,TT
POP P,T
JRST POPBJ
MKNAM5: HLRZ A,(TT)
MOVEI B,PNAME(S)
PUSHJ P,GET
HLRZ A,(A)
LDB A,[POINT 7,(A),6]
JRST MKNAM4
MKNAM6: MOVEI A," "
HLLOS MKNAM3
JRST MKNAM4
; A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
FREE: MOVEM F,(A) ;$$ RETURN A SINGLE CELL TO FREE LIST
HRRZ F,A
JRST FALSE
FREELI: JUMPE A,CPOPJ ;$$ RETURN A LIST TO THE FREE LIST
HRRZ B,(A)
MOVEM F,(A)
HRRZ F,A
MOVE A,B
JRST FREELI
PAGE
SUBTTL EVAL APPLY -- THE INTERPRETER
APPLY.: CAILE A,INUMIN ;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
JRST UNDTAG
HLRZ T,(A)
CAIE T,-1
JRST GAPP
HRRZ T,(A)
AAGN: JUMPE T,GAPP
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,FSUBR(S)
JRST [MOVE A,B
HLRZ T,(T)
JRST (T)]
CAIN TT,FEXPR(S)
JRST [ HLRZ T,(T)
HRL T,A
PUSH P,T
MOVE A,B
JRST APPL.2]
CAIN TT,MACRO(S)
JRST [ PUSHJ P,CONS
JRST EVAL]
CAIN TT,EXPR(S)
JRST GAPP
CAIN TT,SUBR(S)
JRST GAPP
CAIE TT,LSUBR(S)
JRST AAGN
GAPP: HRREI T,-2
PUSH P,A
PUSH P,B
JRST APPLY
PAGE
EV3: HLRZ A,(AR1)
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPE A,UNDFUN ;function object has no definition
HRRZ A,(A)
REMOTE<
XXX4:
UBDPTR: UNBOUND>
HLRZ B,(AR1) ;$$GET ORIGINAL FN NAME
CAME A,B ;$$IF VALUE IS THE SAME THE WE HAVE A LOOP
CAMN A,UBDPTR
JRST UNDFUN
HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
PUSHJ P,CONS
JRST XXEVAL
PAGE
OEVAL: AOJN T,AEVAL
POP P,A
EVAL: PUSH P,SP ;$$SAVE SPDL
PUSHJ P,XXEVAL ;$$GO DO EVALUATION AS USUAL
POP P,SP ;$$RESTORE SPDL
POPJ P, ;$$AND RETURN TO CALLER
XXEVAL: HRRZM A,AR1
CAILE A,INUMIN
JRST CPOPJ
;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
PUSH P,B ;$$SAVE WHAT WAS IN B
HRRZI B,-1(P) ;$$GET RPDL POINTER AND OFFSET
HRLI B,UNBOUND(S) ;$$ SET UP RPDL POINTER
PUSH SP,B ;$$ SAVE RPDL POINTER ON SPDL
PUSH SP,A ;$$SAVE EVAL FORM ON SPDL
POP P,B ;$$AND GO OON
HLRZ T,(A) ;;;;;;;;;;;;;
SKIPN ERINT# ;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
JRST .+4 ;$$SKIP OVER INTERRUPT FEATURE
SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
PUSHJ P,EPRINT ;$$PRINT OUT WHAT WAS INTERRUPTED
ERR1 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
CAIN T,-1
JRST EE1 ;x is atomic
CAILE T,INUMIN
JRST UNDFUN
HLRO TT,(T)
AOJE TT,EE2 ;car (x) is atomic
JRST EXP3
EE1:
EV5: HRRZ AR1,(AR1)
JUMPE AR1,UNBVAR
HLRZ TT,(AR1)
CAIE TT,FLONUM(S)
CAIN TT,FIXNUM(S)
POPJ P,
EVBIG: HRRZ AR1,(AR1) ;bignums know about me
CAIE TT,VALUE(S)
JRST EV5
HLRZ AR1,(AR1)
HRRZ AR1,(AR1)
CAIN AR1,UNBOUND(S)
JRST UNBVAR
MOVEM AR1,A
POPJ P,
PAGE
; HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
ALIST: SKIPE A,-1(P)
PUSHJ P,NUMBERP
MOVEM SP,SPSV
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
POP C,T ;pointer for next block
JUMPGE T,AEVAL6 ;$$SKIP ANY EVAL BLIP CRAP
AEVAL4: CAMN C,T
JRST AEVAL6 ;thru with block
POP C,AR1
TLNE AR1,-1 ;$$ TEST FOR EVAL BLIP
JRST .+3
SUB C,[XWD 1,1] ;$$ FOUND ONE, SKIP RPDL WORD
JRST AEVAL4
MOVSS AR1
PUSH SP,(AR1) ;save value cell
HLRM AR1,(AR1) ;store previous value in value cell
HRLM AR1,(SP) ;save pointer to spec pdl loc
JRST AEVAL4
AEVAL: PUSHJ P,ALIST
POP P,A
MOVEI A,UNBIND
EXCH A,(P)
JRST EVAL
PAGE
AEVAL1: SKIPGE AEVAL2
SKIPN B,-1(P)
JRST ABIND3 ;done with binding
;alist binding
MOVE A,B
PUSHJ P,REVERSE
SKIPA
ABIND2: MOVE A,B
HRRZ B,(A)
HLRZ A,(A)
HRRZ AR1,(A)
HLRZ A,(A)
PUSHJ P,BIND
JUMPN B,ABIND2
ABIND3: PUSH SP,SPSV
POPJ P,
;spec pdl binding
AEVAL7: MOVE A,-1(P)
PUSHJ P,NUMVAL
JUMPL A,.+5 ;MAKE SURE IT IS A VALID STACK POINTER
MOVS T,SC2 ;IT'S NOT, MAKE IT VALID
ADD T,A
ADD A,SC2
HRL A,T
CLEARM AEVAL2#
MOVEM A,AEVAL5 ;point to unbind to
JRST AEVAL8
;AEVAL2: 0 ;0 for number, -1 for a-list
PAGE
EE2: HRRZ T,(T)
JUMPE T,EV3
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,SUBR(S)
JRST ESB
CAIN TT,LSUBR(S)
JRST EELS
CAIN TT,EXPR(S)
JRST AEXP
CAIN TT,FSUBR(S)
JRST EFS
CAIN TT,MACRO(S)
JRST EFM
CAIE TT,FEXPR(S)
JRST EE2
HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
HRRZ A,(A)
APPL.2: TLO A,400000
PUSH P,A
MOVNI T,1
JRST IAPPLY
AEXP: HLRZ T,(T)
HLL T,(AR1)
EXP3: PUSH P,T
HRRZ A,(AR1)
CILIST: JSP TT,ILIST
EXP2: JRST IAPPLY
EFS: HLRZ T,(T)
HRRZ A,(AR1)
JRST (T)
PAGE
ESB: HRRZ A,(AR1)
UUOS2: HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
JSP TT,ILIST
ESB1: JRST .+NACS+1(T)
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POPAJ: POP P,A
POPJ P,
EFM: HLRZ T,(T)
CALLF 1,(T)
JRST EVAL
PAGE
APPLY: MOVEI TT,AP2
CAME T,[-3]
JRST PDLARG
MOVEM T,APFNG1#
PUSHJ P,ALIST
MOVE T,APFNG1
JSP TT,PDLARG
PUSH P,[UNBIND]
AP2: PUSH P,A
MOVEI T,0
AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
HLRZ C,(B)
PUSH P,C ;push arg
HRRZ B,(B)
SOJA T,AP3
IAP4: JUMPGE D,TOOFEW ;special case for fexprs
AOJN R,TOOFEW
PUSH P,B
MOVE A,SP
PUSHJ P,FIX1A
EXCH A,(P)
MOVE B,A
MOVNI R,2
SOJA T,IAP5
FUNCT: PUSH P,A
MOVE A,SP
PUSHJ P,FIX1A
POP P,B
HLRZ B,(B)
PUSHJ P,XCONS
MOVEI B,FUNARG(S)
JRST XCONS
PAGE
APFNG: SOS T
MOVEM T,APFNG1
JSP TT,PDLARG ;get args and funarg list
HRRZ A,(A)
HRRZ D,(A) ;a-list pointer
HLRZ A,(A) ;function
HRLZ R,APFNG1 ;no. of args
PUSH P,[UNBIND]
JSP TT,ARGP1 ;replace args and fn name
PUSH P,D ;a-list pointer
PUSHJ P,ALIST ;set up spec pdl
POP P,D
AOS T,APFNG1
;falls through
PAGE
;falls in
IAPPLY: MOVE C,T ;state of world at entrance
ADDI C,(P) ;t has - number of args on pdl
ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
CAILE B,INUMIN
JRST UNDTAC
HLRZ A,(B)
CAIN A,-1
JRST IAP1 ;fn is atomic
CAIN A,LAMBDA(S)
JRST IAPLMB
CAIN A,FUNARG(S)
JRST APFNG
CAIN A,LABEL(S)
JRST APLBL
PUSH P,T
MOVE A,B
PUSHJ P,EVAL
POP P,T
MOVE C,T
ADDI C,(P)
ILP1B: MOVEM A,(C)
JRST ILP1A
IAPXPR: HLRZ A,(B)
JRST ILP1B
IAP1: HRRZ B,(B)
JUMPE B,IAP2
HLRZ TT,(B)
HRRZ B,(B)
CAIN TT,EXPR(S)
JRST IAPXPR
CAIN TT,LSUBR(S)
JRST IAP6
CAIE TT,SUBR(S)
JRST IAP1
HLRZ B,(B)
MOVEM B,(C)
JRST ESB1
PAGE
IAPLMB: HRRZ B,(B)
HLRZ TT,(B)
MOVEM SP,SPSV
HRRZ B,(B)
HLRZ D,(TT)
CAIN D,-1
JUMPN TT, IAP3
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;no more args
JUMPE TT,TOMANY ;too many args supplied
IAP5: HLRZ A,(TT)
MOVEI AR1,1(T)
ADD AR1,P
HLLZ D,(AR1)
HRLM A,(AR1)
HRRZ TT,(TT)
AOJA T,IPLMB1
PAGE
IPLMB2: JUMPN TT,IAP4 ;too few args supplied
JUMPE R,IAP69
IPLMB4: POP P,AR1
HLRZ A,AR1
AOJG R,IPLMB3
PUSHJ P,BIND
JRST IPLMB4
IPLMB3: SKIPE BACTRF
JRST APBK1
APBK2: MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
PUSH SP,SPSV
MOVE T,B ;$$SETUP FOR IMPLIED PROG
PUSHJ P,COND2+1 ;$$INSTEAD OF EVAL
JRST UNBIND
IAP69: POP P,(P)
MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
MOVE T,B ;$$
JRST COND2+1 ;$$INSTEAD OF EVAL
APBK1: HRRI AR1,CPOPJ
TLNE AR1,-1
PUSH P,AR1
JRST APBK2
IAP6: MOVEI TT,CPOPJ
MOVEM TT,(C)
HLRZ B,(B)
JRST (B)
APLBL: MOVEM SP,SPSV
HRRZ B,(B)
HLRZ A,(B)
HRRZ B,(B)
HLRZ AR1,(B)
MOVEM AR1,(C)
PUSHJ P,BIND
MOVEI A,APLBL1
EXCH A,-1(C)
EXCH A,LBLAD#
HRLI A,LBLAD
PUSH SP,A
PUSH SP,SPSV
JRST IAPPLY
APLBL1: PUSH P,LBLAD
JRST SPECSTR
IAP2: HRRZ A,(C)
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPE A,UNDTAC
HRRZ A,(A)
HRRZ B,(C) ;$$GET ORIGINAL FN NAME
CAME A,B ;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
CAIN A,UNBOUND(S)
JRST UNDTAC
JRST ILP1B
IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
MOVE A,TT
PUSHJ P,BIND
PUSH P,%ARG
SUBI C,INUM0
HRRM C,%ARG
PUSH SP,SPSV
MOVEI A,NIL ;$$ MORE FOR IMPLIED PROG
MOVE T,B ;$$
PUSHJ P,COND2+1 ;$$ INSTEAD OF EVAL
HRRZ T,%ARG
POP P,%ARG
SUBI T,1-INUM0(P)
HRLI T,-1(T)
ADD P,T
JRST UNBIND
ARG: HRRZ A,@%ARG
POPJ P,
REMOTE<%ARG: XWD A,0>
SETARG: HRRZM B,@%ARG
JRST PROG2
PAGE
BIND: JUMPE A,BNDERR ;$$CAN'T REBIND NIL
CAIN A,TRUTH(S) ;$$SHOULDN'T REBIND T
JRST BNDERR ;$$
PUSH P,B
HRRZM A,BIND3#
BIND2:
MOVEI B,VALUE(S) ;bind atom in a to value in ar1,save
PUSHJ P,GET ;old binding on s pdl
JUMPE A,BIND1 ;add value cell
PUSH SP,(A)
HRLM A,(SP)
HRRM AR1,(A) ;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
POPBJ: POP P,B
POPJ P,
BIND1:
MOVEI B,UNBOUND(S)
MOVE A,BIND3 ;$$SET UP ATOM POINTER FROM SPECIAL CELL
;$$THIS WAS MOVEI A,0
PUSHJ P,CONS
HRRZ B,@BIND3
PUSHJ P,CONS
MOVEI B,VALUE(S)
PUSHJ P,XCONS
HRRM A,@BIND3
MOVE A,BIND3
JRST BIND2
UBD: CAMG SP,B
POPJ P,
HLRZ TT,(SP) ;$$SKIP OVER EVAL BLIPS ETC.
JUMPE TT,.+2 ;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
JRST PJUBND
SUB SP,[XWD 2,2] ;$$DECREMENT SPDL
JRST UBD ;$$GO BACK AND CHECK
PJUBND: PUSHJ P,UNBIND
JRST UBD
UNBIND:
SPECSTR: MOVE TT,(SP)
CAMN SP,SC2 ;$$CHECK TO AVOID OVERSHOOT
POPJ P, ;$$
SUB SP,[XWD 1,1]
JUMPGE TT,UNBIND ;syncronize stack
UNBND1: CAMN SP,TT
POPJ P,
POP SP,T
CAIN T,(T) ;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
JRST PROGUB ;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
MOVSS T
HLRM T,(T) ;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
JRST UNBND1
PROGUB: HLRZ T,(T) ;$$CHECK FOR A PROG
CAIE T,PROGAT+1(S) ;$$CHECK IF IT IS A PROG
JRST PROGU1 ;$$NOT A PROG, SKIP IT AND GO ON
MOVE T,(SP) ;$$GET THE RPDL POINTER FOR PROG INTO T
ADDI T,2 ;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
POP T,PA4 ;$$RESTORE PA4
POP T,PA3 ;$$AND PA3 FROM WHERE THEY WERE SAVED
PROGU1: POP SP,T ;$$ POP RPDL POINTER
JRST UNBND1 ;$$AND GO ON WITH THE UNBINDING
SPECBIND: MOVE TT,SP
SPEC1: LDB R,[POINT 13,(T),ACFLD]
CAILE R,17
JRST SPECX
SKIPE R
MOVE R,(R)
HLL R,@(T) ;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
EXCH R,@(T)
HRLI R,@(T)
PUSH SP,R
AOJA T,SPEC1
SPECX: PUSH SP,TT
JRST (T)
;random special case compiler run time routines
%AMAKE: PUSH P,A ;make alist for fsubr that requires it
MOVE A,SP
PUSHJ P,FIX1A
MOVE B,A
JRST POPAJ
%UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
HRRZ R,(P)
PUSHJ P,ERSUB3
JRST ERREND
%LCALL: MOVN A,T ;set up routine for compile lsubr
ADDI A,INUM0
ADDI T,(P)
PUSH P,T
PUSHJ P,(3)
POP P,T
SUBI T,(P)
HRLI T,-1(T)
ADD P,T
POPJ P,
PAGE
SUBTTL ARRAY SUBROUTINES
ARRERR=-1
ARRAY: PUSHJ P,ARRAYS
HRRI AR2A,1(R)
MOVE A,AR2A
PUSH R,[0]
AOBJN A,.-1
ARREND: MOVE A,BPPNR#
MOVEM AR2A,-1(A)
MOVEI A,INUM0+1(R)
MOVEM A,VBPORG(S)
POPJ P,
ARRAYS: PUSH P,A
MOVE A,VBPORG(S)
SUBI A,INUM0
MOVEM A,BPPNR
MOVE A,VBPEND(S)
MOVNI A,-INUM0-2(A)
ADD A,BPPNR ;bporg-bpend+2
HRLM A,BPPNR
POP P,A
HRRZ AR1,(A) ;(cdr l)
HLRZ A,(A) ;(car l)name
HRRZ B,BPPNR
ADDI B,2
MOVEI C,SUBR(S)
PUSHJ P,PUTPROP
HLRZ A,(AR1) ;(cadr l)mode
PUSH P,AR1
PUSHJ P,EVAL ;eval mode
POP P,AR1
MOVEM A,AMODE#
MOVEI C,44
JUMPE A,ARRY1
MOVEI C,-INUM0(A)
CAILE A,INUMIN
JRST ARRY1
MOVEI C,22
HRRZ A,BPPNR
MOVE B,GCMKL
PUSHJ P,CONS
MOVEM A,GCMKL
ARRY1: MOVEM C,BSIZE#
MOVEI A,44
IDIV A,C
MOVEM A,NBYTES#
HRRZ A,(AR1) ;(cddr l)bound pair list
JSP TT,ILIST
AOS R,BPPNR
MOVEI AR1,1 ;ar1 is array size
MOVEI AR2A,0 ;ar2a is cumulative residue
AOJGE T,ARRYS ;single dimension
MOVEI D,A-1
SUB D,T ;d is next ac for array code generation
ARRY2: PUSHJ P,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: POP P,TT
EXCH TT,(P)
CAILE TT,INUMIN
JRST ARRB1
HLRZ A,(TT)
HRRZ TT,(TT)
SUBI TT,(A)
ADDI TT,1
JRST ARRB2
ARRB1: MOVEI A,INUM0
SUB TT,A
ARRB2: IMUL A,AR1
IMULB AR1,TT
;%% ADDM A,AR2A
ADD AR2A,A ;%% SOME PEOPLE HAVE PROBLEMS
POPJ P,
ARRY3: PUSH R,[ADD A,B]
ARRYS: PUSHJ P,ARRB0
HRRZ TT,BPPNR
MOVEM AR2A,(TT)
HRLI TT,(SUB A,)
PUSH R,TT
PUSH R,[JUMPL A,ARRERR]
MOVE TT,AR1
HRLI TT,(CAIL A,)
PUSH R,TT
PUSH R,[JRST ARRERR]
IDIV AR1,NBYTES ;calc #words in array
SKIPE AR2A ;correct for remainder non-zero
ADDI AR1,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 AR2A,AMODE
CAIL AR2A,INUMIN
ADDI TT,40 ;mode not = t
TLC TT,(HRLZI C,)
PUSH R,TT
MOVEI TT,4(R)
HRLI TT,(ADDI C,(A))
PUSH R,TT
PUSH R,[LDB A,C]
HRLZI AR2A,(POPJ P,)
SKIPN TT,AMODE
MOVE AR2A,[JRST FLO1A]
CAIL TT,INUMIN
MOVE AR2A,[JRST FIX1A]
PUSH R,AR2A
MOVS AR2A,AR1
MOVNS AR2A
POPJ P,
PAGE
GTBLK: MOVNI C,-INUM0(A) ;##COMPUTE NEGATIVE LENGTH
MOVE A,VBPORG(S) ;## GET BPORG
HRRI A,-INUM0(A) ;## CONVERT
HRLM C,(A) ;## MOVE TO BPORG INFO FOR (GC)
HRRM A,(A) ;##
AOS R,(A) ;## ADD ONE TO INFO AND MOVE TO R
SUBI R,1 ;## SET PUSH DOWN POINTER(ASSUME POINTER BLOCK)
CAIN B,0 ;## IS IT A POINTER BLOCK?
SUBI R,1 ;## NO
MOVE AR1,VBPEND(S) ;## GET BPEND
MOVNI AR1,-INUM0(AR1) ;## CONVERT TO NEGATIVE
ADD AR1,R ;## BPORG-BPEND +(0 OR 1)
HRLI R,(AR1) ;## MOVE TO R FOR TESTING FOR BPS EXCEEDED
PUSH R,[0] ;## CLEAR THE SPACE, NOTE THAT IF IT IS NOT
AOJN C,.-1 ;## WE WILL ALSO CLEAR THE INFO LOCATION
HRRZI R,INUM0+1(R) ;## COMPUTE NEW BPORG
HRRM R,VBPORG(S)
CAIN B,0 ;## IF IT WAS NOT A POINTER BLOCK, DONE
POPJ P,
MOVE B,GCMKL ;## GET GC'S LIST
PUSHJ P,CONS ;## CONS
MOVEM A,GCMKL ;## SAVE IT
HLRZ A,(A) ;GET THE OLD BPORG BACK
AOJA A,.-5 ;## ADD ONE AND RETURN
BLKLST: PUSH P,A ;## SAVE LIST
CAIE B,0 ;## BLK LENGTH GIVEN
SKIPA A,B ;## YES
PUSHJ P,LENGTH ;## NO, USE LENGTH OF LIST
MOVEI B,(A) ;## GET A POINTER BLOCK FROM GTBLK
PUSHJ P,GTBLK
POP P,B ;## GET LIST BACK
PUSH P,A
HRRZI R,-1(A) ;## SET UP PDL
HLRE C,(R) ;## NEG LENGTH FROM GC INFO.
BLKLS1: HRRI A,1(A) ;## BUMP A FOR CDR
IFN OLDNIL< ;## IF(CDR NIL)#NIL
TRNE B,-1 ;## END OF LIST?
SKIPA B,(B) ;## NO
SETZ B, ;## YES, REST OF BLOCK IS NIL
>
IFE OLDNIL<
MOVE B,(B) ;## IF (CDR NIL )=NIL
>
HLL A,B ;## GET (CAR LIST)
PUSH R,A ;## AND STORE
AOJL C,BLKLS1 ;## SEE IF DONE
HLLZM A,(R) ;## SET (CDR (LAST BLOCK)) TO NIL
JRST POPAJ ;## AND RETURN POINTER TO THE BLOCK
EXARRAY: PUSH P,A
HLRZ A,(A)
PUSHJ P,GETSYM
JUMPE A,POPAJ
PUSHJ P,NUMVAL
EXCH A,(P)
PUSHJ P,ARRAYS
POP P,A
HRRM A,-2(R)
HRR AR2A,A
JRST ARREND
STORE: PUSH P,A
PUSHJ P,CADR
PUSHJ P,EVAL ;value to store
EXCH A,(P)
HLRZ A,(A)
PUSHJ P,EVAL ;byte pointer returned in c
POP P,A
NSTR: PUSH P,A
TLNE C,40
PUSHJ P,NUMVAL ;numerical array
DPB A,C
POP P,A
POPJ P,
PAGE
SUBTTL EXAMINE, DEPOSIT , ETC
BOOLE: MOVE TT,T
ADDI TT,2(P)
MOVE A,-1(TT)
SUBI A,INUM0
DPB A,[POINT 4,BOOLI,OPFLD-2]
PUSHJ P,BOOLG
MOVE C,A
BOOLL: PUSHJ P,BOOLG
XCT BOOLI
REMOTE<
BOOLI: CLEARB C,A>
JRST BOOLL
BOOLG: CAIL TT,(P)
JRST BOOL1
MOVE A,(TT)
PUSHJ P,NUMVAL
AOJA TT,CPOPJ
BOOL1: HRLI T,-1(T)
ADD P,T
POP P,B
JRST FIX1A
EXAMINE:PUSHJ P,NUMVAL
MOVE A,(A)
JRST FIX1A
DEPOSIT:MOVE C,B
PUSHJ P,NUMVAL
EXCH A,C
PUSHJ P,NUMVAL
MOVEM A,(C)
JRST MAKNUM
LSH: MOVEI C,-INUM0(B)
PUSHJ P,NUMVAL
LSH A,(C)
JRST FIX1A
PAGE
SUBTTL GARBAGE COLLECTER
;garbage collector
GC: PUSHJ P,AGC
JRST FALSE
AGC: SETOM GCFLG ;SET GCFLAG INCASE OF USER CONTROL-C
MOVEM R,RGC#
GCPK1: PUSH P,PA3
PUSH P,PA4
IFE OLDNIL <PUSH P,NILPRP ;## PROP LIST OF NIL>
PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
PUSH P,MKNAM3
PUSH P,GCMKL ;i/o channel input lists and arrays
PUSH P,BIND3
PUSH P,INITF
PUSH P,INITF1 ;## INIT FILE LIST
GCPK2: PUSH P,[XWD 0,GCP6] ;this is a return address
JRST GCP4
REMOTE<
GCP4: MOVEI S,X ;pdlac, .=bottom of reg pdl + 1
GCP41: BLT S,X ;save ACs 0 through 10 at bottom of regpdl ;pdlac+n
GCP2: CLEARB 0,X ;gc indicator, init. for bit table zero
MOVE A,C3GC
GCP5: BLT A,X ;zero bit tables, .=top of bit tables
JRST GCRET1>
GCRET1: SKIPN GCGAGV
JRST GCP5A
SKIPN F
STRTIP [SIXBIT /_FREE STG EXHAUSTED_!/]
SKIPN FF
STRTIP [SIXBIT /_FULL WORD SPACE EXHAUSTED_!/]
GCP5A: MOVEI TT,1
MOVEI A,0
CALLI A,STIME ;time
MOVNS A
ADDM A,GCTIM#
MOVE C,GCP3# ;.=bottom of reg pdl
GCP6B: MOVE S,P
HLL C,P
MOVEI B,0
GC1: CAMN C,S
POPJ P,
HRRZ A,(C)
GCPI: CAMGE A,GCP# ;.=bottom of bit tables
REMOTE<
GCPP1:
XXX5:FS>
CAMGE A,GCPP1
JRST GCEND
CAML A,GCP1# ;.=bottom of full word space (fws)
JRST GCMFW
MOVE F,(A)
LSHC A,-5
ROT B,5
MOVE AR1,GCBT(B)
TDOE AR1,@GCBTP2 ;bit tab- (fs_-5), .=magic number for sync
JRST GCEND
MOVEM AR1,@GCBTP1 ;bit tab- (fs_-5)
PUSH P,F
HLRZ A,F
JRST GCPI
REMOTE<
GCBTP1: XWD A,0
GCBTP2: XWD A,0
GCMFWS: XWD A,0>
GCMFW: MOVEI AR1,@GCMFWS ;.=- bottom of fws
IDIVI AR1,44
MOVNS AR2A
LSH AR2A,36
ADD AR2A,C2GC
DPB TT,AR2A
GCEND: CAMN P,S
AOJA C,GC1
POP P,A
HRRZS A
JRST GCPI
REMOTE<
GCMKL: XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
C2GC: XWD 430100+AR1,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
GCP6: HRRZ R,SC2
GCP6C: CAIL R,(SP) ;mark sp
JRST GCP6A
PUSH P,(R)
HRRZ C,P
PUSHJ P,GCP6B
SUB P,[XWD 1,1]
AOJA R,GCP6C
GCP6A: HRRZ R,GCMKL ;mark arrays
GCP6D: JUMPE R,GCSWP
HLRZ A,(R)
MOVE D,(A)
GCP6E: PUSH P,(D)
HRRZ C,P
PUSH P,(D)
MOVSS (P)
PUSHJ P,GCP6B
SUB P,[XWD 2,2]
AOBJN D,GCP6E
HRRZ 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
;garbage collector sweep
GCSWP: MOVSI R,GFSWPP
BLT R,LPROG
MOVEI F,NIL ;will become movei f,-1
MOVE D,C3GCS
JRST XXX3
REMOTE<
XXX3: MOVEI R,FS ;$$ANOTHER FOOLIST REMNANT
GCBTL1: HRLI R,X ;-(32-<fs&37>
MOVE S,(D)
GCBTL2: ROT S,X ;fs&37
AOBJN D,GFSP1
JRST GFSPR>
GFSPR: MOVE A,C1GCS
MOVE B,C2GCS
PUSHJ P,GCS0
SKIPN GCGAGV
JRST GCSPI1
MOVE B,F
PUSHJ P,GCPNT
STRTIP [SIXBIT / FREE STG,!/]
MOVE B,FF
PUSHJ P,GCPNT
STRTIP [SIXBIT / FULL WORDS AVAILABLE_!/]
GCSPI1: HRLZ S,GCSP1# ;bottom of reg pdl+1
BLT S,NACS+3 ;reload ac's
SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
AOSN GCFLG ;CHECK FLAG FOR PENDING INTERRUPT
JRST GCEXIT ;NO- SO NORMAL EXIT
POP P,JOBOPC ;INTERRUPT WILL CONTINUE FROM THE GC RETURN
PUSH P,GCFLG ;GC WILL RETURN TO THE INTERRUPT POINT
SETZM GCFLG ;CLEAR GCFLG
GCEXIT: JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
MOVE R,RGC
MOVEI A,0
CALLI A,STIME ;time
ADDM A,GCTIM
MOVE S,ATMOV ;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
POPJ P,
GCS0: MOVEI FF,0
GCS1: ILDB C,B
JUMPN C,GCS2
HRRZM FF,(A)
HRRZ FF,A
GCS2: AOBJN A,GCS1
POPJ P,
REMOTE<
C1GCS: 0 ;(- length of fws) bottom of fws
C2GCS: XWD 100,0 ;.=bottom of fws bit table
C3GCS: 0 ;-n wds in bt,,bt
>
GCGAG: EXCH A,GCGAGV#
POPJ P,
GCTIME: MOVE A,GCTIM
JRST FIX1A
TIME: MOVEI A,0
CALLI A,STIME
JRST FIX1A
SPEAK: MOVE A,CONSVAL#
JRST FIX1A
GCPNT: MOVEI R,TTYO
MOVEI A,0
JUMPE B,PRINL1
HRRZ B,(B)
AOJA A,.-2
IFN REALLC <
;%% NEW ROUTINES TO COUNT AVAILABLE
;%% FREE SPACE AND FULL WORD SPACE
FSCNT: TDZA C,C ;%% INITIALIZE
FWCNT: MOVEI C,1 ;%%
MOVE B,F(C) ;%% FREE LIST START
SETZ A, ;%% COUNTER
JUMPE B,FIX1A ;%% WHEN DONE, NO MORE POINTER
HRRZ B,(B) ;%%
AOJA A,.-2 ;%%
>
GCING: OUTSTR [ASCIZ /
GARBAGE COLLECTING
/]
POP P,GCFLG ;CAN'T INTERRUPT GC, QUEUE UP THE REQUEST
JRST @JOBOPC
PAGE
SUBTTL SYMBOL TABLE ACCESSING ROUTINES
R50MAK: PUSHJ P,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
POPJ P,
IMULI B,50
ADD B,A
JRST MK3
;## NEW ROUTINES FOR CONVERTING SYMBOLS TO CONS CELL
SYMERR: MOVE A,B
SYMER1: PUSHJ P,EPRINT ;## PRINT OFFENDER
ERR1 [SIXBIT /NOT A CONS CELL !/]
;## **CAUSES ERROR IF NOT IN FREE STORAGE**
RGTSYM: PUSHJ P,GETSYM
PUSHJ P,NUMVAL ;## CONVERT TO REAL ADDRESS
ADDI A,(S) ;## ADD RELOCATION
CAIL A,FS(S) ;## LESS THAN FS(S) IS NOT CONS CELL
CAML A,FWSO ;## FS(S)<= A < FWSO IS A CONS CELL
JRST SYMER1
POPJ P,
GETSYM: PUSHJ P,R50MAK
TLO B,040000 ;04 for globals
MOVE C,JOBSYM
MK7: CAMN B,(C)
JRST MK10 ;found
AOBJP C,.+2
AOBJN C,MK7
TLC B,140000 ;10 for locals
TLNE B,100000
JRST MK7-1
JRST FALSE
MK10: MOVE A,1(C) ;value
JRST FIX1A
;## ROUTINE TO STORE A CONS CELL SO THAT IT CAN BE
;## REFERENCED VIA ,CELL(S) I.E. THRU INDEX REG. S
;## ERROR IF NOT LEGITIMATE CONS CELL
RPTSYM: CAIL B,FS(S) ;## FS(S) =< B <FWSO IS A LEGIT
CAML B,FWSO ;## CONS CELL, ALL ELSE IS ERROR
JRST SYMERR ;## ERROR
SUBI B,(S) ;## STRIP OF RELOCATION
PUTSYM: PUSH P,B
PUSHJ P,R50MAK
MOVE A,B
TLO A,040000 ;make global
SKIPL JOBSYM
AOS JOBSYM ;increment initial symbol table pointer
MOVN B,[XWD 2,2]
ADDB B,JOBSYM
MOVEM A,(B) ;name
POP P,1(B) ;value
JRST FALSE
PATCH: BLOCK 20
PAGE
SUBTTL SPRINT -- THE PRETTY PRINTER
;THIS IS THE NEW IMPROVED VERSION OF SPRINT
; 0(P) = A
; -1(P) = B
; -2(P) = C
; -3(P) = M
; -4(P) = N
; -5(P) = X
SPRINT: SUBI B,INUM0
SPRNT2: PUSH P,A
PUSH P,B
SETZM M#
SETZM CSW#
MOVEM P,STP#
MOVEI B,0
PUSHJ P,DEPTH
SKIPN B,M
JRST .+6
MOVE A,LINL
SUB A,B
SUB A,B
IDIV A,B
CAILE A,14
MOVEI A,14
MOVEM A,CUT#
MOVE A,0(P)
IDIV A,LINL
CAIG B,0
ADD B,LINL
MOVEM B,0(P)
MOVEI C,0
JRST .+3
ISPRIN: PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,[0]
PUSH P,[0]
PUSH P,[0]
MOVE A,B
SUB B,LINL
JUMPLE B,.+3
MOVE A,B
MOVEM A,-4(P)
PUSHJ P,POS
MOVE A,-5(P)
PUSHJ P,PATOM
JUMPE A,.+4
SPRN1: MOVE A,-5(P)
PUSHJ P,PRIN1
JRST SPRN22
MOVE B,LINL
SUB B,-4(P)
ADDI B,1
MOVEM B,0(P)
SUB B,-3(P)
MOVE A,-5(P)
PUSHJ P,FLATLE
JUMPN A,SPRN1
MOVEI A,50
PUSHJ P,TYO
AOS -4(P)
SOS 0(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
HLRZ A,@-5(P)
CAIN A,LAMBDA(S)
JRST LAM
CAIN A,PROGAT+1(S)
JRST PRG
PUSHJ P,PATOM
JUMPE A,SPRN3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
MOVE A,0(P)
SUB A,CHCT
MOVEM A,-1(P)
CAIG A,24
JRST SPRN4
JRST SPRN12+4
SPRN3: MOVE B,0(P)
CAILE B,20
MOVEI B,20
HLRZ A,@-5(P)
PUSHJ P,FLATLE
JUMPE A,SPRN12
MOVEM A,-1(P)
SPRN4: HRRZ A,@-5(P)
MOVEM A,-2(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,SPRN8
MOVE B,-1(P)
CAMG B,CUT
JRST SPRN2
SKIPE CSW
JRST SPRN8
MOVE A,0(P)
SUB A,B
SUBI A,1
MOVEM A,-1(P)
JRST SPRN5
SPRN2: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,-4(P)
ADD A,-1(P)
ADDI A,1
MOVEM A,-4(P)
JRST SPRN12
SPRN5: MOVE B,-1(P)
HLRZ A,@-2(P)
PUSHJ P,FLATLE
JUMPE A,SPRN8
HRRZ A,@-2(P)
MOVEM A,-2(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPE A,SPRN5
HRRZ B,@-2(P)
JUMPN B,.+3
MOVE B,-1(P)
SOJA B,SPRN7
HRRZ A,@-2(P)
PUSHJ P,FLATSI
SUBI A,INUM0-4
SUB A,-1(P)
MOVN B,A
SPRN7: SUB B,-3(P)
HLRZ A,@-2(P)
PUSHJ P,FLATLE
JUMPN A,SPRN18
SPRN8: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
SPRN9: HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
CAMN A,-2(P)
JRST SPRN11
MOVE A,-4(P)
PUSHJ P,POS
JRST SPRN9
SPRN11: HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
SPRN12: MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
HRRZ A,@-5(P)
MOVEM A,-5(P)
JRST SPRN11
SPRN13: HRRZ A,@-5(P)
JUMPE A,.+4
PUSHJ P,FLATSI
SUBI A,INUM0-3
ADDM A,-3(P)
AOS -3(P)
MOVE C,-3(P)
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
SPRN16: HRRZ A,@-5(P)
JUMPE A,SPRN17
MOVEI A,40
PUSHJ P,TYO
MOVEI A,56
PUSHJ P,TYO
MOVEI A,40
PUSHJ P,TYO
HRRZ A,@-5(P)
PUSHJ P,PRIN1
SPRN17: MOVEI A,51
PUSHJ P,TYO
JRST SPRN22
SPRN18: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
MOVEI A,40
PUSHJ P,TYO
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,LINL
SUB A,CHCT
ADDI A,1
MOVEM A,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN21
SPRN19: HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,.+4
MOVE A,-4(P)
PUSHJ P,POS
JRST SPRN19
MOVE A,-4(P)
PUSHJ P,POS
SPRN21: HLRZ A,@-5(P)
PUSHJ P,PRIN1
JRST SPRN16
LAM: PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE B,-4(P)
MOVEM B,-1(P)
HLRZ A,0(A)
PUSHJ P,PATOM
MOVEI B,6
CAIE A,NIL
ADDI B,1
ADDM B,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
MOVE B,-1(P)
MOVEM B,-4(P)
JRST SPRN12+4
PRG: PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,-4(P)
MOVEM A,-1(P)
MOVEI A,5
ADDM A,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
MOVE A,0(P)
SUBI A,5
MOVEM A,-2(P)
PRG1: HRRZ A,@-5(P)
MOVEM A,-5(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,PRG3
HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPE A,PRG2
MOVE A,-1(P)
PUSHJ P,POS
HLRZ A,@-5(P)
PUSHJ P,PRIN1
JRST PRG1
PRG2: MOVE A,CHCT
CAMG A,-2(P)
PUSHJ P,TERPRI
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
JRST PRG1
PRG3: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPE A,SPRN13
MOVE B,-1(P)
MOVEM B,-4(P)
JRST SPRN13
SPRN22: MOVEI A,NIL
SUB P,[XWD 6,6]
POPJ P,
POS: PUSH P,A
PUSH P,[0]
MOVE A,LINL
SUB A,CHCT
ADDI A,1
PUSH P,A
CAMN A,-2(P)
JRST POS4
CAMG A,-2(P)
JRST .+4
PUSHJ P,TERPRI
MOVEI A,1
MOVEM A,0(P)
SUBI A,1
LSH A,-3
ADDI A,1
LSH A,3
ADDI A,1
MOVEM A,-1(P)
CAMLE A,-2(P)
JRST POS3
POS2: MOVEI A,11
PUSHJ P,TYO
MOVE A,-1(P)
MOVEM A,0(P)
ADDI A,10
JRST POS2-3
POS3: AOS A,0(P)
CAMLE A,-2(P)
JRST POS4
MOVEI A,40
PUSHJ P,TYO
JRST POS3
POS4: SUB P,[XWD 3,3]
POPJ P,
FLATLE: JUMPLE B,ABORT+1
SETZM M
MOVEM B,N#
MOVEM P,STP
SCAN: PUSH P,A
PUSHJ P,PATOM
JUMPN A,EXIT1-6
NA: AOS A,M
CAMLE A,N
JRST ABORT
HLRZ A,@0(P)
PUSHJ P,SCAN
HRRZ A,@0(P)
MOVEM A,0(P)
JUMPN A,.+3
AOS A,M
JRST EXIT1-2
MOVE A,0(P)
PUSHJ P,PATOM
JUMPE A,NA
MOVEI A,4
ADDB A,M
CAMLE A,N
JRST ABORT
MOVE A,0(P)
PUSHJ P,FLATSI
SUBI A,INUM0
ADDB A,M
CAMLE A,N
JRST ABORT
EXIT1: SUB P,[XWD 1,1]
POPJ P,
ABORT: MOVE P,STP
MOVEI A,NIL
POPJ P,
DEPTH: PUSH P,A
PUSH P,B
PUSHJ P,PATOM
JUMPN A,D2
AOS A,0(P)
CAMLE A,LINL
JRST OUT+1
CAMLE A,M
MOVEM A,M
MOVE A,-1(P)
PUSH P,A
PUSH P,[0]
D1: HLRZ A,@-3(P)
MOVE B,-2(P)
PUSHJ P,DEPTH
HRRZ A,@-3(P)
MOVEM A,-3(P)
MOVE B,-1(P)
SETCMB C,0(P)
JUMPN C,.+3
HRRZ B,0(B)
MOVEM B,-1(P)
CAMN A,B
JRST OUT
PUSHJ P,PATOM
JUMPE A,D1
SUB P,[XWD 2,2]
D2: SUB P,[XWD 2,2]
POPJ P,
OUT: SETOM CSW
MOVE P,STP
JRST @1(P)
;
;
;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
;
.TAB: PUSHJ P,NUMVAL
PUSHJ P,POS ;LET POS IN SPRINT DO THE WORK
JRST FALSE
PAGE
SUBTTL ALVINE AND LOADER INTERFACES
;interface to alvine
IFN ALVINE,<
ED: MOVE 10,EDA
JRST (10)
PUSH P,A
HRRZ A,CORUSE
HRRM A,LST
AOS A
HRRM A,EDA#
HRRM A,ED1 ;$$SAVE REENTRY TO EDITOR
AOS ED1# ;$$
MOVSI A,(SIXBIT /ED/)
SETZ D, ;THAT RELOCATION AGAIN - SEE BELOW
PUSHJ P,SYSINI
HRLM A,LST
MOVNS A
PUSHJ P,MORCOR
PUSHJ P,SYSINP+1
POP P,A
JRST ED
GRINDEF:PUSH P,A
PUSHJ P,ED
POP P,A
JRST 2(10)>
EXCISE:
IFN ALVINE<
MOVEI A,ED+2
HRRM A,EDA>
MOVE A,JRELO
SETZM LDFLG# ;initial loader symbol table flag
CALLI A,CORE
JRST .+1
JSP R,IOBRST
JRST TRUE
PAGE
; lisp loader interface
; REG. D IS USED SINCE VARIABLES ARE MOVE WHEN LISP IS REENTRANT
LOAD: AOS B,CORUSE
MOVEM B,OLDCU#
MOVEM A,LDPAR#
JUMPE A,LOAD2
MOVE B,VBPORG(S)
SUBI B,INUM0
LOAD2: MOVEM B,RVAL# ;final destination of loaded code
MOVSI A,(SIXBIT /LOD/)
SETZ D,
PUSHJ P,SYSINI
SUBI A,150 ;extra room for locations 0 to 137 and slop
PUSH P,A
MOVNS A ;length(loader)
HRRZM A,LODSIZ#
PUSHJ P,MORCOR ;expand core for loader
MOVEM A,LOWLSP# ;location of blt'ed low lisp
MOVN B,(P) ;length(loader)
ADD B,A
MOVEM B,HVAL# ;temporary destination of loaded code
HRLI A,0
MOVE D,A ;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
BLT A,(B) ;blt up low lisp
HLL A,NAME+3(D) ;-length(loader)
HRRI A,137-1
PUSHJ P,SYSINP
SKIPE LDFLG(D)
JRST LOAD3
SETOM LDFLG(D)
MOVSI A,(SIXBIT /SYM/)
PUSHJ P,SYSINI
MOVNS A ;length symbols
PUSHJ P,MORCOR ;expand core for symbols
SKIPGE B,JOBSYM
SOS B ;if no symbol table, use original jobsym
HLRZ A,NAME+3(D) ;-length(symbols)
ADDB A,B
HLL A,NAME+3(D) ;symbol table iowd
PUSHJ P,SYSINP
HRRM B,JOBSYM
HLLZ A,NAME+3(D)
ADDM A,JOBSYM
SKIPA
LOAD3: SOS JOBSYM ;want jobsym to point one below 1st symbol
MOVE 3,HVAL(D) ;h
MOVE 5,RVAL(D) ;r
MOVE 2,3
SUB 2,5 ;x=h-r
HRLI 5,12 ;(w)
HRLI 2,11 ;(v)
SETZB 1,4
JSP 0,140 ;call the loader
MOVEM 5,RLAST#(D) ;last location loaded(in final area)
MOVE T,OLDCU(D)
MOVE A,JOBSYM
MOVEM A,JOBSYM(T)
MOVE A,JOBREL
MOVEM A,JOBREL(T) ;update jobrel
HRLZ 0,LOWLSP(D)
SOS LODSIZ(D)
AOBJN 0,.+1
BLT 0,@LODSIZ(D) ;blt down low lisp
MOVE 0,@LOWLSP ;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
MOVE B,RLAST
MOVE A,RVAL
HRL A,HVAL
SKIPE LDPAR
JRST BINLD
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,JOBSYM
SUB C,JOBSYM ;length of free core
ORCMI C,776000
AOJGE C,START ;no contraction
ADD C,JOBREL ;new top of core
MOVE B,C
PUSHJ P,MOVDWN
CALLI C,CORE ;contract core
JRST .+1
JRST START
BINLD: MOVEI C,INUM0(B)
CAML C,VBPEND(S)
JRST [ SETOM BPSFLG ;bps exceeded
JRST START]
MOVEM C,VBPORG(S) ;updat bporg
SOS C,OLDCU ;old top of core
JRST LDRET2
PAGE
SYSINI: MOVEM A,NAME+1(D)
;%% FOLLOWING IS OLD, NON-PATCHABLE CHANNEL OPEN
COMMENT &
IFN SYSPRG,< MOVE A,[XWD SYSPRG,SYSPN]
MOVEM A,NAME+3(D)>
IFE SYSPRG,< SETZM NAME+3(D)>
INIT 17
SYSDEV
0
JRST AIN.4+1
& ;%% END OF OLD CODE
;%% NEW PATCHABLE CODE (DEVICE NAME IN LOW SEGMENT)
MOVE A,SYSIN1(D) ;%% PICK UP PPN
REMOTE<
SYSIN1: XWD SYSPRG,SYSPN ;%% KEEP IN LOW SEGMENT
>
MOVEM A,NAME+3(D) ;%% RESET VALUE HERE
MOVEI A,17 ;%% SET DATA MODE
MOVEM A,SYSIN0(D) ;%%
OPEN 0,SYSIN0(D) ;%% OPEN CHANNEL 0 TO READ FILE
JRST AIN.4+1 ;%% ERROR IN OPEN IF HERE
REMOTE<
SYSIN0: 17 ;%% DUMP MODE I/O
SYSDEV ;%% INITIALLY SYSTEM DEVICE
;%% MAY BE PATCHED
;%% NOTE THAT THIS MAY REMAIN "SYS"
;%% WHEN HGHDAT IS CHANGED TO
;%% SOMETHING ELSE
0 ;%% NO BUFFERING
>
LOOKUP NAME(D)
JRST AIN.7+1
MOVE A,[IOWD 1,NAME+3] ;KLUDGE BECAUSE OF REG. D
ADD A,D
MOVEM A,INLOW(D)
INPUT INLOW(D) ;INPUT SIZE OF FILE
REMOTE<
INLOW: IOWD 1,NAME+3
0>
HLRO A,NAME+3(D)
POPJ P,
REMOTE<
NAME: SYSNAM
0
0
0>
SYSINP: MOVEM A,LST(D)
INPUT LST(D)
STATZ 740000
ERR1 AIN.8
RELEASE
POPJ P,
REMOTE<
LST: 0
0>
PAGE
MOVDWN: HRLM B,JOBSA ;##SAVE NEW JOBSA
HLRZ A,JOBSYM
JUMPE A,MOVS1
ADDI A,1(B)
HRL A,JOBSYM
HRRM A,JOBSYM
BLT A,(B) ;downward blt
POPJ P,
MOVSYM: MOVE B,JOBREL
HRLM B,JOBSA
HLRE A,JOBSYM
JUMPE A,MOVS1
ADDI B,1(A) ;new bottom of symbol table
MOVNI A,1(A)
ADD A,JOBSYM ;last loc of old symbol table
HRRM B,JOBSYM
PUSH P,C
MOVE B,JOBREL ;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
POP P,C
POPJ P,
MOVS1: HRRZM B,JOBSYM
POPJ P,
;enter with size needed in a
;exit with pointer in a to core
MORCOR: PUSH P,B
HRRZ B,JOBSYM
SUB B,CORUSE(D)
SUBM A,B ;NEEDED-JOBSYM-CORUSE(IE. NEEDED-FREE)
JUMPL B,EXPND2
ADD B,JOBREL ;new core size
CALLI B,CORE ;expand core
ERR1 [SIXBIT /CANT EXPAND CORE !/]
PUSH P,A
PUSHJ P,MOVSYM
POP P,A
EXPND2: MOVE B,CORUSE(D)
ADDM A,CORUSE(D)
MOVE A,B
POP P,B
POPJ P,
PAGE
SUBTTL HIGH SEGMENT FUNCTIONS
REMOTE<VHGHORG:BHORG>
HGHCOR: JUMPE A,NOWRT ;EXPAND CORE AND SET WRITE STATUS
PUSHJ P,NUMVAL
JUMPLE A,FALSE
CLEARB C,WRTSTS
CALLI C,SETUWP
UWPERR: ERR1 [SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
MOVE B,VHGHORG
ADD B,A
HRRZ C,JOBHRL
CAMG B,C
JRST TRUE
HRLZ A,B
CALLI A,CORE
ERR1 [SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
JRST TRUE
NOWRT: MOVEI A,1
MOVEM A,WRTSTS
CALLI A,SETUWP
JRST UWPERR
JRST TRUE
HGHORG: SKIPE A ;SET HIGH ORG. TO A AND RETURN OLD ORG.
PUSHJ P,NUMVAL
PUSH P,A
MOVE A,VHGHORG
MOVEI B,FIXNUM(S)
PUSHJ P,MAKNUM
POP P,B
SKIPE B
MOVEM B,VHGHORG
POPJ P,
HGHEND: HRRZ A,JOBHRL ;GET VALUE OF END OF HIGH SEG.
MOVEI B,FIXNUM(S)
JRST MAKNUM
;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
SETSYS: MOVE T,A ;MOVE ARGUMENT FOR UIOSUB
SETZM DEV ;## ALLOW DEFAULT TO DSK:
PUSHJ P,IOSUB ;BREAKS DOWN THE SPECIFICATION
MOVEM A,HGHDAT+1 ;SAVE THE FILE NAME
MOVE A,DEV ;GET THE DEVICE AND SAVE IT
MOVEM A,HGHDAT
MOVE A,PPN ;GET THE PPN AND SAVE IT
MOVEM A,HGHDAT+4
JRST FALSE ;RETURN NIL
REMOTE<WRTSTS: 1>
PAGE
SUBTTL REALLOC CODE
IFN REALLC <
;%% DYNAMIC REALLOCTION ROUTINE
;%%
;%% ARGUMENTS:
;%% A = FULL WORD SPACE INCREMENT
;%% B = BINARY PROGRAM SPACE INCREMENT
;%% C = REGULAR PUSHDOWN LIST INCREMENT
;%% AR1 = SPECIAL PUSHDOWN LIST INCREMENT
;%% AR2A = FREE SPACE INCREMENT
;%%
;%% ACTION:
;%% 1) PERFORMS AN EXCISE
;%% 2) ALLOCATES ADDITIONAL CORE AS REQUIRED
;%% (IF IMPOSSIBLE, SIGNALS "CAN'T EXPAND CORE")
;%% 5) UNBINDS ALL VARIABLES ON THE SPECIAL STACK
;%% AND CLEARS BOTH STACKS
;%% 4) REALLOCATES SPACE ACCORDING TO SPECIFICATIONS
;%% (NOTE THAT TOTAL CORE USED WILL BE ROUNDED
;%% UP TO A MULTIPLE OF 1K WORDS, AND ANY EXCESS
;%% WILL BE APPORTIONED TO FWS, RPDL, SPDL, AND
;%% FS.)
;%% 5) RESTARTS THE SYSTEM AT THE TOP LEVEL
;%%
REALL1: JUMPE A,.+2 ;%%NO CONVERSION IF NIL
PUSHJ P,NUMVAL ;%%CONVERT TO BINARY
ADDI T,(A) ;%%ADD TO TOTAL BEING ACCUMULATED
EXCH A,(P) ;%%PUSH ON STACK
JRST (A) ;%%AND RETURN
REALLOC:
SETZ T, ;%% CLEAR ACCUMULATOR FOR ALLOC TOTAL
MOVE TT,B ;%% SAVE SECOND ARG DURING FIRST CALL
PUSHJ P,REALL1 ;%% PROCESS FIRST ARG
MOVE A,TT ;%%
PUSHJ P,REALL1 ;%% PROCESS SECOND ARG
MOVE A,C ;%%
PUSHJ P,REALL1 ;%% PROCESS THIRD ARG
MOVE A,AR1 ;%%
PUSHJ P,REALL1 ;%% PROCESS FOURTH ARG
MOVE A,AR2A ;%%
PUSHJ P,REALL1 ;%% PROCESS FIFTH ARG
MOVE A,-4(P) ;%% PICK UP FWS INCREMENT
ADD A,SFWS ;%% MAKE NEW TOTAL FWS
IDIVI A,44 ;%% CALCULATE SPACE FOR BIT TABLE
ADDI T,1(A) ;%% ADD TO TOTAL
MOVEM T,(P) ;%% SAVE TOTAL (FS AMOUNT NOT NEEDED)
PUSHJ P,EXCISE ;%% CLEAR BUFFERS, ETC.
POP P,A ;%% GET TOTAL BACK
SETZ D, ;%% CLEAR RELOCATION REGISTER
;%% (HERE WE GO AGAIN)
PUSHJ P,MORCOR ;%% ALLOCATE THE ADDITIONAL SPACE
MOVE B,SC2 ;%% CLEAR STACKS AND UNBIND VARIABLES
PUSHJ P,UBD ;%%
HRRZ B,JOBREL ;%% GET NEW HIGH LIMIT
CAMGE B,JRELO# ;%% DID CORE GET SMALLER?
HALT . ;%% YES -- WE QUIT
MOVEM B,JRELO# ;%% RESET LIMIT
HRLM B,JOBSA ;%%
IFN ALVINE <
MOVEI A,ED+2 ;%%INDICATE ED WAS OVERWRITTEN
HRRM A,EDA ;%%SO THEY WILL BE RELOADED IF NEEDED
>
SETZM LDFLG ;%% INDICATE SYMBOLS GONE [1]
MOVE A,SFWS ;%% SAVE OLD VALUE
MOVEM A,OSFWS ;%%
MOVE A,FSO ;%%
MOVEM A,OFSO ;%%
POP P,A ;%% SPDL INCREMENT
ADDM A,SSPDL ;%% CHANGE TOTAL
MOVN AR2A,A ;%% SAVE JUST IN CASE
POP P,A ;%% RPDL INCREMENT
ADDM A,SRPDL ;%% CHANGE TOTAL
MOVN AR1,A ;%% SAVE AGAIN
POP P,A ;%% BPS TOTAL
MOVEM A,FSMOVE ;%% HOW MUCH TO MOVE FS
ADDM A,FSO ;%% NEW FS ORIGIN
ADDM A,SBPS ;%% BPS INCREMENT
POP P,A ;%% FWS INCREMENT
ADDM A,SFWS ;%% ADD TO TOTAL
JRST REALL2 ;%% JUMP INTO REGULAR ALLOCATOR
;%% (ALL DATA OFF STACK)
>
STRT:
INALLC: HRRZ A,JOBREL ;SEE IF CORE WAS EXPANDED
CAMN A,JRELO# ;OR NOT
JRST OUTALC ;NO EXPANSION - DON'T REALLOCATE
CAMG A,JRELO# ;CHECK TO SEE IF IT GOT SMALLER!
JRST 4,0 ;YES - BITCH
MOVEM A,JRELO# ;SAVE NEW CORE BOUND
HRLM A,JOBSA
IFN ALVINE,<
MOVEI F,ED+2 ;INDICATE THAT ED WAS OVERWRITTEN
HRRM F,EDA ;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
SETZM LDFLG ;%% INDICATE SYMBOLS GONE [1]
INAGN: SETZM NOALIN# ;SET UP TO ASK FOR ALLOCATION
OUTSTR [ASCIZ /
ALLOC? (Y OR N) /] ;ASK USER IF HE WISHES TO SET UP
INCHRW C ;THE ALLOCATION INCREMENTS
CAIGE C,"O"
SETOM NOALIN# ;SET FLAG SO NO INPUT IS DONE LATER
SETFWS: MOVE A,SFWS# ;SAVE OLD SIZE OF FWS
MOVEM A,OSFWS#
SKIPN NOALIN ;SKIP QUESTIONS IF AUTOMATIC
OUTSTR [ASCIZ /
FULL WORD SP. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW#
ADDI A,440 ;INITIAL ALLOCATION FOR FWS
ADDM A,SFWS# ;ADD EITHER USER INCREMENT OR 0 TO SFWS
MOVE A,FSO# ;SAVE OLD FS ORIGIN
MOVEM A,OFSO# ;FOR RELOCATION
SKIPN NOALIN ;SKIP IF USER DONE
OUTSTR [ASCIZ /
BIN. PROG. SP. = /]
JSP R,ALLNUM
ADDM A,SBPS#
MOVEM A,FSMOVE# ;THE INCREMENT TO SBPS IS THE AMOUNT BY
ADDM A,FSO# ;THE FREE SPACE IS MOVED - UPDATE ORIGIN
SKIPN NOALIN ;SKIPIF USER DONE
OUTSTR [ASCIZ /
REG. PDL. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW# ;CHECK IF INITIAL ALLOCATION
ADDI A,1000
ADDM A,SRPDL#
MOVN AR1,A ;SAVE IN CASE OF OVERFLOW
SKIPN NOALIN ;SKIP IF USER DONE
OUTSTR [ASCIZ /
SPEC. PDL. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW# ;CHECK FOR INITIAL ALLOCATION
ADDI A,1000
ADDM A,SSPDL#
MOVN AR2A,A ;SAVE IN CASE OF OVERFLOW
IFN HASH,<
SKIPN INITFW
SETOM NOALIN
SKIPN NOALIN
OUTSTR [ASCIZ /
HASH = /]
JSP R,ALLNUM
CAIG A,BCKETS
JRST OCR
HRRM A,INT1
MOVNS A
HRRM A,RH4
SETOM HASHFG>
OCR: OUTSTR [ASCIZ /
/]
REALL2: MOVE A,JRELO# ;COMPUTE SIZE OF AVAILABLE CORE
SUBI A,FS ;SO THAT EXTRA CORE CAN BE DISTRIBUTED
SUB A,SBPS ;TAKE OFF CORE ALLOCATED FOR BPS
SUB A,SFS# ;TAKE OFF CORE IN PREVIOUS FS
SUB A,SBT# ;AND ASSOCIATED BIT TABLE
SUB A,SFWS ;TAKE OFF CORE NOW ALLOCATED TO FWS
SUB A,SRPDL ;TAKE OFF CORE NOW ALLOCATED TO RPDL
SUB A,SSPDL ;TAKE OFF CORE NOW ALLOCATED TO SPDL
MOVE F,SFWS ;ESTIMATE SIZE NEEDED FOR BTF
IDIVI F,44
ADDI F,1
SUB A,F ;AND TAKE IT OFF TOTAL
MOVEM F,SBTF# ;ALSO SAVE TO RESTORE LATER
JUMPGE A,ALOK ;MAKE SURE NO OVERFLOW
OUTSTR [ASCIZ /ALLOCATIONS ARE TOO LARGE
/] ; IF SO THEN RETRY
MOVE A,OSFWS
MOVEM A,SFWS ;RESTORE SIZE OF FWS
MOVN A,FSMOVE
ADDM A,SBPS ;RESET SIZE OF BPS
ADDM A,FSO ;AND FS ORGIN
ADDM AR1,SRPDL ;RESET STACKS
ADDM AR2A,SSPDL
JRST INAGN
ALOK: MOVE B,A ;NOW CAN ALLOCATE EXCESS CORE
ACHLOC: ASH B,-4 ;1/16 TO FWS
ADDM B,SFWS
SUB A,B ;TAKE IT OFF REMAINING CORE
SKIPE INITFW
SETZ B,
ASH B,-4 ;1/64 TO PDLS
ADDM B,SSPDL
SUB A,B
ADDM B,SRPDL
SUB A,B ;AND TAKE IT OFF REMAINING CORE
MOVE T,SFWS ;CALCULATE ACTUAL SIZE OF BTF
IDIVI T,44
ADDI T,1
ADD A,SBTF ;REMOVE ESTIMATED LOSS FOR BTF
MOVEM T,SBTF
SUB A,T ;AND TAKE OFF ACTUAL LOSS TO BTF
ADD A,SFS ;ADD BACK ON SPACE FROM OLD FS
ADD A,SBT ;AND ASSOCIATED BT
;GIVING NEW SPACE AVAILABLE FOR
;FS AND BT
MOVE TT,A
IDIVI TT,41 ;SBS = SFS/32. = (SBS + SFS)/33.
ADDI TT,1
MOVEM TT,SBT
SUB A,TT ;TAKE OFF SBT FROM REMAINING CORE
MOVEM A,SFS ;GIVING AVAILABLE SFS
;SET UP REGISTERS FOR GC ETC. SETUP
MOVE A,SFWS ;A _ SFWS
MOVEI B,FS
ADD B,SFS
ADD B,SBPS ;B _ NFWSO (ORIGIN OF NEW FULL WORD SPACE)
MOVE C,SRPDL ;C _ SRPDL
MOVE F,OSFWS ;F _ OLD SIZE OF FWS
HRRM B,GCP1 ;GCP1 _ NFWSO
MOVN SP,B ;-NEW BOTTOM OF FWS
HRRM SP,GCMFWS
HRLZM A,C1GCS
MOVNS C1GCS ;-NEW LENGTH OF FWS
HRRM B,C1GCS ;HAVE FWS POINTER AND COUNT FOR SWEEP
ADD B,A ;NEW FIRST WORD OF BT (FS BIT TABLE)
MOVE SP,FSO ;SP _ NEW ORIGIN OF FS
LSH SP,-5
SUBM B,SP ;NUMBER USED TO FIND BIT TABLE WORD
HRRM SP,GCBTP1 ;FROM FS WORD ADDRESS
HRRM SP,GCBTP2
HRLM B,C3GC ;BOTTOM OF BIT TABLES
HRRM B,GCP2
HRRM B,GCP ;(ALSO UPPER BOUND ON FWS AND FS)
MOVNI SP,-2(TT) ;-SIZE OF BT (TT = SBT)
HRLM SP,C3GCS ;IOWD FOR BIT TABLE SWEEP
HRRM B,C3GCS
MOVE SP,FSO
ANDI SP,37 ;MASK OUT ALL BU LAST FIVE BITS
HRRM SP,GCBTL2 ;MAGIC NUMBER TO POSITION
SUBI SP,40
HRRM SP,GCBTL1
ADDI B,1 ;B _ B + 1
HRRM B,C3GC ;BOTTOM OF FS BIT TABLE + 1
ADDI B,-2(TT) ;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
HRRM B,C2GCS ;BEFORE USE
ADDI B,1 ;B _ B + 1
HRRM B,C2GC ;BOTTOM OF FWS BIT TABLE + 1
ADDI B,-1(T) ;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
HRRM B,GCP5 ;TOP OF BIT TABLES
ADDI B,1 ;BOTTOM OF REG PDL
MOVE S,ATMOV ;## S NOT SET IF LISP STARTED WITH CORE
;## ALREADY EXPANDED, SO RESET IT
HRRZI A,OBTBL(S) ;GET OBLIST POINTER
;## RHX2 IS NO LONGER PURE, WE WANT THE SYSTEM OBLIST
;## THIS IS IT (I HOPE)3/28/73
ADD A,FSMOVE ;INCREMENT TO
;ACCOUNT FOR MOVE OF FS
MOVEM A,(B)
HRRM B,GCP3 ;ROOM FOR ACS DURING GC
ADDI B,1 ;B _ B + 1
HRRM B,GCSP1
HRRM B,GCP4 ;ROOM FOR ACS
ADDI B,10 ;B _ B + 10
HRRM B,GCP41 ;TOP OF AC AREA
ADDI B,1 ;B _ B + 1
HRRM B,C2 ;SET UP RPDL POINTER
MOVNI A,-20(C) ;A _ - (C -20) = -(SRPDL - 20)
HRLM A,C2 ;THIS IS THE ACTUAL SIZE OF RPDL
;TAKING INTO ACCOUNT THE AC AREA
HRRZ A,JRELO# ;TOP OF CORE - FOR SPDL PTR
MOVN B,SSPDL
ADD A,B
HRL A,B
MOVEM A,SC2# ;SET UP SPDL POINTER (I HOPE)
MOVN A,A ;CREATE OFFSET FOR STACK POINTERS
ADDI A,INUM0
HRRZM A,SPNM#
SETZM INITFW ;TURN OFF INITIAL ALLOCATION FLAG
;RELOCATE THE FULL WORD SPACE
;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
MOVSI B,F
HRR B,GCP1
MOVE C,FWSO#
HRRZI AR2A,-1(C) ;TAKE THE OPPORTUNITY TO GET ADDRESS
;OF END OF OLD FS (USED LATER)
HRLI C,F
MOVE A,@C ;GET WORD FROM END OF OLD FWS
MOVEM A,@B ;AND MOVE TO END OF NEW FWS
SOJGE F,.-2 ;F COUNTS DOWN WORDS IN OLDFWS
;END OF FWS RELOCATION
MOVE FF,FSMOVE ;GET FAST ACCESS TO RELOCATE SIZE FOR FS
HRRZ F,AR2A
ADD F,FF ;AND FIND WHERE TO PUT WORDS FROM
;END OF OLD FS IN NEW FS
HRRZ AR1,GCP1 ;COMPUTE FWS RELOCATION CONSTANT
SUB AR1,FWSO
;RELOCATE FS - ALSO RELOCATE ALL
;POINTERS TO FS AND TO FWS
REL1: HLRZ A,(AR2A) ;GET CAR POINTER OF OLD FS WORD
JSP R,REL4
HRLM A,(F) ;MOVE CAR TO NEW POSITION
HRRZ A,(AR2A) ;GET CDR PTR
JSP R,REL4 ;CHECK FOR FS RELOCATE
HRRM A,(F)
SUBI F,1 ;F _ F -1
CAMLE AR2A,OFSO ;CHECK TO SEE IF DONE
SOJA AR2A,REL1 ;NO - GO LOOP
HRRZ A,GCMKL ;RELOCATE ARRAYS
JSP R,REL4
HRRZ D,A
MOVEM D,GCMKL
REL5: HLRZ AR2A,(D)
MOVE AR2A,(AR2A)
REL6: HLRZ A,(AR2A)
JSP R,REL4
HRLM A,(AR2A)
HRRZ A,(AR2A)
JSP R,REL4
HRRM A,(AR2A)
AOBJN AR2A,REL6
HRRZ D,(D)
JUMPN D,REL5
SETZM BIND3 ;JUST IN CASE
SKIPE INITF ;DON'T FORGET THE INITFN
ADDM FF,INITF
SKIPE INITF1 ;## DON'T FORGET THE INIT FILES
ADDM FF,INITF1 ;##
SKIPE NOUUOF ;RELOCATE FLAGS
ADDM FF,NOUUOF
SKIPE BACTRF
ADDM FF,BACTRF
SKIPE GCGAGV
ADDM FF,GCGAGV
SKIPE RSTSW
ADDM FF,RSTSW
JRST RELFOO
REL4: CAMGE A,EFWSO ;SEE IF BEYOND END OF FWS
CAMGE A,OFSO ;OK - SEE IF MAYBE IN FS
JRST (R)
CAMGE A,FWSO ;SEE IF IN FWS
JRST .+3
ADD A,AR1 ;RELOCATE FWS POINTER
JRST (R)
ADD A,FF ;RELOCATE FS POINTER
JRST (R)
RELFOO: MOVE S,SBPS ;S IS THE RELOCATOR FOR MOST MACRO
MOVEM S,ATMOV ;REFERENCES TO ATOMS AND FS
MOVE A,FSMOVE ;NOW IS THE TIME FOR ALL GOOD MEN TO
ADDM A,VBPEND(S) ;SET BPEND
IFE OLDNIL< ADDM A,NILPRP> ;## RESET NIL
HRR B,VOBLIST(S) ;## GET CURRENT VALUE OF OBLIST
HRRM B,RHX5 ;## RESET WORD THAT POSTINDEXES OFF B
HRRM B,RHX2 ;## RESET WORD POSTINDEXING OFF C
ADDM A,XXX3 ;## RESET WIERD CODE
ADDM A,XXX4 ;## RESET UNBOUND
ADDM A,XXX5 ;## RESET FS (SAME WORD AS FS),ALSO GCPP1
MOVE A,GCP1
HRRZM A,FWSO
MOVE A,C3GCS
HRRZM A,EFWSO#
OUTALC: CLEARB F,DDTIFG
JSP R,IOBRST
JRST START
;SUBROUTINE FOR NUMBER INPUT
;%% RETURNS 0 IF NOALIN # 0
;%% SETS NOALIN # 0 IF ALTMOD IS INPUT
;%% RETURNS 0 IF A BLANK IS INPUT
;%% IGNORES OTHER NON-NUMERIC CHARACTERS EXCEPT
;%% AS TERMINATORS OF NUMBERS
ALLNUM: SETZB A,ALLNM1# ;%% CLEAR A AND FIRST TIME FLAG
SKIPE NOALIN#
JRST (R)
INCHRW C
CAIN C,RUBOUT
JRST [OUTSTR [ASCIZ /XXX /]
JRST ALLNUM]
CAIL C,"0"
CAILE C,"9"
JRST BANGCK
SETOM ALLNM1# ;%% NOT FIRST TIME NOW
ASH A,3
ADDI A,-"0"(C)
JRST ALLNUM+3
BANGCK: CAIE C,15 ;%% TERMINATE ON CR OR
CAIN C,40 ;%% TERMINATE ON BLANK
JRST (R) ;%%
CAIN C,ALTMOD ;%% ALTMODE (TERMINATOR)?
JRST [SETOM NOALIN#
JRST (R) ] ;%% YES--TURN ON SWITCH AND RETURN
SKIPE ALLNM1# ;%% IGNORE LEADING JUNK?
JRST (R) ;%% NO--RETURN
JRST ALLNUM+3 ;%% YES--LOOP
PAGE
IFN HASH,<
REHASH:
MOVEI A,BFWS(S)
PUSH P,A
HRRM A,RHX2
HRRM A,RHX5
MOVS B,RH4#
ADD B,S ;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
;$$IN THE NEXT THREE FOO'S
HRRZI A,BFWS+1(B)
MOVEM A,BFWS(B)
AOBJN B,.-2
SETZM BFWS(B)
MOVSI AR2A,-BCKETS
HRR AR2A,S ;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
;$$DOUBLE INDEXING WITH S IN REMOVING FOO
;$$PROBLEM
RH1:
HLRZ C,OBTBL(AR2A)
RH3: JUMPE C,RH2
HLRZ A,(C)
PUSH P,C
PUSH P,AR2A
PUSHJ P,INTERN
POP P,AR2A
POP P,C
HRRZ C,(C)
JRST RH3
RH2: AOBJN AR2A,RH1
SETZM HASHFG
POP P,A
HRRM A,@GCP3
MOVEM A,OBLIST(S)
JRST START>
PAGE
SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
SPDLPT: HRRZ A,SP ;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
ADD A,SPNM
POPJ P, ;$$
;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
SPDLFT: SUB A,SPNM ;$$CONVERT TO ADDRESS
HLRE A,(A) ;$$GET LEFT HAND ITEM
JUMPL A,TRUE ;$$IF IT IS NEGATIVE IT CAME FROM A STACK
;$$POINTER AND WE RETURN T INSTEAD
HRRZI A,(A) ;$$CLEAR OUT LEFT HAND OF AC
POPJ P, ;$$RETURN - RETURNS NIL FOR LHS = 0
;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
SPDLRT: SUB A,SPNM ;$$CONVERT TO AN ADDRESS
HRRZ A,(A) ;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
POPJ P, ;$$
;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
NEXTEV: SUB A,SPNM ;$$GET POINTER INSTEAD OF INUM
HRRZ T,SC2 ;$$GET POINTER TO BOTTOM OF SPDL
SPDNLP: CAMG A,T ;$$CHECK IF HIT THE BOTTOM OF SPDL
JRST FALSE ;$$RETURN NIL IF NO MORE INTERESTING WORDS
HLL A,(A) ;$$TEST FOR WORD WITH 0 LHS
TLZE A,-1 ;$$
SOJA A,SPDNLP ;$$NOT AN INTERESTING WORD, LOOK AGAIN
ADD A,SPNM ;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
POPJ P, ;$$
;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
;$$ MORE EFFICIENT THAN EVAL WITH ALIST
EVALV: MOVE C,A ;$$ MOVE AROUND FOR ATOM CHECK
PUSHJ P,ATOM ;$$
EXCH A,C ;$$
SUB B,SPNM ;$$
EVALV1: CAIN B,(SP) ;$$CHECK FOR END OF SPDL
JRST GETV ;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
SKIPGE ,(B) ;$$CHECK TO AVOID SPDL POINTERS ON STACK
AOJA B,EVALV1 ;$$
HLRZ T,(B) ;$$T_CAR(B)
SKIPE C ;$$
HLRZ T,(T) ;$$GET CAR OF SPECIAL CELL - ATOM POINTER
CAIE T,(A) ;$$COMPARE WITH ATOM TO BE EVALUATED
AOJA B,EVALV1 ;$$NOT IT, LOOK SOME MORE
HRRZ A,(B) ;$$GET VALUE FROM SPDL
POPJ P, ;$$
GETV: JUMPE C,GETV1
MOVEI B,VALUE(S) ;$$ATOM NOT REBOUND, VALUE THEN IS
PUSHJ P,GET ;$$
JUMPE A,UNBOND ;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
GETV1: HRRZ A,(A) ;$$GET CDR OF SPECIAL CELL
POPJ P, ;$$
UNBOND: HRRZI A,UNBOUND(S) ;$$RETURN ATOM UNBOUND
POPJ P, ;$$
;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
CLRSPD: MOVEI B,-2-INUM0(A) ;$$ -2 TO GET OVER EVAL BLIP
HLRZ TT,SC2# ;$$GET REAL SPD POINTER WITH A LHS
ADD TT,B ;$$FIND OUT HOW MANY WORDS ARE USED
ADD B,SC2 ;$$
HRL B,TT ;$$SET UP SPD POINTER
JRST UBD ;$$UBD DOES ALL THE WORK
;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
;$$EVAL BLIP, WITH A GIVEN VALUE
OUTVAL: PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL BLIP
JUMPE A,FALSE ;$$ NO EVAL BLIP, RETURN NIL
HRLZI C,(POPJ P,) ;$$ SET TYPE OF RETURN
JRST SPRE1 ;$$ FINISH UP IN SPREDO
;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
REVAL1: HRRZ P,1(SP) ;$$ RPDL POINTER IS UP ONE
HRRZ T,C2# ;$$
HLRZ TT,C2# ;$$
ADD TT,P ;$$
SUB TT,T ;$$
HRL P,TT ;$$
DOSET: MOVE D,ERRTN ;$$ POP ERRSETS, LOAD CURRENT ERRSET
SKIPE D ;$$DONE IF EMPTY
CAMG D,P ;$$ COMPARE TO CURRENT RPDL
XCT C ;$$ DONE, DO A STRANGE EXIT
SUB D,[XWD 1,1] ;$$ GO DOWN A WORD
POP D,ERRSW ;$$
POP D,ERRTN ;$$
SUB D,[XWD 2,2] ;$$ SKIP PROG JUNK
JRST DOSET ;$$ TRY AGAIN
;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
SPREDO: PUSHJ P,NEXTEV ;$$FORCE TO EVAL BLIP POINTER
JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL BLIP
MOVE B,A ;$$GET THE EXPRESSION
SUB B,SPNM
HRRZ B,(B)
MOVE C,[JRST EVAL] ;$$SET RETURN
SPRE1: PUSH P,B ;$$SAVE SPDL POINTER
PUSHJ P,CLRSPD ;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
POP P,A ;$$
JRST REVAL1
;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
;
SPREVAL:PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL-BLIP
JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL-BLIP
JRST SPRE1-1 ;$$LET SPREDO FINISH UP
;$$COMPUTES A LISP POINTER TO A STACK ENTRY
STKPTR: SUB A,SPNM
POPJ P,
PAGE
SUBTTL LOW SEGMENT INCLUDING REMOTE CODE
RELOC 0
HERE
VAR
XALL
PAGE
SUBTTL LISP ATOMS AND OBLIST
FS:
DEFINE MAKBUC (A,%B)
<DEFINE OBT'A <%B=.>
XWD %B,IFN <<BCKETS-1>-A>,<.+1>
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>)
ZY==<ZY-1>/5
Q1(ZY,ZZ)
>
DEFINE Q1 (N,Z)<
IFN N,<XWD Z,[Q1(N-1,Z+1)]>
IFE N,<XWD Z,0>>
;## ARGS ARE A=NAME, B=PROP NAME, C'A=THE PROPERTY, D=LABEL OF ATOM
DEFINE MKAT (A,B,C,D)
<XLIST
IRP A< PUTOB A,.+1
D XWD -1,.+1
XWD B,.+1
XWD C'A,.+1
XWD PNAME,.+1
XWD [PSTRCT(A)],0>
LIST>
;## ARGS ARE: D'A=PROPERTY, B=PROP NAME, C=NAME
DEFINE MKAT1 (A,B,C,D)
<XLIST
IRP C <PUTOB C,.+1
XWD -1,.+1
XWD B,.+1
XWD D'A,.+1
XWD PNAME,.+1
XWD [PSTRCT(C)],0>
LIST>
DEFINE LENGTH (A,B)
<A==0
IRPC B,<A==A+1>>
;## ATOM WITH SYM PROPERTY =V'ATOM LOCATION
DEFINE ML1 (A)<IRP A,<
V'A: XWD -1,.+1
XWD FIXNUM,[A]
MKAT A,SYM,V
>>
;## SIMILAR TO ML1, EXCEPT %C=THE SYM PROP
DEFINE MKSY1 (A,B,%C)<
XLIST
%C: XWD -1,.+1
XWD FIXNUM,[A]
PUTOB B,.+1
XWD -1,.+1
XWD SYM,.+1
XWD %C,.+1
XWD PNAME,.+1
XWD [PSTRCT(B)],0
LIST>
;## ATOM WITH NO PROPS WITH LABEL SAME AS ATOM NAME
DEFINE ML (A)<
XLIST
IRP A,<PUTOB A,.+1
A: XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(A)],0>
LIST>
;## CREATE ATOM WITH NO LABEL OR PROPS. USED FOR COMMON ATMS IN SYSTEM
DEFINE MK (A)<
XLIST
IRP A,<PUTOB A,.+1
XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(A)],0>
LIST>
OBTBL:
OBLIST: ZZ==0
XLIST
REPEAT BCKETS,<MAKBUC \ZZ
ZZ==ZZ+1>
LIST
PAGE
;## GENERATE # FNS ONLY IF NONUSEFUL VALUES DESIRED
IFN NONUSE<
MKAT1 MEMBR.,SUBR,MEMBER#
MKAT1 MEMB,SUBR,MEMQ#
MKAT1 AND.,FSUBR,AND#
MKAT1 OR.,FSUBR,OR#
>
MKAT<RPLACA,RPLACD,MINUS,TERPRI,CAR,CDR,CAAR>,SUBR
MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,GET,INTERN,MEMBER>,SUBR
MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,BAKGAG,MEMQ>,SUBR
MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
MKAT<PROG1,SPRINT,LITATOM,NTHCHAR>,SUBR
IFN STPGAP,<MAKAT<PGLINE>,SUBR>
MKAT EXPLODEC,SUBR,%
MKAT TAB,SUBR,.
MKAT TYO,SUBR,I
MKAT TYI,SUBR,I
CEVAL=.+1
MKAT1 EVAL,SUBR,*EVAL
;$$ REDEF. FOR NEW MAP FUNCTIONS
MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
MKAT1 MAPCAN,LSUBR,MAPCONC
PROGAT: MKAT<PROG>,FSUBR
;##LIST STARTS HERE
MKAT LIST,FSUBR,,LISTAT:
MKAT <PROGN,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR
IFN ALVINE,<MKAT<GRINDEF>,FSUBR
MKAT<ED>,SUBR>
IFE ALVINE,<MK<GRINDEF>>
MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
MKAT1 QUOTE,FSUBR,FUNCTION
MKAT1 %CLRBFI,SUBR,CLRBFI
MKAT1 .ERROR,SUBR,ERROR
MKAT1 LINRD,SUBR,LINEREAD
MKAT1 UNBOND,SUBR,UNBOUND
MKAT1 ECHO,SUBR,TTYECHO
MKAT1 FUNCT,FSUBR,*FUNCTION
MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
;## LABELS ON READ AND LISP EVAL FOR BOOTS
MKAT READ,SUBR,,READAT:
MKAT EVAL,LSUBR,O,EVALAT:
MKAT ASCII,SUBR,A
MKAT QUOTE,FSUBR,,CQUOTE:
MKAT INUM0,SYM
PUTOB T,.+1
TRUTH: XWD -1,.+1
XWD VALUE,.+1
XWD VTRUTH,.+1
XWD PNAME,.+1
XWD [PSTRCT(T)],0
VTRUTH: TRUTH
PUTOB NIL,0
CNIL2: XWD VALUE,.+1
XWD VNIL,.+1
XWD PNAME,.+1
XWD [PSTRCT(NIL)],0
VNIL: NIL
MKSY1 %LCALL,*LCALL
MKSY1 %AMAKE,*AMAKE
MKSY1 %UDT,*UDT
MKSY1 .MAPC,*MAPC
MKSY1 .MAP,*MAP
MKAT1 %NOPOINT,VALUE,*NOPOINT
%NOPOINT: NIL
UNBOUND: XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(UNBOUND)],0
PAGE
MKAT1 EXPN1,SUBR,*EXPAND1
MKAT1 EXPAND,SUBR,*EXPAND
MKAT1 PLUS,SUBR,*PLUS,.
MKAT1 DIF,SUBR,*DIF,.
MKAT1 QUO,SUBR,*QUO,.
MKAT1 TIMES,SUBR,*TIMES,.
MKAT1 APPEND,SUBR,*APPEND,.
MKAT1 RSET,SUBR,*RSET,.
MKAT1 GREAT,SUBR,*GREAT,.
MKAT1 LESS,SUBR,*LESS,.
MKAT1 PUTSYM,SUBR,*PUTSYM
MKAT1 GETSYM,SUBR,*GETSYM
MKAT1 RPTSYM,SUBR,*RPUTSYM
MKAT1 RGTSYM,SUBR,*RGETSYM
ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
PUTOB NUMVAL,.+1
XWD -1,.+1
XWD SUBR,.+1
XWD NUMVAL,.+1
XWD SYM,.+3
XWD FIXNUM,[NUMVAL]
XWD -1,.-1
XWD .-1,.+1
XWD PNAME,.+1
XWD [PSTRCT(NUMVAL)],0
MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
;## QUEUE ATOMS AND OTHER NEW FNS.
MKAT<GTBLK,ERRCH,RDNAM>,SUBR
MKAT<INUMP,NUMTYPE>,SUBR
MKAT<UFDINP,RDFILE,MYPPN,BLKLST>,SUBR
MKAT<RENAME,DELETE,INITFL>,FSUBR
IFN QALLOW< ;%% [1]
ML<DISP,CPU,FORMS,LIMIT,COPIES>;;##
MKAT<QUEUE>,FSUBR; ;##
> ;%% [1]
MK<SUBST,COPY,*RENAME,FILBAK,LBK,DIR>
MKAT1 ISFILE,SUBR,LOOKUP
MK<NO BACKUP >
IFN QALLOW< ;%% [1]
;## MOST OF THE EXTENDED SWITCHES (NOT ALL)
IFN QSWEXT<
ML<DEAD,AFTER>
ML<MODIFY,KILL,JOB,DEPND,UNIQUE>
ML<PAGES,PLOT,PTAPE,CARD,SEQ,PRIOR,SPACE,LIMIT,HEAD>
> ;##END OF EXTENDED SWITCHES
> ;%% END OF QALLOW CONDITIONAL [1]
;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
ML ERRORX
MKAT1 INTPRP,SUBR,INITPROMPT
MKAT1 LSPRET,FSUBR,**TOP**
MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
MKAT<MEMB,NEXTEV>,SUBR
MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
MKAT<EVALV,OUTVAL>,SUBR
IFN REALLC <
;%% NEW DYNAMIC REALLOCATION FUNCTION
MKAT1 REALLO,SUBR,REALLOC
MKAT<FWCNT,FSCNT>,SUBR
>
;$$ MORE EXTENSIONS INCLUDING READ MACROS
ML READMACRO
MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,LEXORDER>,SUBR
MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
MKAT1 FALSE,FSUBR,SPECIAL
MKAT1 FALSE,FSUBR,NOCALL
MKAT1 FALSE,FSUBR,DECLARE
MKAT1 FALSE,FSUBR,NILL
MKAT1 APPLY.,SUBR,APPLY#
MKAT1 .MAX,SUBR,*MAX
MKAT1 .MIN,SUBR,*MIN
;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
MKAT1 BIOCHN,VALUE,#%IOCHANS%#
MKAT1 BPMPT,VALUE,#%PROMPTS%#
MKAT1 BINDNT,VALUE,#%INDENT
BIOCHN: NIL
BPMPT: NIL
BINDNT: INUM0
VOBLIST: OBLIST
VBASE: 8+INUM0
VIBASE: 8+INUM0
ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,
$EOF$,LABEL,FUNARG,LSUBR,MACRO>
PUTOB ?,.+1
QST: XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(?)],0
VBPORG: INUM0
VBPEND: INUM0
;MKAT ACHLOC,SYM
;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
;%% THIS WAS A PREDECESSOR TO THE FUNCTIONS UNDER SWITCH "REALLC"
;%% NO LONGER USEFUL
PAGE
;
; ALL THE ATOMS IN THE WHOLE SYSTEM
MK<USERERRORX,RPUTSYM,RGETSYM>
MK<A,ADD,AFTER,ALIAS,ARGPRINT,ASSOC#,ATM,B,BEFORE,BELOW,BEND1,BF,BI,BIND>
MK<BK,BKE,BKEV,BKEVAL,BKF,BKFNLIST,BKFV,BKPOS,BKPROG,BKSETQ,BKV>
MK<BLOCK,BLOCKED,BO,BORG1,BREAK>
MK<BREAKMACROS,BREAK0,BREAK1,BREAK1ERX,BRKAPPLY>
MK<BRKCOMS,BRKEXP,BRKFN,BRKTYPE,BRKWHEN,BROKEN,BROKENFNS>
MK<BY,C,CAIE,CAIN,CALL,CALLF,CALLF@,CAME,CAMN,CAN'T,CHANGE>
MK<CHNGDFLG,CLEARB,CLEARM,COM,COM0>
MK<COMS,COMSQ,COPYFLG,CPTR,D,DE,DEFSYM,DELETE,DF>
MK<DIFFERENCE,DIFFERENT EXPRESSION,DM,DREVERSE,DRM,DSKIN>
MK<DSKOUT,DSM,DSUBST,E,EDIT,EDIT-SAVE>
MK<EDIT4E,EDIT4F,EDIT4F1,EDIT:,EDITBF,EDIT1,EDITCOMSL>
MK<EDITE,EDITF,EDITFNS,EDITFPAT>
MK<EDITL,EDITL0,EDITL1,EDITMACROS,EDITMBD,EDITMV>
MK<EDITOPS,EDITQF,EDITRACEFN,EDITXTR,EMBED,ENTER ,ERXACTION>
MK<EX,EXCH,EXTRACT,F,F=,FF,FILES-LOADED,FINDFLAG,FNDBRKPT,FOR,FOUND>
MK<FROM,FROM?=,FS,FUNTYPE,G,GETSYM,GREATERP,GRINL,GVAL>
MK<GWD,HERE,HLLZS@,HLRZ,HLRZ@,HRLM@,HRRM,HRRM@,HRRZ,HRRZ@,HRRZS@>
MK<I,IF,IN,INSERT,INSIDE,JCALL,JCALLF,JCALLF@,JRST,JSP>
MK<JUMPE,JUMPN,KLIST,L,L0,L11,L12,LAP,LAPEVAL,LAPLST,LASTAIL>
MK<LASTPOS,LASTWORD,LASTP1,LASTP2,LASTVALUE,LC,LCFLG,LCL,LDIFF,LESSP>
MK<LEXPR,LI,LO,LP,LPQ,LPTLENGTH,LSUBST>
MK<M,MARK,MARKLST,MAX,MAXLEVEL,MAXLEVEL EXCEEDED>
MK<MAXLOOP,MAXLOOP EXCEEDED,MBD,MIN,MOVE,MOVEI,MOVEM>
MK<MOVNI,MV,N,N?,NAMESCHANGED,NEX,NOT BLOCKED,NOT EDITABLE>
MK<NOTHING SAVED,NTH,NX,OCCURRENCES,OK,OLDPROMPT,OPS,ORF,ORR>
MK<P,PLEV,PLUS,POP,POPJ,PP,PREVEV,PRINLEV,PRINTLEV>
MK<PUSH,PUSHJ,PUTSYM,QLIST,QUOTIENT,R,READBUF>
MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO> ;##REMOVE MARKER
MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
MK<START,STKCOUNT,STKNAME,STKNTH>
MK<STKSRCH,STOP,SUB,SUBPAIR,SURROUND,SW>
MK<TAILP,TCONC,TDZA,TEST,THIRD,THROUGH,THRU,TIMES,TO>
MK<TOFLG,TOPFLG,TRACE,TRACEDFNS,TTY:,TYPE,UNBLOCK,UNBREAK>
MK<UNBREAK0,UNBREAKABLEFNS,UNDEF,UNDO>
MK<UNDOLST,UNDOLST1,UNDONE,UNFIND,UNTRACE,UP>
MK<UPFINDFLG,USE,USERMACROS,WHEN,WITH,X,XTR,Y,ZZ>
MK<@,<\>,<\#\ >,<\P>,^,^^,_,__, , , ?, . ,< . UNBOUND)>>
MK<- LOCATION UNCERTAIN, = ,! ,!0,!NX,!UNDO,!VALUE,##>
MK<#1,#2,#3,$%DOTFLG,%%BKPOS,%%CMDL,%%V>
MK<%DEFINE,%DEREAD,%DEVP,%ERDEPTH,%LOOKDPTH,%PREVFN%>
MK<%PRINFN,%READIN,&,& ,<(>,<(DEFPROP >,<)>,*,*ANY*,*RSETERX,-->
MK<-IN-,::,:::,/BREAK1,:,=,==,?=,??>
MK<... , ...],BINARY PROGRAM SPACE EXCEEDED>
MK<NOT A TAIL - LDIFF,NO EVAL BLIP - RETFROM>
MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC>
MK<DSK:,INIT,LSP,NOT IN SYMBOL TABLE,& UNHAPPY>
MK<ARGUMENTS NOT FOUND,NOT BREAKABLE FUNCTION,ARGUMENT LIST?>
MK<AROUND,BREAKIN,EDBRK,BROKEN-IN,EDVAL,DREMOVE,LCONC,SUBLIS>
MK<EDITDSUBST,MAKEFN,FNDEF,LXPD,WHERE,MESS>
MK<SHOULD BE LIST,SHOULD BE LIST OF ATOMIC ARGUMENTS>
MK<FSUBR -- TAKES ONLY ONE ARGUMENT,UNBREAKABLE UNLESS 'IN' SOMETHING>
MK<EDITV,GRINPROPS,=EDITV,EDITP,ARGS,EDITFINDP>
;%% MORE NEW SYSTEM FUNCTIONS
MK<Q,%%MSGFLAG,-,SUBFUN1*RSETERX,SUBFUN2*RSETERX>
;ATOMS OF GENERATED FUNCTIONS
MK<SUBFUN1ARGPRINT,SUBFUN1BREAKIN0,SUBFUN1EDITCONT,SUBFUN1EDITL1,SUBFUN1EDOR>
MK<SUBFUN1EDVAL,SUBFUN1ERRCOM>
BFWS:
EFWS: 0
RELOC
XLIST
LIT
LIST
BHORG: 0
RELOC
PAGE
SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY)
ALLOC: CLEARM 0,SBPS ;SET UP INITIAL ALLOCATIONS FOR SPACE
HRRZI A,BFWS-FS ;THIS IS THE SIZE OF THE ORIGINAL FS
HRRZM A,SFS
HRRZI A,EFWS-BFWS ;THIS ALLOWS ONLY THE INITIAL
HRRZM A,SFWS ;FWS
HRRZI A,0 ;THE INITIAL ALLOCATION FOR SPDL
HRRZM A,SSPDL
HRRZM A,SRPDL ;AND FOR RPDL IS SET UP IN INALLC
HRRZI A,FS
HRRZM A,FSO ;THIS SETS UP INITIAL FS POINTER
HRRZI A,BFWS ;THIS SETS UP INITIAL FWS ORIGIN POINTER
HRRZM A,FWSO#
HRRZI A,EFWS
HRRZM A,EFWSO#
MOVEI A,FS
ADDM A,VBPORG ;SET UP VARIABLE FOR BPS ORIGIN
SOS A
ADDM A,VBPEND
MOVE A,JOBREL
HRLM A,JOBSA
CALLI RESET
MOVEI A,DDT
CALLI A,2 ;SET UP DDT REENTRY POINT FOR AUTOMATIC CONTROL H
MOVEI A,LISPGO
HRRM A,JOBSA
SETOM INITFW# ;FLAG FOR STANDARD INITIALIZATION OF
SETZM JRELO# ;OF SIZES, AND TO INDICATE CORE WAS EXPANDED
JRST INALLC
DEFINE MKENT (A)<
INTERNAL A>
;##DEBUG QUEUE
MKENT <CADAR,ATMOV,CADAR,CORUSE,DEBUGO,DEV>
IFN QALLOW< ;%% [1]
MKENT <COPIES> ;%% [1]
> ;%% [1]
MKENT <EXT,HGHDAT,INUM0,INUMIN,IOPPN,LISTAT,MORCOR,MOVDWN>
MKENT <NXTIO,OLDCU,SIXMAK,STNIL>
MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL>
MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET>
MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
IFN ALVINE,<MKENT<PSAV1,BKTRC>>
;%% RECENT ADDITIONS
MKENT <FLTYIA,SIXATM,BNINIT,RDFILE,UFDINP,MYPPN>
IFN QALLOW< ;%% [1]
MKENT <QUEUE> ;%% [1]
> ;%% [1]
MKENT <SYSIN0,SYSIN1,SYSINI,SYSINP>
IFN REALLC <
MKENT <FWCNT,FSCNT,REALLO>
>
;$$ FOR ALAN'S DIRECT ACCESS INPUT
MKENT <ININBF,TYI2,TYIA,INCH>
;## FOR BILL'S DIRECT ACCESS INPUT/OUTPUT
MKENT <AIN.2,AIN.4,AIN.7,AOUT.2,CHANNE>
MKENT <CHNSUB,CHTAB,DEVDAT,ENTR,IOSUB>
MKENT <LOOKIN,OUTCH,OUTERR,POPAJ,PPN,SMAC>
MKENT <TABSR1,TABSRC,TYI2E,TYI2Z,TYI3B,TYO2X>
MKENT <TYO5,AIOP,SETIN>
;$$ FOR ALVINE
MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
;%% FOR THE MODIFIED ARITHMETIC PACKAGE
MKENT <FIXNUM,FLONUM>
PAGE
END ALLOC