github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-17 00:33:22 +00:00
Code Issues Releases Wiki Activity
PDP-10.its/src/l/error.155

1510 lines
34 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; -*-MIDAS-*-
;;; **************************************************************
;;; ***** MACLISP ****** MACLISP ERROR HANDLERS, AND MSGS ********
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
SUBTTL ERROR UUO HANDLERS
.SEE EPRINT
EPRNT1:
PUSHJ P,SAVX5 ;ERROR PRIN1
PUSH P,AR1 .SEE ERROR3
PUSHJ P,MSGFCK
SKIPN V%PR1
JRST EPRNT2
MOVEI B,(AR1)
CALLF 2,@V%PR1
JRST EPRNT3
EPRNT2: TLO AR1,200000
PUSHJ P,$PRIN1
EPRNT3: STRT 17,[SIXBIT \ !\]
POP P,AR1
JRST RSTX5
ERROR1: MOVEM TT,UUTTSV
MOVEM R,UURSV
EROR1Z: JSP TT,ERROR9 ;PROCESS A LISP ERROR
JRST EROR1A ; (LERR AND LER3)
PUSHJ P,MSGFCK
MOVEI D,-2(P) ;D POINTS TO ERRFRAME
PUSHJ P,ERROR3
EROR1A: MOVEI A,NIL
JRST 2,@[ERRRTN]
;;; MSGFILES CHECK. GET VALUE OF MSGFILES IN AR1 AFTER CHECKING FOR
;;; VALIDITY. IF A LOSER, SIGNAL AN ERROR AFTER RESTORING IT TO (T).
;;; SAVES A.
MSGFCK: HRRZ AR1,VMSGFILES
SFA$ JSP F,MSGFC1 ;MAKE SURE AN SFA NEVER GETS INVOKED FROM
SFA$ 0 ; MPFLOK, BUT STILL DO VALIDITY CHECK
SFA$ MSGFC1:
PUSHJ P,MPFLOK ;SKIPS IF LIST OF FILES *NOT* VALID
CMSGFCK: POPJ P,MSGFCK
PUSH P,A
MOVEI B,QTLIST
MOVEI A,QMSGFILES
PUSHJ P,BDGLBV
POP P,A
JRST MSGFCK
SUBTTL ERRFRAME FORMATS
;;; FORMAT OF ERRFRAME:
;;;
;;; [1] NORMAL TYPE ERROR (ERINT, LERR, ETC.)
;;; <SP>,,<RETURN FROM ERROR IF ERINT>
;;; $ERRFRAME
;;; <UUO> ;ADDRESS OF MSG IN RIGHT HALF
;;; <S-EXP> ;FOR ERINT, LER3
;;;
;;; [2] ERRBAD TYPE ERROR (ILL MEM REF, ETC.)
;;; <SP>,,<ADDRESS WHERE ERROR OCCURRED>
;;; $ERRFRAME
;;; 0,,<ADDRESS OF MSG>
.SEE ERRBAD
ERROR9: PUSH P,UUOH
HRLM SP,(P)
PUSH P,[$ERRFRAME] ;RANDOMNUMBER,,EPOPJ
PUSH P,40 ;CANNOT HAVE LH = 0; SEE ERRPRINT
PUSH P,A
LERFRAME==:4 ;LENGTH OF ERRFRAME - WATCH THIS IN CASE OF CHANGE
IFN ITS,[
.SUSET [.SPICLR,,XC-1]
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
] ;END OF IFN ITS
IFN D10+D20, PUSHJ P,REAINT ;RE-ENABLE INTERRUPTS
EROR9A: SKIPN PSYMF
SKIPE ERRSW
JRST 1(TT)
JRST (TT)
;;; ERROR RETURN. COME HERE TO PERFORM AN ERROR BREAKOUT (RETURN
;;; TO ERRSET OR TOP LEVEL). VALUE TO RETURN FROM ERRSET IN A.
ERRRTN: SETZM NOQUIT
IFN ITS,[
.SUSET [.SPICLR,,XC-1]
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
] ;END OF IFN ITS
IFN D10+D20, PUSHJ P,REAINT ;RE-ENABLE INTERRUPTS
PUSH P,A
SKIPL A,UNREAL
PUSHJ P,CHECKU ;CHECK FOR ANY DELAYED "REAL TIME" INTS
POP P,A
ERR2: SKIPE ERRTN ;TO TOPLEVEL, OR BREAK OUT OF AN ERRSET
JRST ERR0 ;GO BREAK UP AN ERRSET
LSPRT0: PUSH FXP,CATRTN ;RETURN TO TOP LEVEL FROM LISP ERROR
JSP A,ERINI0
POP FXP,CATRTN ;GJS NEEDS TO THROW FROM A *RSET-TRAP
CLSPRET:
SETZ A,LSPRET
SKIPE B,V.TRAP ;INVOKE *RSET-TRAP
CALLF 1,(B)
MOVE A,VERRLIST
MOVEM A,VIQUOTIENT
JUMPE A,LSPRET
HRRZ T,C2
HRRZ T,1(T)
CAIE T,HACENT ;MEANS BUG ON ERRLIST
JRST LSPRET
MOVE A,VERRLIST
MOVEI B,QERRLIST
PUSH P,CLSPRET
SUBTTL ERINT, SERINT, LERR, LER3
;ERROR3: 0 ;PRINT OUT ERROR MESSAGE FOR ORDINARY
; LISP ERRORS (LERR, LER3, ERINT, SERINT)
ERROR3: ;CALLED VIA PUSHJ P,ERROR3
;POINTER TO $ERRFRAME IN D
JUMPE AR1,CPOPJ
MOVEI A,TRUTH ;PREVENT AUTO-TERPRI IN THE
JSP T,SPECBIND ; MIDDLE OF AN ERROR MESSAGE
0 A,V%TERPRI ;SPECBIND SAVES D
HRLI AR1,200000 ;OUTPUT FILES LIST FOR MSG IN AR1
LDB TT,[331100,,1(D)] ;P HAS BEEN STACKED UP BY ERROR9
JUMPE TT,EROR3C ;ERRBD2 PUSHS MSG WITH NO LERR OPERATION
HRRZ A,2(D) ;MUST FETCH THE S-EXPRESSION TO PRINT
STRT AR1,[SIXBIT \^M;!\] ;PRECEDE MSG WITH A ";"
CAIE TT,LERR_-33 ;LERR DOESN'T PRINT AN S-EXP
PUSHJ P,EPRINT
CAIN TT,SERINT_-33 ;SERINT HAS AN S-EXP MSG
JRST EROR3F
LDB A,[270400,,1(D)] ;IF IT IS LERR OR LER3, THEN
CAIE TT,ERINT_-33 ; A NON-ZERO AC FIELD MEANS
JUMPN A,EROR3F ; THE MSG IS AN S-EXP
EROR3C:
STRT AR1,@1(D) ;NOTE: THIS CLOBBERS UUOH LEVEL VARS
EROR3E: STRT AR1,STRTCR
JRST UNBIND
EROR3F:
HRRZ A,1(D)
PUSHJ P,$PRINC
JRST EROR3E
;;; PROCESS ERINT/SERINT CORRECTABLE INTERRUPTS
ERROR5: MOVEM TT,UUTTSV
MOVEM R,UURSV
SKIPN ERRTN ;ALLOW USER INTERRUPT TO RUN,
JRST EROR5F ; EVEN IF INSIDE AN ERRSET,
SKIPN VERRSET ; IF THE ERRSET BREAK IS SET
JRST ERROR1 ;OTHERWISE, JUST DO NORMAL ERROR
EROR5F: LDB TT,[270400,,40]
CAIGE TT,NERINT ;TT HAS AC FIELD FROM UUO
SKIPN VUDF(TT)
JRST ERROR1 ;CONVERT TO LER3 IF NOT ENABLED
MOVEI T,ERRV ;NORMAL XIT FROM CODE BELOW IS POP2J,
CAIE TT,<%IOL_-27>&17 ;IO-LOSSAGE
CAIN TT,<%FAC_-27>&17 ;FAIL-ACT
MOVEI T,EVAL.A
EROR5A: PUSH FXP,T
MOVEI T,(TT) ;SAVE AC NUMBER FOR BELOW
JSP TT,ERROR9 ;PUSH AN ERROR FRAME
JFCL
MOVEI A,(A)
PUSH FXP,T
JSP T,PDLNMK
EXCH D,(FXP)
CAIG D,<%UGT_-27>&17
PUSHJ P,ACONS
PUSH P,A ;FOR GC PROTECTION ONLY
TRO D,2000 ;ERINT SERIES USER INTERRUPT
HRLI D,(A)
MOVE TT,UUTTSV
MOVE T,UUTSV
SKIPN INHIBIT
SKIPE NOQUIT
.VALUE ;STUPID TO SIGNAL ERROR WHEN INTERRUPTS LOCKED
PUSHJ P,UINT
POP FXP,D
SUB P,R70+1 ;GC PROTECTION NO LONGER NEEDED
JUMPE A,EROR6A
PUSH FXP,TT
SKOTT A,LS
JRST EROR6A
POP FXP,TT
HLRZ A,(A) ;IF ATOM RETURNED, THEN CRAP OUT
;OTHERWISE, RETURNED VALUE IS LIST OF
POPJ FXP, ;CORRECT QUANTITY MUST GO TO EVAL.A OR ERRV
EROR6A: MOVE A,(P) ;RESTORE A
MOVEI TT,EROR1Z ;USER DIDN'T SUPPLY SUITABLE VALUE
JRST EROR9A ;SO ERROR OUT
ERRV: SUB P,R70+LERFRAME-1 ;CLEAR OUT ALL BUT RETURN ADDRESS
POPJ P,
;;; IOJRST UUO DECODER. USAGE:
;;; .CALL FOO ;OR .OPEN, OR WHATEVER
;;; IOJRST N,FOO
;;; IOJRST CAUSES A TRANSFER TO FOO AFTER PUTTING IN C THE
;;; ADDRESS OF A SIXBIT (STRT FORMAT) STRING INDICATING THE
;;; ERROR MESSAGE. THIS MESSAGE MAY BE GIVEN TO AN ERINT
;;; UUO (TYPICALLY %IOL). N IS THE NUMBER OF THINGS ON THE
;;; REGPDL ABOVE THE RETURN ADDRESS - THIS IS A CROCK SO THAT
;;; IOJRST CAN STICK THE ADDRESS OF A RESTORATION ROUTINE
;;; ON THE PDL. (THIS ISN'T DONE IN THE D10 VERSION, HOWEVER.)
;;; FOR ITS, THE MOST RECENT ERROR AS DETERMINED BY .BCHN IS
;;; OBTAINED VIA THE ERR DEVICE AND STACKED UP ON FLP.
;;; FOR D10, TT IS ASSUMED TO CONTAIN THE LOOKUP/ENTER/RENAME
;;; ERROR CODE OF INTEREST, AND IS USED TO INDEX A TABLE.
;;; FOR D20, THE MOST RECENT ERROR IS OBTAINED FROM THE ERSTR
;;; JSYS AND STACKED UP ON FLP.
;;; CLOBBERS THE JCL BUFFER!
;;; USER INTERRUPTS SHOULD BE INHIBITED.
ERRIOJ:
10% PUSH P,A ;SAVE ACS
10% PUSH P,B
IFN D10,[
HRRE C,TT ;ISOLATE ERROR CODE
SKIPL C ;IF TT CONTAINS SOME WEIRD
CAILE TT,LERTBL ; VALUE, JUST CALL IT THE
SKIPA C,ERTBL-1 ; "UNKNOWN ERROR"
MOVE C,ERTBL(C) ;OTHERWISE USE A STANDARD MESSAGE FROM THE TABLE
] ;END OF IFN D10
IFN ITS+D20,[
PUSHN P,2 ;PUSH 2 SPARE PDL SLOTS
LDB A,[270400,,40] ;GET N
ADDI A,2 ;ADD 2 FOR PUSHED ACS
MOVEI C,(P)
ERIOJ1: MOVE B,-2(C) ;SHUFFLE PDL UP TWO SLOTS
MOVEM B,(C)
SUBI C,1
SOJG A,ERIOJ1
MOVEM FLP,-1(C) ;SAVE CURRENT FLP POINTER
MOVEI A,ERIOJ9 ;PLOP IN ADDRESS OF RESTORATION ROUTINE
MOVEM A,(C)
MOVEI C,1(FLP)
PUSH FXP,C
IFN ITS,[
.SUSET [.RBCHN,,A]
.CALL ERIO6B
.LOSE 1400
.CALL ERIOJ6 ;GET MOST RECENT ERROR FOR THIS JOB
.LOSE 1400
MOVE A,[440700,,JCLBF]
MOVEI B,LJCLBF*BYTSWD-1
.CALL ERIO6A ;READ IT IN USING A SIOT
.LOSE 1400
.CLOSE TMPC,
] ;END OF IFN ITS
IFN D20,[
HRROI 1,JCLBF
HRLOI 2,.FHSLF ;GET MOST RECENT ERROR FOR THIS FORK
HRLZI 3,-<LJCLBF*BYTSWD-1>
ERSTR
HALT ;GROSS ERROR
JFCL ;BUFFER NOT BIG ENOUGH
] ;END OF IFN D20
IDPB NIL,A
MOVEI A,'# ;# IS THE STRT QUOTE CHARACTER
PUSH FXP,[440700,,JCLBF]
ERIOJ2: MOVSI B,(440600,,(FLP))
PUSH FLP,R70
ERIOJ3: ILDB C,(FXP) ;GET A CHARACTER OF THE ERROR MESSAGE
CAIGE C,40
JRST ERIOJ8 ;ANY CONTROL CHARACTER TERMINATES IT
CAIGE C,140 ;CONVERT CHARACTER TO SIXBIT,
SUBI C,40 ; ALLOWING LOWER CASE TO WORK
ANDI C,77
CAIE C,'# ;SOME CHARACTERS REQUIRE QUOTING
CAIN C,'^
JRST ERIOJ5
CAIN C,'!
JRST ERIOJ5
ERIOJ4: IDPB C,B ;DEPOSIT SIXBIT ON FLP
TLNE B,770000
JRST ERIOJ3
JRST ERIOJ2 ;NO MORE ROOM - MUST PUSH ANOTHER WORD
ERIOJ5: IDPB A,B ;DEPOSIT QUOTING CHARACTER
TLNE B,770000
JRST ERIOJ4 ;GO DEPOSIT REAL CHARACTER
MOVSI B,(440600,,(FLP))
PUSH FLP,R70 ;NEED ANOTHER WORD FIRST
JRST ERIOJ4
ERIOJ8: POPI FXP,1 ;FLUSH THE BYTE POINTER ON FXP
POP FXP,C
ERIOJ7: MOVEI A,'! ;MUST WRITE TERMINANTION INTO STRING
IDPB A,B
POP P,B ;RESTORE A AND B
POP P,A
] ;END OF IFN ITS+D20
MOVE T,UUTSV
JRST @40 ;THAT'S 40, NOT UUOH! MUST EFFECT A TRANSFER
IFN ITS,[
ERIO6B: SETZ
SIXBIT/STATUS/
A ;BAD CHANNEL
402000,,A ;STATUS RETURNED
ERIOJ6: SETZ
SIXBIT \OPEN\ ;OPEN FILE
1000,,TMPC ;CHANNEL NUMBER
,,[SIXBIT \ERR\] ;DEVICE NAME
1000,,3 ;3 MEANS ERROR STATUS IN FN2
400000,,A
ERIO6A: SETZ
SIXBIT \SIOT\ ;STRING I/O TRANSFER
1000,,TMPC ;CHANNEL NUMBER
,,A ;BYTE POINTER
400000,,B ;BYTE COUNT
] ;END OF IFN ITS
IFN ITS+D20,[
;;; RESTORATION ROUTINE
ERIOJ9: POP P,FLP ;RESTORE FLP
POPJ P, ;NOW REALLY RETRN FROM ORIGINAL FUNCTION
] ;END OF IFN ITS+D20
IFN D10,[
;;; TABLE OF STANDARD LOOKUP/ENTER/RENAME ERRORS
[SIXBIT \UNKNOWN ERROR!\]
ERTBL:
OFFSET -.
ERFNF%:: [SIXBIT \FILE NOT FOUND!\]
ERIPP%:: [SIXBIT \NON-EXISTENT PPN!\]
ERPRT%:: [SIXBIT \PROTECTION VIOLATION!\]
ERFBM%:: [SIXBIT \FILE BUSY BEING MODIFIED!\]
ERAEF%:: [SIXBIT \FILE ALREADY EXISTS!\]
ERISU%:: [SIXBIT \ILLEGAL SEQUENCE OF UUOS!\]
ERTRN%::
SA% [SIXBIT \TRANSMISSION ERROR!\]
SA$ [SIXBIT \DIFFERENT FILENAME SPECIFIED!\]
ERNSF%::
SA% [SIXBIT \NOT A SAVE FILE!\]
SA$ [SIXBIT \THIS ERROR CAN'T HAPPEN!\]
ERNEC%::
SA% [SIXBIT \NOT ENOUGH CORE!\]
SA$ [SIXBIT \BAD RETRIEVAL ##10!\]
ERDNA%::
SA% [SIXBIT \DEVICE NOT AVAILABLE!\]
SA$ [SIXBIT \BAD RETRIEVAL ##11!\]
ERNSD%::
SA% [SIXBIT \NO SUCH DEVICE!\]
SA$ [SIXBIT \DISK IS FULL!\]
IFE SAIL,[
ERILU%:: [SIXBIT \ILLEGAL UUO!\]
ERNRM%:: [SIXBIT \NO ROOM ON FILE STRUCTURE!\]
ERWLK%:: [SIXBIT \DEVICE WRITE-LOCKED!\]
ERNET%:: [SIXBIT \NOT ENOUGH MONITOR TABLE SPACE!\]
ERPOA%:: [SIXBIT \PARTIAL ALLOCATION ONLY!\]
ERBNF%:: [SIXBIT \BLOCK NOT FREE!\]
ERCSD%:: [SIXBIT \CAN'T SUPERSEDE DIRECTORY!\]
ERDNE%:: [SIXBIT \CAN'T DELETE NON-EMPTY DIRECTORY!\]
ERSNF%:: [SIXBIT \SFD NOT FOUND!\]
ERSLE%:: [SIXBIT \SEARCH LIST EMPTY!\]
ERLVL%:: [SIXBIT \SFD NESTED TOO DEEP!\]
ERNCE%:: [SIXBIT \NO-CREATE FOR ALL SEARCH LISTS!\]
ERSNS%:: [SIXBIT \NON-SWAPPED SEGMENT!\]
ERFCU%:: [SIXBIT \CAN'T UPDATE FILE!\]
ERLOH%:: [SIXBIT \SEGMENTS OVERLAP!\]
ERNLI%:: [SIXBIT \NOT LOGGED IN!\]
] ;END OF IFE SAIL
LERTBL==:.
OFFSET 0
] ;END OF IFN D10
SUBTTL DEC-10 HAIRY PDL OVERFLOW HANDLER (NEWIO)
IFN D10*<PAGING-1>,[
PDLOV: MOVE F,INTPDL ;INTERRUPT ROUTINES MUST LOAD INTPDL INTO F
MOVE R,IPSWD1(F) ;GET OLD INTERRUPT MASK
IFN D10,[
IFE SAIL,[
TRZ R,AP.CLK ;LEAVE ON ALL EXCEPT CLOCK INTS
MOVEM R,IMASK ;REMEMBER, ALLOW PDL OV IN PDL OV HANDLER
APRENB R,
] ;END IFE SAIL
IFN SAIL,[
TLZ R,4 ;TURN OFF <ESC>I INTERRUPTS
MOVEM R,IMASK
INTMSK R ;LEAVE ON ALL BUT ESC<I> AND CLOCK INTS
] ;END IFN SAIL
] ;END IFN D10
HLRZ R,NOQUIT
JUMPN R,GCPDLOV ;PDL OV IN GC - LOSE, LOSE, LOSE!!!
MOVEI R,P ;NOW, AS GLS SAYS, "20 QUESTIONS"
JUMPGE P,PDLH0
MOVEI R,SP
JUMPGE SP,PDLH0
MOVEI R,FLP
JUMPGE FLP,PDLH0
MOVEI R,FXP
JUMPGE FXP,PDLH0
HLRZ R,NOQUIT
SKIPN R
LERR [SIXBIT \RANDOM PDL OVERFLOW!\]
JRST INTXT2
PDLH0: HRRZ D,OC2-P(R) ;GET ORIGION OF OVERFLOW AREA
CAIGE D,@(R) ;IF OVER THEN LOSE
JRST PDLLOS
CAIG D,@(R) ;IF EQUAL THEN WE HAVE REALLY OVERFLOWED
JRST PDLOV1
;IF WE ARRIVE HERE THEN WHAT HAS HAPPENED IS THAT A ROUTINE IS FORCING A
;RECALCULATION OF THE LENGTH OF THE PDL AND THERE DOES NOT ACTUALLY
;EXIST A PDL OV. THEREFORE, ALL WE HAVE TO DO IS TO CALCULATE THE
;NUMBER OF WORDS REMAINING IN THE PDL AND RETURN TO MAINLINE.
HRRZ D,(R) ;GET PDL POINTER
HRRZ F,C2-P(R) ;GET PDL ORIGION
SUBI D,(F) ;COMPUTE NUMBER OF WORDS USED
HLRZ F,C2-P(R) ;GET FULL SIZE OF PDL
ADDI F,(D) ;COMPUTER CURRENT SIZE
HRLM F,(R) ;STORE LENGTH IN PDL POINTER
HRRZ F,INTPDL ;THEN JUST RETURN NORMALLY
JRST INTXT2
;HERE IF WE HAVE A REAL PDL OV BUT STILL HAVE SOME EMERGENCY SPACE TO USE
PDLOV1: MOVE F,OC2-P(R) ;GET OVERFLOW POINTER
MOVEM F,(R) ;STORE IN APPROPRIATE PDL
MOVSI D,QREGPDL-P(R)
HRRI D,1005 ;PDL-OVERFLOW
HRRZ R,INTPDL
HRRZ R,IPSPC(R)
CAIL R,UINT0 ;AVOID DEEP INTERRUPT RECURSION:
CAILE R,EUINT0 ; IF PDL OVERFLOWED WITHIN UINT0,
JRST PDLH4 ; THEN JUST STACK UP THE INTERRUPT,
JSR UISTAK ; AND SOMEONE WILL EVENTUALLY TRY CHECKI
PDLRET: HRRZ F,INTPDL
JRST INTXT2
PDLH4: MOVE R,FXP ;ELSE TRY TO GIVE A PDL OVERFLOW
SKIPE GCFXP ; USER INTERRUPT IMMEDIATELY
MOVE FXP,GCFXP ;REMEMBER, PDL OVERFLOW IS NOT
PUSH FXP,R ; DISABLED INSIDE THE PDL
PUSHJ FXP,$IWAIT ; OVERFLOW HANDLER!!!
JRST XUINT
JRST INTXIT
PDLLOS: MOVE P,C2
MOVE FXP,FXC2
SETZM TTYOFF
STRT UNRECOV
STRT @PDLMSG-P(R)
JRST DIE
PDLMSG: POVPDL ;REG
POVFLP ;FLONUM
POVFXP ;FIXNUM
POVSPDL ;SPEC
] ;END OF IFN D10*<PAGING-1>
SUBTTL UNRECOVERABLE PDL OVERFLOW ACTION
PDLOV5:
IFN ITS,[
.SUSET [.SPICLR,,XC-1]
.SUSET [.SDF1,,R70]
.SUSET [.SDF2,,R70]
] ;END OF IFN ITS
IFN D10+D20, PUSHJ P,REAINT ;RE-ENABLE INTERRUPTS
STRT UNRECOV
STRT (B)
SKIPN ERRTN ;BACK TO TOPLEVEL IF NOT ERRSET
JRST LSPRET
JSP T,GOBRK ;BREAK UP THE ERRSET, AND SEE IF
MOVEI A,NIL
HRRZ TT,OFXC2 ;ENOUGH PDL SPACE WAS RELEASED
HRRZ D,OSC2 ;THEREBY. IF NOT, THEN DO MAJOR
CAILE D,(SP) ;RESTART
CAIG TT,(FXP)
JRST PDLOV6
HRRZ D,OC2
HRRZ TT,OFLC2
CAILE D,(P)
CAIG TT,(FLP)
JRST PDLOV6
JRST (T) ;HERE IS ERRSET'S ERROR EXIT
PDLOV6: SETZM TTYOFF
MOVE P,C2
PUSHJ P,ERRPNU ;UNDO SPECIAL BINDINGS, NO UNWIND-PROTECTS RUN
STRT MESMAJ
JRST LISPGO ;BIG RESTART
SUBTTL ILLEGAL OPERATION AND MEMORY VIOLATION HANDLER
ERRBAD: MOVE T,UUTSV
MOVEM D,ERRSVD
SETZM JPCSAV ;TOO LATE TO GET JPC
MOVE D,UUOH
IFN ITS,[
JRST UUOGL2
UUOGL1: MOVEM D,ERRSVD
MOVE D,UUOGLEEP
];END IFN ITS
UUOGL2:
IT$ SUBI D,THIRTY+5 ;SEE IF LOSING INSTRUCTION WAS AN X
IT$ TRNN D,-1
IT$ JRST $XLOST
IT$ ADDI D,THIRTY+5-1 ;ELSE MOVE PC BACK TO LOSING INST
SKIPN VMERR ;SKIP IF USER HANDLER
JRST UUOGL7
PUSH FXP,ERRSVD ;YES, SET UP USER INTERRUPT
PUSH FXP,D
HRLI D,(D)
HRRI D,UIMILO+100000 ;ILLEGAL OPERATION
PUSHJ P,UINT
POP FXP,ERRSVD
POP FXP,D
JRST 2,@ERRSVD ;RESTORE MACHINE FLAGS
UUOGL7: EXCH D,ERRSVD ;NO USER HANDLER
IT$ .CALL UUOGL8 ;CRAP OUT TO DDT
10$ OUTSTR [ASCIZ\?ILLEGAL INSTRUCTION - BAD ERROR\]
.VALUE
IFN ITS,[
UUOGL8: SETZ
SIXBIT \LOSE\ ;TELL DDT WE'RE LOSING
1000,,1+.LZ %PIILO ;ILLEGAL OPERATION
400000,,ERRSVD ;NEW PC
] ;END OF IFN ITS
SUBTTL MISCELLANEOUS ERROR ROUTINES
;; A REVERSE LISTIFICATION FOR ERROR ROUTINES -- GENERALLY YOU
;; FIND A VALUE IN A, AND YOU WANT TO LISTIFY IT AND CONS ONTO THAT
;; SOME QUOTED VALUE
%%RLFE: PUSHJ P,NCONS
HRRZ B,@(P)
PUSHJ P,XCONS
JRST POPJ1
UUONVE: PUSHJ P,%%RLFE
,,QNUMBERP
FAC [NUMBER FUNCTION RETURNED NON-NUMERIC VALUE!]
JRST UUONVL
NTHIEN: WTA [ILLEGAL ELEMENT NUMBER - NTH/NTHCDR!]
JRST NTHCD5
NTHER: %WTA NAPLMS
JRST NTHCD2
LASTER: %WTA NAPLMS
JRST LAST
UUOMER: HRRZ A,40
LER3 [SIXBIT \ - MACRO NOT PERMITTED IN UUO CALL!\]
UUOFER: HRRZ A,40
LER3 [SIXBIT \ - WRONG NUMBER ARGS IN UUO CALL!\]
IFN BIGNUM,[
REMAIR: WTA [FLONUM ARG TO REMAINDER!]
JRST -4(T)
] ;END OF IFN BIGNUM
UNOVER:
IFE NARITH, TLNN T,100 .SEE %PCFXU ;FLOATING UNDERFLOW
IFN NARITH, TLNN A,100 .SEE %PCFXU ;FLOATING UNDERFLOW
OVFLER: LERR [SIXBIT \ARITHMETIC OVERFLOW!\]
UNFLER: LERR [SIXBIT \ARITHMETIC UNDERFLOW!\]
ER4: LERR [SIXBIT \GO OUT OF CATCH-BREAK DAMN#!!\]
ADEAD: JFCL ;PUSHJ OR JRST THROUGH DEAD ARRAY PTR
MOVEI A,ARQLS ;COULD ALSO GET HERE VIA ACALL/AJCALL
FAC [ARRAY DEFINITION LOST!]
EG1: UGT [NOT SEEN AS PROG TAG!]
JRST GO2
INTNCO: UNLOCKI ;INTERN CRAP-OUT
PUSHJ FXP,SAV2
MOVEI B,OBARRAY
MOVEI A,QOBARRAY
PUSHJ P,BDGLBV
PUSHJ FXP,RST2
JRST INTRN4
DFPER: POPI P,1
POP P,A
WTA [WRONG FORMAT - DEFPROP!]
JRST DEFPROP
DEFNER: POPI P,1
POP P,A
WTA [WRONG FORMAT - DEFUN!]
JRST DEFUN
REVER: %WTA NAPLMS
JRST REV4
NAPLMS: SIXBIT \ARGUMENT MUST BE A PROPER LIST!\
PNGE:
PNGE1: %WTA NASER
JRST -2(T)
NASER: SIXBIT \ATOMIC SYMBOL REQUIRED!\
SBADSP: SIXBIT \ BAD SPACE TYPE - STATUS!\
;;; INCREDIBLE CROCK TO CONSTRUCT AN ERROR MESSAGE
;;; CONTAINING THE NAME OF THE APPROPRIATE CAR/CDR FUNCTION.
CA.DER: PUSH FXP,[SIXBIT \ILLEGA\]
PUSH FXP,[SIXBIT \L DATU\]
PUSH FXP,[SIXBIT \M - CX\]
PUSH FXP,[SIXBIT \R!!!! \]
CA.DE1: TRNN T,776
JRST CA.DE2
ROT T,-1
JRST CA.DE1
CA.DE2: MOVEI D,-1(FXP)
HRLI D,060600
CA.DE3: ROT T,1
MOVEI TT,'A
TRNE T,1
MOVEI TT,'D
IDPB TT,D
TRNN T,400000
JRST CA.DE3
MOVEI TT,'R
IDPB TT,D
%WTA -3(FXP)
SUB FXP,R70+4
JRST CR1A
NILSETQ: PUSH P,A ;SOME NERD TRIED TO SETQ NIL, MAYBE?
PUSH P,CPOPAJ
CAIE T,VNIL
JRST TSETQ ;NO, 'TWAS REALLY A TSETQ, MAYBE?
MOVEI A,QNILSETQ
%FAC NIHIL
TSETQ: CAIE T,VT
JRST XSETQ ;NO, I DON'T KNOW WHAT IT WAS!
MOVEI A,QTSETQ
%FAC VERITAS
XSETQ: HRLM T,QXSET1 ;HAND VALUE CELL (?) TO LOSER
MOVEI A,QXSETQ
%FAC PURITAS
STORE5: PUSH P,CSTOR7
STOREE: HRRZ A,-2(P)
%WTA [SIXBIT \NOT VALID ARRAY REFERENCE - STORE!\]
MOVEM A,-2(P)
CSTOR7: POPJ P,STORE7
RPLCA0: WTA [BAD ARG - RPLACA!]
JRST RPLACA
RPLCD0: WTA [BAD ARG - RPLACD!]
JRST RPLACD
RPLCA1: WTA [PURE ARG - RPLACA!]
JRST RPLACA
RPLCD1: WTA [PURE ARG - RPLACD!]
JRST RPLACD
%ARR0A: WTA [WRONG TYPE ARRAY - ARRAYCALL!]
JRST %ARR0B
%ARR0: WTA [NOT ARRAY POINTER!]
%ARR0B: MOVEM A,1(D)
JRST %ARR7
LDGETQ: FAC [CAN'T GET DDT SYMBOL - FASLOAD!]
LDXERR: LERR [SIXBIT \BAD VALUE FOR "PURE" - FASLOAD!\]
10$ LDYERR: LERR [SIXBIT \BAD VALUE FOR *PURE - FASLOAD!\]
LDALREADY:
FAC [INCORRECTLY NESTED FASLOAD!]
IFE BIGNUM*DBFLAG*CXFLAG,[
LDATE9: QBIGNUM
QDOUBLE
QCOMPLEX
QDUPLEX
LDATER:
HN% SKIPA A,LDATE9-3(T)
HN$ MOVE A,LDATE9-3(T)
] ;END OF IFE BIGNUM*DBFLAG*CXFLAG
HN% FASHNE: MOVEI A,QHUNK
IFE HNKLOG*BIGNUM*DBFLAG*CXFLAG, LER3 [SIXBIT \IN FASL FILE, BUT NOT IMPLEMENTED IN THIS LISP!\]
.SEE DBCONS
.SEE CXCONS
.SEE DXCONS
IFE DBFLAG*CXFLAG, NUM1MS: SIXBIT \CONS IN COMPILED CODE, BUT NOT IMPLEMENTED IN THIS LISP!\
IBSERR: MOVEI B,IN10
MOVEI A,QIBASE
PUSH P,[RD0B1]
;; BaD GLoBal Variable routine -- enter with name of variable in A,
;; with a default 'good' value in B, and with return address on stack
BDGLBV: PUSH P,C
HLRZ C,(A) ;GET SY2 BLOCK
HRRZ C,(C) ; THEN ADDR OF VALUE CELL
EXCH B,(C) ;SET LOSING VARIABLE TO WINNING VALUE
POP P,C
CALLF 2,QLIST
FAC [BAD VALUE FOR SYSTEM GLOBAL VARIABLE!]
BASER: MOVEI B,IN10
MOVEI A,QBASE
PUSH P,[PRINI]
JRST BDGLBV
IFN USELESS,[
%LVERR: SETZ B,
MOVEI A,Q%LEVEL
PUSH P,[%LVCHK]
JRST BDGLBV
%LNERR: SETZ B,
MOVEI A,Q%LENGTH
PUSH P,[%LNCHK]
JRST BDGLBV
] ;END OF IFN USELESS
SUBTTL A PANDORA'S BOX OF ERROR MESSAGES
NIHIL: SIXBIT \NIHIL EX NIHIL - DON'T SETQ NIL!\
VERITAS: SIXBIT \VERITAS AETERNA - DON'T SETQ T!\
PURITAS: SIXBIT \FOO - DON'T SETQ PURE VALUE CELL!\
POVPDL: SIXBIT \REG PDL OVERFLOW!\
POVFLP: SIXBIT \FLONUM PDL OVERFLOW!\
POVFXP: SIXBIT \FIXNUM PDL OVERFLOW!\
POVSPDL: SIXBIT \SPEC PDL OVERFLOW!\
MESMAJ: SIXBIT \^M;MAJOR RESTART UNDERTAKEN^M!\
UNRECOV: SIXBIT \^M;UNRECOVERABLE !\
FLNMER:
$ARERR: SIXBIT \NON-FLONUM VALUE!\
IARERR:
FXNMER: SIXBIT \NON-FIXNUM VALUE!\
DB$ DBNMER: SIXBIT \NON-DOUBLE VALUE!\
CX$ CXNMER: SIXBIT \NON-COMPLEX VALUE!\
DX$ DXNMER: SIXBIT \NON-DUPLEX VALUE!\
NMV3: SIXBIT \NON-NUMERIC VALUE!\
IFN BIGNUM+CXFLAG, NMV5: SIXBIT \UNACCEPTABLE NUMERIC VALUE!\
CAMMES: SIXBIT \FIXNUM CANT COMPARE TO FLONUM. IN =, <, OR >!\
MES5: SIXBIT \UNDEFINED FUNCTION OBJECT!\
MES6: SIXBIT \UNBOUND VARIABLE!\
MES14: SIXBIT \NOT INSIDE LEXPR/LSUBR!\
MES18: SIXBIT \TOO MANY ARGUMENTS - APPLY!\
MES19: SIXBIT \TOO FEW ARGUMENTS - APPLY!\
MES20: SIXBIT \WRONG NUMBER OF ARGS!\
MES21: SIXBIT \WRONG NUMBER OF ARGS TO FSUBR!\
; EMS11: SIXBIT \HOW THE HELL CAN THIS BE?!\ .SEE HHCTB
EMS12: SIXBIT \TOO MANY INTERRUPTS - GO AWAY!\
EMS13: SIXBIT \LOST USER INTERRUPT!\
EMS15: SIXBIT \UNDEFINED FUNCTION IN UUO CALL!\
EMS16: SIXBIT \MORE THAN 5 ARGS!\
EMS18: SIXBIT \FUNCTION UNDEFINED AFTER AUTOLOAD!\
EMS21: SIXBIT \IMPROPER USE OF MACRO - EVAL!\
EMS22: SIXBIT \ILGL GO OR RETURN - NOT INSIDE A PROG!\
EMS25: SIXBIT \UNEVALUABLE DATUM - EVAL!\
EMS26: SIXBIT \FILE NOT FOUND!\
EMS29: SIXBIT \NO CATCH FOR THIS TAG - THROW!\
EMS31: SIXBIT \INVALID ARG TO GENSYM!\
EMS34: SIXBIT \NOT SUBR POINTER!\
STRTCR: SIXBIT \^M!\
NFXIX: SIXBIT \NON-FIXNUM INDEX!\
IXEXBD: SIXBIT \INDEX EXCEEDS BOUNDS!\
;READER ERROR MSGS
RDRM1: SIXBIT \EXTRA CHARS - READLIST!\
RDRM2: SIXBIT \ILLEGAL TOKEN PARSED - READ!\
RDRM3: SIXBIT \NOT ENOUGH CHARS - READLIST!\
RDRM4: SIXBIT \DOT CONTEXT ERROR!\
RDRM5: SIXBIT \READ-MACRO CONTEXT ERROR!\
RDRM6: SIXBIT \BLAST, MISSING ")"!\
RDRM7: SIXBIT \BLAST? - READ!\
RDRM8: SIXBIT \NUMERIC OVERFLOW - READ!\
RDRM9: SIXBIT \SPLICING MACROS RETURN NON-NIL AFTER "." -- READ!\
RDRM11: SIXBIT \ILLEGAL VALUE FROM SPLICING MACRO -- READ!\
NAFOS:
SFA$ SIXBIT \NOT A FILE OR SFA!\
SFA% SIXBIT \NOT A FILE!\
SUBTTL YET MORE MISCELLANEOUS ERROR ROUTINES
ERRERC: POP P,A ;LIKE (ERROR MSG ARGS)
LER3 1,@(P)
ERRERO: MOVEI A,(B)
WTA [INVALID ERROR CHANNEL SPEC!]
JRST ERRERB
ERERER: MOVEI D,Q$ERROR
SOJA T,S2WNAL
EVAL.A: SUB P,[LERFRAME,,LERFRAME] ;CLEAR OUT ALL OF ERRFRAME
PUSHJ P,SAVX5 ;SAVE EVERYTING AND EVAL A
PUSHJ FXP,SAV5M1 ;ORDINARY FAIL-ACT ERROR.
PUSHJ P,EVAL
EVAL.1: PUSHJ FXP,RST5M1
JRST RSTX5
.UDT: SKOTTN A,FX+BN ;COME HERE WHEN COMPILED CODE CANT
JRST .UDT2 ; FIND A TAG FOR A COMPUTED "GO"
SKIPN ERRSW
JRST .UDT1
PUSH P,A
STRT 17,[SIXBIT \^M;IN !\] ;USE MSGFILES, SINCE UGT BELOW WILL
HRRZ B,-1(P) ;GET RETURN ADDRESS
HRRZ AR1,VMSGFILES
TLO AR1,200000
PUSHJ P,ERRAD1 ;AND PRINT OUT FUN THEREFOR
POP P,A
.UDT1: UGT [ UNDEFINED COMPUTED GO TAG!]
POPJ P,
.UDT2: SETZM PNBUF
SETZM PNBUF+1
SETZM PNBUF+2
MOVEI C,10.
MOVEI R,.UDT4
MOVE AR1,[440700,,PNBUF]
JUMPGE TT,.+3
MOVNS TT
%NEG%
PUSHJ P,PRINI9
SETOM LPNF
MOVEI C,(AR1)
JRST RINTERN
; ENDCODE [.UDT]
ESB6: MOVEI D,0
WNAERR: CAMG TT,T
SKIPA TT,[MES19] ;TOO FEW ARGS
MOVEI TT,MES18 ;TOO MANY ARGS
MOVEM B,QF1SB
PUSH FXP,TT
TRNE D,1 ; 1.1 of D ^= 0 => LISTING ALREADY DONE
JRST WNAER1
PUSH FXP,R
PUSHJ FXP,LISTX
POP FXP,R
WNAER1: HLRZ B,(P)
PUSHJ P,XCONS
MOVEM A,(P)
PUSHJ P,ARGSCU
POP FXP,TT
JRST QF1A
QF3A: SKIPA TT,[MES19] ;AT THIS POINT, WE CRAP OUT
QF2A: MOVEI TT,MES18
MOVE T,R
PUSHJ FXP,LISTX
HLRZ B,(P)
JUMPN B,.+2
MOVEI B,QM ;QUESTION MARK!
PUSHJ P,XCONS
EXCH A,(P)
JSP T,%CADR
QF1A: PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
%WNA (TT)
JRST EVAL
UUOH3C: SOVE A B
MOVEI T,EMS18
JRST UUOUE1
UUOH3A: SOVE A B
UUOUER: MOVEI T,EMS15
UUOUE1: MOVNI A,LUUSV ;UNDEFINED UUO CALL
PUSH FXP,UUOH+LUUSV(A)
AOJL A,.-1
PUSH FXP,40
HRRZ A,40
%UDF (T) ;UNDEF FUN IN UUO CALL (OR AFTER AUTOLOAD)
POP FXP,40
MOVEI T,LUUSV
POP FXP,UUOH-1(T)
SOJG T,.-1
HRRZ T,A
JUMPN A,UUOUE2
HRRZ A,40
PUSHJ P,EPRINT
LERR [SIXBIT \UNDEFINED FUNCTION CALLED!\]
UUOUE2: POP P,B
POP P,A
CAIE T,QUNBOUND
JRST UUOH0A
JRST UUOH3A
EPRINT: SKIPN ERRSW ;ERROR PRINTOUT
POPJ P,
JRST EPRNT1
EV3B: SKIPA A,EV0B
EV3A: HLRZ A,AR1
%UDF MES5 ;UNDEFINED FUNCTION OBJECT
JRST EV4B
EV3J: HLRZ A,AR1
%UDF EMS18 ;FN UNDEF AFTER AUTOLOAD
JRST EV4B
IAP2A: TDZA TT,TT ;UNDEFINED FN OBJECT
IAP2J: MOVEI TT,EMS18-MES5 ;FN UNDEF AFTER AUTOLOAD
HLRZ A,(C)
SKIPN A
HRRZ A,(C)
%UDF MES5(TT)
HRRM A,(C)
JRST ILP1
WNAL0: MOVE D,(TT)
TLNE D,1 ;SKIP IF LSUBR
JRST WNAFOSE
WNALOSE:
PUSHJ FXP,LISTX ;LISTIFY UP LSUBR ARGS
MOVEI TT,MES20 ;USE LSUBR MESSAGE
WNAL1: MOVEI B,(D)
PUSHJ P,XCONS ;CONS FUNCTION NAME ONTO ARG LIST
PUSH P,A
MOVEI A,QM ;USE ? FOR ARGS SPEC
JRST QF1A
STERR: MOVEI D,(F)
WNAFOSE: MOVEI TT,MES21 ;USE FSUBR MESSAGE
JRST WNAL1
IFN D10,[
FASLUR: RELEASE TMPC,
FASLUH: UNLOCKI
LERR [SIXBIT \CAN'T DEPURIFY HIGH SEGMENT!\]
] ;END OF IFN D10
FASLNX:
PG% SETZM LDXSIZ
PG$ SETZM LDXLPC
FASLNC:
HRRZ A,LDBSAR
PUSHJ P,$CLOSE
LERR [SIXBIT \NO MORE ADDRESS SPACE - FASLOAD!\] ;TOTAL LOSS
LDFERR:
HRRZ A,LDBSAR
PUSHJ P,$CLOSE
UNLOCKI
MOVE A,LDFNAM
MOVEI B,QFASLOAD
PUSHJ P,XCONS
PUSHJ P,UNBIND
SUB P,R70-LDPRLS+1
FAC [FILE NOT IN FASLOAD FORMAT!]
LMBERR: EXCH A,C
MOVE R,T
WTA [BAD LAMBDA LIST!]
MOVE TT,C
JRST IPLMB1
LXPRLZ: LERR [SIXBIT \TOO MANY ARGS TO LEXPR!\]
DOERRE: MOVEI A,(B)
WTA [ BAD END TEST FORM - DO!]
MOVEI B,(A)
JRST DO4C
GETLE: EXCH A,B
GETLE1: %WTA NAPLMS
EXCH A,B
JRST GETL
SETWNA: POP P,A
MOVEI B,QSETQ
PUSHJ P,XCONS
PUSHJ P,NCONS
WNA [ODD NUMBER OF ARGS - SETQ!]
JRST EVAL
SIGNPE: MOVE A,(P)
WTA [BAD TEST REQUEST - SIGNP!]
MOVEM A,(P)
JRST SIGNP0
PROPER: WTA [BAD ARG - PUTPROP!]
JRST PUTPROP
RMPER0: WTA [BAD ARG - REMPROP!]
JRST REMPROP
LFYER: PUSHJ P,%%RLFE ;NOT INSIDE LSUBR
,,QLISTIFY ;LET LOSER FIGURE IT OUT
%FAC MES14
GENSY8: %WTA EMS31
PUSH P,A
JRST GENSY7
ARGCM8: WTA [ARG OUT OF RANGE - ARG/SETARG!]
JRST ARGCOM
ARGCM0: MOVEI R,-1(R) ;NOTE: FLUSHES FLAGS IN LEFT HALF!
CAIN R,ARGXX
JRST ARGCM1
CALLF 2,QLIST
MOVEI B,QSETARG
JRST ARGCM2
ARGCM1: PUSHJ P,NCONS
MOVEI B,QARG
ARGCM2: PUSHJ P,ACONS ;LISTIFY AGAIN, WITHOUT LOSING B
PUSHJ P,XCONS
%FAC MES14
PTRCKE: PUSH P,A
MOVEI A,(TT)
%WTA EMS34
MOVEI TT,(A)
POP P,A
JRST PTRCHK
.STOLZ: PUSH P,B
PUSHJ P,%%RLFE
,,QM
MOVEI B,QSTORE
PUSHJ P,XCONS
POP P,B
PUSH P,T
FAC [CAN'T STORE INTO NON-ARRAY!]
TYOAGE: WTA [NOT ASCII VALUE!]
JRST TYOARG
EOFER: MOVEI B,QRDEOF
MOVEI T,[SIXBIT \END OF FILE WITHIN READ!\]
PUSHJ P,EOFE
JRST EOF5
RDLNER: PUSHJ P,SINFGET ;GETS VINFILE IN AR1
MOVEI B,Q%READLINE
MOVEI T,[SIXBIT \END OF FILE WITHIN A LINE!\]
EOFE: MOVEI A,(AR1)
PUSHJ P,NCONS
PUSHJ P,XCONS
PUSHJ P,[%FAC (T)]
JUMPE A,CPOPJ
SKIPE T,EOFRTN ;CLOBBER IN EOF VALUE IF NON-NIL
HRRM A,-LERSTP-1(T) ; AND IF EOF FRAME EXISTS
POPJ P,
IFE ITS,[
IIOERR: LERR [SIXBIT \I/O ERROR DURING INPUT!\]
OIOERR: LERR [SIXBIT \I/O ERROR DURING OUTPUT!\]
] ;END OF IFE ITS
MAPWNA: MOVEI D,QMAPLIST-MAPLIST-1(TT)
SOJA T,WNALOSE
MEMQER: EXCH A,(P)
%WTA NAPLMS
MOVE B,A
EXCH A,(P)
JRST (T)
DLTER: CAIE B,MEMBER
SKIPA D,[QDELQ]
MOVEI D,QDELETE
JRST WNALOSE
LIST.9: MOVEI D,QLIST. ;ZERO ARGS => ERROR
SOJA D,WNALOSE
SUSPE: PUSHJ P,%%RLFE
,,QSUSPEND
MOVE TT,FXP ;TO ALLOW RETURNS FROM THE FAC, FXP
SUB TT,R70+1 ; MUST BE RESTORED
SKIPE (FXP)
MOVE TT,(FXP) ;IF TOP OF FXP NON-ZERO THEN IS POINTER
MOVE FXP,TT ; TO OLD FXP; RESTORE CORRECT FXP
FAC [I/O IN PROGRESS - CAN'T SUSPEND!]
GTPDL1: WTA [NOT PDL POINTER!]
JRST GTPDLP
RAND9: MOVEI D,QRANDOM
S2WNAL: SOJA T,S1WNAL
TYPKER: MOVEI D,QTYIPEEK
S1WNAL: SOJA T,WNALOSE
GRCTIE: EXCH A,B
WTA [BAD READTABLE INDEX!]
EXCH A,B
JRST GRCTI
FRERR: WTA [NOT A FRAME POINTER!]
JRST FRETURN
IFN USELESS,[
CRSRP2: WTA [BAD CURSORPOS CODE!]
JRST CRSRP3
] ;END OF IFN USELESS
ALST0: MOVE A,-1(P)
WTA [BAD ALIST - EVAL/APPLY!]
MOVEM A,-1(P)
JRST ALIST
LFY0: WTA [ARG TOO LARGE - LISTIFY!]
JRST LISTIFY
IFN ITS+SAIL,[
ALCK0: EXCH A,B
WTA [BAD ARG - ALARMCLOCK!]
JRST ALARMCLOCK
] ;END OF IFN ITS+SAIL
PRGER1: EXCH A,AR2A
WTA [BAD VAR LIST - PROG!]
EXCH A,AR2A
JRST PRG1
DOERR: POP P,A
WTA [BAD VAR LIST - DO!]
MOVEM A,-2(P)
JRST DO5
DO5ER: MOVEI A,(B)
WTA [EXTRANEOUS STEPPER - DO!]
JRST DO5Q
ATAN.7: LERR [SIXBIT \OVERFLOW/UNDERFLOW IN ATAN!\]
EXP.ER: MOVE D,[EXPER1,,[SIXBIT \ARG TOO BIG - EXP!\]]
JRST NUMER
EXPER1: EXCH A,B
JRST EXP.
SIN.ER: SKIPA D,[SIN.,,[SIXBIT \ARG TOO BIG FOR ACCURACY - SIN!\]]
COS.ER: MOVE D,[COS.,,[SIXBIT \ARG TOO BIG FOR ACCURACY - COS!\]]
JRST NUMER
SQR$ER: SKIPA D,[SQRT.,,[SIXBIT \NEG ARG - SQRT!\]]
LOG.ER: MOVE D,[LOG.,,[SIXBIT \NON-POS ARG - LOG!\]]
NUMER: JSP T,PDLNMK ;IF ARG WAS A PDL NUM, GET A REAL ONE
%WTA (D) ;COMPLAIN TO LOSER
HLRZS D
JRST 2,@D
IARERR
$ARERR
ARTHER: %WTA @.-1(T)
JRST ARITH
1EQNF: TDZA T,T
1GPNF: MOVEI T,$GREAT-$EQUAL
EXCH A,B
%WTA CAMMES
JRST $EQUAL(T)
2EQNF: TDZA T,T
2GPNF: MOVEI T,$GREAT-$EQUAL
%WTA CAMMES
EXCH A,B
JRST $EQUAL(T)
ALHNKE: PUSH P,A
PUSH FXP,TT
MOVEI A,(FXP)
WTA [CAN'T CREATE A HUNK OF THIS SIZE!]
POPI FXP,1
MOVE TT,(A)
POP P,A
JRST ALHUNK
GCMLOSE:
JUMPN A,GCMLS1
HRRZ A,GCMES+NFF(F)
POP FXP,F
JRST GCMLS2
GCMLS1: HRRZ C,GCMES+NFF(F)
JSR GCRSR
GCMLS2: SETOM PANICP
%GCL GCLSMS
SETZM PANICP
POP P,A
SETOM IRMVF ;ON GENERAL PRINCIPLES, GCTWA ONCE
JRST AGC
GCMES: QLIST
QFIXNUM
QFLONUM
DB$ QDOUBLE
CX$ QCOMPLEX
DX$ QDUPLEX
BG$ QBIGNUM
QSYMBOL
IFN HNKLOG,[
RADIX 10.
REPEAT HNKLOG+1, CONC QHUNK,\.RPCNT
RADIX 8
] ;END OF IFN HNKLOG
QARRAY
QSYMBOL ;FOR SYMBOL-BLOCKS, SIMPLY SAY "SYMBOL"
IFN .-GCMES-NTYPES-1+1, WARN [WRONG LENGTH TABLE]
GCLSMS: SIXBIT \STORAGE CAPACITY EXCEEDED!\
;;; COME HERE WHEN THINGS LOOK REALLY DESPERATE IN GC.
GCLUZ0: TDZA A,A
GCLUZ: MOVEI A,TRUTH
SKIPN PANICP ;HOPE FOR THE BEST, JPG!
SKIPE INHIBIT ;GC-LOSSAGE CAN'T WIN IF INHIBITED
CAIA
JRST GCMLOSE
JUMPN A,GCLUZ1
SKIPE A,F ;IF A HAD (), THEN GCRSR ALREADY DONE
HRRZ A,GCMES+NFF(F)
POP FXP,F
JRST GCLUZ2
GCLUZ1: SKIPE C,F
HRRZ C,GCMES+NFF(F) ;WELL, IT LOOKS LIKE WE
JSR GCRSR ; HAVEN'T EVEN A SNOBOL'S
GCLUZ2: SETZM TTYOFF ; CHANCE IN HELL HERE...
JUMPE A,GCLUZ6
PUSHJ P,PRINT ;TELL LOSER HE LOST TOTALLY
GCLUZ3: STRT 17,GCLSMS
STRT 17,[SIXBIT \ BEYOND RECUPERATION!\]
SKIPLE IRMVF
JRST GCLUZ7
GCLUZ5: MOVEI TT,SPDLORG
CAILE TT,(SP) ;IF WE LOST OUT GC'ING AT TOP
JRST DIE ; LEVEL, WE ARE TOTALLY LOST
GCLUZ4: STRT 17,MESMAJ ;OTHERWISE WE HAVE HALF A CHANCE
PUSHJ P,ERRPNU ; OF FREEING UP SOME STORAGE (NO UNWIND-PRO'S)
JRST LISPGO ; BY UNBINDING SPECIAL VARIABLES
GCLUZ6: STRT 17,[SIXBIT \SYMBOL BLOCK!\]
JRST GCLUZ3
GCLUZ7: SETOM IRMVF
JRST GCLUZ4
GCPDLOV: SETZM TTYOFF
MOVE P,C2
MOVE FXP,FXC2
STRT 17,[SIXBIT \^M;PDL OVERFLOW WHILE IN GC#!!\]
JRST GCLUZ5
;;; COME HERE WHEN EVERY HOPE FOR RECOVERY HAS BEEN EXHAUSTED.
DIE: STRT 17,[SIXBIT \^M;YOU HAVE LOST BADLY#!^M!\]
.VALUE
JRST DIE
SUBTTL ERROR ADDRESS DECODER
ERRADR: SKIPE AR1,TAPWRT
HRRZ AR1,VOUTFILES
ERRAD1: PUSH P,AR1
PUSHJ P,ERRDCD
POP P,AR1
JRST $PRIN1
ERRDCD: MOVEI A,QM ;DECODE ADDRESS AS SUBR OR ARRAY
10$ CAIL B,ENDFUN ; PROPERTY OF SOME ATOM
10% CAIGE B,BEGFUN ;ADDRESS 0 ALWAYS GIVES OUT QM - SEE BK1A1B
CPRIN1: POPJ P,PRIN1 ;ERRDCD SAVES T (SEE WNALOSE)
10$ CAIL B,BEGFUN
10% CAIGE B,ENDFUN
JRST ERRO2E
CAIL B,BBPSSG
CAMLE B,BPSH
POPJ P,
ERRO2E:
10$ MOVEI AR2A,BBPSSG
10% MOVEI AR2A,BEGFUN
LOCKI ;GCGEN IS NOT INTERRUPT SAFE
JSP R,GCGEN
ERRO2Q
UNLKPOPJ
ERRO2Q: SKIPE INTFLG ;LET INTERRUPTS HAPPEN - THIS IS A VERY
JRST ERRO2R ; LONG PROCESS FOR LARGE OBARRAYS!
ERRO2A: HLRZ TT,(D)
ERRO2C: HRRZ TT,(TT)
JUMPE TT,ERRO2B
HLRZ AR1,(TT)
HRRZ TT,(TT)
CAIN AR1,QLSUBR
JRST ERRO2H
CAIE AR1,QSUBR
CAIN AR1,QFSUBR
JRST ERRO2H
CAIE AR1,QARRAY
JRST ERRO2C
HLRZ AR1,(TT)
HRRZ TT,(AR1)
CAML B,@VBPEND ;IF ARG IS < BPEND, THEN CANT BE AN ARRAY
CAIGE TT,-3(B)
JRST ERRO2B
JRST ERRO2G
ERRO2H: HLRZ TT,(TT)
10$ CAIL B,HILOC ;IF ARG IS IN HIGH SEGMENT,
10$ JRST ERRO2G ; MUST BE SUBR
CAML B,@VBPORG
JRST ERRO2B ;IF ARG > BPORG, THEN CANT BE A SUBR [MUST BE ARRAY]
ERRO2G: CAMLE TT,AR2A
CAMLE TT,B
JRST ERRO2B
MOVE AR2A,TT
HLRZ A,(D)
ERRO2B: HRRZ D,(D)
JUMPN D,ERRO2A
JRST GCP8A
ERRO2R: HRRZ AR1,VOBARRAY
MOVEI TT,(F)
SUB TT,TTSAR(AR1)
UNLOCKI ;GIVE A POOR INTERRUPT
LOCKI ; A CHANCE IN LIFE
ADD TT,TTSAR(AR1)
HRRI F,(TT)
JRST ERRO2A
SUBTTL ERROR, ERRFRAME, ERRPRINT
BEGFUN==.
$ERROR: JUMPE T,EROR1A ;(ERROR) SIMPLY ACTS LIKE (ERR)
AOJE T,[LERR 1,@(P)] ;(ERROR MSG)
AOJE T,ERRERC
AOJN T,ERERER
POP P,A
ERRERB: MOVEI B,(A)
CAIL A,QUDF
CAIL A,QUDF+NERINT
JRST ERRERN
10$ MOVEI D,(A)
10$ SUBI D,QUDF
.ELSE HRREI D,-QUDF(A)
JRST ERRERD
ERRERN: PUSHJ P,FIXP
JUMPE A,ERRERO
MOVEI D,-5(TT)
JUMPL D,ERRERO
ERRERD: CAIL D,NERINT ;# USER INTERRUPT ERRORS - RANGE FROM 0 TO NERINT-1
JRST ERRERO
MOVEI A,POP1J ;(ERROR MSG ARGS CHNO)
EXCH A,(P)
IORI D,<(SERINT)>_-5
DPB D,[2715_30 -1(P)]
XCT -1(P) ;THIS WINS FOR FAIL-ACT, FOR IT WILL
POPJ P, ; POPJ BY ISELF WITHOUT COMING HERE;
; DITTO FOR IO-LOSSAGE.
SUBR: HRRZ B,(A) ;SUBR 1
JRST ERRDCD
;;; ERRFRAME TAKES PDL POINTER, AND RETURNS AN ERROR FRAME.
;;; FORM OF RETURNED VALUE:
;;; (ERR <REGPDL PTR> <ERROR MSG> <SPECPDL PTR>)
;;; WHERE <ERROR MSG> TAKES ONE OF THREE FORMS:
;;; (<MESSAGE>)
;;; (<MESSAGE> <LOSING S-EXP>)
;;; (<MESSAGE> <LOSING S-EXP> <TYPE>)
;;; I.E. IT IS A LIST OF ARGS SUITABLE FOR THE ERROR FUNCTION.
ERRFRAME: JSP R,GTPDLP ;SUBR 1
$ERRFRAME ;MUST APPEAR TWICE
$ERRFRAME
JRST FALSE
POPI D,1
PUSH FXP,D
PUSHJ FXP,SAV5M1
MOVE D,2(D) ;D SHOULD POINT TO JUST BELOW THE FRAME MARKER
PUSH P,R70
LSHC D,-33
LSH R,-40
CAIGE D,ERINT_-33
JRST EPR6
MOVEI A,QUDF(R)
PUSHJ P,ACONS
MOVEM A,(P)
EPR6: HRRZ A,(FXP)
HRRZ A,3(A)
HRRZ B,(P)
PUSHJ P,CONS
MOVEM A,(P)
HRRZ A,(FXP)
HRRZ A,2(A)
CAIN D,ERINT_-33
JRST EPR7
CAIE D,SERINT_-33
SKIPE R
JRST EPR5
EPR7: HRLI A,440600 ;IF MSG IS SIXBIT, MUST CREATE
MOVEM A,CORBP ; AN ATOMIC SYMBOL WHOSE PRINT NAME
MOVEI T,EPR1 ; IS THE MESSAGE
PUSHJ FXP,MKNR6C
PUSHJ P,RINTERN
EPR5: POP P,B
PUSHJ P,CONS
PUSH P,CR5M1PJ
PUSH P,A
POP FXP,D
JRST FRM4
EPR1: ILDB BYTEAC,CORBP
CAIN BYTEAC,'! ;! IS END OF MESSAGE
POPJ P,
CAIN BYTEAC,'^ ;^ CONTROLIFIES NEXT CHARACTER
JRST EPR3
CAIN BYTEAC,'# ;# QUOTES NEXT CHAR
ILDB BYTEAC,CORBP
EPR4: ADDI BYTEAC,40
JRST POPJ1
EPR3: ILDB BYTEAC,CORBP ;THIS "CONTROLIFICATION" ALGORITHM
ADDI BYTEAC,40 ; CONVERTS ^M TO CTRL/M, BUT ALSO ^4 TO
TRC BYTEAC,100 ; LOWER CASE T, ETC.; HENCE CAN REPRESENT
POPJ P, ; ALL OF ASCII USING ^ AS AN ESCAPE
ERRPRINT: ;LSUBR (1 . 2)
JSP F,PRNARG
[QERRPRINT]
TRNE AR1,-1 ;IF THERE IS ALREADY SOME MSGFILE TO GET THE MSG,
TLO AR1,200000 ; THEN INHIBIT AUTO-FORCT TO TTY
PUSHJ P,OFCAN
JSP R,GTPDLP ;PRINT OUT ERROR MESSAGE STACKED ON
$ERRFRAME ; PDL JUST PRIOR TO POINT SPECIFIED BY ARG
$ERRFRAME ;EXTRA COPY OF $ERRFRAME
JRST FALSE
PUSHJ P,ERROR3
JRST TRUE
;OUTPUT FILE CANONICALIZER. MAKES CONTENTS OF AR1
; INTO AN ORDINARY LIST SUITABLE FOR FEEDING TO STRT.
OFCAN: PUSH P,A ;SAVES T
MOVEI A,(AR1)
SKIPGE AR1
PUSHJ P,ACONS
HRRZ B,V%TYO
TLNN AR1,200000
PUSHJ P,XCONS
MOVEI AR1,(A)
JRST POPAJ
Reference in New Issue View Git Blame Copy Permalink