;;; -*-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.) ;;; ,, ;;; $ERRFRAME ;;; ;ADDRESS OF MSG IN RIGHT HALF ;;; ;FOR ERINT, LER3 ;;; ;;; [2] ERRBAD TYPE ERROR (ILL MEM REF, ETC.) ;;; ,,
;;; $ERRFRAME ;;; 0,,
.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,- 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*,[ 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 I INTERRUPTS MOVEM R,IMASK INTMSK R ;LEAVE ON ALL BUT ESC 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* 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 ) ;;; WHERE TAKES ONE OF THREE FORMS: ;;; () ;;; ( ) ;;; ( ) ;;; 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