;;; -*-MIDAS-*- ;;; ************************************************************** ;;; ***** MACLISP ****** LISP INTERPRETER AND SYSTEM ************* ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** .SYMTAB 16001.,5000. ;ENSURE ROOM FOR MANY SYMBOLS AND LITERALS! TITLE ***** MACLISP ****** LISP INTERPRETER AND SYSTEM ************* .NSTGWD ;NO STORAGE WORDS PLEASE UNTIL FIRSTLOC .XCREF A,B,C,AR1,AR2A,T,TT,D,R,F,P,FXP,% .MLLIT==1 SUBTTL ASSEMBLY PARAMETERS IF1,[ ;***** CONDITIONAL ASSEMBLY FLAGS AND PARAMETERS ***** ;" FOR ASSLIS - DO NOT PUT ANY OTHER DOUBLE QUOTES ON THIS PAGE ITS==0 ;1 FOR RUNNING UNDER THE ITS MONITOR TOPS10==0 ;1 FOR RUNNING UNDER DEC TOPS-10 MONITOR TOPS20==0 ;1 FOR RUNNING UNDER DEC TOPS-20 MONITOR SAIL==0 ;1 FOR RUNNING UNDER SAIL MONITOR TENEX==0 ;1 FOR RUNNING UNDER THE TENEX MONITOR CMU==0 ;1 FOR RUNNING UNDER THE CMU MONITOR ;LATER WE WILL DEFINE D10==TOPS10\SAIL\CMU AND D20==TENEX\TOPS20 KA10==0 ;1 FOR KA10 PROCESSOR (WILL ALSO WORK ON KI AND KL) KI10==0 ;1 FOR KI10 PROCESSOR (WILL ALSO WORK ON KL) KL10==0 ;1 FOR KL10 PROCESSOR ONLY ML==0 ;1 SAYS THIS LISP IS FOR ML (OR MC) INSTEAD OF AI (ONLY IF ITS==1) BIGNUM==1 ;MULTIPLE PRECISION ROUTINES FLAG OBTSIZ==777 ;LENGTH OF OBLIST PTCSIZ==40 ;MINIMUM SIZE FOR PATCH AREA NEWRD==0 ;NEW READER FORMAT ETC JOBQIO==1 ;SUPPORT FOR INFERIOR PROCEDURES HNKLOG==9 ;LOG2 OF SIZE (IN WORDS) OF LARGEST HUNK (0 => NO HUNKS) SFA==0 ;1 FOR SFA I/O NIOBFS==1 ;NUMBER OF I/O BUFFERS FOR D10 SYSTEMS USELESS==1 ;NOT PARTICULARLY IMPORTANT FEATURES, LIKE: ; 1) ROMAN NUMERAL READER AND PRINTER ; 2) PRINLEVEL AND PRINLENGTH ; 3) DOUBLE-PRECISION INPUT OF SINGLE-PRECISION FLONUMS ; 4) CURSORPOS ; 5) GCD ; 6) DUMPARRAYS, LOADARRAYS [AUTOLOADED IN NEWIO] ; 7) RECLAIM, AND RETSP FEATURE WHICH RETURNS BPS CORE TO TS SYSTEM ; 8) PURIFY, AND PURE-INITIAL-READ-TABLE ; 9) CLI INTERRUPT SUPPORT ; 10) MAR-BREAK SUPPORT ; 11) AUTOLOAD PROPERTIES FOR ALLFILES ETC. ; 13) CLEVER TERPRI-BEFORE-THE-PARENS HACK ; 14) HUGE TABLE FOR RANDOM NUMBER GENERATOR ; 15) Exchange A and CONSed hunk for REES and RWK DBFLAG==0 ;1 FOR DOUBLE-PRECISION FLOATING-POINT NUMBERS CXFLAG==0 ;1 FOR COMPLEX ARITHMETIC NARITH==0 ;1 FOR NEW ARITHMETIC PACKAGE ;" FOR ASSLIS - DOUBLE QUOTES ARE OKAY NOW ;;; IF1 SUBTTL STORAGE LAYOUTS ;;; STORAGE LAYOUT FOR ITS ;;; ;;; BZERSG 0 - - LOW PAGES ;;; ACCUMULATORS, TEMPORARY VARIABLES, ;;; INITIAL READTABLE AND OBARRAY ;;; BSTSG ST: - - SEGMENT TABLES ;;; BSYSSG FIRSTL: INITIAL SYSTEM CODE (PURE) ;;; BSARSG INITIAL SAR SPACE ;;; BVCSG INITIAL VALUE CELL SPACE ;;; BXVCSG [EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE] ;;; BIS2SG SYMBOL-BLOCKS ;;; BSYMSG SYMBOL-HEADERS ;;; BSY2SG **SYMBOL-BLOCKS ;;; BPFXSG **FIXNUMS ;;; BPFSSG **LIST-STRUCTURE ;;; BPFLSG [**FLONUMS - - POSSIBLY NONE] ;;; BIFSSG LIST-STRUCTURE ;;; BIFXSG FIXNUMS ;;; BIFLSG FLONUMS ;;; BBNSG BIGNUMS ;;; BBITSG BIT BLOCKS FOR GC ;;; BBPSSG START OF BINARY PROGRAM SPACE ;;; C(BPSL) (ALLOC IS IN THIS AREA) ;;; V(BPORG) START OF BPS UNUSED FOR PROGRAMS ;;; V(BPEND) ARRAYS START NO LOWER THAN THIS ;;; C(BPSH) LAST WORD OF BPS ;;; ... BINARY PROGRAM SPACE GROWS UPWARD ... ;;; C(HINXM) LAST WORD OF GROSS HOLE IN MEMORY ;;; ... LIST STRUCTURE GROWS DOWNWARD ... ;;; PUSHDOWN LISTS WITH HOLES BETWEEN: ;;; FXP, FLP, P, SP ;;; ;;; C(NPDLL) LOW WORD OF NUMBER PDL (LOW OF FXP) ;;; C(NPDLH) HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP) ;;; ;;; STORAGE LAYOUT FOR DEC10 ;;; ;;; ***** LOW SEGMENT ***** ;;; BZERSG 0 - - LOW PAGES ;;; ACCUMULATORS, TEMPORARY VARIABLES, ;;; INITIAL READTABLE AND OBARRAY ;;; BSTSG ST: - - SEGMENT TABLES ;;; BSARSG INITIAL SAR SPACE ;;; BVCSG INITIAL VALUE CELL SPACE ;;; BXVCSG [EXTRA VALUE-CELL SEGMENTS - - POSSIBLY NONE] ;;; BIS2SG SYMBOL-BLOCKS ;;; BSYMSG SYMBOL-HEADERS ;;; BIFSSG LIST-STRUCTURE ;;; BIFXSG FIXNUMS ;;; BIFLSG FLONUMS ;;; BBNSG BIGNUMS ;;; BBITSG BIT BLOCKS FOR GC ;;; PUSHDOWN LISTS: ;;; FXP, FLP, P, SP ;;; C(NPDLL) LOW WORD OF NUMBER PDL (LOW OF FXP) ;;; C(NPDLH) HIGH WORD OF NUMBER PDL + 1 (HIGH+1 OF FLP) ;;; BBPSSG START OF BINARY PROGRAM SPACE ;;; (ALLOC IS IN THIS AREA) ;;; V(BPORG) START OF BPS UNUSED FOR PROGRAMS ;;; V(BPEND) ARRAYS START NO LOWER THAN THIS ;;; C(BPSH) LAST WORD OF BPS (FIXED, SET BY ALLOC) ;;; C(HIXM) HIGH WORD OF EXISTING MEMORY ;;; C(MAXNXM) HIGHEST WORD OF NXM THAT MAY BE USED ;;; ;;; ***** HIGH SEGMENT ***** ;;; BSYSSG INITIAL SYSTEM CODE (PURE) ;;; BSY2SG **SYMBOL-BLOCKS ;;; BPFXSG **FIXNUMS ;;; BPFSSG **LIST-STRUCTURE ;;; BPFLSG [**FLONUMS - - POSSIBLY NONE] ;;; BPFSSG INITIAL PURE LIST STRUCTURE ;;; IF1 SUBTTL VARIOUS PARAMETER CALCULATIONS IFNDEF LVRNO,LVRNO==.FNAM2 IFE LVRNO-SIXBIT \MID\,[ PRINTX /What is LISP's version number (type four octal digits) ?/ .TTYMAC VRS LVRNO=SIXBIT \VRS\ TERMIN ] .ELSE,[ LVRNO==+ ;HACK FOR CROSSING 1000'S IFN <&77>-'9, LVRNO==LVRNO+<1_36> ;HACK FOR CROSSING 2000'S ] ;END OF IFGE LVRNO PRINTX \MACLISP VERSION \ ;PRINT OUT VERSION OF THIS LISP .TYO6 .OFNM2 PRINTX \ [\ ;WATCH OUT FOR THE BRACKETS! .TYO6 LVRNO PRINTX \] ASSEMBLED ON \ .TYO6 .OSMIDAS PRINTX \ AT \ IFE <.SITE 0>, PRINTX \UNKNOWN SITE\ .ELSE REPEAT 20, IFE <.SITE .RPCNT>,[.ISTOP] .TYO6 <.SITE .RPCNT> PRINTX \ \ ;TERPRI TO FINISH VERSION MESSAGE ;;; HACK FLAGS AND PARAMETERS DEFINE ZZZZZZ X,SYM,VAL IFSE [X]-, PRINTX \* \ .ELSE PRINTX \ \ PRINTX \SYM=VAL \ TERMIN PRINTX \INITIAL SWITCH VALUES (*=EXPERIMENTAL): \ ;X=- => EXPERIMENTAL SWITCH IRPS S,X,[ITS,TOPS10,TOPS20,SAIL,TENEX-CMU-KA10,KI10-KL10- ML,BIGNUM,OBTSIZ,JOBQIO,HNKLOG,USELESS, DBFLAG-CXFLAG-NARITH-SFA-] ZZZZZZ [X]S,\S TERMIN EXPUNGE ZZZZZZ PRINTC \REDEFINITIONS: \ .INSRT TTY: PRINTC \ \ IFNDEF HSGORG,HSGORG==400000 ;;; ALL FLAGS WHICH ARE NON-ZERO MUST BE ONES: MUCH CONDITIONAL ;;; ASSEMBLY DOES ARITHMETIC WITH THEM. IRP FOO,,[ITS,TOPS10,TOPS20,SAIL,TENEX,CMU,KA10,KI10,KL10 ML,BIGNUM,NEWRD,JOBQIO,USELESS DBFLAG,CXFLAG,NARITH,SFA] IFN FOO, FOO==:1 .ELSE FOO==:0 TERMIN ;USE OF ==: PREVENTS CHANGING THEM RANDOMLY ;;; CHECK MUTUALLY EXCLUSIVE FLAGS OF WHICH ONE MUST BE SET DEFINE MUTXOR FLAGS,DEFAULT ZZZ==0 IRP X,Y,[FLAGS] ZZZ==ZZZ+X IRP Z,,[Y] IFN X*Z, .FATAL BOTH X AND Z SPECIFIED AMONG {FLAGS} TERMIN TERMIN IFE ZZZ,[ PRINTX \NONE OF {FLAGS} SPECIFIED - ASSUMING DEFAULT==:1 \ EXPUNGE DEFAULT DEFAULT==:1 ] ;END OF IFE ZZZ EXPUNGE ZZZ TERMIN IRP OS,,[ITS,DEC,SAIL,TENEX,CMU]FLAG,,[ITS,TOPS10,SAIL,TENEX,CMU] IFE .OSMIDAS-, MUTXOR [ITS,TOPS10,TOPS20,SAIL,TENEX,CMU]OS TERMIN MUTXOR [KA10,KI10,KL10]KA10 ;;; IF1 D10==:TOPS10\SAIL\CMU ;SWITCH FOR DEC-10-LIKE SYSTEMS D20==:TOPS20\TENEX ;SWITCH FOR DEC-20-LIKE SYSTEMS IFNDEF PAGING, PAGING==:D20\ITS ;SWITCH FOR PAGING SYSTEMS IFNDEF HISEGMENT, HISEGMENT==:D10*<1-PAGING> ;ASSUME HISEGMENT FOR DEC-10 ;;; INSIST FORCIBLY ALTERS A PARAMETER IF NECESSARY. DEFINE INSIST COND,SET COND,[ IRPS X,,[SET] ZZZ==X EXPUNGE X SET IFN X-ZZZ,[ PRINTX \ COND =>SET \ ] EXPUNGE ZZZ .ISTOP TERMIN ] ;END OF COND TERMIN ;;; CANONICALIZE BITS INSIST IFE ITS, JOBQIO==:0 INSIST IFG SAIL*<6-NIOBFS>, NIOBFS==:6 ;INSIST IFN TOPS20, KA10==:0 ;INSIST IFN TOPS20, KI10==:0 ;INSIST IFN TOPS20, KL10==:1 SEGLOG==:11 ;LOG2 OF # OF WORDS PER SEGMENT (WARNING! BUILT INTO NCOMPLR!) INSIST IFG HNKLOG-SEGLOG, HNKLOG==:SEGLOG-1 OBTSIZ==:OBTSIZ\1 ;MUST BE ODD DXFLAG==:DBFLAG*CXFLAG ;;; IF1 IFE .OSMIDAS-,[ DEFINE $INSRT $%$%$% .INSRT $%$%$% > PRINTX \ ==> INSERTED: \ .TYO6 .IFNM1 PRINTX \ \ .TYO6 .IFNM2 PRINTX \ \ TERMIN ] ;END OF IFE .OSMIDAS-, .ELSE,[ DEFINE $INSRT $%$%$% .INSRT $%$%$%!.MID PRINTX \INSERTED: \ .TYO6 .IFNM1 PRINTX \.\ .TYO6 .IFNM2 PRINTX \ \ TERMIN ] ;END OF .ELSE ;;; MAKE SURE THE SYMBOLS WE WILL NEED ARE DEFINED. ;;; THEY MAY NOT BE IF ASSEMBLING FOR A DIFFERENT OPERATING SYSTEM DEFINE FLUSHER DEF/ IRPS SYM,,[DEF] EXPUNGE SYM .ISTOP TERMIN TERMIN DEFINE SYMFLS TARGETSYS,OS,.DEFS.,DEFFER,CHKSYM,.BITS.,CHKBIT IFE <.OSMIDAS-SIXBIT\OS\>,[ IFE TARGETSYS,[ PRINTX \FLUSHING OS SYMBOL DEFINITIONS \ $INSRT .DEFS. DEFFER FLUSHER IFSN .BITS.,,[ PRINTX \FLUSHING OS BIT DEFINITIONS \ EQUALS DEFSYM,FLUSHER $INSRT .BITS. EXPUNGE DEFSYM ] ;END OF IFSN .BITS. ] ;END OF IFE TARGETSYS ] ;END OF IFE <.OSMIDAS-SIXBIT\OS\> TERMIN DEFINE SYMDEF TARGETSYS,OS,.DEFS.,DEFFER,CHKSYM,.BITS.,CHKBIT IFN TARGETSYS,[ IFN <.OSMIDAS-SIXBIT\OS\>,[ PRINTX \MAKING OS SYMBOL DEFINITIONS \ $INSRT .DEFS. DEFFER IFSN .BITS.,,[ PRINTX \MAKING OS BIT DEFINITIONS \ $INSRT .BITS. ] ;END OF IFSN .BITS.,, ] ;END OF IFN <.OSMIDAS-SIXBIT\OS\> .ELSE,[ IFNDEF CHKSYM,[ PRINTX \FUNNY - RUNNING ON OS, BUT CHKSYM UNDEFINED; MAKING OS SYMBOL DEFINITIONS \ $INSRT .DEFS. DEFFER ] ;END OF IFNDEF CHKSYM IFSN .BITS.,,[ IFNDEF CHKBIT,[ PRINTX \FUNNY - RUNNING ON OS, BUT CHKBIT UNDEFINED; MAKING OS BIT DEFINITIONS \ $INSRT .BITS. ] ;END OF IFNDEF CHKBIT ] ;END OF IFSN .BITS.,, ] ;END OF .ELSE ] ;END OF IFN TARGETSYS TERMIN IFN D20, EXPUNGE RESET IRP HACK,,[SYMFLS,SYMDEF] HACK ITS,ITS,ITSDFS,.ITSDF,.IOT,ITSBTS,%PIC.Z HACK TOPS10,DEC,DECDFS,.DECDF,LOOKUP,DECBTS,.GTSTS HACK TOPS20,TENEX,TNXDFS,.TNXDF,JSYS,TWXBTS,GJ%FOU HACK TENEX,TENEX,TNXDFS,.TNXDF,JSYS,TWXBTS,GJ%FOU HACK SAIL,SAIL,SAIDFS,.DECDF,SPCWAR,DECBTS,.GTSTS TERMIN ;;; CONFLICTS WITH UNLOCKI MACRO AND SEGSIZ VARIABLE IFN D10,[ IFE SAIL,[ IFN <.OSMIDAS-SIXBIT\CMU\>,[ ;THE FOLLOWING ARE THE SPECIAL CMU UUOs: DEFINE .CMUCL DEF DEF SRUN=:47000777756 DEF USRDEF=:47000777757 DEF JENAPX=:47000777760 DEF IMPUUO=:47000777761 DEF PRIOR=:47000777762 DEF LNKRDY=:47000777763 DEF INT11=:47000777764 DEF RSTUUO=:47000777765 DEF UNTIME=:47000777766 DEF TIME=:47000777767 DEF STOP=:47000777770 DEF UNLOCK=:47000777771 DEF JENAPR=:47000777772 DEF MSGPOL=:47000777773 DEF MSGSND=:47000777774 DEF DECCMU=:47000777775 DEF CMUDEC=:47000777776 TERMIN PRINTX \MAKING CMU-SPECIFIC "CALL" DEFINITIONS \ .CMUCL FLUSHER .CMUCL ] ;END OF IFN <.OSMIDAS-SIXBIT\CMU\> ] ;END OF IFE SAIL IFN SAIL, EXPUNGE SEGSIZ EXPUNGE UNLOCK ] ;END OF IFN D10 COMMENT | MAKE @ PROGRAM UNDERSTAND POTENTIAL FILE INSERTIONS ;TABS IN FRONT OF $INSRT'S ARE NECESSARY TO FAKE OUT UNIFY PROGRAM $INSRT ITSDFS $INSRT DECDFS $INSRT TNXDFS $INSRT SAIDFS $INSRT ITSBTS $INSRT DECBTS $INSRT TWXBTS | ;END OF COMMENT IFN D10,[ DEFINE HALT JRST 4,.!TERMIN EXPUNGE .VALUE EQUALS .VALUE HALT DEFINE .LOSE JRST 4,.-1!TERMIN ] ;END OF IFN D10 IFN D20,[ GETTAB==:47_33 41 DEFINE HALT HALTF!TERMIN EXPUNGE .VALUE EQUALS .VALUE HALTF DEFINE .LOSE HALTF!TERMIN ] ;END OF IFN D20 ;;; IF1 ;;; LOSING KL10 HAS A FIX INSTRUCTION EXPUNGE FIX ;;; CALL IS A DEC UUO, BUT WE USE THAT NAME FOR A LISP UUO EXPUNGE CALL ;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT ;;@ DEFNS 221 STANDARD AC, UUO, AND MACRO DEFINITIONS ;;; ***** MACLISP ****** STANDARD AC, UUO, AND MACRO DEFINITIONS * ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** ;;; THIS FILE CONTAINS: ;;; STANDARD SYMBOLIC ACCUMULATOR DEFINITIONS. ;;; UUO DEFINITIONS: ;;; ERROR CALLS AND STRING TYPEOUT. ;;; COMPILED CODE TO INTERPRETER INTERFACES. ;;; VARIOUS UUOS USEFUL FROM DDT. ;;; .GLOBAL DECLARATIONS. ;;; .FORMAT DECLARATIONS. ;;; TYPE BIT DEFINITIONS FOR USE WITH SEGMENT TABLE ;;; MACROS FOR CONDITIONALIZING SINGLE LINES OF CODE. ;;; GENERAL MACRO DEFINITIONS [THAT ANY LOSER MIGHT WANT]. ;;; SYMBOL BLOCK-STRUCTURE DEFINITIONS ;;; SYMBOLIC NAMES RELATED TO ARRAYS. ;;; SYMBOLIC NAMES RELATED TO FILES. ;;; THE DEFINITIONS FOR MACLISP CONTAINED HEREIN ;;; ARE RELATIVELY STABLE. THIS FILE MAY BE .INSRT'D BY MIDAS ;;; FILES ASSEMBLED IN .FASL MODE TO DEFINE THESE THINGS. ;;; THE .GLOBAL DECLARATIONS IN PARTICULAR ARE FOR THE ;;; BENEFIT OF THESE .FASL FILES. ;;; IT IS A GOOD IDEA FOR .FASL FILES TO USE THE FASEND MACRO ;;; IN PLACE OF THE USUAL END STATEMENT. ;;; SYMBOLS FOR COMPILED CODE IFNDEF ITS, ITS==:1 IFNDEF TOPS10, TOPS10==:0 IFNDEF TOPS20, TOPS20==:0 IFNDEF SAIL, SAIL==:0 IFNDEF TENEX, TENEX==:0 IFNDEF CMU, CMU==:0 IFNDEF D10, D10==:TOPS10\SAIL\CMU IFNDEF D20, D20==:TOPS20\TENEX IFNDEF PAGING, PAGING==:ITS\D20 IFNDEF BIGNUM, BIGNUM==:1 IFNDEF JOBQIO, JOBQIO==:1 IFNDEF SFA, SFA==:1 SUBTTL ACCUMULATOR USAGE NIL=:0 ;ATOM HEADER FOR NIL A=:1 ;ARG 1; VALUE; MARKED FROM BY GC B=:2 ;ARG 2; MARKED FROM BY GC C=:3 ;ARG 3; MARKED FROM BY GC AR1=:4 ;ARG 4; MARKED FROM BY GC AR2A=:5 ;ARG 5; MARKED FROM BY GC NACS==:5 ;NUMBER OF ACS MARKED FROM BY GC - NO OTHER ACS MARKED T=:6 ;- FOR LSUBR CALL; ALSO USED FOR JSP T, TT=:7 ;TEMP; OFTEN USED FOR ARGS TO INTERNAL ROUTINES D=:10 ;SOMEWHAT LESS TEMPORARY THAN TT R=:11 ;DITTO; SOMETIMES USED FOR JSP R, F=:12 ;SOMEWHAT LESS TEMPORARY THAN D AND R FREEAC=:13 ;UNUSED BY LISP, EXCEPT SAVED-USED-RESTORED BY GC P=:14 ;SUBROUTINE AND SYSTEM PDL POINTER ("REGULAR PDL") FLP=:15 ;FLONUM PDL POINTER ("FLOPDL") FXP=:16 ;FIXNUM PDL POINTER ("FIXPDL") SP=:17 ;LAMBDA-BINDINGS PDL POINTER ("SPECIAL PDL") ;;; PDL POINTERS ARE ALWAYS KEPT IN ACS. PDL POINTERS ARE NOT ;;; MARKED FROM, BUT PDL DATA ON REGULAR AND SPECIAL PDLS ARE ;;; PROTECTED FROM GARBAGE COLLECTION. ;;; FLP IS NOT USED BY LISP, EXCEPT AT LDATFL AND ERRIOJ, ;;; BUT PRIMARILY BY COMPILED NUMERICAL CODE. ;;; DO NOT DO RANDOM PUSH/POPS ON SP - USE BIND AND UNBIND ROUTINES. SUBTTL DEFINITIONS OF UUO'S ;;; NOTE: LERR < LER3 < ERINT < SERINT -- SEE ERRFRAME. LERR=:1_33 ;LISP ERROR; AC FIELD=0 => MSG IS SIXBIT, ELSE S-EXP ACALL=:2_33 ;KLUDGY FAST UUO FOR NCALLS TO ARRAYS AJCALL=:3_33 ;AJCALL:ACALL :: JCALL:CALL LER3=:4_33 ;EPRINT, THEN LERR ERINT=:5_33 ;A CORRECTABLE ERROR PP=:6_33 ;SEXP TYPE OUT FROM DDT STRT=:7_33 ;STRING TYPEOUT (sixbit format - stops on unquoted "!") SERINT=:10_33 ;LIKE ERINT, BUT S-EXPRESSION MESSAGE. TP=:11_33 ;PRINTS ST ENTRY FOR A GIVEN LOCATION IOJRST=:12_33 ;JRST TO ADR AFTER PUTTING I/O ERROR MSG IN C STRT7=:13_33 ;STRING TYPEOUT (ascii format - stops on 0 byte) UUOMAX==:13 ;NO OF ERROR-TYPE UUO'S CALL=:14_33 ;BASIC CALL FROM COMPILED CODE TO INTERFACE TO INTERPRETER JCALL=:CALL+1_33 ;4.1 BIT ON MEANS JRST TO FUNCTION RATHER THAN PUSHJ CALLF=:CALL+2_33 ;4.2 BIT ON MEANS NEVER CONVERT UUO INTO PUSHJ [OR JRST] JCALLF=:CALL+3_33 NCALL=:20_33 ;4.5 BIT MEANS NUMBER FUNCTION CALL NJCALL=:NCALL+1_33 NCALLF=:NCALL+2_33 NJCALF=:NCALL+3_33 NUUOCLS==:NJCALF_-33-CALL_-33 ;;; SPECIAL INTERPRETATION OF STRT AC FIELD: ;;; AC FIELD OUTPUT TO ;;; 0 OUTFILES IF ^R SET; TTY IF ^W SET ;;; 17 MSGFILES ;;; X FILE(S) IN ACCUMULATOR X ;;; ERINT AND SERINT ARE DECODED BY THEIR ACCUMULATOR FIELDS. ;;; HERE ARE SOME SYMBOLS FOR REFERENCING THEM. NERINT==0 IRPS X,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC,IOL] %!X=:ERINT .IRPCNT, %%!X=:SERINT .IRPCNT, DEFINE X CRUFT %!X [SIXBIT CRUFT] TERMIN NERINT==NERINT+1 TERMIN ;;; SHORT FORM ATOM WHAT IS IT? ;;; ;;; 0) UDF UNDEF-FNCTN UNDEFINED FUNCTION (FUNCTION IN A) ;;; 1) UBV UNBND-VRBL UNBOUND VARIABLE BEING EVAL'ED (ATOM IN A) ;;; 2) WTA WRNG-TYPE-ARGS WRONG TYPE OF ARGUMENTS FOR A FUNCTION (ARG IN A) ;;; 3) UGT UNSEEN-GO-TAG GO TO A TAG THAT'S NOT THERE (TAG IN A) ;;; 4) WNA WRNG-NO-ARGS WRONG NUMBER OF ARGS TO A FUNCTION (FORM IN A) ;;; 5) GCL GC-LOSSAGE GC LOST (A = NAME OF SPACE: LIST...) ;;; 6) FAC FAIL-ACT RANDOM LOSSAGE (ARG IS UP TO CALLER) ;;; 7) IOL IO-LOSSAGE ;I/O LOSSAGE SUBTTL TABLE OF GLOBAL SYMBOLS USED BY COMPILED FUNCTIONS ;;; THE RELATIVE POSITIONS OF THESE SYMBOLS GET BUILT INTO FASL FILES, ;;; SO BE VERY CAREFUL ABOUT DISTURBING THE ORDER OF EXISTING SYMBOLS! ;;; GLBSYM AND SIXSYM MUST ALWAYS HAVE CORRESPONDING ENTRIES. DEFINE GLBSYM B IRP A,,[.SET,.MAP,PRINTA,SPECBIND,UNBIND,IOGBND,.LCALL .UDT,ARGLOC,INUM,ST,FXNV1,PDLNMK,PDLNKJ,FIX1A FIX1,FLOAT1,IFIX,IFLOAT,FXCONS,FLCONS,ERSETUP,ERUNDO GOBRK,CARCDR,.STORE,NPUSH,PA3,QUNBOUND,FLTSKP,FXNV2 FXNV3,FXNV4,FIX2,FLOAT2,AREGET] B TERMIN IRP A,,[%HUNK1,%HUNK2,INTREL,INHIBIT,NOQUIT,CHECKI,0PUSH,0.0PUSH,NILPROPS,VBIND %CXR,%RPX,%CONS,%NCONS,%XCONS,%C2NS,%HUNK3,%HUNK4,%PDLC,%PDLXC,%PDLNC PTNTRY,PTEXIT,SFCALI,UNWPUS] B TERMIN TERMIN DEFINE SIXSYM B ;SIXBIT NAMES -- MUST MATCH GLBSYM IRP A,,[*SET,*MAP,PRINTA,SPECBIND,UNBIND,IOGBND,*LCALL *UDT,ARGLOC,INUM,NUMVAL,FXNV1,PDLNMK,PDLNKJ,FIX1A FIX1,FLOAT1,IFIX,IFLOAT,FXCONS,FLCONS,ERSETUP,ERUNDO GOBRK,CARCDR,*STORE,NPUSH,PA3,MAKUNBOUND,FLTSKP,FXNV2 FXNV3,FXNV4,FIX2,FLOAT2,AREGET] B TERMIN IRP A,,[%HUNK1,%HUNK2,INTREL,INHIBIT,NOQUIT,CHECKI,0PUSH,0*0PUSH,NILPROPS,VBIND %CXR,%RPX,%CONS,%NCONS,%XCONS,%C2NS,%HUNK3,%HUNK4,%PDLC,%PDLXC,%PDLNC PTNTRY,PTEXIT,SFCALI,UNWPUS] B TERMIN TERMIN ;;; ADDITIONAL SYMBOLS FOR LAP AND .FASL HACKERS. ;;; THE ORDER OF THESE IS NOT CRITICAL. DEFINE XTRSYM B IRP A,,[CPOPJ,CCPOPJ,POPAJ,POP1J,CINTREL,LWNACK,SIXMAK,SQUEEZE,MKFXAR,FWCONS SACONS,CFIX1,1DIMF,2DIMF,SEGLOG,R70,ARGLOC,ARGNUM,TTSAR,Q..MIS,MAKVC,SUNBOUND IN0,TYIMAN,READ6C,READ0A,GCMKL,DEDSAR,BRGEN,RINTERN,LPNF,PNBUF ALFILE,ALCHAN,XFILEP,FIL6BT,6BTNML,SIXATM,CHNTB,%HNK4R,GRBPSG,HNKLOG,IAPPLY] B TERMIN IFN PAGING,[ IRP A,,[FLSTBL] TERMIN ] ;END of IFN PAGING IFN ITS,[ IRP A,,[GETCOR,IOCINS] B TERMIN ] ;END OF IFN ITS IFN D10,[ IRP A,,[PPNATM,CMUP] B TERMIN ] ;END OF IFN D10 IFN D20,[ IRP A,,[TENEXP] B TERMIN ] ;END OF IFN D20 IFN BIGNUM,[ IRP A,,[BNCONS,NVSKIP] B TERMIN ] ;END OF IFN BIGNUM IFN JOBQIO,[ IRP A,,[JOBTB,LOJOBA] B TERMIN ] ;END OF IFN JOBQIO IFN SFA,[ IRP A,,[AFOSP,XFOSP] B TERMIN ] ;END IFN SFA TERMIN GLBSYM [.GLOBAL A] XTRSYM [.GLOBAL A] SUBTTL SYMBOLS FOR NUMBER-OF-ARGS CHECKING, AND .FORMAT ;;; SYMBOLS TO BE USED WITH FWNACK AND LWNACK. ;;; ORDINARILY ONE WRITES ;;; JSP TT,FWNACK ;;; FAXXX,,QZZZZZ ;;; IN EACH SYMBOL, THE 3.1 BIT (THESE ARE LEFT-HALF SYMBOLS) ;;; MEANS FSUBR. THE 3.2 BIT MEANS 0 ARGS IS OKAY; 3.3, 1 ARG; ;;; 3.4, 2 ARGS; ... ; 4.8, 15. ARGS; 4.9, > 15. ARGS. ;;; ITEMS IN THIS IRP MUST HAVE FIRST FOUR CHARS UNIQUE!!! ;;; IF YOU ADD STUFF HERE, ALSO FIX UP FASEND. .SEE FASEND IRP X,,[02,1N,12,23,2N,0,1,2,4,01,012,01234,0234,3456,1234567 13456,234,345,234567,76543,45] LA!X==0 IRPC Q,,[X] IFSN Q,N, LA!X==LA!X+2_Q .ALSO ZZ==Q .ELSE LA!X==LA!X+<<777774_ZZ>&7777777> TERMIN FA!X==LA!X+1 TERMIN ;;; THE FOLLOWING FORMATS ARE HEREBY DECLARED ILLEGAL AS ;;; BEING REDUNDANT AND/OR GROSSLY CONFUSING. ;;; SEE THE MIDAS MANUAL FOR DETAILS. ;;; ,A ;;; ,A C ;;; ,A, ;;; ,A,C ;;; A B C ;;; A, ;;; A,B ;;; A,B C ;;; A,B, ;;; A,B,C IRP X,,[14,15,16,17,25,30,34,35,36,37] .FORMAT X,0 TERMIN ;;; FLAG BITS FOR SQUOZE SYMBOLS IN DDT %SY==1,,537777 %SYHKL==:400000 ;HALF KILLED %SYKIL==:200000 ;FULLY KILLED %SYLCL==:100000 ;LOCAL %SYGBL==:40000 ;GLOBAL ;;; A FEW RANDOMLY USEFUL DEFINITIONS TO KEEP THINGS SYMBOLIC ;;; BUT WATCH OUT! DONT JUST RANDOMLY THINK YOU CAN CHANGE NASCII ;;; AND HAVE THINGS WIN, ESPECIALLY THE PACKING OF CHARS FOR ;;; PNAMES, AND THE SPECIAL OBARRAY ENTRIES FOR SCOS. IFN SAIL, NASCII==:1000 ;NUMBER OF ASCII CHARS .ELSE NASCII==:200 ;NUMBER OF ASCII CHARS BYTSWD==:5 ;NUMBER OF ASCII BYTES PER WORD SUBTTL DEFINITIONS OF BIBOP TYPE BITS FOR USE IN THE SEGMENT TABLE .SEE ST LS==:400000 ;4.9 1=LIST STRUCTURE, 0=ATOMIC ST.LS==:400000 $FS==:200000 ;4.8 FREE STORAGE (BIT 4.9 SHOULD BE ON ALSO) ST.$FS==:200000 FX==:100000 ;4.7 FIXNUM STORAGE ST.FX==:100000 FL==:40000 ;4.6 FLONUM STORAGE ST.FL==:40000 BN==:20000 ;4.5 BIGNUM HEADER STORAGE ST.BGN==:20000 SY==:10000 ;4.4 SYMBOL HEADER STORAGE ST.SY==:10000 SA==:4000 ;4.3 SAR STORAGE (BIT 3.8 SHOULD BE ON ALSO) ST.SA==:4000 VC==:2000 ;4.2 VALUE CELL STORAGE (BIT 4.9 SHOULD BE ON ALSO) ST.VAC==:2000 $PDLNM==:1000 ;4.1 NUMBER PDL AREA ; (ONE OF THE NUMBER TYPE BITS SHOULD BE ON ALSO) ST.$PDLNM==:1000 ;3.9 400 RESERVED - AVOID USING (FORMERLY $FLP) $XM==:200 ;3.8 EXISTENT (RANDOM) AREA ST.$XM==:200 $NXM==:100 ;3.7 NONEXISTENT (RANDOM) AREA ST.$NXM==:100 PUR==:40 ;3.6 PURE SPACE ; (ONE OF BITS 4.8-4.5, 3.8, OR 3.4-3.2 ALSO ON) ST.PUR==:40 HNK==:20 ;3.5 HUNK OF ONE KIND OR ANOTHER (BIT 4.9 ON ALSO) ST.HNK==:20 DB==:10 ;3.4 DOUBLE-PRECISION FLONUMS ST.DB==:10 CX==:4 ;3.3 COMPLEX NUMBERS ST.CX==:10 DX==:2 ;3.2 DOUBLE-PRECISION COMPLEX NUMBERS ST.DX==:2 ;3.1 1 UNUSED (USE THIS BEFORE BIT 3.9) RN==:$XM+$NXM ;RANDOMNESS! NUM==:FX+FL+BN+DB+CX+DX ;NUMBERNESS! ST.==:1,, SUBTTL ONE-LINE CONDITIONAL MACROS ;;; THESE HELP MAKE SOME CODE LESS MESSY TO READ. ;;; PREFACING A LINE OF CODE WITH ONE OF THESE SYMBOLS TELLS MIDAS ;;; TO ASSEMBLE THAT LINE ONLY UNDER THE SPECIFIED CONDITION. ;;; EXAMPLE: ;;; ;;; FOO: MOVE A,(P) ;;; 10$ PUSHJ P,10HACK ;THIS LINE IS FOR DEC-10 ONLY ;;; MOVE A,-1(P) ;;; Q% PUSHJ P,OLDHAK ;THIS LINE IS FOR OLD I/O ONLY ;;; POPJ P, DEFINE 10$ IFN D10,TERMIN DEFINE 10% IFE D10,TERMIN DEFINE IT$ IFN ITS,TERMIN DEFINE IT% IFE ITS,TERMIN DEFINE 20$ IFN D20,TERMIN DEFINE 20% IFE D20,TERMIN DEFINE 10X IFN TENEX,TERMIN DEFINE SA$ IFN SAIL, TERMIN DEFINE SA% IFE SAIL,TERMIN DEFINE CMU$ IFN CMU,TERMIN DEFINE CMU% IFE CMU,TERMIN DEFINE T10$ IFN TOPS10,TERMIN DEFINE T10% IFE TOPS10,TERMIN DEFINE 20X IFN TOPS20,TERMIN ;;; NEWRD IS FOOLISH NEW READER FLAG (HISTORICAL ARTIFACT -- FLUSH EVENTUALLY) DEFINE NW$ IFN NEWRD,TERMIN DEFINE NW% IFE NEWRD,TERMIN DEFINE BG$ IFN BIGNUM,TERMIN DEFINE BG% IFE BIGNUM,TERMIN DEFINE DB$ IFN DBFLAG,TERMIN DEFINE DB% IFE DBFLAG,TERMIN DEFINE CX$ IFN CXFLAG,TERMIN DEFINE CX% IFE CXFLAG,TERMIN DEFINE DX$ IFN DXFLAG,TERMIN DEFINE DX% IFE DXFLAG,TERMIN DEFINE HN$ IFN HNKLOG,TERMIN DEFINE HN% IFE HNKLOG,TERMIN DEFINE KA IFN KA10,TERMIN DEFINE KAKI IFN KA10+KI10,TERMIN DEFINE KI IFN KI10,TERMIN DEFINE KIKL IFN KI10+KL10,TERMIN DEFINE KL IFN KL10,TERMIN DEFINE PG$ IFN PAGING,TERMIN DEFINE PG% IFE PAGING,TERMIN DEFINE SFA$ IFN SFA,TERMIN DEFINE SFA% IFE SFA,TERMIN DEFINE HS$ IFN HISEGMENT,TERMIN DEFINE HS% IFE HISEGMENT,TERMIN DEFINE REL$ IFE D20\,TERMIN DEFINE REL% IFN D20\,TERMIN SUBTTL GENERAL MACROS DEFINE CONC A,B ;HAIRY CONCATENATOR MACRO A!B!TERMIN DEFINE LOCKI ;LOCK OUT USER INTERRUPTS UNTIL UNLOCKI'D PUSH FXP,INHIBIT SETOM INHIBIT TERMIN DEFINE UNLOCKI ;RELEASE THE USER-INTERRUPT LOCK, AND CHECK TO SEE PUSHJ P,INTREL ;IF ANY INTERRUPTS WERE STACKED UP WHILE IN LOCKED STATE TERMIN DEFINE LOCKTOPOPJ ;LOCK ALL THE ENSUING CODE UNTIL THE PUSH P,CINTREL ;EXITING POPJ P, LOCKI TERMIN DEFINE UNLKPOPJ ;UNLOCK, THEN POPJ P, JRST INTREL TERMIN .SEE CHNINT DEFINE .5LOCKI ;HALF-LOCK INHIBIT PUSH FXP,INHIBIT HRROS INHIBIT TERMIN DEFINE .5LKTOPOPJ PUSH P,CINTREL .5LOCKI TERMIN IRP PL,,[,FX] DEFINE SAVE!PL AL/ ;CALLED LIKE SAVE A B C IRPS AC,,AL PUSH PL!P,AC TERMIN TERMIN DEFINE RSTR!PL AL/ ;CALLED LIKE RSTR C B A IRPS AC,,AL POP PL!P,AC TERMIN TERMIN TERMIN DEFINE MACROLOOP COUNT,NAME,C ;FOR EXPANDING MANY MACROS IFSN C,, .CRFOFF REPEAT COUNT,[ CONC NAME,\.RPCNT ] IFSN C,, .CRFON TERMIN ;SKIP IF TYPE, USING TT AS TEMP, ACCORDING TO BIBOP TYPE BITS DEFINE SKOTT /Z SKOTT% N,L,Z TERMIN ;SKIP IF NOT TYPE, USING TT AS TEMP, ACCORDING TO BIBOP TYPE BITS DEFINE SKOTTN /Z SKOTT% E,GE,Z TERMIN DEFINE SKOTT% N,L,X,TYP IFN TT-, HRRZ TT,X LSH TT,-SEGLOG IFN -LS,[ MOVE TT,ST(TT) TLN!N TT, ] .ELSE SKIP!L TT,ST(TT) TERMIN DEFINE % ;THIS IS GOOD FOR LIST STRUCTURE ,,.+1!TERMIN DEFINE INFORM R,S,T,U,V,W,X,Y,Z,$,% PRINTX  R!S!T!U!V!W!X!Y!Z!$!%  TERMIN DEFINE WARN R,S,T,U,V,W,X,Y,Z,$,% WARN1 [R!S!T!U!V!W!X!Y!Z!$!%] TERMIN DEFINE WARN1 CRUFT IFL 40-.LENGTH CRUFT,[ .ERR ###### PRINTX  ###### CRUFT  ] .ELSE .ERR ###### CRUFT TERMIN ;;; USEFUL MACRO FOR .FASL FILES. CAUSES LOADING TO PRINT MESSAGE. DEFINE VERPRT NAME,VRS=[???] IFN .FNAM2-SIXBIT /MID/,[ %%%==.fnam2 .SXEVAL (COND ((STATUS NOFEATURE NOLDMSG) (TERPRI MSGFILES) (TYO #73 MSGFILES) ((LAMBDA (UGLY) (PRINC (QUOTE L/o/a/d/i/n/g/ NAME/ ) MSGFILES) (PRINC UGLY MSGFILES) (TYO #40 MSGFILES) (DEFPROP NAME UGLY VERSION)) (MAKNAM (QUOTE (#<<<%%%&<770000,,0>>_-36>+40> #<<<%%%&<7700,,0>>_-30>+40> #<<<%%%&<77,,0>>_-22>+40> #<<<%%%&770000>_-14>+40> #<<<%%%&7700>_-6>+40> #<<%%%&77>+40> )))))) ] .ELSE [ .SXEVAL (COND ((STATUS NOFEATURE NOLDMSG) (TERPRI MSGFILES) (TYO #73 MSGFILES) (PRINC (QUOTE L/o/a/d/i/n/g/ NAME/ VRS/ ) MSGFILES) (DEFPROP NAME VRS VERSION))) ] TERMIN ;MACRO TO HANDLE UNWIND-PROTECT ; UNWINDPROTECT CODE,CONTINUATION-CODE ;CAUSES CONTINUATION TO BE INVOKED AFTER CODE IS EXECUTED ;THE STATE OF THE PDLS MUST BE THE SAME BEFORE AND AFTER CODE EXECUTES. ; CODE SHOULD BE THOUGHT OF AS A FUNCTION CALL. ; CODE IS THE CODE TO BE INVOKED AND PROTECTED. ; CONT IS THE "CONTINUATION" TO BE RUN WHEN UNWINDING THE STACK, OR AFTER ; CODE IS RUN DEFINE UNWINDPROTECT CODE,CONT,\LABEL JSP TT,PTNTRY ;SETUP AN UNWIND PROTECT JRST LABEL CONT POPJ P, LABEL: CODE ;ASSUMPTION IS THAT FOLLOWING JSP CLOBBERS THE WORLD JSP TT,PTEXIT ;RUN CONTINUATION, PRESERVES A TERMIN ;;; HERE COME THE RANDOM "RPG" MACROS FOR IN-LINING THE PDL-FIXUP CODE DEFINE PFIXPDL AC HRRZ AC,P MOVE P,C2 SUBI AC,(P) HRLS AC ADD P,AC TERMIN DEFINE FXPFIXPDL AC HRRZ AC,FXP MOVE FXP,FXC2 SUBI AC,(FXP) HRLS AC ADD FXP,AC TERMIN DEFINE FLPFIXPDL AC HRRZ AC,FLP MOVE FLP,FLC2 SUBI AC,(FLP) HRLS AC ADD FLP,AC TERMIN DEFINE SPFIXPDL AC HRRZ AC,SP MOVE SP,SC2 SUBI AC,(SP) HRLS AC ADD SP,AC TERMIN IF1,[ ;;; FEATURE SO THAT HAIRY SUMS OF BITS MAY BE WRITTEN NICELY. ;;; BITMAC FOO,FOO. ;;; CAUSES THE FORM ;;; FOO ;;; TO EXPAND INTO THE FORM ;;; FOO.A+FOO.B+FOO.C NBITMACS==0 DEFINE BITMAC XX,YY,ZZ=[1,,525252] DEFINE XX IRPS J,K,[BITS] YY!!J!K!TERMIN TERMIN BITMA1 XX,YY,[ZZ]\NBITMACS NBITMACS==NBITMACS+1 TERMIN DEFINE BITMA1 XX,YY,ZZ,NN DEFINE BTMC!NN EXPUNGE XX,YY XX==ZZ YY==ZZ IFSN [ZZ], IFGE <.TYPE ZZ>, EXPUNGE ZZ TERMIN TERMIN IRP FOO,,[%TB,%TI,%TJ,%TX,%TO,%TS,%TC,%TG,%TT,%PI,%PJ] IFDEF FOO, SV$!FOO==FOO .SEE BITMAC .ELSE SV$!FOO==1,,525252 EXPUNGE FOO TERMIN BITMAC AS,AS. ;LH ASARS BITMAC TTS,TTS.,[1,,725252] ;LH TTSARS BITMAC FBT,FBT. ;LH F.MODE WORD IN FILE ARRAYS BITMAC RS.,RS. ;FOR READER SYNTAX BITS BITMAC RS%,RS%,525252 ;READER SYNTAX BITS, LH SHIFTED INTO RH BITMAC IB,IB.,[525252,,525252] ;WORD 1 INTERRUPT BITS BITMAC %TB,%TB,SV$%TB ;LH .TTY USER VARIABLE BITMAC %TI,%TI,SV$%TI ;LH TTY IOCHNM BITS (SOME PER-IOT) BITMAC %TJ,%TJ,SV$%TJ BITMAC %TX,%TX,SV$%TX ;RH TTY CHARACTER BITS BITMAC %TO,%TO,SV$%TO ;LH TTYOPT VARIABLE BITMAC %TS,%TS,SV$%TS ;LH TTYSTS VARIABLE BITMAC %TC,%TC,SV$%TC ;LH TTYCOM VARIABLE BITMAC %TG,%TG,SV$%TG ;6-BIT BYTE TTYST1,TTYST2 GROUPS BITMAC %TT,%TT,SV$%TT ;LH TTYTYP VARIABLE BITMAC %PI,%PI,SV$%PI ;FULL WORD .PIRQC VARIABLE BITMAC %PJ,%PJ,SV$%PJ ;LH .PIRQC VARIABLE ] ;END OF IF1 ;;; MACRO FOR .FASL LOSERS WHO .INSRT THIS FILE TO USE ;;; IN PLACE OF THE "END" PSEUDO. THIS GENERATES AN "END" ;;; AFTER PERFORMING SOME CLEANUP. MANY SYMBOLS ARE EXPUNGED ;;; SO THAT .FASL FILES WILL NOT SPEND INFINITE TIME TRYING TO ;;; PASS THEM TO DDT. DEFINE FASEND IF2,[ EXPUNGE NIL A B C AR1 AR2A NACS T TT D R F FREEAC P FLP FXP SP EXPUNGE LERR ACALL AJCALL LER3 ERINT PP STRT SERINT TP IOJRST UUOMAX EXPUNGE CALL JCALL CALLF JCALLF NCALL NJCALL NCALLF NJCALF NUUOCLS EXPUNGE NERINT NASCII EXPUNGE %UDF %UBV %WTA %UGT %WNA %GCL %FAC %IOL EXPUNGE %%UDF %%UBV %%WTA %%UGT %%WNA %%GCL %%FAC %%IOL EXPUNGE ASAR TTSAR EXPUNGE AS.SFA AS.JOB AS.FIL AS.RDT AS.OBA AS.SX AS.FX AS.FL AS.DB AS.CX EXPUNGE AS.DX AS.GCP EXPUNGE TTS.CL TTS.IM TTS.BN TTS.TY TTS.IO TTS.CN TTS.GC EXPUNGE TTSDIM TTS.1D TTS.2D TTS.3D TTS.4D TTS.5D EXPUNGE FI.EOF FO.EOF FI.BBC FI.BBF TI.BFN FT.CNS F.GC EXPUNGE F.MODE FBT.CM FBT.SA FBT.CP FBT.LN FBT.AP FBT.CC FBT.ND EXPUNGE F.CHAN F.JFN F.FLEN F.FPOS F.DEV F.SNM F.PPN F.FN1 F.FN2 EXPUNGE F.RDEV F.RSNM F.RFN1 F.RFN2 EXPUNGE F.DIR F.FNM F.EXT F.VRS EXPUNGE L.6DEV L.6DIR L.6FNM L.6EXT L.6VRS L.D6BT L.N6BT L.F6BT EXPUNGE LOPOFA EXPUNGE TI.ST1 TI.ST2 TI.ST3 TI.ST4 ATO.LC EXPUNGE AT.CHS AT.LNN AT.PGN FO.LNL FO.PGL FO.RPL LONBFA EXPUNGE FB.BFL FB.BVC FB.BYT FB.IBP FB.BP FB.CNT FB.HED FB.NBF EXPUNGE FB.BWS FB.ROF FB.BUF EXPUNGE J.INTF J.LFNM J.GC J.INTB J.STAD J.UIND LOJOBA J.SYMS J.CRUF EXPUNGE SR.CAL SFCALI SR.WOM SR.UDL SR.FML SR.FUN SR.PNA SR.FUS SR.LEN EXPUNGE SO.OPN SO.CLO SO.REN SO.DEL SO.TRP SO.PR1 SO.TYI SO.UNT SO.TIP EXPUNGE SO.IN SO.EOF SO.TYO SO.OUT SO.FOU SO.RED SO.RDL SO.PRT SO.PRC EXPUNGE SO.MOD SO.POS EXPUNGE ST.LS ST.$FS ST.FX ST.FL ST.BGN ST.SY ST.SA ST.VAC ST.$PDLNM EXPUNGE ST.$XM ST.$NXM ST.PUR ST.HNK ST.DB ST.CX ST.DX ST. IRP X,,[02,1N,12,23,2N,0,1,2,4,01,012,01234,0234,3456,1234567 13456,234,345,234567,76543,45] EXPUNGE LA!X FA!X TERMIN MACROLOOP NBITMACS,BTMC,* ] ;END OF IF2 END TERMIN SUBTTL SYMBOL BLOCK-STRUCTURE DEFINITIONS ;;; FORMAT OF SYMBOL HEADER FOR BIBOP: ;;; THE MAIN HEADER OF A SYMBOL IS A SINGLE WORD IN SYMBOL SPACE. ;;; THE RIGHT HALF CONTAINS THE PROPERTY LIST, AND THE LEFT HALF ;;; POINTS TO THE REST OF THE HEADER, WHICH IS IN THE IS2 OR SY2 AREA. ;;; SINCE THE REST OF THE HEADER (ALSO CALLED A "SYMBOL BLOCK") MUST ;;; LIE ON AN EVEN WORD BOUNDARY, THE LOW BIT OF THE LEFT HALF OF ;;; THE MAIN HEADER IS NORMALLY ZERO. THIS BIT IS USED BY THE ;;; GARBAGE COLLECTOR FOR MARKING PURPOSES, AND THEN RESET TO ZERO. ;;; THE SYMBOL BLOCK IS 2 WORDS LONG: ;;; ,, ;;; ,, ;;; THE "VARIOUS BITS" ARE: ;;; 4.9-3.9 ONES (FOR NO PARTICULARLY GOOD REASON) ;;; 3.9 ZERO (RESERVED FOR SPECIAL VALUE CELL/LAP HACK) ;;; 3.8 1 => SYMBOL BLOCK MAY BE PURE (SEE GCMARK) ;;; 3.7 ONE IFF COMPILED CODE NEEDS THE SYMBOL ;;; 3.6 ONE IFF COMPILED CODE REFERENCES BY OTHER THAN CALL UUO ;;; (IMPLIES 3.7 WHICH *MUST* ALSO BE ON) ;;; 3.5-3.1 ZERO (SO CAN INDIRECT THROUGH THE WORD TO GET VALUE) ;;; THE ARGS PROPERTY IS IN THE SAME FORMAT FASLOAD USES, ;;; TWO NINE-BIT BYTES DECODED AS FOLLOWS: ;;; 0 => NIL ;;; 777 => 777 (EFFECTIVELY INFINITY) ;;; N => N-1, N NOT 0 OR 777 ;;; THUS 000006 = (NIL . 5), 004005 = (3 . 4), AND 002777 = (1 . 777) SYMVC==0 ;BITS,,VC SYMARGS==1 ;ARGS PROP,,PNAME SYMPNAME==1 SY.ONE==:777000 ;ONES (NO GOOD REASON!!) SY.LAP==:400 SY.PUR==:200 SY.CCN==:100 SY.OTC==:040 SY.ZER==:037 SY.==:1,, SUBTTL FORMAT OF ARRAYS ;;; ARRAYS ARE POINTED TO BY A TWO-WORD SAR (SPECIAL ARRAY CELL). ;;; SARS RESIDE IN A SPECIAL SPACE CALLED SAR SPACE. ASAR==:0 ;SAR POINTER POINTS TO ASAR (CODE DEPENDS ON THIS) TTSAR==:1 ;TTSAR COMES JUST AFTER IT ;;; THE FIRST WORD OF THE SAR, CALLED THE ASAR, POINTS TO THE ARRAY ;;; HEADER; PUSHJ'ING INDIRECTLY THOUGH IT GETS TO THE ARRAY ;;; SUBSCRIPT EVALUATION CODE. THE LEFT HALF, EXCLUDING THE ;;; INDIRECT AND INDEX BITS, CONTAINS VARIOUS BITS DESCRIBING ;;; THE TYPE OF THE ARRAY: AS.SFA==:200000 ;SFA ARRAY AS.JOB==:100000 ;JOB ARRAY AS.FIL==:40000 ;FILE ARRAY AS.RDT==:20000 ;READTABLE AS.OBA==:10000 ;OBARRAY AS.DX==:4000 ;DUPLEX ;THESE ARE AS.CX==:2000 ;COMPLEX ; THE ACCESS AS.DB==:1000 ;DOUBLE ; METHODS - AS.SX==:400 ;S-EXPRESSION ; EXACTLY ONE AS.FX==:200 ;FIXNUM ; SHOULD BE SET AS.FL==:100 ;FLONUM ; IN EACH ASAR AS.GCP==:40 ;GC SHOULD USE AOBJN PTR TO MARK ARRAY ;;; THE SECOND WORD, CALLED THE TTSAR, POINTS TO THE ARRAY DATA ;;; AND IS INDEXED BY ACCUMULATOR TT. ITS LEFT HALF, EXCLUDING ;;; AGAIN THE INDIRECT AND INDEX BITS, CONTAIN MORE INFORMATION ;;; ABOUT THE ARRAY: TTS.CL==:40000 ;CLOSED FILE TTS.BM==:20000 ;TOPS-10 I/O BUFFER HAS BEEN MOVED TTS.IM==:2000 ;1 => IMAGE ;BOTH 0 TTS.BN==:1000 ;1 => BINARY (FIXNUM) ; => ASCII TTS.TY==:400 ;0 => DSK-TYPE, 1 => TTY TTS.IO==:200 ;0 => IN, 1 => OUT TTS.CN==:100 ;COMPILED CODE NEEDS THIS SAR TTS.GC==:40 ;USED AS MARK BIT BY GC TTSDIM==:410300 ;BYTE POINTER FOR # OF DIMENSIONS (1-5) TTS.1D==:100000 ;DEFINITIONS TTS.2D==:200000 ; FOR SPECIFYING TTS.3D==:300000 ; NUMBER OF TTS.4D==:400000 ; ARRAY TTS.5D==:500000 ; DIMENSIONS ;;; S-EXPRESSION ARRAYS HAVE THE FOLLOWING FORM: ;;; -<# WDS FOR GC MARK>,,<1ST WD OF DATA TO MARK> ;;; HEADER: JSP TT,DIMS ;ASAR POINTS HERE; N=# OF DIMS ;;;
;LH USED BY FLASH ;;; ;;; ... ;;; ;;; DATA: ,, ;TTSAR POINTS HERE ;;; ... ;DATA PACKED 2/WD ;;; ,, ;;; ;;; THE FORMAT OF A NUMBER ARRAY IS AS FOLLOWS: ;;; ;PROBABLY MEANINGLESS ;;; HEADER: PUSH P,CFIX1 ;CFLOAT1 FOR A FLONUM ARRAY ;;; JSP TT,DIMF ;N=# OF DIMS ;;;
;LH USED BY FLASH ;;; ;;; ... ;;; ;;; DATA: ;TTSAR POINTS HERE ;;; ;FULL-WORD DATA 1/WD ;;; ... ;;; ;;; THE AOBJN POINTER AT THE TOP OF EACH ARRAY IS MEANINGFUL ONLY ;;; IF THE AS.GCP BIT IS 1 IN THE ARRAY'S ASAR; IT INDICATES ;;; WHAT ENTRIES IN THE ARRAY GC SHOULD MARK. FOR S-EXPRESSION ;;; ARRAYS, THIS IS GENERALLY THE ENTIRE ARRAY; FOR OBARRAYS, ;;; IT INCLUDES THE BUCKETS BUT NOT THE SCO TABLE. FOR ;;; READTABLES, WHICH ARE OTHERWISE FIXNUM ARRAYS, UNDER NEWRD ;;; THE GC AOBJN POINTER INDICATES THAT THE LIST OF CHARACTER ;;; MACRO FUNCTIONS SHOULD BE MARKED. ;;; NOTE THAT IF SUCH AN AOBJN POINTER IS OF THE FORM <-N>,,, ;;; THEN 2*N ENTRIES ARE MARKED; THE LEFT HALF IS THE NUMBER ;;; OF WORDS TO BE MARKED, WITH TWO ENTRIES PER WORD. ;;; CORRESPONDS TO ARRAY TYPE BITS IN ASAR'S. SUBTTL FORMAT OF FILE ARRAYS ;;; FILE ARRAYS ARE ARRAYS WHICH HAVE THE AS.FIL BIT SET ;;; IN THE ASAR AND SOME EXTRA BITS IN THE TTSAR DESCRIBING ;;; THE TYPE OF ARRAY. ;;; A FILE ARRAY CONTAINS A NUMBER OF VARIABLES RELATED TO ;;; THE FILE, AND POSSIBLY A BUFFER FOR DATA. ;;; THE PREFIX OF EACH NAME OF A FILE ARRAY COMPONENT INDICATES THE ;;; TYPES OF FILE ARRAYS TO WHICH IT IS APPLICABLE. THUS TI.ST1 ;;; IS ONLY FOR TTY INPUT FILE ARRAYS. ;;; NOTE: COMPONENTS MARKED (RELOC) MUST HAVE THEIR RIGHT ;;; HALVES RELOCATED WHEN THE ARRAY IS MOVED. .SEE GT3D ;;; THE FOLLOWING ARE INDICES INTO THE FILE ARRAY'S DATA AREA ;;; (I.E. THEY ARE USED TO INDEX THROUGH THE TTSAR). FI.EOF==:0 ;EOF FUNCTION FO.EOP==:0 ;END OF PAGE FUNCTION FJ.INT==:0 ;INTERRUPT FUNCTION FOR USR DEVICE FI.BBC==:1 ;BUFFERED BACK CHARS FOR ASCII FILES ; LEFT HALF: SINGLE CHAR (3.8=1 IF ANY, ; SO CAN DISTINGUISH ^@ FROM NONE) ; RIGHT HALF: LIST OF CHARS FOLLOWING THE ONE ; IN THE LEFT HALF .SEE $DEVICE FI.BBF==:2 ;LIST OF BUFFERED BACK FORMS (NOT IMPLEMENTED) TI.BFN==:3 ;BUFFER-FORWARD (PRESCAN) FUNCTION FOR READ FT.CNS==:4 ;ASSOCIATED TTY FILE FOR OTHER DIRECTION .SEE STTYCONS ;;; SLOTS 5, 6, AND 7 ARE RESERVED FOR EXPANSION. F.GC==:10 ;NUMBER OF SLOTS GC SHOULD EXAMINE F.MODE==:10 ;MODE BITS FBT.CM==:400000 ;4.9 0=BUFFERED, 1=CHARMODE FBT.SA==:200000 ;4.8 SAIL CHARACTER SET (OUTPUT ONLY) FBT.CP==:100000 ;4.7 CURSORPOS WILL SUCCEED (?) ; ON ITS, REFLECTS %TOMVU (CAN MOVE UP) .SEE OPNTO1 FBT.LN==:40000 ;4.6 HANDLE TTY IN LINE MODE SA$ FBT.AP==:20000 ;4.5 OPENED IN APPEND MODE SA% 10% FBT.AP==:20000 ;4.5 OPENED IN APPEND MODE SA% 10$ FBT.AP==:0 ;4.5 NOT YET HACKED FOR VANILLA TOPS-10 FBT.EC==:10000 ;4.4 OUTPUT TTY IN ECHO AREA (ITS ONLY) FBT.SE==:2000 ;4.2 TTY CAN SELECTIVELY ERASE FBT.FU==:1000 ;4.1 TTY SHOULD READ/PRINT FULL 12.-BIT ; CHARACTERS (FIXNUM MODE) FBT.ND==:400 ;3.9 DON'T MEREGEF WITH DEFAULTF (NEVER LEFT ON ; IN OPTIONS WORD) IT% FBT.CA==:0 ;THIS SHOULD WORK CORRECTLY IT$ FBT.CA==:40 ;3.6 CLA DEVICE (ITS ONLY) FBT.SC==:20 ;3.5 SCROLL MODE ;THE RIGHT HALF IS USED TO INDEX VARIOUS TABLES. ;1.4-1.3 0=ASCII, 1=FIXNUM, 2=IMAGE ;1.2 0=DSK, 1=TTY ;1.1 0=INPUT, 1=OUTPUT F.CHAN==:11 ;I/O CHANNEL NUMBER ;FOR ALL IMPLEMENTATIONS, THIS IS THE INDEX INTO .SEE CHNTB ; THE CHANNEL TABLE. ;FOR THE ITS AND D10 IMPLEMENTATIONS, IT IS ; ALSO THE I/O CHANNEL NUMBER. 20$ F.JFN==:12 ;THE JOB-FILE NUMBER FOR THIS FILE F.FLEN==:13 ;THE LENGTH OF THE FILE, OR -1 IF RANDOM ACCESS IS IMPOSSIBLE. ; MAY NOT BE UP-TO-DATE ON AN OUTPUT FILE, BUT FILEPOS .SEE FPOS5 ; UPDATES IT FIRST IN THIS CASE. F.FPOS==:14 ;FILE POSITION ;FOR SINGLE MODE FILES, THIS IS THE ACTUAL FILE POSITION. ;FOR BLOCK MODE, THIS IS THAT OF THE BEGINNING OF .SEE FB.BUF ; THE BUFFER IN THE FILE ARRAY, AND ONE .SEE FB.B ; MUST LOOK AT FB.BVC AND FB.CNT .SEE FB.CNT ; (OR WHATEVER) TO CALCULATE THE EXACT FILEPOS. ;THE POSITION IS MEASURED IN CHARACTERS FOR ASCII FILES, ; AND WORDS FOR FIXNUM FILES. ;THIS VALUE MAY BE GARBAGE IF F.FLEN IS NEGATIVE. ;;; SLOTS 15-17 ARE RESERVED. IFN ITS+D10,[ ;;; FROM F.DEV TO F.RFN2 ARE USED BY JOB ARRAYS ALSO. ;;; MUST HAVE (F.DEV, F.SNM/F.PPN, F.FN1, F.FN2) IN THAT ORDER. ;;; DITTO FOR (F.RDEV, F.RSNM/F.RPPN, F.RFN1, F.RFN2). L.6DEV==:1 ;LENGTH OF DEVICE NAME IN "SIXBIT" FORM L.6DIR==:1 ;LENGTH OF DIRECTORY NAME L.6FNM==:1 ;LENGTH OF FILE NAME L.6EXT==:1 ;LENGTH OF EXTENSION (TYPE) L.6VRS==:0 ;LENGTH OF VERSION (GENERATION) ] ;END OF IFN ITS+D10 IFN D20,[ ;;; FOR D20, "SIXBIT" FORM IS REALLY AN ASCIZ STRING. L.6DEV==:8 ;LENGTH OF DEVICE NAME IN "SIXBIT" FORM L.6DIR==:8 ;LENGTH OF DIRECTORY NAME L.6FNM==:8 ;LENGTH OF FILE NAME L.6EXT==:8 ;LENGTH OF EXTENSION (TYPE) L.6VRS==:2 ;LENGTH OF VERSION (GENERATION) ] ;END OF IFN D20 L.D6BT==:L.6DEV+L.6DIR ;LENGTH OF DEVICE/DIRECTORY "SIXBIT" FORM L.N6BT==:L.6FNM+L.6EXT+L.6VRS ;LENGTH OF FILE NAMES IN "SIXBIT" FORM L.F6BT==:L.D6BT+L.N6BT ;LENGTH OF TOTAL FILE SPEC IN "SIXBIT" FORM ;;; THESE ARE THE NAME WHICH WERE GIVEN TO OPEN. F.DEV==:20 ;DEVICE NAME IFE D20,[ IT$ F.SNM==:F.DEV+L.6DEV ;SYSTEM NAME (SNAME) 10$ F.PPN==:F.DEV+L.6DEV ;PROJECT-PROGRAMMER NUMBER F.FN1==:F.DEV+L.D6BT ;FILE NAME 1 F.FN2==:F.FN1+L.6FNM ;FILE NAME 2 (D10: EXTENSION) ;;; THESE ARE THE NAMES RETURNED BY THE TRUENAME FUNCTION. F.RDEV==:F.DEV+L.F6BT ;"REAL" DEVICE NAME IT$ F.RSNM==:F.RDEV+L.6DEV ;"REAL" SYSTEM NAME 10$ F.RPPN==:F.RDEV+L.6DEV ;"REAL" PPN F.RFN1==:F.RDEV+L.D6BT ;"REAL" FILE NAME 1 F.RFN2==:F.RFN1+L.6FNM ;"REAL" FILE NAME 2 ] ;END OF IFE D20 IFN D20,[ F.DIR==:F.DEV+L.6DEV ;DIRECTORY F.FNM==:F.DIR+L.6DIR ;FILE NAME F.EXT==:F.FNM+L.6FNM ;EXTENSION F.VRS==:F.EXT+L.6EXT ;VERSION ;;; THE "REAL" FILE NAMES ARE NOT STORED, BUT FETCHED BY JSYS EACH TIME. ; F.RDEV ; F.RDIR ; F.RFNM ; F.REXT ; F.RVRS ] ;END OF IFN D20 LOPOFA==:70 .SEE ALFILE ;LENGTH OF PLAIN OLD FILE ARRAY IFL LOPOFA-, WARN [DEFINITION OF LOPOFA IS TOO SMALL] IFN ITS+D20+SAIL,[ ;;; FOR ITS, THESE ARE TTYST1 AND TTYST2 FOR GIVING TO TTYSET. ;;; FOR D20, THESE ARE THE CCOC WORDS FOR GIVING TO SFCOC. ;;; FOR SAIL, THESE ARE THE ACTIVATION WORDS FOR SETACT. TI.ST1==:LOPOFA+0 ;TTY STATUS WORD 1 TI.ST2==:LOPOFA+1 ;TTY STATUS WORD 2 IT% TI.ST3==:LOPOFA+2 ;TTY STATUS WORD 3 IT% TI.ST4==:LOPOFA+3 ;TTY STATUS WORD 4 ] ;END OF ITS+D20+SAIL ATO.LC==:LOPOFA+4 ;LAST CHARACTER FLAG FOR ASCII OUTPUT: ;ZERO: NORMAL STATE. ;POSITIVE: LAST CHARACTER OUTPUT WAS A SLASH, ; SO THE AUTOMATIC TERPRI SHOULD BE INHIBITED. ;NEGATIVE: LAST CHARACTER OUTPUT WAS A , ; SO IT MAY BE NECESSSARY TO SUPPLY A . AT.CHS==:LOPOFA+5 ;CHARPOS AT.LNN==:LOPOFA+6 ;LINENUM AT.PGN==:LOPOFA+7 ;PAGENUM FO.LNL==:LOPOFA+10 ;LINE LENGTH ;NORMALLY INITIALIZED TO 1 LESS THAN THE ACTUAL WIDTH ; OF THE DEVICE TO ALLOW FOR SLASH OVERRUN. .SEE STERPRI ;MAY BE NEGATIVE, IN WHICH CASE THE ; MAGNITUDE IS THE ACTUAL VALUE. FO.PGL==:LOPOFA+11 ;PAGE LENGTH FO.RPL==:LOPOFA+12 ;"REAL" PAGEL FOR TTYS ;;; SLOTS 13-17 ARE RESERVED FOR EXPANSION. LONBFA==:LOPOFA+20 ;LENGTH OF NON-BUFFERED FILE ARRAY ;;; EVERYTHING AFTER THIS IS ONLY FOR FILES WITH BUFFERS FB.BYT==:LONBFA+0 ;NUMBER OF DATA BYTES PER WORD FB.BFL==:LONBFA+1 ;LENGTH OF BUFFER IN BYTES FB.BVC==:LONBFA+2 ;# VALID CHAARS IN BUFFER (ONLY INPUT FILES) IFN ITS+D20,[ FB.IBP==:LONBFA+3 ;INITIAL BUFFER BYTE POINTER (RELOC) FB.BP==:LONBFA+4 ;CURRENT BUFFER BYTE POINTER (RELOC) FB.CNT==:LONBFA+5 ;COUNT OF REMAINING BYTES IN BUFFER ] ;END OF ITS+D20 IFN D10,[ FB.HED==:LONBFA+3 ;ADDRESS OF 3-WORD BUFFER RING HEADER FB.NBF==:LONBFA+4 ;NUMBER OF BUFFERS FB.BWS==:LONBFA+5 ;SIZE OF BUFFER IN WORDS (NOT COUNTING BUFFER HEADER) SA$ FB.ROF==:LONBFA+6 ;(NEGATIVE) RECORD OFFSET IN BYTES, I.E. FILEPOS ; OF THE PHYSICAL BEGINNING OF THE FILE ] ;END OF IFN D10 FB.BUF==:LONBFA+10 ;BEGINNING OF BUFFER ;FOR ITS AND D20, THE DATA BUFFER BEGINS HERE. ;FOR D10, THE BUFFER RING STRUCTURE BEGINS HERE. ;FOR TTY INPUT FILES, THE "BUFFER" IS AN ARRAY ; OF INTERRUPT FUNCTIONS FOR EACH ASCII CHARACTER. SUBTTL FORMAT OF JOB ARRAYS IFN ITS,[ ;;; JOB ARRAYS ARE ARRAYS WHICH HAVE THE AS.JOB BIT SET ;;; IN THE ASAR. THE TTS.CL BIT IS RELEVANT HERE ALSO, ;;; INDICATING A CLOSED JOB ARRAY. ;;; THE ARRAY CONTAINS VARIOUS DATA ASSOCIATED WITH THE JOB. ;;; NOTE: COMPONENTS MARKED (RELOC) MUST HAVE THEIR RIGHT ;;; HALVES RELOCATED WHEN THE ARRAY IS MOVED. ;;; THE FOLLOWING ARE INDICES INTO THE FILE ARRAY'S DATA AREA ;;; (I.E. THEY ARE USED TO INDEX THROUGH THE TTSAR). J.INTF==:0 ;INTERRUPT FUNCTION (NEEDED BY INT SYSTEM) J.CINT==:1 ;CHANNEL INTERRUPT FUNCTION J.LFNM==:2 ;LOAD FILE NAMELIST? J.CRUFT==:3 ;RANDOM CRUFT (USUALLY PROPERTY LIST) J.GC==:4 ;NUMBER OF SLOTS GC SHOULD EXAMINE ;SLOTS 3-12 RESERVED ;;; F.DEV THROUGH F.RFN2 (12 TO 21) APPLY TO JOB ARRAYS ALSO. J.INTB==:LOPOFA+0 ;INTERRUPT BIT, OR ZERO FOR FOREIGN JOB J.STAD==:LOPOFA+1 ;START ADDRESS J.UIND==:LOPOFA+2 LOJOBA==:FB.BUF J.SYMS==:FB.BUF ;START OF SYMBOL TABLE, IF ANY ] ;END OF IFN ITS IFE SFA, SFCALI==-1 IFN SFA,[ SUBTTL FORMAT OF SFA OBJECTS ;;; AN SFA OBJECT HAS THE AS.SFA BIT SET IN THE ASAR. TTS.CL IS IGNORED. ;;; THE FOLLOWING ARE INDICIES INTO THE SFA ARRAY AND ARE UNMARKED FROM: SR.CAL==:0 ;THE LISP CALL UUO XCT'ED TO INVOKE THE SFA FUNCTION SFCALI==:SR.CAL ;FOR COMPILED CODE SR.WOM==:1 ;WHICH-OPERATIONS MASK: ENCODED MASK OF THE OPERATIONS THAT ; THE SFA CAN PERFORM. USED FOR QUICK TESTING IN CERTAIN ; DISPATCH CASES. BITS AS FOLLOWS: SR.UDL==:2 ;USER DATA LENGTH ;;; ***NOTE: THE HALVNESS OF THE BITS MUST NOT CHANGE *** ;LH BITS SO.OPN==:400000 ;OPEN SO.CLO==:200000 ;CLOSE SO.REN==:100000 ;RENAMEF SO.DEL==:040000 ;DELETEF SO.TRP==:020000 ;TERPRI SO.PR1==:010000 ;PRIN1 SO.TYI==:004000 ;TYI SO.UNT==:002000 ;UNTYI SO.TIP==:001000 ;TYIPEEK SO.IN==:000400 ;IN SO.EOF==:000200 ;EOFFN SO.TYO==:000100 ;TYO SO.PRO==:000040 ;PRINT-OBJECT SO.FOU==:000020 ;FORCE-OUTPUT SO.RED==:000010 ;READ SO.RDL==:000004 ;READLINE SO.PRT==:000002 ;PRINT SO.PRC==:000001 ;PRINC ;RH BITS SO.MOD==:400000 ;FILEMODE SO.POS==:200000 ;FILEPOS SO.ICL==:100000 ;CLEAR-INPUT SO.OCL==:040000 ;CLEAR-OUTPUT SO.OUT==:020000 ;OUT SR.FML==:3 ;FIRST MARKED LOCATION SR.FUN==:3 ;RH IS SFA FUNCTION SR.PNA==:4 ;RH IS PRINTNAME SR.FUS==:5 ;LH IS FIRST USER SLOT SR.LEN==:5 ;NUMBER OF WORDS NEEDED BY THE SYSTEM ] ;END IFN SFA ;;; Size of hunks IFDEF SEGLOG, HNKLOG==SEGLOG-1 IFNDEF SEGLOG, HNKLOG==11;;@ END OF DEFNS 221 ;;; DON'T HACK THIS $INSRT - UNIFY DEPENDS ON IT ;;@ MACS 71 LOTSA MOBY MACROS ;;; ***** MACLISP *** RANDOM MIDAS MACROS FOR USE IN LISP SOURCE * ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** SUBTTL RANDOM MACROS ;;; MACRO TO REMOVE SYMBOLS OF THE FORM "GXXXXX" DEFINE GEXPUN DEFFLUSH .GSSET 0 STPFL==0 .TAG FOO FLUSH IFE STPFL, .GO FOO TERMIN DEFINE DEFFLUSH \SYM DEFINE FLUSH \ZZX IFSE SYM,ZZX, STPFL==1 EXPUNGE ZZX TERMIN TERMIN DEFINE HAOLNG NM,N RADIX 2 NM==HAOWNG \N RADIX 8 TERMIN DEFINE HAOWNG A .LENGTH /A/ TERMIN DEFINE MAYBE DEF IF1,[ IRPS SYM,,[DEF] IFNDEF SYM, DEF .ISTOP TERMIN ] TERMIN DEFINE TBLCHK START,LENGT IFN .--, WARN [WRONG LENGTH TABLE] TERMIN ;;; "POP IMMEDIATE" MACRO TRIES TO DECREMENT A PDL POINTER IN THE BEST WAY. DEFINE POPI IFN KL10, ADJSP AC,- .STOP IFDEF R70, IFDEF LR70, IFL -LR70, SUB AC,R70+ .STOP SUB AC,[,,] TERMIN ;;; "PUSH N SLOTS" MACRO PUSHES ZERO WORDS ONTO A PDL. DEFINE PUSHN IFE , .STOP IFE -1, PUSH AC,R70 .STOP IFE AC-P,{ PUSHN1 AC,N,NPUSH .STOP} IFE AC-FXP,{ PUSHN1 AC,N,0PUSH .STOP} IFE AC-FLP,{ PUSHN1 AC,N,0.0PUSH .STOP} WARN [PUSH AC,N UNKNOWN PDL] TERMIN DEFINE PUSHN1 IFLE -N!XPUSH, JSP T,XPUSH- .STOP JSP T,XPUSH-N!XPUSH PUSHN1 AC,,XPUSH TERMIN SUBTTL $LOSEG, $HISEG, IFN D10,[ IFN HISEGMENT,[ DEFINE $LOSEG ;MACRO TO SWITCH TO LOW SEGMENT FOR 2SEG ASSEMBLY IFN %LOSEG+1,[ %HISEG==.-HILOC LOC FIRSTLOC+%LOSEG %LOSEG==-1 CURSTD==STDLO ] ;END OF IFN %LOSEG+1 .ELSE WARN [ALREADY IN LOW SEGMENT] TERMIN DEFINE $HISEG ;MACRO TO SWITCH TO HIGH SEGMENT FOR 2SEG ASSEMBLY IFN %HISEG+1,[ %LOSEG==.-FIRSTLOC LOC HILOC+%HISEG %HISEG==-1 CURSTD==STDHI ] ;END OF IFN %HISEG+1 .ELSE WARN [ALREADY IN HIGH SEGMENT] TERMIN ] ;END IFN HISEGMENT IFE HISEGMENT,[ DEFINE $LOSEG TERMIN DEFINE $HISEG TERMIN ] ;END IFE HISEGMENT ] ;END OF IFN D10 SUBTTL PIONAGAIN, PIPAUSE, PION, TICCMAP IFN ITS,[ DEFINE PIPAUSE ;DISABLE INTERRUPT SYSTEM .SUSET PIHOLD TERMIN DEFINE PIONAGAIN .SUSET PINBL TERMIN DEFINE PION .SUSET PINBL TERMIN ] ;END OF IFN ITS IFN D10\D20,[ DEFINE PIPAUSE PUSHJ P,DALINT TERMIN DEFINE PIONAGAIN PUSHJ P,REAINT TERMIN DEFINE PION PUSHJ P,ENBINT TERMIN ] ;END OF IFN D10\D20 IFN D20,[ ;DO THE "BODY' WITH "CODE" SUCCESSIVELY SET TO TERMINAL-INTERRUPT-CONTROL OPTIONS DEFINE TICMAP {BODY} IRP CODE,,[CB,CD,CG,CW,CX,CZ,CA,CV,CE,CF] BODY TERMIN TERMIN ] ;END OF IFN D20 SUBTTL FUMBLE, STUMBLE, AND GRUMBLE DEFINE FUMBLE FF,RIDER,SPECS ;FOR SPACES STUMBLE FUMBLE,FF,RIDER,0,SEGSIZ,[SPECS] TERMIN DEFINE GRUMBLE PDL,RIDER,SPECS ;FOR PDLS STUMBLE GRUMBLE,PDL,RIDER,20,100,[SPECS] TERMIN DEFINE STUMBLE NAME,FF,RIDER=[IFE 0],LO,HI,%SPECS ZZZ==0 IRP SPEC,,[%SPECS] IRP COND,VALS,[SPEC] IFN COND,[ IRP M,,[MIN,MAX]Q,,[LO,HI]V,,VALS RIDER,[ IFL V-Q, M!!FF==:Q .ELSE M!!FF==:V ] .ELSE M!!FF==:0 TERMIN ZZZ==ZZZ+1 ] .ISTOP TERMIN TERMIN IFN ZZZ-1, WARN \ZZZ,[ SPECS SUCCEEDED FOR NAME FF] EXPUNGE ZZZ TERMIN SUBTTL PGBOT, [PGTOP], PAGEUP, SEGUP, SPCBOT, SPCTOP ;;; NOTE THAT PGBOT DEFINES PGTOP FOR THE NEXT USE, WHILE ;;; PGTOP IS AUTO-EXPUNGING (AND VICE VERSA). DEFINE DPGBOT DEFINE PGBOT SPC PGTPMK==. DEFINE PGBOT SPC1 WARN [ILLEGAL PGBOT SPC1] TERMIN DEFINE PGTOP SPC1,CRUFT IFSN SPC1,SPC, WARN [PGTOP SPC1 DOESN'T MATCH PGBOT SPC] CONC CPG,\NPGTPS,: CONSTANTS CONC ECPG,\NPGTPS,:: PGTOP1 \NPGTPS,\.-PGTPMK,[CRUFT] NPGTPS==NPGTPS+1 DPGBOT TERMIN TERMIN DEFINE PGTOP SPC,CRUFT WARN [ILLEGAL PGTOP SPC,CRUFT] TERMIN TERMIN DPGBOT DEFINE PGTOP1 N,SIZE,STUFF PRINTX  P!N: SIZE [STUFF]  TERMIN .XCREF PGTOP1 DEFINE PAGEUP REL$ LOC .RL1+<<.-.RL1+CURSTD+PAGSIZ-1>&PAGMSK>-CURSTD REL% LOC <<.-CURSTD+PAGSIZ-1>&PAGMSK>-CURSTD TERMIN DEFINE SEGUP PT REL$ LOC .RL1+<&SEGMSK>-CURSTD REL% LOC <&SEGMSK>-CURSTD TERMIN DEFINE SPCBOT SPC REL$ ZZ==.-.RL1 REL% ZZ==. ZZY==.TYPE B!SPC!SG IFN <17-ZZY>*<3-ZZY>*<11-ZZY>,[ IFN B!SPC!SG-., WARN [FORMERLY B!SPC!SG=]\B!SPC!SG,[, BUT NOW B!SPC!SG=]\ZZ ] IFN &SEGKSM, WARN \ZZ+CURSTD,[=BAD BOUNDARY FOR B!SPC!SG] B!SPC!SG==. TERMIN ;;; NOTE WELL! ZZW MUST BE SAFE ACROSS THE SPCTOP MACRO DEFINE SPCTOP SPC,TYP,CRUFT ZZ==. SEGUP . ZZX==<.-B!SPC!SG>/SEGSIZ ZZY==.TYPE N!SPC!SG IFN <17-ZZY>*<3-ZZY>*<11-ZZY>,[ IFN N!SPC!SG-ZZX, WARN [FORMERLY N!SPC!SG=]\N!SPC!SG,[, BUT NOW N!SPC!SG=]\ZZX ] N!SPC!SG==ZZX IFL ZZX-5, SPCTP1 \ZZX,[CRUFT]\<.-ZZ> IFGE ZZX-5, SPCTP2 \ZZX,[CRUFT]\<.-ZZ> TERMIN DEFINE SPCTP1 N,CRUFT,U IRP Q,,[0,1,2,3,4]R,,[ZERO,ONE,TWO,THREE,FOUR] IFE N-Q,[ PRINTX  ***** R CRUFT SEGMENT IFN N-1, PRINTX \S\ IFN U, PRINTX \ [U UNUSED WORDS]\ PRINTX \ \ ] IFE N-Q, .ISTOP TERMIN TERMIN DEFINE SPCTP2 N,CRUFT,U IRP Q,,[5,6,7,10,11,12,13,14,15,16,17,20,21,22 23,24,N]R,,[FIVE,SIX,SEVEN,EIGHT,NINE,TEN ELEVEN,TWELVE,THIRTEEN,FOURTEEN,FIFTEEN,SIXTEEN,SEVENTEEN EIGHTEEN,NINETEEN,TWENTY,N (OCTAL)] IFE N-Q,[ PRINTX  ***** R CRUFT SEGMENT IFN N-1, PRINTX \S\ IFN U, PRINTX \ [U UNUSED WORDS]\ PRINTX \ \ ] IFE N-Q, .ISTOP TERMIN TERMIN .XCREF SPCTP1 SPCTP2 SUBTTL PURTRAP, IOCTRAP, 2DIF, AND INTPRO MACROS ;;; FEATURE FOR AUTOMATIC TRAPOUT ON PURE PAGE VIOLATIONS ;;; STANDARD USAGE IS TO REPLACE ;;; MOVEM X,Y ;COULD CAUSE PURE PAGE TRAP ;;; WITH ;;; PURTRAP PATCH-LOC,AC, MOVEM X,Y ;;; IF THE INSTRUCTION CAUSES A PURE PAGE VIOLATION, ;;; THEN THE PURE PAGE TRAP HANDLER WILL TRANSFER TO FOO, ;;; WITH ALL ACS, ETC. INTACT (HOPEFULLY), RATHER THAN ;;; ERRORING OUT, WHICH IS THE DEFAULT. SEE PURPGI. ;;; FOR DEC-10, THERE IS AN EXPLICIT CHECK FOR TRYING TO CLOBBER ;;; THE HISEG. ;;; A SIMILAR FEATURE FOR IOC TRAPS ;;; STANDARD USAGE IS: ;;; ;;; BAR: XCT D ;D HAS .IOT ;;; IOCTRAP TT,FOO,N ;N IS OPTIONAL ;;; ;;; ;;; IF THE INSTRUCTION AT BAR CAUSES AN IOC ERROR, ;;; THEN THE IOC ERROR CODE IS PUT INTO ACCUMULATOR TT, ;;; AND CONTROL TRANSFERRED TO FOO WITH ALL OTHER ACS INTACT. ;;; IF N IS GIVEN, ONLY IOC ERROR CODE N IS TRAPPED. IFN ITS+D20,[ DEFINE PURTRAP X,B-INST INST PURTR1 \.-1,\NPURTR,D,X NPURTR==NPURTR+1 TERMIN DEFINE PURTR1 L,N,AC,X DEFINE ZZP!N CAIN AC,L HRROI AC,X TERMIN TERMIN ;;; FOR COMMENTS ON 2DIF, SEE BELOW DEFINE 2DIF INST,X,Y \<,,-> TERMIN ] ;END OF IFN ITS+D20 DEFINE IOCTRAP AC,X,N IOCTR1 \.-1,\NIOCTR,AC,X,N NIOCTR=NIOCTR+1 TERMIN DEFINE IOCTR1 L,N,AC,X,N DEFINE ZZI!N IFSN [N],[ CAIE D,N JRST .+3 ] CAIN R,L MOVE R,[SETZ X(AC)] TERMIN TERMIN IFN D10,[ DEFINE PURTRAP X,B-INST HS$ CAIL B,HILOC HS$ JRST X INST TERMIN ] ; END -- IFN D10, ;Hack for PWIOINT for WITHOUT-INTERRUPTS, in BIND ;PURTRAP is OK for non-D10, but must check explicitly for PWIOINT in D10 ;I'm not sure if this HS$ is the right thing. It wants to check in all cases ;where a pure trap won't happen, such as PLISP at SAIL --RWK IFE D10,[ DEFINE BNDTRAP X,B-INST PURTRAP X,B, INST TERMIN ] ;END -- IFE D10 IFN D10,[ DEFINE BNDTRAP X,B-INST CAIN B,PWIOINT JRST X INST TERMIN ] ;END -- IFN D10, IFN D10,[ ;;; FEATURE FOR TWO-SEGMENT DEC-10 ASSEMBLIES TO WIN ON THE ;;; MANY INSTRUCTIONS IN LISP WHICH ARE OF THE FORM ;;; JRST FOO-BAR(X) ;;; WHERE FOO IS IN ONE SEGMENT AND BAR IN THE OTHER. ;;; THE CORRECT WAY TO WRITE THE ABOVE INSTRUCTION IS ;;; 2DIF JRST (X),FOO,BAR DEFINE 2DIF INST,X,Y IFN %HISEG+1, 2DIF1 \.-HILOC,HILOC,[X][Y]\N2DIF IFE %HISEG+1, 2DIF1 \.-FIRSTLOC,FIRSTLOC,[X][Y]\N2DIF N2DIF==N2DIF+1 INST TERMIN ;;; A COUPLE OF CROCKS: ;;; [1] THE .CRFON AND .CRFOFF IN ZZD!N INTERACT WITH ;;; THOSE IN THE MACROLOOP MACRO. ;;; [2] THE OFFSETS ALLOW ADDRESSES CONTAINING . IN ;;; THE 2DIF'ED INSTRUCTION (KNOCK PLASTIC). ;;; I.E. THE OFFSET F+L-. IS A HACK SO THAT ;;; ANY .'S IN X OR Y WILL REFER TO THE 2DIF'D ;;; INSTRUCTION AND NOT TO THE PLACE WHERE THE ZZD!N ;;; GETS EXPANDED. DEFINE 2DIF1 L,F,X,Y,N .CRFOFF DEFINE ZZD!N .CRFON OFFSET F+L-. MOVEI T,X SUBI T,Y OFFSET 0 .CRFOFF HRRM T,F+L TERMIN .CRFON TERMIN ;;; THE ZZD MACROS GET EXPANDED IN THE INIT ROUTINE. ] ;END OF IFN D10 DEFINE INTPRO W REL$ PROENT \.-.RL1,W,\NPRO REL% PROENT \.,W,\NPRO TERMIN DEFINE PROENT L,W,N DEFINE PRO!N REL$ W,,L+.RL1 REL% W,,L TERMIN NPRO==NPRO+1 TERMIN DEFINE NOPRO ;BEGINS INTERVAL WITH NO INT PROTECTION INTPRO INTOK TERMIN DEFINE SFXPRO ;CODE PROMISES TO RETURN THROUGH AN SFX CELL INTPRO INTSFX TERMIN DEFINE XCTPRO ;FOLLOWING INSTRS MUST BE XCT'D BEFORE INT INTPRO INTXCT TERMIN DEFINE BAKPRO ;MUST BACK UP TO HERE IF INT HAPPENS INTPRO INTBAK TERMIN DEFINE SPECPRO H ;USED A SPECIALIZED PROTECTION ROUTINE INTPRO H TERMIN ;;; NO PROTECTION FOR ABSOLUTE LOCATIONS FROM 0 UP TO NEXT INTERVAL DEFINE PRO0 INTOK,,0 TERMIN ;;; THE PRO MACROS ARE EXPANDED AT PROTB (Q.V.) SUBTTL ST AND GCST HACKERS IFN PAGING,[ ;;; THESE MACROS ACTUALLY FILL IN THE SEGMENT TABLES, FOR ITS ASSEMBLIES DEFINE $ST SPC,BITS IFN .-ST-,[ WARN [SEGMENT TABLE PHASE ERROR - TABLE LOC=]\.-ST,[, B!SPC!SG/SEGSIZ=]\B!SPC!SG/SEGSIZ LOC ST+ ] IFN N!SPC!SG, $ST1 SPC,\N!SPC!SG,BITS TERMIN DEFINE $ST1 SPC,N,XBITS ST.!SPC: ZZ==0 IRP TYPE,,[LIST,FIXNUM,FLONUM,BIGNUM,SYMBOL,RANDOM,ARRAY]BB,,[LS,FX,FL,BN,SY,RN,SA] IFN &BB,[ REPEAT N, ,,Q!TYPE ZZ==ZZ+1 ] TERMIN IFN ZZ-1, WARN [IMPROPER TYPE BITS FOR SPC SPACE: ]\XBITS TERMIN ;;; THERE ARE NO INITIAL HUNKS!!! ;;; THESE MACROS HAVE THEREFORE NOT BEEN HACKED FOR HUNKS!!! DEFINE $GCST SPC,LINK,BTBP,BITS IFSE LINK,L, L!SPC!SG==0 IFN .-GCST-,[ WARN [GCST PHASE ERROR - TABLE LOC=]\.-GCST,[, B!SPC!SG/SEGSIZ=]\B!SPC!SG/SEGSIZ LOC GCST+ ] IFN N!SPC!SG, $GCST1 \N!SPC!SG,SPC,LINK,BTBP,BITS TERMIN DEFINE $GCST1 N,SPC,LINK,BTBP,BITS GS.!SPC: REPEAT N,[ ZZ==(BITS) IFSE BTBP,B, ZZ==ZZ+BTB._<5-SEGLOG> .ALSO BTB.==BTB.+BTBSIZ IFSE LINK,L, ZZ==ZZ+L!SPC!SG_<22-> .ALSO L!SPC!SG==.-GCST ZZ ] TERMIN ] ;END OF IFN PAGING IFE PAGING,[ ;;; THIS MACRO MAKES UP THE CODE THAT INITIALIZES THE SEGMENT TABLES DEFINE 10ST SPC,STENT=[$XM,,QRANDOM]GCENT=0,LINK,BITS IFN N!SPC!SG,[ MOVEI T,B!SPC!SG LSH T,-SEGLOG MOVE TT,[STENT] REPEAT N!SPC!SG, MOVEM TT,ST+.RPCNT(T) IFN GCENT,[ MOVSI TT,GCENT REPEAT N!SPC!SG,[ IFSN BITS,,[ HRRI TT,(AR1) ADDI AR1,1 ] ;END OF IFSN BITS,, MOVEM TT,GCST+.RPCNT(T) ] ;END OF REPEAT N!SPC!SG ] ;END OF IFN GCENT IFSN LINK,,[ IFG N!SPC!SG-1,[ HRLI T,-N!SPC!SG+1 DPB T,[SEGBYT,,GCST+1(T)] AOBJN T,.-1 ] ;END OF IFG N!SPC!SG-1 HRRZM T,LINK ] ;END OF IFSN LINK,, ] ;END OF IFN N!SPC!SG TERMIN ] ;END OF IFE PAGING ;;; $T IN DDT IS GOOD FOR LOOKING AT GCST GS==<777000,,>\<<1_<22->>-1> ;;; FOR FETCHING LINK FIELD WITH A LDB SEGBYT==<22->_14+<22-SEGLOG>_6 ;;@ END OF MACS 71 SA% LRCT==:NASCII+10 ;SPACE SUFFICIENT FOR CHARS AND SWITCHES SA$ LRCT==:1010 10$ LIOBUF==:200 ;LENGTH OF STANDARD VANILLA I/O BUFFER LONUM==400 ;MINIMUM MAGNITUDE OF LOWEST NEGATIVE INUM HINUM==1000 ;MINIMUM MAGNITUDE OF LARGEST POSITIVE INUM ;SOME CODE ASSUMES HINUM IS AT LEAST 777 ;MUCH CODE ASSUMES HINUM IS AT LEAST 177 (FOR ASCII CHARS) IFN ITS, PAGLOG==:12 ;LOG2 OF PAGE SIZE ; (DAMN WELL BETTER BE 12 FOR ITS!!! IFN D10, PAGLOG==:11 ; SOME CODE ASSUMES IT WILL BE 11 OR 12) IFN D20, PAGLOG==:11 IFE D10*PAGING, MEMORY==:<1,,0> ;SIZE OF MEMORY!!! IFN D10*PAGING, MEMORY==:776000 ;ON D10 SYSTEMS, CAN'T USE ALL OF MEMORY PAGSIZ==:1_PAGLOG ;PAGE SIZE PAGMSK==:<777777_PAGLOG>&777777 ;MASKS ADDRESSES TO PAGE BOUNDARY PAGKSM==:PAGMSK#777777 ;MASKS WORD ADDRESS WITHIN PAGE NPAGS==:MEMORY/PAGSIZ ;NUMBER OF PAGES IN MEMORY NNUMTP==:2+BIGNUM+DBFLAG+CXFLAG+DBFLAG*CXFLAG ;NUMBER OF NUMBER TYPES NTYPES==:3+HNKLOG+1+NNUMTP+1 ;NUMBER OF DATA TYPES, COUNTING RANDOM ;;; IF1 SEGSIZ==:1_SEGLOG ;SEGMENT SIZE SEGMSK==:<777777_SEGLOG>&777777 ;MASKS ADDRESSES TO SEGMENT BOUNDARY SEGKSM==:SEGMSK#777777 ;MASKS WORD ADDRESS WITHIN SEGMENT NSEGS==:MEMORY/SEGSIZ ;NUMBER OF SEGMENTS IN MEMORY BTBSIZ==:SEGSIZ/40 ;SIZE OF BIT BLOCKS ;(ENOUGH BITS FOR A SEGMENT, 40 PER WORD) SGS%PG==:NSEGS/NPAGS ;NUMBER OF SEGMENTS PER PAGE BTSGGS==1 ;GUESS AT THE NUMBER OF INITIAL BIT SEGMENTS IFN PAGING,[ ALPDL==4*PAGSIZ ;DEFAULT TOTAL PDL SIZES ALFXP==4*PAGSIZ ALFLP==1*PAGSIZ ALSPDL==2*PAGSIZ ] ;END OF IFN ITS+D20 IFE PAGING,[ ALFXP==SEGSIZ ;DEFAULT TOTAL PDL SIZES ALFLP==SEGSIZ ALPDL==3000 ALSPDL==1400 ] ;END OF IFN D10 ;;; GROSSLY DETERMINE MIN AND MAX PARAMETERS FOR EACH SPACE AND PDL FUMBLE FFS,,[[1,[0.25,40000]]] FUMBLE FFX,,[[PAGING,[0.2,14000]],[PAGING-1,[0.25,3000]]] FUMBLE FFL,,[[PAGING,[0.15,2*SEGSIZ]],[PAGING-1,[0.25,SEGSIZ]]] FUMBLE FFD,IFN DBFLAG,[[1,[0,SEGSIZ]]] FUMBLE FFC,IFN CXFLAG,[[1,[0,SEGSIZ]]] FUMBLE FFZ,IFN DXFLAG,[[1,[0,SEGSIZ]]] FUMBLE FFB,IFN BIGNUM,[[PAGING,[3*SEGSIZ/4,2*SEGSIZ]],[PAGING-1,[0.2,SEGSIZ]]] FUMBLE FFY,,[[PAGING,[SEGSIZ/2,6000]],[PAGING-1,[SEGSIZ/2,3*SEGSIZ]]] FUMBLE FFH,IFN HNKLOG,[[1,[0,2*SEGSIZ]]] FUMBLE FFA,,[[1,[40,SEGSIZ]]] GRUMBLE PDL,,[[1,[200,1400]]] GRUMBLE SPDL,,[[1,[100,1400]]] GRUMBLE FXP,,[[1,[200,1000]]] GRUMBLE FLP,,[[1,[20,200]]] ;;; IF1 ;;; ********** INTERRUPT BITS ********** IFN ITS,[ ;;; THESE NAMES SHOULD BE PHASED OUT IN FAVOR OF THE ITS-STANDARD %PI SERIES. ;;; LISP SETS ITS INTERRUPT MASK (.MASK USET VARIABLE) ONLY FROM ;;; THE CONTENTS OF LOCATION IMASK, WHICH INITIALLY CONTAINS STDMSK. ;;; DEPOSITING DBGMSK THERE BEFORE STARTUP DISABLES ALL INTERRUPTS ;;; EXCEPT TTY AND PDL OVERFLOW, SO THAT DDT WILL TRAP ILOP, MPV, ETC. IB.ALARM==200000,, ; REAL TIME CLOCK (ALARM CLOCK) IB.TIMER==100000,, ; RUN TIME CLOCK IB.PARITY==1000,, ;+ PARITY ERROR IB.FLOV==400,, ; FLOATING OVERFLOW IB.PURE==200,, ;+ PURE PAGE TRAP (WRITE INTO READ-ONLY) IB.PCPURE==100,, ;+ PURE INSTRUCTION FETCH FROM IMPURE IB.SYSUUO==40,, ;+ SYS UUO TRAP IB.AT3==20,, ; ARM TIP BREAK 3 IB.AT2==10,, ; ARM TIP BREAK 2 IB.AT1==4,, ; ARM TIP BREAK 1 IB.DEBUG==2,, ; SYSTEM BEING DEBUGGED IB.RVIOL==1,, ;+ RESTRICTION VIOLATION (?) IB.CLI==400000 ; CORE LINK INTERRUPT IB.PDLOV==200000 ; PDL OVERFLOW IB.LTPEN==100000 ; LIGHT PEN INTERRUPT IB.MAR==40000 ;+ MAR INTERRUPT IB.MPV==20000 ;+ MEMORY PROTECTION VIOLATION IB.SCLK==10000 ; SLOW CLOCK TICK (.5 SEC) IB.1PROC==4000 ;* SINGLE INSTRUCTION PROCEED IB.BREAK==2000 ;* .BREAK EXECUTED IB.ILAD==1000 ;+ ILLEGAL USER ADDRESS IB.IOC==400 ;+ I/O CHANNEL ERROR IB.VALUE==200 ;* .VALUE EXECUTED IB.DOWN==100 ; SYSTEM GOING DOWN OR BEING REVIVED IB.ILOP==40 ;+ ILLEGAL INSTRUCTION OPERATION IB.DMPV==20 ;+ DISPLAY MEMORY PROTECTION VIOLATION IB.AROV==10 ; ARITHMETIC OVERFLOW IB.42BAD==4 ;* BAD LOCATION 42 IB.C.Z==2 ;* ^Z TYPED WHEN THIS JOB HAD TTY IB.TTY==1 ; INTERRUPT CHAR TYPED ON TTY ] ;END OF IFN ITS IFN D10,[ IB.PDLOV==AP.POV ; PDL OVERFLOW IB.MPV==AP.ILM ;+ MEMORY PROTECTION VIOLATION SA% STDMSK==AP.REN+AP.POV+AP.ILM+AP.NXM+AP.PAR SA$ STDMSK==<404,,230000> ] ;END OF IFN D10 ;;; ********** I/O CHANNEL ASSIGNMENTS ********** ;;; PAGE 376 IS RESERVED FOR COPYING (SEE IP1), AND 377 FOR DISUSE. ;;; (THE DISUSE AS TO DO WITH AN OLD HARDWARE BUG IN BLT.) ;;; ON AI, PAGE 375 IS FOR MAPPING PAGE 0 OF THE DISPLAY SLAVE. IT$ P6=MEMORY-3*PAGSIZ ;PAGE 0 OF PDP6 SLAVE IS MAPPED INTO PDP-10 MEMORY ] ;END OF IF1 ;IFE *USELESS, NPGTPS==0 IFE 0, NPGTPS==0 TOPN==0 BOTN==0 .XCREF TOPN BOTN NPURTR==0 NIOCTR==0 .XCREF PURTR1 NPURTR NIOCTR N2DIF==0 NPRO==0+1 ;NUMBER OF INTERRUPT PROTECTION REGIONS ;NOTE DEFN OF PRO0 IN MACS FILE .XCREF NPRO IFN D10,[ HS$ .DECTWO HSGORG ;DEC TWO-SEGMENT RELOC OUTPUT HS% .DECREL ;ONE SEGMENT ASSEMBLY IFN PAGING, LOC 140 ;FOR PAGING ASSEMBLY NEED ABSOLUTE ADDRESSING %LOSEG==-1 ;INITIALLY START IN LOW SEGMENT %HISEG==0 ;START AT 0 RELATIVE TO HIGH SEG ORIGIN ] ;END OF IFN D10 IFN ITS, IFDEF .SBLK, .SBLK ;EVENTUALLY FLUSH "IFDEF .SBLK" 20$ .DECREL ;FOR TOPS-20 NEED DEC RELOCATABLE FORMAT 20$ LOC 140 ;BUT FORCE ABSOLUTE ADDRESSING .YSTGWD ;STORAGE WORDS ARE OKAY NOW FIRSTLOC: IFN D10,[ HS$ HILOC==.+HSGORG ;HISEG GENERALLY STARTS AT 400000 HS% HILOC==. ;;; FOR DEC-10, FIRSTLOC AS LOADED WITH RELOCATION MUST BE ;;; STDLO+M*SEGSIZ ;;; AND SIMILARLY HILOC WHEN LOADED MUST BE ;;; STDHI+N*SEGSIZ ;;; FOR INTEGRAL M AND N. INIT WILL ENFORCE THIS IN ORDER ;;; TO PRESERVE SEGMENT BOUNDARIES CORRECTLY. ;;; CURSTD IS THE STDXX FOR WHICHEVER IS THE CURRENT SEGMENT. STDLO==140 ;SIZE OF JOB DATA AREA STDHI==10 ;VESTIGIAL JOB DATA AREA CURSTD==STDLO .SEE $LOSEG ] ;END OF IFN D10 IFN PAGING,[ STDLO==0 STDHI==0 CURSTD==0 ] ;END OF IFN PAGING IFN PAGING, BZERSG==0 ;BEGINNING OF "ZERO" SEGMENT(S) IFE PAGING, BZERSG==FIRSTLOC-STDLO SUBTTL FIRST LOCATIONS (41, GOINIT, LISPGO); UUO AND INTERRUPT VECTORS LOC 41 JSR UUOH ;UUO HANDLER 10X WARN [TENEX INTERRUPT VECTOR?] LOC FIRSTLOC GOINIT: IT$ .SUSET [.S40ADDR,,[TWENTY,,FORTY]] ;SET .40ADDR MOVEI A,READTABLE MOVEM A,VREADTABLE IFN USELESS,[ MOVE A,[RCT0,,RCT] BLT A,RCT+LRCT-1 ;RESTORE READ CHARACTER SYNTAX TABLE ] ;END OF IFN USELESS MOVEI A,TTYIFA MOVEM A,V%TYI MOVEI A,TTYOFA MOVEM A,V%TYO MOVEI A,TRUTH MOVEM A,VINFILE SETZM VINSTACK SETZM VOUTFILES SETZM VECHOFILES MOVEI A,QTLIST MOVEM A,VMSGFILES IFN USELESS&ITS,[ MOVEI T,IB ;RESET THE MAR BREAK FEATURE ANDCAM T,IMASK .SUSET [.SAMASK,,T] .SUSET [.SMARA,,R70] ] ;END OF IFN USELESS MOVEI A,OBARRAY MOVEM A,VOBARRAY ;GET BACK TOPLEVEL OBARRAY SETZM V%PR1 SETZM VOREAD SETZM TLF SETZM BLF ;?? SETZM UNRC.G ;CLEAR STACKED NOINTERRUPT STUFF SETZM UNRRUN SETZM UNRTIM SETZM UNREAR SETZM TTYOFF JSP A,ERINIT GOINI7: SETZB A,VERRLI ;NULLIFY ERRLIST PUSHJ P,INTERN JUMPE A,LISPGO PUSHJ P,REMOB2 ;GET STANDARD COPY OF NIL ON OBLIST JRST GOINI7 ;;; HERE IF NOT STOPPING AFTER A SUSPEND SUSCON: MOVEI A,TRUTH ;RETURN T RATHER THAN NIL MOVEM A,-1(FLP) ;;; FALL INTO LISPGO LISPGO: SETOM AFILRD ;START HERE ON G'ING IT$ .SUSET GOL1 ;SET .40ADDR IT$ .SUSET GOL2 ;GET INITIAL SNAME 20$ RESET ;RESET OURSELVES ON STARTUP JRST 2,@LISPSW ;ZEROS OUT PC FLAGS, AND TRANSFERS TO LISP IT$ GOL2: .RSNAM,,IUSN ;KEEP THESE ON SAME PHYSICAL PAGE IT$ GOL1: .S40ADDR,,.+1 IT$ TWENTY,,FORTY LISPSW: %ALLOC ;ALLOC CLOBBERS TO BE "LISP" SUSFLS: TRUTH ;NON-NIL MEANS FLUSH SHARABLE PAGES BEFORE SUSPENDING IFN ITS,[ TWENTY==:20 ;VARIOUS PLACES OFFSET FROM TWENTY ARE USED BY DDT THIRTY==:TWENTY+10 ;RECALL THAT THE LEFT HALF OF .40ADDR IS THE ".20ADDR" ;;; ADDRESSES IN THE 20 BLOCK, SWIPED FROM DDT ORDER ;;; 25 HOLDS "." DURING A USER TYPEOUT INSTRUCTION ;;; 26 CONDITIONAL BREAKPOINT INSTRUCTION ;;; 27-30 .BREAK 16,'S FOR RETURNING FROM 26 ;;; 31 INSTRUCTION FOR BREAKPOINT WHICH DIDN'T BREAK ;;; 32-33 JRST'S TO PROGRAM FROM 31, OR DATA FOR INSTRUCTION IN 31 ;;; 34 INSTRUCTION BEING X'D .SEE MEMERR .SEE UUOGL2 ;;; 35-36 .BREAK 16,'S FOR RETURNING FROM 34 .SEE $XLOST .SEE UUOGL2 ;;; 37 HOLDS Q DURING A USER TYPEOUT INSTRUCTION .SEE PSYM1 FORTY: 0 ;.40ADDR USER VARIABLE POINTS HERE JSR UUOGLEEP ;SYSTEMIC UUO HANDLER -LINTVEC,,INTVEC ;SYSTEMIC INTERRUPT HANDLER ;;; THAT'S SYSTEMIC, NOT NECESSARILY SYSTEMATIC!!! ;;; ITS PASSES THE BUCK TO THE USER ON UUO'S 0 AND 50-77. ;;; THEY TRAP THROUGH THE .40ADDR, NOT NECESSARILY 40; ;;; SINCE LISP TREATS THESE AS ERRORS, WE CAN AFFORD TO SAVE ;;; THE JPC AND OTHER GOODIES HERE. UUOGLEEP: 0 .SUSET [.RJPC,,JPCSAV] JRST UUOGL1 ] ;END OF IFN ITS JPCSAV: 0 SUBTTL SFX HACKERY ;;; SFX MACRO TELLS WHERE A LONG PIECE OF SEMI-CRITICAL (MAY BE QUIT ;;; OUT OF, BUT MUST NOT PERMIT USER INTERRUPTS IN) CODE MAY BE MUNGED ;;; IF INTERRUPTED IN THE MIDDLE SO THAT WHEN DONE IT WILL RETURN TO ;;; THE INTERRUPT HANDLER. SUCH CODE INCLUDES ARRAY SUBSCRIPT ;;; COMPUTATIONS (SINCE AN INTERRUPT COULD DISPLACE THE ARRAY) ;;; AND ALL CODE WHICH MODIFIES THE SPECIAL PDL. NSFC==0 ;COUNTER FOR MACRO SFX .XCREF NSFC IFE PAGING,[ DEFINE SFX A/ SFSTO \.-FIRSTLOC,\NSFC,[A] NSFC==NSFC+1 A TERMIN DEFINE SFSTO PT,NM,IN DEFINE ZZM!NM FIRSTLOC+PT TERMIN DEFINE ZZN!NM IN TERMIN TERMIN ] ;END OF IFN PAGING IFN PAGING,[ DEFINE SFX A/ SFSTO \.,\NSFC,[A] NSFC==NSFC+1 A TERMIN DEFINE SFSTO PT,NM,IN DEFINE ZZM!NM PT TERMIN DEFINE ZZN!NM IN TERMIN TERMIN ] ;END OF IFN PAGING ;;; THE ZZM AND ZZN MACROS ARE EXPANDED AT SFXTBL (Q.V.) ;;; **** ALL USES OF THE SFX MACRO MUST APPEAR ON THIS PAGE **** SFXPRO 10$ UNBD2A: 10$ POP FXP,R ;Restore R UNBND2: MOVE TT,(SP) MOVEM TT,SPSV ;ABOUT LOADING TT WITH SPSV, SEE UNBIND MOVE TT,UNBND3 SFX POPJ P, ABIND3: PUSH SP,SPSV SFX POPJ P, SETXIT: SUB SP,R70+1 SFX JRST (T) SPECX: PUSH SP,SPSV SFX JRST (T) AYNVSFX: ;XCT'ED BY AYNVER SFX %WTA (D) 1DIMS: JSP T,AYNV1 ;1-DIM S-EXP ARRAYS COME HERE ARYGET: ROT R,-1 ;COMMON S-EXP ARRAY ACCESS ROUTINE ADDI TT,(R) ARYGT4: JUMPL R,ARYGT8 HLRZ A,(TT) SFX POPJ P, ARYGT8: HRRZ A,(TT) SFX POPJ P, 1DIMF: JSP T,AYNV1 ;1-DIM FULLWORD ARRAYS COME HERE ANYGET: ADDI TT,(R) ;COMMON FULLWORD ARRAY ACCESS ROUTINE MOVE TT,(TT) SFX POPJ P, IFN DBFLAG+CXFLAG,[ 1DIMD: JSP T,AYNV1 ;1-DIM DOUBLEWORD ARRAYS COME HERE ADYGET: LSH R,1 ;COMMON DOUBLEWORD ARRAY ACCESS ROUTINE ADDI TT,(R) KA MOVE D,1(TT) KA MOVE TT,(TT) KIKL DMOVE TT,(TT) SFX POPJ P, ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ 1DIMZ: JSP T,AYNV1 ;1-DIM FOUR-WORD ARRAYS COME HERE AZYGET: LSH R,2 ;COMMON FOUR-WORD ARRAY ACCESS ROUTINE ADDI TT,(R) KA MOVE R,(TT) KA MOVE F,1(TT) KA MOVE D,3(TT) KA MOVE TT,2(TT) KIKL DMOVE R,(TT) KIKL DMOVE TT,2(TT) SFX POPJ P, ] ;END OF IFN DXFLAG NOPRO SPSV: 0 ;IMPORTANT TO SPECPDL BINDINGS .SEE $IWAIT ;;; **** THERE MUST BE NO MORE USES OF THE MACRO SFX BEYOND HERE **** EXPUNGE SFX SFSTO SUBTTL INTERRUPT FLAGS AND VARIABLES ;;; INTFLG INDICATES WHETHER IN INTERRUPT IS PENDING: ;;; 0 => NO INTERRUPT ;;; -1 => USER INTERRUPT PENDING (STACKED IN INTAR) ;;; -2 => ^X QUIT PENDING, DON'T RESET TTY ;;; -3 => ^G QUIT PENDING, DON'T RESET TTY ;;; -6 => ^X QUIT PENDING, DO RESET TTY ;;; -7 => ^G QUIT PENDING, DO RESET TTY INTFLG: 0 ;;; MAY NOT ^G/^X QUIT OR ALLOW USER INTERRUPTS IF NOQUIT NON-ZERO ;;; NON-ZERO IN LH MEANS GC IN PROGRESS; IMPLIES ;;; PDL POINTERS AND NIL MAY BE CLOBBERED ;;; NON-ZERO ONLY IN RH MEANS PDL POINTERS AND NIL ARE OK NOQUIT: 0 ;;; MAY NOT ALLOW "REAL TIME" INTERRUPTS (CLOCK AND TTY) WHEN ;;; UNREAL IS NON-ZERO. MUNGED BY THE FUNCTION NOINTERRUPT. ;;; 0 => ALL INTERRUPTS OKAY ;;; -1 => NO INTERRUPTS OKAY ;;; 'TTY => ALARMCLOCK OKAY, TTY NOT OKAY UNREAL: 0 REALLY: 0 ;IF NON-ZERO, THE ADDRESS OF A PDL SLOT FOR THE ;UNBINDER TO UNBIND A SAVED UNREAL INTO. ;SO THAT UNWPR1 CAN KEEP UNREAL SET WHILE BINDING IT. .SEE WIOUNB .SEE UNWPR1 ERRSVD: 0 .SEE ERRBAD ;;; INTERRUPT MASK IS ALWAYS INITIALIZED FROM THIS WORD. ;;; FOR ITS, THIS IS THE .MASK (AND .MSK2) WORDS. ;;; FOR TOPS10 AND CMU, THIS IS THE APRENB WORD. ;;; FOR D20, THIS IS THE CHANNEL ENABLE WORD ;;; DEPOSITING DBGMSK INTO IT BEFORE STARTUP CAN AID DEBUGGING. ;;; FOR ITS AND D20, IMPURE LISPS WILL HAVE DEBUG MASKS IN THESE ;;; LOCATIONS; THE PURIFY ROUTINE INSTALLS THE STANDARD MASKS. .SEE PURIFY .SEE DBGMSK IFN , OIMASK: 0 ;HOLDS OLD INT MASK WHEN INTS ARE DISABLED SA% INTMSK: IMASK: STDMSK ;INTERRUPT MASK WORD IT$ IMASK2: STDMS2 ;ITS HAS TWO INTERRUPT MASKS LFAKP==5 ;MUST BE LONG ENOUGH FOR USES BY LFAKFXP==6 ; PDLOV, ERINIT, AND PURIFY FAKP: BLOCK LFAKP ;FAKE REGPDL, FOR USE BY PDLOV AND ERINIT FAKFXP: BLOCK LFAKFXP ;FAKE FIXPDL, FOR USE BY PDLOV AND ERINIT IT$ VALFIX: 0 ;-1 --> VALRET 'STRING' IS REALLY A FIXNUM IT$ .SEE VALSTR IFN D10,[ CMUP: 0 ;CMU MONITOR? IFE SAIL,[ MONL6P: 0 ;6-LEVEL MONITOR OR BETTERP? KA10P: 0 ;KA PROCESSOR (AS OPPOSED TO KL OR KI) ] ;END OF IFE SAIL ] ;END OF IFN D10 ;;; IF NON-ZERO, THIS CONTAINS THE ADDRESS OF A USER-SUPPLIED ;;; INTERRUPT PROCESSOR. THE LISP SYSTEM INTERRUPT HANDLER ;;; WILL GIVE IT ANY INTERRUPT LISP DOESN'T PROCESS ITSELF. SEE INT0. UPIINT: 0 IFN D20,[ ;;; TOPS-20 INTERRUPT VARIABLES ;;; FLAGS SETUP BY ALLOC AND SUSPEND CCOCW1: CCOC1 ;This words may be "remodeled" at allocation time, and at CCOCW2: CCOC2 ; start-up from suspension, to account for 10X/20X differences TENEXP: 0 ;Also set up as above ;;; BLOCK OF THREE LOCATIONS IN WHICH THE PC IS STORED ON AN INTERRUPT. ;;; ONE LOCATION FOR EACH OF TOPS-20'S THREE LEVELS INTPC1: 0 INTPC2: 0 INTPC3: 0 ;;; TEMPORARY LOCATIONS USED BY INTERRUPT HANDLERS PDLSVT: 0 ;USED BY $PDLOV TO SAVE AC T WHILE MUNGING THE INTPDL SUPSAV: 0 ;USED BY INTSUP LV2SVT: 0 ;LEVEL 2 PARAMETERS: SAVE T LV2SVF: 0 ; SAVE F LV2ST2: 0 ; SECOND SAVE T LV3SVT: 0 ;LEVEL 3 PARAMETERS: SAVE T LV3SVF: 0 ; SAVE F LV3ST2: 0 ; SECOND SAVE T DSMSAV: . ;POINTER INTO SMALL STACK USED BY DSMINT BLOCK 10 ;TO BE SAFE, BUT 4 SHOULD BE MAXIMUM DEPTH IT% CN.ZX: 0 ;WHERE TO EXIT AFTER ^Z ;;; AS TTY INTERRUPT CHANNEL MUST BE DYNAMICALLY ALLOCATED, AND THERE ARE ;;; FEWER CHANNELS THAN THE TOTAL POSSIBLE NUMBER OF INTERRUPT CHARACTERS, ;;; A TABLE IS USED TO STORE THE INFORMATION. THE TABLE IS 18. WORDS LONG. ;;; A ZERO ENTRY IS UNUSED, NONZERO HAS INTERRUPT CHARACTER. IF THE TABLE ;;; ENTRY IS NEGATIVE, THEN THE CHANNEL IS ASSIGNED FOR SOME OTHER USE. ;CHANNEL ASSIGNMENTS FOR NON-STANDARD(?) INTERRUPTS CINTAB: TICMAP .TIC!CODE REPEAT 18.-<.-CINTAB>, 0 ;INITIALLY UNUSED CINTSZ==.-CINTAB ] ;END IFN D20 SUBTTL DEFINITIONS OF TTY STATUS WORDS IFN ITS,[ ;;; INITIAL TTY STATUS IS AS FOLLOWS: ;;; ACTIVATION CHARS: ;;; ^@-^L, ^N-^Z, ^\-^_, SPACE, < > ( ) { } RUBOUT CR ;;; LBRACKET RBRACKET ;;; INTERRUPT CHARS: ;;; ^@-^H, ^K, ^L, ^N-^Z, ^\-^_, SPACE ;;; ^H AND SPACE DO NOT INTERRUPT ;;; SPACE AND BACKSPACE OUTPUT IN IMAGE MODE, ALL OTHERS IN ASCII. ;;; ALL CHARS ECHO IN PI MODE (ECHO WHEN TYPED), EXCEPT RUBOUT DOESN'T ECHO. ;;; ;;; RECALL THAT THE TWELVE CHARACTER GROUPS ARE: ;;; ^@ ^A-^F ^K-^L ^N-^R ^T-^Z ^RBRACKET ^\ ^^ ^_ ;;; A-Z (UPPER CASE), a-z (LOWER CASE) ;;; 0-9 ;;; ! " # $ % & ' , . : ; ? @ \ ` | ~ ;;; * + - / = ^ _ ;;; < > ( ) { } LBRACKET RBRACKET ;;; ^G ^S ;;; ^J ^I ;;; ALTMODE ;;; ^M ;;; RUBOUT ;;; SPACE ^H .SEE %TG STTYW1==:232020,,202022 ;STATUS WORDS FOR NORMAL MODE STTYW2==:232220,,220232 STTYL1==:232020,,202020 ;STATUS WORDS FOR LINE MODE STTYL2==:212020,,220222 STTYA1==:022222,,222222 ;STATUS WORDS FOR ALLOC STTYA2==:320222,,020222 ] ;END OF IFN ITS IFN D20,[ ;;; Control-Character-Output-Control - two bits for each control character ;;; 0 - ignore, ;;; 1 - print ^X, ;;; 2 - output unmodified, ;;; 3 - simulate format action RADIX 4 CCOC1==:111111123321231111 CCOC2==:111111111311110000 RADIX 8 ; SEE CCOCW1 AND CCOCW1 ;;; Four classes of wake-up control XACTW==:TT%WKF+TT%WKN+TT%WKP+TT%WKA XACTL==:TT%WKF STDTIW==0 ;STANDARD TERMINAL INTERRUPT WORD - not really used! TICMAP {STDTIW==STDTIW+<1_<35-.TIC!CODE>>} ] ;END OF IFN D20 IFN SAIL,[ SACTW1==:777777777370 SACTW2==:030000005000 SACTW3==:000000240000 SACTW4==:000005200000 SACTL1==:775177577370 SACTL2==:000000000000 SACTL3==:000000000000 SACTL4==:000000200000 ] ;END OF IFN SAIL SUBTTL ENTRIES TO VARIOUS ROUTINES CALLED BY JSR UISTAK: 0 ;STACK UP (ACTUALLY, QUEUE) A USER INTTERRUPT JRST UISTK1 GCRSR: 0 ;GC RESTORE. CLEANS UP JUST BEFORE AN JRST GCRSR0 ; ABNORMAL EXIT (GCEND IS NORMAL EXIT). IFN PAGING,[ PDLSTH: 0 ;"PDL ST HACK". GETS A NEW PAGE FOR A PDL, JRST PDLST0 ; AND UPDATES ST AND GCST APPROPRIATELY. IFN D20,[ PDLSTA: 0 ;TEMPS FOR SAVING ACS PDLSTB: 0 PDLSTC: 0 ] ;END OF IFN D20 ] ;END OF IFN PAGING SUBTTL NEWIO I/O CHANNEL ALLOCATION TABLE ;;; ENTRIES: ;;; 4.9 => CHANNEL IS LOCKED FOR A PARTICULAR PURPOSE ;;; 1.1-2.9 => ADDRESS OF FILE ARRAY SAR ;;; IF AN ENTRY IS NON-ZERO BUT ITS FILE ARRAY SAR'S ;;; TTS.CL BIT IS SET, THE CHANNEL MAY BE DE-ALLOCATED. ;;; THIS ORDINARILY HAPPENS ONLY ON A QUIT OUT OF $OPEN. ;;; CHANNEL 0 (TMPC) IS PERMANENTLY LOCKED FOR USE OF THE ERR ;;; DEVICE, FOR UPROBE, ETC. NOTE THAT ITS PUTS .OPEN ;;; AND .CALL FAILURE CODES ON CHANNEL 0 ARBITRARILY. IFN ITS+D10, LCHNTB==:20 ;NUMBER FIXED BY OPERATING SYSTEM IFN D20, MAYBE LCHNTB==:40 ;THIS NUMBER IS BASICALLY ARBITRARY CHNTB: OFFSET -. TMPC:: 400000,,NIL ;FIXED TEMPORARY CHANNEL IFGE LCHNTB-., BLOCK LCHNTB-. .ELSE WARN [TOO MANY FIXED I/O CHANNELS] OFFSET 0 ;;; DEC-10 I/O BUFFER HEADERS (MUST REMAIN FIXED IN CORE) ;;; THEY ARE NAMED BFHD0, BFHD1, ..., BFHD17. IFN D10, REPEAT LCHNTB, CONC BFHD,\.RPCNT,: BLOCK 3 DPAGEL: 60. ;INITIAL DEFAULT PAGEL DLINEL: 70. ;INITIAL DEFAULT LINEL IFN JOBQIO,[ LJOBTB==10 ;EIGHT INFERIOR PROCEDURES JOBTB: BLOCK LJOBTB ] ;END OF IFN JOBQIO SUBTTL INITIAL TTY INPUT FILE ARRAY -F.GC,,TTYIF2 ;GC AOBJN POINTER TTYIF1: JSP TT,1DIMS TTYIFA ;POINTER BACK TO SAR 0 ;ILLEGAL FOR USER TO ACCESS - DIMENSION IS ZERO TTYIF2: OFFSET -. FI.EOF:: NIL ;EOF FUNCTION (??) FI.BBC:: 0,,NIL ;BUFFERED BACK CHARS FI.BBF:: NIL ;BUFFERED BACK FORMS TI.BFN:: QTTYBUF ;PRE-SCAN FUNCTION FT.CNS:: TTYOFA ;ASSOCIATED TTY OUTPUT FILE REPEAT 3, 0 ;UNUSED SLOTS F.MODE:: SA% FBT.CM,,2 ;MODE (ASCII TTY IN SINGLE) SA$ FBT.CM\FBT.LN,,2 F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL) 20$ F.JFN:: .PRIIN ;JFN (FOR D20 ONLY) 20% 0 F.FLEN:: -1 ;WE EXPECT RANDOM ACCESS TO BE ILLEGAL F.FPOS:: 0 ;FILE POSITION REPEAT 3, 0 ;UNUSED SLOTS IFN ITS+D10,[ F.DEV:: SIXBIT \TTY\ ;DEVICE IT$ F.SNM:: 0 ;SNAME (FILLED IN) 10$ F.PPN:: 0 ;PPN (FILLED IN) F.FN1:: IT$ SIXBIT \.LISP.\ ;FILE NAME 1 10$ SIXBIT \LISP\ F.FN2:: IT$ SIXBIT \INPUT\ ;FILE NAME 2 10$ SIXBIT \IN\ F.RDEV:: BLOCK 4 ;TRUE FILE NAMES ] ;END OF IFN ITS+D10 IFN D20,[ F.DEV:: ASCII \TTY\ ] ;END OF IFN D20 LOC TTYIF2+LOPOFA IFN ITS+D20+SAIL,[ ; TI.ST1:: IT$ STTYW1 ;TTY STATUS WORDS 20$ CCOC1 SA$ SACTW1 ; TI.ST2:: IT$ STTYW2 20$ CCOC2 SA$ SACTW2 ; TI.ST3:: SA$ SACTW3 20$ XACTW 10$ 0 ; TI.ST4:: SA$ SACTW4 20$ STDTIW IT$ 0 ] ;END OF IFN ITS+D20+SAIL .ELSE BLOCK 4 ; 0 .SEE ATO.LC ; AT.CHS:: 0 ;CHARPOS ; AT.LNN:: 0 ;LINENUM ; AT.PGN:: 0 ;PAGENUM ; BLOCK 10 ; LONBFA:: BLOCK 10 LOC TTYIF2+FB.BUF ; FB.BUF:: ;INTERRUPT FUNCTIONS IFE SAIL,[ NIL,,IN0+^A ;^@ ^A "SIGNAL" ON IT% QCN.BB,,NIL ;^B ^B-BREAK ^C IT$ QCN.BB,,IN0+^C ;^B ^B-BREAK ^C GC STAT OFF IN0+^D,,NIL ;^D GC STAT ON ^E NIL,,IN0+^G ;^F ^G HARD QUIT REPEAT 3, NIL,,NIL ;^H-^M (FORMAT EFFECTORS) NIL,,NIL ;^N ^O NIL,,NIL ;^P ^Q IT% IN0+^R,,NIL ;^R UWRITE ON? ^S IT$ IN0+^R,,IN0+^W ;^R UWRITE ON? ^S ^W INT, ^V MACRO IN0+^T,,NIL ;^T UWRITE OFF? ^U IN0+^V,,IN0+^W ;^V TTY ON ^W TTY OFF IN0+^X,,NIL ;^X SOFT QUIT ^Y IN0+^Z,,NIL ;^Z GO TO DDT  NIL,,NIL ;^\ CONTROL RIGHT-BRACKET NIL,,NIL ;^^ ^_ REPEAT -<.-FB.BUF>, NIL,,NIL ;ALL OTHERS INITIALLY UNUSED ] ;END IFE SAIL IFN SAIL,[ REPEAT 100, NIL,,NIL ;ALPHABETIC (ASCII 0 THROUGH ASCII 177) REPEAT 40, NIL,,NIL ;LOW CONTROL ^ UP TO ^@ (200-277) NIL,,IN0+^A ; ^A QCN.BB,,IN0+^C ;^B ^C IN0+^D,,NIL ;^D NIL,,IN0+^G ;^F ^G REPEAT 3, NIL,,NIL NIL,,NIL ;^N ^O NIL,,NIL ;^P ^Q IN0+^R,,IN0+^W ;^R ^S IN0+^T,,NIL ;^T IN0+^V,,IN0+^W ;^V ^W IN0+^X,,NIL ;^X ^Y IN0+^Z,,NIL ;^Z REPEAT 3, NIL,,NIL QCN.BB,,NIL NIL,,NIL NIL,,IN0+^G ;LOWERCASE ^G REPEAT 11, NIL,,NIL IN0+^Z,,NIL REPEAT -<.-FB.BUF>, NIL,,NIL ] ;END IFN SAIL OFFSET 0 SUBTTL INITIAL TTY OUTPUT FILE ARRAY -F.GC,,TTYOF2 ;GC AOBJN POINTER TTYOF1: JSP TT,1DIMS TTYOFA ;POINTER BACK TO SAR 0 ;USER MAY NOT ACCESS, SO SAY DIMENSION IS ZERO TTYOF2: OFFSET -. FO.EOP:: QTTYMOR ;END OF PAGE FUNCTION REPEAT 3, 0 FT.CNS:: TTYIFA ;STATUS TTYCONS REPEAT 3, 0 F.MODE:: FBT.CM,,3 ;MODE (ASCII TTY OUT SINGLE) F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL) 20$ F.JFN:: .PRIOU ;JFN 20% 0 F.FLEN:: -1 ;NOT RANDOMLY ACCESSIBLE F.FPOS:: 0 ;FILE POSITION REPEAT 3, 0 IFN ITS+D10,[ F.DEV:: SIXBIT \TTY\ ;DEVICE IT$ F.SNM:: 0 ;SNAME (FILLED IN) 10$ F.PPN:: 0 ;PPN (FILLED IN) F.FN1:: IT$ SIXBIT \.LISP.\ ;FILE NAME 1 10$ SIXBIT \LISP\ F.FN2:: IT$ SIXBIT \OUTPUT\ ;FILE NAME 2 10$ SIXBIT \OUT\ F.RDEV:: BLOCK 4 ;TRUE FILE NAMES ] ;END OF IFN ITS+D10 IFN D20,[ F.DEV:: ASCII \TTY\ ] ;END OF IFN D20 LOC TTYOF2+LOPOFA BLOCK 4 0 ;ATO.LC LINEFEED/SLASH FLAG 0 ;AT.CHS CHARPOS 0 ;AT.LNN LINENUM 0 ;AT.PGN PAGENUM FO.LNL:: 71. ;LINEL FO.PGL:: 200000,, ;PAGEL FO.RPL:: 24. ;"REAL" PAGEL OFFSET 0 BLOCK -<.-TTYOF2> SUBTTL SUPER-WRITABLE STUFF - MUST BE SAVED UPON USER INTERRUPT ;;; DONT ALLOW USER INTERRUPTS WHILE: ;;; (1) NOQUIT IS NON-ZERO - THIS PROTECTS GC, ;;; RETSP, SUBLIS, AND OTHERS. ;;; (2) INHIBIT IS NON-ZERO - THIS PROTECTS ;;; MANY AREAS OF SEMI-CRITICAL CODE. ;;; (CF. LOCKI AND UNLOCKI MACROS) ;;; (3) UNREAL IS NON-ZERO (DEPENDS ONEXACT VALUE) ;;; - THIS IS FOR THE NOINTERRUPT FUNCTION SWS:: ;;; THE FOLLOWING STUFF IS SAVED WHEN AN "ERRSET FRAME" IS CREATED. ;;; NOT ONLY ERRSET, BUT ALSO CATCH AND READ NEED TO DO THIS. ;;; INTERPRETED PROGS CREATE A SORT OF HALF-ASSED FRAME. ;;; BEWARE! THE COMPILER DEPENDS ON KNOWING THE LENGTH OF ;;; THE ERRSET FRAME AS A CONSTANT PARAMETER. ERRTN: 0 ;PDL RESTORATION FOR ERRSET CATRTN: 0 ;PDL RESTORATION FOR CATCH OF A THROW EOFRTN: 0 ;PDL RESTORATION ON E-O-F TRAPOUT PA4: 0 ;PDL RESTORATION ON GO OR RETURN INHIBIT: 0 ;NON-ZERO => INHIBIT (DELAY) USER INTERRUPTS ERRSW: -1 ;0 MEANS NO PRINT ON ERROR DURING ERRSET BFPRDP: 0 ;LH: FUNCTION WHICH WANTS TTY PRE-SCAN ; (READ, READLINE) ; TYI FOR ACTIVATION AND CURSORPOS ; CLEVERNESS, BUT NO PRE-SCAN ; NIL FOR NO CLEVERNESS AT ALL ;RH: -1 IF WITHIN READ CATID: NIL ;RH: CATCH IDENTIFICATION TAG ;LH: FLAGS INDICATING SUBTYPE OF FRAME CATSPC==400000 ; SPECIAL PROCESSING NEED BE DONE (OTHER BITS HAVE ; MEANING) CATLIS==200000 ; C(RH) IS POINTER TO A LIST OF CATCH TAGS CATUWP==100000 ; UNWIND-PROTECT, C(RH) IS FUNCTION CATCAB==040000 ; CATCH-BARRIER: RH POINTER TO (CONS FUN CATCH-TAGS) CATALL==020000 ; CATCH-ALL: RH IS FUNCTION OF TWO ARGS CATCOM==010000 ; FROM COMPILED CODE, DO CALLF, NOT IPROGN LEP1==.-ERRTN ;***** LENGTH OF SOME OF ERRSET PUSH .SEE ERSTP UIRTN: 0 ;NON-ZERO => PDL LOC OF MOST RECENT USER INT FRAME .SEE UINT0 RSXTB: (A) ;POINTER TO READ SYNTAX TABLE, INDEXED BY A PNMK1: 0 .SEE PDLNMK ;SAVE TT GCD.A: .SEE GCDBB UNBND3: .SEE UNBIND ;SAVE TT SIXMK2: 0 .SEE SIXMAK SAVMAR: .SEE SUSP14 ;NEEDN'T BE IN SWS, BUT WHO CARES? GCD.B: .SEE GCDBB AUNBD: .SEE AUNBIND ;SAVES D FOR AUNBIND EXP.S: .SEE EXP ;REMEMBERS SIGN OF ARG ATAN.S: .SEE ATAN ;SAVES SIGNS OF ARGS UNMTMP: ;UNAME TEMP FPTEM: ;PSYM WANTS THIS TO BE SAME AS PCNT!!! IFLT9: .SEE IFLOAT ;D SAVED HERE EQLP: 0 ;PDL POINTER UPON ENTRY TO EQUAL .SEE EQUAL GCD.C: .SEE GCDBB ATAN.X: .SEE ATAN ;TEMPORARY X VALUE GWDCNT: 0 GCD.D: .SEE GCDBB ATAN.Y: .SEE ATAN ;TEMPORARY Y VALUE GWDORG: 0 ;ORIGIN OF LAPPIFICATION - GWDRG1 IS GWDORG-1 GWDRG1: 0 EXPL5: 0 ;TEMP FOR EXPLODE GCD.UH: .SEE GCDBB BKTRP: .SEE BAKTRACE EV0B: .SEE EVAL FLAT1: .SEE FLATSIZE MEMV: 0 .SEE MEMBER UAPOS: ;-1=> UWRITE, >=0 => UAPPEND .ACCESS POS GCD.VH: .SEE GCDBB LPNF: ;-1 MEANS NOT A LONG PNAME (FITS IN PNBUF) .SEE RINTERN AUNBR: 0 ;SAVES R FOR AUNBIND DLTC: 0 ;# OF TIMES DELETE/DELQ SHOULD REMOVE ITEM .SEE DELQ RINF: APFNG1: TABLU1: 0 AUNBF: ;SAVES F FOR AUNBIND IFE BIGNUM,[ MNMX0: ;"MIN" INSTRUCTION GRESS0: 0 ;"GREATERP" INSTRUCTION ] ;END OF IFE BIGNUM IFN BIGNUM,[ GRESS0: 0 ;"MIN" AND"GREATERP" INSTRUCTION CFAIL: JRST . ;TRANSFER ON FAILURE CSUCE: JRST . ;TRANSFER ON SUCCEED ] ;END OF IFN BIGNUM IT$ IOST: .STATUS 00,A IFN ITS, SYSCL8: BACTYF: 0 ;ZERO ON FIRST LOOP THROUGH BACTRACE. BOOLI: SETZB D,TT ;BOOLEAN INSTRUCTION FOR BOOLE TOPAST: -1 ;IF -1 THEN TOP-LEVEL ASTERISK NOT PRINTED IF VINFILE ; IS INIIFA IFN USELESS, PRINLV: ;-1 PLUS0: 0 ;TYPE - QFIXNUM OR QFLONUM IFE BIGNUM,[ PLUS3: ADD D,TT PLUS6: FAD D,TT ;FLOAT-POINT INSTRUCTION FOR ARITH GENERATOR ] ;END OF IFE BIGNUM IFN USELESS, ABBRSW: ;KIND OF STUFF DESIRED FROM PRINT0: ; - => ONLY ABBREV STUFF ; 0 => ONLY NON-ABBREV STUFF ; + => BOTH (DISTINGUISHED BY TYOSW) PLUS8: 0 ; WHERE THERE ARE N ARGS RM4: 0 IFN USELESS, PRPRCT: ;PRINT'S PARENS COUNTS (LEFT,,RIGHT) SWNACK: 0 ;USED FOR WNA CHECKING IN STATUS JRST STAT1 IFN USELESS, TYOSW: 0 ;NORMALLY ZERO - TELLS TYO TYPE OF CHAR ; + => CHAR IS FOR FILES ONLY ; - => CHAR IS FOR TTY ONLY ; 0 => CHAR IS FOR BOTH FILES AND TTY RDBKC: 0 ;SAVED BREAK CHARACTER, ON EXIT FROM RDCHAR RDNSV: 0 ;SAVED NUMBER (BEFORE DECIMAL-OR-NOT IS DECIDED) RDDSV: 0 ;SAVED VALUE OF # OF DIGITS TO RIGHT OF DECIMAL POINT RDIBS: 0 ;NUMERIC IBASE DURING READING IFN USELESS, RDROMP: 0 ;ROMANP - ARE ROMAN NUMERALS OK? RDINCH: 0 ;SOURCE OF CHARACTERS FOR READ CORBP: 0 ;BYTE-POINTER FOR READ-SOURCE WHEN SOURCE IS BLOCK OF ;ASCII OR SIXBIT STUFF IN CORE MKNCH: 0 ;INSTRUCTIION FOR MAKNAM TO GET NEXT BYTE ;;; THE PNAME BUFFER IS USED FOR VARIOUS AND SUNDRY PURPOSES. ;;; THE PRIMARY PURPOSE IS ACCUMULATING PRINT NAMES OF ATOMS. .SEE RINTERN ;;; IT IS ALSO USED FOR VALRET AND SUSPEND STRINGS, .SEE VALRET .SEE SUSPEND ;;; JCL, NAMESTRINGS OF FILES (ESPECIALLY FOR D20 GTJFN JSYS), .SEE 6BTNS ;;; ERROR MESSAGE STRING PROCESSING, .SEE ERRIOJ ;;; AND SO ON. FOR SOME PURPOSES THIS BUFFER OVERLAPS THE BIGNUM TEMPS. 20% MAYBE LPNBUF==:10 20$ MAYBE LPNBUF==:50 PNBP: 440700,,PNBUF ;BYTE POINTER FOR PNAME BUFFER PNBUF: BLOCK LPNBUF 0 ;EXTRA WORD USED TO GUARANTEE THAT A STRING CAN BE MADE ASCIZ JCLBF==:PNBUF+1 ;SINCE STATUS JCL MAY CALL INTERN ON A SCO ATMBF==:PNBUF+1 ;DITTO INTERACTION BETWEEN PRINTA AND EXPLODE IFN BIGNUM,[ REMFL: 0 ;REMAINDER FLAG VETBL0: 0 ;DIVISION STUFF DVS1: 0 DVS2: 0 DVSL: 0 DD1: 0 DD2: 0 DD3: 0 DDL: 0 NORMF: 0 QHAT: 0 BNMSV: 0 FACF: 0 FACD: 0 AGDBT: 0 YAGDBT: 0 TSAVE: 0 DSAVE: 0 RSAVE: 0 FSAVE: 0 NRD10FL: 0 ;NOT READING IN BASE 10. FLAG ] ;END OF IFN BIGNUM IFG JCLBF+24-., BLOCK JCLBF+24-. ;MUST HAVE AT LEAST 24 WDS LJCLBF==:.-JCLBF UUOH: ;KEEP THIS UUO STUFF CONTIGIOUS SO THAT GC CAN SAVE IT. ERROR: 0 JRST UUOH0 ERBDF: ;SOME RANDOM TEMP FOR UUO HANDLER UUOFN: 0 ;POINTER TO FUNCTION DURING THE UUOH1 LOOP UUTSV: 0 UUTTSV: 0 UURSV: 0 UUALT9: .SEE UUALT ;DOESN'T CONFLICT WITH UUPSV UUPSV: 0 UUOBKG: 0 ;IF IN *RSET MODE, PUT STUFF ON PDL LUUSV==:.-UUOH ;STUFF THAT NEEDS SAVING FOR THE UUO HANDLER LSWS==:.-SWS ;TOTAL LENGTH OF SUPER-WRITABLE STUFF JRST UUBKG1 ;;; ******** STUFF SAVED UPON USER INTERRUPT ENDS HERE ******** SUBTTL FREE STORAGE LISTS, AND GC AND ALLOC PARAMETERS ;;; ********** FREE STORAGE LISTS ********** ;;; THESE ARE USED BY THE VARIOUS CONSERS TO ALLOCATE CELLS OF ;;; THE VARIOUS FREE STORAGE SPACES. NEVER PUT ONE OF THESE IN ;;; A MARKABLE AC (EXCEPT WITHIN A PROPERLY PROTECTED CONSER)! ;;; CAUTION! MUST PRESERVE RELATIVE ORDERING OF ;;; FFS,FFX,FFL,FFD,FFC,FFZ,FFB,FFY,FFH,FFA,FFY2 .SEE GC ;GARBAGE COLLECTOR FFS: 0 ;LIST FREE STORAGE LIST FFX: 0 ;FIXNUMS (AND PNAME AND BIGNUM WORDS) FFL: 0 ;FLONUM WORDS LIST DB$ FFD: SETZ ;DOUBLE-PRECISION FLONUMS CX$ FFC: SETZ ;COMPLEX NUMBERS DX$ FFZ: SETZ ;DOUBLE-PRECISION COMPLEX (DUPLEX) BG$ FFB: 0 ;BIGNUM HEADERS FFY: 0 ;SYMBOL (PNAME-TYPE ATOM) HEADERS HN$ FFH: REPEAT HNKLOG+1, SETZ ;HUNKS FFA: 0 ;SARS (ARRAY POINTERS) NFF==:.-FFS ;NUMBER OF FF FROBS FFY2: SY2ALC ;SYMBOL BLOCKS (EXPLICIT RETURN USED) ;;; SIGN BIT IN FF- MEANS EXEMPT FROM 40-WORD MINIMUM RECLAIMED. .SEE GCSWH1 .SEE AGC1Q .SEE GCE0C5 .SEE GCE0C9 .SEE HUNK ;;; PURE FREE STORAGE COUNTERS (NON-POSITIVE, RELATIVE TO EPFF- BELOW) ;;; MUST PRESERVE RELATIVE ORDERING THROUGH NPFFY2 NPFFS: 0 ;LIST NPFFX: 0 ;FIXNUM NPFFL: 0 ;FLONUM DB$ NPFFD: 0 ;DOUBLE CX$ NPFFC: 0 ;COMPLEX DX$ NPFFZ: 0 ;DUPLEX BG$ NPFFB: 0 ;BIGNUM 0 ;NO PURE SYMBOLS HN$ NPFFH: REPEAT HNKLOG+1, 0 ;HUNKS 0 ;NO PURE SARS IFN .-NPFFS-NFF, WARN [NPFF- TABLE WRONG LENGTH] NPFFY2: 0 ;SYMBOL BLOCKS ;;; ADDRESS OF WORD ABOVE CURRENT PURE SEGMENT FOR EACH SPACE ;;; MUST PRESERVE RELATIVE ORDERING THROUGH EPFFY2 EPFFS: 0 ;LIST EPFFX: 0 ;FIXNUM EPFFL: 0 ;FLONUM DB$ EPFFD: 0 ;DOUBLE CX$ EPFFC: 0 ;COMPLEX DX$ EPFFZ: 0 ;DUPLEX BG$ EPFFB: 0 ;BIGNUM 0 ;NO PURE SYMBOLS HN$ EPFFH: REPEAT HNKLOG+1, 0 ;HUNKS 0 ;NO PURE SARS IFN .-EPFFS-NFF, WARN [EPFF- TABLE WRONG LENGTH] EPFFY2: 0 ;SYMBOL BLOCKS EFVCS: BVCSG+NVCSG*SEGSIZ ;END OF CURRENT VC REGION (EFVCS+NFVCS=LAST USED VC) NFVCP: NXVCSG/SGS%PG ;NUMBER OF EXTRA VC PAGES FFVC: BFVCS ;VALUE CELL FREELIST (EXPLICIT RETURN USED) ETVCFLSP: 0 .SEE GCMARK ;EVER-TOOK-VALUE-CELL-FROM-LIST-SPACE-P ;;; GCMKL IS ARRANGED LIKE A PROPERTY LIST: THE "PROPERTY NAMES" ;;; ARE SARS, IN DECREASING ORDER OF POSITION IN ARRAY SPACE, ;;; AND THE "PROPERTY VALUES" ARE FIXNUMS DENOTING THE LENGTHS ;;; OF THE ARRAYS. USED BY GC, RETSP, GRELAR, *ARRAY, AND OTHERS ;;; TO KEEP TRACK OF ARRAYS. NOTE: THE INITIAL OBARRAY AND ;;; READTABLE ARE NOT IN GCMKL SINCE THEY ARE NOT IN BPS. GCMKL: IGCMKL ;;; PROLIS IS AN ALIST USED TO PROTECT NON-ATOMIC READ-MACRO ;;; FUNCTIONS FROM BEING GC'ED. EACH ITEM ON THE ;;; ALIST IS OF THE FORM (FUN RDT . NUM) WHERE: ;;; FUN IS THE FUNCTION TO BE PROTECTED ;;; RDT IS THE SAR OF THE READTABLE CONCERNED ;;; NUM IS A LISP NUMBER (GUARANTEED NLISP INUM) ;;; FOR READ-MACRO FUNCTION ;;; PROLIS IS UPDATED BY SSGCPRO AND SSGCREL. PROLIS: NIL ;;; VARIOUS RANDOM PARAMETERS FOR GARBAGE COLLECTOR. ;;; MUST PRESERVE RELATIVE ORDER WITHIN GROUPS. ;;; GCMIN PARAMETERS FOR EACH SPACE (FLONUM IFF LH NON-ZERO) .SEE GCE0C0 MFFS: MINFFS ;LIST MFFX: MINFFX ;FIXNUM MFFL: MINFFL ;FLONUM DB$ MFFD: MINFFD ;DOUBLE CX$ MFFC: MINFFC ;COMPLEX DX$ MFFZ: MINFFZ ;DUPLEX BG$ MFFB: MINFFB ;BIGNUM MFFY: MINFFY ;SYMBOL HN$ MFFH: REPEAT HNKLOG+1, MINFFH ;HUNKS MFFA: MINFFA ;SARS IFN .-MFFS-NFF, WARN [MFF- TABLE WRONG LENGTH] ;;; LENGTH OF FREELISTS .SEE GCP4B NFFS: 0 ;LIST NFFX: 0 ;FIXNUM NFFL: 0 ;FLONUM DB$ NFFD: 0 ;DOUBLE CX$ NFFC: 0 ;COMPLEX DX$ NFFZ: 0 ;DUPLEX BG$ NFFB: 0 ;BIGNUM NFFY: 0 ;SYMBOL HN$ NFFH: REPEAT HNKLOG+1, 0 ;HUNKS NFFA: 0 ;SARS IFN .-NFFS-NFF, WARN [NFF- TABLE WRONG LENGTH] IFN USELESS*ITS,[ GCWHO: 0 ;VALUE OF (STATUS GCWHO) ;1.1 => DISPLAY MESSAGE DURING GC ;1.2 => CLOBBER .WHO2 WITH GC STATISTICS GCWHO1: 0 ;SAVED VALUES OF WHO-LINE VARIABLES DURING GC GCWHO2: 0 GCWHO3: 0 ] ;IFN USELESS*ITS GCACSAV: BLOCK NACS+1 ;MARKED ACS SAVED HERE GCNASV: BLOCK 20- ;UNMARKED ACS SAVED HERE GCP=:GCACSAV+P GCFLP=:GCACSAV+FLP GCFXP=:GCACSAV+FXP ;TEST GCFXP FOR NON-ZERO TO DECIDE IF GCSP=:GCACSAV+SP ; INSIDE GC (IMPLYING REAL PDL POINTERS ARE HERE) PANICP: 0 ;-1 SAYS WE'RE CLOSE TO RUNNING OUT OF CELLS GCMRKV: 0 ;NON-NIL MEANS MARK PHASE ONLY GCTIM: 0 ;GC TIME GCTM1: 0 GCUUSV: BLOCK LUUSV IRMVF: 0 ;GCTWA REMOVAL OVERRIDE SWITCH GCRMV: 0 ;WHETHER TO DO GCTWA REMOVAL ARPGCT: 4 ;# OF PAGES TO GRAB FREELY FOR ARRAYS BEFORE GC ;;; PARAMETERS RELEVANT TO MEMORY ALLOCATION. ;;; MUST PRESERVE RELATIVE ORDERING OF MOST OF THIS STUFF. ;USED BY GC TO HOLD EXACT CALCULATED INTEGRAL GCMINS ZFFS: 0 ;LIST ZFFX: 0 ;FIXNUM ZFFL: 0 ;FLONUM DB$ ZFFD: 0 ;DOUBLE CX$ ZFFC: 0 ;COMPLEX DX$ ZFFZ: 0 ;DUPLEX BG$ ZFFB: 0 ;BIGNUM ZFFY: 0 ;SYMBOL HN$ ZFFH: REPEAT HNKLOG+1, 0 ;HUNK ZFFA: 0 ;SARS IFN .-ZFFS-NFF, WARN [ZFF- TABLE WRONG LENGTH] .SEE SSPCSIZE ;SIZE OF EACH SWEEPABLE SPACE. USED TO CALCULATE PERCENTAGE RECLAIMED. SFSSIZ: NIFSSG*SEGSIZ ;LIST SFXSIZ: NIFXSG*SEGSIZ ;FIXNUM SFLSIZ: NIFLSG*SEGSIZ ;FLONUM DB$ SDBSIZ: 0 ;DOUBLE CX$ SCXSIZ: 0 ;COMPLEX DX$ SDXSIZ: 0 ;DUPLEX BG$ SBNSIZ: NBNSG*SEGSIZ ;BIGNUM SSYSIZ: NSYMSG*SEGSIZ ;SYMBOL HN$ SHNSIZ: REPEAT HNKLOG+1, 0 ;HUNKS SSASIZ: NSARSG*SEGSIZ ;SARS IFN .-SFSSIZ-NFF, WARN [S--SIZ TABLE WRONG LENGTH] ;SIZES OF SPACES BEFORE START OF GC. COPIED FROM SFSSIZ ET AL. AT START OF GC. OFSSIZ: 0 ;LIST OFXSIZ: 0 ;FIXNUM OFLSIZ: 0 ;FLONUM DB$ ODBSIZ: 0 ;DOUBLE CX$ OCXSIZ: 0 ;COMPLEX DX$ ODXSIZ: 0 ;DUPLEX BG$ OBNSIZ: 0 ;BIGNUM OSYSIZ: 0 ;SYMBOL HN$ OHNSIZ: REPEAT HNKLOG+1, 0 ;HUNKS OSASIZ: 0 ;SARS IFN .-OFSSIZ-NFF, WARN [O--SIZ TABLE WRONG LENGTH] ;SIZE FOR EACH SPACE BELOW WHICH TO GRAB NEW SEGMENTS FASTLY .SEE SGCSIZE ; (I.E. WITHOUT DOING A WHOLE GARBAGE COLLECTION FIRST) GFSSIZ: MAXFFS ;LIST GFXSIZ: MAXFFX ;FIXNUM GFLSIZ: MAXFFL ;FLONUM DB$ GDBSIZ: MAXFFD ;DOUBLE CX$ GCXSIZ: MAXFFC ;COMPLEX DX$ GDXSIZ: MAXFFZ ;DUPLEX BG$ GBNSIZ: MAXFFB ;BIGNUM GSYSIZ: MAXFFY ;SYMBOL HN$ GHNSIZ: REPEAT HNKLOG+1, MAXFFH ;HUNKS GSASIZ: MAXFFA ;SARS IFN .-GFSSIZ-NFF, WARN [G--SIZ TABLE WRONG LENGTH] ;;; ROOTS OF THE CHAINS LINKING LIKE PAGES IN THE GARBAGE COLLECTOR ;;; SEGMENT TABLE (GCST). FILLED IN AT INIT TIME. FSSGLK: 0 ;LIST FXSGLK: 0 ;FIXNUM FLSGLK: 0 ;FLONUM DB$ DBSGLK: 0 ;DOUBLE CX$ CXSGLK: 0 ;COMPLEX DX$ DXSGLK: 0 ;DUPLEX BG$ BNSGLK: 0 ;BIGNUM SYSGLK: 0 ;SYMBOL HN$ HNSGLK: REPEAT HNKLOG+1, 0 ;HUNKS SASGLK: 0 ;SARS IFN .-FSSGLK-NFF, WARN [--SGLK TABLE WRONG LENGTH] S2SGLK: 0 ;THIS MUST FOLLOW THOSE ABOVE! (SYMBOL BLOCKS) BTSGLK: 0 ;LINKED LIST OF BIT BLOCKS IMSGLK: 0 ;LINKED LIST OF UNALLOCATED IMPURE SEGMENTS (INIT SETS UP) PRSGLK: 0 ;LINKED LIST OF UNALLOCATED PURE SEGMENTS 10$ SVPRLK: 0 ;SAVED PRSGLK WHEN HISEG GETS PURIFIED PG$ LHSGLK: 0 ;LINKED LIST OF BLOCKS FOR LH HACK BTBAOB: PG$ -+NBITB,,BFBTBS_<5-SEGLOG> PG% -+NBITB,, .SEE IN10S5 MAINBITBLT: BFBTBS-1 ;END ADDRESS FOR BLT OF MAIN BIT BLOCK AREA GC98: 0 ;RANDOM TEMP FOR GC GC99: 0 ;RANDOMER TEMP FOR GC .SEE SPURSIZE ;SIZE OF PURE FREE STORAGE AREAS - USED MAINLY BY STATUS, .SEE LDXQQ2 ; BUT ALSO RANDOMLY USED BY DEC-10 FASLOAD INTO HISEG PFSSIZ: NPFSSG*SEGSIZ ;LIST PFXSIZ: NPFXSG*SEGSIZ ;FIXNUM PFLSIZ: NPFLSG*SEGSIZ ;FLONUM DB$ PDBSIZ: 0 ;AIN'T NO INITIAL PURE DOUBLES, SONNY! CX$ PCXSIZ: 0 ;AIN'T NO INITIAL PURE COMPLICES, MAMA! DX$ PDXSIZ: 0 ;AIN'T NO INITIAL PURE DUPLICES, DADDY! BG$ PBNSIZ: 0 ;AIN'T NO INITIAL PURE BIGNUMS, BABY! 0 ;AIN'T NEVER NO PURE SYMBOLS! HN$ PHNSIZ: REPEAT HNKLOG+1, 0 ;HUNKS (YOU GOTTA BE KIDDING!) 0 ;AIN'T NEVER NO PURE SARS NEITHER! IFN .-PFSSIZ-NFF, WARN [P--SIZ TABLE WRONG LENGTH] PS2SIZ: NSY2SG*SEGSIZ ;SYMBOL BLOCKS ;;; ********** HAIRY PARAMETERS HACKED BY ALLOC ********** BPSH: ;BINARY PROG SPACE HIGH PG% 0 ;FILLED IN BY ALLOC PG$ <&PAGMSK>-1 BPSL: BBPSSG ;BINARY PROG SPACE LOW IFN PAGING,[ HINXM: 0 ;ADDRESS OF LAST WORD OF NXM HOLE ] ;END OF IFN PAGING IFE PAGING,[ HIXM: 0 ;ADDRESS OF LAST WORD OF LOW SEGMENT MAXNXM: 0 ;HIGHEST USABLE WORD OF NXM ABOVE LOW SEGMENT HBPORG: ENDHI ;FIRST AVAILABLE WORD OF HISEG FOR LOADING BINARY PROGRAMS HBPEND: IF1,[0] IF2,[HILOC+<&PAGMSK>-1] ] ;END OF IFE PAGING ;;; THESE TWO VALUES ARE USED FOR A QUICK-AND-DIRTY PDL NUMBER CHECK. .SEE PDLNMK .SEE SPECBIND ;AND OTHERS NPDLL: 0 ;LOW END OF NUMBER PDL AREA NPDLH: 0 ;HIGH END OF NUMBER PDL AREA IFN PAGING,[ PDLFL1: 0 ;FOR FLUSHING PDL PAGES - SEE ERINIT PDLFL2: 0 ;FOR UPDATING ST - SEE ERINIT ] ;END OF IFN PAGING ;;; THE NEXT FEW THINGS MUST BE IN THIS ORDER .SEE SSGCMAX ;MAXIMUM SIZES FOR STORAGE SPACES XFFS: 0 ;LIST XFFX: 0 ;FIXNUM XFFL: 0 ;FLONUM DB$ XFFD: 0 ;DOUBLE CX$ XFFC: 0 ;COMPLEX DX$ XFFZ: 0 ;DUPLEX BG$ XFFB: 0 ;BIGNUM XFFY: 0 ;SYMBOL HN$ XFFH: REPEAT HNKLOG+1, MAXFFH ;HUNKS XFFA: 0 ;SARS IFN .-XFFS-NFF, WARN [XFF- TABLE WRONG LENGTH] IFN PAGING,[ ;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER XPDL: MAXPDL ;MASTER PDL POSITIONS TO GIVE XFLP: MAXFLP ; PDL-LOSSAGE INTERRUPTS AT XFXP: MAXFXP XSPDL: MAXSPDL ;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER ZPDL: MAXPDL ;ACTUAL PDL POSITIONS FOR LOSING ZFLP: MAXFLP ;INITIALIZED AT ERINIT FROM XPDL ET AL. ZFXP: MAXFXP ; AND DIDDLED BY PDLOV AT OVERFLOW TIME ZSPDL: MAXSPDL ] ;END OF IFN PAGING ;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER C2: -PAGSIZ+NACS+1+2,,PDLORG-1 ;STANDARD REG PDL PTR FLC2: -PAGSIZ+2,,FLPORG-1 ;STANDARD FLO PDL PTR FXC2: -PAGSIZ+2,,FXPORG-1 ;STANDARD FIX PDL PTR SC2: -PAGSIZ+1+2,,SPDLORG ;STANDARD SPEC PDL PTR ;SC2 IS INITIALIZED TO ONE SLOT HIGHER THAN MIGHT BE EXPECTED ; IN ORDER TO ACCOMMODATE A ONE-SLOT OVERPOP IN SOME PLACES. .SEE ERRPOP ZSC2: SPDLORG ;SC2 WITH ZERO LEFT HALF ;;; THE NEXT FOUR THINGS MUST BE IN THIS ORDER OC2: 0 ;ABS LIMITS FOR PDLS OFLC2: 0 OFXC2: 0 OSC2: 0 SUBTTL RANDOM VARIABLES IN LOW CORE ;; Fast XCT'd cells for UUOLINK snapping USRHNK: 0 ;Either 0 or CALL instruction: is this a special hunk? SENDI: 0 ;Either 0 or CALL instruction: send msg to user's hunk ICALLI: 0 ;Either 0 or CALL instruction: Apply user's hunk ;;; I GUESS THIS STUFF NEED NOT BE CONSIDERED SACRED ;;; SPACE FOR ALL CHANNELS AND INFERIORS AND USELESS INTS AND GC OVERFLOWS MAYBE LINTAR==20+10*JOBQIO+5*USELESS+NFF INTAR: 0 ;INDEX INTO INTERRUPT ARRAY (FIFO QUEUE) BLOCK LINTAR ;ENTRIES OF FORM ; RIGHT HALVES ARE PROTECTED BY GC ;;; ENOUGH FOR ALL CHANNELS AND INFERIORS AND USELESS INTS AND GC OVERFLOWS MAYBE LUNREAR==20+10*JOBQIO+5*USELESS+NFF UNRC.G: 0 ;-2/-3 FOR DELAYED ^X/^G INTERRUPT IFN USELESS, UNRCLI: 0 ;ENTRY FOR DELAYED CLI INTERRUPT IFN USELESS, UNRMAR: 0 ;ENTRY FOR DELAYED MAR INTERRUPT UNRRUN: 0 ;ENTRY FOR DELAYED RUNTIME ALARMCLOCK UNRTIM: 0 ;ENTRY FOR DELAYED REAL TIME ALARMCLOCK UNREAR: 0 ;INDEX INTO "REAL TIME" INTERRUPT QUEUE BLOCK LUNREAR ;ENTRIES OF FORM ;ARGS IN UNREAR NEED NO GC PROTECTION .SEE NOINTERRUPT ;;; INTERRUPT PDL LIPSAV==:10 ;LENGTH OF CRUD PUSHED BY INTERRUPT IPSWD1==:-7 ;WORD ONE (.PIRQC) INTERRUPTS TAKEN IPSWD2==:-6 ;WORD TWO (.IFPIR) INTERRUPTS TAKEN IPSDF1==:-5 ;SAVED .DF1 IPSDF2==:-4 ;SAVED .DF2 IPSPC==:-3 ;SAVED PC IPSD==:-2 ;SAVED ACCUMULATOR D IPSR==:-1 ;SAVED ACCUMULATOR R IPSF==:0 ;SAVED ACCUMULATOR F MXIPDL==4 ;MAX SIMULTANEOUS INTERRUPTS ; (CALCULATED FROM THE DEFER WORDS ; IN THE INTERRUPT VECTOR): ; 1 MISCELLANEOUS ; 2 PDL OVERFLOW ; 1 MEMORY ERROR/ILLEGAL OP LINTPDL==LIPSAV*MXIPDL+1 .SEE PDLOV INTPDL: -LINTPDL,,INTPDL .SEE INTVEC ;EXTRA ROOM FOR ONE INTPDL OVERFLOW AND RESULTING EXTRA INTERRUPT BLOCK LINTPDL+2*LIPSAV .SEE PDLOV IT$ IOCINS: 0 ;USER IOC ERROR ADDRESS IT$ .SEE IOCER8 IFN D10,[ IFN SAIL,[ ;SAIL ONLY DEFINITIONS ACBASE==:20 ;WHERE SAIL MONITOR SAVES USER ACS UPON INT INTPAR==:000400,,000000 ;PARITY ERROR INTCLK==:000200,,000000 ;CLOCK INTERRUPT INTTTI==:000004,,000000 ;I INTERRUPT INTPOV==:000000,,200000 ;PDL OV INTILM==:000000,,020000 ;ILL MEMORY REF INTNXM==:000000,,010000 ;NON EXISTANT MEMORY ] ;END IFN SAIL REEINT: BLOCK 1 REENOP: BLOCK 1 APRSVT: BLOCK 1 REESVT: BLOCK 1 ] ;END IFN D10 IFN D10+D20,[ INTALL: BLOCK 1 ;FUDGE BIT DEFINITIONS FOR VARIOUS ITS PI BITS ;LEFT HALF BITS %PIPAR==:1000,, %PIWRO==:200,, ;RH BITS %PIMPV==:20000 %PIILO==:40 ] ;END IFN D10+D20 ;;; LH OF MUNGP => GC IS IN PROCESS OF USING MARK BITS ;;; IN SARS OR SYMBOLS ;;; RH OF MUNGP => ALIST IS IN PROCESS OF USING LH'S OF ;;; VALUE CELLS FOR SPECPDL HACKERY ;;; ERINIT CHECKS MUNGP AND ATTEMPTS TO RESTORE THINGS IF ;;; NECESSARY. THIS SHOULD HAPPEN ONLY IN THE CASE OF SOME ;;; GROSS BUG LIKE A MEMORY VIOLATION. MUNGP: 0 ;;; VARIABLES NEEDED FOR ERRPOP ERRPAD: 0 ;SAVE RETURN ADDRESS ERRPST: 0 ;SAVE T OVER UNWPRO ;;; TEMPORARIES FOR FASLOAD BFTMPS:: SQ6BIT: 0 ;TEMPORARIES FOR SQUEEZE SQSQOZ: 0 LDBYTS: 0 ;WORD OF RELOCATION BYTES LDOFST: 0(TT) ;LOAD OFFSET (RELOCATION FACTOR = VALUE OF BPORG BEFORE LOAD) LDAAOB: 0 ;AOBJN INDEX FOR ATOMTABLE ARRAY LDTEMP: ;RANDOM TEMPORARY LD6BIT: 0 ;PLACE TO ACCUMULATE SIXBIT WHILE CONVERTING FROM SQUOZE ; - FIRST 6 BITS OF NEXT WORD MUST BE ZERO LDAPTR: 0(TT) ;WILL BE AN INDIRECT POINTER FOR ACCESSING THE ATOMTABLE LDBPTR: 0(F) ;WILL BE AN INDIRECT POINTER FOR ACCESSING THE I/O BUFFER LDF2DP: 0 ;.FNAM2-DIFFERENT-P ; (NON-ZERO --> FASLAP'S LDFNM2 DIFFERS FROM CURRENT FASLOAD'S) LDASAR: 0 ;ADDRESS OF SAR FOR FASLOAD'S ATOMTABLE ARRAY LDBSAR: 0 ;ADDRESS OF SAR FOR FASLOAD'S I/O BUFFER ARRAY IFE PAGING,[ LDXBLT: 0 ;BLT POINTER FOR ZAPPING CALLS FOR XCTS IN BPS LDXSIZ: 0 ;0=XCT HACKERY NEVER DONE, -1=DONE AND PURIFIED, ; N>0=LENGTH (IN WORDS) OF AREA FOR XCTED CALLS LDXSM1: 0 ;CONTAINS 1 LESS THAN LDXSIZ, AND RETAINS VALUE AFTER ; LDXSIZ BECOMES -1 LDXDIF: 0(D) .SEE LDPRC6 ;RH WILL CONTAIN DIFFERENCE BETWEEN RH AND LH OF LDXBLT ] ;END IFE PAGING LDHLOC: 0 ;HIGHEST LOC ASSEMBLED INTO + 1 LDEOFJ: 0 ;JUMP ADDRESS FOR END OF FASLOAD INPUT FILE 10$ LDEOFP: 0 ;USED FOR EOF HANDLING IN FASLOAD FOR D10 LFTMPS==:.-BFTMPS ;NUMBER OF FASLOAD TEMPORARIES IFN PAGING,[ ;MULTIPLE XCT SEGMENTS ASSEMBLY TIME PARAMETERS ;DESCRIPTION OF SEGMENT FORMAT: ;LDXPNT POINTS TO FIRST IMPURE SEGMENT IN THE CHAIN. THE RH OF LDXPSP ; WORD IN EACH SEGMENT IS THE POINTER TO THE PURIFIABLE SEGMENT ATTACHED ; TO THE IMPURE SEGMENT, AND THE LH OF LDXPSP IS THE POINTER TO THE NEXT ; SEGMENT OR 0 IF NO MORE SEGMENTS IN CHAIN. LDXLPC IS THE -COUNT OF THE ; NUMBER OF SLOTS FREE IN THE CURRENT SEGMENT. THE CURRENT SEGMENT IS THE ; ONE POINTED TO BY LDXLPL. IF LDXLPC IS >= 0, IT IS POSSIBLE THAT THE PURE ; SEGMENT ATTACHED TO C(LDXLPL) IS ACTUALLY PURE, AND THUS MAY NOT BE WRITTEN ; INTO. IF LDXPNT IS 0, THE DATABASE IS COMPLETELY INVALID. ; THE SEGMENT SIZE USED IS THE DEFAULT SEGMENT SIZE DEFINED BY SEGLOG AND ; SEGSIZ. IF LDXPFG IS -1, THEN A PURIFICATION HAS BEEN DONE. THIS FLAG IS ; USED SOLELY FOR (STATUS UUOLINKS). AN EMPTY SLOT IS ZERO IN BOTH THE PURE ; AND IMPURE SEGMENT. THE FIRST WORD THAT IS USED FOR DATA IN EACH SEGMENT ; IS LDXOFS. THIS IS COMPUTED SUCH THAT THE LAST WORD OF DATA IS ACTUALLY THE ; LAST WORD OF THE SEGMENT. ;HASHING VALUES IFE SEGLOG-8.,[LDHSH1==:251. LDHSH2==:241.] IFE SEGLOG-9.,[LDHSH1==:509. LDHSH2==:503.] IFE SEGLOG-10.,[LDHSH1==:1019. LDHSH2==:1021.] LDX%FU==:90. ;WHAT PERCENTAGE FULL ANY PAGE IS ALLOWED TO GET ;THIS MUST BE LOCATION ZERO! LDXPSP==:0 ;NEXT SEGMENT IN CHAIN,,PURE SEGMENT POINTER LDXOFS==:SEGSIZ-LDHSH1-1 ;OFFSET OF FIRST WORD OF UUOLINKS LDXPNT: 0 ;POINTER TO XCT PAGES LDXLPC: 0 ;COUNT OF WORDS REMAINING ON LAST PAGE USED LDXLPL: 0 ;STARTING LOCATION OF LAST PAGE USED LDXHS1: 0 ;FIRST HASH VALUE LDXHS2: 0 ;SECOND HASH VALUE LDXPFG: 0 ;-1 WHEN PURIFIED ] ;END IFN PAGING IT$ IUSN: 0 ;INITIAL USER SNAME - SET BY LISPGO USN: BLOCK 2 ;USER SYSTEM NAME EVPUNT: TRUTH ;DON'T EVAL FUNCTION ATOM IFN D10,[ UWUSN: 0 ;UWRITE SNAME (I.E. PPN) D10PTR: 0 ;AOBJN POINTER FOR DEC BUFFERS.. D10ARD: -200,,. ;I/O WORD FOR ARRAY DUMP AND FASL 0 D10NAM: 0 ;THIS WORD ;WILL BE ###LSP WHERE ###=JOB NR D10REN: BLOCK 2 ;FILE NAME TO ] ;END OF IFN D10 IT% SYMLO: 0 ;LOW BOUNDARY FOR DDT'S SYMBOL TABLE IFN SAIL,[ ;DEFINE SOME EXTRA TTY RELATED BITS %TXTOP==:4000 ;"TOP" KEY. %TXSFL==:2000 ;"SHIFT-LOCK" KEY. %TXSFT==:1000 ;"SHIFT" KEY. %TXMTA==:400 ;"META" KEY. %TXCTL==:200 ;"CONTROL" KEY. %TXASC==:177 ;THE ASCII PART OF THE CHARACTER. ] ;END IFN SAIL IT$ %TXSFL==:0 ;"SHIFT-LOCK" KEY DOESN'T EXIST ON ITS RDOBJ8: RD8N ;OR RD8W FOR WHITE'S + HAC ALGCF: 0 ;FLAG TO STOP THE GC WHILE IN ALLOC AFILRD: -1 ;-1 => NO INIT FILE, >0 => CDR OF ALLOC COMMENT GNUM: ASCII \G0000\ ;INITIAL GENSYM ;;; RANDOM STUFF FOR RANDOM NUMBER GENERATOR ;;; RNOWS, RBACK, AND RBLOCK MUST BE IN THAT ORDER. IFN USELESS,[ MAYBE LRBLOCK==:71. ; 71 35 MAYBE ROFSET==:35. ;X +X +1 IS IRREDUCIBLE MOD 2 (ASK MACSYMA!) ] ;END OF IFN USELESS IFE USELESS,[ MAYBE LRBLOCK==:7 ; 7 3 MAYBE ROFSET==:3 ;SO ALSO IS X +X +1 IRREDUCIBLE MOD 2 ] ;END OF IFE USELESS RNOWS: 0 .SEE INIRND ;INITIALIZED AT INIT TIME RBACK: 0 .SEE SSRANDOM ;CAN BE RESTORED BY (SSTATUS RANDOM ...) RBLOCK: BLOCK LRBLOCK .SEE RANDOM ;71. WORDS OF "RANDOM"NESS RNTN2: .(T) ;CURRENT PNBUF WORD FOR COMPARE ON INTERN ;;; VARIABLES FOR ARRAY ALLOCATOR BPPNR: 0 ;,,- GAMNT: 0 ;NUMBER OF WORDS REQUIRED, ON A CALL TO GETSP GSBPN: 0 ;USED AS TEMPORARY BPEND WHILE BLT'ING DOWN ARRAYS ADDSAR: 0 ;ADDRESS OF SPECIAL ARRAY CELL WHEN MAKIN ARRAY TOTSPC: 0 ;<# OF ARRAY DIMS>,, LLIP1: 0 ;+1 INSP: 0 ;PSEUDO-PDL POINTER FOR ARRAY-ING RTSP1: 0 RTSP3: 0 LOSEF: 77 ;LAP OBJECT STORAGE - EFFICIENCY FACTOR. FOR (STATUS LOSEF) = N, ;THERE WILL BE <1_N>-1 STORED HERE. SIZE OF GC PROTECTION ARRAY RWG: 0 ;IF = 0, THEN CREATE ERROR ON DIVIDE BY ZERO, ;OR FLOATING OVFLO ON CONVERSION OF BIGNUM FLOV9A: 0 ;RANDOM TEMPS FOR FLOATING POINT FLOV9B: 0 ; OVERFLOW INTERRUPT HANDLER CPJSW: 0 ;IF NOT ZERO, THEN *RSET WAS ON, AND BAKTRACE WILL FIND MUCH ;INFORMATION FROM THE [FUN,,CPOPJ] TYPE STUFF ON THE PDL PSYMF: 0 ;NON-ZERO DURING EXECUTION OF PSYM. POFF: 0 ;VARIOUS ROUTINES INVOLVING $X'S FROM DDT DO JSR'S HERE JRST PSYM1 PSMS: BLOCK 20 ;THIS SHOULD BE ENOUGH FOR LPSMTB BLOCK 3 PSMTS: 0 PSMRS: 0 IT$ SQUOZE 0,. ;FOR A .BREAK 12,[4,,PS.S-1] PS.S: 0 .SEE PSYM1 STQLUZ: 0 ;FOR SETQING NIL OR T - REMEMBER WHICH ONE OVER INTWAIT NOPFLS: 0 ;NON-ZERO => PURIFY$G SHOULDN'T FLUSH PDLS SAWSP: -1 ;SCREW-AROUND-WITH-SHARING-P: -1 SAYS WE MUS READ ; OUR CORE IMAGE IN FROM A "PURQIO" FILE 20$ PSYSP: -1 ;PURIFY-SYSTEM-PAGES -1 SAYS YES IFN ITS,[ PURDEV: 0 ;PDUMP FILE DEVICE NAME PURFN1: 0 ;PDUMP FILE FN1 PURFN2: 0 ;PDUMP FILE FN2 PURSNM: 0 ;PDUMP FILE SNAME SYSDEV: SIXBIT \SYS\ SYSFN1: SIXBIT \PURQIO\ SYSFN2: LVRNO SYSSNM: SIXBIT \SYS\ ] ;IFN ITS SA$ FAKDDT: HALT ;FOR FAKING OUT THE WORLD MAYBE LSJCLBUF==10 ;ENOUGH FOR 40. CHARS SJCLBUF: 0 ;FIRST WORD HOLD NUMBER OF CHARS BUFFERED BLOCK LSJCLBUF 0 ;INSURES THAT ILDBS WILL FINALLY SEE A ZERO SUBTTL INITIAL READTABLE, OBARRAY (IN LOW CORE) ;;; INITIAL READ SYNTAX TABLE IN FORM OF AN ARRAY -1,,0 ;IN NEWIO, WILL POINT TO MACRO CHAR LIST RSXTB1: PUSH P,CFIX1 JSP TT,1DIMF READTABLE 0 RCT: BLOCK LRCT-2 ;WHICH IS BLT'D IN FROM RCT0 TRUTH,,0 ;(STATUS TTYREAD),,(STATUS ABBREVIATE) NIL,,TRUTH ;(STATUS TERPRI),,(STATUS _) ;;; INITIAL OBLIST IN FORM OF ARRAY -/2,,IOBAR2 IOBAR1: JSP TT,1DIMS OBARRAY OBTSIZ+1+200 IOBAR2: BLOCK /2 BLOCK 200/2 ;SINGLE CHAR OBJS TABLE (CREATED AS NEEDED) SUBTTL PURTBL AND IPURIFIY ;;; PURE PAGE TABLE ;;; CONTAINS TWO BITS FOR EACH PAGE, 16 PAGES PER TABLE WORD ;;; MEANING OF BITS: 00=NXM 01=IMPURE ;;; 10=PURE 11=SPECIAL HACKERY NEEDED IFN PAGING,[ PURTBL: IF1,[ BLOCK NPAGS/20 IFN NPAGS&17, BLOCK 1 ] ;END IF1 IF2,[ ZZW==. ;DARN WELL BETTER BE SAFE OVER THE FOLLOWING MESS! .BYTE 2 ZZZ==0 $==3 ;FOR HAIRY PRINTOUT TO WORK PRINTX \ INITIAL PURTBL MEMORY LAYOUT [0=NXM, 1=IMPURE, 2=PURE, $=BPS/PDL/SCRATCH] \ NLBTSG==0 NHBTSG==0 IFN LOBITSG, NLBTSG==NBITSG .ELSE, NHBTSG==NBITSG ;;; IN THE IRP BELOW, COMMAS AND CR'S MARK GUARANTEED PAGE BOUNDARIES IRP SPCS,,[ZER+LBT,ST,SYS,SAR+VC,XVC,IS2+SYM+XXA,XXZ,SY2+PFX+PFS+PFL+XXP IFS+IFX+IFL+BN+XXB,HBT,BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP SP,XSP,SCR]BITS,,[1,1,2,1,0,1,0,2,1,1,$,0,$,0,$,0,$,0,$,0,$] ZZX==0 IRPS SPC,,[SPCS] ZZX==ZZX+N!SPC!SG TERMIN REPEAT ZZX/SGS%PG,[ BITS ZZZ==ZZZ+1 IFE ZZZ&17,[ 0 0 ] PRINTX \BITS\ IFE &17, PRINTX \ \ IFE &37, PRINTX \ \ IFE ZZZ&37,[ PRINTX \ \ ] ] ;END OF REPEAT TERMIN .BYTE IFN ZZZ-NPAGS,[ WARN \ZZZ,[=WRONG LENGTH FOR PURTBL (SHOULD BE ]\NPAGS,[)] LOC ZZW BLOCK NPAGS/20 IFN NPAGS&17, BLOCK 1 ] ;END OF IFN ZZZ-NPAGS PRINTX \ \ ] ;END IF 2 ] ;END OF IFN PAGING .SEE PURIFY ;PURIFY ENTERS HERE FPURF7: MOVSI F,2000 ;THIS BIT CONVERTS CALL TO CALLF, JCALL TO JCALLF MOVEI T,VPURCL PUSH P,T FPURF1: HRRZ T,(T) ;CDR DOWN THE PURLIST FPUR1Q: JUMPE T,POP1J FPUR1A: HLRZ AR2A,(T) PUSHJ P,LDSMSH ;TRY TO SMASH JRST FPURF4 ;WIN IORM F,(AR2A) ;LOSE - MAKE IT A CALLF/JCALLF FPURF4: HRRZ T,@(P) ;WIN, SO CUT IT OUT OF PURCLOBRL HRRZ T,(T) HRRM T,@(P) JRST FPUR1Q IFN USELESS,[ IP0: ;PURIFY/DEPURIFY SOME PAGES IFN D10, JRST (R) ;C HAS FLAG, NON-NULL MEANS PURIFY IFN D20+ITS,[ LSH D,-PAGLOG ;CALLED BY JSP R,IP0 LSH TT,-PAGLOG ;USES B,C,T,TT,D,F CAIGE TT,1 LERR [SIXBIT \1ST PAGE NOT PURE!\] MOVEI B,(TT) ;FIGURE OUT PURTBL BYTE POINTER IFN ITS,[ ROT B,-4 ADDI B,(B) ROT B,-1 TLC B,770000 ADD B,[450200,,PURTBL] SUBI D,-1(TT) ;CALCULATE NUMBER OF PAGES IMULI TT,1001 TRO TT,400000 ;SET UP ARG FOR .CBLK20$ MOVSI 1,.FHSLF SKIPN C TLOA TT,400 SKIPA C,R70+2 ;IN PURTBL, 1=IMPURE, 2=PURE MOVEI C,1 IP7: .CBLK TT, ;HACK PAGE JSP F,IP1 ;IP1 HANDLES LOSSES ADDI TT,1001 ] ;END OF IFN ITS IFN D20,[ ROT TT,-4 ADDI TT,(TT) ROT TT,-1 TLC TT,770000 ADD TT,[450200,,PURTBL] SUBI D,-1(B) ;CALCULATE NUMBER OF PAGES HRRI 1,(TT) HRLI 1,.FHSLF MOVSI 2,(PA%RD+PA%EX) SKIPN C TLOA 3,(PA%CPY) SKIPA F,R70+2 MOVEI F,1 IP7: SPACS ADDI 1,1 ADDI 2,1 ] ;END OF IFN D20 TLNN B,730000 ;FOR BIBOP, DEPOSIT BYTE IN PURTBL TLZ B,770000 IT$ IDPB C,B 20$ IDPB F,TT SOJN D,IP7 JRST (R) IFN ITS,[ IP1: MOVE T,[4400,,<776000+>];ASSUME FAILURE WAS DUE TO SHARING .CBLK T, ;USES ONLY T,TT .LOSE 1000+%ENACR ;NO CORE AVAILABLE LDB T,[111000,,TT] LSH T,PAGLOG+22 HRRI T,<376+SFA>*PAGSIZ ;SO COPY PAGE INTO SOME FAKE PAGE BLT T,<376+SFA>*PAGSIZ+1777 ;LIKE PAGE NUMBER 376 MOVE T,TT ANDCMI T,377 IORI T,376+SFA .CBLK T, ;MOVE PAGE MAP FOR 376 INTO LOSING PAGE POSITION .LOSE MOVEI T,376000+ .CBLK T, ;FLUSH ENTRY FOR PAGE 376 .LOSE JRST (F) ] ;END OF IFN ITS ] ;END OF IFN ITS+D20 ] ;END OF IFN USELESS SUBTTL START-UP CODE, AFTER A FLUSHING SUSPEND ;NOTHING ON THIS PAGE IS FLUSHED WHEN/IF LISP'S PURE PAGES ARE CLEARED FROM ; CORE DURING A SUSPEND IFN PAGING,[ NFLSS:: FLSTBL: IF1, BLOCK <<777777_-SEGLOG>+1>/36. IF2,[ .BYTE 1 IRP SPCS,,[ZER+LBT,ST,SYS,SAR+VC,XVC,IS2+SYM+XXA,XXZ,SY2+PFX+PFS+PFL+XXP IFS+IFX+IFL+BN+XXB,HBT,BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP SP,XSP,SCR]BITS,,[1,1,2,1,0,1,0,2,1,1,$,0,$,0,$,0,$,0,$,0,$] ZZX==0 IRPS SPC,,[SPCS] ZZX==ZZX+N!SPC!SG TERMIN REPEAT ZZX/SGS%PG,[ IFE BITS-2, 1 ;GENERATE A FLUSH ENTRY IF PURE .ELSE, 0 ; ELSE PAGE SHOULD NOT BE FLUSHED ] TERMIN .BYTE BLOCK <<777777_-SEGLOG>+1>/36.-<.-FLSTBL> ] ;END OF IF2 ] ;END OF IFN PAGING IFN D20,[ ENTVEC: JRST LISPGO ;TOPS-20 ENTRY VECTOR JRST CTRLG 0 ;TO BE FILLED IN WITH VERSION NUMBER IN ; BITS 4.6 - 3.7 ] ;END OF IFN D20 IFN ITS+D20,[ FLSPA1: ASCIZ \:Job Suspended \ FLSPA3: ASCIZ \:LISP pure pages flushed, and job Suspended \ FLSDIE: ASCIZ \:LOSE!! Cannot find file with pure pages for the LISP which this job was dumped from! \ FLSSTARTUP: JSP TT,SHARP1 ;BEFORE STARTING MUST HAVE A REAL CORE IMAGE .VALUE FLSDIE ; DIE, DIE, DIE SETZM SAWSP ;WE HAVE ALREADY MAPPED OURSELVES IN JRST SUSP3 NOSHARE==JRST (T) ;DEPOSIT INTO SHAREP TO INHIBIT SHAREING SHAREP: SKIPN SAWSP JRST (T) SETZM SAWSP IFN ITS,[ .CALL PURCHK .VALUE JUMPL TT,(T) ;NEGATIVE IF FIRST SYSTEM PAGE IS WRITEABLE ] ;END OF IFN ITS JSP TT,SHARP1 JFCL ;IGNORE CASE OF LOST PURQIO FILE JRST (T) SHARP1: IT% JRST (TT) IT% WARN [HOW TO SHARE WITH "PURQIO" FILE?] IFN ITS,[ .CALL SYSFIL ;GET SYSTEM FILE AND SHARES - SKIP IF WIN JRST (TT) .CALL SHRLOD ;LOAD ALL PURE PAGES FROM THE FILE .LOSE 1400 .CLOSE TMPC, JRST 1(TT) SHRLOD: SETZ SIXBIT \LOAD\ MOVEI %JSELF ;MYSELF MOVEI TMPC ;CHANNEL ON WHICH PURQIO/PURBIB IS OPEN'ED SETZI 0 ;LOAD ONLY PURE PAGES ] ;END OF IFN ITS FLSLSP: 20$ JRST FLSNOT IFN ITS,[ .CALL SYSFIL ;IN ORDER TO FLUSH PAGES, WE MUST BE CERTAIN JRST FLSNOT ; THAT WE CAN GET OURSELVES BACK! .CLOSE TMPC, .CALL PURCHK ;ONLY FLUSH IF LISP IS PURE .VALUE JUMPLE TT,FLSNOT SETOM SAWSP ;FLAG THAT WE MUST READ OURSELVES FROM THE FILE MOVE T,[440100,,FLSTBL] ;POINTER INTO TABLE OF WHICH PAGES TO FLUSH SETZI TT, ;KEEP PAGE NUMBER IN TT FLSPA4: ILDB R,T ;GET INFO ON THIS PAGE JUMPE R,FLSPA5 ;SKIP IF NOT FLUSHABLE CAIE TT,NFLSS/PAGSIZ ;NEVER FLUSH THE PAGES WE ARE ON CAIN TT,NFLSE/PAGSIZ JRST FLSPA5 .CALL FLSPA6 ;ELSE FLUSH THE PAGE FROM OUR PAGE MAP .LOSE 1400 FLSPA5: CAIGE TT,777777/PAGSIZ ;LOOP UNTIL HIGHEST PAGE NUMBER AOJA TT,FLSPA4 .SUSET FLSMSK ;MAKE SURE NO INTERRUPTS TRY TO HAPPEN PUSHJ P,PDUMPL ;PURE DUMP LISP IF SO DESIRED SKIPE (FLP) ;NIL JCL? JRST SUSCON ;NOPE, RETURN T AND PROCEED SKIPE TT,(FXP) ;CHECK IF VALRET STRING JRST FLSVAL ;YES, MUST VALRET IT THEN MOVE T,FXP SUB T,FLSADJ MOVEM T,(FXP) .VALUE FLSPA3 ;PRINT SUSPENSION MESSAGE JRST SUSCON ;CONTINUING AFTER A SUSPEND FLSVAL: SKIPN VALFIX ;IS VALRET STRING REALLY A FIXNUM? JRST FLSVA1 ;NO, USE NORMAL VALRET HRRZ T,1(TT) ;PICKUP THE VALUE .BREAK 16,(T) ;DO THE .BREAK JRST SUSCON ;CONTINUE WHEN IT RETURNS, BUT RETURN T FLSVA1: .VALUE 1(TT) JRST SUSCON ;ON PROCEED, RETURN T FLSADJ: 1,,1 FLSMSK: .SMASK,,.+1 0,,0 FLSPA6: SETZ SIXBIT \CORBLK\ MOVEI 0 ;FLUSH THE PAGE MOVEI %JSELF ;FROM OURSELVES SETZ TT ;PAGE NUMBER IN TT PURCHK: SETZ SIXBIT \CORTYP\ ;GET TYPE FOR CORE BLOCK 1000,,BSYSSG/PAGSIZ ;THAT FIRST SYSTEM PAGE IS ON 402000,,TT ;>0 READ-ONLY, < 0 WRITABLE, = 0 NON-EXISTENT SYSFIL: SETZ ;FOR OPENING UP FILE TO SHARE SIXBIT \OPEN\ SYSCHN SYSDEV SYSFN1 SYSFN2 SETZ SYSSNM SYSCHN: .UII,,TMPC ] ;END OF IFN ITS ;ROUTINE TO PDUMP A FILE WITH INDIRECT SYMBOL TABLE POINTER INCLUDED IT% PDUMPL: POPJ P, IFN ITS,[ PDUMPL: SKIPN PURDEV ;DID THE GUY WANT PURE DUMPING? POPJ P, ;NOPE, RETURN RIGHT AWAY .CALL PUROPN ;OPEN THE FILE FOR PDUMP'ING .LOSE 1400 ;THE GUY LOST, OH WELL, WE ARE PROBABLY IN ; A SUSPEND ANYWAY SETZ T, ;PDUMP REQUIRES AN INITALLY ZERO STATE WORD .CALL PDUMP ;DO THE ACTUAL PDUMP .LOSE 1400 .IOT TMPC,PURSTI ;OUTPUT START INSTRUCTION .IOT TMPC,PURISP ;INDIRECT SYMBOL TABLE POINTER INDICATOR MOVE TT,PURPTR ;POINTER TO FILENAMES MOVE T,PURPTR ;START CHECKSUM PURCKS: ROT T,1 ADD T,(TT) ;AND CHECKSUM FOR DDT .IOT TMPC,(TT) ;ALSO OUTPUT THE WORD TO THE FILE AOBJN TT,PURCKS .IOT TMPC,T ;OUTPUT THE CHECKSUM .IOT TMPC,PURSTI ;THEN AGAIN THE START ADR .CALL PURRWO ;RENAME TO CORRECT FILENAME .LOSE 1400 .CLOSE TMPC, ;FINISH UP WITH THE FILE POPJ P, PUROPN: SETZ SIXBIT \OPEN\ PURCHN PURDEV PUROP1 PUROP2 SETZ PURSNM PUROP1: SIXBIT \.LISP.\ PUROP2: SIXBIT \OUTPUT\ PURRWO: SETZ SIXBIT \RENMWO\ MOVEI TMPC PURFN1 SETZ PURFN2 PDUMP: SETZ SIXBIT \PDUMP\ MOVEI %JSELF MOVEI TMPC SETZ T PURCHN: .UIO,,TMPC PURSTI: JRST LISPGO PURISP: -4,,2 PURPTR: -4,,SYSDEV ] ;END OF IFN ITS ] ;END OF IFN ITS+D20 PG$ NFLSE: SUBTTL KILHGH AND GETHGH IFN D10*HISEGMENT,[ IFE SAIL,[ KILHG4: OUTSTR [ASCIZ \ ;Not flushing high segment - can't find .SHR file \] KILHG2: MOVEI A,KILHG3 ;THIS SHOULD BE START ADR IF NOT KILLING HS HRRM A,.JBSA MOVE 0,SGANAM ;IMPORTANT INFO INTO ACS IN CASE OF CONTINUE MOVE 11,SGADEV MOVE 7,SGAPPN EXIT 1, ;SUSPEND FOR A WHILE KILHG3: MOVEM 0,SGANAM MOVEM 11,SGADEV MOVEM 7,SGAPPN JRST RETHGH ] ;END IFE SAIL KILHGH: MOVEI A,GETHGH ;KILL HIGH SEGMENT HRRM A,.JBSA" ;SET START ADDRESS IFE SAIL,[ SKIPN SUSFLS JRST KILHG2 SKIPE SGANAM ;CAN'T FLUSH HIGH SEGMENT IF WE SKIPN SGADEV ; DON'T KNOW WHEREFROM TO RETRIEVE IT JRST KILHG4 MOVSI A,1 CORE A, ;FLUSH HIGH SEGMENT JFCL KILHG1: ] ;END OF IFE SAIL IFN SAIL,[ SKIPE SUSFLS SKIPN SGANAM JRST KILHG1 MOVEI A,FAKDDT ;FOO, HOW MANY WAYS CAN SAIL LOSE? SKIPN .JBDDT ; JOBDDT MUST BE NON-ZERO TO SAVE! SETDDT A, ; OTHERWISE MAY FAIL TO SAVE ENTIRE LOSEG SETZ A, CORE2 A, ;FLUSH HIGH SEGMENT HALT ;HOW CAN WE POSSIBLY LOSE? (HA HA) JRST KILHG2 KILHG1: SKIPL .JBHRL JRST KILHG2 MOVEI A,1 SETUWP A, HALT KILHG2: ] ;END OF IFN SAIL EXIT 1, ;"CONTINUE" WILL FALL INTO GETHGH GETHGH: IFE SAIL,[ MOVEI A,A+1 ;SET UP TO GET HIGH SEG BACK MOVE A+1,SGADEV MOVE A+2,SGANAM MOVE A+3,SGAEXT MOVEI A+4,0 MOVE A+5,SGAPPN SKIPE SGANAM SKIPN SGADEV JRST GETHG1 GETSEG A, ;GET HIGH SEGMENT JRST GLSLUA GETHG1: ] ;END OF IFE SAIL IFN SAIL,[ RESET SKIPE .JBHRL JRST GETHG1 MOVE T,SGANAM ATTSEG T, SKIPA TT,SGADEV JSP FREEAC,CHKHGH MOVEI T,.IODMP ;ON FAILURE, LOCK THE SHR FILE, THEN TRY AGAIN, SETZ D, ; AND ON FAILING MAKE THE HISEG OURSELVES OPEN TMPC,T ;OPEN UP .SHR FILE DEVICE IN DUMP MODE HALT ;SOME MORON GAVE LOSING SECOND ARG TO SUSPEND? MOVE T,SGANAM MOVE TT,SGAEXT SETZ D, GETSTS TMPC,R ;GET CHANNEL STATUS WORD TDO R,1000 ;FAST READ-ALTER SETSTS TMPC,(R) ;DO IT MOVE R,SGAPPN LOOKUP TMPC,T JRST GLSLUA ;LOOK UP .SHR FILE MOVS F,R TRZ TT,-1 ;WE NOW OPEN IT FOR READ-ALTER MODE FOR SETZ D, ; THE SOLE PURPOSE OF PREVENTING OTHER MOVE R,SGAPPN ; JOBS FROM READING IT TOO, THEREBY ENTER TMPC,T ; CAUSING WEIRD RACE CONDITIONS JRST GLSLUA MOVE T,SGANAM ATTSEG T, ;SEE IF SOMEONE ELSE HAS SAME HISEG; THIS CAN SKIPA T,F ; HAPPEN IF SOME OTHER JOB GETS THROUGH THIS JSP FREEAC,CHKHGH ; CODE BETWEEN OUR FIRST ATTSEG AND THE ENTER MOVNS T ;T GETS LENGTH OF .SHR FILE ADD T,.JBREL HRR R,.JBREL ;MUST GOBBLE SOME COPIES OF .JBREL HRRZ TT,.JBREL ; BEFORE THE CORE UUO CHANGES IT CORE T, ;EXTEND LOSEG BY THIS AMOUNT JRST GLSLZ1 SETZ F, IN TMPC,R ;READ IN HISEG SKIPA T,SGANAM JRST LDSCRU TLO TT,HSGORG ;WRITE PROTECT HISEG GETHG2: REMAP TT, ;LET'S SPLIT JRST GLSLZ3 GETHG1: MOVE T,SGANAM SETNM2 T, HALT RELEASE TMPC, ;FLUSH TEMP CHANNEL *AFTER* CREATING THE HISEG ] ;END OF IFN SAIL JSP F,JCLSET ;GOBBLE DOWN ANY JCL RETHGH: JRST . ;RETURN ADDR CLOBBERED IN HERE GLSLUY: SIXBIT \CANNOT GET HIGH SEGMENT!\ GLSLUA: MOVEI C,GLSLUY IFN SAIL,[ RELEASE TMPC, TLZ TT,-1 CAIE TT,ERFBM% ;COLLISION DUE TO LOCKOUT? JRST GLSLZ0 ;NO, GENUWINE LOSSAGE PJOB TT, ;THIS IS ALL PRETTY RANDOM - WE'RE IDIVI TT,7 ; TRYING JUST A LITTLE BIT TO SOLVE SLEEP D, ; THE HAIRY RACE CONDITIONS (ALOHA!) JRST GETHGH CHKHGH: MOVE D,SGAPPN CAME D,PSGPPN JRST GLSLZ4 MOVE D,SGADEV CAME D,PSGDEV JRST GLSLZ4 MOVE D,SGAEXT CAME D,PSGEXT JRST GLSLZ4 MOVE D,SGANAM ;CHECK HISEG VALIDATION WORDS CAME D,PSGNAM JRST GLSLZ4 JRST GETHG1 GLSLZ4: SETZ T, ;WRONG HISEG, SO ZERO IT OUT AND START AGAIN CORE2 T, JRST GLSLZ1 MOVE TT,SGADEV MOVE T,F JRST (FREEAC) GLSLZ0: ] ;END OF IFN SAIL HRLI C,440600 ;WILL READ A SIXBIT STRING GLSLZA: ILDB T,C ;READ STRING AND TYPE IT ADDI T," " ;CONVERT TO ASCII OUTCHR T CAIE T,"!" ;STOP AFTER EXCLAMATION-POINT JRST GLSLZA EXIT ;FOO IFN SAIL,[ GLSLZ1: OUTSTR GLSLM1 EXIT GLSLM1: ASCIZ \?CORE UUO LOST \ GLSLZ2: OUTSTR GLSLM2 EXIT GLSLM2: ASCIZ \?IN UUO LOST \ GLSLZ3: OUTSTR GLSLM3 JRST GETHG2 GLSLM3: ASCIZ \?REMAP lost -- no job slots available, retrying \ ] ;END OF IFN SAIL SGANAM: SA% 0 ;THESE ARE THE SAVED NAMES FOR GETTING SA$ SIXBIT \MACLSP\ SGADEV: SA% 0 ; THE HIGH SEGMENT BACK AFTER SUSPENSION SA$ SIXBIT \SYS\ SGAPPN: 0 .SEE SUSPEND SGAEXT: SIXBIT \SHR\ ;SOME LOSER MIGHT WANT TO CHANGE THIS ;;; CODE FOR FASLOAD TO READ IN A NEW HIGH SEGMENT. ;;; THIS CODE MUST BE IN THE LOW SEGMENT! ;;; T HAS LENGTH OF THE .SHR FILE; LH(R) HAS NEGATIVE OF THIS. LDRIHS: IFE SAIL,[ MOVSI TT,1 CORE TT, ;FLUSH OLD HIGH SEGMENT JRST LDSCRU HRRZ TT,.JBREL ;CURRENT HIGHEST ADDRESS IN LOSEG HRRZ D,.JBREL HRR R,.JBREL ADD TT,T CORE TT, ;EXPAND LOSEG SO CAN HOLD COPY OF HISEG JRST LDSCRU ; (REMEMBER, CAN'T DO I/O INTO HISEG!) SETZ F, IN TMPC,R ;READ IN .SHR FILE CAIA JRST LDSCRU REMAP D, ;NOW MAKE A HISEG FROM THE READ-IN CODE JRST LDSCRU SETUWP F, ;TOPS-10 PROTECTS US FROM OURSELVES, JRST LDSCRU ; SO WE MUST MAKE HISEG WRITABLE (F IS ZERO) SETZM SGANAM ;WE NO LONGER KNOW THE HIGHSEG NAME! ;IF THIS IS NON-ZERO, HIGH-SEG GETS FLUSHED ; DURING (SUSPEND) AND ALL THE STUFF WE'VE ; DONE TO IT GOES BYEBYE! (ARG!) POPJ P, ] ;END OF IFE SAIL IFN SAIL,[ SETZ TT, CORE2 TT, ;FLUSH OLD HIGH SEGMENT JRST LDSCRU LDRHS1: CORE2 T, ;MAKE A NEW (WRITABLE) HISEG THAT BIG JRST LDSCRU MOVE T,D10NAM ;USE D10NAM AS HISEG NAME TO MAKE HISEG UNIQUE LSH T,-6 ;AS LONG AS WE'RE BEING RANDOM... SETNM2 T, ;TRY TO SET NAME FOR HIGH SEGMENT JFCL HLRE T,R ;GET WORD COUNT SING EXTENDED MOVMS T ;AND MUST GET A HI-SEG THAT BIG HRRI R,HSGORG-1 SETZ F, IN TMPC,R ;READ IN HISEG POPJ P, ;RETURN TO CODE IN HISEG ] ;END OF IFN SAIL LDSCRU: OUTSTR [ASCIZ \DEPURIFYING HISEG LOST - YOU ARE STRANDED! \] SA% EXIT SA$ JRST LDRHS1 ] ;END OF IFN D10*HISEGMENT SUBTTL LOBITSG TEST CONSTANTS ;;; NO MORE CONSTANTS PERMITTED AFTER THIS IN THE LOSEG (WRITEABLE FIRST PAGE) IF1,[ ZZ==. LOBITSG==0 ;NON-ZERO ==> BITSGS ARE LOW PAGEUP TOP.PG==. IFGE TOP.PG-ZZ-SEGSIZ,[ ;SEE IF THERE IS ANOTHER SEGMENT LEFT ON THIS PAGE SEGUP ZZ SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)] SPCBOT BIT BTBLKS: BLOCK BTSGGS*SEGSIZ-1 SEGUP . SPCTOP BIT,ST,[BIT BLOCK] IFE TOP.PG-., LOBITSG==1 .ELSE,[ WARN [LOBITSG STUFF DIDN'T WORK] EXPUNGE NZERSG NBITSG BBITSG EXPUNGE BTBLKS LOBITSG==0 ] ;END OF .ELSE ] ;END OF IFGE TOP.PG-ZZ-SEGSIZ ] ;END OF IF1 IF2,[ IFN PAGING, PAGEUP IFE PAGING, SEGUP . ] ;END OF IF2 IFE LOBITSG, SPCTOP ZER,SYS,["ZERO" (LOW IMPURE)] PG% EXPUNGE BZERSG EXPUNGE TOP.PG SUBTTL SEGMENT TABLES ;;; FORMAT OF SEGMENT TABLE ( WORDS, ONE FOR EACH SEGMENT) ;;; 4.9 LS 1=LIST STRUCTURE, 0=ATOMIC ;;; 4.8 $FS FREE STORAGE (BIT 4.9 SHOULD BE ON ALSO) ;;; 4.7 FX FIXNUM STORAGE ;;; 4.6 FL FLONUM STORAGE ;;; 4.5 BN BIGNUM HEADER STORAGE ;;; 4.4 SY SYMBOL HEADER STORAGE ;;; 4.3 SA SAR STORAGE (BIT 3.8 SHOULD BE ON ALSO) ;;; 4.2 VC VALUE CELL STORAGE (BIT 4.9 SHOULD BE ON ALSO) ;;; 4.1 $PDLNM NUMBER PDL AREA ;;; (ONE OF THE NUMBER TYPE BITS SHOULD BE ON ALSO) ;;; 3.9 RESERVED - AVOID USING (FORMERLY $FLP) ;;; 3.8 $XM EXISTENT (RANDOM) AREA ;;; 3.7 $NXM NONEXISTENT (RANDOM) AREA ;;; 3.6 PUR PURE SPACE (ONE OF BITS 4.8-4.5 OR 3.8 SHOULD BE ON) ;;; 3.5 HNK HUNK OF ONE KIND OR ANOTHER (BIT 4.9 ON ALSO) ;;; 3.4 DB DOUBLE-PRECISION FLONUMS ;THESE ARE ;;; 3.3 CX COMPLEX NUMBERS ; NOT YET ;;; 3.2 DX DOUBLE-PRECISION COMPLEX NUMBERS ; IMPLEMENTED ;;; 3.1 UNUSED ;;; 2.9-1.1 ADDRESS OF A DATA TYPE, ATOM: ;;; QLIST, QFIXNUM, QFLONUM, QBIGNUM, ;;; QSYMBOL, QRANDOM, QARRAY, QHUNK ;;; NOTE THAT THESE ATOMS OCCUPY CONSECUTIVE MEMORY ;;; LOCATIONS AND THUS NUMERICALLY ENCODE THE PAGE TYPE. ;;; THIS COMMENT SHOULD BE KEPT CONSISTENT WITH THE DEFINITIONS (IN THE ;;; DEFNS FILE) FOR THE ABOVE SYMBOLS, AND WITH LOCATION PSYMTT. .SEE LS .SEE PSYMTT SPCBOT ST ST: ;SEGMENT TABLE IFE PAGING, BLOCK NSEGS ;FOR PAGING SYSTEM, CODE IN INIT SETS UP ; THESE TABLES AT RUN TIME. IFN PAGING,[ IF1, BLOCK NSEGS IF2,[ STDISP: EXPUNGE STDISP ;FOR .SEE $ST ZER,$XM ;"ZERO" (LOW IMPURE) SEGMENTS IFN LOBITSG, $ST BIT,$XM ;BIT BLOCKS $ST ST,$XM ;SEGMENT TABLES $ST SYS,$XM+PUR ;SYSTEM CODE $ST SAR,SA ;SARS (ARRAY POINTERS) $ST VC,LS+VC ;VALUE CELLS $ST XVC,$NXM ;RESERVED FOR EXTRA VALUE CELLS $ST IS2,$XM ;IMPURE SYMBOL BLOCKS $ST SYM,SY ;SYMBOL HEADERS $ST XXA,$XM ;SLACK SEGMENTS (IMPURE!) $ST XXZ,$NXM ;SLACK SEGMENTS (INITIALLY NXM) $ST SY2,$XM+PUR ;PURE SYMBOL BLOCKS $ST PFX,FX+PUR ;PURE FIXNUMS $ST PFS,LS+$FS+PUR ;PURE FREE STORAGE (LIST) $ST PFL,FL+PUR ;PURE FLONUMS $ST XXP,$XM+PUR ;SLACK PURE SEGMENT (FOOEY!) $ST IFS,LS+$FS ;IMPURE FREE STORAGE (LIST) $ST IFX,FX ;IMPURE FIXNUMS $ST IFL,FL ;IMPURE FLONUMS IFN BIGNUM, $ST BN,BN ;BIGNUMS $ST XXB,$XM ;SLACK SEGMENTS (IMPURE!) IFE LOBITSG, $ST BIT,$XM ;BIT BLOCKS $ST BPS,$XM ;BINARY PROGRAM SPACE $ST NXM,$NXM ;(INITIALLY) NON-EXISTENT MEMORY $ST FXP,FX+$PDLNM ;FIXNUM PDL $ST XFXP,$NXM ;FOR FXP EXPANSION $ST FLP,FL+$PDLNM ;FLONUM PDL $ST XFLP,$NXM ;FOR FLP EXPANSION $ST P,$XM ;REGULAR PDL $ST XP,$NXM ;FOR P EXPANSION $ST SP,$XM ;SPECIAL PDL $ST XSP,$NXM ;FOR SP EXPANSION $ST SCR,$NXM ;SCRATCH SEGMENTS .HKILL ST.ZER IFN ST+NSEGS-., WARN \.-ST,[=WRONG SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)] ] ;END IF2 ] ;END IFN PAGING ;;; THE FORMAT OF THE GARBAGE COLLECTOR SEGMENT TABLE IS RATHER HAIRY, SINCE ;;; THE SIZES AND POSITIONS OF ALL FIELDS IN EACH WORD ARE DEPENDENT ON THE ;;; SEGMENT SIZE. THE LOW ORDER <22-> BITS OF EACH ENTRY CONTAIN ;;; THE HIGH BITS OF THE ADDRESS OF THE BLOCK OF BITS TO BE USED IN MARKING ;;; THAT SEGMENT. (NOTE THAT THE OMITTED LOW-ORDER BITS OF THIS ADDRESS ARE ;;; ZERO ANYWAY.) THESE ADR BITS ARE IN THIS STRANGE RIGHT-ADJUSTED POSITION ;;; FOR THE CONVENIENCE OF THE GCMARK ROUTINE (Q.V.). NOT ALL SEGMENTS HAVE ;;; BIT BLOCKS; THOSE WHICH DO NOT HAVE A BIT BLOCK HAVE ZERO IN THIS FIELD. ;;; TO THE LEFT OF THIS BIT BLOCK ADDRESS FIELD IS A FIELD OF <22-SEGLOG> BITS; ;;; THIS CONTAINS THE NUMBER OF THE NEXT SEGMENT IN THE TABLE OF THE SAME TYPE. ;;; (NOT ALL SEGMENTS ARE LINKED IN THIS WAY; THOSE SEGMENTS WHICH ARE NOT ;;; LINKED TO ANOTHER ONE HAVE THIS FIELD ZERO.) THE HIGH-ORDER BIT (BIT 4.9) ;;; IS ONE IFF GCMARK SHOULD MARK (PERHAPS NOT WITH A BIT BLOCK) THE CONTENTS ;;; OF THE SEGMENT. THE BIT 22 BIT POSITIONS TO THE LEFT OF THE HIGH-ORDER ;;; BIT OF THE BIT BLOCK ADDRESS FIELD IS ONE IFF GCMARK SHOULD MARK FROM THE ;;; CDR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY IF BIT 4.9 ;;; IS ONE. THE BIT TO THE RIGHT OF THE CDR BIT IS ONE IFF GCMARK SHOULD ALSO ;;; MARK FROM THE CAR OF AN OBJECT IN THE SEGMENT; THIS BIT IS MEANINGFUL ONLY ;;; IF THE CDR BIT IS ONE. THESE THREE BITS MUST BE IN THESE EXACT POSITIONS, ;;; AGAIN FOR THE CONVENIENCE OF GCMARK (Q.V.). THE OTHER BITS IN EACH WORD ;;; ARE ARRANGED AS TO USE UP FREE BITS FROM THE LEFT END OF THE WORD, PACKED ;;; IN AROUND THE THREE BITS ALREADY DESCRIBED. THESE BITS INDICATE WHETHER ;;; OR NOT THE SEGMENT CONTAINS VALUE CELLS, SYMBOLS, OR SARS. GCBMRK==400000 ;THESE ARE ALL LEFT HALF FLAGS GCBCDR==1_<22--1> GCBCAR==GCBCDR_-1 GCB==1,,525252 ;FOR BIT TYPEOUT MODE ZZZ==400000 GCBFOO==0 IRPS NAM,X,[VC+SYM+SAR+HNK ] ZZZ==ZZZ_-1 IFN ZZZ&GCBCDR, ZZZ==ZZZ_-2 GCB!NAM==ZZZ IFSE X,+, GCBFOO==GCBFOO\ZZZ TERMIN IFG GCBHNK-GCBCAR, WARN [GCMARK WILL LOSE ON HUNKS] GCST: ;GC SEGMENT TABLE IFE PAGING, BLOCK NSEGS ;FOR PAGING SYSTEM, ; THE GCST TABLE IS SET UP AT RUN TIME BY INIT. IFN PAGING,[ IF1, BLOCK NSEGS IF2,[ BTB.==BTBLKS ;LOCATION COUNTER FOR ASSIGNING BIT BLOCKS $GCST ZER,,,0 IFN LOBITSG, $GCST BIT,,,0 $GCST ST,,,0 $GCST SYS,,,0 $GCST SAR,L,,GCBMRK+GCBSAR $GCST VC,,,GCBMRK+GCBVC $GCST XVC,,,0 $GCST IS2,L,,0 $GCST SYM,L,,GCBMRK+GCBSYM $GCST XXA,L,,0 $GCST XXZ,,,0 $GCST SY2,,,0 $GCST PFX,,,0 $GCST PFS,,,0 $GCST PFL,,,0 $GCST XXP,,,0 $GCST IFS,L,B,GCBMRK+GCBCDR+GCBCAR $GCST IFX,L,B,GCBMRK $GCST IFL,L,B,GCBMRK IFN BIGNUM, $GCST BN,L,B,GCBMRK+GCBCDR LXXBSG==LXXASG $GCST1 NXXBSG,XXB,L,,0 IFE LOBITSG, $GCST BIT,,,0 $GCST BPS,,,0 $GCST NXM,,,0 $GCST FXP,,,0 $GCST XFXP,,,0 $GCST FLP,,,0 $GCST XFLP,,,0 $GCST P,,,0 $GCST XP,,,0 $GCST SP,,,0 $GCST XSP,,,0 $GCST SCR,,,0 .HKILL GS.ZER IFN GCST+NSEGS-., WARN \.-GCST,[=WRONG GC SEGMENT TABLE LENGTH (SHOULD BE ]\NSEGS,[)] ] ;END IF2 ] ;END OF IFN PAGING PAGEUP SPCTOP ST,,[SEGMENT TABLE] IFN PAGING, SPCBOT SYS 10$ $HISEG 10$ HILOC==. ;ORIGIN OF HIGH SEGMENT SA$ PSGNAM: 0 ;THESE LOCATIONS FOR SAIL HISEG VALIDATION SA$ PSGDEV: 0 SA$ PSGEXT: 0 SA$ PSGPPN: 0 SUBTTL BEGINNING OF PURE LISP SYSTEM CODE PGBOT ERR ;;; THESE CONSTANTS ARE BUILT INTO THE COMPILER. ;;; THEY MUST BE DEFINED HERE FOR THE BENEFIT OF THE PUSHN MACRO. .SEE PUSHN NNPUSH==:20 .SEE NPUSH N0PUSH==:10 .SEE 0PUSH N0.0PUSH==:10 .SEE 0.0PUSH BPURPG==:. ;BEGINNING OF PURE PAGES FOR INSERT FILE PAGE AND PURIFY $$$NIL: 777300,,VNIL ;SYMBOL BLOCK FOR NIL 0,,$$NIL ;ALWAYS KEEP ON FIRST PURE SYSTEM PAGE ;;@ ERROR 137 ERROR MSGS AND HANDLERS ;;; ***** MACLISP ****** MACLISP ERROR HANDLERS, AND MSGS ******** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1979 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 A,(AR1) PUSHJ P,NCONS MOVEI B,QMSGFILES PUSHJ P,XCONS MOVEI AR1,QTLIST MOVEM AR1,VMSGFILES PUSHJ P,[IOL [BAD VALUE FOR MSGFILES!]] 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 PUSHJ P,NCONS MOVEI B,QERRLIST PUSHJ P,XCONS PUSH P,CLSPRET FAC [POSSIBLY FELONIOUS ERRLIST - PLEASE INSPECT BEFORE PROCEEDING!] SUBTTL ERINT, SERING, 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 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 UUONVE: PUSHJ P,NCONS MOVEI B,QNUMBERP PUSHJ P,XCONS FAC [NUMBER FUNCTION RETURNED NON-NUMERIC VALUE!] JRST UUONVL NTHIEN: WTA [ILLEGAL ELEMENT NUMBER - NTH/NTHCDR!] JRST NTHCD5 NTHER: WTA [NOT A PROPER LIST - NTH/NTHCDR!] JRST NTHCD2 LASTER: WTA [ATOMIC ARG TO LAST!] JRST LAST UUOMER: HRRZ A,40 LER3 [SIXBIT \ - MACRO NOT PERMITTED IN UUO CALL!\] UUOFER: HRRZ A,40 LER3 [SIXBIT \ - WRONG NUMBER OF ARGS SUPPLIED BY 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!\] ER2: LERR MES3 ;CONTEXT ERROR WITH DOT NOTATION -READ ER3: LERR [SIXBIT \BLAST? - READ!\] ER4: LERR [SIXBIT \GO OUT OF CATCH-BREAK DAMN#!!\] RDNMER: LERR [SIXBIT \NUMERIC OVERFLOW - READ!\] RDSME2: LERR [ SIXBIT /MULTIPLE SPLICING MACROS RETURNED NON-NIL AFTER "." -- READ!/] RDSME1: POP FXP,T RDSMER: LERR [SIXBIT /ILLEGAL RETURN VALUE FROM SPLICING MACRO -- READ!/] 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: PUSH P,A ;INTERN CRAP-OUT MOVEI A,OBARRAY EXCH A,VOBARRAY UNLOCKI PUSHJ P,BADOB POP P,A JRST INTRN4 BADOB: FAC [BAD VALUE FOR OBARRAY!] 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 [NOT A PROPER LIST - REVERSE/NREVERSE/NRECONC/APPEND/NCONC!] JRST REV4 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 \DIDN'T EVAL TO GOOD 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 A,IN10 EXCH A,VIBASE PUSHJ P,NCONS MOVEI B,QIBASE PUSHJ P,XCONS PUSH P,[RD0B1] FAC [BAD VALUE FOR IBASE!] BASER: MOVEI A,IN10 EXCH A,VBASE PUSHJ P,NCONS MOVEI B,QBASE PUSHJ P,XCONS PUSH P,[PRINI] FAC [BAD VALUE FOR BASE!] IFN USELESS,[ %LVERR: SETZ A, EXCH A,V%LEVEL PUSHJ P,NCONS MOVEI B,Q%LEVEL PUSHJ P,XCONS PUSH P,[%LVCHK] FAC [BAD VALUE FOR PRINLEVEL!] %LNERR: SETZ A, EXCH A,V%LENGTH PUSHJ P,NCONS MOVEI B,Q%LENGTH PUSHJ P,XCONS PUSH P,[%LNCHK] FAC [BAD VALUE FOR PRINLENGTH!] ] ;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 \PURITAS NECESSE EST - DON'T DO RANDOM BINDINGS!\ 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 >!\ MES2: SIXBIT \ILLEGAL OBJECT SOMEWHERE OR OTHER - READ!\ MES3: SIXBIT \DOT CONTEXT ERROR!\ MES5: SIXBIT \UNDEFINED FUNCTION OBJECT!\ MES6: SIXBIT \UNBOUND VARIABLE!\ MES14: SIXBIT \NOT INSIDE LEXPR/LSUBR!\ MES18: SIXBIT \TOO MANY ARGUMENTS SUPPLIED - APPLY!\ MES19: SIXBIT \TOO FEW ARGUMENTS SUPPLIED - APPLY!\ MES20: SIXBIT \WRONG NUMBER OF ARGS TO LSUBR!\ MES21: SIXBIT \WRONG NUMBER OF ARGS TO FSUBR!\ EMS1: SIXBIT \EXTRA CHARS IN LIST - READLIST!\ EMS3: SIXBIT \NOT ENOUGH CHARS IN LIST - READLIST!\ EMS5: SIXBIT \READ-MACRO CONTEXT ERROR!\ EMS6: SIXBIT \BLAST, MISSING ")"!\ EMS10: SIXBIT \GOT TO TTY INSIDE S-EXP - READ!\ ; 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!\ 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 SPECIFICATION!] 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 JUMPN D,WNAER1 ; D ^= 0 => LISTING ALREADY DONE 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: SAVE A B MOVEI T,EMS18 JRST UUOUE1 UUOH3A: SAVE 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 \YOU HAVE RUN OUT OF CORE - 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 [BAD LIST - GETL!] 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 [UNRECOGNIZABLE 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,NCONS ;NOT INSIDE LSUBR MOVEI B,QLISTIFY PUSHJ P,XCONS ;LET LOSER FIGURE IT OUT %FAC MES14 GENSY8: %WTA EMS31 PUSH P,A JRST GENSY7 ARGCM8: WTA [ARG TOO LARGE OR <1 - 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,NCONS MOVEI B,QM PUSHJ P,XCONS 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 GTRDT9: FAC [BAD VALUE FOR READTABLE!] EOFE: MOVEI A,(AR1) PUSHJ P,NCONS MOVEI B,QRDEOF PUSHJ P,XCONS PUSHJ P,EOFE1 JUMPE A,EOF5 SKIPE T,EOFRTN ;CLOBBER IN EOF VALUE IF NON-NIL HRRM A,-LERSTP-1(T) ; AND IF EOF FRAME EXISTS JRST EOF5 EOFE1: FAC [END OF FILE WITHIN READ!] 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 [NOT A PROPER LIST - MEMBER/DELETE/ASSOC!] MOVE B,A EXCH A,(P) JRST (T) DLTER: CAIE D,MEMBER SKIPA D,[QDELQ] MOVEI D,QDELETE JRST WNALOSE LIST.9: MOVEI D,QLIST. ;ZERO ARGS => ERROR SOJA D,WNALOSE SUSPE: PUSHJ P,NCONS MOVEI B,QSUSPEND PUSHJ P,XCONS 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 [NOT VALID READTABLE INDEX!] EXCH A,B JRST GRCTI FRERR: WTA [NOT A FRAME POINTER - FRETURN!] JRST FRETURN IFN USELESS,[ CRSRP2: WTA [BAD CURSOR CODE - CURSORPOS!] 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 WNAYOSE) 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] 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 ;;@ END OF ERROR 137 ;;; ERROR FILE HAS DEFINITION FOR BEGFUN PGTOP ERR,[ERROR HANDLERS AND MESSAGES] PGBOT TOP ;;; LISPGO HAS BEEN MOVED SO IT WILL STAY IN CORE WHEN PURE PAGES ARE FLUSHED ;;; AT SUSPEND TIME AS CONTROLLED BY THE SUSFLS FLAG. SUBTTL BASIC TOP LEVEL LOOP ;;; (DEFUN STANDARD-TOP-LEVEL () ;;; (PROG (^Q ^W ^R EVALHOOK BASE IBASE ...) ;;; ERROR ;ERRORS, UNCAUGHT THROWS, ETC. COME HERE ;;; ^G ;^G QUITS COME HERE ;;; (RESET-BOUND-VARIABLES-AND-RESTORE-PDLS) ;;; (SETQ ^Q NIL) ;;; (SETQ ^W NIL) ;;; (SETQ EVALHOOK NIL) ;;; (NOINTERRUPT NIL) ;;; (DO-DELAYED-TTY-AND-ALARMCLOCK-INTERRUPTS) ;;; ;RECALL THAT ERRORS DO (SETQ // ERRLIST) ;;; (MAPC (FUNCTION EVAL) //) ;;; (OR (TOP-LEVEL-LINMODE) (TERPRI)) ;;; (DO ((PRT '* *)) ;;; (NIL) ;DO FOREVER (UNTIL ERROR OR ^G QUIT) ;;; (SETQ * (COND ((STATUS TOPLEVEL) ;;; (EVAL (STATUS TOPLEVEL))) ;;; ((PROG () ;;; (READ-EVAL-*-PRINT PRT) ;print ;;; (READ-EVAL-PRINT-*) ;terpri ;;; A (SETQ TEM (*-READ-EVAL-PRINT)) ;read ;;; (AND (EQ TEM ) ;;; (PROG2 (TERPRI) (GO A))) ;;; (RETURN (READ-*-EVAL-PRINT TEM)))))) ;eval ;;; ))) LSPRET: PUSHJ FXP,ERRPOP MOVE P,C2 ;RETURN TO TOP LEVEL BY ERR, THROW, AND ERRORS LSPRT1: JSP T,TLVRSS ;RETURN TO TOP BY ^G JSP A,ERINIT SETZ A, ;NEED A NIL IN A FOR CHECKU PUSHJ P,CHECKU ;CHECK FOR DELAYED "REAL TIME" INTS MOVEI A,QOEVAL SKIPE B,VIQUOTIENT ;SHADES OF ERRLIST!!! CALLF 2,QMAPC HACENT: PUSH P,FLP .SEE PDLCHK PUSH P,FXP PUSH P,SP PUSH P,LISP1 ;ENTRY FROM LIHAC HRRZ F,VINFILE ;ONLY PRINT FIRST ASTERISK IF NO INIT FILE AOSN TOPAST ;IS THIS THE FIRST TIME? CAIE F,INIIFA SKIPA ;NOT (INIT-FILE AND FIRST-TIME) JRST LISP2B PUSH P,[Q.] JSP F,LINMDP PUSHJ P,ITERPRI JRST LISP2 ;KLUDGE SO AS NOT TO MUNG * LISP1: PUSH P,LISP1 ;******* BASIC TOP LEVEL LOOP ******* HRRZM A,V. ;THE SYMBOL * GETS AS ITS VALUE THE PUSH P,A LISP2: JSP T,TLVRSS ; RESULT OF THE LAST TOP-LEVEL EVAL POP P,B SKIPN A,TLF JRST LISP2A HRRZ TT,-3(P) HRRZ D,-2(P) HRRZ R,-1(P) PUSHJ P,PDLCHK ;CHECK PDL LEVELS FOR ERRORS JRST EVAL LISP2A: MOVEI A,(B) PUSHJ P,TLPRINT ;PRINT THE LAST OUTPUT FORM HRRZ TT,-3(P) HRRZ D,-2(P) HRRZ R,-1(P) PUSHJ P,PDLCHK ;CHECK PDL LEVELS FOR ERRORS PUSHJ P,TLTERPRI ;OUTPUT A TERPRI LISP2B: PUSHJ P,TLREAD ;READ AN INPUT FORM JRST TLEVAL ;EVALUATE IT, RETURNING TO LISP1 IF NO EOF SETZ AR1, PUSHJ P,TERP1 JRST LISP2B ; LOOP BACK AFTER EOF-PROCESSED EXIT ;;; (DEFUN STANDARD-IFILE () ;;; (COND ((OR (NULL ^Q) (EQ INFILE 'T)) TYI) ;;; ('T INFILE))) STDIFL: HRRZ A,VINFILE SKIPE TAPRED CAIN A,TRUTH HRRZ A,V%TYI POPJ P, ;;; (DEFUN READ-EVAL-PRINT-* () ;TOP-LEVEL-TERPRI ;;; (AND READ-EVAL-PRINT-* ;;; (FUNCALL READ-EVAL-PRINT-*)) ;;; ((LAMBDA (IFILE) ;;; (AND (TTYP IFILE) ;;; (TOP-LEVEL-TERPRI-X (STATUS LINMODE IFILE) ;;; (STATUS TTYCONS IFILE)))) ;;; (STANDARD-IFILE))) ;;; ;;; (DEFUN TOP-LEVEL-TERPRI-X (LM OFILE) ;;; (AND OFILE ;;; (COND ((EQ OFILE TYO) ;;; (TERPRI (CONS T (AND ^R OUTFILES)))) ;;; (T (OR LM ^W (TERPRI OFILE)))))) TLTERPRI: SKIPE B,VTLTERPRI ;CHECK FOR USER'S INTERCEPT FUNCTION CALLF 0,(B) PUSHJ P,STDIFL ;GET STANDARD INPUT FILE MOVE F,TTSAR(A) TLNN F,TTS.TY POPJ P, MOVEI TT,FT.CNS MOVE AR1,@TTSAR(A) MOVEI TT,F.MODE MOVE F,@TTSAR(A) ;TOP-LEVEL-TERPRI-X; TTYCONS IN AR1, F.MODE IN F TLTERX: JUMPE AR1,CPOPJ ;EXIT IF NO TTYCONS FILE CAME AR1,V%TYO JRST TLTER1 SKIPE AR1,TAPWRT ;IF SAME AS TYO, TERPRI TO HRRZ AR1,VOUTFILES ; STANDARD OUTPUT FILES JRST TERP1 TLTER1: TLNN F,FBT.LN ;IF INPUT FILE NOT IN LINMODE, SKIPE TTYOFF ; AND ^W IS NOT SET, POPJ P, ; TERPRI TO JUST THE TTYCONS FILE TLO AR1,-1 JRST TERP1 ;;; (DEFUN *-READ-EVAL-PRINT () ;TOP-LEVEL-READ ;;; (AND *-READ-EVAL-PRINT ;;; (FUNCALL *-READ-EVAL-PRINT)) ;;; (DO ((EOF (LIST 'TLRED1)) (IFILE) (FORM)) ;;; (NIL) ;DO UNTIL RETURN ;;; (SETQ IFILE (STANDARD-IFILE IFILE)) ;;; (SETQ FORM (COND (READ (FUNCALL READ EOF)) ;;; ('T (READ EOF)))) ;;; (COND ((NOT (EQ FORM EOF)) ;;; (AND (NULL READ) ;;; (ATOM FORM) ;;; (IS-A-SPACE (TYIPEEK)) ;;; (TYI)) ;;; (RETURN FORM))) ;;; (COND ((TTYP IFILE) ;;; (TOP-LEVEL-TERPRI-X () (STATUS TTYCONS IFILE))) ;;; ('T (RETURN ))))) $TLREAD: PUSHJ P,TLREAD POPJ P, SETZ AR1, PUSHJ P,TERP1 JRST $TLREAD TLREAD: SKIPE B,V$TLREAD ;CHECK FOR USER'S INTERCEPT FUNCTION, CALLF 0,(B) ; AND RUN IT. PUSHJ P,STDIFL ;GET STANDARD INPUT FILE AS OF PUSH P,A ; *BEFORE* THE READ, AND SAVE IT MOVEI T,TLRED1 PUSH P,T ;RETURN ADDR FOR READ PUSH P,T ;argument FOR RANDOM EOF VALUE MOVNI T,1 JRST IREAD1 ;READ THE FORM (POSSIBLY USING USER'S READ) ; AND POSSIBLY POPPING INSTACK INTO INFILE TLRED1: POP P,B CAIE A,TLRED1 POPJ P, MOVE TT,TTSAR(B) TLNN TT,TTS.TY JRST POPJ1 ;SKIP-EXIT, IF NON-TTY EOF TLRED2: HRRI TT,FT.CNS MOVE AR1,@TTSAR(B) SETZ F, ;EOF ON TTY MEANS OVER-RUBOUT, SO PUSHJ P,TLTERX ; TERPRI ON ASSOCIATED OUTPUT TTY JRST TLREAD ; AND TRY AGAIN ;;; (DEFUN READ-*-EVAL-PRINT (FORM) ;TOP-LEVEL-EVAL ;;; (AND READ-*-EVAL-PRINT ;;; (FUNCALL READ-*-EVAL-PRINT FORM)) ;;; (SETQ - FORM) ;;; ((LAMBDA (+) ;;; (PROG2 NIL ;;; (EVAL +) ;;; (AND (OR (CAR NIL) (CDR NIL)) ;;; (ERROR '|NIL CLOBBERED| ;;; (PROG2 NIL ;;; (CONS (CAR NIL) (CDR NIL)) ;;; (RPLACA NIL NIL) ;;; (RPLACD NIL NIL)) ;;; 'FAIL-ACT)))) ;;; (PROG2 NIL + (SETQ + (COND ((EQ - '+) +) ('T -)))))) TLEVAL: SKIPE B,VTLEVAL ;CHECK FOR USER'S INTERCEPT FUNCTION CALLF 1,(B) MOVEM A,VIDIFFERENCE ;THE SYMBOL - GETS THE TYPED-IN CAIN A,QIPLUS SKIPA B,VIPLUS MOVEI B,(A) ; EXPRESSION AS ITS VALUE AND KEEPS IT EXCH B,VIPLUS ;THE SYMBOL + GETS THE THE TYPED-IN JSP T,SPECBIND ; EXPRESSION AS ITS VALUE, BUT NOT 0 B,VIPLUS ; UNTIL AFTER IT HAS BEEN EVALUATED. CEVAL: PUSHJ P,EVAL ;SPECBINDING IT ENSURES THAT IT WILL JUMPE UNBIND ; GET THIS VALUE IN SPITE OF ERRORS. PUSH P,CUNBIND NILBAD: PUSH P,A ;FOO! WELL, ERROR HANDLING SAVES PUSH P,CPOPAJ ;ALL ACS IN CASE YOU WANT TO CONTINUE MOVS A,NIL CSETZ: SETZ NIL, ;NIL=0! CAN USE THIS AS A CONSTANT WORD PUSHJ P,ACONS %FAC [SIXBIT \NIL CLOBBERED!\] ;;; PUSHJ HERE WITH PROPER VALUES FOR THE RIGHT HALVES ;;; OF IN . WILL ERROR OUT ;;; IF THEY DON'T MATCH UP. USED FOR TRAPPING GROSS ;;; ERRORS IN THE SYSTEM. PDLCHK: SETZ T, CAIE TT,(FLP) MOVEI T,QFLPDL CAIE D,(FXP) MOVEI T,QFXPDL CAIE R,(SP) MOVEI T,QSPECPDL JUMPE T,CPOPJ ;EVERYBODY HAPPY? PDLCRP: MOVEI A,(T) ;NO, PDL CRAP-OUT LER3 [SIXBIT \OUT OF PHASE (SYSTEM ERROR)!\] ;;; (DEFUN TOP-LEVEL-LINMODE () ;;; ((LAMBDA (FL) ;;; (COND ((AND (TTYP FL) (STATUS LINMODE FL)) ;;; FL))) ;;; (STANDARD-IFILE INFILE))) ;;; SKIP IF INPUT FILE (PASSED IN ACC B) IS IN LINE MODE. ;;; ALSO LEAVE OUTFILES IN AR1 AND READTABLE IN AR2A. ;;; FURTHERMORE LEAVE INPUT FILE IN C (SEE TLPRINT). ;;; ALSO LEAVE TTSAR OF INPUT FILE IN T. LINMDP: JSP T,GTRDTB HRRZ C,VINFILE SKIPE TAPRED CAIN C,TRUTH HRRZ C,V%TYI SKIPE AR1,TAPWRT HRRZ AR1,VOUTFILES SFA$ HRLZI TT,AS.SFA ;SFAS ARE NEVER IN LINE MODE SFA$ TDNE TT,ASAR(C) SFA$ JRST (F) ;RETURN NON-LINEMODE XCTPRO MOVE T,TTSAR(C) MOVE TT,F.MODE(T) NOPRO TLNE T,TTS.TY TLNN TT,FBT.LN ;ONLY A TTY CAN HAVE LINMODE SET JRST (F) ;TYPICALLY RETURN TO AN ITERPRI JRST 1(F) ; OR SKIP OVER IT ;;; (DEFUN READ-EVAL-*-PRINT (OBJ) ;TOP-LEVEL-PRINT ;;; (AND READ-EVAL-*-PRINT ;;; (FUNCALL READ-EVAL-*-PRINT OBJ)) ;;; ((LAMBDA (FL) ;;; (COND ((OR (NULL FL) (NOT (EQ (STATUS TTYCONS FL) TYO))) ;;; (TERPRI IFILE))) ;;; (COND (PRIN1 (FUNCALL PRIN1 OBJ)) ('T (PRIN1 OBJ))) ;;; (TYO 32.)) ; ;;; (TOP-LEVEL-LINMODE))) TLPRINT: SKIPE C,VTLPRINT ;CHECK FOR USER'S INTERCEPT FUNCTION CALLF 1,(C) PUSH P,A ;TOP-LEVEL PRINT JSP F,LINMDP ;LEAVES INPUT FILE IN C JRST TLPR1 MOVE T,TTSAR(C) ;PICK UP THE TTSAR MOVEI TT,FT.CNS HRRZ C,@T ;PICK UP FT.CNS TLNE T,TTS.TY CAME C,V%TYO TLPR1: PUSHJ P,ITERPRI MOVE A,(P) PUSHJ P,IPRIN1 MOVEI A,40 PUSHJ P,TYO JRST POPAJ IPRIN1: SKIPN V%PR1 JRST PRIN1 JCALLF 1,@V%PR1 ;;; TOP LEVEL VARIABLE SETTINGS TLVRSS: MOVE A,[PNBUF,,PNBUF+1] SETZM PNBUF BLT A,PNBUF+LPNBUF-1 TLVRS1: PUSH P,EOFRTN MOVE A,[ERRTN,,ERRTN+1] SETZM ERRTN BLT A,ERRTN+LEP1-1 SETOM ERRSW POP P,EOFRTN SETZB NIL,PANICP SETZB A,PSYMF SETZB B,EXPL5 SETZB C,PA3 SETZB AR1,RDLARG SETZB AR2A,QF1SB SETZM ARGLOC SETZM ARGNUM JRST (T) IFN D10,[ SIXJBN: PJOB TT, IDIVI TT,100. IDIVI D,10. LSH TT,14 LSH D,6 ADDI TT,(D) ADDI TT,202020(R) HRLI TT,(SIXBIT /LSP/) MOVSM TT,D10NAM ;SAVE ###LSP AS TEMP FILE NAME POPJ P, ] ;END OF IFN D10 SUBTTL INITIALIZATION ON ^G QUIT AND ERRORS ;;; ERINIT RESETS PDL POINTERS, THEN FALLS INTO ERINI0. ;;; ERINI0 RESETS VARIOUS VARIABLES AND PERFORMS CLEANUP. ERINIT: ;DISABLE INTERRUPT SYSTEM 10$ SA% MOVE P,C2 10$ SA% MOVE FXP,FXC2 PIPAUSE ;DISABLE ALL INTERRUPTS ERINIX: ;ENTER HERE IF INTERRUPTS ALREADY DISABLED IFE PAGING,[ MOVE P,C2 ;SET UP PDL POINTERS MOVE FXP,FXC2 MOVE FLP,FLC2 MOVE SP,SC2 ] ;END OF IFE PAGING IFN PAGING,[ IT$ MOVE T,PDLFL1 ;CONTAINS <- # OF PDL PAGES,,# OF 1ST PDL PAGE> IT$ .CALL PDLFLS ;FLUSH ALL PDL PAGES IT$ .VALUE 20$ WARN [SHOULD TWENEX FLUSH PDL PAGES??] MOVE T,[$NXM,,QRANDOM] MOVE TT,PDLFL2 ;CONTAINS <- # OF PDL SEGS,,# OF 1ST PDL SEG> MOVEM T,ST(TT) ;UPDATE SEGMENT TABLE TO REFLECT AOBJN TT,.-1 ; LOSS OF PDL PAGES HRRZ T,PDLFL1 ROT T,-4 ADDI T,(T) ROT T,-1 TLC T,770000 ADD T,[450200,,PURTBL] SETZ D, HLRE TT,PDLFL1 ERINI8: TLNN T,730000 TLZ T,770000 IDPB D,T AOJL TT,ERINI8 IRP Z,,[P,FLP,FXP,SP] MOVEI F,Z MOVE Z,C2-P+Z ;CAUSE ONE PDL PAGE MOVEI D,1(Z) ; FOR Z TO EXIST ANDI D,PAGMSK JSR PDLSTH .SEE PDLST0 TERMIN ERIN8G: MOVE T,[XPDL,,ZPDL] BLT T,ZSPDL ] ;END OF IFN PAGING ERINI0: SETZB NIL,TAPRED ;INITIALIZATION AFTER PDL SETUP SETZM NOQUIT SETZM REALLY SETZM FASLP IFN USELESS, SETZM TYOSW SETZM INTFLG SETZM INTAR SETZM VEVALHOOK SETZM GCFXP ;NON-ZERO WOULD MEAN INSIDE GC SETZM BFPRDP MOVE T,[-LINTPDL,,INTPDL] MOVEM T,INTPDL MOVEI T,$DEVICE ;RESTORE READER'S LITTLE MEN MOVEM T,TYIMAN MOVEI T,UNTYI MOVEM T,UNTYIMAN ;FALLS THROUGH ;FALLS IN ERINI2: SKIPL MUNGP ;MAYBE NEED TO UNMUNG SYMBOLS AND SARS JRST ERINI6 MOVE D,SYSGLK ERINI5: JUMPE D,ERIN5A MOVEI F,(D) LSH F,SEGLOG HRLI F,-SEGSIZ LDB D,[SEGBYT,,GCST(D)] ERIN5C: MOVSI R,1 ANDCAB R,(F) ;UNMUNGS THE SYMBOL HEADER, IF NECESSARY HLRZS R HRRZ R,(R) ;GET ADDR OF VALUE CELL CAIL R,BVCSG CAIL R,BVCSG+*SEGSIZ JRST .+2 JRST ERIN5D CAIL R,BPURFS CAIL R,PFSLAST JRST .+2 JRST ERIN5D HRRZS (R) ;UNMUNGS THE VALUE CELL, IF STORED IN LIST SPACE ERIN5D: AOBJN F,ERIN5C JRST ERINI5 ERIN5A: MOVE F,[SARTOB,,B] BLT F,LPROGZ MOVE D,SASGLK ERIN5B: JUMPE D,ERINI6 MOVEI F,(D) LSH F,SEGLOG HRLI F,-SEGSIZ/2 LDB D,[SEGBYT,,GCST(D)] JRST SATOB1 ERINI6: HRRZS MUNGP SKIPN MUNGP ;UNMUNG VALUE CELLS (SEE ALIST) JRST ERIN6A MOVEI F,BVCSG SUB F,EFVCS HRLI F,(F) HRRI F,BVCSG HRRZS (F) AOBJN F,.-1 SETZM MUNGP ERIN6A: MOVE B,[ERRTN,,ERRTN+1] SETZM ERRTN BLT B,UIRTN SETOM ERRSW MOVSI B,-NSFC ERINI3: MOVE C,SFXTBI(B) ;RESTORE CLOBBERED LOCATIONS MOVEM C,@SFXTBL(B) AOBJN B,ERINI3 TLZ A,-1 ;ENABLE THE INTERRUPT SYSTEM IFN ITS,[ .SUSET [.SMASK,,IMASK] ;RESTORE INTERRUPT ENABLE MASKS .SUSET [.SMSK2,,IMASK2] .SUSET [.SDF1,,R70] ;RESET DEFER WORDS .SUSET [.SDF2,,R70] ] ;END OF IFN ITS PIONAGAIN JRST (A) ;RETURN TO CALLER SARTOB: ;TURN OFF MARK BITS IN SARS OFFSET B-. SATOB1: ANDCAM SATOB7,TTSAR(F) AOBJP F,ERIN5B AOJA F,SATOB1 SATOB7: TTS,, LPROGZ==.-1 OFFSET 0 .HKILL SATOB1 SATOB7 PDLFLS: SETZ SIXBIT \CORBLK\ 1000,,0 ;DELETE PAGES... 1000,,-1 ; FROM MYSELF... SETZ T ; AND HERE'S HOW MANY AND WHERE! SUBTTL SPECIAL VARIABLE BINDING AND UNBINDING ROUTINES JFCL ;HISTORICAL LOSS -- EVENTUALLY FLUSH SPECBIND: MOVEM SP,SPSV ;0 0,FOO MEANS FOO IS ADDR OF SVC TO BE BOUND TO NIL, SAVES D SPEC1: LDB R,[271500,,(T)] ;0 N,FOO MEANS SVC FOO TO BE BOUND TO CONTENTS OF ACC N JUMPE R,SPEC4 CAILE R,17 ;7_41 M,FOO MEANS BIND FOO TO -M(P) JRST SPEC3 ;OTHERWISE, IS PDP10 INSTRUCTION, SO EXIT SPEC2: HRRZ R,(R) ;NOTE WELL! NCOMPLR DEPENDS ON THE FACT CAML R,NPDLL ; THAT R = TT+2 = NUMVALAC+2 CAMLE R,NPDLH JRST SPEC4 PUSH FXP,T MOVEI T,(R) LSH T,-SEGLOG SKIPL T,ST(T) ;NMK1 WILL WANT TYPE BITS IN T TLNN T,$PDLNM ;SKIP IF PDL NUMBER JRST SPEC5 HRR T,(FXP) LDB R,[271500,,(T)] ;RECOMPUTE ADDRESS OF FROB CAIG R,17 JRST SPEC6 TRC R,16000#-1 ADDI R,1(P) SPEC6: PUSHJ P,ABIND3 ;TEMPORARILY CLOSE THE BIND BLOCK PUSH P,A HRRZ A,(R) PUSHJ P,NMK1 MOVEM A,(R) ;CLOBBER LOC OF FROB WITH NEW NUMBER CAIN R,A ;GRUMBLE MOVEM A,(P) SUB SP,R70+1 ;SO RE-OPEN THE BIND-BLOCK MOVEI R,(A) ;THEREBY INHIBITING INTERRUPTS POP P,A SPEC5: POP FXP,T SPEC4: BNDTRAP WIOSPC,T, EXCH R,@(T) SPEC4A: HRL R,(T) PUSH SP,R AOJA T,SPEC1 SPEC3: CAIGE R,16000 JRST SPECX TRC R,16000#-1 ;RH OF R NOW HAS N ADDI R,1(P) ;SPECBINDING OFF PDL JRST SPEC2 ERRPOP: POP FXP,ERRPAD ;POP RETURN ADR OFF FXP MOVE TT,C2 ;RUN ALL OF THE UNWIND HANDLERS MOVEM T,ERRPST ;SAVE T PUSHJ FXP,UNWPRO MOVE T,ERRPST ;RESTORE SAVED T PUSH P,ERRPAD ;SAVE ERR RETURN ADR ;ENTRY POINT IF NO UNWIND-PROTECT FUNCTIONS SHOULD BE RUN ERRPNU: SKIPA TT,ZSC2 ;TOTALLY POP OFF SPECPDL FOR ERRORS UBD0: TLZA TT,-1 ;POP SPECPDL TO PLACE SPECIFIED IN TT SETOM (TT) ;ERRPOP MUST SETOM - SEE UBD4 UBD: CAIL TT,(SP) ;RESTORE THE SPDL BY RESTORING VALUES JRST UNBND2 ; UNTIL (SP) MATCHES (TT) POP SP,R HLRZ D,R TLZ R,-1 CAMGE R,ZSC2 JRST UBD3 CAIG R,(SP) JRST UBD4 SKIPN D .LOSE ;Somebody screwed the SPECPDL - HELP!!! UBD3: BNDTRAP UBDP,D, HRRZM R,(D) UBD1: JRST UBD UBDP: PUSH FXP,T ;Figure out if WITHOUT-INTERRUPTS HRRZI T,(D) CAIN D,PWIOINT ;WITHOUT-INTERRUPTS, handle specially JRST UBDWIO POP FXP,T ;Restore state HRRZM R,(D) ;Recause error, will trap this time JRST UBD ;Continue if continued UBDWIO: PUSH P,[WIOUNB] ;Make sure without-interrupt'er gets called POP FXP,T PUSH FXP,R ;With old value to store MOVSS (FXP) ;WIOUNB expects it in left half JRST UBD UBD4: HLRZ D,(SP) JUMPN D,UBD ;AMONG OTHER THINGS, ERRPOP'S SETOM MAKES THIS JUMP PUSH FXP,T ;MUST SAVE T MOVEI T,(R) PUSHJ P,AUNBN0 ;FOUND A FUNARG BINDING BLOCK POP FXP,T ; - USE SPECIAL ROUTINE TO UNBIND IT JRST UBD UNBIND: POP SP,T MOVEM TT,UNBND3 ;HORRIBLE HACK TO SAVE AC TT. THINK ABOUT THIS SOME DAY UNBND0: TLZ T,-1 ;AUNBIND ENTERS HERE IFE D10,[ UNBND1: CAIN T,(SP) JRST UNBND2 POP SP,TT MOVSS TT BNDTRAP UNBNDP,TT, HLRZM TT,(TT) JRST UNBND1 ]; END IFE D10, IFN D10,[ PUSH FXP,R ;Save R for comparison MOVEI R,PWIOINT ;For comparison, factored out of the loop UNBND1: CAIN T,(SP) ;End of looop? JRST UNBD2A POP SP,TT MOVSS TT CAIN R,(TT) ;Is this the special case PWIOINT? JRST UNBNDP ; Yes, hack it HLRZM TT,(TT) JRST UNBND1 ]; END IFN D10, UNBNDP: PUSH FXP,T ;FIGURE OUT IF WITHOUT-INTERRUPTS HRRZI T,(TT) CAIN T,PWIOINT ;WITHOUT-INTERRUPTS, HANDLE SPECIALLY JRST UNBWIO POP FXP,T ;RESTORE STATE HLRZM TT,(TT) ;RECAUSE ERROR, WILL TRAP THIS TIME JRST UNBND1 ;CONTINUE IF CONTINUED UNBWIO: PUSH P,[WIOUNB] ;MAKE SURE WITHOUT-INTERRUPT'ER GETS CALLED POP FXP,T PUSH FXP,TT ;WITH OLD VALUE JRST UNBND1 ;;; BIND, AND MAKE-VALUE-CELL ROUTINES. ;;; PUSHJ P,BIND WITH SYMBOL IN A, VALUE IN AR1. ;;; USES ONLY A, TT; MUST SAVE T ;;; JSP TT,MAKVC WITH AN ATOMIC SYMBOL ON THE PDL (WHICH IS POPPED) ;;; AND THE VALUE IN B. RETURNS ADDRESS OF NEW VALUE CELL IN A. ;;; (LATTER CROCK FOR BIND1 ONLY). USES ONLY A,B,TT. BIND: SKIPN TT,A JRST BIND5 HLRZ A,(A) XCTPRO HRRZ A,(A) NOPRO CAIN A,SUNBOUND JRST BIND1 BIND4: PUSH SP,(A) HRLM A,(SP) STQPUR: BNDTRAP WIOBND,A, HRRZM AR1,(A) POPJ P, BIND5: MOVEI A,VNIL ;ALLOW PURPGI TRAP TO WORK JUST CBIND4: JRST BIND4 ;LIKE FOR SETQING T BIND1: PUSH P,CBIND4 ;SET UP FOR CALL TO MAKVC PUSH P,B PUSH P,TT MOVEI B,QUNBOUND JSP TT,MAKVC POPBJ: POP P,B CPOPBJ: POPJ P,POPBJ MAKVC: PUSH FXP,TT ;SAVE RETURN ADDR SPECPRO INTZAX MAKVC0: SKIPN A,FFVC JRST MAKVC3 EXCH B,@FFVC XCTPRO HRRZM B,FFVC NOPRO MAKVC1: HLRZ B,@(P) ;POINTER TO SYMBOL HEADER IS ON STACK PURTRAP MAKVC9,B, HRRM A,(B) MAKVCX: SUB P,R70+1 ;POP POINTER, RETURN ADDRESS OF VALUE CELL POPJ FXP, ; IN A, ADDR OF SY2 BLOCK IN B IFE PAGING,[ MAKVC3: PUSHJ P,CONS1 SETOM ETVCFLSP JRST MAKVC1 ] ;END OF IFE PAGING SUBTTL VARIOUS ODDBALL CONSERS IFN BIGNUM,[ C1CONS: EXCH T,YAGDBT JSP T,FWCONS EXCH T,YAGDBT JRST ACONS ] ;END OF IFN BIGNUM %NCONS: PUSH P,T NCONS: TLZ A,-1 BAKPRO ACONS: SKIPN FFS ;THIS IS A CONS LIKE XCONS PUSHJ P,AGC ;BUT USES ONLY ACCUMULATOR A MOVSS A ;SWAP HALVES OF A, THEN SPECPRO INTACX EXCH A,@FFS ;CONS WHOLE WORD FROM A XCTPRO EXCH A,FFS NOPRO POPJ P, IFN BIGNUM,[ BAKPRO BGNMAK: ;MAKE A POSITIVE BIGNUM (SAME AS BNCONS) BNCONS: SKIPN FFB ;BIGNUM CONSER PUSHJ P,AGC EXCH A,@FFB XCTPRO EXCH A,FFB NOPRO POPJ P, ] ;END OF IFN BIGNUM ;;; EXPLODEC ARGUMENT IN A (WITH BASE=10., *NOPOINT=T), ;;; AND RETURN A SIXBIT WORD IN TT. CLOBBERS ALL ACS. SIXMAK: MOVEI B,IN0+10. JSP T,SPECBIND 0 B,VBASE 0 B,V.NOPOINT SETZM SIXMK2 MOVE AR1,[440600,,SIXMK2] HRROI R,SIXMK1 .SEE PR.PRC PUSHJ P,PRINTA ;CALL PRINTA TO EXPLODEC THE ARGUMENT MOVE TT,SIXMK2 JRST UNBIND SIXMK1: CAIGE A,140 ;THIS SAYS CONVERT LOWER CASE TO UPPER TRC A,40 ;CONVERT CHAR TO SIXBIT TLNE AR1,770000 .UDT4: IDPB A,AR1 ;MAYBE SAVE IT, UNLESS ALREADY HAVE SIX POPJ P, ;;; TAKE SIXBIT IN TT, RETURN AN ATOMIC SYMBOL IN A. ;;; EMBEDDED BLANKS COUNT, BUT TRALING ONES DON'T. ;;; A ZERO WORD BECOMES THE ATOM "*". SAVES F. SIXATM: SETOM LPNF MOVE C,PNBP MOVSI T,(ASCII \*\) MOVEM T,PNBUF SETZM PNBUF+1 SIXAT1: JUMPE TT,RINTERN ;RINTERN SAVES F SETZ T, LSHC T,6 ADDI T,40 ;CONVERT SIXBIT TO ASCII IDPB T,C ;STICK CHARACTERS IN PNBUF JRST SIXAT1 ;;; A STRING IS IN PNBUF, TERMINATED BY A NULL. ;;; LOCATE ITS END, AND CALL RINTERN TO MAKE AN ATOM. PNBFAT: MOVE T,PNBP PNBFA1: MOVE C,T ILDB TT,T JUMPN TT,PNBFA1 SETOM LPNF JRST RINTERN ;;; TAKE AN S-EXPRESSION IN A, AND EXPLODEC IT INTO PNBUF. ;;; AR2A WILL CONTAIN THE COUNT OF UNUSED CHARACTER POSITIONS IN PNBUF. ;;; PRESERVES ITS ARGUMENT. PNBFMK: PUSH P,A PUSH P,CPOPAJ SETZM PNBUF MOVE T,[PNBUF,,PNBUF+1] BLT T,PNBUF+LPNBUF-1 MOVE AR1,PNBP MOVEI AR2A,LPNBUF*BYTSWD HRROI R,PNBFM6 .SEE PR.PRC JRST PRINTA PNBFM6: JUMPLE AR2A,CPOPJ ;GIVE UP IF NO MORE ROOM IN PNBUF IDPB A,AR1 ;ELSE STICK CHARACTER IN SOJA AR2A,CPOPJ IFN D10,[ ;;; CONVERT A PPN IN TT TO AN "ATOM", I.E. AN S-EXPR OF APPROPRIATE FORM. SAVES F. PPNATM: IFE SAIL,[ SKIPN CMUP JRST PPNAT2 HLRZ T,TT CAIG T,10 ;PPN'S WITH PROJECT BETWEEN 1 AND 10 JRST PPNAT2 ; MUST BE EXPRESSED IN DEC FORM MOVE T,[TT,,PNBUF] SETZM PNBUF+1 ;NEED THIS BECAUSE OF CMU BUG DECCMU T, ;TRY CONVERTING PPN TO CMU STRING JRST PPNAT2 ;ON FAILURE, JUST REVERT TO DEC FORMAT JRST PNBFAT ;ON SUCCESS, CONS UP ATOM FROM STRING ] ;END OF IFE SAIL PPNAT2: JUMPN TT,.+3 MOVEI A,Q. POPJ P, PUSHN P,1 PUSH FXP,TT TLZ TT,-1 PUSHJ P,PPNAT4 ;CONVERT PROGRAMMER POP FXP,TT HLRZS TT PUSHJ P,PPNAT4 ;CONVERT PROJECT JRST POPAJ PPNAT4: IFE SAIL,[ CAIN TT,-1 ;777777 => OMITTED HALF OF PPN SKIPA A,[Q.] ;REPLACE IT WITH * JSP T,FXCONS ;OTHERWISE USE A FIXNUM MOVE B,-1(P) PUSHJ P,CONS MOVEM A,-1(P) POPJ P, ] ;END OF IFE SAIL IFN SAIL,[ CAIN TT,-1 ;777777 => OMITTED HALF OF PPN JRST PPNAT9 ;REPLACE IT WITH * JUMPE TT,PPNAT9 ;? MIGHT AS WELL TREAT 0 AS OMITTED PPNAT6: TLNE TT,770000 ;LEFT JUSTIFY THE SIXBIT CHARACTERS JRST PPNAT3 ;WHEN DONE, CREATE AN ATOM AND CONS ONTO LIST LSH TT,6 JRST PPNAT6 ] ;END OF IFN SAIL SA$ PPNAT9: SKIPA A,[Q.] PPNAT3: 20% PUSHJ P,SIXATM 20$ PUSHJ P,PNBFAT PPNAT5: MOVE B,-1(P) PUSHJ P,CONS MOVEM A,-1(P) POPJ P, ] ;END OF IFN D10 SUBTTL CATCH, THROW, ERRSET, .SET, AND BREAK ROUTINES ;NORMAL CATCH CATPUS: PUSH P,B ;COMPILED CODE FOR *CATCH ENTERS HERE MOVEI A,(A) ; COMPLR TURNS "CATCH" TO "*CATCH" MOVEI T,(A) LSH T,-SEGLOG SKIPGE ST(T) ;SEE IF TAG OR TAGLIST HRLI A,CATSPC\CATLIS CATPS1: MOVEM A,CATID ;SET UP A CATCH FRAME JSP T,ERSTP MOVEM P,CATRTN JRST (TT) ;CATCH-BARRIER CATBAR: PUSH P,B ;ADR TO JUMP TO WHEN THROW IS DONE HRLI A,CATSPC\CATLIS\CATCAB ;FLAG AS CATCH-BARRIER MOVEM A,CATID ;THIS IS THE CATCH ID JSP T,ERSTP ;SETUP A NEW CATCH FRAME MOVEM P,CATRTN JRST (TT) ;CATCHALL ; UPON ENTRY: TT HAS ADR-1 OF CATCHALL FUN, T HAS ADR AFTER OTHER FUNS CTCALL: PUSH P,T AOS TT ;POINT TO FIRST LOCATION OF CATCHALL FUN HRLI TT,CATSPC\CATALL\CATCOM ;FLAG AS A COMPILED CATCHALL MOVEM TT,CATID ;THIS IS THE CATCH ID JSP T,ERSTP ;SETUP A NEW CATCH FRAME MOVEM P,CATRTN JRST -1(TT) ;BREAKUP A CATCHALL THRALL: SETZM (P) ;TURN INTO A NORMAL CATCH JRST THROW1 ;THEN BREAK UP LIKE A NORMAL THROW THROW5: SKIPE D,UIRTN ;IF NO USER INTERRUPT FRAME STACKED, CAIG D,(TT) ; OR IF IT IS BELOW THE CATCH FRAME, JRST THROW3 ; THEN JUST EXIT THE CATCH FRAME JSP TT,UIBRK ;OTHERWISE BREAK OUT OF THE INTERRUPT THROW1: SKIPN TT,CATRTN ;SKIP IF CATCH FRAME BELOW US JRST THROW4 MOVSI T,CATUWP TDNE T,(TT) ;UNWIND-PROTECT FRAME? JRST THRNXT ;YES, SKIP IT COMPLETELY JUMPE B,THROW5 THROW6: SKIPN T,(TT) ;(CATCH FOO NIL) = (CATCH FOO) JRST THROW5 ;CATCH ID MATCHES THROW ID TLNE T,CATSPC ;SPECIAL PROCESSING NEEDED? JRST THRSPC ;YES, DO SO CAIN B,(T) ;CATCH ID MATCHES? JRST THROW5 ;YES THRNXT: MOVE TT,<-LEP1+1>+(TT) ;GO BACK ONE CATCH JUMPN TT,THROW6 ;FALL THROUGH IF NO MORE THROW7: EXCH A,B %UGT EMS29 EXCH A,B JRST THROW1 THROW3: PUSHJ FXP,UNWPRO ;UNWIND PROTECT CHECKER MOVE P,TT THRXIT: SETZM PANICP MOVSI D,-LEP1+1(P) HRRI D,ERRTN BLT D,ERRTN+LEP1-1 MOVE C,CATID ;GET CURRENT CATCH ID SUB P,EPC1 POP P,FXP POP P,FLP POP P,TT POP P,PA3 PUSHJ P,UBD0 ;RESTORE CONDITIONS AND PROCEED TLNN C,CATALL ;A CATCHALL? POPJ P, ;NOPE, RETURN THROWN VALUE EXCH A,B ;TAG AS FIRST ARG, VAL AS SECOND TLNE C,CATCOM ;COMPILED? JRST (C) ;YES, RUN COMPILED CODE CALLF 2,(C) ;ELSE CALL THE USER'S FUNCTION POPJ P, ;RETURN NEW VAL IF THE CATCHALL FUN RETURNS THRSPC: TLNE T,CATALL ;CATCHALL? JRST THROW5 ;YES, WE HAVE FOUND A GOOD FRAME TO STOP AT TLNE T,CATUWP ;UNWIND-PROTECT? JRST THRNXT ;YES, IGNORE THE FRAME TLNE T,CATCAB ;CATCH-BARRIER? JRST THRCAB TLNN T,CATLIS ;A LIST OF TAGS? LERR [SIXBIT\SPECIAL CATCH FRAME, BUT NO VALID TYPE BITS EXIST!\] PUSH P,A PUSH P,B ;SAVE NEEDED ACS MOVEI A,(B) ;CATCH TAG MOVEI B,(T) ;LIST OF TAGS PUSHJ P,MEMQ1 ;CHECK FOR MEMBERSHIP (DOES NOT DESTROY TT) MOVE T,A ;SAVE THE RESULTS POP P,B POP P,A JUMPE T,THRNXT ;UPWARD TO NEXT CATCH FRAME JRST THROW5 ;ELSE FOUND A MATCH, SO DO THE ACTUAL THROW THRCAB: PUSH P,A PUSH P,B ;SAVE NEEDED ACS MOVEI A,(B) ;CATCH TAG MOVEI B,(T) ;LIST OF TAGS PUSHJ P,MEMQ1 ;CHECK FOR MEMBERSHIP (DOES NOT DESTROY TT) MOVE T,A ;SAVE THE RESULTS POP P,B POP P,A JUMPE T,THROW7 ;CATCH-BARRIER, NOT IN LIST OF TAGS, ERROR JRST THROW5 ;ELSE FOUND A MATCH, SO DO THE ACTUAL THROW THROW4: JUMPN B,THROW7 ;NO CATCH FRAME -- GIVE UGT EROR JRST LSPRET ;IF NO THROW TAG, THROW TO TOP LEVEL JRST THRALL ;COMPILED REMOVAL OF A CATCHALL JRST THROW1 ;COMPILED THROWS COME HERE ERUNDO: SKIPN ERRTN ;COMPILED ERR, AND NORMAL ERRSET EXIT COME HERE JRST LSPRET ;RETURN TO TOPLEVEL ERR0: IFN USELESS, SETZM TYOSW JUMPN A,ERUN0 ;ELSE, BREAK UP AN ERRSET SKIPE V.RSET SKIPN VERRSET ;ERRSET BEING BROKEN BY AN ERROR JRST ERUN0 PUSH P,A MOVEI D,1001 ;ERRSET USER INTERRUPT PUSHJ P,UINT POP P,A JRST ERUN0 SKIPA TT,CATRTN ;PHOOEY, COMPILED CODE COMES HERE WHEN A GOBRK: MOVE TT,ERRTN ;GO OR RETURN OCCURS WITHIN AN ERRSET OR CATCH JUMPE TT,ER4 EXCH T,-LERSTP(TT) JRST ERR1 IOGBND: JSP T,SPECBIND ;BIND ALL I/O CONTROL VARIABLES TO NIL: TTYOFF ; ^W TAPRED ; ^Q TAPWRT ; ^R EPOPJ: POPJ P, .SEE $ERRFRAME ;;; MOVEI D,LOOP ;ROUTINE TO LOOP ;;; PUSHJ P,BRGEN ;;; GENERATES A BREAK LOOP SURROUNDED BY A CATCH AND AN ;;; ERRSET. ERRORS CAUSE THE LOOP TO BE RE-ENTERED. ;;; BRGEN RETURNS WHEN THE LOOP ROUTINE PERFORMS A ;;; THROW TO THE TAG BREAK. .SEE BREAK .SEE $BREAK BRGEN: MOVEI A,QBREAK ;CATCH ID = BREAK JSP TT,CATPS1 ;SET UP CATCH FRAME PUSH P,D PUSH P,. ;RETURN POINT FOR ERROR JSP T,ERSTP ;SET UP ERRSET FRAME SETOM ERRSW MOVEM P,ERRTN JRST @-LERSTP-1(P) ;CALL RANDOM ROUTINE ;;; BREAK LOOP USED BY *BREAK BRLP1: PUSH P,FLP PUSH P,FXP PUSH P,SP PUSHJ P,TLEVAL ;EVALUATE FORM READ MOVEM A,V. ;STICK VALUE IN * PUSHJ P,TLPRINT ;PRINT VALUE HRRZ TT,-2(P) HRRZ D,-1(P) HRRZ R,(P) POPI P,3 PUSHJ P,PDLCHK ;CHECK PDL LEVELS JRST TLTERPRI ;TERPRI IF APPROPRIATE BRLP: PUSH P,BRLP ;***** BASIC BREAK LOOP ***** SKIPE A,BLF ;IF USER SUPPLIED A BREAK LOOP FORM, JRST EVAL ; EVALUATE IT (RETURNS TO BRLP) PUSHJ P,TLREAD ;OTHERWISE READ A FORM JRST .+4 SETZ AR1, ;ON EOF, LOOP BACK AFTER TERPRING PUSHJ P,TERP1 JRST .-4 SKIPE VDOLLRP ;IF THE FORM IS EQ TO THE CAME A,VDOLLRP ; NON-NIL VALUE OF THE VARIABLE P, JRST BRLP4 ; THEN THAT MEANS RETURN NIL MOVEI A,NIL BRLP2: MOVEI B,QBREAK JRST THROW1 ;ESCAPE FROM BRGEN LOOP BRLP4: HLRZ B,(A) ;(RETURN ) MEANS RETURN THE CAIE B,QRETURN ; VALUE OF FOO JRST BRLP1 ;OTHERWISE EVAL AND PRINT THE FORM JSP T,%CADR BRLP3: PUSHJ P,EVAL JRST BRLP2 ;;; JSP T,.STORE ;USED BY COMPILED CODE ;;; ON CALLING .STORE WE MUST HAVE JUST COMPLETED AN "INTERPRETED" ;;; ARRAY REFERENCE OF SOME KIND, BY PUSHJ'ING INTO THE ARRAY HEADER ;;; AND GOING TO ONE OF THE NDIMX ROUTINES. THIS LEAVES THE SAR ;;; OF THE ARRAY REFERENCED IN LISAR, AND THE INDEX WORD IN R. ;;; A CONTAINS THE VALUE TO STORE INTO THE ARRAY. .STORE: SKIPN D,LISAR JRST .STOLZ ;ERROR IF NO ARRAY REFERENCED LATELY HLL D,ASAR(D) TLNN D,AS.SX ;WAS IT AN S-EXPRESSION ARRAY? JRST .STOR2 .STOR0: MOVEI TT,(R) ;YEP, STORE A HALF-WORD QUANTITY JUMPL R,.STOR1 HRLM A,@TTSAR(D) JRST (T) .STOR1: HRRM A,@TTSAR(D) JRST (T) .STOR2: TLNN D,AS.FX+AS.FL ;SKIP IF FIXNUM OR FLONUM IFN DBFLAG+CXFLAG, JRST .STOR4 .ELSE .VALUE MOVEI F,(T) TLNN D,AS.FX JSP T,FLNV1X ;GET FLONUM QUANTITY, WITH SKIP RETURN JSP T,FXNV1 ;OR MAYBE GET FIXNUM QUANTITY EXCH TT,R MOVEM R,@TTSAR(D) ;STORE QUANTITY INTO ARRAY JRST (F) IFN DBFLAG+CXFLAG,[ .STOR4: TLNN D,AS.DB+AS.CX ;SKIP IF DOUBLE OR COMPLEX IFN DXFLAG, JRST .STOR6 .ELSE .VALUE MOVEI F,(T) DB$ CX$ TLNN D,AS.DB DB$ CX$ JSP T,CXNV1X ;GET COMPLEX QUANTITY, WITH SKIP RETURN DB$ JSP T,DBNV1 ;OR MAYBE GET DOUBLE QUANTITY DB% JSP T,CXNV1 MOVE T,LISAR EXCH TT,R MOVEM R,@TTSAR(T) ;STORE QUANTITY INTO ARRAY ADDI TT,1 MOVEM D,@TTSAR(T) JRST (F) ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ .STOR4: TLNN D,AS.DX ;SKIP IF DUPLEX .VALUE ;IF NOT THAT, THEN ERROR (UNKNOWN ARRAY TYPE) PUSH P,F PUSH FXP,R JSP T,DXNV1 MOVE T,LISAR EXCH TT,(FXP) KA MOVEM R,@TTSAR(T) ;STORE QUANTITY INTO ARRAY KA ADDI TT,1 KA MOVEM F,@TTSAR(T) KA ADDI TT,1 KIKL DMOVEM R,@TTSAR(T) KIKL ADDI TT,2 POP FXP,@TTSAR(T) ADDI TT,1 MOVEM D,@TTSAR(T) POPJ P, ] ;END OF IFN DXFLAG ;;; JSP T,.SET ;USED BY COMPILED CODE ;;; ATOM TO SET IN AR1, AND VALUE TO SET TO IN A. ;;; THE VALUE MUST NOT BE A PDL QUANTITY. .SET: EXCH A,AR1 .SET1: PUSH P,A PUSHJ P,BIND ;BIND TAKES SYMBOL IN A, VALUE IN AR1 POP P,A ;THIS CROCKISH IMPLEEMNTATION EXCH A,AR1 ; PERFORMS A SET BY DOING A SPECBIND, JRST SETXIT ; THEN DISCARDING THE BINDING FROM SP ;;; JSP TT,FWNACK ;OR LWNACK ;;; FAXXXX,,QFOO ;OR LAXXXX,,QFOO ;;; CHECKS FOR AN FSUBR (LSUBR) THAT THE RIGHT NUMBER OF ARGUMENTS ;;; WERE PROVIDED, AND GENERATES AN APPROPRIATE WNA ERROR IF NOT. ;;; THE FAXXXX (LAXXXX) HAS THE LOW BIT 0 FOR LSUBR, 1 FOR FSUBR. ;;; BIT 2_N IS SET IFF GETTING EXACTLY N ARGUMENTS IS ACCEPTABLE. FWNACK: SETZ T, ;COUNT UP ACTUAL NUMBER OF ARGS MOVEI D,(A) ;LEAVES NEGATIVE OF NUMBER OF ARGS IN T, FWNAC1: JUMPE D,LWNACK ; SO CAN FALL INTO LSUBR CHECKER HRRZ D,(D) SOJA T,FWNAC1 LWNACK: MOVE D,(TT) ;GET WORD OF BITS ASH D,(T) TLNE D,2 ;SKIP UNLESS WNA JRST 1(TT) JRST WNAL0 ;GO PRODUCE A WRNG-NO-ARGS ERROR ;;; PUSH CRUFT FOR AN ERRSET/CATCH/READEOF FRAME ;;; BEWARE! THE COMPILER DEPENDS ON THE LENGTH OF THE ;;; ERRSET FRAME BEING A CONSTANT. ERSTP: PUSH P,PA3 ;"ERRSET" PUSH PUSH P,SP ;MUST SAVE TT - SEE $TYI PUSH P,FLP PUSH P,FXP REPEAT LEP1, PUSH P,ERRTN+.RPCNT LERSTP==.-ERSTP ;LENGTH OF ERRSET PUSH JRST (T) ERUN0: HRRZ TT,ERRTN ;GENERAL BREAK OUT OF AN ERRSET SKIPE D,UIRTN CAIL TT,(D) JRST ERR1A JSP TT,UIBRK ;MAYBE BREAK UP A USER INTERRUPT FIRST JRST ERUN0 ERR1A: HRRZ TT,ERRTN ;WHERE WE ARE UNWINDING TO PUSHJ FXP,UNWPRO ;HANDLE UNWIND-PROTECT MOVE P,ERRTN ERR1: SETZM PANICP MOVSI D,-LEP1+1(P) HRRI D,ERRTN BLT D,ERRTN+LEP1-1 SUB P,EPC1 POP P,FXP POP P,FLP POP P,TT POP P,PA3 JRST UBD0 ;RESTORE CONDITIONS AND PROCEED EPC1: LEP1,,LEP1 UIBRK: EXCH D,TT ;UNWIND-PROTECT NEEDS STACK POINTER IN AC TT PUSHJ FXP,UNWPRO ;HANDLE UNWIND PROTECTION EXCH D,TT HRRM TT,-1(D) HRRO FXP,1(D) ;JUST SET LEFT HALF OF PDL POINTERS HLRO FLP,1(D) ; TO -1 FOR BIBOP, AND LET PDLOV HRROI P,-UIFRM(D) IFN SAIL,[ FXPFIXPDL AR1 FLPFIXPDL AR1 PFIXPDL AR1 ] ;END OF IFN SAIL MOVEM F,UISAVT-T+F(FXP) ;LET F BE SAFE OVER RESTORATION MOVEM T,UISAVT(FXP) ;T TOO MOVEM C,UISAVA-A+C(P) ;C TOO MOVEM B,UISAVA-A+B(P) ;B TOO MOVEM A,UISAVA(P) ;A TOO JRST UINT0X ;THIS ROUTINE FINDS ALL UNWIND-PROTECTS BETWEEN THE CURRENT STACK POSITION ; AND THE DESIRED STACK POSITION (AS FOUND IN TT). IF AN UNWIND-PROTECT IS ; FOUND, THEN: ; A) THE UNWIND-PROTECT STACK FRAME IS POP'ED *WITHOUT UPDATING FXP OR FLP* ; B) SP IS UNWOUND TO THE CURRENT BINDING LEVEL ; C) THE FUNCTION IS CALLED WITH EVERYTHING SAVED ; D) WHEN THE FUNCTION RETURNS, ACS ARE RESTORED AND THE ROUTINE CONTINUES ; SEARCHING FOR THE NEXT UNWIND PROTECT ; WHEN NO MORE UNWIND PROTECTS EXIST IN THE SPECIFIED RANGE OF THE PDL, ; THIS ROUTINE RETURNS TO ITS CALLER, WHICH IS EXPECTED TO RESTORE ; FXP AND FLP (AND POSSIBLY OTHERS) FROM THE STACK FRAME THAT WAS USED TO STOP ; THE UNWIND-PROTECT SEARCH ; CALLED WITH PUSHJ FXP, ; TT CONTAINS LOWEST ADR TO SEARCH ; PRESERVES ALL AC'S UNWPRO: ;;; AMOUNT OF STUFF THAT GETS PUSHED MUST BE WELL DEFINED, CHANGE UNWPUS ;;; IF IT CHANGES .SEE UNWPUS PUSH FXP,D PUSH FXP,T PUSH FXP,R PUSH FXP,TT ;;; HRRZS TT ;ONLY PDL PART MOVEI R,(SP) ;CURRENT VALUE OF SP IN CASE NO FRAMES FOUND UNWPR2: SKIPE D,CATRTN UNWPR1: CAILE TT,(D) ;HAVE WE GONE TOO FAR? JRST UNWPRT ;NO MORE FRAMES POSSIBLE, SO RETURN HRLZI T,CATUWP ;IS THIS AN UNWIND-PROTECT FRAME? TDNN T,(D) JRST UNWNXT ;NOT UNWIND-PROTECT, SO SKIP THIS FRAME HRRO P,D ;RESET PDL, WILL WORK BY PDL OV NEXT PUSH SA$ PFIXPDL T ;;; PUSH NOTE .SEE UNWPUS PUSH FXP,UNREAL ;FROM THIS POINT ON ALLOW NO USER INT'S SETOM UNREAL HRRZM FXP,REALLY MOVE T,(P) ;GET POINTER TO UNWIND HANDLER MOVSI D,-LEP1+1(P) ;RESTORE HAS FRAME (SNARFED FROM ERR1) HRRI D,ERRTN BLT D,ERRTN+LEP1-1 SUB P,EPC1 POP P,D ;GET OLD FXP POP P,FLP ;RESTORE FLP POP P,R ;SAVE LEVEL TO SP UNWIND TO POP P,PA3 PUSHJ FXP,SAV5 ;SAVE ALL PROTECTED ACS MOVEI B,(T) ;POINTER TO COMPILED FUNCTION OR LIST ;;; PUSH NOTE .SEE UNWPUS PUSHJ P,SAVX5 ;AND UNPROTECTED ONES HRRI T,(D) MOVEI TT,(R) PUSHJ P,UBD0 ;Unwind SP PUSH FLP,T SETOI A, JSP T,SPECBIND 0 A,PWIOINT SETZM REALLY POP FLP,T TLNN T,CATCOM ;COMPILED CODE? JRST UNWNCM ;NOPE, USE PROGN UNWPUS==:13 ;NUMBER OF PUSHES DONE ON FXP MOVEI TT,(T) HRLI TT,-(FXP);BLT POINTER TO DATA THAT MUST BE MOVED AOS TT MOVEI D,UNWPUS-1(TT) ;BLT END POINTER BLT TT,(D) ;BLT ALL IMPORTANT FXP DATA HRROI FXP,(D) ;NEW FXP IFN SAIL,[ PUSH P,TT FXPFIXPDL TT POP P,TT ] ;END OF IFN SAIL PUSHJ P,(B) ;INVOKE THE UNWINDPROTECTION CODE SKIPA UNWNCM: PUSHJ P,IPROGN PUSHJ P,UNBIND ;UNDO THE NOINTERRUPT PROTECTION PUSHJ P,RSTX5 ;RESTORE ACS PUSHJ FXP,RST5 POPI FXP,1 ;FLUSH SAVED UNREAL FROM STACK JRST UNWPR2 UNWNXT: MOVE D,<-LEP1+1>+(D) ;GO BACK ONE CATCH JUMPN D,UNWPR1 ;IF MORE FRAMES TO CHECK THEN GO ON UNWPRT: POP FXP,TT POP FXP,R POP FXP,T POP FXP,D POPJ FXP, SUBTTL VARIOUS COMMON EXITS CIN0: IN0 ;SURPRISE! ;;; THESE ROUTINES ARE USEFUL FOR CONSING UP LISTS OF NUMBERS ;;; (AS STATUS FUNCTIONS OFTEN DO, FOR INSTANCE). ;;; A CALL TO CONS1FX WILL TAKE A NUMBER IN TT AND MAKE A SINGLETON ;;; LIST OF IT. SUCCESSIVE CALLS TO CONSFX WILL THEN TACK NEW NUMBERS ;;; ONTO THE FRONT OF THE LIST. CONS1PFX AND CONSPFX ARE SIMILAR, ;;; BUT POP THE NUMBER FROM FXP. IN THIS WAY ONE CAN PRODUCE NUMBERS ;;; IN FORWARDS ORDER, PUSHING THEM ON FXP, THEN USE THESE ROUTINES ;;; TO CONS THEM UP IN REVERSE ORDER, PRODUCING A FORWARDS LIST OF THEM. CONS1PFX: TDZA B,B CONS1FX: TDZA B,B CONSPFX: POP FXP,TT CONSFX: JSP T,FXCONS CONSIT: PUSHJ P,CONS BAPOPJ: MOVEI B,(A) POPJ P, ;;; OTHER COMMON EXITS ZPOPJ: TDZA TT,TT ;ZERO TT, THEN POPJ POPNVJ: JSP T,FXNV1 ;FXNV1, THEN POPJ CCPOPJ: POPJ P,CCPOPJ ;NOT CPOPJ! WILL SCREW BAKTRACE 0POPJ: SKIPA A,CIN0 ;PUT A LISP FIXNUM 0 IN A AND POPJ POP2J: POPI P,2 ;POP 2 PDL SLOTS AND POPJ CPOPJ: POPJ P,CPOPJ .SEE BAKTRACE ;SACRED TO BAKTRACE POP3J: POPI P,3 POPJ P, POPAJ1: AOSA -1(P) ;POP INTO A, THEN SKIP RETURN S1PAJ: POPI P,1 ;POP 1 PDL SLOT, POP INTO A, AND POPJ POPAJ: POP P,A ;POP A, THEN POPJ CPOPAJ: POPJ P,POPAJ POP1J1: AOSA -1(P) ;POP 1 PDL SLOT, THEN SKIP RETURN POPJ1: AOSA (P) ;SKIPPING POPJ RETURN POP1J: POPI P,1 ;POP 1 PDL SLOT AND POPJ CPOP1J: POPJ P,POP1J M1TTPJ: SKIPA TT,XC-1 ;-1 IN TT, THEN POPJ POPCJ: POP P,C ;POP C, THEN POPJ CPOPCJ: POPJ P,POPCJ UNLKFALSE: TDZA A,A ;UNLOCK INTERRUPTS, RETURNING FALSE (NIL) UNLKTRUE: MOVEI A,TRUTH ;UNLOCK INTERRUPTS, RETURNING TRUTH (T) UNLKPOPJ PX1J: POPI FXP,1 ;FLUSH 1 FXP SLOT, THEN POPJ P, CPXDFLJ: POPJ P,PXDFLJ PXDFLJ: HLLZ D,(P) ;POP FXP INTO D, THEN POPJ P, JRST 2,POPXDJ(D) ; AND RESTORE FLAGS FROM THE P SLOT POPXDJ: POP FXP,D ;POP FXP SLOT INTO D, THEN POPJ P, CPXDJ: POPJ P,POPXDJ SUBTTL VARIOUS COMMON SAVE AND RESTORE ROUTINES SAV5: PUSH P,A SAV5M1: PUSH P,B SAV5M2: PUSH P,C SAV5M3: PUSH P,AR1 PUSH P,AR2A CPOPXJ: POPJ FXP, SAV3: PUSH P,C SAV2: PUSH P,B SAV1: PUSH P,A POPJ FXP, RST3: POP P,A POP P,B POP P,C POPJ FXP, RST2: POP P,A POP P,B POPJ FXP, RST1: POP P,A POPJ FXP, RST5: POP P,AR2A POP P,AR1 POP P,C POP P,B POP P,A POPJ FXP, R5M1PJ: PUSH FXP,CCPOPJ RST5M1: POP P,AR2A POP P,AR1 POP P,C POP P,B CR5M1PJ: POPJ FXP,R5M1PJ RST5M2: POP P,AR2A POP P,AR1 POP P,C POPJ FXP, RST5M3: POP P,AR2A POP P,AR1 POPJ FXP, SAVX5: PUSH FXP,T PUSHJ P,SAVX3 PUSH FXP,F POPJ P, SAVX3: PUSH FXP,TT PUSH FXP,D PUSH FXP,R POPJ P, RSTX5: POP FXP,F POP FXP,R POP FXP,D PXTTTJ: POP FXP,TT POPXTJ: POP FXP,T POPJ P, RSTX3: POP FXP,R RSTX2: POP FXP,D RSTX1: POP FXP,TT CPOPNVJ: POPJ P,POPNVJ SUBTTL VARIOUS KINDS OF FRAME MARKERS $ERRFRAME=525252,,EPOPJ ;ERROR FRAME $EVALFRAME=525252,,POP2J ;EVAL FRAME ;; $APPLYFRAME=525252,,AFPOPJ ;APPLY FRAME DEFINED BELOW $UIFRAME=525252,,CPOPAJ ;USER INTERRUPT FRAME ;;; FORMAT OF EVALFRAME: ;;; ,, ;;; ,,
;;; $EVALFRAME L$EVALFRAME==3 ;LENGTH OF EVALFRAME ;;; FORMAT OF APPLYFRAME: ;;; -- ARGS -- ;;; ,, ;;; ,, ;;; $APPLYFRAME .SEE L$EVALFRAME ;;; WHERE -- ARGS -- MAY BE ONE OF THREE THINGS, DEPENDING ;;; ON ITS LEFT HALF: ;;; LH=0 RH=LIST OF ARGS ;;; LH<0 LH,,RH=AOBJN POINTER TO ARGS VECTOR (E.G. FOR LSUBR) ;;; LH>0 RH=LAST ARG; OTHER ARGS ARE BELOW THIS ON THE ;;; STACK. IN THIS CASE THE APPLYFRAME MAY BE MORE ;;; THAN FOUR WORDS LONG. ;;; EXAMPLE: MOVEI A,QFOO ;;; MOVEI B,QBAR ;;; CALL 2,QUUX ;;; CAUSES THIS APPLYFRAME TO APPEAR ON THE STACK: ;;; 0,,QFOO ;;; 2,,QBAR ;;; ,, ;;; ,,QUUX ;;; $APPLYFRAME AFPOPJ: HLRE T,-2(P) ;APPLYFRAME POPJ SKIPG T ;FIGURE OUT LENGTH OF MOVEI T,1 ; APPLY FRAME ADDI T,2 HRLI T,(T) SUB P,T ;POP CRUFT FROM PDL POPJ P, ;RETURN $APPLYFRAME=525252,,AFPOPJ ;APPLY FRAME SUBTTL NUMERIC TYPE-TESTING, CONVERSION, AND VALUE ROUTINES IFN BIGNUM+DBFLAG+CXFLAG,[ FLTSK1: %WTA NMV5 ;UNACCEPTABLE NUMERIC VALUE IFE NARITH, JRST 2,@[FLTSKP] ;CLEAR PC FLAGS ] ;END OF IFN BIGNUM+DBFLAG+CXFLAG FLTSK2: %WTA NMV3 ;NON-NUMERIC VALUE IFE NARITH, JRST 2,@[FLTSKP] ;CLEAR PC FLAGS FLTSKP: MOVEI TT,(A) ;"FLOAT SKIP" ROUTINE LSH TT,-SEGLOG ; SKIPS 0 FOR FIXNUMS, 1 FOR FLONUMS (OR DOUBLES) HRRZ TT,ST(TT) ;LEAVES NUMERIC VALUE IN TT IFE NARITH, 2DIF JRST @(TT),FLTSTB,QLIST IFN NARITH, 2DIF [JRST 2,@(TT)]FLTSTB,QLIST ;DISPATCH AND CLEAR PC FLAGS FLTSTB: FLTSK2 ;LIST ;ERROR FLTSFX ;FIXNUM ;SKIPS 0 FLTSFL ;FLONUM ;SKIPS 1 DB$ FLTSFL ;DOUBLE ;SKIPS 1 CX$ FLTSK1 ;COMPLEX;ERROR DX$ FLTSK1 ;DUPLEX ;ERROR BG$ FLTSK1 ;BIGNUM ;ERROR FLTSK2 ;SYMBOL ;ERROR HN$ REPEAT HNKLOG+1, FLTSK2 ;HUNKS ;ERROR FLTSK2 ;RANDOM ;ERROR FLTSK2 ;ARRAY ;ERROR IFN .-FLTSTB-NTYPES, WARN [WRONG LENGTH TABLE] IFN BIGNUM*<1-NARITH>, NVSKBG: IFN BIGNUM*NARITH, NMSKBG: FLTSFX: MOVE TT,(A) JRST (T) IFN BIGNUM*<1-NARITH>, NVSKFX: FLTSFL: MOVE TT,(A) JRST 1(T) IFN BIGNUM*<1-NARITH>,[ NVSKP2: %WTA NMV3 ;NON-NUMERIC VALUE NVSKIP: MOVEI TT,(A) ;"NUMERIC VALUE SKIP" LSH TT,-SEGLOG ;SKIPS: 0 = BIGNUM, 1 = FIXNUM, 2 = FLONUM, ELSE ERROR HRRZ TT,ST(TT) ;LEAVES NUMERIC VALUE IN TT 2DIF JRST @(TT),NVSKTB,QLIST .SEE STDISP NVSKTB: NVSKP2 ;LIST ;ERROR NVSKFX ;FIXNUM ;SKIPS 1 NVSKFL ;FLONUM ;SKIPS 2 DB$ NVSKP2 ;DOUBLE CX$ NVSKP2 ;COMPLEX DX$ NVSKP2 ;DUPLEX BG$ NVSKBG ;BIGNUM ;SKIPS 0, LEAVES BIGNUM HEADER IN TT NVSKP2 ;SYMBOL ;ERROR HN$ REPEAT HNKLOG+1, NVSKP2 ;HUNKS ;ERROR NVSKP2 ;RANDOM ;ERROR NVSKP2 ;ARRAY ;ERROR IFN .-NVSKTB-NTYPES, WARN [WRONG LENGTH TABLE] NVSKFL: MOVE TT,(A) JRST 2(T) ] ;END OF IFN BIGNUM*<1-NARITH> IFN NARITH,[ ;;; NUMERIC SKIP ROUTINE ;;; JSP T,NMSKIP ;;; BG$ ... ;HERE FOR BIGNUMS; LEAVES HEADER IN TT ;;; DX$ ... ;HERE FOR DUPLEX ;;; CX$ ... ;HERE FOR COMPLEX ;;; DB$ ... ;HERE FOR DOUBLE; LEAVES FIRST WORD IN TT ;;; ... ;HERE FOR FLONUM; LEAVES VALUE IN TT ;;; ... ;HERE FOR FIXNUM; LEAVES VALUE IN TT ;;; ALSO CLEARS THE PC FLAGS NMSKP2: %WTA NMV3 ;NON-NUMERIC VALUE NMSKIP: MOVEI TT,(A) LSH TT,-SEGLOG HRRZ TT,ST(TT) 2DIF [JRST 2,@(TT)]NMSKTB,QLIST ;PC FLAGS IN THIS TABLE MUST BE ZERO NMSKTB: NMSKP2 ;LIST NMSKFX ;FIXNUM NMSKFL ;FLONUM DB$ NMSKDB ;DOUBLE CX$ NMSKCX ;COMPLEX DX$ NMSKDX ;DUPLEX BG$ NMSKBG ;BIGNUM NVSKP2 ;SYMBOL HN$ REPEAT HNKLOG+1, NVSKP2 ;HUNKS NVSKP2 ;RANDOM NVSKP2 ;ARRAY IFN .-NVSKTB-NTYPES, WARN [WRONG LENGTH TABLE] NMSKFX: MOVE TT,(A) JRST BIGNUM+DXFLAG+CXFLAG+DBFLAG+1(T) NMSKFL: MOVE TT,(A) JRST BIGNUM+DXFLAG+CXFLAG+DBFLAG(T) DB$ NMSKDB: MOVE TT,(A) DB$ JRST BIGNUM+DXFLAG+CXFLAG(T) CX$ NMSKCX: JRST BIGNUM+DXFLAG(T) DX$ NMSKDB: JRST BIGNUM(T) ] ;END OF IFN NARITH LR70==:20 ;LAP AND FASLAP HAVE THIS QUANTITY BUILT IN CDUPL1: DUPL1 ;FOR (% 0 0 DUPL1) CCMPL1: CMPL1 ;FOR (% 0 0 CMPL1) CDBL1: DBL1 ;FOR (% 0 0 DBL1) CFIX1: FIX1 ;FOR (% 0 0 FIX1) CFLOAT1: FLOAT1 ;FOR (% 0 0 FLOAT1) R70: REPEAT LR70, .RPCNT,,.RPCNT ;COMMON LAP CONSTANTS ALSO USED BY LISP CODE ZZZ==5 IFL ZZZ-NACS, ZZZ==NACS ;NEED AT LEAST OF THESE REPEAT ZZZ, .RPCNT-ZZZ XC:: ;WRITE "XC-N" TO GET THE CONSTANT -N FOR SMALL N ;;; INTERNAL FLONUM-TO-FIXNUM CONVERSION; DOES NO ERROR CHECKS. ;;; CONVERTS NUMBER IN TT TO BE A FIXNUM, CLOBBERING D. ;;; THE CONVERSION IS A "FLOOR" OR "ENTIER" FUNCTION. ;;; THAT IS, 3.5 => 3, BUT -3.5 => -4. IFIX: MULI TT,400 ;EXPONENT IN TT, MANTISSA IN D TSC TT,TT ;THIS HACK GETS MAGNITUDE OF EXPONENT ASH D,-243(TT) ;SHIFT THE MANTISSA MOVE TT,D ;RESULT IN TT JRST (T) ;;; INTERNAL FIXNUM-TO-FLONUM CONVERSION. SAVES D. IFLOAT: TLNE TT,777000 ;FOR POSITIVE INTEGERS 27. BITS OR LESS, JRST IFLT1 ; CAN JUST USE FSC TO SCALE IFLT5: FSC TT,233 ;FSC NORMALIZES RESULT JRST (T) IFLT1: TLC TT,777000 ;THE SAME HACK WORKS FOR NEGATIVE NUMBERS TLCN TT,777000 ; WITH NO MORE THAN 27. SIGNIFICANT BITS JRST IFLT5 IFLT2: MOVEM D,IFLT9 ;FOR 28. TO 35. BITS OF SIGNIFICANCE, JUMPL TT,IFLT3 ; WE CONVERT THE LEFT AND RIGHT HALVES HLRZ D,TT ; SEPARATELY, AND THEN ADD THEM, TRUNCATING MOVEI TT,(TT) IFLT4: FSC D,255 ;SCALE RIGHT HALF FSC TT,233 ;SCALE LEFT HALF FAD TT,D ;ADD TOGETHER MOVE D,IFLT9 ;RESTORE D JRST (T) IFLT3: HLRO D,TT ;FOR NEGATIVE NUMBERS, WE MUST HRROI TT,(TT) ; PRODUCE THE CORRECT SIGN AOJA D,IFLT4 ;;; NUMERIC VALUE ROUTINES. THESE CHECK AN S-EXPRESSION ;;; FOR BEING THE DESIRED NUMERIC TYPE, AND PRODUCE A ;;; WRNG-TYPE-ARG ERROR IF APPROPRIATE. OTHERWISE ;;; THE VALUE OF THE NUMBER IS LIFTED INTO TT (D,R,F). COMMENT |FXNV1: FXNV2: FXNV3: FXNV4:| ;;; FXNV1 (2,3,4) TAKES S-EXP IN A (B,C,AR1) AND PUTS VALUE IN TT (D,R,F). IRPC AC,,[1234] EFXNV!AC: IFN AC-A, EXCH A,AC %WTA FXNMER IFN AC-A, EXCH A,AC FXNV!AC: MOVEI TT-1+AC,(AC) ;CHECK DATA TYPE ROT TT-1+AC,-SEGLOG SKIPL TT-1+AC,ST(TT-1+AC) TLNN TT-1+AC,FX ;SKIP IFF FIXNUM JRST EFXNV!AC ;LOSE MOVE TT-1+AC,(AC) ;GET VALUE IN NUMERIC AC JRST (T) TERMIN FLNV1X: AOJA T,FLNV1 ;FLNV1 WITH SKIP RETURN EFLNV1: %WTA FLNMER FLNV1: SKOTT A,FL ;GET FLONUM VALUE IN TT FROM A JRST EFLNV1 MOVE TT,(A) JRST (T) IFN DBFLAG,[ EDBNV1: %WTA DBNMER DBNV1: SKOTT A,DB ;GET DOUBLE VALUE IN (TT,D) FROM A JRST EDBNV1 ;HIGH ORDER WORD IN TT, LOW ORDER IN D KA MOVE TT,(A) KA MOVE D,1(A) KIKL DMOVE TT,(A) JRST (T) ] ;END OF IFN DBFLAG IFN CXFLAG,[ CXNV1X: AOJA T,CXNV1 ;CXNV1 WITH SKIP RETURN ECXNV1: %WTA CXNMER CXNV1: SKOTT A,CX ;GET COMPLEX VALUE IN (TT,D) FROM A JRST ECXNV1 ;REAL PART IN TT, IMAGINARY IN D KA MOVE TT,(A) KA MOVE D,1(A) KIKL DMOVE TT,(A) JRST (T) ] ;END OF IFN CXFLAG IFN DXFLAG,[ EDXNV1: %WTA DXNMER DXNV1: SKOTT A,DX ;GET DUPLEX VALUE IN (R,F,TT,D) FROM A JRST EFLNV1 ;REAL PART IN (R,F), IMAGINARY IN (TT,D) KA REPEAT 4, MOVE TT+<2#.RPCNT>,.RPCNT(A) KIKL DMOVE R,2(A) KIKL DMOVE TT,(A) JRST (T) ] ;END OF IFN DXFLAG BAKPRO RSXST: HRRZ TT,VREADTABLE ;READ CHARACTER SYNTAX HRRZ TT,TTSAR(TT) ; TABLE SETUP HRLI TT,((A)) ;USED AS INDIRECT ADDRESS WITH MOVEM TT,RSXTB ;INDEX FIELD A NOPRO JRST (T) SUBTTL SUPPORT FOR LAP/FASLAP CODE ;;; USE THE PUSHN MACRO TO PUSH N NIL'S (0'S, 0.0'S) ONTO P (FXP, FLP). ;;; IT WILL GENERATE JSP T,NPUSH-N (0PUSH, 0.0PUSH) AS APPROPRIATE. ;;; COMPILED CODE USES THESE ROUTINES VERY FREQUENTLY. REPEAT NNPUSH, CONC \NNPUSH-.RPCNT,NPUSH,: PUSH P,R70 NPUSH: JRST (T) REPEAT N0PUSH, CONC \N0PUSH-.RPCNT,PUSH,: PUSH FXP,R70 0PUSH: JRST (T) REPEAT N0.0PUSH, CONC \N0.0PUSH-.RPCNT,.PUSH,: PUSH FLP,R70 0.0PUSH: JRST (T) CINTREL: INTREL ;RANDOM USEFUL RETURN ADDRESS INTREL: POP FXP,INHIBIT .SEE UNLOCKI ;COME HERE TO PERFORM AN UNLOCKI CHECKI: SKIPN NOQUIT ;CHECK FOR DELAYED INTRRUPTS SKIPN INTFLG POPJ P, ;EXIT IF NONE JRST CKI0 ;ELSE GO PROCESS .SEE INTXIT JRST CTCALL ;CATCHALL IN COMPILED CODE JRST CATBAR ;CATCH-BARRIER IN COMPILED CODE JRST CATPUS ;COMPILED CODE CALLS CATCH ERSETUP: PUSH P,B ;COMPILED CODE CALLS ERRSET JSP T,ERSTP MOVEM P,ERRTN SETZM ERRSW SKIPE A ;VALUE IN A DESCRIBES WHETHER ERRORS PRINT SETOM ERRSW JRST (TT) SUBTTL SUPPORT FOR COMPILED LSUBRS ;;; ORDINARY TYPE COMPILED LSUBRS BEGIN THEIR CODE WITH ;;; JSP D,.LCALL ;;; NUMERIC TYPE COMPILED LSUBRS BEGIN THEIR CODE WITH ;;; JSP D,.LCALL-N ;N IS A FUNCTION OF THE TYPE ;;; JSP D,.LCALL ;;; THIS ROUTINE TAKES CARE OF BINDING ARGLOC AND ARGNUM FOR THE ;;; BENEFIT OF THE ARG, SETARG, AND LISTIFY FUNCTIONS, ;;; AND TAKE CARE OF FLUSHING THE ARGUMENTS FROM THE STACK. ;;; THE ORDER OF THESE ENTRY POINTS IS BUILT INTO THE COMPILER JRST .LCADX ;SETUP FOR DUPLEX TYPE COMPILED LSUBRS JRST .LCACX ;SETUP FOR COMPLEX TYPE COMPILED LSUBRS JRST .LCADB ;SETUP FOR DOUBLE TYPE COMPILED LSUBRS JRST .LCAFL ;SETUP FOR FLONUM TYPE COMPILED LSUBRS JRST .LCAFX ;SETUP FOR FIXNUM TYPE COMPILED LSUBRS .LCALL: PUSH P,R70 ;SETUP FOR REGULAR COMPILED LSUBRS, OR NCALL ENTRY .LCAF5: MOVN TT,T ;NUMBER OF ARGS ADDI T,-1(P) ;ADDR OF BEGINNING OF ARG VECTOR CAIL TT,XHINUM ;XHINUM IS TYPICALLY >777, SO THERE'S LITTLE JRST LXPRLZ ; CHANCE OF THIS SCREW, BUT BETTER BE SAFE MOVEI A,IN0(TT) MOVEI TT,(T) JSP T,SPECBIND 0 TT,ARGLOC ;ARGLOC HOLDS PDL POSITION FOR VECTOR OF LSUBR ARGS 0 A,ARGNUM ;ARGNUM IS NUMBER OF ARGS, AS A LISP FIXNUM PUSHJ P,(D) ;CALL THE USER FUNCTION, NUMBER OF ARGS IN A POP P,D SKIPN T,@ARGNUM JRST .LCAF7 ;MIGHT AS WELL BUM FOR NO ARGUMENTS HRLS T ;GOT TO GET RID OF THE ARGUMENTS SUB P,T .LCAF7: JUMPE D,UNBIND ;THIS EXIT SIGNALS CALL TO NOTYPE LSUBR, OR NCALL TO NUMERIC PUSH P,D ;ELSE EXIT THROUGH FIX1 OR EQUIVALENT, JRST UNBIND ; MEANING REGULAR CALL TO NUMERIC LSUBR .LCAFX: PUSH P,CFIX1 ;PUSH ADDRESS FOR CONVERTINGMACHINE NUMBER TO FIXNUM AOJA D,.LCAF5 ;INCREMENT D PAST THE CALL TO .LCALL-0 WHICH FOLLOWS .LCAFL: PUSH P,CFLOAT1 AOJA D,.LCAF5 .LCADB: DB$ PUSH P,CDBL1 DB$ AOJA D,.LCAF5 DB% LERR [SIXBIT \CALL TO DOUBLE-TYPE USER LSUBR!\] .LCACX: CX$ PUSH P,CCMPL1 CX$ AOJA D,.LCAF5 CX% LERR [SIXBIT \CALL TO COMPLEX-TYPE USER LSUBR!\] .LCADX: DX$ PUSH P,CDUPL1 DX$ AOJA D,.LCAF5 DX% LERR [SIXBIT \CALL TO DUPLEX-TYPE USER LSUBR!\] ;;; THESE THREE FUNCTIONS MERELY SAVE THE LOSER THE TROUBLE OF TYPING "SETQ ". NORET: PUSHJ P,NOTNOT ;SUBR 1 HRRZM A,VNORET POPJ P, .RSET: PUSHJ P,NOTNOT ;SUBR 1 MOVEM A,V.RSET POPJ P, NOUUO: PUSHJ P,NOTNOT ;SUBR 1 HRRZM A,VNOUUO POPJ P, SUBTTL VARIOUS LISTING AND DE-LISTING ROUTINES LIST: PUSH FXP,CCPOPJ ;LSUBR LISTX: MOVEI A,NIL ;BASICALLY, THE FUNCTION "LIST" SKIPN R,T ; CALLED WITH A PUSHJ FXP, LISTX3: JUMPE R,CPOPXJ MOVEI B,(A) ;CLOBBERS A,B,T,TT,R POP P,A JSP T,PDLNMK JSP T,%CONS AOJA R,LISTX3 ;;; INTERNAL LISTING FUNCTION; EVALUATES A LIST OF ARGS, ;;; STACKING THEIR VALUES ON THE PDL KLIST: HLRZ B,(A) ;SUPER-HACKISH VERSION PUSH P,B HRRZ A,(A) JLIST: HLRZ B,(A) ;HACKISH VERSION WHICH DOESN'T PUSH P,B ; EVAL FIRST ARG OR COUNT IT HRRZ A,(A) ILIST: MOVEI T,0 ;CALLED BY JSP TT,ILIST JUMPE A,(TT) PUSH FXP,TT PUSH FXP,T ;CONTAINS 0 - USED AS COUNTER PUSH FXP,R ;MUST SAVE R! ILIST1: PUSH P,A ;OTHERWISE, THIS EVAL LOOP HLRZ A,(A) ; MAY CLOBBER ANYTHING PUSHJ P,EVAL ILIST3: EXCH A,(P) ;SAVE VALUE ON STACK HRRZ A,(A) SOS -1(FXP) ;COUNT VALUES JUMPN A,ILIST1 POP FXP,R ;RESTORE R POP FXP,T ;T HAS -<# OF VALUES ON PDL> POPJ FXP, ;;; JSP T,GTRDTB ;GETS READTABLE IN AR2A, AND MAYBE CHECKS FOR ERRORS. GTRDTB: HRRZ AR2A,VREADTABLE SKIPN V.RSET ;ERROR CHECKS IFF *RSET NON-NIL JRST (T) SKOTT AR2A,SA JRST GTRDT8 ;ERROR IF NOT ARRAY MOVE TT,ASAR(AR2A) TLNE TT,AS ;ERROR IF NOT READTABLE TYPE ARRAY JRST (T) GTRDT8: MOVEI AR2A,READTABLE ;ON ERROR, RESTORE TO STANDARD READTABLE EXCH AR2A,VREADTABLE EXCH AR2A,A PUSHJ P,GTRDT9 ;GIVE OUT A FAIL-ACT MOVEI A,(AR2A) JRST GTRDTB ;TRY AGAIN IF LOSER RETURNS TO US SUBTTL NOINTERRUPT FUNCTION NOINTERRUPT: JUMPE A,CHECKU ;SUBR 1 - ENABLE/DISABLE CAIN A,QTTY JRST CHECKU SETO A, ; RANDOM ASYNCHRONOUS NOINT0: EXCH A,UNREAL ; "REAL TIME" INTERRUPTS SKIPGE A ; (CLOCKS AND TTY) MOVEI A,TRUTH POPJ P, ;;; CHECK FOR ANY DELAYED "REAL TIME" INTERRUPTS, AND RUN THEM ;;; IF ANY. MUST DO THEM IN THE ORDER ^G/^X, CLOCKS, AND OTHER. ;;; NOTE THAT AFTER A ^G OR ^X, CHECKU GETS CALLED AGAIN. ;;; DESTROYS D AND F CHECKU: SKIPN UNREAL ;NONE CAN BE PENDING IF NOT DELAYING JRST NOINT0 CHECKQ: PUSH P,A PUSHJ P,UINTPU NOINT1: SKIPE (P) JRST NOINT5 SKIPE D,UNRC.G ;PROCESS ^G/^X FIRST JRST CKI2A ;TOP LEVEL OR ERRRTN WILL DO A CHECKU NOINT5: PUSHJ P,NOINTA ;NOW PROCESS ALARMCLOCK INTERRUPTS JRST NOINT1 NOINT3: SKIPG F,UNREAR ;NOW ANY OTHER INTERRUPTS JRST NOINT4 SOS UNREAR MOVE D,UNREAR(F) TRNE D,400000 ;IF (NOINTERRUPT 'TTY), SUPPRESS SKIPN (P) ; TTY INTERRUPTS AT THIS TIME PUSHJ P,YESINT ;MAY CLOBBER R (SEE UISTAK) JRST NOINT1 NOINT4: SKIPG A,UNREAL MOVEI A,TRUTH POP P,UNREAL JRST UINTEX ;;; DO NOT TRANSFORM THE "PUSHJ, POPJ" SEQUENCES INTO "JRST". ;;; YESINT DEPENDS ON LOOKING AT THE PUSHJ ADDRESS TO SEE WHETHER ;;; WE CAME FROM NOINTERRUPT OR ELSEWHERE! NOINTA: SKIPN D,UNRRUN JRST NOINT2 SETZM UNRRUN PUSHJ P,YESINT POPJ P, NOINT2: SKIPN D,UNRTIM JRST POPJ1 SETZM UNRTIM PUSHJ P,YESINT POPJ P, ENOINT::. .SEE UINT0N SUBTTL CAR/CDR ROUTINES AND FUNCTIONS ;;; HERE BELOW FOLLOW THE "FAST" CAR-CDR ROUTINES, ;;; USED WHEN *RSET=NIL, AND BY COMPILED CODE. ;;; NOTE THAT THE RELATIVE DISPLACEMENT OF THE FUNCTION ENTRY POINTS ;;; IS VERRRRRY IMPORTANT TO THE POOOR COMPLR. ;;; DONT EVER CHANGE THEM!! CARCDR: ;INDEX NUMBER FOR CALL BY COMPILED CODE %CADDDR: SKIPA A,(A) ; 0 %CADDAR: HLRZ A,(A) ; 1 %CADDR: SKIPA A,(A) ; 2 %CADAR: HLRZ A,(A) ; 3 %CADR: SKIPA A,(A) ; 4 %CAAR: HLRZ A,(A) ; 5 %CAR: HLRZ A,(A) ; 6 JRST (T) %CDDDDR: SKIPA A,(A) ; 8 %CDDDAR: HLRZ A,(A) ; 9 %CDDDR: SKIPA A,(A) ;10. %CDDAR: HLRZ A,(A) ;11. %CDDR: SKIPA A,(A) ;12. %CDAR: HLRZ A,(A) ;13. %CDR: HRRZ A,(A) ;14. JRST (T) %CAADDR: SKIPA A,(A) ;16. %CAADAR: HLRZ A,(A) ;17. %CAADR: SKIPA A,(A) ;18. %CAAAR: HLRZ A,(A) ;19. JRST %CAAR %CDADDR: SKIPA A,(A) ;21. %CDADAR: HLRZ A,(A) ;22. %CDADR: SKIPA A,(A) ;23. %CDAAR: HLRZ A,(A) ;24. JRST %CDAR %CAAADR: SKIPA A,(A) ;26. %CAAAAR: HLRZ A,(A) ;27. JRST %CAAAR %CDDADR: SKIPA A,(A) ;29. %CDDAAR: HLRZ A,(A) ;30. JRST %CDDAR %CDAADR: SKIPA A,(A) ;32. %CDAAAR: HLRZ A,(A) ;33. JRST %CDAAR %CADADR: SKIPA A,(A) ;35. %CADAAR: HLRZ A,(A) ;36. JRST %CADAR ;;; THE FOLLOWING TABLE IS A TRANSFER VECTOR: GIVEN THE INFO-NUMBER ;;; OF A CAR-CDR OPERATION, SAY N, THEN CARCDR[N-2] IS THE ;;; ADDRESS OF THE FAST ROUTINE FOR THAT OPERATION. NOTE THAT THE ;;; INFO-NUMBER IS NOT THE SAME AS THE INDEX-NUMBER-FOR-COMPILED-CODE ;;; ALSO, THE TOP 13. BITS ENCODE A DECOMPOSITON OF THE A-D STRING INTO ;;; 1) THE LEFT-MOST OPERATION - 1 BIT (1 FOR "D" AND 0 FOR "A"), ;;; 2) THE INFO NUMBER OF THE "TAIL" - 6 BITS ("TAIL" IS REMAINDER OF ;;; A-D STRING, E.G., "TAIL" OF "ADDAD" IS "DDAD") ;;; 3) THE "BOY ARE THESE NUMBERS RANDOM" NUMBER WHICH THE COMPILER ;;; USES WHEN OUTPUTTING FAST JSP CALLS THE THE %CARCDR ROUTINES. %CARCDR: IRP X,,[A,D AA,AD,DA,DD AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD]AD,,[0,1 0,0,1,1 0,0,0,0,1,1,1,1 0,0,0,0,0,0,0,0 1,1,1,1,1,1,1,1]TL,,[0,0 2,3,2,3 4,5,6,7,4,5,6,7 10,11,12,13,14,15,16,17 10,11,12,13,14,15,16,17] zz==%C!X!R AD_35.+TL_29.+_23.+zz TERMIN ICADRP: PUSH P,CFIX1 ;+INTERNAL-CARCDRP JSP T,IC.RP SETO TT, POPJ P, ;;; SKIPE IF CARCDR FUNCTION, WITH CODE WORD IN TT IC.RP: CAIL A,QCAR ;First CAILE A,QCDDDDR ;Last CARCDR sym JRST (T) 2DIF [HLRZ TT,(A)]%CARCDR,QCAR LSH TT,-5 JRST 1(T) ;;; STANDARD INTERPRETER SUBRS FOR THE VARIOUS CAR-CDR ;;; OPERATIONS. THESE CALL A CENTRAL DECODER WHICH IN *RSET ;;; MODE PERFORMS TYPE CHECKING ON THE OPERAND AT EACH STEP. CRSUBRS: IRP X,,[A,D,AA,AD,DA,DD AAA,AAD,ADA,ADD,DAA,DAD,DDA,DDD AAAA,AAAD,AADA,AADD,ADAA,ADAD,ADDA,ADDD DAAA,DAAD,DADA,DADD,DDAA,DDAD,DDDA,DDDD] C!X!R: JSP F,CR0 TERMIN ;;; LET A=0, D=1, AND LET CWXYZR BE A CAR-CDR OPERATION, WITH ;;; THE VARIABLES W,X,Y,Z RANGING OVER {,A,D}. LET A NUMBER N ;;; BE COMPUTED CORRESPONDING TO CXYZWR AS FOLLOWS: ;;; N = Z + 2 IF W,X,Y ARE NULL ;;; N = Y*2 + Z + 4 IF W,X ARE NULL ;;; N = X*4 + Y*2 + Z + 10 IF W IS NULL ;;; N = W*10 + X*4 + Y*2 + Z + 20 IF NONE OF W,X,Y,Z ARE NULL ;;; NOTE TWO THINGS: ;;; [1] THIS REPRESENTATION OF A CAR-CDR OPERATION IS EASILY ;;; BITWISE DECODABLE. THE POSITION OF THE FIRST 1 BIT ;;; INDICATES THE START OF THE REST OF THE ENCODING, WHICH HAS ;;; 0 FOR CAR, 1 FOR CDR AT EACH POSITION. ;;; [2] FOR ANY SET OF OPERATIONS COMPLETE FROM CAR AND CDR, ;;; THROUGH CAAR, CADR, ... TO "LEVEL M" CAR-CDR'S (THOSE WITH ;;; M A'S AND D'S), THIS ENCODING PRODUCES A COMPACT ENCODING, ;;; M+1 ;;; WITH N RANGING FROM 2 TO 2 -1 INCLUSIVE. ;;; ;;; NAME N (OCTAL) N (BINARY) ;;; CAR 2 10 ;;; CDR 3 11 ;;; CAAR 4 100 ;;; CADR 5 101 ;;; . . . ;;; CDDADR 35 11101 ;;; CDDDAR 36 11110 ;;; CDDDDR 37 11111 CR0: SKIPE V.RSET JRST CR1 POP P,T JRST @%CARCDR-(F) ;QUICK VERSION FOR *RSET = NIL CR1: PUSHJ P,SAVX3 ;COMPILED CODE ASSUMES NUMACS SAFE CR1A: MOVEI D,(A) 2DIF [MOVEI T,(F)]400002,CRSUBRS+1 ;400000 IS FOR CA.DER CR2: SKOTT D,LS ;CHECK FOR LIST TYPE JRST CR4 CR3: TRNE T,1 ;SKIP IF CAR OPERATION SKIPA D,(D) HLRZ D,(D) ROT T,-1 TRNE T,776 ;SKIP IF ALL DONE JRST CR2 CR7: MOVEI A,(D) JRST RSTX3 ;COMPILED CODE ASSUMES NUMACS SAFE CR4: TRNE T,1 ;IF NEXT ARG ISN'T A LIST SKIPA R,VCDR ;THEN CHECK OUT AGAINST PERMISSIBLITIES MOVE R,VCAR JUMPN R,CR5 TRNN D,-1 ;IF ONLY NIL AND LISTS PERMISSIBLE JRST CR7 ;THEN LET NIL BECOME NIL (CAR NIL) = (CDR NIL) = NIL JRST CA.DER ;ELSE, BOMB OUT CR5: CAIE R,QSYMBOL JRST CR6 TRNE D,-1 TLNE TT,SY JRST CR3 JRST CA.DER ;LOSE IF NEITHER NIL NOR SYMBOL CR6: CAIN R,QLIST JRST CA.DER ;LIST TEST ON ARG HAS ALREADY FAILED, SO FAIL JRST CR3 ;IF CAR,CDR NOT "LIST", "SYMBOL", OR "NIL", ; THEN OK FOR ANYTHING ;;; NTH and NTHCDR - if *RSET is off, try to do fastly ; (NTH N FOO) RETURNS THE NTH CAR [WHERE (NTH 0 FOO) IS (CAR FOO)] ; EQUIVALENT TO (CAR (NTHCDR N FOO)) ; (NTHCDR N FOO) RETURNS THE RESULT OF 'N' CDR'S NTH: TDZA R,R NTHCDR: MOVEI R,TRUTH ;R IS "NTHCDR"P FLAG - () ==> "NTH" NTHCD5: SKIPN D,V.RSET JRST NTHCD6 SKOTT A,FX JRST NTHIEN NTHCD6: MOVE TT,(A) JUMPLE TT,NTHCD0 ;MUST BE NON-NEGATIVE EXCH A,B ;RESULT TO BE RETURNED IN A JUMPN D,NTHCD2 ;*RSET ==> DO ERROR CHECK ON EACH ELEMENT NTHCD1: HRRZ A,(A) ;DO A CDR SOJG TT,NTHCD1 ;LOOP UNTIL APPROPRIATE NUMBER OF CDR'S DONE JUMPE R,$CAR POPJ P, ;THEN RETURN NTHCD0: JUMPN TT,NTHIEN ;INDEX "0" EXCH A,B JUMPN R,CPOPJ ;JUST EXIT FOR NTHCDR JUMPE D,$CAR ;BECOME "CAR" FOR (NTH 0 X) JRST CAR NTHCD2: MOVE F,(B) SOS F PUSHJ P,LASTCK ;TAKE "(F)" CDRS, SKIP IF SUCCESSFUL JRST NTHER ; ERROR IF ARG-1 CDRS IS ATOMIC JUMPN R,NTHCD4 HRRZ D,(D) SKOTT D,LS JUMPN D,NTHER HLRZ A,(D) ;FOR "NTH" POPJ P, NTHCD4: HRRZ A,(D) ;FOR "NTHCDR", TAKE FINAL CDR POPJ P, SUBTTL SYMBOL CONSER PNGNK: ADDI C,PNBUF-1 ;ONLY BY INTERN - PURIFIES PNAME IF RELEVANT SKIPGE LPNF ;IF LPNF IS NEGATIVE, THE PNAME IS IN PNBUF, PUSHJ P,PNCONS ; SO WE CONS IT UP NOW SKIPE B,V.PURE CAIN B,QSYMBOL JRST SYCONS ;NO PURE COPY NEEDED, JUST CONS UP SYMBOL PUSHJ P,PURCOPY ;ELSE GET PURE COPY OF PNAME JRST PSYCONS ;AND USE PURE CONSER PNGNK1: SKIPGE LPNF ;CONS UP PNAME IF NECESSARY PNGNK2: PUSHJ P,PNCONS SYCONS: ;CONS UP A SYMBOL - PNAME LIST IS IN A BAKPRO SKIPN FFY ;IF SYMBOL FREELIST EMPTY, GO DO A GC JRST SYCON1 SKIPN B,FFY2 ;IF SYMBOL BLOCK FREELIST EMPTY, MUST GC JRST SYCON1 MOVEM A,SYMPNAME(B) ;PUT PNAME IN SYMBOL BLOCK MOVE A,[SY.ONE,,SUNBOUND] ;INITIAL VALUE CELL IS SUNBOUND XCTPRO EXCH A,SYMVC(B) ;PUT IN SYMBOL BLOCK MOVEM A,FFY2 ;CDR SYMBOL BLOCK FREELIST SYCON2: MOVSI A,(B) ;INITIAL PROPERTY LIST IS NIL EXCH A,@FFY ;CONS UP SYMBOL HEADER EXCH A,FFY NOPRO POPJ P, SPECPRO INTSYX SYCON1: PUSHJ P,AGC JRST SYCONS ;PURE SYMBOL CONSER PSYCONS: BAKPRO AOSL B,NPFFY2 ;CONS UP A PURE SYMBOL BLOCK NOPRO SPECPRO INTSYQ PUSHJ P,GTNPSG ADD B,EPFFY2 AOS NPFFY2 SPECPRO INTSYP MOVEM A,SYMPNAME(B) MOVE A,[SY.ONE+SY.PUR,,SUNBOUND] ;SY.PUR BIT SAYS MAYBE READ-ONLY MOVEM A,SYMVC(B) BAKPRO SKIPE FFY ;IF SYMBOL FREELIST EMPTY, GO DO A GC JRST SYCON2 PUSHJ P,AGC JRST SYCON2 NOPRO PNCONS: PUSH FXP,T ;CONS A PNAME LIST OUT OF PNBUF MOVEI A,NIL 2DIF [MOVEI C,(C)]1,PNBUF PNG2: MOVE B,A MOVE TT,PNBUF-1(C) JSP T,FWCONS PUSHJ P,CONS SOJG C,PNG2 CPXTJ: JRST POPXTJ SUBTTL LIST SPACE CONSERS ;;; THIS SET OF CONSERS IS USED WITHIN THE LISP SYSTEM. ;;; ONLY A AND B ARE CLOBBERED, AND THE ARGUMENTS MUST NOT ;;; BE PDL QUANTITIES. ;;; FOR NCONS, SEE JUST BEFORE "ACONS" ;NCONS: TRZA B,-1 ;(NCONS A) = (CONS A NIL) XCONS: EXCH B,A ;(XCONS A B) = (CONS B A) CONS: HRL B,A SPECPRO INTC2X CONS1: SKIPN A,FFS ;SKIP UNLESS FREELIST EMPTY JRST CONS3 EXCH B,(A) ;PUT POINTERS IN CELL, GET CDR OF FREELIST XCTPRO EXCH B,FFS ;CDR FREELIST, COPY OF CELL POINTER TO B NOPRO ; (BUT NO ONE CURRENTLY TAKES ADVANTAGE OF IT) POPJ P, SPECPRO INTC2X CONS3: HLR A,B ;DO THIS TO PROTECT POINTERS FROM GC PUSHJ P,AGC ;PERFORM A GARBAGE COLLECTION NOPRO JRST CONS1 ;GO TRY AGAIN ;;; THIS SET OF CONSERS IS THE SET AVAILABLE TO INTERPRETED CODE. ;;; THEY MAKE SURE THAT PDL QUANTITIES DO NOT GET INTO LIST STRUCTURE. $NCONS: MOVEI B,NIL ;SUBR 1 EXCH A,B $XCONS: JSP T,PDLNMK ;SUBR 2 EXCH A,B JSP T,PDLNMK JRST CONS LIST.: AOJG T,LIST.9 ;LSUBR (1 . N) POP P,A ;(CONS A B C D) = (CONS A (CONS B (CONS C D))) PUSH FXP,R ;THIS ROUTINE MUST SAVE R AS COMPILED CODE COUNTS ON IT MOVE R,T ;LISTX3 WILL WANT COUNT IN R - ALSO SAVE OVER PDLNMK JSP T,PDLNMK PUSHJ FXP,LISTX3 ;LISTIFY ALL BUT LAST ARG, POP FXP,R POPJ P, ; WITH LAST ARG AS FINAL CDR ;;; THIS SET OF CONSERS IS CALLED FROM COMPILED CODE. ;;; THE "CDR" MUST NOT BE A PDL QUANTITY; THE "CAR" IS PDLNMK'D. %PDLNC: TRZA B,-1 %PDLXC: EXCH B,A %PDLC: CAML A,NPDLL ;VERY FAST CHECK FOR A PDL NUMBER CAMLE A,NPDLH JRST %CONS PUSH P,T ;IF PROBABLY A PDL NUMBER, JSP T,PDLNM0 ; IT'S SO SLOW THAT THIS PART ; DOESN'T MATTER SO MUCH, JRST CONS ; BLETCHEROUS IS IT IS ;;; THIS SET OF CONSERS IS CALLED FROM COMPILED CODE. ;;; ARGUMENTS MUST NOT BE PDL QUANTITIES. ;;; THESE ARE SLIGHTLY FASTER, SINCE T IS USED FOR JSP. ;;; FOR %NCONS, SEE JUST BEFORE "ACONS" ;%NCONS: TRZA B,-1 ;(NCONS A) = (CONS A NIL) %XCONS: EXCH B,A ;(XCONS A B) = (CONS B A) %CONS: HRLI B,(A) SPECPRO INTC2Y %CONS1: SKIPN A,FFS ;SKIP UNLESS FREELIST EMPTY JRST %CONS3 EXCH B,(A) ;PUT POINTERS IN CELL, GET CDR OF FREELIST XCTPRO EXCH B,FFS ;CDR FREELIST, COPY OF CELL POINTER TO B NOPRO ; (BUT NO ONE CURRENTLY TAKES ADVANTAGE OF IT) JRST (T) SPECPRO INTC2Y %CONS3: HLR A,B ;DO THIS TO PROTECT POINTERS FROM GC PUSHJ P,AGC ;PERFORM A GARBAGE COLLECTION NOPRO JRST %CONS1 ;GO TRY AGAIN ;THIS ROUTINE IS FOR COMPILED CODE. IT DOES A PDLNMK CHECK ON BOTH ARGS %C2NS: PUSH P,T ;ALLOW RETURN VIA PUSHJ $C2NS: EXCH A,B ;WE CAN USE $XCONS, BUT IT WILL ALSO DO AN EXCH JRST $XCONS SUBTTL NUMBER CONSERS FIX2: JSP T,IFIX ;FLONUM TO FIXNUM CONVERSION, FXCONS, POPJ FIX1: POP P,T ;FXCONS, THEN POPJ FXCONS: ;FIXNUM CONS - MAY UNIQUIZE FIX1A: CAIGE TT,XHINUM ;IF WITHIN THE RANGE OF THE CAMGE TT,[-XLONUM] ; BUILT-IN TABLE OF UNIQUE FIXNUMS, JRST FWCONS ; THEN NEEDN'T DO A REAL CONS MOVEI A,IN0(TT) ;JUST PROVIDE A POINTER INTO THE TABLE JRST (T) SPECPRO INTZAX FWCONS: SKIPN A,FFX ;FULL WORD CONS - ALWAYS CONSES JSP A,AGC4 EXCH TT,(A) XCTPRO EXCH TT,FFX NOPRO JRST (T) FLCONX: AOJA T,FLCONS ;FLCONS WITH SKIP RETURN FLOAT2: JSP T,IFLOAT ;FIXNUM TO FLONUM, FLCONS, POPJ FLOAT1: POP P,T ;FLCONS, THEN POPJ SPECPRO INTZAX FLCONS: ;FLONUM CONS FPCONS: SKIPN A,FFL JSP A,AGC4 EXCH TT,(A) XCTPRO EXCH TT,FFL NOPRO JRST (T) IFN DBFLAG,[ DBL1: POP P,T SPECPRO INTZAX DBCONS: HRRZS FFD ;DOUBLE PRECISION CONSER SKIPN A,FFD JSP A,AGC4 EXCH TT,(A) XCTPRO EXCH TT,FFD NOPRO MOVEM D,1(A) JRST (T) ] ;END OF IFN DBFLAG IFE DBFLAG,[ DBCONS: PUSH P,T DBL1: MOVEI A,QDOUBLE ;ERROR IF DOUBLES NOT IMPLEMENTED %FAC NUM1MS ] ;END OF IFE DBFLAG IFN CXFLAG,[ CXCONX: AOJA T,CXCONS ;CXCONS WITH SKIP RETURN CMPL1: POP P,T SPECPRO INTZAX CXCONS: HRRZS FFC ;COMPLEX NUMBER CONSER SKIPN A,FFC JSP A,AGC4 EXCH TT,(A) XCTPRO EXCH TT,FFC NOPRO MOVEM D,1(A) JRST (T) ] ;END OF IFN CXFLAG IFE CXFLAG,[ CXCONS: PUSH P,T CMPL1: MOVEI A,QCOMPLEX ;ERROR IS COMPLEX NUMBERS NOT IMPLEMENTED %FAC NUM1MS ] ;END OF IFE CXFLAG IFN DXFLAG,[ DUPL1: POP P,T SPECPRO INTZAX DXCONS: HRRZS FFZ ;DOUBLE-PRECISION COMPLEX NUMBER CONSER SKIPN A,FFZ JSP A,AGC4 EXCH R,(A) XCTPRO EXCH R,FFZ NOPRO MOVEM F,1(A) KA MOVEM TT,2(A) KA MOVEM D,3(A) KIKL DMOVEM TT,2(A) JRST (T) ] ;END OF IFN DXFLAG IFE DXFLAG,[ DXCONS: PUSH P,T DUPL1: MOVEI A,QDUPLEX ;ERROR IF DUPLICES NOT IMPLEMENTED %FAC NUM1MS ] ;END OF IFE DXFLAG SUBTTL HUNK PRIMITIVES - CXR, RPLACX, HUNK, HUNK, HUNKIFY IFE HNKLOG,[ %HUNK1: %HUNK2: %HUNK3: %HUNK4: %CXR: %RPX: LERR [SIXBIT \NO HUNKS IN THIS LISP - HUNK/CXR/RPLACX!\] ] ;END OF IFE HNKLOG IFN HNKLOG,[ CXR: JSP T,FXNV1 ;SUBR 2 SKIPE V.RSET JSP F,CXR3 ;CHECK ARGS ROT TT,-1 ADDI TT,(B) JUMPGE TT,CXR2 HLRZ A,(TT) ;ODD-NUMBERED COMPONENTS IN LEFT HALVES POPJ P, CXR2: HRRZ A,(TT) ;EVEN-NUMBERED COMPONENTS IN RIGHT HALVES POPJ P, RPLACX: JSP T,FXNV1 ;SUBR 3 SKIPE V.RSET JSP F,CXR3 ;CHECK ARGS CAML C,NPDLL CAMLE C,NPDLH JRST .+4 EXCH A,C JSP T,PDLNMK ;SIGH - MUST PDLNMK THE DATUM EXCH A,C ROT TT,-1 ADDI TT,(B) JUMPGE TT,RPLX2 HRLM C,(TT) JRST BRETJ ;RETURN SECOND ARG RPLX2: HRRM C,(TT) JRST BRETJ CXR30: TLNN T,$FS+VC ;A LIST CELL OR VALUE CELL IS OKAY JRST CXR31 ; IF THE INDEX IS 0 OR 1 JUMPL TT,CXR33 CAIG TT,1 JRST (F) CXR31: EXCH A,B WTA [INVALID OR WRONG LENGTH HUNK!] EXCH A,B CXR3: MOVEI T,(B) ;CHECKING ROUTINE FOR CXR/RPLACX LSH T,-SEGLOG MOVE T,ST(T) TLNN T,HNK ;SECOND ARG MUST BE HUNK JRST CXR30 MOVEI D,2 2DIF [LSH D,(T)]0,QHUNK0 CAMLE D,TT ;FIRST ARG MUST BE SMALLER THAN JUMPGE TT,CXR34 ; LENGTH OF SECOND, YET NON-NEGATIVE CXR33: WTA [BAD HUNK INDEX!] JRST -3(F) CXR34: MOVE D,TT ;EVERYTHING IS APPARENTLY OKAY ROT D,-1 ADDI D,(B) HRRZ T,(D) ;FETCH COMPONENT IN QUESTION SKIPGE D HLRZ T,(D) CAIN T,-1 ;ERROR IF AN UNUSED COMPONENT JRST CXR33 JRST (F) ;;; IFN HNKLOG ;;; CXR ROUTINE FOR COMPILED CODE. HUNK IN A, INDEX IN TT. %CXR: ROT TT,-1 ;QUICK ENTRY FOR COMPILED CALLS ADDI TT,(A) JUMPGE TT,%CXR2 HLRZ A,(TT) JRST (T) %CXR2: HRRZ A,(TT) JRST (T) ;;; RPLACX ROUTINE FOR COMPILED CODE. ;;; HUNK IN A, DATUM IN B, INDEX IN TT. ;;; THE DATUM IS GUARANTEED NOT TO BE A PDL QUANTITY. %RPX: ROT TT,-1 ;HUNK SUBSCRIPT IS PASSED IN TT ADDI TT,(A) JUMPGE TT,%RPX2 HRLM B,(TT) JRST (T) %RPX2: HRRM B,(TT) JRST (T) ;;; %HUNK1, %HUNK2, %HUNK3, AND %HUNK4 ROUTINES FOR COMPILED CODE. ;;; THESE ALLOCATE HUNKS OF SIZE 1, 2, 3, OR 4 SUPER-QUICKLY. ;;; ARGUMENTS IN A, B, C, AR1, GUARANTEED NOT TO BE PDL QUANTITIES. %HUNK1: SKIPN VMAKHUNK JRST %NCONS MOVEI B,(A) ;%HUNK1 IS %HUNK2, WITH ONE UNUSED COMPONENT, MOVEI A,-1 ; BUT UNFORTUNATELY MUST SHUFFLE ARGS JRST %HUNK2 %HNK2A: HRRZS FFH ;HUNK4 IS THE IMPORTANT CASE PUSHJ P,AGC BAKPRO %HUNK2: SKIPN VMAKHUNK JRST %CONS SKIPG FFH JRST %HNK2A HRL B,A EXCH B,@FFH XCTPRO EXCH B,FFH EXCH A,B NOPRO JRST (T) %HUNK3: MOVEI AR1,(C) ;HUNK3 IS JUST HUNK4, WITH ONE UNUSED COMPONENT MOVEI C,-1 ; BUT UNFORTUNATELY MUST SHUFFLE ARGS JRST %HUNK4 %HNK4A: HRRZS FFH+1 ;HUNK4 IS THE IMPORTANT CASE PUSHJ P,AGC BAKPRO %HUNK4: SKIPG FFH+1 JRST %HNK4A HRL AR1,A EXCH AR1,@FFH+1 XCTPRO EXCH AR1,FFH+1 EXCH A,AR1 HRRZM B,1(A) HRLM C,1(A) NOPRO JRST (T) ;; For various misc hacks of REES and RWK. Exchange hunk and A. ;; Only makes sense in very strange hand-code. IFN USELESS,[ %HNKRA: HRRZS FFH+1 ;Be sure sign bit is off PUSHJ P,AGC BAKPRO %HNK4R: SKIPG FFH+1 JRST %HNKRA EXCH A,@FFH+1 ;Pick up sticks XCTPRO EXCH A,FFH+1 ;A -> Hunk with old contents of A NOPRO JRST (T) ] ;;; IFN HNKLOG HNKSZ0: WTA [NOT A HUNK - HUNKSIZE!] JRST HNKSZ1 HUNKSIZE: ;SUBR 1 - NCALLABLE PUSH P,CFIX1 HNKSZ1: MOVEI T,(A) LSH T,-SEGLOG SKIPL T,ST(T) JRST HNKSZ0 MOVEI TT,2 TLNE T,HNK JRST .+4 SKIPN VMAKHUNK POPJ P, ;RANDOM CONSES ARE OF SIZE 2 JRST HNKSZ0 MOVEI D,1 2DIF [LSHC TT,(T)]0,QHUNK0 ADDI D,-1(A) HNKSZ3: SETCM R,(D) ;OTHERWISE CALCULATE LENGTH TLNE R,-1 POPJ P, TRNE R,-1 SOJA TT,CPOPJ SUBI D,1 SUBI TT,2 JUMPG TT,HNKSZ3 .VALUE HUNKP: LSH A,-SEGLOG ;SUBR 1 SKIPGE A,ST(A) TLNN A,HNK JRST FALSE JRST TRUE MHUNKE: WTA [MUST BE LIST OR FIXNUM - MAKHUNK!] MAKHUNK: SKOTT A,FX ;SUBR 1 JRST MHUNK5 SKIPN TT,(A) JRST FALSE MOVE T,TT PUSHJ P,ALHUNK ;INITIALIZED TO NIL MHUNK7: LSHC T,-1 ;LEAVES THE "ODDP" BIT IN SIGN OF TT HRLOI T,-1(T) ;SEE HAKMEM FOR THIS EQVI HAK EQVI T,(A) TLNN T,-1 JRST MHUNK6 SETZM (T) AOBJN T,.-1 MHUNK6: SKIPGE TT HLLZS (T) POPJ P, MHUNK5: JUMPGE TT,MHUNKE .SEE LS JSP TT,AP2 ;STACK LIST ON PDL, -COUNT IN T HUNK: MOVN TT,T ;LSUBR AOJG T,FALSE ;CREATE HUNK BIG ENOUGH TO MOVEI D,QHUNK ; HOLD ALL GIVEN ARGUMENTS, CAILE TT,2_HNKLOG SOJA T,WNALOSE PUSHJ FXP,ALHNKL ; AND INSTALL THEM POPJ P, ;;; IFN HNKLOG ;;; HUNK ALLOCATION ROUTINES ;;; MAKE A HUNK - (TT) HAS NUMBER OF ITEMS WANTED. ;;; THEN INSTALL THESE ITEMS FROM PDL BY POPPING OFF ALHNKL: PUSH FXP,TT PUSHJ P,ALHUNK ;CREATE A FRESH HUNK, AND INSTALL ARGS FROM PDL MOVEI B,(A) ;SAVES C - ALSO USED BY FASLOAD POP P,A .SEE LDLHNK JSP T,PDLNMK ;CAN'T PUT PDL QUANTITY INTO A HUNK HRROM A,(B) ;LAST ELEMENT GOES IN POSITION 0 SOSN TT,(FXP) JRST ALHNLY LSHC TT,-1 ;IN D, SIGN BIT ON ==> EVEN NUMBER OF ELEMENTS MOVEI T,(B) ADDI T,(TT) EXCH D,T ;NOW IN D - LAST WORD INTO WHICH TO POP JUMPGE T,ALHNLD ALHNLA: POP P,A ;LOOP TO INSTALL ARGS IN HUNK JSP T,PDLNMK HRLM A,(D) ALHNLD: SOJL TT,ALHNLX POP P,A JSP T,PDLNMK HRRM A,(D) SOJA D,ALHNLA ALHNLY: SKIPN VMAKHUNK HRLZS (B) ALHNLX: POPI FXP,1 EXCH A,B POPJ FXP, ;;; ALLOCATE A HUNK OF SIZE INDICATED IN (TT) ;;; AND INITIALIZE TO THE "UNUSED" POINTER (#777777) ALHUNK: JUMPLE TT,ALHNKE ;PRESERVES AR1,AR2A - SEE SUBST CAILE TT,2_HNKLOG ;MUST PRESERVE T JRST ALHNKE SUBI TT,1 JFFO TT,ALHNKD ;SELECT CONSER FOR CORRECT SIZE HUNK JRST ALHNKF ALHNKD: JRST ALHNKF-35.(D) ;DISPATCH TO INDIVIDUAL HUNK CONSERS BELOW RADIX 10. REPEAT HNKLOG, JRST CONC ALHNK,\ RADIX 8 ALHNKF: SKIPE VMAKHUNK ;1 OR 2 THINGS - TEST FOR USE OF CONS JRST ALHNK0 JRA A,ACONS ;;; HUNK IS THE CONSER FOR HUNKS OF SIZE 2^ WORDS. ;;; index no.: 0 1 2 3 4 5 6 7 8 9 ;;; no. words: 1 2 4 8 16 32 64 128 256 512 ;;; no. items: 2 4 8 16 32 64 128 256 512 1024 ;;; WARNING! THESE CONSERS MUST PRESERVE T .SEE MHUNK7 REPEAT HNKLOG+1,[ SPECPRO INTZAX RADIX 10. CONC GHNK,\.RPCNT,: HRRZS FFH+.RPCNT ;FLUSH SIGN BIT - NEED A HUNK NOW SKIPN A,FFH+.RPCNT ;INITIATE GC DUE TO HUNKS JSP A,AGC4 CONC ALHNK,\.RPCNT,: ;VARIOUS HUNK CONSERS: HUNK0, HUNK1, ... SKIPG A,FFH+.RPCNT JRST CONC GHNK,\.RPCNT HRRZ TT,(A) RADIX 8 XCTPRO MOVEM TT,FFH+.RPCNT SETOM (A) ;MUST FILL IN COMPONENTS WITH THE "UNUSED" POINTER IFLE .RPCNT-2, REPEAT <1_.RPCNT>-1, SETOM .RPCNT+1(A) IFG .RPCNT-2,[ MOVEI D,1(A) HRLI D,(A) BLT D,<1_.RPCNT>-1(A) ] NOPRO POPJ P, ] ;END OF REPEAT HNKLOG ] ;END OF IFN HNKLOG SUBTTL ATOM, PLIST, SETPLIST, ASSOC AND FRIENDS ATOM: LSH A,-SEGLOG ;CAN DO LSH HERE BECAUSE DON'T NEED ARG SKIPGE ST(A) ;FALSE ONLY FOR NON-ATOMIC TDZA A,A ; FREE-STORAGE POINTERS MOVEI A,TRUTH POPJ P, LATOM: ;SKIP IF EQ TEST IS SUFFICIENT FOR EQUALITY SPATOM: JUMPE A,1(T) ;SKIP IF NIL (WHICH IS SYMBOL) SPAT1: SKOTT A,SY ;LEAVES TYPE BITS IN TT JRST (T) JRST 1(T) PRPLSE: JUMPE A,PRPNIL JRST FALSE PLIST: SKOTT A,SY+LS ;SUBR 1 - FETCH PROPERTY LIST JRST PRPLSE HRRZ A,(A) POPJ P, PRPNIL: HRRZ A,NILPROPS ;SPECIAL HACK FOR NIL POPJ P, RPLIZ: JUMPE A,RPSNIL %WTA NASER SETPLIST: SKOTT A,SY+LS ;SUBR 2 - SET PROPERTY LIST JRST RPLIZ HRRM B,(A) MOVE A,B POPJ P, RPSNIL: HRRM B,NILPROPS ;SPECIAL HACK FOR NIL POPJ P, STENT: MOVEI TT,(A) ;GET ST ENTRY FOR A IN TT LSH TT,-SEGLOG ;FOR USE WHERE SPACE MORE IMPORTANT THAN TIME MOVE TT,ST(TT) JRST (T) VALLCE: WTA [NON-SYMBOL - VALUE-CELL-LOCATION!] JRST VALLC1 VALLOC: PUSH P,CFIX1 VALLC1: JUMPE A,VLCNIL JSP T,SPATOM JRST VALLCE HLRZ TT,(A) HRRZ TT,(TT) CAIN TT,SUNBOUND SETZ TT, POPJ P, VLCNIL: MOVEI TT,VNIL POPJ P, SASSQ: SKIPA T,ASSQ ;[IASSQ] SASSOC: MOVEI T,IASSOC PUSHJ P,(T) CALLF 0,(C) POPJ P, ASSOC: SKIPA T,SASSOC ;[IASSOC] ASSQ: MOVEI T,IASSQ PUSHJ P,(T) ;.SEE SSGCP1 - MUST PRESERVE R FALSE: MOVEI A,NIL POPJ P, IASSOC: MOVEI F,TRUTH ;INTERNAL "ASSOC" JSP T,LATOM JRST IASSC0 IASSQ: MOVEI F,NIL SKIPN V.RSET JRST IASSQF ;FAST VERSION OF ASSQ WITH NO CHECKING IASSC0: SAVE B F A B ;ASSOC LOOP WITH CHECKING MOVE TT,B JRST IASSC7 IASSC3: HLRZ TT,T MOVEM TT,(P) ;(P) HOLDS SUCCESSIVE TAILS OF LIST IASSC7: SKOTT TT,LS JRST IASSC4 MOVS T,@(P) SKOTT T,LS JRST IASSC3 ; "NIL" ENTRIES GET BYPASSED HERE HLRZ B,(T) CAMN B,-1(P) ;-1(P) HOLDS ITEM BEING SOUGHT JRST IASSCX SKIPN -2(P) ;-2(P) FLAG = () FOR ASSQ, NON-() FOR ASSOC JRST IASSC3 MOVE A,-1(P) PUSHJ P,EQUAL MOVS T,@(P) JUMPE A,IASSC3 IASSCX: POP P,B POPI P,3 JRST IASWIN IASSC4: SKIPN (P) JRST IASLOS JSP T,MEMQER JRST IASSC3 IASLOS: POPI P,4 POPJ P, IASSQ0: HLRZ B,T IASSQF: JUMPE B,CPOPJ ;FAST VERSION OF ASSQ WITH NO CHECKING MOVS T,(B) ; MUST PRESERVE AR2A - SEE FASLAP HLRZ TT,(T) ; NOTE - MUST NOT USE OTHER THAN A, B, T, TT CAIE A,(TT) ; BECAUSE OF ASSQ'S FOR READ CHAR MACROS JRST IASSQ0 TRNN T,-1 ;SPURIOUS MATCH OF "()" WITH NULL SLOT JRST IASSQ0 ; E.G. ((A . 1) () (() . 5)) IASWIN: POP P,T HLRZ A,(B) ;BUT EXIT BY SKIPPING IF WIN, LEAVING FINAL JRST 1(T) ; TAIL IN (B) - .SEE SSGCP1 ;(DEFUN DISPLACE (X Y) ; (AND (ATOM X) (ERROR '|NOT A LIST - DISPLACE| X)) ; (COND ((ATOM Y) ; (RPLACA X 'PROGN) ; (RPLACD X (NCONS Y))) ; ('T (RPLACA X (CAR Y)) ; (RPLACD X (CDR Y))))) DISPL0: WTA [NOT A LIST - DISPLACE!] DISPLACE: MOVEI TT,(A) ;INSURE FIRST ARG IS A LIST LSH TT,-SEGLOG SKIPL ST(TT) ;IS IT? JRST DISPL0 MOVEI TT,(B) ;CHECK WHETHER SECOND ARG IS LIST OR NOT LSH TT,-SEGLOG SKIPL ST(TT) ;LIST? JRST DISPL1 ;NOPE, SPECIAL TREATMENT DISPL2: HLRZ AR1,(B) ;CAR Y HRLM AR1,(A) ;RPLACA X HRRZ AR1,(B) ;CDR Y HRRM AR1,(A) ;RPLACD X POPJ P, ;RETURN X DISPL1: MOVEI C,QPROGN HRLM C,(A) ;(RPLACA <1ST-ARG> 'PROGN) PUSH P,A ;NOW (NCONS <2ND ARG>) MOVEI A,(B) PUSHJ P,$NCONS HRRM A,@(P) ;(RPLACD <1ST-ARG> (NCONS <2ND-ARG>)) POP P,A ;RETURN FIRST ARG POPJ P, SUBTTL GET, GETL, PUTPROP, REMPROP FUNCTIONS $GET: SKOTTN A,LS+SY JRST GET1 GET3: JUMPN A,FALSE MOVEI A,NILPROPS JRST GET1 GET0: HRRZ A,(TT) ;USES ONLY A,B,TT JUMPE A,CPOPJ GET1: HRRZ TT,(A) ;MUST PRESERVE B, C, AR1, T, D JUMPE TT,FALSE ;(SEE EVAL AT EV3, MKNAM3, SETF1B, .REARRAY, AND ARRY1) HLRZ A,(TT) ;ALSO PRESERVE R, SEE UUOH1 CAIE A,(B) ;ALSO AR2A AND F, SEE FASLOAD JRST GET0 HRRZ TT,(TT) HLRZ A,(TT) POPJ P, SARGET: MOVEI TT,(A) LSH TT,-SEGLOG MOVE TT,ST(TT) TLNE TT,SA POPJ P, ARGET: JSP T,SPATOM ;GET ARRAY PROPERTY FROM ATOM JSP T,PNGE1 ARGET1: MOVEI B,QARRAY JRST GET1 PNGET: JSP T,SPATOM ;INTERNAL SUBROUTINE -GET PNAME PROP FROM ATOM PNGT1: JSP T,PNGE PNGT0: SKIPN A ;SAVES B SKIPA TT,[$$$NIL] HLRZ TT,(A) ;MUST DO IT INTO TT SO AS TO HAVE HRRZ A,1(TT) ; CONTINUOUS GC PROTECTION POPJ P, .SEE CRSR40 GETL: SKIPN V.RSET JRST GETL5 SKOTT B,LS JUMPN B,GETLE GETLA: MOVEI TT,(A) LSH TT,-SEGLOG MOVE TT,ST(TT) TLNE TT,LS+SY JRST GETL1 JUMPN A,FALSE ;FALL INTO GETL5 - WON'T HURT GETL5: JUMPN A,GETL1 MOVEI A,NILPROPS GETL1: JUMPE B,FALSE ;FLUSH DEGENERATE CASE OF NO PROPS JRST GETL1A GETL0: HRRZ A,(A) ;USES A,B,C,T,TT JUMPE A,CPOPJ GETL1A: HRRZ A,(A) ;GET NEXT OFF PROPERTY LIST JUMPE A,CPOPJ HLRZ T,(A) MOVE C,B GETL4: HLRZ TT,(C) ;MEMQ IT DOWN LIST OF PROPS CAIN T,(TT) POPJ P, HRRZ C,(C) JUMPN C,GETL4 JRST GETL0 ;;; ARGUMENTS ARE A SYMBOL, A VALUE, AND AN INDICATOR. ;;; THE INDICATOR MUST NOT BE A PDL QUANTITY (RECALL THAT THE ;;; EQNESS OF SUCH QUANTITIES IS UNDEFINED IN THE LANGUAGE ANYWAY). ;;; THE VALUE IS PDLNMK'D IF NECESSARY. THE SYMBOL MAY BE A LIST ;;; (KNOWN AS A "DISEMBODIED PROPERTY LIST"; THE CDR IS THE PLIST). ;;; IF THE PROPERTY ALREADY EXISTS, THE NEW VALUE IS INSTALLED THERE. ;;; OTHERWISE A NEW PROPERTY IS INSTALLED AT THE FRONT OF THE ;;; PROPERTY LIST. IF THE PROPERTY ALREADY EXISTS IN A PORTION ;;; OF THE PROPERTY LIST THAT IS PURE, ENOUGH OF THE PURE PART ;;; IS COPIED AS IMPURE LIST STRUCTURE TO PERMIT THE PUTPROP. ;;; IF THE VALUE OF *PURE IS NON-NIL, THEN THE VALUE IS PURCOPY'D ;;; AND THE NEW PROPERTY LIST CELLS, IF ANY, ARE PURE-CONSED. PUTPROP: SKOTT A,LS+SY ;LISTS AND SYMBOLS ARE OKAY JRST CSET7 CSET0C: CAML B,NPDLL ;MAKE A QUICK TEST ON THE SECOND ARGUMENT CAML B,NPDLH ;SHIP-OF-THE-DESERT TEST (TWO CAML'S) JRST CSET0Q EXCH B,A ;LOSE - MUST PDLNMK THE VALUE JSP T,PDLNMK EXCH B,A CSET0Q: MOVEI T,(A) CSET0: HRRZ T,(T) ;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT JUMPE T,CSET2 ;SEARCH FOR AN EXISTING PROPERTY HLRZ TT,(T) HRRZ T,(T) CAIE TT,(C) JRST CSET0 CSET0A: ;IF PROPERTY FOUND, CLOBBER IN PURTRAP CSET4,T,HRLM B,(T) BRETJ: SPROG2: MOVEI A,(B) ;RETURN VALUE POPJ P, CSET7: JUMPN A,PROPER MOVEI A,NILPROPS JRST CSET0C CSET2: PUSH P,A ;DOESN'T HAVE SUCH A PROPERTY, SO CONS ONE UP SKIPE V.PURE JRST CSETP1 ;MAYBE WANT TO PURE-CONS CSET2A: HRRZ A,(A) ;PLAIN VANILLA CONSES PUSHJ P,XCONS HRRZ B,C JSP T,%PDLXC ;IN CASE SOMEONE TRIES TO USE A PDLNUM POP P,C HRRM A,(C) ;SETPLIST TO NEW THING $CADR: HRRZ A,(A) ;RETURN VALUE (I.E. GET IT BACK) $CAR: HLRZ A,(A) C$CAR: POPJ P,$CAR CSET4: PUSH P,A ;FOOL PROPERTY IS IN A PURE PAGE PUSH P,B MOVEI T,(A) CSET4A: HRRZ TT,(T) ;COPY ENOUGH OF THE PROPERTY LIST PUSHJ P,CSET4C ; TO PERMIT THE PUTPROP HLRZ A,(TT) CAIE A,(C) JRST CSET4A POP P,B POP P,A JRST CSET0A ;NOW TRY IT REMPROP: ;SUBR 2 - REMOVE PROPERTY FROM ATOMIC SYMBOL SKOTT A,LS+SY JRST REMP7 ;MUST SAVE AR1,R,F FOR FASLOAD - SEE LDENT REMP0: SKIPA D,A ;SAVE C, AR2A - SEE DEFPROP AND DEFUN REMP1: HRRZ D,(T) HRRZ T,(D) JUMPE T,FALSE MOVS TT,(T) CAIE B,(TT) JRST REMP1 HLRZ T,TT REMP20: HRRZ TT,(T) ;A IS GC-PROTECTING THE ATOM PURTRAP REMP3,D, HRRM TT,(D) MOVEI A,(T) POPJ P, REMP7: JUMPN A,RMPER0 MOVEI A,NILPROPS JRST REMP0 CSET4C: PUSHJ P,.+1 ;HAIRY WAY TO DO A DOUBLE COPY! HRRZ A,(T) MOVE B,(A) PUSHJ P,CONS1 HRRM A,(T) MOVEI T,(A) POPJ P, REMP3: PUSH P,A ;COME HERE ON PURE PAGE TRAP PUSH P,B ;A ON PDL GC PROTECTS ATOM MOVEI T,(A) REMP3A: PUSHJ P,CSET4C ;COPY ENOUGH OF PROPERTY LIST HRRZ TT,(T) ; TO DO REMPROP HLRZ A,(TT) CAME A,(P) JRST REMP3A HRRZ A,(TT) HRRZ TT,(A) HRRM TT,(T) JRST POP2J SUBTTL NOT, NULL, LAST, BOUNDP, RUNTIME NOTNOT: JUMPE A,CPOPJ ;REPLACES A NON-NIL VALUE BY T JRST TRUE NOT: $NULL: JUMPN A,FALSE TRUE: MOVEI A,TRUTH CNOT: POPJ P,NOT LAST: PUSHJ P,LLASTCK ;SUBR 1 - GET LAST CONS OF A LIST JRST LAST4 LAST5: MOVE A,D POPJ P, LAST4: CAIE F,-1 JRST LAST5 ; (A B C ... . Z) CASE SKOTTN A,LS ;SO WE TOOK NO CDRS! JRST LAST5 ; (A . Z) CASE HRRZ TT,C2 ;FOO! ALLOW RANDOM PTS TO PDL, FOR SAKE CAILE A,(TT) ; OF THAT KLUDGEY CODE OUTPUT BY THE CAILE A,(P) ; COMPLR FOR MAPCAN ETC. JRST LASTER SKIPN TT,(A) POPJ P, MOVEI A,(TT) JRST LAST LLASTCK: MOVEI F,-1 ;"LONG" LAST CHECK ; RETURNS <262143.-> IN F ; MUST PRESERVE T,R. SEE APPEND, REVERSE, NTHCDR LASTCK: SKIPN D,A ;SKIP RETURN ON NORMAL-FORM LIST JRST POPJ1 ; LEAVES PTR TO LAST NODE IN D, SKOTT D,LS ;() IS OK, AND IS ITS OWN "LASTNODE" POPJ P, ; BUT OTHER ATOMS LOSE JUMPLE F,POPJ1 ; LIMITED TO (F) CDRS LAST1: HRRZ TT,(D) SKOTT TT,LS JRST LAST2 HRRZ D,(D) SOJG F,LAST1 JRST POPJ1 LAST2: HRRZ TT,(D) JUMPE TT,POPJ1 POPJ P, ;ENDED WITH NON-NULL ATOM BOUNDP: JUMPE A,TRUE ;SUBR 1 JSP T,SPATOM ;TRUE IFF THE SYMBOL ARGUMENT IS BOUND JSP T,PNGE1 ;ERROR FOR NON-SYMBOLS HLRZ T,(A) ;GET VALUE CELL HRRZ A,(T) ;DO IT INTO T TO PROTECT FROM GC HRRZ T,(A) CAIN T,QUNBOUND TDZA A,A MOVEI A,TRUTH POPJ P, ;;; RETURN RUNTIME AS A FIXNUM IN MICROSECOND ;;; UNITS (NOT NECESSARILY THAT ACCURATE THOUGH). $RUNTIME: PUSH P,CFIX1 ;SUBR 0 NCALLABLE IT$ .SUSET [.RRUNT,,TT] ;RUNTIME IN 4-MICROSECOND UNITS 10$ SETZ TT, 10$ RUNTIM TT, ;RUNTIME IN MILLISECONDS IFN D20,[ LOCKI ;MUST LOCKI OVER ALL JSYS'S MOVEI 1,.FHSLF ;GET RUNTIME FOR SELF RUNTM MOVE TT,1 ;RUNTIME IN MILLISECONDS SETZB 1,3 ;1 AND 3 HAVE DANGEROUS CRUD UNLOCKI ] ;END OF IFN D20 RNTM1: ;CONVERT NUMBER FROM INTERNAL UNITS TO USECS IT$ LSH TT,2 IT% IMULI TT,1000. POPJ P, ;ANSWER IN MICROSECONDS SUBTTL TIME FUNCTION ;;; RETURN A TIME STANDARD AS A FLONUM IN SECONDS. ;;; WE ENDEAVOR TO MAKE THIS INCREASE MONOTONICALLY AND TO MEASURE ;;; THE PASSAGE OF REAL TIME. IN PRACTICE, WE MAY NOT MEASURE ;;; REAL TIME WHILE THE TIME-SHARING SYSTEM IS TEMPORARILY STOPPED, ;;; AND WE PERMIT A GLITCH (RESET TO 0) AT MIDNIGHT OF EACH DECEMBER 31. $TIME: PUSH P,CFLOAT1 ;SUBR 0 NCALLABLE IFN ITS,[ .RDTIME TT, ;GET AMOUNT OF TIME SYSTEM HAS BEEN UP ; CAMGE TT,[30.*3600.*24.*28.] ;FOUR WEEKS OF 1/30 SEC TICS ; JRST .+3 ; SUB TT,[30.*3600.*24.*28.] ; JRST .-3 JSP T,IFLOAT FDVRI TT,(30.0) ] ;END OF IFN ITS IFN D10,[ IFE SAIL,[ MOVE T,[%CNDTM] ;INTERNAL DATE/TIME STANDARD, GETTAB T, ; AS DATE,,FRACTION OF DAY JRST TIME3 ; 1-ORIGINED ON NOVEMBER 18, 1858 ADD T,[2*365.+1-43.,,] ;ALTER TO 0-ORIGIN ON JANUARY 1,1856 IDIV T,[365.*4+1,,] ;GET THIS MOD A FOUR-YEAR INTERVAL JSP T,IFLOAT FMPR T,[.OP ,86400.0,0] ;CONVERT TO SECONDS POPJ P, TIME3: MSTIME TT, ;THIS PRODUCES GLITCHES AT MIDNIGHT JSP T,IFLOAT FDVRI TT,(1000.0) ] ;END OF IFE SAIL IFN SAIL,[ ACCTIM TT, HLRZ D,TT IDIVI D,12.*31. ;YEAR-1964 IN D IDIVI R,31. ;MONTH-1 IN R, DAY-1 IN F ADD F,TIME8(R) ;ADD IN NUMBER OF DAYS PRECEDING CURRENT MONTH TLNN D,3 ;SKIP IF NOT LEAP YEAR CAIL R,2 ;SKIP IF JANUARY OR FEBRUARY SUBI F,1 ;ADJUST FOR CRETINOUS LEAP YEARS IMULI F,24.*3600. ;CONVERT TO SECONDS FROM LAST MIDNIGHT TO MIDNIGHT LAST DEC 31 TLZ TT,-1 ADD TT,F ;ADD IN SECONDS SINCE MIDNIGHT LAST JSP T,IFLOAT ] ;END OF IFN SAIL ] ;END OF IFN D10 IFN D20,[ LOCKI ;MUST LOCKI AROUND THE JSYS TIME ;GET TIME SINCE SYSTEM LAST RESTARTED IN MSECS MOVE TT,1 SETZ 1, ;ZERO CRUD UNLOCKI JSP T,IFLOAT FDVRI TT,(1000.0) ;CONVERT TO SECONDS ] ;END OF IFN D20 POPJ P, IFN SAIL,[ TIME8: ZZZ==1 ;WILL SUBTRACT THIS 1 BACK EXCEPT FOR AFTER FEB 29'S IRP X,,[31.,28.,31.,30.,31.,30.,31.,31.,30.,31.,30.,31.] ZZZ ZZZ==ZZZ+X TERMIN IFN ZZZ-366., WARN [TABLE OF CUMULATIVE DAYS IN MONTHS LOSES] EXPUNGE ZZZ ] ;END OF IFN SAIL SUBTTL EQUAL FUNCTION EQUAL: CAIN A,(B) ;EQ THINGS ARE EQUAL JRST TRUE ; .SEE ASSOC - MUST PRESERVE F MOVEM P,EQLP PUSHJ P,EQUAL1 ;EQUAL1 ACTUALLY RETURNS ONLY IF EQUAL JRST TRUE EQUAL0: CAIN A,(B) ;EQ THINGS ARE EQUAL POPJ P, EQUAL1: MOVEI T,(A) MOVEI TT,(B) ROTC T,-SEGLOG ;GET TYPES OF ARGS HRRZ T,ST(T) MOVE TT,ST(TT) CAIN T,(TT) ;MUST HAVE SAME TYPE TO BE EQUAL 2DIF JRST @(T),EQLTBL,QLIST .SEE STDISP IFN HNKLOG,[ SKIPN VHUNKP TLNN TT,LS ] ;END OF IFN HNKLOG JRST EQLOSE IFN HNKLOG,[ SKOTT A,LS ;IF VHUNKP CONTAINS NIL, THEN WANT TO JRST EQLOSE ; TREAT ALL HUNKS AS IF THEY WERE LIST CELLS ] ;END OF IFN HNKLOG EQLLST: PUSH P,(A) PUSH P,(B) HLRZ A,(A) HLRZ B,(B) PUSHJ P,EQUAL0 ;COMPARE CARS HRRZ A,-1(P) HRRZ B,0(P) SUB P,R70+2 JRST EQUAL0 ;COMPARE CDRS EQLTBL: EQLLST ;LIST EQLNUM ;FIXNUM EQLNUM ;FLONUM DB$ EQLNM2 ;DOUBLE CX$ EQLNM2 ;COMPLEX DX$ EQLNM4 ;DUPLEX BG$ EQLBIG ;BIGNUM EQLOSE ;PNAME ATOMS MUST BE EQ TO BE EQUAL HN$ REPEAT HNKLOG+1, EQLHNK ;HUNKS REQUIRE RECURSION LIKE LISTS EQLOSE ;RANDOMS AND NIL MUST BE EQ TO BE EQUAL EQLOSE ;ARRAY POINTERS MUST BE EQ TO BE EQUAL IFN .-EQLTBL-NTYPES, WARN [WRONG LENGTH TABLE] IFN DXFLAG,[ EQLNM4: KA MOVE T,2(A) KA MOVE TT,3(A) KIKL DMOVE T,2(A) CAMN T,2(B) CAME TT,3(B) JRST EQLOSE ] ;END OF IFN DXFLAG IFN DBFLAG+CXFLAG,[ EQLNM2: MOVE T,1(A) CAME T,1(B) JRST EQLOSE ] ;END OF IFN DBFLAG+CXFLAG EQLNUM: MOVE T,(A) CAMN T,(B) ;COMPARE VALUES OF NUMBERS POPJ P, EQLOSE: MOVE P,EQLP ;THE ULTIMATE FALSITY - ESCAPE BACK JRST FALSE ; TO TOP LEVEL OF ENTRY TO EQUAL WITH FALSE IFN BIGNUM,[ EQLBIG: HLRZ T,(A) HLRZ TT,(B) CAIE T,(TT) ;EQUAL BIGNUMS HAVE EQ SIGNS JRST EQLOSE ; AND CDRS ARE EQUAL LISTS OF FIXNUMS HRRZ A,(A) ;CHECK ONLY EQUAL CDRS HRRZ B,(B) JRST EQUAL0 ] ;END OF IFN BIGNUM IFN HNKLOG,[ EQLHNK: SKIPN VHUNKP JRST EQLLST SKIPE USRHNK JRST EQLHN4 EQLHN3: PUSH P,A PUSH P,B MOVNI T,1 2DIF [LSH T,(TT)]0,QHUNK0 ;REALLY SHOULD BE ASH, BUT LSH IS FASTER ON KL10 HRLI B,(T) PUSH P,A PUSH P,B EQLHN1: HLRZ A,@-1(P) HRRZ B,(P) HLRZ B,(B) PUSHJ P,EQUAL0 HRRZ A,@-1(P) HRRZ B,(P) HRRZ B,(B) PUSHJ P,EQUAL0 MOVE T,(P) AOBJP T,EQLHN2 MOVEM T,(P) AOS -1(P) JRST EQLHN1 EQLHN2: SUB P,R70+4 POPJ P, EQLHN4: SKIPN USRHNK ;Is the USRHUNK/SENDI feature enabled? JRST EQLHN3 ; no, check the parts PUSH FXP,EQLP ;Gotta ask the user predicate PUSHJ FXP,SAV5 PUSHJ P,USRHNP ;Check for user-hunkness JUMPE T,EQLHN5 ;If not, go hack it normally PUSH P,[EQLH4X] PUSH P,A PUSH P,[QEQUAL] PUSH P,B MOVNI T,3 XCT SENDI ;Send the object a message EQLH4X: PUSHJ FXP,RST5M1 POP FXP,EQLP JUMPE A,EQLOSE JRST POPBJ EQLHN5: POP P,A PUSHJ FXP,RST5 POP FXP,EQLP JRST EQLHN3 ;; Send a message to a hunk with object in A and message in B USRSAB: PUSHJ FXP,SAV5M2 ;Save AC's PUSH P,[RST5M2] USRAB: PUSH P,A ;Don't save AC's if called here PUSH P,B XCT SENDI ;; Check A for being a HUNK and a USRHUNK, return answer in T USRHPP: MOVEI T,(A) LSH T,-SEGLOG MOVE T,ST(T) ;Get segment table entry TLNE T,HNK ;Is it a hunk at all? JRST USRHNP ; Yes, call user's hook. TFALSE: SETZ T, ;Nope.... POPJ P, ;; If we are using the USRHNK, assuming we already know it's a hunk. USRHNP: SKIPE USRHNK ;Must have both a USRHUNK and a SENDI SKIPN SENDI ; in order to make use of either JRST TFALSE PUSHJ FXP,SAV5 PUSH FXP,R XCT USRHNK ;Check it out POP FXP,R MOVE T,A ;Return value in T, not A PUSHJ FXP,RST5 POPJ P, ] ;END OF IFN HNKLOG SUBTTL NCONC, *NCONC, APPEND, *APPEND, REVERSE, NREVERSE, NRECONC NCONC: TDZA R,R ;LSUBR - DESTRUCTIVELY CATENATE LISTS APPEND: MOVEI R,.APPEND-.NCONC ;LSUBR - CATENATE BY COPYING JUMPE T,FALSE POP P,B APP2: AOJE T,BRETJ POP P,A JUMPE A,APP2 SKIPE V.RSET PUSHJ P,APRVCK APP3: PUSHJ P,.NCONC+1(R) ;FIRST INST OF .NCONC IS "JUMPE A,BRETJ" MOVE B,A JRST APP2 .NCONC: JUMPE A,BRETJ .SEE APP3 .NCNC1: MOVEI TT,(A) ;SUBR 2 (*NCONC) .NCNC2: HRRZ D,(TT) JUMPE D,.NCNC3 HRRZ TT,(D) JUMPN TT,.NCNC2 HRRM B,(D) POPJ P, .NCNC3: HRRM B,(TT) POPJ P, .APPEND: JUMPE A,BRETJ ;SUBR 2 (*APPEND) MOVEI C,AR1 ;FIRST INST MUST BE JUMPE A,BRETJ MOVE AR2A,A ;MUST SAVE T,D - SEE MAKOBLIST APP1: HLRZ A,(AR2A) PUSHJ P,CONS HRRZ B,(A) HRRM A,(C) MOVE C,A HRRZ AR2A,(AR2A) JUMPN AR2A,APP1 AR1RETJ: SUBS4: MOVEI A,(AR1) POPJ P, REVERSE: SKIPE V.RSET ;SUBR 1 - USES A,B,C,T,F PUSHJ P,APRVCK MOVEI C,(A) MOVEI A,NIL ;REVERSES A LIST BY CONSING UP A COPY REV1: JUMPE C,CPOPJ ; OF THE TOP LEVEL IN REVERSE ORDER HLRZ B,(C) PUSHJ P,XCONS HRRZ C,(C) JRST REV1 APRVCK: PUSHJ P,SAVX3 ;APPEND/REVERSE ARGUMENT CHECKING REV4: PUSHJ P,LLASTCK ;MUST SAVE TT,D,R FOR MANY PLACES WHICH JRST REVER ; CALL REVERSE/NREVERSE JRST RSTX3 NREVERSE: MOVEI B,NIL ;SUBR 1 - REVERSE A LIST USING RPLACD'S NRECONC: JUMPE A,BRETJ ;SUBR 2 - (NRECONC X Y)=(NCONC (NREVERSE X) Y) SKIPE V.RSET ; - USES A,B,C,T,F PUSHJ P,APRVCK NREV1: HRRZ C,(A) ;ONLY 3 INSTRUCTIONS PER CELL! ZOOM! HRRM B,(A) JUMPE C,CPOPJ HRRZ B,(C) HRRM A,(C) JUMPE B,CRETJ HRRZ A,(B) HRRM C,(B) JUMPN A,NREV1 JRST BRETJ SUBTTL GENSYM FUNCTION GENSYM: JUMPN T,GENSY1 GENSY0: MOVE TT,[010700,,GNUM] ;STANDARD GENSYMER MOVEI B,"0 ;WILL INCREMENT NUMERICAL PART GENSY2: LDB T,TT ; AND GIVE OUT GENSYMED ATOM AOS T DPB T,TT CAIG T,"9 JRST GENSY3 DPB B,TT ADD TT,[070000,,0] CAMGE TT,[350000,,] JRST GENSY2 GENSY3: MOVE TT,GNUM MOVEM TT,PNBUF MOVEI C,PNBUF JRST PNGNK2 GENSY1: MOVEI D,QGENSYM AOJN T,S1WNALOSE GENSY7: POP P,A SKOTT A,FX JRST GENSY5 MOVE TT,(A) JUMPL TT,GENSY8 MOVE T,[010700,,GNUM] GENSY6: IDIVI TT,10. ;INSTALL 4 DECIMAL DIGITS ADDI D,"0 ; IN GENSYM COUNTER DPB D,T ADD T,[070000,,0] CAMGE T,[350000,,] JRST GENSY6 JRST GENSY3 GENSY5: TLNN TT,SY JUMPN A,GENSY8 JSP T,CHNV1D DPB TT,[350700,,GNUM] JRST GENSY0 SUBTTL MEMBER, MEMQ, SUBST, DELQ, DELETE, *DELQ, *DELETE MEMBER: ;USES A,B,AR1,AR2A,T,TT SMEMBER:: MOVEI AR1,(A) ; FOR BENEFIT OF DELETE MOVEI AR2A,(B) JSP T,LATOM JRST MEMBR SMEMQ: SETZM MEMV ;USES A,B,T,MUST PRESERVE AR1,AR2A;SEE GTSPC3 PUSH P,B MEMQ2: SKOTT B,LS JRST MEMQ4 HLRZ T,(B) CAMN A,T JRST MEMQ3 HRRM B,MEMV HRRZ B,(B) JRST MEMQ2 MEMQ3: POPI P,1 JRST SPROG2 MEMQ4: JUMPE B,MEMQ3 JSP T,MEMQER JRST MEMQ2 MEMBR: SETZM MEMV PUSH P,B MEMB2: SKOTT AR2A,LS JRST MEMB4 MOVE A,AR1 HLRZ B,(AR2A) PUSHJ P,EQUAL JUMPN A,MEMB3 HRRM AR2A,MEMV HRRZ AR2A,(AR2A) JRST MEMB2 MEMB3: POPI P,1 AR2ARETJ: MOVEI A,(AR2A) POPJ P, MEMB4: JUMPE AR2A,MEMB3 JSP T,MEMQER MOVE AR2A,B JRST MEMB2 ;;; SUBSTITUTE A FOR EQUAL OCCURRENCES OF B IN C. SUBST: JSP T,PDLNMK ;SUBR 3 EXCH A,C JSP T,PDLNMK EXCH A,C SKIPA AR1,A SUBS0A: SKIPA A,AR1 SKIPA AR2A,B MOVE B,AR2A PUSH P,C MOVE A,C PUSHJ P,EQUAL POP P,C JUMPN A,AR1RETJ SUBS1: SKOTT C,LS ;FOO, THIS INCLUDES HUNKS! JRST SPROG3 PUSH P,C IFN HNKLOG,[ TLNE TT,HNK JRST SUBSTH ]; END of IFN HNKLOG, HLRZ C,(C) ;A "PAIR" CELL PUSHJ P,SUBS0A EXCH A,(P) HRRZ C,(A) PUSHJ P,SUBS0A POP P,B JRST XCONS IFN HNKLOG,[ SUBSTH: MOVE A,(C) PUSHJ P,USRHNP ;Check for being a USER extended hunk JUMPE T,SUBST8 POP P,A SAVE AR1 AR2A PUSH P,[SUBSH0] PUSH P,A PUSH P,[QSUBST] PUSH P,AR1 PUSH P,AR2A MOVNI T,4 XCT SENDI ;Send the frob a SUBST message SUBSH0: RSTR AR2A AR1 POPJ P, SUBST8: MOVEI R,1 ;R GETS MAX SIZE IN WORDS 2DIF [LSH R,(TT)]0,QHUNK0 PUSH FXP,R ;CNTR WHILE COPYING PUSH P,R70 ;TEMP PTR WHILE COPYING MOVE TT,R LSH TT,1 PUSHJ P,ALHUNK ;SAVES AR1,AR2A PUSH P,A SUBST5: SOSGE R,(FXP) JRST SUBST6 ADD R,-2(P) MOVE R,(R) ;GET WORD OF ORIGINAL HUNK HRRZM R,-1(P) ; AND REMEMBER RH OF IT HLRZ C,R CAIN C,-1 PUSHJ P,SUBS0A ;COPY LH EXCH C,-1(P) CAIN C,-1 PUSHJ P,SUBS0A ;COPY RH MOVE R,(FXP) ADD R,(P) ;POINTER TO NEW COPY HRRM C,(R) ;INSTALL RH MOVE B,-1(P) HRLM B,(R) ;INSTALL LH JRST SUBST5 SUBST6: POP P,C POPI P,2 POPI FXP,1 ]; End of IFN HNKLOG, CRETJ: SPROG3: MOVE A,C POPJ P, DELQ: SKIPA D,[SMEMQ] ;USES A,B,C,T,TT. MUST SAVE AR2A - SSMACRO DELETE: MOVEI D,SMEMBER ;USES A,B,C,AR1,AR2A,T,TT MOVEI TT,-1 ;MUST SAVE R, SEE GCP6H1 CAMN T,XC-2 JRST DLT3 CAME T,XC-3 JRST DLTER POP P,A JSP T,FLTSKP JRST .+2 JSP T,IFIX DLT3: MOVEM TT,DLTC MOVEI TT,(P) SKIPA B,(P) DLT2: HRRM B,(TT) MOVEM TT,TABLU1 MOVE A,-1(P) SOSGE DLTC JRST DLT1 PUSHJ P,(D) ;MEMBER OR MEMQ JUMPE A,DLT1 HRRZ B,(A) SKIPN TT,MEMV MOVE TT,TABLU1 JRST DLT2 DLT1: POP P,A JRST POP1J .DELQ: SKIPA D,[SMEMQ] .DELETE: MOVEI D,MEMBER PUSH P,A PUSH P,B MOVEI TT,-1 JRST DLT3 MEMQ: SKIPE V.RSET JRST SMEMQ MEMQ1: JUMPE B,FALSE .SEE THRCAB ;REQUIRES MEMQ1 PRESERVES TT HLRZ T,(B) CAIN T,(A) JRST BRETJ HRRZ B,(B) JRST MEMQ1 SUBTTL FLOATP, FIXP, NUMBERP, TYPEP, AND PDLNMK ROUTINE IRP NUMP,,[FIXP,FLOATP,NUMBERP]BITS,,[FX+BN,FL,FX+FL+BN] NUMP: SKOTT A,BITS JRST FALSE ;RETURN NIL IF NOT OF DESIRED TYPE MOVE TT,(A) ;RETURN T IF WHAT WE WANT. ALSO, TT GETS THE NUMBER. JRST TRUE ;IF NUMBERP GETS A BIGNUM, TT GETS THE CORRECT SIGN, ANYWAY TERMIN TYPEP: JUMPE A,TYPNIL ;SUBR 1 - USES ONLY A ROT A,-SEGLOG HRRZ A,ST(A) POPJ P, TYPNIL: MOVEI A,QSYMBOL POPJ P, %SYMBOLP: ;SUBR 1 JSP T,SPATOM JRST FALSE JRST TRUE NMCK0: POP P,A NUMCHK: ;CHECK TO SEE THAT WE HAVE A NUMBER, THEN EXIT IFE NARITH,[ BG% JSP T,FLTSKP BG$ JSP T,NVSKIP BG$ POPJ P, JFCL ;FALLS INTO PDLNKJ ] ;END OF IFE NARITH IFN NARITH, WARN [NUMCHK? PDLNMK?] PDLNKJ: CAML A,NPDLL ;PDLNKJ = PDLNMK, THEN POPJ P, CAMLE A,NPDLH POPJ P, MOVEI T,CPOPJ PDLNMK: CAML A,NPDLL ;FIRST A QUICK AND DIRTY CHECK CAMLE A,NPDLH JRST (T) PDLNM0: ROT A,-SEGLOG ;NOW TO CHECK THE ST ENTRY SPECPRO INTROT HLL T,ST(A) ROT A,SEGLOG NOPRO TLNN T,$PDLNM ;SKIP IFF PDL NUMBER JRST (T) PUSH P,T NMK1: MOVEM TT,PNMK1 ;EXPECTS TYPE BITS IN T MOVE TT,(A) HRRI T,PNMK2 ;MUST SAVE TT TLNN T,FL ;FIGURE OUT WHICH KIND OF CONS TO DO JRST FXCONS ; - FIXNUM JRST FLCONS ; - FLONUM PNMK2: MOVE TT,PNMK1 ;RESTORE TT FOR PDLNMK CPDLNKJ: POPJ P,PDLNKJ SUBTTL GCPRO AND SXHASH GCPRO: JUMPE B,GCREL CAIN B,QM ;SECOND ARG = ? MEANS ONLY GCLOOK JRST GCLOOK %GCPRO: MOVEI AR1,1 ;MUST SAVE R,F - FOR FASLOAD GCPR1: CAIL A,IN0-XLONUM CAILE A,IN0+XHINUM-1 SKIPA POPJ P, SKOTT A,SY JRST GCPR2 JUMPLE AR1,CPOPJ HLRZ T,(A) MOVSI TT,SY.CCN\SY.OTC ;COMPILED CODE NEEDS ME BIT MOVSI D,SY.PUR ;PURE SYMBOL BLOCK BIT TDNN D,(T) IORM TT,(T) POPJ P, GCPR2: MOVE AR2A,A ;SAVE ARG PUSHJ P,SXHSH0 ;LEAVES HASHKEY IN D MOVE A,AR2A MOVE T,AR1 ;T=0 => RELEASE, ELSE PROTECT .GCPRO: JUMPE A,CPOPJ LOCKI PUSH P,A ;PLACES ORIG ARG ON PDL PUSHJ P,SAVX5 ;SAVES NUM ACS SKIPE B,GCPSAR JRST .GCPR5 MOVEI A,NIL MOVE TT,LOSEF ADDI TT,1 LSH TT,-1 PUSHJ P,MKLSAR MOVE D,-2(FXP) ;RESTORE HASHKEY IN D MOVEM B,GCPSAR .GCPR5: MOVE T,D ;ARG ON P, AND SAVES NUM ACS ON FXP LSH T,-1 IDIV T,LOSEF PUSH FXP,TT MOVEI A,(FXP) PUSHJ P,@ASAR(B) SUB FXP,R70+1 MOVEM R,-3(FXP) MOVE B,A MOVE A,(P) ;ORIG ARG ON P PUSH P,B ;SAVE PROLIST BUCKET SKIPN -4(FXP) JRST GCRL1 ;GO RELEASE IF FLAG SO SET. PUSHJ P,MEMBER JUMPN A,GCPR3 ;ITEM ALREADY IN PROTECTIVE BUCKET SKIPG -4(FXP) JRST GCPR4 MOVE A,-1(P) ;ORIGINAL ARG MOVE B,(P) ;CONSED ONTO PROLIST BUKET PUSHJ P,CONS MOVE R,-3(FXP) HRRZ D,GCPSAR JSP T,.STOR0 GCPR3: HLRZ A,(A) GCPR4: PUSHJ P,RSTX5 SUB P,R70+2 UNLKPOPJ GCRL1: CALLF 2,QDELETE ;GCRELEASE MOVE R,-3(FXP) HRRZ D,GCPSAR JSP T,.STOR0 JRST GCPR4 GCREL: TDZA AR1,AR1 GCLOOK: MOVNI AR1,1 SKIPN GCPSAR JRST FALSE JRST GCPR1 SXHASH: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE PUSH P,F ;SAVE F - SEE DEFUN PUSHJ P,SXHSH0 MOVE TT,D POP P,F POPJ P, ATMHSH: ;HASH A PRINT NAME BNHSH: SETZ T, ;HASH A BIGNUM (SAME ALGORITHM) SKIPA B,A AHSH1: HRRZ B,(B) JUMPE B,AHSH2 HLRZ C,(B) XOR T,(C) JRST AHSH1 AHSH2: LSH T,-1 ;FOR ATOMS, THIS INSURES THAT THE HASHKEY IS POSITIVE JRST (TT) NILHSH: MOVE D,[_-1] ;HASH NIL FASTLY POPJ P, SXHSH0: JUMPE A,NILHSH ;RETURNS S-EXPR'S HASHKEY IN D HRRZ TT,A LSH TT,-SEGLOG MOVE TT,ST(TT) 2DIF JRST @(TT),SXHSH9,QLIST .SEE STDISP SXHSLS: HRRZ B,(A) PUSH P,B HLRZ A,(A) PUSHJ P,SXHSH0 ROT D,-1 PUSH FXP,D POP P,A PUSHJ P,SXHSH0 POP FXP,T ADD D,T POPJ P, SXHSH8: MOVM D,(A) ;FLONUM POPJ P, SXHSH7: MOVE D,(A) ;FIXNUM POPJ P, IFN BIGNUM,[ SXHSH4: HRRZ A,(A) ;BIGNUM JSP TT,BNHSH MOVE D,T POPJ P, ] ;END OF IFN BIGNUM SYMHSH: SXHSH5: HLRZ T,(A) ;SYMBOL HRRZ A,1(T) JSP TT,ATMHSH SKIPA D,T SXHSH6: MOVEI D,(A) POPJ P, ;RANDOM, ARRAY SXHSH9: SXHSLS ;LIST SXHSH7 ;FIXNUM SXHSH8 ;FLONUM DB$ SXHSD1 ;DOUBLE CX$ SXHSC1 ;COMPLEX DX$ SXHSZ1 ;DUPLEX BG$ SXHSH4 ;BIGNUM SXHSH5 ;SYMBOL HN$ REPEAT HNKLOG+1, SXHS1A ;HUNKS SXHSH6 ;RANDOM SXHSH6 ;ARRAY IFN .-SXHSH9-NTYPES, WARN [WRONG LENGTH TABLE] IFN DBFLAG,[ SXHSD1: MOVE D,1(A) KA ASH D,10 ] ;END OF IFN DBFLAG IFN DBFLAG+CXFLAG,[ SXHSD2: ADD D,(A) POPJ P, ] ;END OF IFN DBFLAG+CXFLAG IFN CXFLAG,[ SXHSC1: MOVS D,1(A) JRST SXHSD2 ] ;END OF IFN CXFLAG IFN DXFLAG,[ SXHSZ1: MOVE D,3(A) KA ASH D,10 SUB D,2(A) KA MOVE T,1(A) KA ASH T,10 KA XOR D,T KIKL XOR D,1(A) JRST SXHSD2 ] ;END OF IFN DXFLAG IFN HNKLOG,[ SXHS1A: PUSH P,A PUSHJ P,USRHPP ;Is this a USERHUNK? JUMPE T,SXHS1 PUSH P,[SXHHS0] PUSH P,A PUSH P,[QSXHASH] MOVNI T,2 XCT SENDI SXHHS0: MOVE D,(A) JRST POPAJ SXHS1: MOVSI T,-1 2DIF [LSH T,(TT)]0,QHUNK0 HRRI T,(A) PUSH P,T PUSH FXP,R70 SXHS1B: HLRZ A,(T) PUSHJ P,SXHSH0 ROT D,1 ADDM D,(FXP) MOVE T,(P) HRRZ A,(T) PUSHJ P,SXHSH0 ADD D,(FXP) ROT D,2 MOVEM D,(FXP) MOVE T,(P) AOBJP T,SXHS1F MOVEM T,(P) JRST SXHS1B SXHS1F: SUB P,R70+2 JRST POPXDJ ] ;END OF IFN HNKLOG SUBTTL MAPPING FUNCTIONS ;;; MAPATOMS FUNCTION ;;; (MAPATOMS FN) CALLS FN REPEATEDLY, FEEDING IT SUCCESSIVE ;;; ATOMS FROM THE CURRENT OBARRAY. OPTIONAL SECOND ARG ;;; SPECIFIES OBARRAY (MUST BE A SAR!). RETURNS NIL. MAPATOMS: MOVEI D,QMAPATOMS AOJG T,S1WNALOSE AOJL T,S2WNALOSE SKIPE T ;SECOND ARG DEFAULTS TO PUSH P,VOBARRAY ; CURRENT OBARRAY MOVEI TT,(CALL 1,) HRLM TT,-1(P) PUSH P,R70 PUSH FXP,[OBTSIZ] ;NUMBER OF BUCKETS MAPAT1: SOSGE TT,(FXP) ;TT GETS BUCKET NUMBER JRST MAPAT9 HRRZ AR1,-1(P) ROT TT,-1 HLRZ A,@TTSAR(AR1) ;FETCH BUCKET SKIPGE TT HRRZ A,@TTSAR(AR1) MOVEM A,(P) ;SAVE BUCKET MAPAT2: SKIPN B,(P) ;MAPCAR DOWN BUCKET JRST MAPAT1 HLRZ A,(B) HRRZ B,(B) MOVEM B,(P) XCT -2(P) ;CALL SUPPLIED FUNCTION JRST MAPAT2 MAPAT9: SUB FXP,R70+1 ;EXIT, RETURNING NIL SUB P,R70+3 JRST FALSE ;;; PDL STRUCTURE FOR MAP SERIES ;;; ,,RETURN ;LEFT HALF MAY HAVE BAKTRACE INFO ;;; ,,EVENTUAL VALUE ;LEFT HALF HAS LAST OF VALUE LIST ;;; LIST1 ;SECOND ARG ;;; LIST2 ;THIRD ARG ;;; LIST3 ;FOURTH ARG ;;; ... ;;; LISTN ;LAST ARG ;;; -N,,
;;; CODE,,MODE ;CODE TELLS WHAT KIND OF MAP, MODE TELLS HOW TO CALL FN ;;; ; (MODE IS ADDRESS OF PLACE WHICH SETS UP ARGS FOR FN) ;;; MAPL6 ;OR MAYBE MAPL3 - THIS IS WHERE FN CALL RETURNS TO ;;; JCALL K,FN ;FN=FIRST ARG - K=1,2,3,4,5, OR 16 ;;; ;UUO HANDLER MAY CLOBBER THIS WITH A JRST ;;; ;IF NEVER GOING TO BE XCT'ED, JCALL NEED NOT BE THERE MAPLIST: JSP TT,MAPL0 ;CODE 0 MAPCAR: JSP TT,MAPL0 ;CODE 1 $MAP: JSP TT,MAPL0 ;CODE 2 MAPC: JSP TT,MAPL0 ;CODE 3 MAPCON: JSP TT,MAPL0 ;CODE 4 $MAPCAN: JSP TT,MAPL0 ;CODE 5 MAPL0: AOJGE T,MAPWNA ;LOSE IF ONLY ONE ARG MOVE D,T ADDI D,1(P) ;D HAS ADDRESS OF LIST1 ON STACK HRLI D,(T) PUSH P,D 2DIF [MOVSI TT,(TT)]-1,MAPLIST PUSH P,TT ;SAVE CODE - FIGURE OUT MODE LATER TLNE TT,2 ;SKIP IF WE'LL BE SAVING UP RESULTS SKIPA A,(D) ;ELSE WE'LL JUST RETURN FIRST LIST AS VALUE MOVSI A,-1(D) EXCH A,-1(D) ;INIT EVENTUAL VALUE SLOT - A NOW HAS FIRST ARG (FN) JSP T,SPATOM JRST MAPL5 ;FOOEY, IT'S NOT A SYMBOL HRRZ C,(A) MAPL1: JUMPE C,MAPL5 ;FOOEY, IT'S A SYMBOL WITH NO FUNCTION PROPERTY HLRZ B,(C) HRRZ C,(C) HRRZ C,(C) CAIL B,QARRAY ;REMEMBER, SYMBOLS DENOTING FUNCTION PROPS CAILE B,QFEXPR ; ARE CONSECUTIVE IN SYMBOL SPACE JRST MAPL1 CAIE B,QARRAY CAIN B,QSUBR JRST MAPL5A ;GO FIGURE OUT JCALL FOR A SUBR OR ARRAY CAIE B,QLSUBR JRST MAPL5 ;FOOEY, IT'S SOMETHING WE CAN'T LINK TO WELL PUSH P,CMAPL3 HRLI A,(JCALL 16,) MOVEI B,MAPL23 MAPL1B: HRRM B,-1(P) ;B HAS MODE - SAVE IT PUSH P,A ;SAVE FN (MAYBE WITH JCALL K, IN LEFT HALF) JRST MAPL2 MAPL3: MOVE D,(P) ;GET FUNCTION CALL FROM STACK TLNE D,700000 ;SKIP IF IT DIDN'T GET CLOBBERED JRST MAPL3A MOVEI D,MAPL24 ;OH, WELL! MIGHT AS WELL USE MODE HRRM D,-2(P) ; FOR UNCLOBBERABLE FNS CMAPL6: MAPL3A: MOVEI D,MAPL6 MOVEM D,-1(P) ;WE ONLY NEED TO DO A MAPL3 CHECK ONCE MAPL6: MOVE D,-3(P) ;D POINTS TO LIST1 ON STACK HLRZ C,-1(D) ;C GETS POINTER TO LAST OF VALUE JUMPE C,MAPL7 ;THIS IS REALLY A MAP OR MAPC HLLZ B,-2(P) ;GET CODE IN LEFT HALF OF B TLNE B,4 JRST MAPL8 ;MAPCAN OR MAPCON PUSHJ P,CONS ;MAPCAR OR MAPLIST - NOTE THAT B IS NIL HRRM A,(C) ;CLOBBER INTO END OF LIST MAPL6A: HRLM A,-1(D) ;SAVE NEW LAST POINTER MAPL7: MOVE TT,(D) MAPL7A: HRRZ A,(TT) ;TAKE CDR OF ALL LISTS MOVEM A,(D) SKIPL TT,1(D) AOJA D,MAPL7A MOVE D,TT ;NOW D POINTS TO LIST1 ON STACK AGAIN MAPL2: MOVE B,-2(P) MOVE C,P ;SAVE C FOR A QUICK GETAWAY PUSH P,-1(P) ;WHERE CALL TO FN SHOULD RETURN MAPL21: SKIPG A,(D) ;D POINTS TO VECTOR OF LISTS JRST MAPL22 ;REMEMBER, <-N,,XXX> IS JUST AFTER MOVEI TT,(A) LSH TT,-SEGLOG SKIPL ST(TT) ;END-OF-LIST TEST JRST MAPL40 TLNE B,1 ;SKIP UNLESS THIS IS A "CAR" KIND OF MAP HLRZ A,(A) PUSH P,A ;PUSH ARG AOJA D,MAPL21 ;IF NOT END, GO CHECK OUT NEXT LIST MAPL40: JUMPE A,MAPL4 LER3 [SIXBIT \NON-NULL TERMINATION OF LIST - MAP!\] MAPL4: MOVE P,C ;THIS POPS OFF FASTLY ANY UNNEEDED STUFF HLRZ T,-3(P) ;GET -N IN T SUBI T,4 HRLI T,-1(T) ADD P,T ;FASTLY POP OFF FN, MODE, ALL LISTS, ETC. POP P,A ;FINAL VALUE GOES IN A TLZ A,-1 ;ZERO ANY LEFT HALF GARBAGE CMAPL3: POPJ P,MAPL3 ;HOORAY! MAPL22: JUMPE A,MAPL4 ;NIL IS NORMAL END-OF-LIST SETZB A,B ;MAY HAVE GARBAGE IN LEFT HALVES HLRE T,(D) ;T GETS -N IN CASE OF LSUBR CALL MOVE TT,1(D) ;GET MODE (D POINTS TO <-N,,XXX> ON STACK) JSP R,(TT) ;FOR SUBRS, GOES TO PDLA2-N MAPL23: XCT 3(D) ;GO HERE FOR LSUBRS MAPL24: MOVEM T,UUTSV ;GO HERE FOR UNCLOBBERABLE CALL MOVE T,3(D) ;SAVE SOME OF THE UUOH TROUBLE BY HRLI T,(JCALLF 16,) ; ENTERING THE UUO MESS MORE DIRECTLY MOVEM T,40 TLZ T,-1 MOVEI R,1 ;R=1 MEANS LSUBR CALL SETZM UUOH JRST UUOH0A MAPL5: PUSH P,CMAPL6 ;SET UP FOR UNCLOBBERABLE FN CALL MOVEI B,MAPL24 JRST MAPL1B MAPL5A: HLRE T,-1(P) CAMGE T,XC-5 ;CHECK NUMBER OF ARGS FOR FN JRST MAPL5 ;FOOEY, TOO MANY ARGS FOR SUBR CALL PUSH P,CMAPL3 MOVM TT,T LSH TT,5 TLO A,(JCALL)(TT) ;MAKE UP JCALL OF RIGHT # OF ARGS MOVEI B,PDLA2(T) ;MODE = PDLA2-<# OF ARGS> JRST MAPL1B MAPL8: JUMPE A,MAPL7 ;NCONC'ING NIL DOES VERY LITTLE HRRM A,(C) ;CLOBBER INTO LAST OF PREVIOUS THING SKIPE V.RSET JRST MAPL8A MOVE T,A MAPL8B: HRRZ TT,(T) ;AN OPEN-CODING OF THE SUPER-FAST "LAST" JUMPE TT,MAPL8C HRRZ T,(TT) JUMPN T,MAPL8B SKIPA A,TT MAPL8C: MOVEI A,(T) JRST MAPL6A MAPL8A: MOVE T,D PUSHJ P,LAST ;FIND LAST OF THIS NEW FROB MOVE D,T JRST MAPL6A .MAP: JSP TT,.MAP1 ;MAPCAN JSP TT,.MAP1 ;MAPCON JSP TT,.MAP1 ;MAPC JSP TT,.MAP1 ;MAP JSP TT,.MAP1 ;MAPCAR JSP TT,.MAP1 ;MAPLIST .MAP1: JUMPE A,CPOPJ TLNE A,-1 ;RIDICULOUS CHECK FOR HORRIBLE .VALUE ; COMPILER LOSSES PUSH P,B ;LIST IN A, FUNCTION IN B, PUSH P,A ;NUMBER IN TT IS INDEX MOVNI T,2 10$ SUBI TT,.MAP+A ;LOSING D10!!! 10$ MOVNS TT ;NO NEGATIVE RELOC ALLOWED! .ELSE MOVNI TT,-.MAP-A(TT) JRST $MAPCAN(TT) SET: JSP D,SETCK ;SUBR 2 EXCH B,A ;FORTUNATELY, NOT USED BY COMPILED CODE JSP T,PDLNMK EXCH B,A EXCH B,AR1 JSP T,.SET1 EXCH B,AR1 POPJ P, SETCK: JSP T,SPATOM JSP T,PNGE1 JRST (D) SUBTTL VARIOUS BREAK ROUTINES $BREAK: JUMPE A,CPOPJ ;*BREAK - SUBR 2 $BRK0: MOVEI A,(B) ;A = BREAKP, B = BREAKID HRRZ B,V. HRRZ AR1,VIPLUS HRRZ AR2A,VIDIFF JSP T,SPECBIND ;DO *NOT* BIND ^R TAPRED ;^Q TTYOFF ;^W VEVALHOOK ;EVALHOOK 0 B,V. ;* 0 AR1,VIPLUS ;+ 0 AR2A,VIDIFF ;- MOVEI B,$DEVICE MOVEI C,UNTYI MOVEI AR2A,TRUTH JSP T,SPECBIND 0 B,TYIMAN 0 C,UNTYIMAN 0 AR2A,V%TERPRI STRT 17,[SIXBIT \^M;BKPT !\] HRRZ AR1,VMSGFILES TLO AR1,200000 PUSHJ P,$PRINC STRT 17,STRTCR MOVE A,VIDIFFERENCE MOVEM A,VIPLUS MOVEI D,BRLP ;FUNCTION TO EXECUTE PUSHJ P,BRGEN ;CATCH AND ERRSET AROUND A READ-EVAL-PRINT LOOP JSP F,LINMDP PUSHJ P,ITERPRI PUSHJ P,UNBIND JRST UNBIND CB: SKIPN V.RSET ;CALL BREAK - *RSET ERROR POPJ P, SKIPA B,[Q.R.TP] CN.BB: MOVEI B,QCN.B ;CONTROL-B BREAK PUSHJ P,IOGBND JRST BKCOM2 UDFB: MOVEI B,QUDF ;UNDEFINED FUNCTION BREAK JRST BKCOM UBVB: MOVEI B,QUBV ;UNBOUND VARIABLE BREAK JRST BKCOM WTAB: MOVEI B,QWTA ;WRONG TYPE OF ARGUMENT BREAK JRST BKCOM UGTB: MOVEI B,QUGT ;UNSEEN GO TAG BREAK JRST BKCOM WNAB: MOVEI B,QWNA ;WRONG # ARGS BREAK JRST BKCOM GCLB: MOVEI B,QGCL ;FAILED TO GARBAGE-COLLECT ENOUGH SPACE BREAK JRST BKCOM PDLB: MOVEI B,QPDL ;PDL OVERFLOW BREAK JRST BKCOM GCOB: MOVEI B,QGCO ;GC OVERFLOW BREAK JRST BKCOM IOLB: MOVEI B,QIOL ;I/O LOSSAGE BREAK JRST BKCOM FACB: MOVEI B,QFAC ;FAILED ACTION REQUEST BREAK BKCOM: PUSHJ P,IOGBND SAVE A B PUSH P,CBKCM0 PUSH P,R70 PUSH P,VMSGFILES MOVNI T,2 JRST ERRPRINT BKCOM0: JSP R,RSTR2 BKCOM2: MOVE AR2A,VE.B.E ;ERROR-BREAK-ENVIRONMENT SKOTT AR2A,LS JRST BKCOM3 HRRZ AR1,(AR2A) ;(OBARRAY . READTABLE) HLRZ AR2A,(AR2A) SKOTT AR1,SA JRST BKCOM3 SKOTT AR2A,SA JRST BKCOM3 BKCOM4: JSP T,SPECBIND 0 A,VARGS ;SPECIAL VALUE CELL OF ARGS 0 AR1,VREADTABLE 0 AR2A,VOBARRAY CBKCM0: SETZ A,BKCOM0 PUSHJ P,NOINTERRUPT MOVEI A,TRUTH PUSHJ P,$BREAK BKCOM1: PUSHJ P,UNBIND JRST UNBIND BKCOM3: PUSH P,[BKCOM2] PUSH P,A PUSH P,CPOPAJ MOVEI A,IGSBV EXCH A,VE.B.E FAC [LOSING VALUE FOR ERROR-BREAK-ENVIRONMENT!] SUBTTL INTERN FUNCTION AND RELATED ROUTINES INTERN: PUSH P,A ;ONLY INIT ENTERS INTERN AT INTRN0 INTRN3: PUSHJ P,PNGET ;MUST SAVE F - SEE FASLOAD SETOM LPNF INTRN1: SETZM RINF JSP TT,ATMHSH ;LEAVES ATOM'S HASHKEY IN T MOVEI AR2A,(A) HLRZ C,(A) INTRN: TLZ T,400000 IDIVI T,OBTSIZ HRLM TT,(P) INTRN4: LOCKI ;SO THAT NO INTERRUPT SNEAKS SOMETHING ON THE SKIPN D,VOBARRAY ; OBLIST JUST AFTER WE DECIDE IT ISNT THERE JRST INTNCO MOVEI C,(D) LSH C,-SEGLOG MOVE C,ST(C) TLNN C,SA JRST INTNCO MOVE T,ASAR(D) TLNN T,AS JRST INTNCO ROT TT,-1 ;GET BUCKET JUMPL TT,.+3 HLRZ A,@TTSAR(D) SKIPA HRRZ A,@TTSAR(D) PUSH FXP,TT JUMPE A,MAKA0 MOVEI C,A MAKF: MOVE AR1,C HRRZ C,(C) JUMPE C,MAKA HLRZ AR1,(C) SKIPN AR1 TROA AR1,$$$NIL ;BEWARE THE SKIP! MAKF1: HLRZ AR1,(AR1) HRRZ AR1,1(AR1) SKIPN T,RINF ;RINF HAS ZERO WHEN IN REGULAR INTERN MOVEI T,(AR2A) MAK2: JUMPE AR1,MAK1 JUMPE T,MAKF HLRZ B,(AR1) MOVE B,(B) SKIPN RINF JRST MAK4 CAME B,@RNTN2 ;(T) JRST MAKF ;COMPARE FOR RINTERN AOJA T,MAK3 MAK4: HLRZ D,(T) ;COMPARE FOR REGULAR INTERN CAME B,(D) JRST MAKF HRRZ T,(T) MAK3: HRRZ AR1,(AR1) JRST MAK2 MAKA3: HRRZ A,(P) SKIPGE LPNF JRST MAKA2 SKIPE B,V.PURE ;INTERN MAKES PURE SY2 IF *PURE=T ANDNOT SYMBOL CAIN B,QSYMBOL JRST MAKA3A PUSHJ P,PSYCONS JRST MAKA2 MAKA3A: PUSHJ P,SYCONS JRST MAKA2 MAKA0: TDZA D,D ;D=0 => BUCKET WAS EMPTY BEFORE THIS CALL MAKA: MOVEI D,1 MOVN C,RINF ;MAKE-UP NEW ATOM JUMPE C,MAKA3 PUSHJ P,PNGNK MAKA2: PUSHJ P,NCONS MOVE TT,(FXP) JUMPE D,MAKA5 HRRM A,(AR1) ;NCONC ONTO END OF BUCKET JRST MAKA4 MAKA5: HRRZ D,VOBARRAY JUMPL TT,.+3 HRLM A,@TTSAR(D) SKIPA HRRM A,@TTSAR(D) MAKA4: SKIPA C,A MAK1: JUMPN T,MAKF ;ATOM FOUND ON OBLIST HLRZ A,(C) POP FXP,TT ;SHOULD EXIT WITH OBTBL BUCKET # IN TT SUB P,R70+1 UNLKPOPJ ;;; COME HERE TO INTERN AN ATOM WHOSE PRINT NAME IS IN PNBUF. RINTERN: CAMN C,[350700,,PNBUF] ;SAVES F JRST RINTN1 RINTN0: PUSH FXP,T PUSH P,CPXTJ PUSH P,A ;ENTERING INTERN AFTER THE "PUSH P A", SO MUST DO HERE SKIPL LPNF JRST INTRN1 ADDI C,1 HRRM C,RNTN2 2DIF [MOVEI C,(C)]0,PNBUF MOVNM C,RINF INTRN2: MOVEI C,PNBUF ;DUPLICATE PNAME HASHING ALGORITHM MOVE T,PNBUF ; AS USED IN SXHASH MOVN D,RINF SOJLE D,.+3 XOR T,PNBUF(D) JRST .-2 LSH T,-1 JRST INTRN RINTN1: SKIPL LPNF JRST RINTN0 MOVE TT,PNBUF ROT TT,6 ADDI TT,/2 ;### OBTSIZ MUST BE ODD MOVE D,VOBARRAY JUMPL TT,.+3 HLRZ A,@1(D) SKIPA HRRZ A,@1(D) JUMPN A,CPOPJ PUSH FXP,TT PUSHJ P,RINTN0 POP FXP,TT MOVE D,VOBARRAY JUMPL TT,.+3 HRLM A,@1(D) POPJ P, HRRM A,@1(D) POPJ P, IMPLODE: SKIPA T,CRINTERN ;SUBR 1 MAKNAM: MOVEI T,PNGNK1 ;SUBR 1 JUMPE A,MKNM4 PUSH P,T PUSH P,RDLARG HRRZM A,RDLARG MOVEI T,MKNM1 PUSHJ FXP,MKNR6C POP P,RDLARG CRINTERN: POPJ P,RINTERN MKNM1: SKIPN A,RDLARG POPJ P, HRRZ B,(A) MOVEM B,RDLARG HLRZ A,(A) MKNM2: JSP T,CHNV1 JRST POPJ1 RDL12: MOVEI T,RINTERN MKNM4: SETZM PNBUF JSP TT,IRDA JRST (T) ;PNGNK1 OR RINTERN, THEN POPJ P, ;;; GET CHARACTER NUMERIC VALUE CHNV1X: TLO T,1 CHNV1: SKOTT A,SY+FX JRST CHNV1C TLNN TT,SY JRST CHNV1A CHNV1D: HLRZ TT,(A) HRRZ TT,1(TT) HLRZ TT,(TT) LDB TT,[350700,,(TT)] JRST CHNV1B CHNV1A: MOVE TT,(A) TLNN T,1 CHNV1B: SA% TDNN TT,[-200] SA$ TDNN TT,[-1000] JRST (T) CHNV1C: WTA [NOT ASCII CHARACTER!] JRST CHNV1 SUBTTL DEFPROP AND DEFUN ;;; THE BASIC IDEA OF DEFPROP IS: ;;; (DEFUN DEFPROP FEXPR (X) ;;; (DO () ((NULL (REMPROP (CAR X) (CADDR X))))) ;;; (PUTPROP (CAR X) (CADR X) (CADDR X))) ;;; THAT IS, REMOVE *ALL* OCCURRENCES OF THE PROPERTY BEFORE ;;; PUTTING ON THE NEW VALUE. DEFPROP: ;FEXPR REPEAT 2, PUSH P,A JSP T,DFPR2 JSP T,DFPR1 JRST DFPER HRRZ TT,(C) JUMPN TT,DFPER HLRZ A,(A) HLRZ AR1,(B) HLRZ B,(C) MOVEI C,(B) ;SYMBOL IN A; PROPERTY NAME IN B *AND* C; PROPERTY VALUE IN AR1. DEF1: MOVEI AR2A,(A) ;DEFUN COMES IN HERE DEF1B: PUSHJ P,REMPROP ;REMPROP SAVES C, AR1, AR2A MOVEI B,(AR1) JUMPN A,DEF1B ;REMOVE ALL OCCURRENCES OF THE PROPERTY MOVEI A,(AR2A) PUSHJ P,PUTPROP DEF9: POP P,A ;PUT NEW VALUE FOR PROPERTY POPI P,1 JRST $CAR DFPR2: HLRZ B,(A) ;SOME HAIRY CHECKS FOR DEFPROP AND DEFUN SKOTT B,SY ;SKIPS ON *FAILURE* TO GET A VALID SYMBOL JUMPN B,1(T) JRST (T) DFPR1: JUMPE A,(T) ;MORE HAIRY CHECKS FOR DEFPROP AND DEFUN HRRZ B,(A) ;SKIPS ON *SUCCESS* JUMPE B,(T) ;LEAVES STUFF SPREAD OUT IN A, B, C HRRZ C,(B) JUMPE C,(T) JRST 1(T) ;;; (DEFUN . ) DEFINES A FUNCTION. ;;; MAY BE OMITTED, OR MAY BE "EXPR", "FEXPR", OR "MACRO". ;;; MAY BE A SYMBOL (THE NAME OF THE FUNCTION), OR A LIST OF ;;; TWO TO FOUR SYMBOLS (IN WHICH CASE THE FLAG "MACRO" IS ILLEGAL). ;;; IS A NON-NIL SYMBOL OR A LIST OF SYMBOLS; THE FORMER INDICATES ;;; AN LEXPR (INCOMPATIBLE WITH THE "MACRO" AND "FEXPR" FLAGS). ;;; OTHER FORMATS FOR , INCLUDING APPEARANCE OF & KEYWORDS, ;;; CAUSES THE MACRO "DEFUN&" TO BE RUN INSTEAD. ;;; ;;; IF THE VALUE OF THE SWITCH DEFUN IS T, THEN THE EXPR-HASH HACK ;;; IS ENABLED. IN THIS CASE, DEFUN AVOIDS MAKING THE INTERPRETIVE ;;; DEFINITION IF HASHING THE DEFINITION INDICATES THAT IT IS ;;; THE SAME AS THE CURRENT, PRESUMABLY COMPILED, DEFINITION. ;;; THE VARIOUS CASES ARE: ;;; FORM OF : ;;; FOO (FOO BAR) (FOO BAR BAZ) (FOO BAR BAZ QUUX) ;;; EXPR-HASH PROPERTY IS ON THE ATOM: ;;; FOO (GET 'FOO 'BAR) - NONE - FOO ;;; [IF THIS IS A SYMBOL] ;;; EXPR-HASH PROPERTY INDICATOR IS: ;;; EXPR-HASH EXPR-HASH - NONE - QUUX ;;; DEFUN PUTS THE FUNCTION DEFINITION ON FOO UNDER THE PROPERTY: ;;; EXPR/FEXPR/MACRO BAR BAR BAR ;;; COMPILER PUTS THE FUNCTION DEFINITION ON FOO UNDER THE PROPERTY: ;;; SUBR/FSUBR/LSUBR BAR * BAZ BAZ ;;; * THE PROPERTY WILL BE A SYMBOL |FOO BAR| WHICH IN TURN ;;; WILL HAVE THE APPROPRIATE SUBR/FSUBR/LSUBR PROPERTY. DEFUN: REPEAT 2, PUSH P,A DEF7: HRRZ A,(A) HLRZ AR1,(A) CAIN AR1,QEXPR JRST DEF3 CAIE AR1,QFEXPR CAIN AR1,QMACRO JRST DEF3 ;(DEFUN ...) MOVEI AR1,QEXPR ;(DEFUN ...); DEFAULTS TO EXPR MOVE A,(P) ; IS IN AR1; THE CDR OF A IS ( ...); THE CAR OF (P) IS . DEF3: JSP T,DFPR1 ;MAKE SURE WE HAVE AT LEAST TWO THINGS JRST DEFNER HLRZ TT,(B) SKOTT TT,LS JRST DEF3L HLRZ AR2A,(B) ;MAYBE HAS & KEY WORDS? DEF3B: HLRZ T,(AR2A) JUMPE T,DEF3X ;NIL doesn't require DEFUN& !! SKOTT T,SY JRST DEF4 ;PATTERN MATCHINGS REQUIRE DEFUN& IRP FL,,[OPTIONAL,REST,AUX] CAIN T,Q%!FL JRST DEF4 ;KEYWORDS REQUIRE DEFUN& TERMIN DEF3X: HRRZ AR2A,(AR2A) JUMPN AR2A,DEF3B DEF3L: MOVEI A,QLAMBDA ;CREATE AN APPROPRIATE LAMBDA-EXPRESSION PUSHJ P,CONS MOVEI C,(A) HRRZ A,(P) ;THE CAR OF THIS IS MOVEI AR2A,QXPRHSH JSP T,DFPR2 ;CHECK TO SEE IF ATOM (SKIPS UNLESS SYMBOL) JRST DEF3A MOVEM B,(P) ;SAVE THIS FUNNY LIST CAIN AR1,QMACRO JRST DEFNER ;FUNNY FORMAT AND MACRO FLAG DON'T MIX HRRZ B,(B) ;PECULIAR FORMAT: (NAME EXPRNAME ...) HLRZ AR1,(B) JUMPE AR1,DEFNER HRRZ B,(B) SETO AR2A, ;FOR A 2-LIST, USE "EXPR-HASH" FOR EXPR-HASH PROPERTY, JUMPE B,DEF3A ; BUT MUST ALSO LOOK IN A DIFFERENT PLACE HRRZ B,(B) JUMPE B,DEF5 ;3-LISTS DON'T USE EXPR-HASH FEATURE HLRZ AR2A,(B) ;4-LISTS USE THE FOURTH ITEM ;EXPR-HASH PROP NAME IN AR2A, OR -1; ; DEFINITION IN C; PROPERTY NAME IN AR1; NAME IN CAR OF (P). DEF3A: SKIPN VDEFUN ;THE VALUE OF DEFUN CONTROLS JRST DEF5 ; THE EXPR-HASH HACK HLRZ A,@(P) JUMPGE AR2A,DEF6 ;JUMP UNLESS 2-LIST FORMAT MOVEI B,(AR1) ;MUST GET VALUE OF EXISTING PROPERTY PUSHJ P,GET1 ; AND SEARCH IT FOR THE EXPR-HASH PROPERTY JUMPE A,DEF5 ;IF NONE, LOSE JSP T,STENT TLNN TT,SY ;NO EXPR-HASH IF NOT A SYMBOL JRST DEF5 MOVEI AR2A,QXPRHSH ;A HAS THE ATOM CONTAINING THE EXPR-HASH PROPERTY, IF ANY. ;AR2A HAS AN ACTUAL EXPR-HASH PROPERTY NAME. DEF6: MOVEI B,(AR2A) MOVEI AR2A,(A) ;SAVE ATOM INVOLVED PUSHJ P,GET1 ;GET EXPR-HASH PROPERTY JUMPE A,DEF5 ;DO DEFUN IF NONE MOVE F,(A) ;EXPR-HASH PROPERTY VALUE BETTER BE FIXNUM! PUSHJ FXP,SAV5M1 MOVEI A,(C) ;CANONICAL LAMBDA FORM PUSHJ P,SXHASH+1 ;NCALL 1,.FUNCTION SXHASH PUSHJ FXP,RST5M1 CAMN TT,F JRST DEF9 ;AHA! HASHES MATCH! FORGET IT. MOVEI A,(AR2A) ;HASHES MATCH, SO FLUSH THE EXPR-HASH PROPERTY PUSHJ P,REMPROP ; AND THEN PERFORM THE DEFINITION ;THE CAR OF (P) IS THE ATOM TO PUTPROP ONTO; AR1 IS THE PROPERTY NAME; C IS THE VALUE. DEF5: HLRZ A,@(P) EXCH C,AR1 MOVEI B,(C) JRST DEF1 ;GO DO THE PUTPROP DEF4: POPI P,1 POP P,B MOVEI A,Q%DEFUN ;"DEFUN&" PUSHJ P,CONS ;TRY AGAIN WITH (DEFUN FOO ...) REPLACED BY JRST EV0 ; (DEFUN& FOO ...) SUBTTL TYIPEEK FUNCTION TYIPEEK: ;LSUBR (0 . 3) NCALLABLE SKIPA F,CFIX1 MOVEI F,CPOPJ MOVEI D,QTYIPEEK CAMGE T,XC-3 JRST WNALOSE SKIPE T ;NO ARGS <=> ONE ARG OF NIL AOSA T ;ELSE DECREMENT ARG COUNT FOR INCALL PUSH P,R70 MOVEI D,(P) ADDI D,(T) MOVEI AR2A,CPOPJ EXCH AR2A,(D) JSP D,XINCALL ;PROCESS ARGS 2 AND 3 SFA% QTYIPEEK ; (ALSO PUSHES F ONTO P) SFA$ [SO.TIP,,],,QTYIPEEK MOVEI A,Q%TYI HRLZM A,BFPRDP MOVEI A,(AR2A) ;GET ARG 1 IN A JSP T,GTRDTB ;GET READTABLE IN AR2A JUMPN A,TYPK1 ;NIL => ACCEPT ANY CHAR $$PEEK: HRRZ TT,TYIMAN ;CALL TYIMAN ONE EARLY TO JRST -1(TT) ; SPECIFY PEEKING TYPK1: CAIE A,TRUTH ;T => SEARCH FOR READER START JRST TYPK3 ; CHARACTER (E.G. PAREN, MACRO) TYPK1C: PUSHJ P,$$PEEK ;PEEK AT A CHAR JUMPL TT,TYPK9A ;HIT EOF - TAKE A "SOFT" EOF, RETURN -1 MOVE T,@TTSAR(AR2A) ;PEEK SETS UP AR2A TLC T,4040 .SEE SYNTAX TLCE T,4040 JRST TYPK1F PUSH P,T PUSHJ P,@TYIMAN POP P,T CALLF 0,(T) ;HIT A HORRIBLE SPLICING MACRO JSP T,GTRDTB ;Refetch the read table. User code clobbers ;AR2A, and may have SETQed READTABLE JRST TYPK1C ;GO BACK AND TRY AGAIN TYPK1F: TLNE T,266217 .SEE SYNTAX ;READER START CHARS POPJ P, TYPK1H: PUSHJ P,@TYIMAN ;CHAR NOT ACCEPTABLE - GOBBLE IT JRST TYPK1C ;NOW GO TRY AGAIN TYPK3: JSP T,FXNV1 ;ARG MUST BE FIXNUM JUMPL TT,TYPK3C ;ARG BETWEEN 0 AND 777 => CAIG TT,777 ; SCAN FOR THAT CHARACTER; TLOA TT,400000 ; OTHERWISE IS A SYNTAX, LSH'ED TYPK3C: LSH TT,-11 ; LEFT BY 11, TO SERVE AS MASK PUSH FXP,TT TYPK4: PUSHJ P,$$PEEK ;PEEK AT A CHAR JUMPL TT,TYPK9 ;SOFT EOF - GO RETURN -1 OR WHATEVER SKIPL D,(FXP) ;SKIP IF SPECIFIC CHARACTER JRST TYPK6 CAIN TT,(D) ;COMPARE TO ONE WE GOT JRST POPXTJ ;SUPER WIN TYPK5: PUSHJ P,@TYIMAN ;NOT THE ONE - GOBBLE AND RETRY JRST TYPK4 TYPK6: HLRZ T,@TTSAR(AR2A) .SEE SYNTAX TDNN T,D ;CHECK SYNTAX AGAINST MASK JRST TYPK5 JRST POPXTJ TYPK9: SUB FXP,R70+1 TYPK9A: SKIPN EOFRTN ;"SOFT" EOF. DOES NOT INVOKE JRST M1TTPJ ; THE EOFFN, BUT WILL PICK UP JRST EOF9 ; THE EOFVAL IF NECESSARY. SUBTTL QUIT, VALRET, AND SUSPEND FUNCTIONS QUIT: MOVEI D,QQUIT ;LSUBR (0 . 1) AOJL T,S1WNALOSE SKIPE T TDZA A,A ;NO ARG => USE NIL POP P,A IT% JRST VLRT3 IFN ITS,[ CAIN A,TRUTH ;T MEANS KILL AS QUIETLY AS POSSIBLE JRST VLRT3 MOVEI D,160000 ;VANILLA-FLAVORED KILL CAIN A,Q$ERROR ;ERROR MEANS WE SHOULD KILL INPUT BUFFER TRZ D,100000 MOVEI TT,(A) LSH TT,-SEGLOG MOVE TT,ST(TT) TLNE TT,FX MOVE D,(A) ;FIXNUM ARG => USE FOR .BREAK 16, ARG JRST VLRT3A ] ;END OF IFN ITS VALRET: JUMPE T,VLRT9 ;LSUBR (0 . 1) JSP TT,LWNACK LA01,,QVALRET POP P,A PUSHJ P,VALSTR 10% SETOM SAWSP PUSHJ P,RETVAL ;VALRET STRING ON FXP IN APPROPRIATE MANNER 10% SETZM SAWSP POPJ P, ;;; TAKE SYMBOL OR FIXNUM IN A, PUSH PNAME STRING OR VALUE ONTO FXP. ;;; ON TOP OF THAT, AS LAST FXP SLOT, PUSH ORIGINAL VALUE OF FXP. VALSTR: JSP T,LATOM ;STRING A SYMBOL? JRST VALS1 IT$ SETZM VALFIX ;FLAG THAT VALRET 'STRING' IS NOT A FIXNUM PUSHJ P,PNGET MOVE R,FXP VLRT2: HLRZ B,(A) PUSH FXP,(B) HRRZ A,(A) JUMPN A,VLRT2 PUSHN FXP,1 ;PUSH A ZERO WORD FOR GOOD MEASURE PUSH FXP,R POPJ P, VALS1: IFN ITS,[ SKOTT A,FX ;ALLOW A FIXNUM JRST VALERR ;ERROR -- WTA SETOM VALFIX ;REALLY A FIXNUM MOVE R,FXP ;SAVE A COPY OF FXP PUSH FXP,(A) ;PUSH THE FIXNUM PUSH FXP,R ;THEN PUSH THE OLD FXP POPJ P, ] ;END IFN ITS VALERR: IT$ WTA [- ARG TO BE VALRET'ED MUST BE A FIXNUM OR A SYMBOL!] IT% WTA [- ARG TO BE VALRET'ED MUST BE A SYMBOL!] JRST VALSTR ;;; ASSUME VALSTR HAS PUSHED A VALRET STRING ONTO FXP. ;;; VALRET THAT STRING IN THE APPROPRIATE MACHINE-DEPENDENT WAY, ;;; EXCEPT THAT CERTAIN "ITS" STRINGS ARE INTERPRETED IN ANY ;;; IMPLEMENTATION (AN ANACHRONISM FOR COMPATIBILITY ONLY). ;;; AFTER DOING WHATEVER, THE STRING IS FLUSHED FROM FXP. RETVAL: IFN ITS,[ SKIPN VALFIX ;WAS VALRET STRING REALLY A FIXNUM? JRST RETSTR ;NO, NORMAL HANDLING HRRZ TT,-1(FXP) ;YES, PICK UP THE FIXNUM .BREAK 16,(TT) MOVE FXP,(FXP) ;RESET FXP POPJ P, ;IF CONTINUING RETURN AND GO ON RETSTR: ] ;END IFN ITS MOVE R,(FXP) MOVE D,1(R) CAME D,[ASCII \:KILL\] CAMN D,[ASCII \:kill\] CAIA JRST VLRT1 MOVE D,2(R) CAME D,[ASCII \ \] CAMN D,[ASCII \ \] JRST VLRT3 JRST VLRT5 VLRT1: CAMN D,[ASCII \.\] JRST VLRT3 CAME D,[ASCII \U\] CAMN D,[ASCII \u\] JRST VLRT9 ;HERE IS THE MACHINE-DEPENDENT THING TO DO TO RET THE VAL STRING VLRT5: IT$ .VALUE 1(R) IFN D10,[ SA% OUTSTR 1(R) IFN SAIL,[ SETZ D, ;D IS ZERO FOR TWO DIFFERENT REASONS! MOVEI TT,1(R) ;THIS PIECE OF CRAP LOOKS LIKE HRLI TT,440700 ; SOMETHING RPG WOULD WRITE (BUT GLS DID) ILDB T,TT JUMPN T,.-1 MOVEI T,^M ;CRUFTY STRAY ^M MAKES PTLOAD HAPPIER DPB T,TT IDPB D,TT ;THEN TERMINATE WITH A NULL HRLI R,440700 HRRI R,1(R) PTLOAD D ;LOAD THE STRING INTO THE LINE EDITOR ] ;END OF IFN SAIL ] ;END OF IFN D10 IFN D20,[ PUSH P,A HRRI 1,(R) TLO 1,440700 RSCAN POP P,A ] ;END OF IFN D20 MOVE FXP,(FXP) POPJ P, VLRT3: IFE ITS,[ VLRT9: 10$ EXIT 1, 20$ HALTF POPJ P, ] ;END IFE ITS IFN ITS,[ MOVEI D,120000 ;"SILENT KILL" VLRT3A: .LOGOUT 1, ;TRY TO LOG OUT JSP T,SIDDTP .VALUE .BREAK 16,(D) VLRT9: .LOGOUT 1, ;TRY TO LOG OUT .VALUE [ASCIZ \:VK \] ;OH, WELL... POPJ P, ;IN CASE LOSER DOES $P FROM IT SIDDTP: .SUSET [.ROPTION,,TT] TLNN TT,OPTBRK ;SKIP IF JOB INFERIOR TO DDT JRST (T) ; (ACTUALLY, IF SUPERIOR HANDLES .BREAK) JRST 1(T) ] ;END OF IFN ITS SUSPEND: ;LSUBR (0 . 2) JSP TT,LWNACK LA012,,QSUSPEND IT$ SETZM PURDEV ;ASSUME NO DUMPING PUSH FLP,R70 ;ASSUME WE ARE RETURNING FROM A RESTART PUSH FLP,R70 ;ALSO ASSUME FIRST ARG IS NON-NIL JUMPE T,SUSP0 AOJE T,SUSP0C ;JUMP IF ONE ARG POP P,A ;2ND ARG, IF ANY, IS SAVE FILE NAME FOR HISEG ; FOR ITS, IS NAME OF PDUMP FILE IFN D10*HISEGMENT,[ SKIPN SUSFLS JRST SUSP0C PUSHJ P,FIL6BT ;CONVERT FILESPEC IN A TO SIXBIT ON FXP PUSHJ P,DMRGF ;MERGE WITH DEFAULTS POP FXP,SGAEXT ;UNSTACK ARGS INTO PROPER SPOT POP FXP,SGANAM POP FXP,SGAPPN POP FXP,SGADEV PUSHJ P,SAVHGH ;SAVE HIGH SEGMENT FAC [FAILED TO SAVE HIGH SEGMENT - SUSPEND!] ] ;END OF IFN D10*HISEGMENT IFN ITS,[ PUSHJ P,FIL6BT ;CONVERT FILESPEC IN A TO SIXBIT ON FXP PUSHJ P,DMRGF ;MERGE WITH DEFAULTS POP FXP,PURFN2 ;UNSTACK ARGS INTO PROPER SPOT POP FXP,PURFN1 POP FXP,PURSNM POP FXP,PURDEV ] ;END IFN ITS SUSP0C: POP P,A ;POP FIRST ARGUMENT SKIPN A ;FIRST ARG NIL? AOSA (FLP) ;YES, NO VALRET STRING PUSHJ P,VALSTR ;NO, PROCESS IT ONTO FXP SKIPA SUSP0: PUSH FXP,R70 ;ZERO WORD MEANS VALRET STRING SETZ A, MOVEI T,LCHNTB SUSP11: SOJE T,SUSP12 SKIPE B,CHNTB(T) CAMN B,V%TYI JRST SUSP11 CAMN B,V%TYO JRST SUSP11 MOVE TT,TTSAR(B) ;IF FILE IS CLOSED THEN IGNORE IT TLNN TT,TTS.CL PUSHJ P,XCONS JRST SUSP11 SUSP12: JUMPN A,SUSPE HRRZ A,V%TYI ;CLOSE THE TTYS LAST, SO THEY WONT CAUSE MOVE TT,TTSAR(A) ;SPURIOUS "CANT SUSPEND -I/O IN PROGRESS" TLNN TT,TTS.CL PUSHJ P,$CLOSE HRRZ A,V%TYO MOVE TT,TTSAR(A) TLNN TT,TTS.CL PUSHJ P,$CLOSE SUSP1: HRROS NOQUIT MOVEM NIL,GCNASV+1 MOVE T,[FREEAC,,GCNASV+2] BLT T,GCNASV+2+17-FREEAC SETOM NOPFLS IFN ITS*USELESS,[ MOVE T,IMASK TRNN T,%PIMAR JRST SUSP14 .SUSET [.RMARA,,SAVMAR] .SUSET [.SMARA,,R70] SUSP14: ] ;END OF IFN ITS*USELESS IFN ITS\D20,[ IT$ SETOM SAWSP ;ITS ALWAYS WANTS TO DO A PMAP FROM FILE MOVEI T,FLSSTARTUP EXCH T,LISPSW MOVEM T,GCNASV SKIPE SUSFLS ;IF FLUSHING PURE PAGES PROCESS VALRET THEN JRST FLSLSP FLSNOT: PUSHJ P,PDUMPL ;PURE DUMP LISP IF APPROPRIATE MOVEI T,SUSP3 ;FROM HERE ON IN START AT SUSP3 DIRECTLY MOVEM T,LISPSW SKIPE (FLP) ;NIL JCL? JRST SUSCON ;YES, CONTINUE ON AND RETURN T SKIPN 1,(FXP) ;ZERO WORD MEANS NO VALRET STRING JRST SUSP24 IT$ PUSHJ P,RETVAL 20$ HRROI 1,1(1) JRST SUSP25 ] ;END OF IFN ITS\D20 IFN D10,[ HRRZ T,.JBSA" HRL T,.JBREN" MOVEM T,GCNASV MOVE T,.JBREL ;GET HIGHEST ADR WE NEED TO SAVE HRLM T,.JBSA ;AND STORE IN CORRECT PLACES SO MONITOR KNOWS MOVEM T,.JBFF MOVEI T,SUSP3 HS% HRRM T,.JBSA HS$ HRRM T,RETHGH SKIPE (FLP) ;NIL JCL? JRST SUSCON ;YES, CONTINUE AND RETURN T SKIPN (FXP) JRST SUSP24 SA$ PUSHJ P,RETVAL ;PTLOAD VALRET STRING FOR SAIL JRST SUSP25 ] ;END OF IFN D10 SUSP24: MOVE T,FXP POPI T,1 MOVEM T,(FXP) 10$ MOVEI TT, 20$ HRROI 1,FLSPA1 IT$ MOVEI TT,FLSPA1 SUSP25: IFN ITS,[ .VALUE (TT) ;PRINT SUSPENSION MESSAGE JRST SUSCON ] ;END OF IFN ITS IFN D20,[ PSOUT HALTF ] ;END OF IFN D20 IFN D10,[ OUTSTR (TT) HS$ JRST KILHGH IFE HISEGMENT,[ IFN SAIL,[ MOVEI A,FAKDDT ;FOO, HOW MANY WAYS CAN SAIL LOSE? SKIPN .JBDDT ; JOBDDT MUST BE NON-ZERO TO SAVE! SETDDT A, ; ELSE MAY FAIL TO SAVE ENTIRE LOSEG ] ;END IFN SAIL EXIT 1, ] ;END IFE HISEGMENT ] ;END OF IFN D10 ;;; HERE ON STARTUP AGAIN AFTER SUSPENSION SUSP3: MOVE NIL,GCNASV+1 ;RESTORE IMPORTANT AC'S MOVE T,[GCNASV+2,,FREEAC] BLT T,17 SETZB A,B ;CLEAR OUT GARBAGE SETZB C,AR1 SETZ AR2A, SKIPN (FLP) ;RESTORE FXP UNLESS JCL WAS NIL MOVE FXP,(FXP) IFN ITS+D20,[ MOVE T,GCNASV MOVEM T,LISPSW JSP T,SHAREP ;RE-READ PURE PAGES IF EVERYTHING IS IN ORDER ] ;END OF IFN ITS+D20 IFN ITS,[ .SUSET [.ROPTION,,TT] TLO TT,OPTINT+OPTOPC ;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE .SUSET [.SOPTION,,TT] .SUSET [.SDF1,,R70] .SUSET [.SDF2,,R70] .SUSET [.SMASK,,IMASK] .SUSET [.SMSK2,,IMASK2] IFN USELESS,[ MOVE T,IMASK TRNE T,%PIMAR .SUSET [.SMARA,,SAVMAR] ] ;END OF IFN USELESS ] ;END OF IFN ITS 20$ JSP R,TNXSET ;MUST BE DONE BEFORE PION IFN D10,[ MOVE T,GCNASV HRRM T,.JBSA" HLRM T,.JBREN SA% JSP T,D10SET ] ;END OF IFN D10 PION JSP T,PPNUSNSET SETZM NOPFLS HRRZS NOQUIT PUSHJ P,OPNTTY ;*** TEMP CROCK? JFCL PUSHJ P,UDIRSET POPI FLP,1 ;REMOVE NIL VALRET FLAG POP FLP,A ;RESTORE RETURN VALUE POPJ P, SUBTTL HIGH SEGMENT SAVE ROUTINE IFN D10,[ ;;; THE RELEVANT FILE NAMES ARE IN SGADEV, SGAPPN, SGAEXT. ;;; THE MAIN FILE NAME IS PASSED THROUGH T, AND STORED INTO ;;; SGANAM ON SUCCESS. SKIP RETURN ON SUCCESS. IFN HISEGMENT,[ SAVHGH: LOCKI ;LOCK OUT INTERRUPTS AROUND USE OF TEMP CHANNEL MOVE F,SGANAM IFN SAIL,[ SKIPL .JBHRL ;IS HISEG CURRENTLY WRITE-PROTECTED? JRST SAPWIN ;NO, MUST PREVIOUSLY HAVE UNPURIFIED IT SKIPN PSGNAM JRST FASLUH MOVEI T,.IODMP MOVE TT,PSGDEV SETZ D, OPEN TMPC,T ;OPEN UP .SHR FILE DEVICE IN DUMP MODE JRST FASLUH MOVE T,PSGNAM MOVE TT,PSGEXT SETZ D, MOVE R,PSGPPN LOOKUP TMPC,T JRST FASLUR MOVS T,R MOVNS T ;T GETS LENGTH OF .SHR FILE ADDI T,HSGORG-1 PUSHJ P,LDRIHS ;GO READ IN HIGH SEGMENT (FROM WITHIN LOSEG!) RELEASE TMPC, ;FLUSH TEMP CHANNEL MOVE T,D10NAM ;USE D10NAM AS HISEG NAME TO FOIL SHARING LSH T,-6 ;AS LONG AS WE'RE BEING RANDOM... SETNM2 T, JFCL MOVE F,SGANAM ;RESTORE MAIN FILE NAME SAPWIN: ] ;END OF IFN SAIL SETZM SGANAM MOVE R,SGADEV IFN SAIL,[ ;;;SAVE VALIDATION WORDS IN HISEG, HOPE THAT HISEG WRITEABLE MOVEM R,PSGDEV MOVE D,SGAEXT MOVEM D,PSGEXT MOVE D,SGAPPN MOVEM D,PSGPPN ] ;END OF IFN SAIL MOVEI D,.IODMP MOVE T,F ;SGANAM WAS SAVED IN F SETZ F, OPEN TMPC,D UNLKPOPJ MOVE TT,SGAEXT SETZ D, MOVE R,SGAPPN SA$ MOVEM T,PSGNAM ENTER TMPC,T UNLKPOPJ MOVEI TT,HSGORG-1 ;MAKE UP IOWD SUB TT,.JBHRL MOVSS TT HRRI TT,HSGORG-1 SETZ D, OUT TMPC,TT ;OUTPUT THE HISEG CAIA UNLKPOPJ CLOSE TMPC, ;FLUSH TEMP CHANNEL RELEASE TMPC, MOVEM T,SGANAM ;WE CAREFULLY DO NOT STORE SGANAM UNTIL UNLOCKI ; WE HAVE CLEARLY WON (MORE OR LESS) JRST POPJ1 ] ;END IFN HISEGMENT ] ;END OF IFN D10 SUBTTL ARGS FUNCTION ARGS: JSP TT,LWNACK ;LSUBR (1 . 2) - USES A,B,C,T,TT,D,R,F LA12,,QARGS JSP R,PDLA2(T) ;SPREAD ARGS ARGS1: SKOTT A,SY JRST ARGS0 ;FIRST ARG MUST BE SYMBOL HLRZ F,(A) ARGS1A: AOJL T,ARGS3 ;TWO ARGS HLRZ R,1(F) ;JUST WANT TO GET PRESENT ARGS PROP ARGSCU: JUMPE R,FALSE ;ARGS CONS-UP IDIVI R,1000 SKIPN B,F JRST ARGSC1 MOVEI TT,-1(F) JSP T,FIX1A MOVEI B,(A) ARGSC1: SKIPN A,R JRST CONS MOVEI TT,(R) CAIE TT,777 SUBI TT,1 JSP T,FIX1A JRST CONS ARGS3: JUMPE A,CPOPJ JUMPN B,ARGS5 HLRZ R,1(F) ;JUST WANT TO FLUSH ARGS PROP JUMPE R,FALSE SETZ R, PUSH P,A JSP D,ARGCLB SUB P,R70+1 JRST TRUE ARGS5: PUSH P,A SETZB TT,R HLRZ C,(B) ;MUMBLE MUMBLE - MUST FIGURE JUMPE C,ARGS6 ; OUT WHATEVER WE WERE HANDED JSP T,FXNV3 CAIE R,777 ADDI R,1 LSH R,11 ARGS6: HRRZ A,(B) JSP T,FXNV1 CAIE TT,777 ADDI TT,1 ADDI R,(TT) HLRZ TT,1(F) ;LOOK AT ARGS PROP ALREADY THERE CAIN TT,(R) ;IF ALREADY WHAT WE WANT, JUST EXIT, JRST POPAJ ; THEREBY AVOIDING A PURE PAGE TRAP MOVEI D,POPAJ ;FAKE OUT A JSP D, ARGCLB: MOVEI B,(F) ;CLOBBER IN AN ARGS PROPERTY ARGCL3: PURTRAP ARGCL7,B, HRLM R,1(B) ;MAY HAVE TO FUSS ABOUT PURE PAGE TRAP JRST (D) ARGS0: MOVEI F,$$$NIL JUMPE A,ARGS1A WTA [ NON-SYMBOL - ARGS!] JRST ARGS1 SUBTTL EVALFRAME FUNCTION, GTPDLP, AND FRETURN EVALFRAME: SKIPA R,[GTPDLP] ;THIS ENTRY CAUSES INTERPRETATION OF ARG AS PDLPOINTER FRM2A: MOVEI R,GTPDL2 ;THIS ENTRY, TO ALLOW CONTINUING FROM WHERE D CURRENTLY IS JSP R,(R) $EVALFRAME ;GET EVALFRAME OR APPLYFRAME JUST PRIOR TO $APPLYFRAME ; POINT ON PDL MARKED BY ARG JRST FALSE FRM3: SUB D,R70+1 ;DEFINE A FRAME POINTER TO BE JUST BELOW THE EVALFRAME MARKER HRRZ TT,(D) JUMPN F,FRM3A ;F IS INDEX OF WHICH KIND OF FRAME MOVEI T,(TT) LSH T,-SEGLOG SKIPL ST(T) JRST FRM4A HLRZ TT,(TT) FRM3A: CAIN TT,QEVALFRAME ;DONT ALLOW THE CALL TO EVALFRAME JRST FRM2B ; ITSELF TO BE OUTPUT FRM4A: PUSH P,(D) FRM4: ;ERRFRAME COMES HERE HLRO TT,(D) ;ONE LEFT HALF'S AS GOOD AS ANOTHER... JSP T,FIX1A ;MAKE UP PREVIOUS SPECIAL PDL POINTER PUSHJ P,ACONS EXCH B,(P) MOVE TT,1(D) CAME TT,[$APPLYFRAME] JRST FRM8 PUSH P,A PUSH P,B MOVE T,-2(D) .SEE $APPLYFRAME ;BECAUSE THERE IS A DISCUSSION JUMPL T,FRM5 ; OF THE FRAME FORMAT THERE MOVEI A,(T) TLCN T,-1 ;THINK ABOUT THIS WHEN YOU LOOK! JRST FRM7 HLRS T ;SUBTLE WAY TO GET NEGATION ADDI T,(D) FRM5: SETZ A, FRM5A: HRRZ B,(T) PUSHJ P,XCONS AOBJN T,FRM5A PUSHJ P,NREVERSE FRM7: PUSHJ P,ACONS POP P,B PUSHJ P,XCONS MOVEI B,(A) POP P,A FRM8: PUSHJ P,XCONS MOVE B,A ;OUTPUT 4-LIST: "EVAL" OR "APPLY" OR "ERR" [A SYMBOL] HRROI TT,(D) ; FRAME (REGPDL) POINTER [A FIXNUM] JSP T,FIX1A ; [EVAL] OR ( ) [APPLY] PUSHJ P,CONS ; OR [ERR] MOVE TT,1(D) ; ALIST (SPECPDL) POINTER [A FIXNUM] MOVEI B,QOEVAL CAMN TT,[$APPLYFRAME] MOVEI B,QAPPLY CAMN TT,[$ERRFRAME] MOVEI B,QERR PUSHJ P,XCONS JRST POPBJ FRM2B: TLNE R,1 ADD D,R70+2 ;WHEN SEARCHING FORWARD, SKIP OVER CALL JRST FRM2A ;TO EVALFRAME GTPDLP: ;CALLED BY JSP R,GTPDLP; RETURNS PDL PTR IN D MOVEI D,(P) JUMPE A,GTPDL2 ;ARG=NIL => START SEARCH FROM CURRENT PDL POS JSP T,FXNV1 ;NOTE: EVALFRAME LOOKS AT BIT 3.1 OF R JUMPL TT,GTPDL5 ;BIT 3.1 OF R = 0 WHEN SEARCHING BACK THE PDL TLO R,1 ;BIT 3.1 OF R = 1 WHEN SEARCHING FORWARD MOVNS TT ;WANT TO SKIP OVER THE FRAME MARKER WHEN SKIPN TT ; SEARCHING FORWARD (SINCE A PDLPOINTER WILL SKIPA TT,C2 ; BE POINTING TO ONE BELOW A FRAME MARKER) ADD TT,R70+2 GTPDL5: TLZ TT,-1 HRRZ T,C2 CAIGE TT,(T) JRST GTPDL1 MOVEI T,(P) SUBI T,(TT) JUMPLE T,GTPDL1 MOVEI T,(TT) CAIL T,(P) MOVE TT,P HRROI D,(TT) GTPDL2: MOVE TT,(R) ;KEY ON WHICH TO SEARCH JUMPE TT,2(R) ;MATCH 0 => NO SEARCH, JUST GIVE OUT PDL PTR MOVE F,1(R) ;WELL, IT'S POSSIBLE TO SEARCH FOR TWO THINGS TLNE R,1 JRST GTPDL4 HRRZ T,C2 GTPDL3: CAIL T,(D) ;A BACK SEARCH JRST 2(R) ;SEARCHED-AND-FAILED EXIT CAMN TT,(D) JRST GTPX0 CAMN F,(D) JRST GTPX1 SOJA D,GTPDL3 GTPDL4: MOVEI T,(P) GTP4A: CAMN TT,(D) JRST GTPX0 CAMN F,(D) JRST GTPX1 CAIG T,(D) JRST 2(R) ;FAILURE AOJA D,GTP4A GTPX0: TDZA F,F GTPX1: MOVEI F,1 JRST 3(R) FRETURN: TDZA C,C ;LH OF C REMEMBERS WHICH ENTRY FRETRY: MOVSI C,TRUTH HRR C,B JSP R,GTPDLP 0 JFCL MOVEI F,(D) MOVE TT,[$EVALFRAME] CAMN TT,1(F) JRST FRETR1 MOVE TT,[$APPLYFRAME] CAME TT,1(F) JRST FRERR FRETR1: MOVEI D,(F) SUBI D,(P) HRLI D,(D) HRRI D,(F) MOVE TT,[$UIFRAME] CAME TT,(D) ;SEARCH FOR A USER INTERRUPT FRAME AOBJN D,.-1 CAMN TT,(D) JSP TT,UIBRK FRP1: SKIPE T,PA4 ;BREAK UP A DOMINEERING PROG CAIL F,(T) ;[WHICH BREAKS UP INTERIOR ERRSETS AND CATCHES] JRST FRP2 MOVEI TT,FRP1-1 ;FAKE OUT RETURN BY INSERTING A RETURN-ADDRESS MOVEM TT,-LPRP+1(T) ;OF FRP1 ON THE PDL JRST RETURN FRP2: SKIPE B,ERRTN ;BREAK UP A DOMINEERING ERRSET FRP2A: CAIL F,(B) JRST FRP4 MOVEI T,FRP1 MOVEI TT,FRP1 JRST BKRST0 FRP4: SKIPE B,CATRTN ;BREAK UP A CATCH CAIL F,(B) JRST FRP3 MOVEI T,FRP1 ;IN CASE OF UNWIND-PROTECT MOVEI TT,FRP1 JRST BKRST0 FRP3: SKIPN B,EOFRTN ;BREAK OUT OF ANY E-O-F SET READS JRST FRP3QA CAIGE F,(B) JRST FRP2A FRP3QA: MOVEI A,(C) IFE PAGING,[ ADDI F,1 ;FIX UP PDL POINTERS SUB F,C2 HRLS F ADD F,C2 MOVE P,F HRRZ F,-2(P) SUB F,FXC2 HRLS F ADD F,FXC2 MOVE FXP,F HLRZ F,-2(P) SUB F,FLC2 HRLS F ADD F,FLC2 MOVE FLP,F ] ;END OF IFE PAGING IFN PAGING,[ ;IN A PAGED SYSTEM, THE PDLOV HANDLER HRROI P,1(F) ; WILL FIX UP THE LHS OF THE PDL PTRS HLRO FLP,-2(P) HRRO FXP,-2(P) IFN SAIL,[ PFIXPDL TT FLPFIXPDL TT FXPFIXPDL TT ] ;END OF IFN SAIL ] ;END OF IFN PAGING HLRZ TT,-1(P) TLNN C,-1 ;FOR "FRETURN" JUST UNBIND TO MARKED JRST UBD ; POINT, AND POP FRAME PUSHJ P,UBD HLRZ TT,(A) ;BUT DO MORE FOR "FRETRY", AFTER UBD JSP T,%CADDR POPI P,L$EVALFRAME ;GET RID OF BASIC EVALFRAME CAIE TT,QAPPLY JRST EVAL HRRZ B,(A) HLRZ B,(B) HLRZ A,(A) HLRE T,(P) ;GET RID OF ARGS ON APPLYFRAME SKIPG T ;FIGURE OUT LENGTH OF ARGS PART MOVEI T,1 HRLI T,(T) SUB P,T JRST .APPLY SUBTTL GETCHAR, GETCHARN, AND SUBLIS $GETCHARN: PUSH P,CFIX1 ;SUBR 2 - NCALLABLE SKIPA F,[ZPOPJ,,CPOPJ] GETCHAR: MOVE F,[FALSE,,RDCH2] ;SUBR 2 SKIPE V.RSET JRST GETCH8 MOVE D,(B) PUSHJ P,PNGT0 GETCH1: SOJL D,(F) IDIVI D,5 ;(Q,R) QUOTIENT,REMAINDER IN D,R SOJL D,GETCH3 GETCH2: HRRZ A,(A) ;CDR BY Q WORDS SOJGE D,GETCH2 ;RECALL THAT (CDR NIL) = NIL JUMPE A,GETCH4 GETCH3: HLRZ A,(A) LDB TT,GTCTB(R) JUMPN TT,(F) GETCH4: MOVS F,F JRST (F) GETCH8: JSP T,FXNV2 PUSHJ P,PNGET JRST GETCH1 GTCTB: 350700,,(A) 260700,,(A) 170700,,(A) 100700,,(A) 010700,,(A) SUBLIS: JUMPN A,SUBLSA ;NULL SUBSTITUTION LIST? MOVE A,B ;YES, RETURN SECOND ARG POPJ P, SUBLSA: PUSH P,A ;USES ONLY A,B,T,TT,D,R PUSH P,B MOVE D,A HLLOS NOQUIT ;MOBY DELAYED QUIT FEATURE SUBL1: JUMPE D,SUBL2 HLRZ T,(D) ;A SUBSTITUTION LIST IS LIKE HLRZ B,(T) ;((U1 . S1) (U2 . S2) . . .) SKOTT B,SY JRST SUBLOSE SUBL1B: HRRZ A,(B) ;SEXPRESSION S IS SUBSTITUTED FOR ATOM U HLRZ A,(A) CAIN A,QSUBLIS JRST SUBL1A HRRZ A,(T) MOVEM B,T HRRZ B,(B) PUSHJ P,CONS MOVEI B,QSUBLIS ;PUT "SUBLIS" PROPERTY ON THOSE ATOMS U IN THE PUSHJ P,XCONS ;SUBSTITUTION LIST ((U1 . V1) . . . (UN . VN)) HRRM A,(T) SUBL1A: HRRZ D,(D) MOVE T,INTFLG AOJGE T,SUBL1 ;0=> NO INT, -1=> USER INT, -2,-3=> QUIT MOVE R,D JRST SUBL3Q SUBLOSE: JUMPE B,SUBL3Z MOVEI A,(B) MOVEI R,(D) MOVEI T,[LER3 [SIXBIT \NON-ATOMIC ITEM - SUBLIS!\]] MOVEM T,-2(P) SUBL3Q: SUB P,R70+1 JRST SUBL3A SUBL3Z: MOVEI B,NILPROPS JRST SUBL1B SUBL2: POP P,A PUSHJ P,SBL1 JFCL MOVEI R,0 ;REMOVE ALL "SUBLIS" PROPERTIES SUBL3A: MOVE TT,(P) SUBL3: CAIN R,(TT) ;REMOVE "SUBLIS" PROPERTY JRST SUBL4 HLRZ T,(TT) HLRZ T,(T) JUMPN T,.+2 MOVEI T,NILPROPS HRRZ B,(T) MOVE B,(B) HLRZ D,B HRRZ B,(B) CAIN D,QSUBLIS HRRM B,(T) HRRZ TT,(TT) JRST SUBL3 SUBL4: SUB P,R70+1 JRST CZECHI SBL1: SKOTT A,LS ;TRACE THROUGH STRUCTURE IN (A) SUBSTITUTING JRST SBL2 ;(GET 'U 'SUBLIS) FOR U WHEREVER IT IS NON-NIL PUSH P,A HLRZ A,(A) PUSHJ P,SBL1 JRST SBL4 EXCH A,(P) HRRZ A,(A) PUSHJ P,SBL1 JFCL HRRZ B,(P) SBL5: SUB P,R70+1 PUSHJ P,XCONS JRST POPJ1 SBL4: HRRZ A,@(P) PUSHJ P,SBL1 JRST POPAJ HLRZ B,@(P) JRST SBL5 SBL2: TLNN TT,SY JRST SBL2B HRRZ B,(A) SBL2A: HLRZ T,(B) CAIE T,QSUBLIS POPJ P, HRRZ A,(B) HLRZ A,(A) JRST POPJ1 SBL2B: JUMPN A,CPOPJ HRRZ B,NILPROPS JRST SBL2A SUBTTL SAMEPNAMEP AND ALPHALESSP SAMEPNAMEP: TDZA D,D ;USES ONLY A,B,T,TT,D ALPHALESSP: MOVEI D,TRUTH ;MUST PRESERVE C,AR1,AR2A,R,F (SEE SORT) PUSH P,B PUSHJ P,PNGET EXCH A,(P) PUSHJ P,PNGET POP P,B ;FROM NOW ON, A HAS PNAME OF 2ND ARG, B OF 1ST JRST ALPLP1 ALPL3: HRRZ A,(A) HRRZ B,(B) ALPLP1: JUMPE B,ALPL2 JUMPE A,FALSE ;ON SAMEPN, LOSE IF 2ND ARG RUNS OUT BEFORE 1ST HLRZ T,(A) ;ON ALPHAL, LOSE IF 2ND ARG IS SHORTER THAN 1ST MOVE T,(T) HLRZ TT,(B) ;FOR SAMEPN, WILL RETURN NIL IF ;TWO ARE UNEQUAL IN SOME PLACE CAMN T,(TT) ;NO INFO IF CORRESPONDING PLACES ARE EQUAL JRST ALPL3 JUMPE D,FALSE ;BUT NOT EQUAL IN SAMENAMEP MEANS LOSE MOVE TT,(TT) ;MUST DO SOME HAIR FOR THE ALPHALESSP LSHC T,-1 ; COMPARE TO WIN, SINCE PNAME WORDS ARE CAMG T,TT ; LOGICAL DATA, NOT ARITHMETIC JRST FALSE ;2ND ARG STRICTLY LESS THAN FIRST JRST TRUE ;2ND ARG STRICTLY GREATER THAN FIRST ALPL2: EXCH A,D JUMPE D,NOT ;IF ALPHAL, WIN WHEN A NON-NUL ;[FOR 1ST ARG IS PROPER SUBSTRING OF 2ND] POPJ P, ;IF SAMEPN, WIN WHEN A NUL ;[FOR CORRESPONDENTS HAVE BEEN EQUAL ALL ALONG] SYSP: MOVEI B,TRUTH ;SUBR 1 - DETERMINE WHETHER SYMBOL HAS SYSP3: 10% CAIGE A,BEGFUN ; A "SYSTEM" SUBR PROPERTY 10$ CAIL A,ENDFUN JRST FALSE 10% CAIG A,ENDFUN 10$ CAIL A,BEGFUN JRST BRETJ CAIGE A,BSYSAR ; ... OR MAYBE A SYSTEM ARRAY PROPERTY JRST SYSP6 CAIGE A,ESYSAR JRST BRETJ ;RETURNS T FOR SUBR/SAR POINTERS CAIE B,QAUTOLOAD JRST SYSP6 CAIL A,BSYSAP CAIL A,ESYSAP JRST FALSE JRST BRETJ SYSP6: JSP T,SPATOM ;RETURNS FALSE FOR NON-SYMBOLS JRST FALSE PUSH P,A ;TRY THE AUTOLOAD PROPERTY FIRST MOVEI B,QAUTOLOAD PUSHJ P,$GET JUMPN A,SYSPZ SYSPZ1: POP P,A MOVEI B,ASBRL PUSHJ P,GETL1 JUMPE A,CPOPJ ;RETURNS FALSE FOR SYMBOLS WITH NO FN PROPS HLRZ B,(A) ;RETURNS NAME OF PROPERTY OF ONE IS FOUND, JSP T,%CADR JRST SYSP3 ; AND THE PROPERTY VALUE PASSES THE SYSP TEST SYSPZ: CAIL A,BSYSAP CAIL A,ESYSAP JRST SYSPZ1 ;AUTOLOAD PROPERTY NOT SYSTEM'S - GO ON POP P,A ;ELSE FLUSH STACK OF A MOVEI A,QAUTOLOAD ;AND RETURN AUTOLOAD POPJ P, GCTWA: JUMPE A,GCTWI HLRZ A,(A) PUSHJ P,NOTNOT MOVEM A,VGCTWA JRST GCTWX GCTWI: SETOM IRMVF GCTWX: MOVEI A,IN0 SKIPGE IRMVF ADDI A,1 SKIPE VGCTWA ADDI A,10 POPJ P, SUBTTL COPYSYMBOL FUNCTION COPYSYMBOL: JSP T,SPATOM JSP T,PNGE CPSY3: JUMPN B,CPSY0 ;IF NON-NIL SECOND ARG COPY PLIST, VC AND ARGS CPSY: PUSHJ P,PNGT0 ;COPY THE SYMBOL JRST SYCONS CPSY0: PUSH P,A ;SAVE OLD SYMBOL PUSHJ P,CPSY ;GET A NEW COPY EXCH A,(P) ;SAVE NEW COPY, GET OLD PUSH P,A ;SAVE OLD ON TOP OF STACK HRRZ A,(A) ;GET PLIST JUMPE A,CPSY1 ;IF NO PLIST THEN TRY VALUE CELL MOVEI B,NIL ;NOW GET A NEW COPY OF THE PLIST PUSHJ FXP,SAV5M3 PUSHJ P,.APPEND PUSHJ FXP,RST5M3 HRRM A,@-1(P) ;STORE IN NEW SYMBOL CPSY1: SKIPN A,(P) JRST CPSY4 HLRZ A,(A) ;POINTER TO OLD SYMBOL BLOCK HLRZ T,1(A) ;ARGS PROPERTY JUMPE T,.+3 ;IF NONE THEN DON'T HACK HLRZ TT,@-1(P) ; ELSE COPY THE ARGS PROPERTY HRLM T,1(TT) HRRZ A,@(A) ;GET CONTENTS OF VALUE CELL CAIN A,QUNBOUND ; IF UNBOUND DON'T BOTHER COPYING JRST S1PAJ CPSY4: EXCH AR1,-1(P) ;ELSE COPY VC BY DOING A (SET NEW OLD) JSP T,.SET EXCH AR1,-1(P) JRST S1PAJ SUBTTL SETSYNTAX AND OTHER READER SYNTAX FUNCTIONS ;ARGS ARE CHAR (AS NUMBER OR ATOM), SYNTAX-CODE, MACRO-OR-TRANSLATION SETSYNTAX: SETZ AR1, ;SUBR 3 MOVEI AR2A,(B) JSP T,SPATOM JRST RSSYN1 JSP T,CHNV1 JSP T,FIX1A RSSYN1: CAIN AR2A,QMACRO JRST RSSYN2 CAIE AR2A,QSPLICING JRST RSSYN3 MOVEI AR1,[QSPLICING,,NIL] RSSYN2: MOVE B,A PUSH P,CTRUE PUSH P,AR1 JRST SSMC43 RSSYN3: MOVSI AR1,40000 ;WAY TO FAKE OUT SSYN0 MOVEI B,(A) JUMPE C,RSSYN5 ;SKIP IF NO CHTRAN STUFF PUSHJ P,RSSYN4 HRRZM A,(FXP) MOVEI A,(B) ;LOSING RETROFIT FOR NSTST MOVEI B,(C) PUSHJ P,SSCHTRAN SUB FXP,R70+1 RSSYN5: JUMPE AR2A,TRUE ;XIT IF NO SYNTAX STUFF CAIE AR2A,QSINGLE JRST RSSYN7 NW% PUSH FXP,[600500] NW$ PUSH FXP,[RS.SCS] MOVEI C,(FXP) JRST RSSYN8 RSSYN7: MOVE C,AR2A PUSHJ P,RSSYN4 HLRZS (FXP) RSSYN8: MOVEI A,(B) ;LOSING RETROFIT FOR NSTAT MOVEI B,(C) PUSHJ P,SSSYNTAX SUB FXP,R70+1 CTRUE: JRST TRUE RSSYN4: PUSH FXP,R70 MOVEI A,(C) JSP T,SPATOM POPJ P, MOVEI C,(B) ;SAVE B JSP T,CHNV1 MOVEI A,(TT) MOVEI B,(C) ;RESTORE B MOVEI C,(FXP) ;SET C TO BE FIXNUM ON TOP OF PDL JSP T,RSXST MOVE TT,@RSXTB MOVEM TT,(FXP) POPJ P, SSCHTRAN: NW% SKIPA F,[HRRM R,(TT)] NW$ SKIPA F,[DPB R,[001100+TT,,]] SSSYNTAX: NW% MOVSI F,(HRLM R,(TT)) NW$ MOVE F,[LDB R,[113300+TT,,]] PUSH P,[SPROG3] MOVSI AR1,40000 ;LOSING CROCK SSSYN1: MOVEI C,(B) ;LOSING CROCK MOVEI B,(A) PUSHJ P,GRCTI ;GET INDEX FOR RCT INTO D TLNE AR1,40000 ;40000 BIT SAYS EVAL 3RD ARG JSP T,FXNV3 JSP T,SMCR2 ;LOCK AND SETUP RCT ARRAY PTR INTO TT ADDI TT,(D) XCT F ;MAY SKIP (FOR (STATUS CHTRAN)) UNLKPOPJ ;MUST BE ONLY ONE INSTRUCTION. NW% TLNE TT,4000 ;SKIP UNLESS MACRO CHAR NW$ TLNE TT,(RS.MAC);SKIP UNLESS MACRO CHAR MOVEI TT,(D) ;USE CHARACTER AS ITS OWN CHTRAN TLZ TT,-1 UNLKPOPJ GRCTI: JSP T,FXNV2 ;GET READTABLE INDEX SA% CAIGE D,NASCII SA$ CAIGE D,1010 JUMPGE D,CPOPJ JRST GRCTIE SMACRO: MOVEI B,(A) PUSHJ P,GRCTI JSP T,SMCR2 ADD TT,D SMCR1: MOVEI A,NIL MOVE C,(TT) UNLOCKI NW% TLNN C,4000 NW$ TLNN C,(RS.MAC) POPJ P, ;EXIT WITH NIL IF NO MACRO CHAR NW% TLNE C,40 NW$ TRNE C,RS.ALT MOVEI A,QSPLICING ;SPLICING TYPE PUSHJ P,NCONS NW% MOVEI B,(C) NW$ PUSH P, A NW$ PUSHJ P, GETMAC NW$ HRRZ B, (A) ;CDR OF ASSQ IS FUNCTION NW$ POP P, A PUSHJ P,XCONS POPJ P, IFN NEWRD,[ ;;;ROUTINE TO GET MACRO ENTRY. CHAR IN D. ;;; CLOBBERS A, B, TT, RETURNS (CHAR . FCN) IN A ;;; RSXST MUST HAVE BEEN DONE GETMAC: MOVEI A, 206 ;GET FCN LIST FROM READTABLE HRRZ B, @RSXTB ;.. MOVE A, D ;CHARACTER PUSHJ P, IASSQF ;DEPENDS ON D,R,F BEING PRESERVED JUMPE A, [LERR [SIXBIT/MACRO CHARACTER VANISHED#!!/]] POPJ P, ] ;END OF IFN NEWRD SSMACRO: CAME T,XC-3 ;CROCK TO GET NSTAT UP FAST PUSH P,R70 POP P,A POP P,C POP P,B SKIPE A PUSHJ P,ACONS PUSH P,A SSMC43: PUSHJ P,GRCTI JSP T,SMCR2 ADD TT,D HRRZM TT,RM4 JUMPE C,SSM1 NW% HRLI C,404500 NW$ MOVE C,[RS.CMS] SKIPE A,(P) JRST SSM3 SSM4: EXCH C,@RM4 NW% HRRZ A,C NW% TLNE C,4000 NW% PUSHJ P,SSGCREL ;CLOBBERS C IFN NEWRD,[ TLNN C,(RS.MAC) JRST SSM4AA PUSHJ P, GETMAC ;REMOVE PREVIOUS MACRO FUNCTION FROM ASSQ LIST. ;**** (SETQ MAC-LIST (DELQ A MAC-LIST)) **** SSM4AA: ;AND NO GCREL CRUFT NECC. ] MOVE C,@RM4 NW% HRRZ A,C NW% TLNE C,4000 NW% PUSHJ P,SSGCPRO NW% HRRM A,@RM4 NW$ DPB D, [001100,,@RM4] ;MACROS MUST HAVE SELF AS CHTRAN NW$ MOVE B, D ;***SURELY THIS COULD BE A LOT LESS KLUDGEY*** NW$ PUSHJ P, XCONS NW$ MOVE B, A NW$ MOVEI A, 206 NW$ MOVE A, @RSXTB NW$ PUSHJ P, XCONS NW$ MOVE B, A NW$ MOVEI A, 206 NW$ MOVEM B, @RSXTB SUB P,R70+1 MOVE TT,RM4 JRST SMCR1 SSM3: MOVEI AR1,(B) HLRZ A,(A) JSP T,CHNV1 CAIN TT,"S ;SPLICINGP NW% TLO C,40 NW$ TRO C,RS.ALT MOVEI B,(AR1) JRST SSM4 SMCR2: LOCKI JRST RSXST SSM1: HRLI D,2 MOVE C,RCT0(D) NW% TLNE C,4000 ;WAS IT ORIGINALLY A MACRO CHAR? NW$ TLNE C,(RS.MAC) MOVE C,D JRST SSM4 SSGCREL: TDZA D,D ;MUST HAVE USER INTERRUPTS OFF SSGCPRO: MOVEI D,1 JSP T,SPATOM JRST SSGCP1 HLRZ T,(A) ;GET SYMBOL BLOCK, FIRST WORD MOVE T,(T) TLNE T,SY.CCN ;IF SYM NOT PROTECTED BECAUSE OF BEING POPJ P, ; "NEEDED" BY COMPILED CODE, THEN PROLIS-IFY SSGCP1: SAVE A B HRRZ R,(B) CAIGE R,200 HRL R,VREADTABLE HRRI R,IN0(R) MOVE B,PROLIS JUMPE D,SSGRL1 PUSHJ P,ASSOC JUMPE A,SSPROQ HLRZ A,(A) MOVEM A,-1(P) SSPROQ: MOVE B,R PUSHJ P,CONS1 MOVE B,-1(P) PUSHJ P,XCONS MOVE B,PROLIS PUSHJ P,CONS MOVEM A,PROLIS MOVE A,-1(P) SSPROX: POP P,B JRST POP1J SSGRL2: MOVE A,-1(P) SSGRL1: PUSHJ P,IASSQF ;INTERNAL ASSQ WITH NO CHECKING JRST SSPROX ; NO SKIP ON FAILURE TO FIND HRRZ B,(B) ; SKIP ON SUCCESS HRRZ T,(A) CAME R,(T) ;COMPARES READTABLE AND NUMBER JRST SSGRL2 MOVE B,PROLIS PUSHJ P,.DELETE MOVEM A,PROLIS MOVEI A,NIL JRST SSPROX AUTOLOAD: ;T SHOULD CONTAIN THE SYMBOL NAME, A SHOULD HRL A,T ; CONTAIN THE AUTOLOAD PROPERTY PUSHJ P,ACONS MOVSS (A) PUSH P,A ;FOR GC PROTECTION PUSH FXP,D MOVSI D,(A) HRRI D,1000 ;AUTOLOAD USER INTERRUPT PUSHJ P,UINT POP FXP,D JRST POP1J IFN ITS,[ SUBTTL SYSCALL FUNCTION SYSCALL: MOVEI D,QSYSCALL CAML T,[-10.] CAMLE T,XC-2 JRST WNALOSE MOVEI D,2(P) ADD D,T ;D POINTS TO ARG WITH .CALL NAME IN IT MOVNM T,SYSCL8 ;#ARGS+2 JSP T,0PUSH+2(T) ;PUSH SLOTS FOR COPYING FIXNUM ARGS SCSL0: MOVE A,-1(D) JSP T,FXNV1 ;,, HLL D,TT HRRZS TT CAILE TT,20 JRST SCSTMA HRLM TT,SYSCL8 ;#ANSWERS,,#ARGS+2 MOVE A,(D) PUSH FXP,D PUSHJ P,SIXMAK MOVSI D,(SETZ) EXCH D,(FXP) ;THE SETZ GETS PUT OUT HERE MOVEI R,-1(FXP) MOVEI F,(FXP) PUSH FXP,TT ;THE SIXBIT FOR THE NAME OF THE .CALL HLRZ T,D TLZ D,-1 TLO T,5000 ;THE CONTROL BITS ARG JRST SCSL1A SCSL1: HRRZ T,(D) SKOTT T,FX JRST SCSL1A MOVE TT,(T) MOVEM TT,(R) MOVEI T,(R) SUBI R,1 SCSL1A: PUSH FXP,T MOVEI AR1,(T) CAIN AR1,TRUTH HRRZ AR1,V%TYI MOVEI T,(AR1) ;THIS IS AN INLINE CODED XFILEP LSH T,-SEGLOG MOVE T,ST(T) TLNN T,SA JRST SCSL6 MOVE T,ASAR(AR1) ;MUST ALSO HAVE FILE BIT SET TLNN T,AS.FIL\AS.JOB ;ALLOW EITHER JOB OR FILE JRST SCSL6 MOVE TT,[@TTSAR] ADDM TT,(FXP) SCSL6: CAIGE D,(P) ;LOOP TO INSTALL REMAINING INPUT ARGS AOJA D,SCSL1 HLRZ D,SYSCL8 SOJL D,SCSL4 MOVEI T,1(FXP) HRLI T,2000 SCSL3: PUSH FXP,T ;LOOP TO INSTALL ANSWER REQUESTS ADDI T,1 SOJGE D,SCSL3 SCSL4: MOVSI T,(SETZ) ;FINAL SETZ SIGNALS END OF PARAMETERS IORM T,(FXP) ;[THERE WILL ALWAYS BE AT LEAST ONE, I.E. THE CONTROL] MOVEI TT,F.CHAN .CALL (F) JRST SCSFAI SETZB A,B HLRZ D,SYSCL8 SCSL5: JUMPE D,SCSXIT ;LOOP TO LISTIFY UP NUMERIC ANSWERS POP FXP,TT PUSHJ P,CONSFX SOJA D,SCSL5 SCSTMA: MOVEI TT,15 JRST SCSXT1 SCSFAI: .SUSET [.RBCHN,,R] .CALL SCSTAT .VALUE LDB TT,[220600,,D] MOVE D,SYSCL8 HLRS D SUB FXP,D ;TAKE OFF THE SLOTS FOR ANSWERS JSP T,FXCONS ;LISP NUMBER FOR ERROR CODE SCSXIT: MOVE D,SYSCL8 ;SYSCL8 HAS 2+#ARGS ADDI D,-1(D) ;PUSHED WAS 3+2*#ARGS HRLS D ; WHICH IS 2*SYSCL8-1 SUB FXP,D SCSXT1: MOVE D,SYSCL8 HRLS D SUB P,D ;STRAIGHTEN UP P POPJ P, SCSTAT: SETZ SIXBIT \STATUS\ ;GET CHANNEL STATUS ,,R ;CHANNEL # 402000,,D ;STATUS WORD .SEE IOCERR .SEE CHNI1 ] ;END OF IFN ITS ;;@ STATUS 220 HAIRY STATUS FUNCTIONS ;;; ***** MACLISP ****** HAIRY STATUS FUNCTIONS ****************** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** SUBTTL INTERPRETER FOR STATUS SERIES STATER: MOVEI B,(AR2A) MOVEI A,(F) PUSHJ P,CONS FAC [ILLEGAL REQUEST!] SSTATUS: SKIPA F,CQSSTATUS ;FEXPR STATUS: MOVEI F,QSTATUS ;FEXPR MOVEI AR2A,(A) JUMPE A,STATER HLRZ A,(A) ;FIRST ARG IS FUNCTION NAME PUSHJ P,STLOOK ;LOOK IT UP IN ASCII TABLE JRST STATER CAIE F,QSTATUS ;STATUS OR SSTATUS? ADDI R,STBSS-STBS ADDI R,STBS MOVE D,(R) ;GET TABLE ENTRY LSH D,13 ASH D,-12 TLO D,1 HRRI D,(F) MOVEM D,SWNACK ;HACK FOR ARGS CHECKING MOVEI A,(AR2A) MOVEI TT,SWNACK JRST FWNACK ;RETURN HERE FROM FWNACK IF ARGS OKAY STAT1: HRRZ A,(A) ;CDR ARGS LIST HRLI R,410200 PUSH FXP,R ;BYTE POINTER TO ARGS DESCRIPTORS PUSH FXP,R70 ;COUNTER FOR ARGS STAT2: JUMPE A,STAT6 ;JUMP IF NO MORE ARGS PUSH P,A HLRZ A,(A) ;ELSE GET NEXT ARG ILDB T,-1(FXP) ;GET ARG DESCRIPTOR JRST .+1(T) JRST STAT6 ;0 END OF ARGS JRST STAT3 ;1 QUOTED ARG JRST STAT8 ;2 QUOTED LIST OF REST PUSHJ P,EVAL ;3 EVALUATED ARG STAT3: EXCH A,(P) ;LEAVE ARG ON PDL HRRZ A,(A) SOS T,(FXP) ;COUNT ARGS CAML T,XC-4 ;NO MORE THAN FOUR ALLOWED JRST STAT2 ; (UNLESS IT IS AN LSUBR) MOVSI TT,020000 ;FOR AN LSUBR, ARRANGE FOR ADDB TT,-1(FXP) ; THE LAST ARG SPEC TO BE REUSED LDB TT,[410300,,(TT)] ;SEE WHETHER IT'S REALLY AN LSUBR CAIE TT,1 CAIN TT,3 JRST STAT2 STAT6: POP FXP,T ;-<# OF ARGS> POP FXP,F ;RH IS ADDRESS OF TABLE ENTRY LDB TT,[410300,,(F)] ;GET STATUS SUBR DISPATCH TYPE STAT6A: HRRZ D,(F) JRST STAT7(TT) STAT7: JSP R,PDLA2(T) ;0 SUBR-TYPE FUNCTION JRST (D) ;1 LSUBR-TYPE FUNCTION JRST STSCH ;2 SUBR-TYPE WITH CHAR ARG JRST STSCH ;3 LSUBR-TYPE WITH CHAR ARG JRST STSGVAL ;4 GET LISP VALUE JRST STSSVAL ;5 SET LISP VALUE JRST STSSTNIL ;6 SET TO T-OR-NIL MOVE TT,(D) ;7 GET FIXNUM VALUE JRST FIX1 STAT8: MOVE A,(P) SETZM (P) JRST STAT3 STSGVAL: HRRZ A,(D) CQSSTATUS: POPJ P,QSSTATUS STSSVAL: POP P,A JSP T,PDLNMK STSSV1: MOVEM A,(D) POPJ P, STSSTNIL: POP P,A PUSHJ P,NOTNOT JRST STSSV1 STLOOK: PUSHJ P,PNGET ;LOOK UP 5 CHARS IN TABLE HLRZ A,(A) ;F SAYS WHETHER STATUS OR SSTATUS MOVE TT,(A) ;SKIP ON SUCCESS, LEAVING POINTER IN R MOVSI R,-LSTBA CAIE F,QSTATUS MOVSI R,-LSSTBA STLK1: CAMN TT,STBA(R) JRST POPJ1 AOBJN R,STLK1 POPJ P, STSCH: PUSH FXP,F PUSH FXP,T ADDI T,1(P) HRRZ A,(T) JSP T,SPATOM JRST STSCH1 PUSHJ P,PNGET HLRZ A,(A) MOVE TT,(A) LSH TT,-35 JSP T,FXCONS JRST STSCH2 STSCH1: PUSHJ P,EVAL JSP T,FXNV1 STSCH2: MOVE T,(FXP) ADDI T,1(P) HRRM A,(T) POP FXP,T POP FXP,F LDB TT,[410300,,(F)] SUBI TT,2 JRST STAT6A SUBTTL STATUS FEATURES FEATURE NOFEATURE, SSTATUS, ARRAY SNOFEATURE: PUSH P,CNOT SFEATURE: HRRZ B,FEATURES JUMPE A,BRETJ HLRZ A,(A) PUSHJ P,MEMQ1 JRST NOTNOT SSFEATURE: PUSH P,A HRRZ B,FEATURES PUSHJ P,MEMQ1 JUMPN A,SSFEA2 HRRZ A,(P) HRRZ B,FEATURES PUSHJ P,CONS SSFEA1: MOVEM A,FEATURES SSFEA2: JRST POPAJ SSNOFEATURE: PUSH P,A HRRZ B,FEATURES PUSHJ P,.DELQ JRST SSFEA1 SSSSLU: POP P,A PUSHJ P,STLOOK JRST FALSE JRST TRUE SSSSS: SKIPA F,CQSSTATUS SSSS: MOVEI F,QSTATUS JUMPN T,SSSSLU PUSH P,R70 CAIN F,QSTATUS SKIPA F,[-LSTBA,,] MOVSI F,-LSSTBA SSSSS1: MOVE T,STBA(F) MOVEM T,PNBUF SETOM LPNF MOVEI C,PNBUF PUSHJ P,RINTERN MOVE B,(P) PUSHJ P,CONS MOVEM B,(P) AOBJN F,SSSSS1 JRST POPAJ ;STATUS ARRAY RETURNS A LIST OF FOUR NUMBERS: ; ;THE LIST IS FRESHLY CONSED ON EACH CALL, AND MAY BE DESTRUCTIVLY MODIFIED SARRAY: SETZ B, ;START WITH NIL MOVEI TT,777777 ;APPROXIMATION OF MAXIMUM AXIS LENGTH JSP T,FXCONS JSP T,%CONS MOVEI B,IN1 JSP T,%XCONS MOVEI B,IN5 JSP T,%XCONS MOVEI B,IN1 JRST XCONS ;CONS UP FINAL NUMBER THEN RETURN SUBTTL STATUS +, STATUS CHTRAN, STATUS SYNTAX SSPLSS: MOVEI C,RD8N SKIPE A MOVEI C,RD8W MOVEM C,RDOBJ8 SPLSS: MOVE A,RDOBJ8 SUBI A,RD8N JRST NOTNOT SCHTRAN: SKIPA F,[SKIPA TT,(TT)] SSYNTAX: NW% MOVSI F,(HLRZ TT,(TT)) NW$ MOVE F,[LDB TT,[113300+TT,,0]] PUSH P,CFIX1 SETZ AR1, ;CROCK JRST SSSYN1 SUBTTL STATUS TTY, SSTATUS TTY ;;; (STATUS TTY ) RETURNS A LIST OF NUMBERS CONCERNING THE TTY: ;;; FOR ITS: ( ) ;;; FOR D10: ( ) ;;; FOR SAIL: ( ) ;;; FOR D20: ( ) ;;; RETURNS NIL IF IS OMITTED AND THE JOB DOES NOT POSSESS A CONTROLLING TTY. STTY: JUMPN T,STTY1 ;TEST TO SEE WHETHER WE POSSESS A CONTROLLING TTY IFN ITS,[ .SUSET [.RTTY,,TT] ;FOR ITS, SEE IF THIS JOB HAS THE TTY JUMPL TT,FALSE .SEE %TBNOT ] ;END OF IFN ITS IFN D10,[ IFN SAIL,[ GETLN D, ;RETURNS ZERO IF JOB IS DETACHED JUMPN D,FALSE ] ;END OF IFN SAIL IFE SAIL,[ GETLIN D, ;FOR D10, LH OF GETLIN WORD ZERO TLNN D,-1 ; MEANS JOB IS DETACHED JRST FALSE ] ;END OF IFE SAIL ] ;END OF IFN D10 IFN D20,[ LOCKI GJINF ;FOURTH RETURNED VALUE IS -1 FOR MOVE T,4 SETZB 1,2 ; A DETACHED JOB SETZB 3,4 UNLOCKI AOJE T,FALSE ] ;END OF IFN D20 SKIPA AR1,V%TYI STTY1: POP P,AR1 PUSHJ P,TFILOK ;SAVES D (FOR SAIL), DOES A LOCKI POP FXP,T ;POP THE LOCKI WORD IFN ITS,[ .CALL TTYGET ;GET THREE VALUES IN D, R, F .LOSE 1400 PUSH FXP,D ;TTYST1 PUSH FXP,R ;TTYST2 PUSH FXP,F ;TTYSTS ZZZ==3 ] ;END OF IFN ITS IFN D10,[ PUSHJ P,D10TNM ;RETURNS APPROPRIATE TERMINAL NUMBER IN D SA% GETLCH D SA$ GETLIN D PUSH FXP,D SKIPL F.MODE(TT) .SEE FBT.CM JRST STTY3 MOVSI R,(SIXBIT \TTY\) ;FOR THE REGULAR TTY, SETZB D,F ; OPEN A TEMPORARY CHANNEL OPEN TMPC,D ; SO CAN GET THE CHANNEL STATUS HALT GETSTS TMPC,D RELEASE TMPC, JRST STTY4 STTY3: MOVE R,F.CHAN(TT) ;FOR ANY OTHER TTY, USE THE EXISTING CHANNEL LSH R,27 IOR R,[GETSTS 0,D] XCT R STTY4: PUSH FXP,D IFE SAIL, ZZZ==2 IFN SAIL,[ PUSHN FXP,4 MOVSI D,-3(FXP) SETACT D ;GET FOUR ACTIVATION WORDS ZZZ==6 ] ;END OF IFN SAIL ] ;END OF IFN D10 IFN D20,[ HRRZ 1,F.JFN(TT) RFCOC ;READ CCOC WORDS PUSH FXP,2 ;CCOC1 PUSH FXP,3 ;CCOC2 RFMOD ;READ JFN MODE WORD FOR TERMINAL PUSH FXP,2 MOVE 1,[RT%DIM,,.FHSLF] RTIW ;READ DEFERRED INTERRUPT WORD PUSH FXP,3 SETZB B,C ZZZ==4 ] ;END OF IFN D20 PUSH FXP,T ;LOCKI WORD UNLOCKI PUSHJ P,CONS1PFX REPEAT ZZZ-2, PUSHJ P,CONSPFX JRST CONSPFX EXPUNGE ZZZ ;;; (SSTATUS TTY ... ) SETS THE ;;; TTY STATUS WORDS FOR (WHICH MAY BE OMITTED). ;;; ANY PARAMETERS WHICH ARE OMITTED OR NIL ARE NOT CHANGED. SSTTY: HRRZ AR1,(P) ;LSUBR CAIN AR1,TRUTH ;LAST ARG T => DEFAULT TTY HRRZ AR1,V%TYI JSP TT,XFILEP ;SEE IF LAST ARG IS A TTY SKIPA AR1,V%TYI ;IF NOT, WE USE THE DEFAULT AOSA D,T ;IN ANY CASE, PUT ADJUSTED NUMBER SKIPA D,T ; OR ARGUMENTS IN D POPI P,1 ; AND ADJUST THE STACK SKIPN F,D ;NO ARGUMENTS MEANS CHANGE NOTHING JRST TRUE MOVE R,FXP ;SAVE CURRENT LEVEL OF FXP SSTTY1: POP P,A ;FOR EACH ARGUMENT SKIPE A ; WE PUSH TWO JSP T,FXNV1 ; WORDS ONTO FXP: PUSH FXP,TT ; THE FIRST IS THE NUMERIC VALUE, IF ANY, PUSH FXP,A ; AND THE SECOND IS ZERO IF THE ARG WAS NIL AOJL D,SSTTY1 ;BECAUSE THE ARGUMENTS WERE POPPED OFF P IN REVERSE ORDER, ; THEY CAN NOW BE POPPED OFF FXP IN THE CORRECT ORDER. ;F HAS THE NEGATIVE OF THE NUMBER OF ARGUMENTS. PUSH P,R ;NOW SAVE OLD FXP ON STACK PUSHJ P,TIFLOK ;DOES A LOCKI, SAVES F POP FXP,AR2A ;POP LOCKI WORD IFN ITS,[ POP FXP,T POP FXP,D SKIPN T SKIPA D,TI.ST1(TT) ;GET COPY OF THE OLD VALUE IF NOT SETTING NEW MOVEM D,TI.ST1(TT) ;UPDATE TTYST1 WORD AOJE F,SSTTY3 ;JUMP IF NO MORE ARGUMENTS POP FXP,T POP FXP,R SKIPN T SKIPA R,TI.ST2(TT) MOVEM R,TI.ST2(TT) ;UPDATE TTYST2 WORD AOJE F,SSTTY3 ;JUMP IF NO MORE ARGUMENTS POP FXP,T POP FXP,F JUMPE T,SSTTY3 ;NULL THIRD ARG, THEN NEEDN'T DO HAIRIER CALL .CALL TTYSAC ;THREE WORDS ARE IN D, R, F .LOSE 1400 JRST SSTTY2 SSTTY3: .CALL TTY2ST ;SET JUST TTYST1, TTYST2 .LOSE 1400 ] ;END OF IFN ITS IFN D10,[ POP FXP,D POP FXP,T JUMPE D,SSTTY7 IFE SAIL,[ PUSHJ P,D10TNM CAMN D,XC-1 GETLCH D HRRI T,(D) SETLCH T ] ;END OF IFE SAIL IFN SAIL,[ SKIPL F.MODE(TT) .SEE FBT.CM SETLIN T ] ;END OF IFN SAIL SSTTY7: AOJE F,SSTTY2 POP FXP,D POP FXP,T JUMPE D,SSTTY4 ;FOR NULL ARG, FORGET THE FOLLOWING HAIR SKIPL F.MODE(TT) .SEE FBT.CM JRST SSTTY3 PUSH FXP,F MOVSI R,(SIXBIT \TTY\) SETZB D,F OPEN TMPC,D ;OPEN A TEMP CHANNEL FOR THE TTY HALT SETSTS TMPC,(T) ;SET THE STATUS correctly! RELEASE TMPC, POP FXP,F JRST SSTTY4 SSTTY3: MOVE R,F.CHAN(TT) LSH R,27 IOR R,[SETSTS 0,(T)] XCT R SSTTY4: IFN SAIL,[ AOJE F,SSTTY2 ;JUMP IF NO MORE ARGS IRPC X,,[1234] POP FXP,D POP FXP,T SKIPE D MOVEM T,TI.ST!X(TT) ;UPDATE ACTIVATION WORD X IFSN X,4, AOJE F,SSTTY5 TERMIN SSTTY5: MOVEI T,TI.ST1(TT) SETACT T ] ;END OF IFN SAIL ] ;END OF IFN D10 IFN D20,[ HRRZ 1,F.JFN(TT) ;GET JFN FOR SUBSEQUENT JSYS'S POP FXP,T POP FXP,D SKIPE T MOVEM D,TI.ST1(TT) ;UPDATE CCOC1 AOJE F,SSTTY3 ;JUMP IF NO MORE ARGUMENTS POP FXP,T POP FXP,R SKIPE T MOVEM R,TI.ST2(TT) ;UPDATE CCOC2 IOR D,R SSTTY3: JUMPE D,SSTTY4 ;JUMP IF NO CHANGE TO CCOC'S MOVE 2,TI.ST1(TT) MOVE 3,TI.ST2(TT) SFCOC ;SET CCOC'S SSTTY4: AOJGE F,SSTTY2 ;JUMP IF NO MORE ARGUMENTS POP FXP,D POP FXP,2 SKIPE D SFMOD ;UPDATE JFN MODE WORD AOJE F,SSTTY2 POP FXP,D POP FXP,3 ;DEFERRED TERMINAL INTERRUPT MASK JUMPE D,SSTTY2 MOVE 1,[ST%DIM,,.FHSLF] MOVE 2,[STDTIW] ;STANDARD TERMINAL INTERRUPT WORD STIW ;SET TERMINAL INTERRUPT WORDS ] ;END OF IFN D20 SSTTY2: POP P,FXP ;RESTORE FXP PUSH FXP,AR2A ;PUSH BACK LOCKI WORD 20$ SETZB B,C ;CLEAR JUNK OUT OF AC'S JRST UNLKTRUE IFN ITS,[ TTY2ST: SETZ SIXBIT \TTYSET\ ;SET TTY VARIABLES ,,F.CHAN(TT) ;CHANNEL # ,,TI.ST1(TT) ;TTYST1 400000,,TI.ST2(TT) ;TTYST2 TTYSAC: SETZ SIXBIT \TTYSET\ ;SET TTY VARIABLES ,,F.CHAN(TT) ;CHANNEL # ,,D ;TTYST1 ,,R ;TTYST2 400000,,F ;TTYSTS ] ;END OF IFN ITS SFRET: CAIN B,QBPS ;FIGURE OUT SPACE TYPE JRST 1(R) ;BPS => SKIP 1 CAIN B,QRANDOM ;BAD SPACE TYPE => SKIP 0 JRST (R) ;LIST, FIXNUM, FLONUM, BIGNUM, CAIN B,QARRAY ; SYMBOL, SAR => SKIP 2 MOVEI B,QRANDOM CAIL B,QLIST CAILE B,QRANDOM JRST (R) 2DIF [HRREI TT,(B)]-NFF,QLIST JRST 2(R) SUBTTL STATUS UUOLI, SSTATUS UUOLI, STATUS IOC, STATUS CLI, SSTATUS CLI SUUOLINKS: IFE PAGING,[ SKIPN T,LDXSIZ JRST FALSE ;RETURN NIL IF NO XCT HACKERY HAS BEEN DONE SETZB TT,D ;ZERO COUNTER TLNE T,400000 MOVEI D,TRUTH ;D GETS TRUE IF PURIFIED MOVNS T ;MAKE UP AOBJN POINTER FOR XCT CALL AREA 2 HLL T,LDXBLT MOVSS T SUUOL1: SKIPN (T) ;COUNT FREE CELLS IN XCT CALL AREA AOS TT AOBJN T,SUUOL1 JSP T,FIX1A ;RETURN LIST OF PURE FLAG AND COUNT PUSHJ P,NCONS MOVE B,D JRST XCONS ] ;END IFE PAGING IFN PAGING,[ SKIPN LDXPNT ;IF NO XCT PAGES JRST FALSE ; RETURN FALSE MOVN TT,LDXLPC ;GET NUMBER OF FREE SLOTS IN LAST SEGMENT JSP T,FIX1A PUSHJ P,NCONS MOVEI B,NIL SKIPE LDXPFG ;PURIFIED? MOVEI B,TRUTH JRST XCONS ] ;END IFN PAGING SSUUOLINKS: MOVE A,USENDI PUSHJ P,SSSENDI ;Re-init SENDI hook and friends MOVE A,UUSRHNK PUSHJ P,SSUSRHUNK MOVE A,UCALLI PUSHJ P,SSCALLI IFE PAGING,[ SKIPN TT,LDXBLT ;ZAP CALLS FOR XCTS WITH A BLT JRST FALSE MOVEI T,(TT) ADD T,LDXSM1 BLT TT,(T) JRST TRUE ] ;END IFE PAGING IFN PAGING,[ SKIPN T,LDXPNT ;LOOP OVER ALL XCT SEGMENTS JRST FALSE SSUUL1: JUMPE T,TRUE ;RETURN TRUE WHEN DONE HRRZI TT,LDXOFS(T) ;TARGET ADR HRL TT,LDXPSP(T) ;ADR-OFFSET TO GET DATA FROM ADD TT,[LDXOFS,,0] ;MAKE INTO SOURCE ADR BLT TT,SEGSIZ-1(T) ;RECOPY LINK AREA HLRZ T,LDXPSP(T) ;LINK TO NEXT PAGE JRST SSUUL1 ] ;END IFN PAGING IFN USELESS*ITS,[ SCLI: MOVEI T,%PICLI ;TEST TO SEE IF THIS BIT IS ON (IN IMASK) TDNN T,IMASK ;IF ON, RETURN T, ELSE RETURN NIL JRST FALSE JRST TRUE SSCLI: MOVEI T,%PICLI MOVEI TT,IMASK SKIPN A ;ON OR OFF? TLOA TT,(ANDCAM T,) ;OFF, USE ANDCAM HRLI TT,(IORM T,) ;ON, USE IORM XCT TT ;MODIFY LISP'S MASK SKIPN A TLOA T,(TRZ) TLO T,(TRO) .CALL CLIVAR .LOSE 1400 ;BAD NEWS.... JUMPN A,TRUE POPJ P, CLIVAR: SETZ SIXBIT \USRVAR\ MOVEI %JSELF MOVEI .RMASK MOVEI SETZ T ] ;END IFN USELESS*ITS SNOINT: SKIPN A,UNREAL ;Check out UNREAL JRST CPOPJ ; NIL JUMPL A,TRUE ;-1 = T POPJ P, ;Else QTTY, just return it SUBTTL STATUS TIME, DATE, UNAME, USERID, JNAME, JNUMBER, SUBSYSTEM IFN ITS,[ STIME: .RTIME TT, JRST SDATE+1 SDATE: .RDATE TT, AOJE TT,FALSE MOVE D,TT SUB D,[202020202021] ;21 ADJUSTS FOR THE AOJE JSP F,STCVT JSP F,STCVT JSP F,STCVT MOVNI T,3 JRST LIST STCVT: SETZB TT,R LSHC TT,6 IMULI TT,10. ROTC D,6 ADD TT,R JSP T,FXCONS PUSH P,A JRST (F) SRCDIR: SKIPE A,SUDIR ;STATUS FOR "READ-CONNECTED-DIRECTORY" POPJ P, MOVE TT,IUSN PUSHJ P,SIXATM MOVEM A,SUDIR POPJ P, SUNAME: .SUSET [.RUNAME,,TT] JRST SIXATM SUSERID: .SUSET [.RXUNAME,,TT] JRST SIXATM SJNAME: .SUSET [.RJNAME,,TT] JRST SIXATM SSUBSYSTEM: .SUSET [.RXJNAME,,TT] JRST SIXATM SJNUMBER: .SUSET [.RUIND,,TT] JRST FIX1 SHOMEDIR: .SUSET [.RHSNAME,,TT] JRST SIXATM SHSNAME: ;NEW HAIRY READ HSNAME JUMPE T,SHOMEDIR ;NO ARGS, SAME AS (STATUS HOMEDIR) PUSH FXP,T ;SAVE NUMBER OF ARGS OVER SUPERIOR CHECK JSP T,SIDDTP ;IS THERE A DDT ABOVE US? JRST SHSNA2 ;NOPE... POP FXP,T SETZ TT, ;ASSUME NULL ITS NAME AOJE T,SHSNA1 ;ITS ARG GIVEN? POP P,A ;YES, GET THE ITS NAME PUSHJ P,SIXMAK ;GET SIXBIT INTO TT SHSNA1: PUSH FXP,TT ;SAVE THE ITS NAME POP P,A PUSHJ P,SIXMAK ;CONVERT UNAME TO SIXBIT PUSH FXP,TT ;STORE THAT ON FXP ALSO MOVEI TT,-1(FXP) ;POINTER TO FIRST WORD HRLI TT,..RHSNAME ;FOR .BREAK 12, .BREAK 12,TT ;READ THE HSNAME FROM DDT POP FXP,TT ;NOW CONVERT TO AN ATOM PUSHJ P,SIXATM POPI FXP,1 ;REMOVE EXTRA WORD FROM STACK POPJ P, ;THEN RETURN SHSNA2: POP FXP,T ;RESTORE NUMBER OF ARGS MOVNS T SUB P,R70(T) ;REMOVE THE APPROPRIATE NUMBER OF WORDS FROM P SETZ A, ;RETURN NIL POPJ P, ] ;END OF IFN ITS IFE ITS,[ SHSNAME: ;HSNAME IS SIMPLY HOMEDIR MOVNS T SUB P,R70(T) ;REMOVE THE APPROPRIATE NUMBER OF WORDS FROM P 20$ JRST SRCDIR 20% MOVE A,SUDIR 20% POPJ P, ] ;END IFE ITS IFN D10,[ IFE SAIL,[ SDATE: MOVE R,[%CNYER] MOVE D,[%CNMON] MOVE TT,[%CNDAY] GETTAB R, JRST FALSE SUBI R,1900. JRST STIM2 STIME: MOVE R,[%CNHOR] MOVE D,[%CNMIN] MOVE TT,[%CNSEC] GETTAB R, JRST FALSE STIM2: GETTAB D, JRST FALSE GETTAB TT, JRST FALSE PUSHJ P,CONS1FX MOVE TT,D PUSHJ P,CONSFX MOVE TT,R JRST CONSFX SSUBSYSTEM: HRROI TT,.GTPRG ;GET PROGRAM NAME FOR MYSELF GETTAB TT, JRST FALSE JRST SIXATM ] ;END OF IFE SAIL IFN SAIL,[ SDATE: DATE D, ;DATE IN D = <*12.+MONTH-1>*31.+DAY-1 IDIVI D,31. ;REMAINDER IN R IS DAYS-1 AOJ R, MOVE T,R IDIVI D,12. ;REMAINDER HERE IS MONTH-1 AOJ R, ADDI D,64. ;QUOTIENT IN D IS YEAR-1964. PUSH FXP,D PUSH FXP,R PUSH FXP,T JRST STIM2 STIME: TIMER TT, ;GET TIME IN TT IDIVI TT,60. ;REDUCE TO SECONDS IDIVI TT,60. ;NOW GET SECONDS AS A REMAINDER MOVE R,D IDIVI TT,60. ;REMAINDER IS MINUTES PUSH FXP,TT PUSH FXP,D ;REST IS HOURS PUSH FXP,R STIM2: PUSHJ P,CONS1PFX ;START A LIST WITH NUMBER ON FXP PUSHJ P,CONSPFX ;ADD FIXNUM TO LIST JRST CONSPFX ;ADD THIRD FIXNUM TO LIST SSUBSYSTEM: SETO TT, GETNAM TT, ;GET (GENERIC?) NAME OF JOB JRST SIXATM ] ;END OF IFN SAIL SJNAME: MOVE TT,D10NAM JRST SIXATM SJNUMBER: PJOB TT, ;GET JOB NUMBER JRST FIX1 SUSERID: IFE SAIL,[ HRROI TT,.GTNM1 ;GET USER NAME FOR THIS JOB GETTAB TT, JRST SUNAME HRROI D,.GTNM2 GETTAB D, HALT ;HOW CAN THIS LOSE? JUMPE TT,SUNAME SETOM LPNF ;CONVERT TWO WORDS OF SIXBIT MOVE C,PNBP ; TO ASCII IN PNBUF SUSER1: LDB T,[360600,,TT] ADDI T,40 IDPB T,C LSHC TT,6 JUMPN TT,SUSER1 PUSHJ FXP,RDAEND JRST RINTERN ;MAKE IT AN ATOMIC SYMBOL ] ;END OF IFE SAIL SUNAME: GETPPN TT, ;PPNATM EXPECTS PPN IN TT JFCL JRST PPNATM ] ;END OF IFN D10 IFN D20,[ STIME: PUSHJ P,SDATIM ;RETURNS TIME IN F MOVEI TT,(F) IDIVI TT,60. ;REMAINDER IS SECONDS MOVE R,D IDIVI TT,60. ;THIS YIELDS HOURS AND MINUTES EXCH TT,R STIME1: PUSHJ P,CONS1FX ;CONS R, D, TT INTO A LIST OF FIXNUMS MOVE TT,D PUSHJ P,CONSFX MOVE TT,R JRST CONSFX SDATE: PUSHJ P,SDATIM ;RETURNS DATE IN D AND R HLRZ TT,R ;DAY-1 HLRZ R,D ;YEAR SUBI R,1900. ;REDUCE IT TO A YEAR MOD 100. MOVEI D,1(D) ;MONTH AOJA TT,STIME1 ;INCREMENT DAY-1 TO DAY, AND GO CONS SDATIM: LOCKI ;PREVENT JUNK IN AC'S FROM CAUSING TROUBLE SETO 2, ;CURRENT TIME SETZ 4, ODCNV ;GET TIME AND DATE INFORMATION MOVE D,2 ;RETURN INFORMATION IN D, R, F MOVE R,3 MOVE F,4 SETZB 1,2 ;PREVENT TROUBLE AFTER UNLOCKI SETZB 3,4 UNLKPOPJ SJNAME: ;? SSUBSYSTEM: LOCKI GETNM ;GET PROGRAM NAME MOVE TT,1 SETZ 1, UNLOCKI JRST SIXATM SRCDIR: JSP T,TNXUDI JRST PNBFAT SUSERID: ;? SUNAME: LOCKI MOVE TT,[PNBUF,,PNBUF+1] SETZM PNBUF ;CLEAR PNBUF BLT TT,PNBUF+LPNBUF-1 GJINF ;GET JOB INFORMATION MOVE 2,1 ;1 HAS LOGIN DIRECTORY NUMBER MOVE 1,PNBP DIRST ;GET EQUIVALENT ASCII STRING HALT ;BETTER NOT FAIL... SETZB 1,2 UNLOCKI JRST PNBFAT ;MAKE ASCII STRING AN ATOM SJNUMBER: LOCKI GJINF ;GET JOB INFORMATION MOVE TT,3 ;JOB NUMBER SETZB 1,2 UNLOCKI JRST FIX1 ] ;END OF IFN D20 SUBTTL STATUS LINMODE SSLINMODE: CAMN T,XC-1 SKIPA AR1,V%TYI POP P,AR1 POP P,A PUSHJ P,TIFLOK ;DOES A LOCKI MOVE T,F.MODE(TT) SKIPN A IFN ITS,[ ZZX==<%TG>*010101010101 ;6 %TGACT BITS SKIPA R,[STTYW1&ZZX] ;PUT APPROPRIATE ACTIVATION SKIPA R,[STTYL1&ZZX] ; BITS IN R AND F SKIPA F,[STTYW2&ZZX] SKIPA F,[STTYL2&ZZX] ] ;END OF IFN ITS IFN SAIL,[ SKIPA D,[[SACTW1 ? SACTW2 ? SACTW3 ? SACTW4],,] SKIPA D,[[SACTL1 ? SACTL2 ? SACTL3 ? SACTL4],,] ] ;END OF IFN SAIL IFN D20,[ SKIPA R,[XACTW] SKIPA R,[XACTL] ] ;END OF IFN D20 TLZA T,FBT.LN TLO T,FBT.LN MOVEM T,F.MODE(TT) IFN ITS,[ MOVE D,[ZZX] ANDCAM D,TI.ST1(TT) IORM R,TI.ST1(TT) ;CLOBBER IN ONLY ACTIVATION BITS ANDCAM D,TI.ST2(TT) IORM F,TI.ST2(TT) EXPUNGE ZZX ] ;END OF IFN ITS IFN SAIL,[ HRRI D,TI.ST1(TT) BLT D,TI.ST4(TT) ;UPDATE STATUS WORDS MOVEI T,TI.ST1(TT) SETACT T ;TELL THE SYSTEM ABOUT IT ] ;END OF IFN SAIL IFN D20,[ MOVEI D,770000 ;BITS 18.-23. ARE FOR WAKE-UP CONTROL ANDCAM D,TI.ST3(TT) IORM R,TI.ST3(TT) ] ;END OF IFN D20 UNLOCKI JRST NOTNOT SUBTTL STATUS DOW IFN USELESS,[ IFN ITS,[ SDOW: .RYEAR TT, AOJE TT,FALSE LSH TT,-31 ANDI TT,16 MOVE T,SDOWQX(TT) MOVEM T,PNBUF MOVE T,SDOWQX+1(TT) MOVEM T,PNBUF+1 JRST PNBFAT SDOWQX: IRP DAY,,[SUNDAY,MONDAY,TUESDAY,WEDNESDAY,THURSDAY,FRIDAY,SATURDAY] ASCII \DAY\ TERMIN ] ;END OF IFN ITS IFN D10,[ SDOW: IFE SAIL,[ MOVE T,[%CNDTM] ;INTERNAL FORMAT DATE,,TIME GETTAB T, JRST FALSE HLRZS T ] ;END OF IFE SAIL IFN SAIL,[ DATE T, ;DATE IN T DAYCNT T, ;CONVERT TO NUMBER OF DAYS ] ;END OF IFN SAIL ;T NOW HAS NUMBER OF DAYS SINCE 1-JAN-64 (A WEDNESDAY) IDIVI T,7 LSH TT,1 MOVE T,SDOWQX(TT) MOVEM T,PNBUF MOVE T,SDOWQX+1(TT) MOVEM T,PNBUF+1 JRST PNBFAT SDOWQX: ;FUNNY ORDER FOR DEC-10 IRP DAY,,[WEDNESDAY,THURSDAY,FRIDAY,SATURDAY,SUNDAY,MONDAY,TUESDAY] ASCII \DAY\ TERMIN ] ;END OF IFN D10 IFN D20,[ SDOW: PUSHJ P,SDATIM ;RH OF R GETS DAY OF WEEK (0 = MONDAY) LSH R,1 MOVE T,SDOWQX(R) MOVEM T,PNBUF MOVE T,SDOWQX+1(R) MOVEM T,PNBUF+1 JRST PNBFAT SDOWQX: ;FUNNY ORDER FOR DEC-10 IRP DAY,,[MONDAY,TUESDAY,WEDNESDAY,THURSDAY,FRIDAY,SATURDAY,SUNDAY] ASCII \DAY\ TERMIN ] ;END OF IFN D20 ] ;END OF IFN USELESS SUBTTL STATUS ABBREVIATE, STATUS MEMFREE IFN USELESS,[ SABBREVIATE: MOVEI TT,LRCT-2 HRRZ A,VREADTABLE HRRZ TT,@TTSAR(A) JRST FIX1 SSABBREVIATE: SKIPN TT,A JRST SSABB1 MOVEI TT,3 CAIE A,TRUTH JSP T,FXNV1 SSABB1: MOVEI T,(TT) MOVEI TT,LRCT-2 HRRZ B,VREADTABLE HRRM T,@TTSAR(B) JRST PDLNKJ ] ;END OF IFN USELESS SMEMFREE: PG$ MOVE TT,HINXM ;NUMBER OF WORDS IN HOLE PG$ SUB TT,BPSH ;INTERRUPT HERE WOULD SCREW, PG% MOVE TT,MAXNXM PG% SUB TT,HIXM JRST FIX1 ; WORRY, WORRY, WHO CARES SUBTTL STATUS SYSTEM SSYST0: WTA [SYMBOL REQUIRED - STATUS SYSTEM!] SSYSTEM: ;(STATUS SYSTEM) ENTRY-POINT JSP T,SPATOM JRST SSYST0 JUMPE A,SSYST6 CAIN A,TRUTH JRST SSYST6 MOVEI AR1,NIL MOVEI B,QSYMBOL ;CHECK FOR SYMBOL HEADER IN SYSTEM SPACE CAIE A,TRUTH CAIN A,QUNBOUND JRST SSYST2 CAIL A,QRDQTE ;First system symbol, except for T and QUNBOUND CAILE A,SYMSYL JRST SSYST7 ;NOT IN RANGE, CONTINUE CHECKING SSYST2: EXCH A,AR1 PUSHJ P,XCONS EXCH A,AR1 SSYST7: MOVEI B,QVALUE HLRZ C,(A) HRRZ C,(C) CAIGE C,ESYSVC JRST SSYST4 SSYST1: MOVEI B,SSSBRL PUSHJ P,GETLA JUMPE A,AR1RETJ HLRZ B,(A) HRRZ A,(A) HLRZ C,(A) CAIE B,QAUTOLOAD JRST SSYST3 CAIL C,BSYSAP ;IS IT A SYSTEM AUTOLOAD PROP? CAIL C,ESYSAP JRST SSYST1 ;NOPE JRST SSYST4 ;YUP SSYST3: CAIE B,QARRAY JRST SSYST5 CAIL C,BSYSAR ;IS IT A SYSTEM ARRAY CAIL C,ESYSAR JRST SSYST1 JRST SSYST4 SSYST5: CAIL C,ENDFUN ;SUBR OR VC ADDRESS IN SYSTEM AREA JRST SSYST1 SSYST4: EXCH A,AR1 ;A WIN, SO CONS UP THIS PROPERTY NAME PUSHJ P,XCONS EXCH A,AR1 JRST SSYST1 SSYST6: MOVEI A,QVALUE PUSHJ P,NCONS MOVEI B,QSYMBOL JRST XCONS SUBTTL STATUS GCTIME, LISPVERSION, TTYREAD, _, TERPRI, OPSYSTEM, SITE, FILESYSTEM SSGCTIM: JSP T,FXNV1 IT$ LSH TT,-2 10$ IDIVI TT,1000. 20$ IDIVI TT,1000. EXCH TT,GCTIM JRST SGCTM1 SGCTIM: MOVE TT,GCTIM SGCTM1: PUSH P,CFIX1 ;FAKE OUT ENTRY INTO RUNTIME JRST RNTM1 SLVRNO: MOVE A,[440600,,[LVRNO]] JRST READ6C SFILESYSTEM.TYPE: HLRZ A,FILEFT POPJ P, SOPSYSTEM.TYPE: HLRZ A,OPSYFT POPJ P, SSITE: HLRZ A,SITEFT POPJ P, STTYREAD: SKIPA TT,[LRCT-2] SLAP: HRROI TT,LRCT-1 SLAP1: HRRZ A,VREADTABLE MOVE A,@TTSAR(A) SKIPL TT MOVSS A JRST RHAPJ SSTTYREAD: SKIPA R,[LRCT-2] SSLAP: HRROI R,LRCT-1 SSLAP1: PUSHJ P,NOTNOT HRRZ D,VREADTABLE ;INTERRUPT COULD SCREW HERE (FOO) JSP T,.STOR0 POPJ P, SLINMODE: MOVSI F,FBT SKIPN T SKIPA AR1,V%TYI POP P,AR1 PUSHJ P,TIFLOK TDNN F,F.MODE(TT) TDZA A,A MOVEI A,TRUTH UNLKPOPJ STERPRI: SKIPN T SKIPA AR1,V%TYO POP P,AR1 PUSHJ P,TOFLOK STERP1: SKIPLE FO.LNL(TT) TDZA A,A MOVEI A,TRUTH UNLKPOPJ SSTERPRI: CAMN T,XC-1 SKIPA AR1,V%TYO POP P,AR1 PUSHJ P,TOFLOK POP P,A MOVMS FO.LNL(TT) SKIPE A MOVNS FO.LNL(TT) JRST STERP1 SUBTTL STATUS CRFILE, LOSEF SCRFUN==FALSE ;***** TEMP CROCK ***** SCRFIL: SETZ A, PUSHJ P,DEFAULTF HRRZ A,(A) POPJ P, SLOSEF: MOVE T,LOSEF JFFO T,.+1 MOVNS TT ADDI TT,36. JRST FIX1 SSLOS0: MOVEI A,(B) WTA [BAD LOSEF - SSTATUS!] SSLOSEF: MOVEI B,(A) SKIPE GCPSAR JRST SLOSEF JSP T,FXNV2 JUMPLE D,SSLOS0 CAILE D,16 JRST SSLOS0 MOVEI TT,1 LSH TT,(D) SUBI TT,1 MOVEM TT,LOSEF BPDLNKJ: MOVEI A,(B) JRST PDLNKJ SUBTTL STATUS JCL, HACTRN IFN D10,[ SJCL: SKIPN T,SJCLBUF JRST FALSE PUSH FXP,T PUSH FXP,[440700,,SJCLBUF+1] SJCL2: ILDB TT,(FXP) PUSHJ P,RDCH2 PUSH P,A SOSLE -1(FXP) JRST SJCL2 SJCL4: MOVE T,SJCLBUF SUB FXP,R70+2 JRST LIST ] ;END OF IFN D10 IFN ITS,[ SDDTP: .SUSET [.RSUPPRO,,TT] ;STATUS HACTRN JUMPL TT,FALSE ;NIL MEANS NO SUPERIOR MOVEI A,TRUTH ;T MEANS THE UNKNOWN SUPERIOR .SUSET [.ROPTION,,TT] TLNE TT,OPTDDT MOVEI A,QDDT TLNE TT,OPTLSP MOVEI A,QLISP POPJ P, SJCL: .SUSET [.ROPTION,,TT] TLNN TT,%OPCMD JRST FALSE ;EXIT WITH NIL IF NO COMMAND LINE .SUSET [.RSUPPRO,,T] JUMPL T,FALSE SETZM JCLBF MOVE T,[JCLBF,,JCLBF+1] BLT T,JCLBF+LJCLBF-1 HLLOS JCLBF+LJCLBF-1 .BREAK 12,[..RJCL,,JCLBF] MOVEI T,JCLBF ;MUST CLEAR BIT 35'S AS DDT MAY SET THEM!! MOVEI TT,1 ;MASK SJCL1A: ANDCAM TT,(T) ;TURN OFF BIT 35 CAIGE T,JCLBF+LJCLBF-1 ;DO ALL WORDS IN JCLBF AOJA T,SJCL1A PUSH FXP,R70 PUSH FXP,[440700,,JCLBF] SJCL1: ILDB TT,(FXP) JUMPE TT,SJCL3 SJCL2: PUSH P,TT PUSHJ P,RDCH2 EXCH A,(P) SOS -1(FXP) CAIE A,^M ;CAR-RET CAUSES TERMINATION JRST SJCL1 SJCL4: MOVE T,-1(FXP) SUB FXP,R70+2 JRST LIST SJCL3: HRRZ T,(FXP) CAIE T,JCLBF+LJCLBF-1 JRST SJCL4 MOVEI A,QSJCL FAC [TOO MUCH JCL - STATUS!] ] ;END OF IFN ITS SUBTTL STATUS TTYSIZE, TTYTYPE, NEWIO OSPEED IFN ITS,[ STTYTYPE: TDZA F,F STTYSIZE: MOVEI F,1 SKIPN T SKIPA AR1,V%TYO POP P,AR1 PUSHJ P,TOFLOK .CALL STTSZ9 .VALUE UNLOCKI JUMPN F,STTYS1 MOVE TT,R JRST FIX1 STTYS1: JSP T,FXCONS MOVEI B,(A) MOVE TT,D JRST CONSFX STTSZ9: SETZ SIXBIT \CNSGET\ ;GET CONSOLE PARAMETERS ,,F.CHAN(TT) ;CHANNEL # 2000,,D ;VERTICAL SCREEN SIZE 2000,,TT ;HORIZONTAL SCREEN SIZE 402000,,R ;TCTYP ;TTYCOM, TTYOPT, TTYTYP NOT RETRIEVED ;OSPEED - RETURNS TTY OUPUT SPEED VARIABLE SOSPEED: SKIPN T SKIPA AR1,V%TYO POP P,AR1 PUSHJ P,TOFLOK .CALL SOSSP9 .VALUE UNLOCKI JRST FIX1 SOSSP9: SETZ SIXBIT \TTYVAR\ ,,F.CHAN(TT) ,,[SIXBIT \OSPEED\] 402000,,TT ] ;END OF IFN ITS IFN D10,[ STTYTYPE: IFE SAIL,[ SKIPE T POPI P,1 JRST 0POPJ ;ALWAYS ZERO (?) ] ;END OF IFE SAIL IFN SAIL,[ SKIPN T SKIPA AR1,V%TYO POP P,AR1 PUSHJ P,TOFLOK PUSHJ P,D10TNM ;GET TTY NUMBER IN D GETLIN D ;GET LINE CHARACTERISTICS UNLOCKI HLRZ T,D TRZ T,150777 ;MASK OUT ALL NON-TTY-TYPE BITS JFFO T,.+2 SETZ TT, JRST FIX1 ] ;END OF IFN SAIL STTYSIZE: SKIPN T SKIPA AR1,V%TYO POP P,AR1 PUSHJ P,TOFLOK IFN SAIL,[ ;R GETS SIZE, TT GETS WIDTH MOVE F,[-2,,R] ;COUNT OF ARGS,,ADR OF ARGS MOVE R,[15,,R] ;TERMINAL SIZE, -1 IF NOT DISPLAY MOVE D,[6,,D] ;TERMINAL WIDTH (EXCEPT IF NON-ARPA TTY) TTYSET F, ;DO TERMINAL OPERATIONS SKIPGE R ;IF USE REAL PAGE LENGTH MOVE R,FO.RPL(TT) MOVE TT,D ;LINE LENGTH ENDS UP IN TT ] ;END OF IFN SAIL MOVE R,FO.RPL(TT) ;GET REAL PAGE LENGTH IFE SAIL,[ MOVE TT,FO.LNL(TT) ;GET LINEL ADDI TT,1 ;WIDTH IS 1 MORE THAN LINEL ] ;END IFE SAIL STTYS1: UNLOCKI JSP T,FXCONS MOVEI B,(A) MOVE TT,R JRST CONSFX ;;; GET DEC-10 TERMINAL NUMBER INTO D (-1 FOR OWN TERMINAL). ;;; ENTER WITH TTSAR OF FILE OBJECT IN TT. D10TNM: IFN SAIL,[ MOVE D,F.CHAN(TT) SKIPL F.MODE(TT) DEVNUM D, ;GET DEVICE NUMBER SETO D, ;ON FAILURE, OR FOR TTY, USE -1 ] ;END OF IFN SAIL IFE SAIL,[ SETO D, SKIPGE F.MODE(TT) .SEE FBT.CM POPJ P, HRRZ D,F.RDEV(TT) ;CONVERT SIXBIT UNIT NUMBER TO OCTAL REPEAT 3,[ DPB D,[360600,,D] DPB D,[030300,,D] TLNN D,700000 LSH D,-3 LSH D,-3 ] ;END OF REPEAT 3 ANDI D,777 ] ;END OF IFE SAIL POPJ P, ] ;END OF IFN D10 IFN D20,[ STTYTYPE: SKIPN T SKIPA AR1,V%TYO POP P,AR1 PUSHJ P,TOFLOK HRRZ 1,F.JFN(TT) GTTYP ;GET TTY TYPE MOVE TT,2 UNLOCKI JRST FIX1 STTYSIZE: SKIPN T SKIPA AR1,V%TYO POP P,AR1 PUSHJ P,TOFLOK HRRZ 1,F.JFN(TT) RFMOD ;READ JFN MODE WORD LDB R,[.BP TT%LEN,TT] ;GET PAGE LENGTH LDB TT,[.BP TT%WID,TT] ;GET WIDTH SETZ 2, STTYS1: UNLOCKI JSP T,FXCONS MOVEI B,(A) MOVE TT,R JRST CONSFX ] ;END OF IFN D20 SUBTTL STATUS TTYSCAN, TTYCONS, TTYINT STTYSCAN: SKIPN T ;GET TTY PRE-SCAN FUNCTION SKIPA AR1,V%TYI POP P,AR1 IFN SFA,[ JSP TT,XFOSP JRST STSCN1 JRST STSCN1 MOVEI A,(AR1) MOVEI B,QTTYSCAN SETZ C, JRST ISTCSH STSCN1: ] ;END IFN SFA PUSHJ P,TIFLOK HRRZ A,TI.BFN(TT) UNLKPOPJ SSTTYSCAN: CAMN T,XC-1 ;SET TTY PRE-SCAN FUNCTION SKIPA AR1,V%TYI POP P,AR1 IFN SFA,[ JSP TT,XFOSP ;DO WE HAVE AN SFA? JRST SSTSC1 ;NOPE JRST SSTSC1 ;DITTO POP P,A ;GET THE ARG JSP T,%NCONS ;TURN IT INTO A LIST MOVEI C,(A) ;AS THE ARG TO THE SFA MOVEI B,QTTYSCAN MOVEI A,(AR1) JRST ISTCSH SSTSC1: ] ;END IFN SFA PUSHJ P,TIFLOK POP P,A HRRZM A,TI.BFN(TT) UNLKPOPJ STTYCONS: MOVEI AR1,(A) ;GET ASSOCIATED TTY FILE OF CAIN AR1,TRUTH ; OPPOSITE DIRECTION, IF ANY HRRZ AR1,V%TYI ;PREFER INPUT TTY IFN SFA,[ JSP TT,XFOSP JRST STCON1 JRST STCON1 MOVEI A,(AR1) MOVEI B,QTTYCONS SETZ C, JRST ISTCSH STCON1: ] ;END IFN SFA PUSHJ P,TFILOK ;LEAVES ITS ARGUMENT IN AR1 HRRZ A,FT.CNS(TT) .SEE TTYMOR UNLKPOPJ SSTTYCONS: SKIPE A ;CONS TOGETHER TWO TTY'S INTO CAIN A,TRUTH ; A SINGLE CONSOLE EXCH A,B ;PREFER TO SEE NIL OR T SECOND CAIN A,TRUTH ;PREFER INPUT TTY FOR FIRST ARG HRRZ A,V%TYI SFA% MOVEI AR1,(A) IFN SFA,[ JSP TT,AFOSP ;DO WE HAVE AN SFA? JRST SSTCO1 ;NOPE JRST SSTCO1 ;NOPE MOVEI C,(B) ;YES, PASS THE SECOND ARG AS THE SFA'S ARG MOVEI B,QTTYCONS ;TTYCONS IS THE OPERATION JRST ISTCSH SSTCO1: ] ;END IFN SFA PUSHJ P,TFILOK JUMPE B,SSTC1 ;SUNDER THEM IF ONE IS NIL MOVEI T,TIFLOK TLNN TT,TTS MOVEI T,TOFLOK UNLOCKI CAIE B,TRUTH JRST SSTC2 HRRZ B,V%TYI ;FOR SECOND ARG OF T, USE TTY TLNN TT,TTS ; OF NECESSARY DIRECTION HRRZ B,V%TYO SSTC2: MOVEI AR1,(B) PUSHJ P,(T) HRRZ C,FT.CNS(TT) HRRZM A,FT.CNS(TT) ;LINK THIS ONE TO THAT ONE MOVEI TT,FT.CNS SKIPE C ;IF IT WAS LINKED, UNLINK SETZM @TTSAR(C) ; ITS FORMER PARTNER EXCH B,@TTSAR(A) ;LINK THAT ONE TO THIS ONE JUMPE B,UNLKTRUE ;????? THINK ABOUT ALL THIS? CAIE B,(A) ;IF IT WAS LINKED, UNLINK SETZM @TTSAR(B) ; ITS FORMER PARTNER JRST UNLKTRUE SSTC1: HRRZ B,FT.CNS(TT) ;GET ASSOCIATED TTY SETZM FT.CNS(TT) ;UNLINK THAT FROM THIS MOVEI TT,FT.CNS SKIPE B ;ONLY UNCONS IF WAS PREVIOUSLY CONSED SETZM @TTSAR(B) ;UNLINK THIS FROM THAT JRST UNLKTRUE STTYINT: CAMN T,XC-1 SKIPA AR1,V%TYI POP P,AR1 POP P,A JSP T,CHNV1 MOVE F,TT PUSHJ P,TIFLOK ROT F,-1 ADDI TT,FB.BUF(F) HRRZ A,(TT) SKIPL F HLRZ A,(TT) UNLKPOPJ SSTTYINT: CAMN T,XC-2 SKIPA AR1,V%TYI POP P,AR1 POP P,A JSP T,PDLNMK MOVEI B,(A) POP P,A JSP T,CHNV1 MOVE F,TT PUSHJ P,TIFLOK ROT F,-1 20$ PUSH P,TT ;SAVE TTSAR ADDI TT,FB.BUF(F) JUMPL F,SSTIN1 HRLM B,(TT) 20% JRST UNLKTRUE 20$ SKIPA SSTIN1: HRRM B,(TT) 20% JRST UNLKTRUE IFN D20,[ POP P,TT ;RESTORE TTSAR ROT F,1 ;RESTORE CHARACTER CAIE F,3 ;DON'T ALLOW USE TO ASSIGN ^C CAILE F,26. ;TOPS-20 ONLY SUPPORTS TO ^Z JRST UNLKTRUE ;RETURN TRUE, BUT DON'T DO TELL THE OP SYS MOVE T,V%TYI ;ONLY DO FOLLOWING IF *THE* TTY CAME TT,TTSAR(T) ;CHECK FOR TTSAR OF *THE* TTY JRST UNLKTRUE SETZB T,R ;SEARCH FOR A) FREE SLOT, B) EQUIVALENT SLOT SSTIN2: CAMN F,CINTAB(T) ;EQUIVALENT SLOT? JRST SSTIN3 ;YES, CODE ASSIGNED SO TAKE SPECIAL ACTION SKIPN CINTAB(T) ;EMPTY SLOT? MOVEI R,400000(T) ;YES, REMEMBER WE HAVE ONE CAIGE T,CINTSZ-1 ;DONE ALL OF TABLE? AOJA T,SSTIN2 ;NOPE, CONTINUE LOOPING JUMPE B,UNLKTRUE ;IF TURNING OFF AND DIDN'T FIND IN TAB, DONE SKIPN R ;FOUND A FREE SLOT? JRST SSTIN4 MOVEM F,CINTAB-400000(R) ;YES, STORE NEW CHARACTER ASSIGNMENT CAILE R,400005 ;CONVERT TO 400000+ ADDI R,22 HRLZI 1,(F) ;CHARACTER HRRI 1,-400000(R) ;INTERRUPT CHANNEL ATI ;ASSIGN THE CHARACTER TO THE CHANNEL MOVEI A,TRUTH ;RETURN TRUE UNLKPOPJ SSTIN3: JUMPN B,UNLKTRUE ;RETURN IF CHARACTER WAS ALREADY ASSIGNED SETZM CINTAB(T) ;CLEAR THE TABLE ENTRY MOVEI 1,(F) ;DEASSIGN THE TERMINAL CODE DTI JRST UNLKTRUE ;THEN RETURN TRUE SSTIN4: UNLOCKI FAC [NO FREE INTERRUPT CHANNELS - (SSTATUS TTYINT)!] ] ;END IFN D20 SUBTTL STORAGE SPACE STATUS CALLS SPDLMAX: IFN PAGING,[ JSP D,SSGP1 ;0 - STATUS PDLMAX SSPDLMAX: JSP D,SSGP1 ;1 - SSTATUS PDLMAX ] ;END OF IFN PAGING .ELSE REPEAT 2, 0 ;0, 1 UNUSED SGCSIZE: JSP D,SSGP1 ;2 - STATUS GCSIZE SSGCSIZE: JSP D,SSGP1 ;3 - SSTATUS GCSIZE SGCMAX: JSP D,SSGP1 ;4 - STATUS GCMAX SSGCMAX: JSP D,SSGP1 ;5 - SSTATUS GCMAX SGCMIN: JSP D,SSGP1 ;6 - STATUS GCMIN SSGCMIN: JSP D,SSGP1 ;7 - SSTATUS GCMIN SPDLSIZE: JSP D,SSGP1 ;10 - STATUS PDLSIZE SPURSIZE: SKIPA B,A ;14 - STATUS PURSIZE SSPCSIZE: JSP D,SSGP1 ;12 - STATUS SPCSIZE MOVEI D,14 ;FAKE OUT A JSP D,SSGP1 CAIG B,QRANDOM ;LOSE IF BAD SPACE TYPE CAIGE B,QLIST JRST SSGPLZ 2DIF SKIPN (B),GTNPS8,QLIST JRST SSGPLZ JRST SSGP1A SPDLROOM: MOVEI D,20+SPDLMAX+1 ;20 - STATUS PDLROOM SSGP1: SUBI D,SPDLMAX+1 ;GET CODE NUMBER IN D MOVEI C,(B) ;YECH - SHUFFLE, SHUFFLE MOVEI B,(A) SSGP1A: MOVEI AR1,(B) CAIN B,QRANDOM ;GET LINEARIZATION BY USING JRST SSGPLZ ; QRANDOM FOR QARRAY CAIN B,QARRAY MOVEI B,QRANDOM TRNE D,6 ;SKIP IF PDLMAX OR PDLSIZE JRST SSGP1C CAIL B,QREGPDL CAILE B,QSPECPDL JRST SSGPLZ JRST SSGP1D SSGP1C: CAIG B,QRANDOM ;LOSE IF BAD SPACE TYPE CAIGE B,QLIST JRST SSGPLZ SSGP1D: ROT D,-1 ;LOW BIT=1 => SSTATUS JUMPL D,SSG3A1 MOVE TT,@SSGPGT(D) ;ELSE GET VALUE TO RETURN TRNE D,3 JRST SSGP2A 2DIF [SUB TT,(B)]C2,QREGPDL ;FOR PDL STUFF, CUT DOWN TLZ TT,-1 ; QUANTITY BY PDL ORIGIN SSGP2A: TLNN TT,-1 ;HACK SO THAT STATUS GCMIN JRST FIX1 ; WILL RETURN A FLONUM JRST FLOAT1 ; IF APPROPRIATE SSGPGT: 10% 2DIF (B),XPDL,QREGPDL ;PDLMAX 10$ 0 ;UNUSED 2DIF (B),GFSSIZ,QLIST ;GCSIZE 2DIF (B),XFFS,QLIST ;GCMAX 2DIF (B),MFFS,QLIST ;GCMIN 2DIF (B),P,QREGPDL ;PDLSIZE 2DIF (B),SFSSIZ,QLIST ;SPCSIZE 2DIF (B),PFSSIZ,QLIST ;PURSIZE 0 ;UNUSED 2DIF (B),OC2,QREGPDL ;PDLROOM SSGPLZ: MOVEI T,SBADSP ;BAD SPACE TYPE (OR MAYBE PDL TYPE?) TRNN D,6 MOVEI T,[SIXBIT \BAD PDL TYPE - STATUS!\] MOVEI A,(AR1) %WTA (T) MOVEI B,(A) JRST SSGP1A SSGP3$: JUMPE C,TRUE ;USED BY $ALLOC ;A CHANGE IN POLICY TO ALWAYS ALLOW A FLONUM SSG3A1: MOVEI T,(D) CAIN T,3 ;IF GCMIN, JRST SSGP4 ; USE SPECIAL CHECKING CODE SSGP3A: SKOTT C,FL ;ALLOW FLONUM JRST SSGP3Z MOVE TT,(C) ;GET THE FLONUM PUSH FXP,D ;SAVE D OVER CALL TO IFIX JSP T,IFIX ;CONVERT TO A FIXNUM POP FXP,D MOVE R,TT JRST SSGP3Y ;THEN HANDLE AS IF FIXNUM SSGP3Z: SKOTT C,FX ;MUST BE FIXNUM JRST FALSE MOVE R,(C) ;ELSE FETCH THE FIXNUM SSGP3Y: TLNE R,-1 ;LOSE IF NEG OR TOO LARGE JRST FALSE JRST SSGPPT(D) ;ELSE JRST TO SPECIAL ROUTINE SSGPPT: 10% JRST SSPM1 ;PDLMAX 10$ 0 JRST SSGS1 ;GCSIZE JRST SSGX1 ;GCMAX SSGM1: CAIL R,40 ;GCMIN 2DIF [CAMLE D,(B)]SSGMRV,QLIST ;FIXNUM GCMIN MUST HAVE JRST FALSE ; "REASONABLE" VALUE SSGM2: 2DIF [MOVEM R,(B)]MFFS,QLIST ;SO SAVE IT, ALREADY JRST TRUE SSGMRV: 20000 ;LIST 10000 ;FIXNUM 4000 ;FLONUM BG$ 4000 ;BIGNUM 4000 ;SYMBOL REPEAT HNKLOG+1, 100000 ;HUNKS 1000 ;SAR SSGP4: MOVEI A,(C) ;(SSTATUS GCMIN ...) PERMITS JSP T,FLTSKP ; A FLONUM ARGUMENT JRST SSGP3A JUMPLE TT,FALSE ;BUT MUST BE POSITIVE CAML TT,[.005] ; AND BETWEEN .005 AND .95 CAMLE TT,[.95] JRST FALSE MOVE R,TT JRST SSGM2 SSGS1: ANDI R,SEGMSK 2DIF [MOVEM R,(B)]GFSSIZ,QLIST ;SET GCSIZE 2DIF [CAMG R,(B)]XFFS,QLIST ;IF GREATER THAN GCMAX, JRST TRUE ; MUST ALSO SET GCMAX TO MATCH SSGX1: 2DIF [CAMGE R,(B)]SFSSIZ,QLIST ;GCMAX MAY NOT BE LESS JRST FALSE ; THAN ACTUAL SIZE XCTPRO 2DIF [HRRZM R,(B)]XFFS,QLIST NOPRO JRST TRUE IFN ITS+D20,[ SSPM1: HRRZ T,P-QREGPDL(B) ;GET CURRENT PDL POINTER ADD R,C2-QREGPDL(B) ;UP USER'S VALUE BY PDL ORIGIN ANDI R,777760 TRNN R,PAGKSM SUBI R,20 CAILE R,(T) ;NEW PDLMAX MUST BE ABOVE CAML R,OC2-QREGPDL(B) ; CURRENT PDL POINTER, AND JRST FALSE ; BELOW ABS OVERFLOW POINT HRRZM R,XPDL-QREGPDL(B) HRRZM R,ZPDL-QREGPDL(B) ;SO UPDATE CRAP HRROS P-QREGPDL(B) ;SET LH OF PDL POINTER TO -1 JRST TRUE ; SO PDLOV WILL HACK IT PROPERLY ] ;END OF IFN ITS+D20 ;;; PART OF PUTPROP - HACK FOR *PURE MODE TO PURIFY PROPERTY LISTS CSETP1: PUSH P,B MOVEI A,(C) MOVE B,VPUTPROP PUSHJ P,MEMQ ;CALLS THE CHECKING VERSION OF MEMQ POP P,B JUMPE A,CSETP7 PUSH P,C ;NEED TO PURCOPY C(C) ALSO MOVEI A,(B) PUSHJ P,PURCOPY EXCH A,(P) ;REMEMBER THE VALUE, GET THE PROPERTY SKOTT A,SY ;IS THE PROPERTY A SYMBOL? JRST CSETNS ;NO HLRZ T,(A) ;POINTER TO THE SY2 BLOCK MOVE T,SYMVC(T) ;GET THE FLAG BITS TLNN T,SY.PUR ;IS IT ALREADY PURE? PUSHJ P,PURCOPY ;NO, PURCOPY IT CSETNS: POP P,A ;RESTORE THE VALUE TO BE PUT ON THE PROPERTY MOVE T,(P) CSETP2: HRRZ B,(T) JUMPE B,CSETP3 MOVEI TT,(B) LSH TT,-SEGLOG MOVE TT,ST(TT) TLNE TT,PUR JRST CSETP3 HRRZ T,(B) JRST CSETP2 CSETP3: PUSHJ P,PCONS MOVEI B,(A) MOVEI A,(C) PUSHJ P,PCONS HRRM A,(T) SUB P,R70+1 JRST $CADR CSETP7: HRRZ A,(P) JRST CSET2A SUBTTL STATUS RANDOM SRANDOM: SETZ B, MOVEI F,LRBLOCK-1+2 ;+2 FOR RNOWS AND RBACK SRAND3: MOVE TT,RNOWS(F) ;CONS UP A LIST SUMMARIZING PUSHJ P,CONSFX ; THE STATE OF THE RANDOM SOJGE F,SRAND3 ; NUMBER GENERATOR POPJ P, SSRAN0: WTA [BAD ARGUMENT - STATUS RANDOM!] SSRANDOM: SKOTT A,LS JRST SSRAN8 MOVEI B,(A) JSP TT,SSRAN6 MOVEM R,RNOWS JSP TT,SSRAN6 MOVEM R,RBACK MOVNI F,LRBLOCK SSRAN3: HLRZ C,(B) JSP T,FXNV3 MOVEM R,RBLOCK+LRBLOCK(F) HRRZ B,(B) AOJL F,SSRAN3 JRST TRUE SSRAN6: HLRZ C,(B) JSP T,FXNV3 JUMPLE R,SSRAN0 CAILE R,LRBLOCK+1 JRST SSRAN0 HRRZ B,(B) JRST (TT) SSRAN8: JSP T,FXNV1 SKIPN TT ;0 IS BAD VALUE MOVEI TT,1 JSP F,IRAND0 JRST TRUE ;;; Hooks for the EXTEND hackery SSCALLI: MOVE C,A MOVEI B,QCALLI ;Look on the CALLI property for PUSHJ P,$GET ;the "SUBR" to invoke MOVE T,[ICALLI,,UCALLI] MOVSI TT,(JRST) ;We JRST to it, and it hacks the stack MOVEM C,(T) ;We write it, since don't have frob in A JRST SSSEN1 SSSENDI: ;Set the SEND interpreter MOVE T,[SENDI,,USENDI] MOVSI TT,(JCALL 16,) SSSENA: MOVEM A,(T) ;Remember what it is for (STATUS SENDI), GC SSSEN1: MOVSS T ;Now hack the instruction cell JUMPE A,SSSEN0 ;If NIL, zero SENDI so won't be XCT'd HRR TT,A MOVEM TT,(T) ;Save the call instruction for it JRST TRUE ;Return truth SSSEN0: SETZM (T) JRST TRUE SSUSRHNK: ;Set the USER-HUNK check MOVE T,[USRHNK,,UUSRHNK] MOVSI TT,(CALL 1,) JRST SSSENA IFN USELESS,[ IFN ITS,[ SUBTTL STATUS WHO-LINE [ETC.] SSWHO1: SETZ F, MOVE D,[441000,,F] JSP T,FXNV1 IDPB TT,D MOVEI A,(B) JSP T,CHNV1X IDPB TT,D JSP T,FXNV3 IDPB R,D MOVEI A,(AR1) JSP T,CHNV1X IDPB TT,D .SUSET [.SWHO1,,F] JRST TRUE SSWHO2: PUSHJ P,SIXNUM .SUSET [.SWHO2,,TT] JRST TRUE SSWHO3: PUSHJ P,SIXNUM .SUSET [.SWHO3,,TT] JRST TRUE SWHO1: .SUSET [.RWHO1,,F] MOVEI R,4 SETZ B, MOVE D,[441000,,F] SWHO1A: ILDB TT,D JSP T,FXCONS PUSHJ P,CONS MOVEI B,(A) SOJG R,SWHO1A JRST NREVERSE SWHO2: .SUSET [.RWHO2,,TT] JRST FIX1 SWHO3: .SUSET [.RWHO3,,TT] JRST FIX1 SIXNUM: SKOTT A,FX JRST SIXMAK POP P,T JRST FXNV1 SMAR: MOVE T,IMASK TRNN T,%PIMAR ;NIL IF LISP NOT USING MAR JRST FALSE ; (BUT SUPERIOR MIGHT BE) .SUSET [.RMARA,,D] HLRZ TT,D MOVEI A,(D) PUSHJ P,ACONS MOVEI B,(A) JRST CONSFX ;RETURN LIST OF (MODE, LOCATION) SSMAR: MOVEI F,%PIMAR JSP T,FXNV1 TRZ TT,4 JUMPE TT,SSMAR5 IORM F,IMASK .SUSET [.SIMASK,,F] HRLI B,(TT) .SUSET [.SMARA,,B] JRST TRUE SSMAR5: .SUSET [.SMARA,,R70] ANDCAM F,IMASK .SUSET [.SAMASK,,F] JRST TRUE ;;; IFN USELESS ;;; IFN ITS SSGCWHO: JSP T,FXNV1 ANDI TT,3 MOVEM TT,GCWHO JRST TRUE SITS: .CALL SITS9 .VALUE PUSH FXP,T JSP T,IFLOAT FDVRI TT,(30.0) JSP T,FLCONS SETZ B, PUSHJ P,CONSIT POP FXP,TT PUSHJ P,CONSFX MOVE TT,D PUSHJ P,CONSFX MOVE TT,R PUSHJ P,CONSFX MOVE TT,F JSP T,IFLOAT SKIPL TT FDVRI TT,(30.0) JSP T,FLCONS JRST CONS SITS9: SETZ SIXBIT \SSTATU\ 2000,,F ;TIME UNTIL SYSTEM GOES DOWN 2000,,R ;SYSTEM BEING DEBUGGED 2000,,D ;NUMBER OF LOSERS 2000,,T ;NUMBER OF MEMORY ERRORS 402000,,TT ;TIME SYSTEM HAS BEEN UP ] ;END OF IFN ITS ] ;END OF IFN USELESS SUBTTL ASCII TABLE OF STATUS FUNCTIONS ;;; ***** ASCII TABLE OF STATUS FUNCTIONS ***** PART 1 ***** STBA: ASCII \MACRO\ ;MACRO ASCII \DIVOV\ ;DIVOV (DIVIDE OVERFLOW) ASCII \TTY\ ;TTY ASCII \TOPLE\ ;TOPLEVEL ASCII \BREAK\ ;BREAKLEVEL ASCII \UREAD\ ;UREAD ASCII \UWRIT\ ;UWRITE ASCII \+\ ;+ (SUPRA-DECIMAL DIGITS OPTION) ASCII \GCMIN\ ;GCMIN ASCII \SYNTA\ ;SYNTAX ASCII \CHTRA\ ;CHTRAN (CHARACTER TRANSLATION) ASCII \TTYIN\ ;TTYINT ASCII \GCTIM\ ;GCTIME ASCII \LOSEF\ ;LOSEF (LAP OBJECT STORAGE EFFICIENCY FACTOR) ASCII \TERPR\ ;TERPRI (SUPPRESSION OF AUTO-TERPRI) ASCII \_\ ;_ (CAN PRIN1 USE _ FIXNUM SYNTAX) ASCII \TTYRE\ ;TTYREAD ASCII \FEATU\ ;FEATURE ASCII \NOFEA\ ;NOFEATURE IFN USELESS, ASCII \ABBRE\ ;ABBREVIATE ASCII \UUOLI\ ;UUOLINKS ASCII \GCMAX\ ;GCMAX IFN PAGING, ASCII \PDLMA\ ;PDLMAX ASCII \GCSIZ\ ;GCSIZE ASCII \LINMO\ ;LINMODE ASCII \CRFIL\ ;CRFILE (CURRENT FILE) ASCII \CRUNI\ ;CRUNIT (CURRENT UNIT) ASCII \EVALH\ ;EVALHOOK (FOR MULTICS COMPATIBILITY) ASCII \TTYSC\ ;TTYSCAN ASCII \TTYCO\ ;TTYCONS ASCII \RANDO\ ;RANDOM IFN USELESS,[ IFN ITS,[ ASCII \WHO1\ ;WHO1 ;ITS WHO-LINE ASCII \WHO2\ ;WHO2 ; DISPLAY ASCII \WHO3\ ;WHO3 ; VARIABLES ASCII \MAR\ ;MAR ;MAR BREAK FEATURE ASCII \GCWHO\ ] ;END OF IFN ITS ] ;END OF IFN USELESS ASCII \PUNT\ ;PUNT ;TRUE MEANS NO FUNCTIONAL VARIABLES ASCII \FLUSH\ ;FLUSH ;NON-NIL MEANS FLUSH PAGES UPON ; A SUSPEND IFN USELESS*ITS, ASCII \CLI\ ;CLI ;DISABLE/ENABLE CLI INTERRUPTS ASCII \NOINT\ ;NOINT ;Enable/disble interrupts ASCII \SENDI\ ;SENDI ;SEND interpreter ASCII \CALLI\ ;CALLI ;CALL interpreter ASCII \USRHU\ ;USRHU ;USRHUNK routine LSSTBA==.-STBA ;END OF ENTRIES WHICH CAN BE SSTATUS'D ;;; ***** ASCII TABLE OF STATUS FUNCTIONS ***** PART 2 ***** ASCII \FASLN\ ;FASLNAMELIST ASCII \PURSI\ ;PURSIZE ASCII \PDLSI\ ;PDLSIZE ASCII \DAYTI\ ;DAYTIME ASCII \DATE\ ;DATE IFN USELESS, ASCII \DOW\ ;DOW (DAY OF WEEK) IT$ ASCII \TTYSI\ ;TTYSIZE (HEIGHT . WIDTH) ASCII \UNAME\ ;UNAME (USER NAME) ASCII \USERI\ ;USERID ASCII \XUNAM\ ;XUNAME ASCII \JNAME\ ;JNAME (JOB NAME) ASCII \SUBSY\ ;SUBSYSTEM ASCII \JNUMB\ ;JNUMBER ASCII \HOMED\ ;HOMEDIR (HOME DIRECTORY NAME) ASCII \HSNAM\ ;HSNAME (SMART HOME DIRECTORY NAME) ASCII \LISPV\ ;LISPVERSION ASCII \JCL\ ;JCL (JOB COMMAND LINE) IT$ ASCII \HACTR\ ;HACTRN ASCII \UDIR\ ;UDIR (USER DIRECTORY NAME) ASCII \FXPDL\ ;FXPDL (FIXNUM PDL) ASCII \FLPDL\ ;FLPDL (FLONUM PDL) ASCII \PDL\ ;PDL (REG PDL) ASCII \SPDL\ ;SPDL (SPECIAL PDL) ASCII \BPSL\ ;BPSL (BINARY PROGRAM SPACE LOW) ASCII \BPSH\ ;BPSH (BINARY PROGRAM SPACE HIGH) ASCII \SEGLO\ ;SEGLOG (LOG2 OF SEGMENT SIZE) ASCII \SYSTE\ ;SYSTEM (SYSTEM ATOM) ASCII \TABSI\ ;TABSIZE ASCII \FILES\ ;FILESYSTEM-TYPE ASCII \OPSYS\ ;OPSYSTEM-TYPE ASCII \SITE\ ;SITE NAME ASCII \SPCNA\ ;SPCNAMES (NAMES OF DATA SPACES) ASCII \PURSP\ ;PURSPCNAMES ASCII \PDLNA\ ;PDLNAMES ASCII \SPCSI\ ;SPCSIZE ASCII \PDLRO\ ;PDLROOM ASCII \MEMFR\ ;MEMFREE ASCII \NEWLI\ ;NEWLINE ASCII \FILEM\ ;FILEMODE ASCII \TTYTY\ ;TTYTYPE IT$ ASCII \OSPEE\ ;OSPEED ASCII \FASLO\ ;FASLOAD (RETURNS CURRENT LDBSAR) IFN USELESS,[ IFN ITS,[ ASCII \ITS\ ;ITS ] ;END OF IFN ITS ] ;END OF IFN USELESS ASCII \STATU\ ;STATUS ASCII \SSTAT\ ;SSTATUS ASCII \ARRAY\ ;ARRAY LSTBA==.-STBA SUBTTL STATUS DISPATCH TABLES ;;; FORMAT <4.9-4.7> , <4.6-3.8> , <2.9-1.1> .FORMAT 37,002231104103 RADIX 4 ;;; MAGIC TABLE OF STATUS OPERATIONS ;;; 4.9-4.7 OPERATION TYPE ;;; 0 SUBR-TYPE FUNCTION ;;; 1 LSUBR-TYPE FUNCTION ;;; 2 SUBR-TYPE WITH CHAR FIRST ARG ;;; 3 LSUBR-TYPE WITH CHAR FIRST ARG ;;; 4 GET LISP VALUE ;;; 5 SET LISP VALUE ;;; 6 SET TO T-OR-NIL ;;; 7 GET FIXNUM VALUE ;;; 4.6-4.5 ARGUMENT 1 TYPE ;;; 0 NO MORE ARGS ;;; 1 QUOTED ARGUMENT ;;; 2 TAKE REST AS QUOTED LIST ;;; 3 EVALUATED ARGUMENT ;;; 4.4-4.3 ARGUMENT 2 TYPE ;;; 4.2-4.1 ARGUMENT 3 TYPE ;;; 3.9-3.8 ARGUMENT 4 TYPE ;;; 3.7-3.1 ARGS INFO ;;; .FORMAT 37,002231104103 ;;; RADIX 4 ;;; ***** SSTATUS FUNCTION TABLE ***** MUST MATCH ASCII TABLE ***** STBSS: 3,1310,SSMACRO (FA23) ;MACRO 6,3000,RWG (FA1) ;DIVOV IT$ 1,3333,SSTTY (FA1234&1333) ;TTY 20$ 1,3333,SSTTY (FA1N&1333) ;TTY 10$ SA% 1,3333,SSTTY (FA12) ;TTY 10$ SA$ 1,3333,SSTTY (FA1N&1333) ;TTY 5,3000,TLF (FA1) ;TOPLEVEL 5,3000,BLF (FA1) ;BREAKLEVEL 0,2000,UREAD (FA0234);UREAD 0,2000,UWRITE (FA012) ;UWRITE 0,3000,SSPLSS (FA1) ;+ 0,3300,SSGCMIN (FA2) ;GCMIN 2,1300,SSSYNTA (FA2) ;SYNTAX 2,1300,SSCHTRA (FA2) ;CHTRAN 1,3330,SSTTYINT (FA23) ;TTYINT 0,3000,SSGCTIM (FA1) ;GCTIME 0,3000,SSLOSEF (FA1) ;LOSEF 1,3300,SSTERPRI (FA12) ;TERPRI 0,3000,SSLAP (FA1) ;_ 0,3000,SSTTYREAD (FA1) ;TTYREAD 0,1000,SSFEATURE (FA1) ;FEATURE 0,1000,SSNOFEATURE (FA1) ;NOFEATURE IFN USELESS, 0,3000,SSABBREVIATE (FA1) ;ABBREVIATE 0,0000,SSUUOLINKS (FA0) ;UUOLINKS 0,3300,SSGCMAX (FA2) ;GCMAX IFN PAGING, 0,3300,SSPDLMAX (FA2) ;PDLMAX 0,3300,SSGCSIZE (FA2) ;GCSIZE 1,3300,SSLINMODE (FA12) ;LINMODE 20% 0,2000,SSCRFIL (FA2) ;CRFILE 20$ 0,2000,SSCRFIL (FA23) ;CRFILE 0,2000,CRUNIT (FA012) ;CRUNIT 0,3000,FALSE (FA1) ;EVALHOOK 1,3300,SSTTYSCAN (FA12) ;TTYSCAN 0,3300,SSTTYCONS (FA2) ;TTYCONS 0,3000,SSRANDOM (FA1) ;RANDOM IFN USELESS,[ IFN ITS,[ 0,3333,SSWHO1 (FA4) ;WHO1 0,3000,SSWHO2 (FA1) ;WHO2 0,3000,SSWHO3 (FA1) ;WHO3 0,3300,SSMAR (FA2) ;MAR 0,3000,SSGCWHO (FA1) ;GCWHO ] ;END OF IFN ITS ] ;END OF IFN USELESS 6,3000,EVPUNT (FA1) ;PUNT 6,3000,SUSFLS (FA1) ;FLUSH IFN USELESS*ITS, 0,3000,SSCLI (FA1) ;CLI 0,3000,NOINTERRUPT (FA1) ;NOINTERRUPT 0,3000,SSSENDI (FA1) ;SENDINTERPRETER 0,3000,SSCALLI (FA1) ;CALLINTERPRETER 0,3000,SSUSRHNK (FA1) ;USRHNK LSST==.-STBSS IFN LSST-LSSTBA, WARN [WRONG LENGTH SSTATUS TABLE] ;;; .FORMAT 37,002231104103 ;;; RADIX 4 ;;; ***** STATUS FUNCTION TABLE ***** PART 1 (MATCHES STBSS) ***** STBS: 2,1000,SMACRO (FA1) ;MACRO 4,0000,RWG (FA0) ;DIVOV 1,3000,STTY (FA01) ;TTY 4,0000,TLF (FA0) ;TOPLEVEL 4,0000,BLF (FA0) ;BREAKLEVEL 0,0000,SUREAD (FA0) ;UREAD 0,0000,SUWRITE (FA0) ;UWRITE 0,0000,SPLSS (FA0) ;+ 0,3000,SGCMIN (FA1) ;GCMIN 2,1000,SSYNTAX (FA1) ;SYNTAX 2,1000,SCHTRAN (FA1) ;CHTRAN 1,3300,STTYINT (FA12) ;TTYINT 0,0000,SGCTIM (FA0) ;GCTIM 0,0000,SLOSEF (FA0) ;LOSEF 1,3000,STERPRI (FA01) ;TERPRI 0,0000,SLAP (FA0) ;_ 0,0000,STTYREAD (FA0) ;TTYREAD 0,2000,SFEATURES (FA01) ;FEATURES 0,2000,SNOFEATURE (FA1) ;NOFEATURE IFN USELESS, 0,0000,SABBREVIATE (FA0) ;ABBREVIATE 0,0000,SUUOLINKS (FA0) ;UUOLINKS 0,3000,SGCMAX (FA1) ;GCMAX IFN PAGING, 0,3000,SPDLMAX (FA1) ;PDLMAX 0,3000,SGCSIZE (FA1) ;GCSIZE 1,3000,SLINMODE (FA01) ;LINMODE 0,0000,SCRFIL (FA0) ;CRFILE 0,0000,SCRUNIT (FA0) ;CRUNIT 0,0000,FALSE (FA0) ;EVALHOOK 1,3000,STTYSCAN (FA01) ;TTYSCAN 0,3000,STTYCONS (FA1) ;TTYCONS 0,0000,SRANDOM (FA0) ;RANDOM IFN USELESS,[ IFN ITS,[ 0,0000,SWHO1 (FA0) ;WHO1 0,0000,SWHO2 (FA0) ;WHO2 0,0000,SWHO3 (FA0) ;WHO3 0,0000,SMAR (FA0) ;MAR 7,0000,GCWHO (FA0) ;GCWHO ] ;END OF IFN ITS ] ;END OF IFN USELESS 4,0000,EVPUNT (FA0) ;PUNT 4,0000,SUSFLS (FA0) ;FLUSH IFN USELESS*ITS, 0,3000,SCLI (FA0) ;CLI 0,0000,SNOINT (FA0) ;NOINTERRUPT 4,0000,USENDI (FA0) ;SENDINTERPRETER 4,0000,UCALLI (FA0) ;CALLINTERPRETER 4,0000,UUSRHNK (FA0) ;USRHNK IFN .-STBS-LSSTBA, WARN [WRONG LENGTH STATUS TABLE PART 1] ;;; .FORMAT 37,002231104103 ;;; RADIX 4 ;;; ***** STATUS FUNCTION TABLE ***** PART 2 (NON-SSTATUS ITEMS) ***** 4,0000,LDFNAM (FA0) ;FASLNamelist 0,3000,SPURSIZE (FA1) ;PURSIZE 0,3000,SPDLSIZE (FA1) ;PDLSIZE 0,0000,STIME (FA0) ;DAYTIME 0,0000,SDATE (FA0) ;DATE IFN USELESS, 0,0000,SDOW (FA0) ;DOW (DAY OF WEEK) IT$ 1,3000,STTYSIZE (FA01) ;TTYSIZE 0,0000,SUNAME (FA0) ;UNAME 0,0000,SUSERID (FA0) ;USERID 0,0000,SUSERID (FA0) ;XUNAME 0,0000,SJNAME (FA0) ;JNAME 0,0000,SSUBSYSTEM (FA0) ;SUBSYSTEM 0,0000,SJNUMBER (FA0) ;JNUMBER IT$ 0,0000,SHOMED (FA0) ;HOMEDIR IT% 20% 4,0000,SUDIR (FA0) ;HOMEDIR 20$ 0,0000,SRCDIR (FA0) ; 1,3300,SHSNAME (FA012) ;HSNAME 0,0000,SLVRNO (FA0) ;LISPVERSION IT$ 0,0000,SJCL (FA0) ;JCL IT% 4,0000,VNIL (FA0) ;DECSYSTEM-10 HAS NO JCL 20$ WARN [TOPS-20 JCL?] IT$ 0,0000,SDDTP (FA0) ;HACTRN IFE D20\ITS 4,0000,SUDIR (FA0) ;UDIR IFN D20\ITS 0,0000,SRCDIR (FA0) ; 7,0000,FXC2 (FA0) ;FXPDL 7,0000,FLC2 (FA0) ;FLPDL 7,0000,C2 (FA0) ;PDL 7,0000,SC2 (FA0) ;SPDL 7,0000,BPSL (FA0) ;BPSL (ORIGINAL BPS LOW) 7,0000,BPSH (FA0) ;BPS HIGH 7,0000,[SEGLOG] (FA0) ;SEGLOG 0,3000,SSYSTEM (FA1) ;SYSTEM 7,0000,IN10 (FA0) ;TABSIZE 0,0000,SFILES (FA0) ;FILESYSTEM-TYPE 0,0000,SOPSYS (FA0) ;OPSYSTEM-TYPE 0,0000,SSITE (FA0) ;SITE 4,0000,[SPCNAMES] (FA0) ;SPCNAMES 4,0000,[PURSPCNAMES] (FA0) ;PURSPCNAMES 4,0000,[PDLNAMES] (FA0) ;PDLNAMES 0,3000,SSPCSIZE (FA1) ;SPCSIZE 0,3000,SPDLROOM (FA1) ;PDLROOM 0,0000,SMEMFREE (FA0) ;MEMFREE 7,0000,IN0+^M (FA0) ;NEWLINE 0,3000,SFILEMODE (FA1) ;FILEMODE 1,3000,STTYTYPE (FA01) ;TTYTYPE IT$ 1,3000,SOSPEED (FA01) ;OSPEED 4,0000,LDBSAR (FA0) ;FASLOAD IFN USELESS,[ IFN ITS,[ 0,0000,SITS (FA0) ;ITS ] ;END OF IFN ITS ] ;END OF IFN USELESS 1,1000,SSSS (FA01) ;STATUS 1,1000,SSSSS (FA01) ;SSTATUS 0,0000,SARRAY (FA0) ;ARRAY IFN .-STBS-LSTBA, WARN [WRONG LENGTH STATUS TABLE PART 2] RADIX 8 .FORMAT 37,0 ;MAKE FORMAT 37 ILLEGAL AGAIN ;;@ END OF STATUS 220 SUBTTL CURSORPOS FUNCTION IFN USELESS,[ CURSORPOS: MOVEI D,QCURSORPOS ;LSUBR (0 . 3) CAMGE T,XC-3 ;MORE THAN THREE ARGS LOSES JRST WNALOSE JUMPE T,CRSRP0 ;IF NO ARGS, IS FOR DEFAULT TTY CRSRPS: SKIPN AR1,(P) ;ELSE LAST ARG MAY BE TTY FILE ARRAY JRST CRSRN MOVEI TT,(AR1) LSH TT,-SEGLOG SKIPGE ST(TT) JRST CRSRMP CAIN AR1,TRUTH ;LAST ARG = T HRRZ AR1,V%TYO ; MEANS THE DEFAULT TTY CRSR10: CAMN T,XC-3 ;FOR THREE ARGS MUST HAVE A FILE ARRAY JRST CRSRP8 JSP TT,XFOSP ;FOR ONE OR TWO ARGS MAY OR MAY JRST CRSRP0 ; NOT HAVE A FILE ARRAY IFN SFA,[ JRST CRSFA1 ;FILE CRSFA5: SUB P,R70+1 ;SFA CRSFAY: SETZ C, AOJE T,CRSFA2 ;ONE LESS ARG; ONLY 1 ARG, ARG TO SFA IS NIL POP P,A ;LISTIFY THE ARGS PUSHJ P,NCONS ;GENERATE THE INITIAL LIST AOSN T ;TWO ARGS? JRST CRSFA4 POP P,B JSP T,%XCONS ;NOW THE LIST IS IN A CRSFA4: MOVEI C,(A) CRSFA2: MOVEI B,QCURSORPOS ;CURSORPOS OPERATION MOVEI A,(AR1) ;THE SFA ITSELF JRST ISTCSH CRSFAZ: HRRO AR1,V%TYO ;GET FILE AS SPECIFIED BY 'T' JSP TT,XFOSP ;CHECK FOR IT BEING A SFA JRST (F) ;NOPE JRST (F) SOJA T,CRSFAY ;A SFA, HANDLE SPECIALLY ] ;END IFN SFA CRSRP8: IFN SFA,[ JSP TT,XFOSP ;CHECK IF FILE OR SFA JFCL SKIPA ;NOT SFA JRST CRSFA5 ;SFA CRSFA1: ] ;END IFN SFA SUB P,R70+1 ;IF WE HAVE ONE, IT MUST PUSH FXP,T ; BE A BONA FIDE TTY OUTPUT FILE PUSHJ P,TOFLOK UNLOCKI POP FXP,T AOSA T CRSRP0: SFA% HRRO AR1,V%TYO SFA$ JSP F,CRSFAZ JSP R,PDLA2(T) MOVEI TT,F.MODE MOVE D,@TTSAR(AR1) SKIPGE AR1 ;IF FILE NOT EXPLICITLY GIVEN SKIPN TTYOFF ; THEN ^W NON-NIL => RETURN NIL SKIPA JRST FALSE JUMPE T,CRSRP1 ;0 ARGS - GET POSITION AOJE T,CRSRP3 ;1 ARG - SPECIAL HACKS (^P CODES) SKOTT A,FX JRST CRSR11 ;2 ARGS MOVEI D,"V ;SET VERTICAL POSITION PUSHJ P,CRSRP5 CRSR20: MOVEI D,"H ;SET HORIZONTAL POSITION MOVEI A,(B) CRSRP5: JUMPE A,TRUE ;NIL MEANS NO CHANGE JSP T,FXNV1 SKIPGE TT SETZ TT, ;NEGATIVE ARG NOT ALLOWED CAILE TT,167 ;NOR ARG ABOVE 167 MOVEI TT,167 IT$ HRLI D,10(TT) ;ADD MAGIC 10 TO AMOUNT FOR ^P IT% JRST FALSE 20$ WARN [CURSORPOS FOR "V" AND "H" ??] CRSRP7: PUSHJ FLP,CNPCHK ;CHECK TO SEE IF CAPABILITY EXISTS? JRST CRSR71 IT$ MOVEI A,TRUTH ;RETURN TRUTH IF WE GOT THIS FAR IT% MOVEI A,NIL ;RIGHT NOW, NON-ITS SYSTEMS CANT "DO IT" JRST CNPCUR ; THEN DO THE ACTION, AND EXIT WITH CZECHI CRSR71: MOVEI A,NIL ;NO CAPABILITY, SO RETURN NIL JRST CZECHI ;1 ARG CASE CRSRP3: JSP T,SPATOM JRST CRSRP4 ;IF NO A SYMBOL, THEN BETTER BE FIXNUM PUSHJ P,CRSR40 ;GET NUMERIC VALUE OF FIRST CHAR OF SYMBOL CRSRP6: MOVEI D,(TT) TRC TT,100 TDNE TT,[-40] JRST CRSRP2 MOVE TT,GCBT(TT) ;Get a "1" bit in the position specified by TT TDNN TT,CRSRP9 JRST CRSRP2 JRST CRSRP7 CRSRP4: JSP T,FXNV1 JRST CRSRP6 CRSR40: JSP T,CHNV1 CAIL TT,140 SUBI TT,40 ;CONVERT TO UPPER CASE POPJ P, CRSRP9: ZZZ==0 IRPC X,,[ABCDEFKLMNPQRSTUXZ[\]^_] ZZZ==ZZZ\> TERMIN ZZZ ;BITS SPECIFYING VALID ^P CODES EXPUNGE ZZZ ;NOTE: H, I, AND V NOT VALID HERE! ;2 ARG CASE WITH NON-FIXNUM AS FIRST ARG CRSR11: JUMPE A,CRSR20 JSP T,SPATOM JRST CRSR12 PUSHJ P,CRSR40 JSP T,FXNV2 SKIPGE D SETZ D, CAIE TT,"H CAIN TT,"V JRST CRSR13 CAIN TT,"I JRST CRSR14 CRSR12: WTA [BAD CURSOR CODE - CURSORPOS!] JRST CRSR11 CRSR13: CAILE D,167 MOVEI D,167 IT$ ADDI D,10 ;H AND V RANDOMLY WANT 10 ADDED CRSR14: MOVSI D,400000(D) .SEE CNPCD1 ;KEEP LH FROM BEING ZERO HRRI D,(TT) JRST CRSRP7 ;0 ARGS CASE CRSRP1: PUSHJ P,FORCE1 MOVEI TT,F.MODE MOVE F,@TTSAR(AR1) MOVEI TT,F.CHAN IT% JRST FALSE 20$ WARN [CURSORPOS FOR "V" AND "H" ??] IFN ITS,[ .CALL RCPOS ;GET CURRENT CURSOR POSITION .LOSE 1400 TLNE F,FBT ;GET ECHO MODE POSITION MOVE D,R ; IF FILE IS FOR ECHO AREA MOVEI TT,(D) ;CONS THEM UP FOR LOSER JSP T,FIX1A MOVEI B,(A) HLRZ TT,D JSP T,FIX1A JRST CONS ] ;END OF IFN ITS CRSRMP: PUSH FXP,T CRSRM1: HLRZ A,@(P) MOVE T,(FXP) MOVEI TT,(T) ADDI TT,(P) PUSH P,1(TT) TRNE T,1 PUSH P,2(TT) PUSH P,A PUSHJ P,CRSRPS HRRZ A,@(P) MOVEM A,(P) JUMPN A,CRSRM1 POP FXP,T CRSRN: MOVEI A,TRUTH JRST PROGN1 ] ;END OF IFN USELESS SUBTTL RANDOM ROUTINES TO HANDLE A PSEUDO ALIST %%FUNCTION: MOVEI D,Q%%FUNCTION JUMPE A,WNAFOSE HRRZ C,(A) JUMPN C,.FUNC1 HLRZ B,(A) ;HALF-ASSED FUNARG BINDING HRROI TT,(SP) ;ONE LH AS GOOD AS ANOTHER JSP T,FIX1A PUSHJ P,XCONS .FUNC4: MOVEI B,QFUNARG JRST XCONS .FUNC1: HLRZ AR2A,(A) HLRZ AR1,(C) HRRZ C,(C) JUMPN C,WNAFOSE .FUNC2: JUMPE AR1,.FUNC3 HLRZ A,(AR1) JSP T,SPATOM JSP T,PNGE1 HLRZ B,(A) HLRZ B,@(B) PUSHJ P,CONS MOVEI B,(C) PUSHJ P,CONS HRRZ AR1,(AR1) JRST .FUNC2 .FUNC3: MOVEI A,(C) MOVEI B,TRUTH PUSHJ P,NRECONC MOVEI B,(AR2A) PUSHJ P,CONS JRST .FUNC4 AEVAL: SKIPE A,(P) ;PURPOSELY CRIPPLING POWER OF ALIST JSP T,FXNV1 ; ROUTINE: FOOEY! - GLS PUSHJ P,ALIST ;EVAL WITH AN ALIST SUB P,R70+1 POP P,A SKIPE T ;ALIST RETURNING NON-ZERO IN T => PUSH P,CAUNBIND ; TWO BIND BLOCKS WERE PUSHED PUSH P,CAUNBIND POPJ FXP, ;;; ALIST CREATES AN ENVIRONMENT AS SPECIFIED BY A GIVEN A-LIST. ;;; AN A-LIST MAY BE: ;;; [1] NIL, MEANING THE TOP-LEVEL ENVIRONMENT. ;;; [2] T, MEANING THE CURRENT ENVIRONMENT (SEE [4]). ;;; [3] A FIXNUM REPRESENTING A SPECPDL POINTER, AS ;;; RETURNED BY THE EVALFRAME FUNCTION AS THE FOURTH ;;; ITEM. THIS INDICATES THE ENVIRONMENT AS OF ;;; THE SPECIFIED FRAME. ;;; [4] (( . ) . ) ;;; THAT IS, ONTO ONE OF THE OTHER THREE KINDS OF A-LIST ;;; ONE MAY CONS ADDITIONAL VARIABLE-VALUE PAIRS IN ;;; THE USUAL MANNER. THIS IS A "TRUE A-LIST". ;;; THIS ENVIRONMENT IS CREATED BY REBINDING ALL VARIABLES ;;; WHICH HAVE BEEN BOUND SINCE THEN BACK TO THEIR OLD VALUES, ;;; OR TO THE VALUES SPECIFIED BY THE TRUE A-LIST. IF A GIVEN ;;; VARIABLE WAS BOUND SEVERAL TIMES, ONLY ONE REBINDING IS DONE ;;; TO RECREATE THE OLD ENVIRONMENT. THIS IS DONE BY USING THE ;;; LEFT HALF OF A VALUE CELL TO INDICATE WHETHER OR NOT IT ;;; HAS ALREADY BEEN REBOUND. THIS HAS THE CONSEQUENCE THAT ;;; NOQUIT MUST BE TURNED ON DURING THIS OPERATION. ;;; EITHER ONE OR TWO SPECPDL BLOCKS ARE PUSHED, THE SECOND ONE ;;; BEING NECESSARY IF ANY TRUE A-LIST IS GIVEN. THERE ARE FOUR ;;; STEPS TO THE PROCESS: ;;; [1] CHECK ARGUMENT THOROUGHLY FOR ERRORS. IF A TRUE ;;; A-LIST IS GIVEN, ALL SYMBOLS ON THE A-LIST ARE GIVEN ;;; VALUE CELLS IF THEY DON'T HAVE ANY ALREADY. ;;; [2] TURN ON NOQUIT. IF A TRUE A-LIST IS GIVEN, BIND ALL ;;; THE SYMBOLS AS SPECIFIED, MARKING THE VALUE CELLS ;;; AS THEY ARE BOUND, AND NEVER BINDING A SYMBOL TWICE. ;;; WHEN DONE, PUSH THE TRUE A-LIST ONTO THE SPECPDL ;;; SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY. ;;; [3] SCAN THE SPECPDL FROM THE POINT SPECIFIED BY THE ;;; SPECPDL POINTER (FROM THE BOTTOM IF NIL), AND BIND ;;; ALL VALUES CELLS SEEN BACK TO THEIR OLD VALUES, ;;; MARKING THEM AS THEY ARE BOUND, NEVER BINDING ONE ;;; TWICE. WHEN DONE, PUSH A POINTER ON THE SPECPDL ;;; SO THAT AUNBIND CAN RESTORE THINGS CORRECTLY. ;;; [4] SCAN BACK OVER ALL THE ITEMS PUSHED IN STEPS 2 ;;; AND 3, RESTORING THE LEFT HALVES OF ALL THE VALUE ;;; CELLS. TURN OFF NOQUIT AND CHECK FOR INTERRUPTS. ;;; ON RETURN, A-LIST LEAVES T NON-ZERO IFF TWO BIND BLOCKS ;;; WERE PUSHED. IT IS UP TO THE CALLER TO MAKE SURE THAT THE ;;; BLOCK(S) ARE UNBOUND CORRECTLY WITH AUNBIND. ;;; NOTE THAT ERRPOP CAN RECOGNIZE THESE SPECIAL BIND BLOCKS AND ;;; CALL AUNBIND TO UNBIND THEM. THIS IS BECAUSE THE LAST WORD ;;; PUSHED HAS ZERO IN THE LEFT HALF. ALIST: SKIPN C,-1(P) ;MAKE COPY OF ENVIRONMENT GIVEN A-LIST ALST1: JUMPE C,ALST3 ;STEP 1 - ERROR CHECKING CAIN C,TRUTH JRST ALST3 ;T AND NIL ARE VALID A-LISTS SKOTT C,LS JRST ALST2 ;NOPE - GO CHECK IT OUT HLRZ AR1,(C) ;YUP - CHECK ITS CAR HRRZ C,(C) SKOTT AR1,LS JRST ALST0 HLRZ A,(AR1) SKOTT A,SY JRST ALST0 CAIN A,TRUTH JRST ALST0 HLRZ AR1,(A) HRRZ B,(AR1) MOVEI AR1,QUNBOUND CAIN B,SUNBOUND JSP T,.SET1 JRST ALST1 ALST2: TLNN TT,FX ; - DARN WELL BETTER BE A FIXNUM JRST ALST0 HRRZ TT,(C) ;MUST BE A VALID SPECPDL POINTER CAML TT,ZSC2 CAILE TT,(SP) JRST ALST0 ALST3: HLLOS NOQUIT ;TURN ON NOQUIT - MUSTN'T INTERRUPT HLLOS MUNGP ;ABOUT TO MUNG VALUE CELLS! MOVEM SP,SPSV ;STEP 2 - PUSH BLOCK FOR TRUE A-LIST SETZ T, ;T WILL BECOME NON-ZERO IF TRUE SKIPN C,-1(P) ; A-LIST IS PRESENT AT ALL ALST3A: JUMPE C,ALST4 ;NIL FOUND CAIN C,TRUTH JRST ALST7 ;T FOUND SKOTT C,LS JRST ALST4A ;FIXNUM FOUND HLRZ B,(C) HRRZ C,(C) HLRZ A,(B) ;A HAS ATOMIC SYMBOL HRRZ AR1,(B) ;AR1 HAS ASSOCIATED VALUE HLRZ B,(A) HRRZ A,(B) SKIPGE AR2A,(A) ;SKIP UNLESS VALUE CELL MARKED JRST ALST3A ;VALUE CELL ALREADY REBOUND HRLI AR2A,(A) ;PUSH PUSH SP,AR2A ; ONTO SPECPDL; THEN INSTALL HRROM AR1,(A) ; VALUE FROM ENVIRONMENT, MARKING CELL AOJA T,ALST3A ;T NON-ZERO => WE PUSHED SOMETHING ALST4: MOVEI C,SC2 ;NIL => TOP LEVEL ENVIRONMENT ALST4A: HRRZ C,(C) ;FIXNUM => SPECIFIED ENVIRONMENT HRRZ B,SPSV JUMPE T,ALST4C ;IF ANYTHING PUSHED, START NEW BLOCK PUSH SP,-1(P) ;LEFT HALF BETTER BE ZERO! PUSH SP,SPSV ;FINISH OFF BLOCK FOR TRUE A-LIST MOVEM SP,SPSV ;START NEW BLOCK FOR FUNARG POINTER ALST4C: MOVEI TT,(C) ;STEP 3 - SCAN SPECPDL FROM ENVIRONMENT ALST5: CAIN TT,(B) ; BACK UP TO POINT WHEN ALIST CALLED JRST ALST6 HRRZ AR1,(TT) ;GET VALUE FROM SPECPDL CAMGE AR1,ZSC2 ;IGNORE SPECPDL POINTERS JRST ALST5A CAIGE AR1,(SP) AOJA TT,ALST5 ALST5A: HLRZ A,(TT) ;GET VALUE CELL FROM SLOT JUMPE A,AL5AB ;IGNORE FROBS ALIST PUSHES! SKIPGE AR2A,(A) ;IGNORE MARKED VALUE CELLS AL5AB: AOJA TT,ALST5 HRLI AR2A,(A) ;ELSE PUSH AS BEFORE PUSH SP,AR2A HRROM AR1,(A) AOJA TT,ALST5 ALST7: HRRZ C,-1(P) ;T => CURRENT ENVIRONMENT SETZ T, ;ONLY ONE BLOCK PUSHED HRRZ B,SPSV ALST6: PUSH SP,C ;STEP 4 - RESTORE VALUE CELLS ALST6A: CAIN B,(SP) JRST ALST7A HLRZ A,(B) JUMPE A,ALST6B CAMGE A,ZSC2 HRRZS (A) ALST6B: AOJA B,ALST6A ALST7A: PUSH SP,SPSV ;CLOSE BIND BLOCK HLLZS MUNGP ;VALUE CELLS UNMUNGED JRST CZECHI ;ALL DONE - CHECK INTERRUPTS ;;; AUNBIND UNDOES A FUNARG BIND BLOCK PUSHED BY ALIST. ;;; IT DOES SO BY SCANNING UP THE SPECPDL FROM THE POINT OF ;;; THE FUNARG ENVIRONMENT, OR BY SCANNING DOWN THE TRUE A-LIST, ;;; CLOBBERING CURRENT VALUES FROM VALUE CELLS INTO SPECPDL ;;; SLOTS OR A-LIST SLOTS AS APPROPRIATE, SO THAT ANY SETQ'S ;;; DONE IN THE CREATED COPY OF THE ENVIRONMENT WILL BE ;;; REFLECTED IN THE ORIGINAL ENVIRONMENT. AUNBIND: POP SP,T AUNBN0: MOVEM TT,UNBND3 MOVEM D,AUNBD MOVEM R,AUNBR MOVEM F,AUNBF MOVEI F,1(T) HRRZ R,(SP) CAMGE R,ZSC2 JRST AUNBN4 AUNBN1: CAIN F,(SP) ;CLOBBER SETQ'S BACK INTO SPECPDL JRST AUNBN3 HLRZ D,(F) AUNBN2: HLRZ TT,(R) CAIE TT,(D) AOJA R,AUNBN2 HRRZ TT,(TT) HRRM TT,(R) AOJA F,AUNBN1 AUNBN3: MOVE F,AUNBF MOVE R,AUNBR MOVE D,AUNBD SUB SP,R70+1 JRST UNBND0 AUNBN4: ;CLOBBER SETQ'S BACK INTO TRUE A-LIST AUNBN5: CAIN F,(SP) JRST AUNBN3 HLRZ D,(F) JRST AUNBN7 AUNBN6: HRRZ R,(R) AUNBN7: HLRZ TT,(R) HLRZ TT,(TT) HLRZ TT,(TT) HRRZ TT,(TT) CAIE TT,(D) JRST AUNBN6 HLRZ TT,(R) HRRZ D,(D) HRRM D,(TT) AOJA F,AUNBN5 IAP4A: MOVEM TT,R ;AT THIS POINT, WE MAKE UP AN HRROI TT,(SP) JSP T,FIX1A PUSH P,A MOVE TT,R MOVNI R,2 MOVNI T,1 JRST IAP5 APFNG: HRRZ A,(B) ;APPLY FUNARG HLRZ B,(B) HRRM B,(C) PUSH P,A MOVEM T,APFNG1 PUSHJ P,ALIST PUSH P,. HRROI TT,-2(P) MOVE D,APFNG1 POP TT,2(TT) AOJLE D,.-1 CAUNBIND: MOVEI D,AUNBIND MOVEM D,2(TT) SKIPN T MOVEI D,CPOPJ MOVEM D,1(TT) MOVE T,APFNG1 JRST IAPPLY APLBL: HLRZ A,(B) HRRZ B,(B) HLRZ AR1,(B) MOVEM AR1,(C) MOVEM SP,SPSV ;APPLY LABEL EXPRESSION PUSHJ P,BIND PUSHJ P,ABIND3 MOVEI A,APLBL1 EXCH A,-1(C) HLLM A,-1(C) PUSH FXP,A JRST IAPPLY APLBL1: PUSHJ P,UNBIND POPJ FXP, SUBTTL LISTIFY, PNPUT, AND PNGET LISTIFY: SKIPN R,ARGLOC JRST LFYER JSP T,FXNV1 ;LISTIFY UP N ARGS FOR AN LSUBR MOVM D,TT CAMLE D,@ARGNUM JRST LFY0 JUMPGE TT,LFY3 ADD R,@ARGNUM SUBI R,(D) LFY3: HRLOI TT,(D) ;SEE HAKMEM (A.I. MEMO 239) ITEM 156 EQVI TT,(R) ;TT GETS <-N-1>,, AOBJP TT,FALSE ;ZERO ARGS PUSH P,R70 MOVEI R,(P) ;T HOLDS LAST POINTER LFY1: MOVE A,(TT) ;GET ARG JSP T,PDLNMK PUSHJ P,NCONS HRRM A,(R) ;CLOBBER ONTO END OF LIST MOVEI R,(A) ;ADVANCE LAST POINTER AOBJN TT,LFY1 JRST POPAJ PNPUT: JUMPE B,SYCONS PUSH P,A SETZM LPNF JRST INTRN1 $PNGET: PUSHJ P,PNGET MOVE C,A JSP T,FXNV2 MOVEI B,0 CAIN TT+1,7 POPJ P, CAIE TT+1,6 LERR [SIXBIT \FEATURE NOT YET IMPLEMENTED - PNGET!\] TDZA D,D $PNG.R: PUSHJ P,CONSFX SETZ TT, MOVE R,[440600,,TT] $PNG3: TLNN D,760000 JRST $PNG.D $PNG3A: TLNN R,740000 JRST $PNG.R $PNG4: ILDB T,D ;GET NEXT ASCII BYTE JUMPE T,$PNGX CAIGE T,140 ;CHECK FOR LOWER-CASE ADDI T,40 ;CONVERT, AND STORE IDPB T,R JRST $PNG3 $PNG.D: JUMPE C,$PNGX HLRZ F,(C) ;CONSTRUCT WORD OF ASCII, AND BPTR THERETO MOVE F,(F) HRRZ C,(C) MOVE D,[440700,,F] JRST $PNG3A $PNGX: JUMPE TT,.+2 PUSHJ P,CONSFX JRST NREVERSE SUBTTL EXAMINE, DEPOSIT, MAKNUM, MUNKAM DEPOSIT: ;FIRST ARG IS FIXNUM ADDRESS, 2ND IS VALUE EXCH A,B JSP T,FXNV2 ;GET ADR INTO TT+1 JSP T,FLTSKP ;GET DATA INTO TT JFCL MOVEM TT,(TT+1) ;PERFORM DEPOSIT JRST TRUE EXAMINE: PUSH P,CFIX1 JSP T,FXNV1 MOVE TT,(TT) POPJ P, MAKNUM: MOVEI TT,(A) JRST FIX1 MUNKAM: JSP T,FXNV1 MOVEI A,(TT) POPJ P, SUBTTL SLEEP, LISTEN, ALARMCLOCK ;;; (SLEEP ) SLEEPS FOR SECONDS. MAY BE A FIXNUM OR FLONUM. $SLEEP: JSP T,FLTSKP ;SUBR 1 IT% CAIA IT$ JSP T,M30. IT$ FMPR TT,[30.0] JSP T,IFIX IT$ .SLEEP TT, ;SLEEP FOR 30TH'S OF A SECOND 10$ SLEEP TT, ;SLEEP FOR SECONDS IFN D20,[ IMULI TT,1000. SPECPRO INTSLP ;MUST PROTECT THIS IN CASE OF INTERRUPTS MOVE 1,TT ;(A) WE WANT TO ALLOW INTERRUPTS TO GO THROUGH DISMS ;(B) WE MUST BEWARE OF CRUD IN AC 1 XCTPRO SETZ 1, NOPRO ] ;END OF IFN D20 JRST TRUE IFN ITS,[ ALARMCLOCK: EXCH A,B SETO TT, CAIE B,Q$RUNTIME JRST ALCK1 JUMPE A,ALCK3 ;NIL => TURN OFF CLOCK JSP T,FLTSKP ;RUN TIME IN MICROSECONDS, JRST .+2 ; ACCURATE TO 4. USEC JIFFIES JSP T,IFIX ASH TT,-2 ALCK3: .SUSET [.SRTMR,,TT] ALCK4: JUMPL TT,FALSE JRST TRUE ALCK1: CAIE B,Q$TIME JRST ALCK0 JUMPE A,ALCK5 ;NIL => TURN OFF CLOCK JSP T,FLTSKP ;REAL TIME IN SECONDS, JSP T,M30. ; ACCURATE TO 30TH'S FMPRI TT,(30.0) JSP T,IFIX ASH TT,1 ALCK5: MOVSI R,400000 JUMPL TT,ALCK2 JUMPN TT,ALCK7 MOVEI TT,1 ;IF 0 SPECIFIED, USE 1/30 SECOND ALCK7: MOVE R,[600000,,TT] ALCK2: .REALT R, JRST ALCK4 M30.: IMULI TT,30. ;NOTE: DOUBLE SKIP RETURN JRST 2(T) ] ;END OF IFN ITS SUBTTL REMOB, ARG, SETARG REMOB: JSP T,SPATOM ;SUBR 1 - REMOVE ATOMIC SYMBOL FROM OBARRAY JSP T,PNGE ;ERROR IF ARG NOT A SYMBOL LOCKI PUSHJ P,INTERN JRST REMOB7 REMOB2: LOCKI REMOB7: EXCH A,B ;OBTBL BUCKET # SHOULD BE IN TT MOVE R,TT HRRZ D,VOBARRAY HRRI TT,@TTSAR(D) PUSHJ P,ARYGT4 HLRZ T,(A) CAIN T,(B) JRST REMOB1 REMOB3: MOVE D,A HRRZ A,(A) HLRZ T,(A) CAIE T,(B) JRST REMOB3 HRRZ T,(A) HRRM T,(D) REMOB4: HLRZ TT,(B) ;LEAVE ATOM HEADER IN T HRRZ TT,1(TT) ;LEAVE PNAME LINK IN TT JSP T,GCP8L ;CHECK TO SEE THAT SCOS ARE REMOVED FROM SCO TABLE. SETZB A,B UNLKPOPJ REMOB1: HRRZ A,(A) JSP T,.STOR0 JRST REMOB4 ARG: JUMPE A,ARG3 ;SUBR 1 - FETCH LSUBR ARGUMENT ARGXX: JSP R,ARGCOM HRRZ A,(D) JRST PDLNKJ ARG3: SKIPN ARGLOC ;(ARG NIL) RETURNS NUMBER OF LSUBR ARGUMENTS JRST ARGCM1 HRRZ A,ARGNUM JRST PDLNKJ SETARG: JSP R,ARGCOM ;SUBR 2 - SET LSUBR ARGUMENT MOVE A,B JSP T,PDLNMK HRRM A,(D) POPJ P, ARGCOM: SKIPN D,ARGLOC JRST ARGCM0 JSP T,FXNV1 JUMPLE TT,ARGCM8 CAMLE TT,@ARGNUM JRST ARGCM8 ADD D,TT JRST (R) SUBTTL P.$X AND FRIENDS 10% DEPURE: JSR POFF ;DEPURIFY A PAGE 10% REPURE: JSR POFF ;REPURIFY A PAGE SBSYM: JSR POFF ;FIND SUBR NAME (ADR IN RH OF .) VCLSYM: JSR POFF ;FIND ATOM FOR VC (ADR IN LH OF .) VCSYM: JSR POFF ;FIND ATOM FOR VALUE CELL TLSYM: JSR POFF ;PRINT ST ENTRY OF LEFT HALF OF A CELL TSYM: JSR POFF ;ST ENTRY OF RIGHT HALF PLSYM: JSR POFF ;PRINT LEFT HALF OF A CELL PSYM: JSR POFF ;PRINT RIGHT HALF OF A CELL POF: JSR POFF ;PRINT ARG (POINTER AT LOC 40) TOF: JSR POFF ;ST ENTRY OF ARG (POINTER IN 40) IT$ P%OFF: JSR POFF ;FOR % TYPEOUT MODE IN DDT 10% PPTBL: JSR POFF ;PRINT OUT PURTBL 10% PPPAG: JSR POFF ;PRINT OUT ACTUAL PAGE STATUSES ;POFF: 0 PSYM1: SETOM PSYMF MOVEM T,PSMTS ;P.$X, DONE IN DDT, MOVEM R,PSMRS ; WILL PRINT CONTENTS MOVEI T,LPSMTB ; OF CURRENT OPEN CELL MOVE R,@PSMTB-1(T) ; IN LISP FORMAT. MOVEM R,PSMS-1(T) SOJN T,.-2 IFE ITS,[ 10$ HRRZ T,.JBDDT" 10$ HRRZ T,@6(T) ;WHAT A KLUDGE! 6?!! 20$ MOVEI T,60 ;TERRIBLE KLUDGE! 60 10$ CAIG R,POF MOVEM T,PS.S ] ;END OF IFE ITS HRRZ T,POFF 10% CAIG T,REPURE+1 10% JRST PUFY PUSH P,CPSYMX JSP T,ERSTP MOVEM P,ERRTN HRRZ R,POFF IFN ITS,[ MOVEI T,40 MOVEM T,PS.S MOVEI T,THIRTY+7 CAIN R,P%OFF+1 MOVEM T,PS.S CAIG R,POF .BREAK 12,PSMST ] ;END OF IFN ITS JSP T,SPECBIND TTYOFF TAPWRT V.RSET 10% V.NOPOINT ;FOR PPTBL IFN USELESS, SETZM TYOSW HRRZ AR1,V%TYO ;UPDATE OUR NOTION OF THE PUSHJ P,TTYBR1 ; LINENUM AND CHARPOS OF THE TTY, MOVEI TT,AT.LNN ; SINCE DDT HAS SCREWED IT ALL UP. HLRZM D,@TTSAR(AR1) MOVEI TT,AT.CHS HRRZM D,@TTSAR(AR1) ;;; FALLS THRU ;;; FALLS IN HRRZ T,POFF 10% CAIL T,PPTBL+1 10% JRST PPTBL1 MOVE T,PSMTS ;AT THIS POINT ALL ACS WILL HAVE BEEN MOVE R,PSMRS ; RESTORED SO THAT MOVE A,@ WILL WORK. MOVE A,PSMS MOVE AR1,PSMS+AR1-A MOVE A,@PS.S ;THUS THIS STUFF WORKS IF . IS AN AC. HRRZ T,POFF IT$ CAIN T,P%OFF+1 IT$ JRST PSYMP1 CAIN T,POF+1 MOVEI T,PSYM+1 CAIN T,TOF+1 MOVEI T,TSYM+1 SUBI T,SBSYM TRNE T,1 TLZA A,-1 HLRZS A LSH T,-1 JRST .+1(T) JRST PSYMSB ;SB.$X JRST PSYMVC ;VC.$X AND VCL.$X JRST PSYMT ;T.$X AND TL.$X AND TP FOO$X PSYMP: PUSHJ P,PRIN1 ;P.$X AND PL.$X AND PP FOO$X PSYMQ: MOVEI A,TRUTH ;RETURN POINT TO GET OUT OF PSYM1 JRST ERR2 PSYMX: MOVEI T,LPSMTB MOVE R,PSMS-1(T) MOVEM R,@PSMTB-1(T) SOJN T,.-2 MOVE T,PSMTS MOVE R,PSMRS SETZM PSYMF CPSYMX: POPJ P,PSYMX IFN ITS,[ PSYMP1: TLNN A,-1 ;LISP MODE TYPEOUT - HACK TWO HALVES JRST PSYMP PUSH P,A HLRZ A,A PUSHJ P,PRIN1 MOVEI A,", ;SEPARATE HALVES WITH ",," REPEAT 2, PUSHJ P,TYO POP P,A TLZ A,-1 JRST PSYMP ] ;END OF IFN ITS PSYMSB: MOVEI B,(A) PUSHJ P,ERRADR ;ERRADR DOES ALL THE DIRTY WORK! JRST PSYMQ FCN.B: SKIPE NOQUIT ;FAKE CONTROL-B INTERRUPT FROM DDT POPJ P, SKIPGE INTFLG POPJ P, ;;; FALLS THRU ;;; FALLS IN PUSH FXP,D MOVE D,INHIBIT ;CROCK SO THAT A .5LOCKI AOJE D,POPXDJ ; WON'T STOP US PUSH FXP,INHIBIT SETZM INHIBIT MOVE D,[TTYIFA,,400000+^B] PUSHJ P,UINT POP FXP,INHIBIT POP FXP,D POPJ P, TOF1: SKIPA T,[TOF] POF1: MOVEI T,POF PUSH P,UUOH EXCH T,UUTSV JRST @UUTSV PSYMVC: MOVEI T,(A) MOVEI A,QUNBOUND CAIN T,SUNBOUND JRST PSYMP SKOTT T,LS JRST PSVC1 JSP R,GCGEN PSVC2 PSVC1: MOVEI A,QM JRST PSYMP PSVC2: HLRZ A,(D) HLRZ B,(A) HRRZ A,(B) CAIN A,(T) JRST PSVC3 HRRZ D,(D) JUMPN D,PSVC2 JRST GCP8A PSVC3: HLRZ A,(D) JRST PSYMP IFE D10,[ PUFY: IT$ .BREAK 12,PSMST MOVEI TT,@PS.S ;PURIFY THE PAGE THAT . IS ON MOVE TT+1,TT ;USED BY DPX AND RPX MOVEI C,-REPURE(T) JSP R,IP0 JRST PSYMX ] ;END OF IFE D10 ;;; TABLE OF CELLS TO SAVE OVER THE PSYM FUNCTIONS ZZ==. ;BE SURE TO SEE PSMS IF YOU CHANGE THIS TABLE PSMTB: ;ACCUMULATOR A MUST BE THE FIRST ITEM, AND AR1 THE FOURTH IRP FOO,,[A,B,C,AR1,AR2A,TT,D,F,40,UUOH,UUTSV,UUTTSV,UURSV,ERBDF,FPTEM] FOO TERMIN IFN USELESS,[ PRINLV TYOSW ABBRSW ] ;END OF IFN USELESS LPSMTB==.-ZZ ;FPTEM AND PCNT ARE SAME LOCATION IT$ PSMST: 4,,PS.S-1 ;READ VALUE OF . FROM DDT WITH .BREAK 12, ; PP - A UUO ;PP IS FOR PRINTING OUT AN ADDRESS AS AN S-EXPRESSION: ;PP 34722$X IN DDT WILL PRINT OUT 34722 AS A ; POINTER IN LIST FORMAT. ; TP - A UUO ;TP IS LIKE PP BUT NICELY PRINTS ST ENTRY FOR ; THAT CELL P.=PUSHJ P,PSYM ;P.$X IS LIKE PP FOO$X WHERE FOO IS RH OF. PL.=PUSHJ P,PLSYM ;LIKE P., BUT FOR LH OF CURRENT CELL IT$ P%=PUSHJ P,P%OFF ;LIKE P., BUT AS A DDT TYPEOUT MODE VC.=PUSHJ P,VCSYM ;FIND NAME OF VALUE CELL RH OF . ADDRESSES VCL.=PUSHJ P,VCLSYM ;A CROSS BETWEEN VC. AND PL. T.=PUSHJ P,TSYM ;A CROSS BETWEEN P. AND TP TL.=PUSHJ P,TLSYM ;A CROSS BETWEEN PL. AND TP SB.=PUSHJ P,SBSYM ;FIND NAME OF SUBR ADDRESSED BY RH OF . 10% TBLPUR=PUSHJ P,PPTBL ;PRINT OUT PURTBL IN NICE FORM 10% PAGPUR=PUSHJ P,PPPAG ;PRINT OUT ACTUAL STATUS OF PAGES BB=PUSHJ P,FCN.B ;FAKE CONTROL-B INTERRUPT FROM DDT IT$ DP=PUSHJ P,DEPURE ;DEPURIFY PAGE . IS ON IT$ RP=PUSHJ P,REPURE ;REPURIFY PAGE . IS ON ; ENDCODE [P.$X] SUBTTL T.$X AND TBLPUR$X STUFF PSYMT: PUSHJ P,ITERPRI ;T.$X TYPEOUT, ETC. MOVEI TT,(A) ROT TT,-SEGLOG MOVE TT,ST(TT) SETZB T,C MOVNI R,22 PSYMT1: LSHC T,1 TRZN T,1 JRST PSYMT3 MOVEI A,"+ TROE C,1 PUSHJ P,TYO MOVEI B,PSYMTT+22(R) CAIL B,PSYMTT+PSYMTL MOVEI B,[ASCII \??\] HRLI B,440700 PSYMT2: ILDB A,B JUMPE A,PSYMT3 PUSHJ P,TYO JRST PSYMT2 PSYMT3: AOJL R,PSYMT1 MOVEI A,", REPEAT 2, PUSHJ P,TYO HLRZ A,TT PUSHJ P,PRINC JRST PSYMQ .SEE LS ;THIS TABLE SHOULD BE KEPT CONSISTENT .SEE ST ; WITH TWO OTHER PLACES PSYMTT: IRP TP,,[LS,$FS,FX,FL,BN,SY,SA,VC,$PDLNM,??,$XM,$NXM,PUR,HNK,DB,CX,DX] ASCII \TP\ TERMIN PSYMTL==.-PSYMTT IFN ITS+D20,[ PPTBL1: MOVEI F,-PPTBL-1(T) ;0 => TBLPUR$X, 1 => PAGPUR$X JSP T,0PUSH-5 MOVE R,[440200,,PURTBL] MOVEI T,1 PPTBL2: MOVEM T,-4(FXP) ILDB TT,R JUMPE F,PPTBL6 IFN ITS,[ .CALL PPTBL8 .VALUE ASH TT,-41 TRZ TT,1 SKIPGE TT MOVEI TT,1 ;0=NONX, 1=IMPURE, 2=PURE ] ;END OF IFN ITS IFN D20,[ MOVEI 1,-1(T) HRLI 1,.FHSLF RPACS SETZ TT, TLNN 2,(PA%PEX) JRST PPTBL6 AND 2,[PA%RD+PA%WT+PA%EX+PA%CPY] MOVEI TT,1 TLNN 2,(PA%WT) SKIPA TT,[2] MOVEI TT,1 ] ;END OF IFN D20 PPTBL6: MOVEI A,(FXP) SUBI A,(TT) AOS (A) MOVEI A,"0(TT) PUSHJ P,TYO MOVE T,-4(FXP) TRNE T,7 AOJA T,PPTBL2 TRNN T,30 JRST PPTBL3 MOVEI A,40 PUSHJ P,TYO MOVE T,-4(FXP) TRNE T,10 AOJA T,PPTBL2 PUSHJ P,TYO PUSHJ P,TYO JRST PPTBL4 PPTBL3: PUSHJ P,ITERPRI MOVE T,-4(FXP) CAIN T,NPAGS JRST PPTBL5 PPTBL4: TLZ R,770000 MOVE T,-4(FXP) AOJA T,PPTBL2 PPTBL5: MOVEI R,TYO MOVNI TT,4 PPTBL7: EXCH TT,(FXP) ;OKAY, QUUX, IF YOU EVER LOOK AT THIS CODE JUMPE TT,PPTBL9 ; AGAIN YOU SHOULD HANG YOUR HEAD IN SHAME MOVEI A,^I ; FOR EVER HAVING WRITTEN SUCH BARFUCIOUS PUSHJ P,TYO ; KLUDGY MEANDERINGS! JUNE 16, 1979 -JONL- MOVE A,(FXP) ADDI A,"4 PUSHJ P,TYO %NEG% MOVEI C,10. PUSHJ P,PRINI2 POP FXP,TT PPTBL9: AOJL TT,PPTBL7 POPI FXP,1 JRST PSYMQ IFN ITS,[ PPTBL8: SETZ SIXBIT \CORTYP\ 1000,,-1(T) 402000,,TT ] ;END OF IFN ITS ] ;END OF IFN ITS+D20 SUBTTL PURIFYG ROUTINE IFN ITS,[ XPURIFY: ;ENTRY POINT TO SETUP A PURQIX MOVE T,[SIXBIT \PURQIX\];CHANGE SYSFN1 TO BE A PURQIX MOVEM T,SYSFN1 MOVE T,[SIXBIT \DSK\] ;NEW DEVICE NAME MOVEM T,SYSDEV MOVE T,[SIXBIT \LISP\] ;AND FINALLY, NEW SNAME MOVEM T,SYSSNM MOVEI T,FEATEX ;SPLICE 'EXPERIMENTAL' INTO FEATURES LIST MOVEM T,FEATURES ] ;END IFN ITS IFN ITS+D20,[ PURIFY: IFN ITS,[ ;DOESN'T REALLY WORK FOR D10 YET JRST NOTINIT ;CLOBBERED BY INIT TO "SETO AR1," ;SETO AR1, ;FOR PURIFY$G FROM DDT MOVE P,[-LFAKP-1,,FAKP-1] PUSHJ P,FPURF7 PUSHJ P,FPURF2 .VALUE [ASCIZ \:PURIFIED \] JRST .-1 ] ;END OF IFN ITS FPURF2: SETZB TT,PRSGLK ;ZERO PURE SEGMENT AOBJN PTR MOVE R,[NPFFS,,NPFFS+1] ;ZERO PURE FREE STORAGE COUNTERS SETZM NPFFS BLT R,NPFFY2 SETZM LDXLPC ;CLEAR # WORDS FREE SO ALWAYS GRAB NEW SET ; OF SEGMENTS THE FIRST TIME A LINK IS NEEDED ; START NEW LIST OF SEGMENTS SETOM LDXPFG ;SET PURE FLAG 20$ HRLI TT,.FHSLF MOVNI R,NPAGS ;SO STEP THROUGH LOSING PURTBL MOVE D,[440200,,PURTBL] ; TO DECIDE HOW TO MUNG PAGES IPUR1: ILDB T,D ;GET BYTE FOR NEXT PAGE JRST .+1(T) JRST IPUR3 ;0 - DELETE JRST IPUR4 ;1 - IMPURIFY JRST IPUR6 ;2 - PURIFY MOVEI T,NPAGS(R) ;3 - HAIRY STUFF - DECODE FURTHER LSH T,PAGLOG CAMGE T,BPSL ;CODE 3 SHOULD NEVER APPEAR .VALUE ; BELOW BINARY PROGRAM SPACE MOVE F,@VBPORG ;PAGIFY CURRENT VALUE OF ANDI F,PAGMSK ; BPORG DOWNWARD CAIGE T,(F) ;ANY CODE 3 PAGE BELOW THAT CAN JRST IPUR6A ; BE PURIFIED CAMG T,BPSH ;ANY CODE 3 PAGE BETWEEN BPORG JRST IPUR2 ; AND BPSH IS LEFT AS IS CAMG T,HINXM ;ANY PAGE BETWEEN BPSH AND HINXM .VALUE ; DAMN WELL BETTER BE 0!!! HRRZ F,PDLFL1 ;ANYTHING BETWEEN HINXM AND LSH F,PAGLOG ; PDLS MUST BE PURE FREE STORAGE CAIGE T,(F) JRST IPUR6A CAIGE T,BSCRSG ;SCRATCH PAGES ARE IGNORED JUMPL AR1,IPUR3A ;PDL PAGES MAY OR MAY NOT BE FLUSHED, DEPENDING ON AR1 IPUR2: IT$ ADDI TT,1001 20$ ADDI TT,1 TLNN D,730000 ;ONLY 20 2-BIT BYTES PER WORD, NOT 22 TLZ D,770000 AOJL R,IPUR1 20$ SETZB B,C ;ZERO OUT CRUD MOVEI A,TRUTH JUMPGE AR1,CPOPJ MOVE T,[STDMSK] MOVEM T,IMASK IT$ MOVE T,[STDMS2] IT$ MOVEM T,IMASK2 POPJ P, ;;; IFN ITS+D20 ;;; VARIOUS PAGE FLUSHING AND PURIFYING ROUTINES FOR PURIFY IPUR4: ;MAKE PAGE WRITABLE IFN ITS,[ .CALL IPUR9 ;CHECK TYPE OF PAGE .VALUE JUMPL T,IPUR2 ;ALREADY IMPURE IOR TT,[4400,,400000] JUMPG T,IPUR5 .CBLK TT, ;NON-EXISTENT - GET A FRESH PAGE .VALUE JRST IPUR2 IPUR5: TLZ TT,4000 ;PURE - TRY TO DEPURIFY .CBLK TT, JSP F,IP1 ;IF WE LOSE, TRY COPYING JRST IPUR2 IPUR9: SETZ SIXBIT \CORTYP\ 1000,,400(R) 402000,,T ] ;END OF IFN ITS IFN D20,[ MOVE 1,TT JSP T,IPURE$ ;MAKE SURE PAGE EXISTS TLZ 2,-1#(PA%RD+PA%WT+PA%EX+PA%CPY) TLNE 2,(PA%WT) ;SKIP IF NOT ALREADY WRITEABLE JRST IPUR2 TLON 2,(PA%CPY) ;SKIP IF ALREADY COPYABLE SPACS JRST IPUR2 ;ARG IN A IS PAGE NUMBER. PRESERVE A,TT,D,R ;MAKE SURE PAGE EXISTS. IF NOT, CREATE SOME 0'S ;LEAVE RESULT OF RPACS IN B, AND PUT .FHSLF IN LH OF A IPURE$: HRLI A,.FHSLF RPACS TLNE B,(PA%PEX) JRST (T) HRL T,A ;SAVE PAGE NUMBER IN LH OF T MOVE F,B ;SAVE RPACS CALL IN F MOVSI B,.FHSLF ;SOURCE PAGE IS 0, WHICH MUST EXIST EXCH A,B MOVSI C,(PM%RD+PM%CPY) PMAP ;MAKE FOOOLISH PAGE EXIST LSH B,9 ; [WHICH PROBABLY GOT LOST BY HRLI B,1(B) ; THE "SAVE" COMMAND] BY COPYING MOVEI C,777(B) ; THE FIRST PAGE OF THE JOB SETZM (B) MOVSS B BLT B,(C) ;FOO! A PAGE OF 0'S MOVE B,F HLR A,T HRLI 1,.FHSLF JRST (T) ] ;END OF IFN D20 ;MAKE PAGE READ-ONLY IPUR6A: MOVEI T,2 ;CHANGE PURTBL ENTRY TO 2 DPB T,D IPUR6: IFN ITS,[ .CALL IPUR9 ;CHECK TYPE OF PAGE .VALUE JUMPG T,IPUR2 ;ALREADY PURE JUMPE T,IPUR7 ;CAN'T PURIFY A NON-EXISTENT PAGE TLZ TT,4400 ;PURIFY AN IMPURE PAGE TRO TT,400000 .CBLK TT, IPUR7: .VALUE JRST IPUR2 ] ;END OF IFN ITS IFN D20,[ MOVE 1,TT JSP T,IPURE$ ;MAKE SURE PAGE EXISTS TLZ 2,-1#(PA%RD+PA%WT+PA%EX+PA%CPY) TLZE 2,(PA%WT+PA%CPY) ;ALREADY READ-ONLY? SPACS JRST IPUR2 ] ;END OF IFN D20 ;DELETE A PAGE IPUR3A: SKIPE NOPFLS ;NOPFLS NON-ZERO => DON'T FLUSH PAGES JRST IPUR2 DPB NIL,D ;ZERO OUT PURTBL ENTRY IPUR3: IFN ITS,[ TRZ TT,400000 .CBLK TT, .VALUE ] ;END OF IFN ITS IFN D20,[ SETO 1, MOVE 2,TT HRLI 2,.FHSLF SETZ 3, PMAP ] ;END OF IFN D20 JRST IPUR2 ] ;END OF IFN ITS+D20 SUBTTL PURE COPY OF THE READ SYNTAX TABLE -1,,0 ;FOR NEWRD WILL POINT TO MACRO CHAR LIST RSXTB2: PUSH P,CFIX1 JSP TT,1DIMF NIL ;SHOULD NEVER ACTUALLY CALL 0 RCT0: IFE NEWRD,[ ;OLD VERSION OF PURE READTABLE IFN SAIL,[ 400500,,0 ;NULL IS IGNORED REPEAT 10, 2,,1+.RPCNT ;SAIL CHARS 500500,,^I ;TAB 500500,,^J 400500,,^K 400500,,^L 500500,,^M ;CR REPEAT 22, 2,,^N+.RPCNT ;SAIL CHARS ] ;END IFN SAIL .ELSE,[ REPEAT 10, 400500,,.RPCNT ;^@ ^A ^B ^C ^D ^E ^F ^G 2,,^H ;^H 500500,,^I ;TAB 400500,,^J ;LINE-FEED 400500,,^K 400500,,^L 500500,,^M ;CARRIAGE-RETURN REPEAT 3, 400500,,^N+.RPCNT ;^N ^O ^P 405540,,QCTRLQ ;^Q 400500,,^R ;^R 405540,,QCTRLS ;^S REPEAT 7, 400500,,^T+.RPCNT ;WORTHLESS 2,,33 ;ALT MODE REPEAT 4, 400500,,^\+.RPCNT ;WORTHLESS ] ;END IFE SAIL 500500,,40 ;SPACE 2,,41 ;! REPEAT 2, 502,,""+.RPCNT ;" # REPEAT 3, 2,,"$+.RPCNT ;$ % & 404500,,QRDQTE ;' 440500,,"( ;( 410500,,") ;) 2,,"* ;* 10,,"+ ;+ 404500,,QI%C%F ;, (INTERNAL-COMMA-FUN) 50,,"- ;- 420700,,". ;. 402500,,"/ ;/ REPEAT 10., 4,,"0+.RPCNT ;DECIMAL DIGITS 2,,": ;: 404540,,QRDSEMI ;; REPEAT 5, 2,,"<+.RPCNT ;< = > ? @ REPEAT 26., 1,,"A+.RPCNT ;ALPHABETIC REPEAT 3, 2,,133+.RPCNT ;SQUARE BRACKTES 22,,"^ ;CARET 62,,"_ ;UNDERSCORE 404500,,QI%B%F ;GRAVE (INTERNAL-BACKQUOTE-FUN) REPEAT 26., 501,,"A+.RPCNT ;SMALL LETTERS 2,,173 ;LEFT BRACE 404500,,QRDVBAR ;VERTICAL BAR REPEAT 2, 2,,175+.RPCNT ;RIGHT BRACE, TILDE 401500,,177 ;RUBOUT IFN .-RCT0-200, WARN [READTABLE LOSSAGE] 402500,,57 ;PSEUDO SLASHIFIER CHARACTER 440500,,50 ;PSEUDO OPEN PARENS 410500,,51 ;PSEUDO CLOSE PARENS 500540,,40 ;PSEUDO SPACE IFN SAIL,[ REPEAT 74, 400500,,204+.RPCNT ;SAIL CONTROLIFIED FUNNY CHARACTERS REPEAT 2, 400500,,300+.RPCNT ;^@ ^A 400500,,302 ;^B REPEAT 5, 400500,,300+.RPCNT ;^C ^D ^E ^F ^G 2,,300+^H ;^H 500500,,300+^I ;TAB 500500,,300+^J ;LINE-FEED 400500,,300+^K 400500,,300+^L 500500,,300+^M ;CARRIAGE-RETURN REPEAT 3, 400500,,300+^N+.RPCNT ;^N ^O ^P 405540,,QCTRLQ ;^Q 400500,,300+^R ;^R 405540,,QCTRLS ;^S REPEAT 7, 400500,,300+^T+.RPCNT ;WORTHLESS 2,,33 ;ALT MODE REPEAT 444, 400500,,300+^\+.RPCNT ;WORTHLESS IFN .-RCT0-1000, WARN [SAIL RCT0 LOSSAGE -- WRONG LENGTH TABLE] ] ;END IFN SAIL ] ;END OF IFE NEWRD ;;; MORE ON NEXT PAGE IFN NEWRD,[ ;NEW VERSION OF PURE READTABLE REPEAT 11, RS.BRK+RS.SL1+RS.SL9 + .RPCNT ;WORTHLESS CONTROL CHARS RS.BRK+RS.SL1+RS.SL9+RS.WSP + ^I ;TAB RS.BRK+RS.SL1+RS.SL9+RS.WSP+RS.VMO + ^J ;LINE-FEED RS.BRK+RS.SL1+RS.SL9 + ^K ;^K (WORTHLESS) RS.BRK+RS.SL1+RS.SL9+RS.VMO + ^L ;^L (WORTHLESS) RS.BRK+RS.SL1+RS.SL9+RS.WSP + ^M ;CARRIAGE-RETURN REPEAT 3, RS.BRK+RS.SL1+RS.SL9 + ^N+.RPCNT ;WORTHLESS RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.FF + ^Q ;^Q (fun is QCTRLQ) RS.BRK+RS.SL1+RS.SL9 + ^R ;^R (WORTHLESS) RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.FF + ^S ;^S (fun is QCTRLS) REPEAT 7, RS.BRK+RS.SL1+RS.SL9 + ^T+.RPCNT ;WORTHLESS RS.XLT + 33 ;ALTMODE REPEAT 4, RS.BRK+RS.SL1+RS.SL9 + 34+.RPCNT ;WORTHLESS RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40 ;SPACE REPEAT 6, RS.XLT + "!+.RPCNT ;! " # $ % & RS.BRK+RS.SL1+RS.SL9+RS.MAC + "' ;SINGLE-QUOTE RS.BRK+RS.SL1+RS.SL9+RS.LP + "( ;LEFT PAREN RS.BRK+RS.SL1+RS.SL9+RS.RP + ") ;RIGHT PAREN RS.XLT + "* ;ASTERISK RS.SL1+RS.SGN + "+ ;PLUS RS.BRK+RS.SL1+RS.SL9+RS.WSP + ", ;COMMA RS.SL1+RS.SGN+RS.ALT + "- ;MINUS RS.BRK+RS.SL1+RS.SL9+RS.DOT+RS.PNT + ". ;DOT RS.BRK+RS.SL1+RS.SL9+RS.SLS + "/ ;SLASH REPEAT 10., RS.SL1+RS.DIG + "0+.RPCNT ;0 - 9 RS.XLT + ": ;COLON RS.BRK+RS.SL1+RS.SL9+RS.MAC+RS.ALT + "; ;SEMI-COLON REPEAT 5, RS.XLT + "< + .RPCNT ;< = > ? @ REPEAT 4, RS.LTR + "A+.RPCNT ;A-D RS.LTR + RS.SQX + "E ;E REPEAT 21., RS.LTR + "F+.RPCNT ;F-Z REPEAT 3, RS.XLT + 133+.RPCNT ;LBRACK BSLASH RBRACK RS.ARR+RS.XLT + "^ ;UP-ARROW RS.ARR+RS.ALT+RS.XLT + #_ ;UNDERSCORE RS.BRK+RS.SL1+RS.SL9+RS.MAC + "` ;BACK-QUOTE REPEAT 4, RS.LTR + "A+.RPCNT ;A-D L.C. RS.LTR+RS.SQX + "E ;E L.C. REPEAT 21., RS.LTR + "F+.RPCNT ;F-Z L.C. REPEAT 4, RS.XLT + "{+.RPCNT ;LBRACE VBAR RBRACE TILDE RS.BRK+RS.SL1+RS.SL9+RS.RBO + 177 ;RUBOUT RS.BRK+RS.SL1+RS.SL9+RS.SLS + "/ ;PSEUDO SLASH RS.BRK+RS.SL1+RS.SL9+RS.LP + "( ;PSEUDO ( RS.BRK+RS.SL1+RS.SL9+RS.RP + ") ;PSEUDO ) RS.BRK+RS.SL1+RS.SL9+RS.WSP + 40 ;PSEUDO SPACE ] ;END OF IFN NEWRD TLRCT==<.-RCT0> SA$ INFORM [READTABLE LENGTH = ]\LRCT ZZ==LRCT-TLRCT IFE NEWRD,[ IFL ZZ-1-2, INFORM READER-TABLE-DEFICIENCY,\<3-ZZ> .ELSE BLOCK ZZ-3 ] ;END OF IFE NEWRD NIL,,NIL ;UNUSED TRUTH,,0 ;(STATUS TTYREAD),,(STATUS ABBREVIATE) NIL,,TRUTH ;(STATUS TERPRI),,(STATUS _) ;;; TTYREAD=NIL => ONLY FORCE FEED CHARS LET READ SEE THE TTY BUFFER ;;; ABBREVIATE: 1.1 => ABBREV FILES, 1.2 => ABBREV FLATSIZE/EXPLODE ;;; THE FOLLOWING, "TERPRI", MAY NO LONGER BE ACTIVE: (11/01/79 - JONL) ;;; TERPRI=T => DO NOT OUTPUT AUTOMATIC NEWLINES ;;; _=T => ALLOW PRIN1/PRINC TO OUTPUT FIXNUMS IN FORM M_N SUBTTL TOP PAGE PGTOP, AND SOME INSRTS MOVEI 1,[.] ;THIS WASTEFUL HAC IS MERELY TO INSURE THAT THE LAST MOVEI 2,[.] ;FEW CONSTANTS ON THIS PART ARE WORTHLESS MOVEI 3,[.] ;IN CASE THERE ARE MORE ON PASS2 THAN PASS1 PGTOP TOP,[TOPLEVEL, COMMON, AND RANDOM STUFF] ;;; HERE IS A SUNDER HAC - IT MUST BE ABLE TO FIND ;;; $INSRTNAME;COMMENTS ON FILE ;;@ PRINT 282 PRINT AND FILE-HANDLING FUNCTIONS ;;; ***** MACLISP ****** PRINT AND FILE-HANDLING FUNCTIONS ******* ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** SUBTTL FUNNY PRINTING ROUTINES PGBOT PRT .NOPOINT: PUSHJ P,NOTNOT HRRZM A,V.NOPOINT POPJ P, COMMENT | HERE IS A FINE HACK THAT GOT SUPERSEDED BY CTYP CTY: PUSHJ P,TYOI ;THIS IS ALWAYS DONE BY A XCT "Q,CTY - FOR RANDOM Q. TYOI: PUSH P,A ; USEFUL MAINLY BECAUSE IT SAVES A. WARNING!!! MOVE A,-1(P) ; THIS CODE IS VERY HACKISH, DEPENDENT ON THE OPCODE LDB A,[270600,,-1(A)] ; OF XCT (256). THIS ONLY WORKS FOR ASCII PUSHJ P,(R) ; CHARS IN THE RANGE 40-57. THUS Q MUST BE AMONG JRST POPAJ ; [ !"#$%&'()*+,-./] (THE BRACKETS ARE META-CHARS!) | ;END OF COMMENT ;;; XCT N,CTYP ;;; CAUSES THE N'TH CHARACTER IN TYO1TB TO GET PRINTED VIA ;;; THE ROUTINE IN R. SYMBOLS ARE DEFINED FOR THESE XCT'S. CTYP: PUSHJ P,TYO1C TYO1C: PUSH P,A HRRZ A,-1(P) LDB A,[270400,,-1(A)] MOVE A,TYO1TB(A) PUSHJ P,(R) JRST POPAJ TYO1TB: IRP X,,[#,(,),+,-,.,/,|,:,;, ,_,E,D,,.]Z,,[NMBR,LPAR,RPAR,POS NEG,DOT,SLSH,VBAR,CLN,SEMI,SPC,BAK,E,D,CTLQ,DCML] %!Z!%=XCT .IRPCNT,CTYP "X TERMIN IFG .-TYO1TB-20, WARN [TOO MANY TYO1TB CHARACTERS] SUBTTL NEWIO TYO FUNCTION AND RELATED ROUTINES ;;; CALLED BY FUNCTIONS LIKE PRINT WHICH TAKE AN ARG AND ;;; AN OPTIONAL ASCII OUTPUT FILE ARRAY. DOES ARGS CHECKING ;;; AND SETS UP AR1 WITH THE CORRECT OUTPUT FILE(S). ;;; IF ONE ARG IS GIVEN AND THERE ARE NO FILES TO OUTPUT TO ;;; (^W IS NON-NIL, AND EITHER ^R OR OUTFILES IS NIL), ;;; THEN A POPJ IS DONE, RETURNING FOR THE CALLING FUNCTION. ;;; LEFT HALF BITS IN AR1: ;;; 400000 RH OF AR1 HAS SINGLE FILE ARRAY (ELSE LIST) ;;; 200000 DO *NOT* OUTPUT TO TTY AS WELL ;;; IFN SFA, THEN ALSO PRINT/PRINC/PRIN1/TYO BIT ;;; ;;; CALLED BY: ;;; JSP F,PRNARG ;;; XXX,,[QPRINT] ;ATOM FOR WNA ERROR ;;; -OR- XXX,,[,,QPRINT] ;IFN SFA ;;; XXX IS TYPICALLY JFCL. IF XXX IS NEGATIVE, THE RETURN VALUE ;;; FOR THE FUNCTION IS NIL INSTEAD OF T. PRNARG: AOJN T,PRNAR2 POP P,A PRNAR$: SAVE AR1 AR2A CPNAGX PRNAR0: SKIPE AR1,TAPWRT ;IF ^R NOT SET, USE NIL HRRZ AR1,VOUTFILES ;OTHERWISE USE OUTFILES JUMPN AR1,PRNAR3 SKIPE TTYOFF JRST PRNAR8 PRNAR3: SFA$ HLRZ T,@(F) ;PLACE OPERATIONS FLAG IN AR1 SFA$ TLO AR1,(T) TRNN AR1,-1 SFA$ JRST PRNTTY ;GOING TO THE TTY SFA% JRST 1(F) PUSHJ P,MPFLOK JRST 1(F) PRNAR7: PUSHJ P,OFCAN EXCH A,AR1 PUSHJ P,[IOL [LOSING OUTPUT FILE SPECS!]] EXCH A,AR1 JUMPE T,PRNAR0 JRST PRNAR4 IFN SFA,[ PRNTTY: TLNE AR1,200000 ;REALLY GOING TO THE TTY? JRST 1(F) ;NOPE, SO RETURN MOVSI T,AS.SFA ;IS C(TYO) AN SFA? MOVE R,V%TYO TDNN T,ASAR(R) JRST 1(F) ;NOPE, SO ALL IS OK HLLZ T,@(F) ;SFA OPERATION MASK MOVEI TT,SR.WOM TDNN T,@TTSAR(R) ;CAN THE SFA DO THIS OPERATION DIRECTLY? JRST 1(F) ;NOPE, IT WILL HANDLER A LOWER-LEVEL THING MOVEI C,(A) ;ARG IS THING TO PRINT/PRINC/PRIN1 MOVEI AR1,(R) ;THE SFA JRST ISTCAL ;DO AN INTERNAL SFA CALL ] ;END IFN SFA PRNAR2: CAME T,XC-1 JRST PRNAR9 MOVE A,-1(P) MOVEM AR1,-1(P) EXCH AR2A,(P) PUSH P,CPNAGX SKIPN AR1,AR2A AOJA T,PRNAR0 PRNAR4: JSP T,PRNARK JRST PRNARA ;ERRONEOUS FILE JRST PRNAR6 ;LIST OF SOME KIND SFA$ SKIPA ;NORMAL RETURN SFA$ JRST PRNAR8 ;HANDLED THE SFA PRNAR5: TLO AR1,600000 ;VALID FILE OBJECT HLRZ T,@(F) TLO AR1,(T) JRST 1(F) PRNAR6: TLO AR1,200000 JRST PRNAR3 PRNARA: TLO AR1,200000 ;MAKE ERROR MESSAGE PRINT CORRECTLY JRST PRNAR7 PRNAR8: SKIPGE (F) JRST FALSE JRST TRUE PRNAR9: HRRZ D,@(F) JRST S1WNAL PNAGX: RSTR AR2A AR1 CPNAGX: POPJ P,PNAGX ;;; CHECK LIST OF FILES IN AR1 FOR VALIDITY. ;;; SKIPS ON *FAILURE*. MPFLOK: PUSH P,AR1 ;MUST PRESERVE LH OF AR1 MOVEI AR2A,(AR1) MPFLO1: JUMPE AR2A,MPFLO2 HLRZ AR1,(AR2A) JSP T,PRNARK JRST MPFLO3 ;ERROR JRST MPFLO3 ;LIST (NOT ALLOWED WITHIN ANOTHER LIST) SFA$ SKIPA ;NORMAL SFA$ JFCL ;HANDLED THE SFA HRRZ AR2A,(AR2A) JRST MPFLO1 MPFLO3: AOS -1(P) ;ERROR - SKIP MPFLO2: POP P,AR1 POPJ P, ;;; CHECK OUT OBJECT IN AR1. ;;; SKIP 3 IF AN SFA, AND HANDLED IT ;;; SKIP 2 IF A VALID, OPEN, NON-BINARY, OUTPUT FILE OBJECT. ;;; SKIP 1 IF A LIST (ELEMENTS ARE NOT CHECKED). ;;; SKIP 0 OTHERWISE. PRNARK: CAIN AR1,TRUTH ;ARG CHECK FOR PRNARG HRRZ AR1,V%TYO ;FOR T, ASSUME CONTENTS OF TYO JSP TT,XFOSP ;MUST BE FILE ARRAY OR SFA JRST PRNRK2 IFN SFA,[ JRST PRNRK1 PUSH P,T ;SAVE T MOVEI TT,SR.WOM ;AN SFA HLLZ T,@(F) ;THE APPROPRIATE FUNCTION TDNN T,@TTSAR(AR1) ;CAN THE SFA DO IT? JRST PRNRK3 ;NOPE, RESTORE T AND PROCEED PUSHJ FXP,SAV5 ;SAVE THE 'WORLD' PUSHJ P,SAVX5 MOVEI C,(A) ;ARGUMENT TO SFA PUSHJ P,ISTCAL PUSHJ P,RSTX5 PUSHJ FXP,RST5 POP P,T JRST 3(T) ;TRIPLE-SKIP RETURN PRNRK3: POP P,T JRST 2(T) ;DOUBLE-SKIP RETURN, LOWER-LEVEL WILL HANDLE IT PRNRK1: ] ;END IFN SFA MOVE TT,TTSAR(AR1) TLNE TT,TTS.IO ;MUST BE OUTPUT FILE TLNE TT,TTS ;MUST NOT BE CLOSED, NOR BINARY JRST (T) ;ERROR JRST 2(T) ;SUCCESS - VALID FILE OBJECT PRNRK2: MOVEI TT,(AR1) LSH TT,-SEGLOG SKIPGE ST(TT) JRST 1(T) ;OKAY IF LIST (CALLER USUALLY WILL USE MPFLOK) JRST (T) ;ELSE ERROR IFN SFA,[ ;;; FILE-ARRAY OR LIST IN AR1: IF ZERO USE V%TYO PRTSTO: PUSH P,PRTSO1 ;IN CASE PRTSTR POPJS PUSH FXP,F PUSH FXP,A MOVEI A,(FXP) ;GIVE IT A PDL NUMBER JSP F,PRTSTR ;DO SFA CHECKING [SO.TYO,,] POP FXP,A POPI P,1 PRTSO1: POPJ FXP,.+1 ;RETURN TO CALLER POPI FXP,2 ;HANDLED ALL WE NEEDED TO POPJ P, PRTSTR: JUMPE AR1,PRTST1 ;HANDLE DEFAULT CONDITION SPECIALLY JSP T,PRNARK ;CHECK OUT C(AR1) JFCL ;PROBABLY BAD OUTFILES JRST PRTSTL ;A LIST JRST 1(F) ;A FILE ARRAY OR UNHANDLED SFA POPJ P, ;A HANDLED SFA PRTST1: HRRZ AR1,V%TYO MOVEI TT,SR.WOM ;AN SFA HLLZ T,@(F) ;THE APPROPRIATE FUNCTION TDNN T,@TTSAR(AR1) ;CAN THE SFA DO IT? JRST PRTST2 ;NOPE, RETURN NORMALLY PUSHJ FXP,SAV5 ;SAVE THE 'WORLD' PUSHJ P,SAVX5 MOVEI C,(A) ;ARGUMENT TO SFA PUSHJ P,ISTCAL PUSHJ P,RSTX5 PUSHJ FXP,RST5 POPJ P, ;RETURN PRTST2: SETZ AR1, ;MAKE SURE AR1 IS STILL ZERO JRST 1(F) ;THEN RETURN TO CALLER PRTSTL: PUSHJ P,MPFLOK ;CHECK THE LIST IN AR1 JRST 1(F) ;RETURN IF ALL OK PUSHJ P,OFCAN EXCH A,AR1 PUSHJ P,[IOL [LOSING OUTPUT FILE SPECS!]] EXCH A,AR1 JRST PRTSTR ] ;END IFN SFA TYO$: JSP F,PRNAR$ ;USER'S "*TYO" ENTRY SFA$ [SO.TYO,,QTYO$] SFA% [QTYO$] JRST %TYO1 %TYO: JSP F,PRNARG ;USER'S "TYO" ENTRY SFA% JFCL [Q%TYO] SFA$ JFCL [SO.TYO,,Q%TYO] %TYO1: JSP T,GTRDTB PUSHJ P,TYO1 JRST TRUE TYO: SKIPE AR1,TAPWRT ;ENTRY FOR SINGLE-ENTER INTERNALS HRRZ AR1,VOUTFILES ;TEMP ?? SFA$ JSP F,PRTSTO ;DO SFA CHECKING STUFF $TYO: PUSH FXP,T ;ENTRY FOR PRIN1, PRINC, GC-PRINTOUT, PUSH FXP,TT ; AND MULTIPLE-ENTER INTERNALS PUSH P,[PXTTTJ] JSP T,GTRDTB TYOPR: SKIPA TT,A ;MUST SAVE R FOR PRINT TYO1: JSP F,TYOARG ;AT THIS POINT: CHAR IN TT, FILE(S) IN AR1, READTABLE IN AR2A ;MUST SAVE A,B,C,AR1,R TYO6: .5LKTOPOPJ STRTYO: JUMPGE AR1,TYO5 TLNN AR1,200000 SKIPE TTYOFF JRST TYO6A SKIPLE TYOSW JRST TYO6A PUSH P,AR1 HRR AR1,V%TYO TLZ AR1,600000 PUSHJ P,TYOF POP P,AR1 TYO6A: MOVEI T,(AR1) CAIE T,TRUTH JRST TYO6B HRR AR1,V%TYO ;T MEANS SAME AS VALUE OF TYO, SKIPN TTYOFF ; BUT CAN BE SILENCED BY ^W TYO6B: SKIPGE TYOSW POPJ P, JRST TYOF TYO5: REPEAT 2, PUSH P,AR1 HRRZS -1(P) TLNN AR1,200000 SKIPE TTYOFF JRST TYO2 HRR AR1,V%TYO SKIPG TYOSW PUSHJ P,TYOF TYO2: SKIPL TYOSW TYO2A: SKIPN AR1,-1(P) JRST TYO4 HLRZ AR1,(AR1) CAIN AR1,TRUTH JRST TYO2Z HLL AR1,(P) JRST TYO2B TYO2Z: HRRZ AR1,V%TYO HLL AR1,(P) SKIPN TTYOFF TYO2B: PUSHJ P,TYOF HRRZ AR1,@-1(P) MOVEM AR1,-1(P) JRST TYO2A TYO4: POP P,AR1 ;PRESERVE AR1 JRST POP1J TYOARG: JSP T,FXNV1 IFN SAIL\ITS, TDNN TT,[777777,,770000] ;UP TO 12. BITS OKAY IFE SAIL\ITS, TDNN TT,[777777,,777400] ;UP TO 8 BITS OKAY JRST (F) JRST TYOAGE ;;; TYO ONE CHARACTER TO ONE FILE. MUST PRESERVE AR1,AR2A ;;; USER INTERRUPTS LOCKED OUT. (??) ;;; FILE ARRAY IN AR1. ;;; READTABLE IN AR2A. ;;; CHARACTER IN TT (MUST BE PRESERVED). ;;; TYOF HANDLES ALL CHARPOS, LINENUM, AND PAGENUM PROCESSING, ;;; CONTROL CHARACTERS, SAIL MODE OUTPUT, ETC. ;;; ALL CR'S NOT FOLLOWED BY LF'S HAVE LF'S SUPPLIED FOR THEM. ;;; MUST SAVE R FOR PRINT. TYOFA: MOVE TT,A TYOFIL: .5LKTOPOPJ TYOF: TRNN AR1,-1 JRST TYOFE IFN SFA,[ MOVSI T,AS.SFA ;AN SFA? TDNN T,ASAR(AR1) JRST TYOFS0 ;NOPE PUSHJ FXP,SAV5 ;SAVE THE 'WORLD' PUSHJ P,SAVX5 SKIPGE TT ;DO A CONVERSION ON FORMAT INFO MOVNI TT,(TT) JSP T,FXCONS ;CONS UP A FIXNUM HLLZ T,AR1 ;HAS THIS SFA BEEN HACKED AT A HIGHER LEVEL? TLZ T,600000 ;BITS NOT OF INTEREST TO THE SFA MOVEI TT,SR.WOM TDNE T,@TTSAR(AR1) ;CHECK THE OPERATIONS MASK JRST TYOFS1 ;ALRADY DONE IT, SO RETURN HRRZS INHIBI ;REALLY DIDN'T WANT THAT .5LKTOPOPJ MOVEI C,(A) ;AS THE ARGUMENT TO THE SFA MOVEI B,Q%TYO ;A TYO OPERATION MOVEI A,(AR1) ;THE SFA ITSELF PUSHJ P,ISTCSH ;DO SHORT INTERNAL SFA CALL TYOFS1: PUSHJ FXP,RST5 JRST RSTX5 ;RESTORE ACS AND RETURN TYOFS0: ] ;END IFN SFA MOVE T,TTSAR(AR1) JUMPL TT,TYOF7 ;NEGATIVE => FORMAT INFO SKIPGE ATO.LC(T) PUSHJ P,TYOFXL IT% CAIN TT,177 ;RUBOUT HAS NO PRINT WIDTH IT% JRST TYOF4 CAIN TT,7 ; HAS NO PRINT WIDTH JRST TYOF0G IT$ CAIE TT,177 ;ITS RUBOUT PRINTS AS TWO CHARACTERS CAIGE TT,40 ;CONTROL CHARACTERS HAVE WIDTH JRST TYOF2 ; OF 1 OR 2, OR ELSE ARE FUNNY TYOF0D: AOS D,AT.CHS(T) ;INCREMENT CHARPOS SKIPE ATO.LC(T) ;SKIP UNLESS LAST CHAR WAS / JRST TYOF0G SKIPLE FO.LNL(T) ;ZERO OR NEGATIVE LINEL => INFINITY TLNE T,TTS .SEE STERPRI JRST TYOF0E ;FOR IMAGE OUTPUT, NO EXTRA CHARS CAMLE D,FO.LNL(T) SKIPE V%TERPRI JRST TYOF0E HRLM TT,(P) ;NEW LINE NEEDED BEFORE THIS CHAR MOVEI TT,^M ;BECAUSE OF AUTO-TERPRI PUSHJ P,TYOF4 PUSHJ P,TYOFXL MOVEI TT,1 MOVEM TT,AT.CHS(T) ;SO THIS CHAR WILL BE AT CHARPOS 1 HLRZ TT,(P) TYOF0E: MOVE D,@TTSAR(AR2A) ;GET READTABLE ENTRY FOR THIS TLNE D,2000 .SEE SYNTAX ;IF THIS IS A /, SET FLAG HLLOS ATO.LC(T) ; FOR NEXT TIME AROUND JRST TYOF4 TYOF0G: SETZM ATO.LC(T) ;RESET / FLAG JRST TYOF4 ;OUTPUT CHAR, IGNORING LINEL TYOF2: CAIG TT,^M ;FOUND CONTROL CHAR CAIGE TT,^H JRST TYOF3 ;REGULAR CONTROL CHAR JRST @.+1-^H(TT) ;FORMAT EFFECTOR - PECULIAR TYOFBS ;^H BACKSPACE TYOFTB ;^I TAB TYOFLF ;^J LINE FEED TYOF3 ;^K TYOFFF ;^L FORM FEED TYOFCR ;^M CARRIAGE RETURN TYOFXL: SETZM ATO.LC(T) ;LINE FEED NEEDED BEFORE THIS CHAR CAIE TT,^J ;FORGET IT IF THIS CHAR IS LF TLNE T,TTS ;DON'T GENERATE LF FOR IMAGE FILE POPJ P, HRLM TT,(P) MOVEI TT,^J PUSHJ P,TYOFLF HLRZ TT,(P) POPJ P, TYOFE: EXCH A,AR1 %WTA [SIXBIT \NOT A FILE - TYO!\] TYOF3: CAIN TT,33 ;ALTMODES ARE ALWAYS 1 WIDE JRST TYOF0D MOVE D,F.MODE(T) ;RANDOM CONTROL CHAR IFE SAIL,[ IT$ CAIE TT,177 ;RUBOUT PRINTS TWO POSITIONS EVEN IN SAIL MODE TLNN D,FBT ;SKIP IF SAIL MODE FILE AOS AT.CHS(T) ;OTHERWISE CONTROL CHARS ARE 2 WIDE ] ;END OF IFE SAIL JRST TYOF0D TYOFBS: SKIPLE AT.CHS(T) ;BACKSPACE - UNLESS AGAINST LEFT MARGIN, SOS AT.CHS(T) ; DECREMENT CHARPOS SETZM ATO.LC(T) ;CLEAR / FLAG JRST TYOF4 TYOFTB: MOVEI D,7 ;TAB FOUND - JUMP TO NEXT IORM D,AT.CHS(T) ;MULTIPLE-OF-8 CHARPOS JRST TYOF0D TYOFLF: AOS D,AT.LNN(T) ;INCREMENT LINENUM SKIPLE FO.PGL(T) ;ZERO PAGEL => INFINITY CAMGE D,FO.PGL(T) ;SKIP IF OVER PAGE LENGTH JRST TYOF4 TYOFFF: SETZM AT.LNN(T) ;ZERO LINE NUMBER AOS AT.PGN(T) ;INCREMENT PAGE NUMBER TLNN T,TTS.TY ;IF TTY THEN DON'T GIVE END PAGE INT ON ^L SKIPN FO.EOP(T) ;IF IT HAS AN ENDPAGEFN, THEN JRST TYOF4 ; WANT TO GIVE USER INTERRUPT PUSHJ P,TYOF4 MOVEI D,200000+2*FO.EOP+1 HRLI D,(AR1) JRST UINT TYOF7: SKIPLE FO.LNL(T) ;INFINITE LINEL TLNE T,TTS ; OR IMAGE MODE TTY POPJ P, ; => IGNORE FORMAT DATA SKIPN V%TERPRI SKIPN AT.CHS(T) ;CAN'T DO ANY BETTER THAN TO BE POPJ P, ; AT THE BEGINNING OF A LINE MOVEI D,(TT) ADD D,AT.CHS(T) CAMG D,FO.LNL(T) POPJ P, SETZM AT.CHS(T) PUSH FXP,TT MOVEI TT,^M ;IF TOO LONG, DO AN AUTO-TERPRI PUSHJ P,TYOFCR POP FXP,TT POPJ P, TYOFCR: SETZM AT.CHS(T) ;CR - SET CHARPOS TO ZERO PUSHJ P,TYOF4 SETOM ATO.LC(T) ;SET LF FLAG (MUSTN'T DO UNTIL AFTER IOT POPJ P, ; OF CR BECAUSE A **MORE** MIGHT OCCUR) TYOF4: .SEE PTYO IT$ TLNE T,TTS.TY IT$ JRST TYOF4C TYOF6: TYOF4A: SKIPL F.MODE(T) .SEE FBT.CM JRST TYOF5 IFN ITS,[ MOVE D,F.CHAN(T) ;CHARMODE (UNIT MODE) LSH D,27 ;TYI USES THIS CODE TOO (SAVES F) IOR D,[.IOT TT] SPECPRO INTTYX TYOXCT: XCT D NOPRO ] ;END OF IFN ITS IFN D10,[ SA$ OUTCHR TT IFE SAIL,[ TLNE T,TTS.IM TLNN T,TTS.TY JRST .+3 IONEOU TT ;DO THIS IF IMAGE MODE TTY JRST .+5 CAIE TT,33 ;NON-SAIL MONITORS LOSE ALTMODES OUTCHR TT CAIN TT,33 ;FOR THEM, WE OUTPUT ALTMODE AS $ OUTCHR C$ ; (ON THE TTY ONLY!) ] ;END OF IFE SAIL ] ;END OF IFN D10 IFN D20,[ PUSHJ FXP,SAV2 HRRZ 1,F.JFN(T) MOVEI 2,(TT) BOUT ;OUTPUT THE BYTE ERJMP OIOERR PUSHJ FXP,RST2 ] ;END OF IFN D20 AOS F.FPOS(T) ;ADJUST FILE POSITION (DOESN'T HURT IF F.FLEN NEG) C$: POPJ P,"$ INTTYR: HRROS INHIBIT .SEE $IWAIT ;COME HERE AFTER INTERRUPT MOVE T,TTSAR(AR1) ;FILE ARRAY MAY HAVE MOVED POPJ P, .SEE TYIXCT TYICAL TYOF5: ;BLOCK MODE IFN ITS+D20,[ IDPB TT,FB.BP(T) ;PUT BYTE IN BUFFER SOSLE FB.CNT(T) ;DECREMENT COUNT ] ;END OF IFN ITS+D20 IFN D10,[ MOVE D,FB.HED(T) ;FOR D10, BYTE POINTER AND COUNT ARE IN BUFFER HEADER IDPB TT,1(D) ;PUT BYTE IN BUFFER SOSLE 2(D) ;DECREMENT COUNT ] ;END OF IFN D10 POPJ P, HRLM TT,(P) MOVE TT,T PUSH FXP,F PUSHJ P,IFORCE POP FXP,F HLRZ TT,(P) TYOF5Y: MOVE T,TTSAR(AR1) POPJ P, IFN ITS,[ TYOF4C: TLNN T,TTS.IM ;DO NOT HACK THIS FOR IMAGE MODE CAIE TT,^P ;^P IS THE DISPLAY ESCAPE CODE, AND JRST TYOF4A ; MUST BE TREATED SPECIALLY SKIPGE F.MODE(T) .SEE FBT.CM JRST TYOF4J MOVE TT,FB.CNT(T) ;FOR BLOCK MODE, BE CAREFUL PUSH FXP,F CAIGE T,2 ; ABOUT SPLITTING A ^P-CODE PUSHJ P,IFORCE ; ACROSS A BLOCK BOUNDARY POP FXP,F TYOF4J: MOVE T,TTSAR(AR1) ;OUTPUT ^P AS ^P P MOVEI TT,^P PUSHJ P,TYOF4A MOVE T,TTSAR(AR1) MOVEI TT,"P PUSHJ P,TYOF4A JRST TYOF5Y ] ;END OF IFN ITS SUBTTL TERPRI AND PTYO FUNCTIONS %TERPRI: JUMPN T,.+3 PUSH P,R70 MOVNI T,1 PUSH P,(P) ;EVEN THOUGH LSUBR (0 . 1) SOS T ;PRETEND TO BE (1 . 2) FOR PRNARG'S SAKE JSP F,PRNARG ;PRNARG MAY DO A POPJ FOR US - BEWARE! SFA% 400000,,[Q%TERPRI] ;BIT 4.9 => RETURN VALUE IS NIL SFA$ 400000,,[SO.TRP,,Q%TERPRI] ;BIT 4.9 => RETURN VALUE IS NIL JRST TERP1 TRP$: JSP F,PRNAR$ SFA% 400000,,[QTRP$] SFA$ 400000,,[SO.TRP,,QTRP$] JRST TERP1 TERPRI: SKIPE AR1,TAPWRT ;1/4-INTERNAL TERPRI HRRZ AR1,VOUTFILES SFA$ JSP F,PRTSTR ;DO SFA CHECKING STUFF SFA$ [SO.TRP,,] TERP1: JSP T,GTRDTB ;SEMI-INTERNAL TERPRI MOVEI A,NIL ITERPRI: PUSH P,A ;INTERNAL TERPRI - SAVES A,B,C MOVEI TT,^M ;MUST HAVE FILE ARRAY IN AR1, PUSHJ P,TYO6 ; READTABLE IN AR2A MOVEI TT,^J PUSHJ P,TYO6 JRST POPAJ PTYO: SKIPE V.RSET ; +TYO: SUBR 2 JRST PTYO2 PTYO1: MOVE TT,(A) ;FIRST ARG IS ASCII VALUE CAIN B,TRUTH ;IF T MOVE B,V%TYO IFN SFA,[ MOVSI T,AS.SFA ;CHECK IF AN SFA TDNE T,ASAR(B) ;SFA BIT SET IN ASAR? JRST PTYO3 ;YUP, CALL AS AN SFA ] ;END IFN SFA .5LKTOPOPJ MOVE T,TTSAR(B) ;SECOND ARG IS FILE MOVEI A,TRUTH ;RETURNS T JRST TYOF4 IFN SFA,[ PTYO3: MOVEI C,(A) ;THIRD ARG IS THE FIXNUM MOVEI A,(B) ;FIRST ARG IS SFA ITSELF MOVEI B,Q%TYO ;TYO OPERATION JRST ISTCSH ;DO FAST INTERNAL CALL ] ;END IFN SFA PTYO2: IFN SFA,[ JSP TT,AFOSP ;CHECK FOR AN SFA JFCL SKIPA ;NOPE JRST PTYO3 ;YUP, SO CALL IT ] ;END IFN SFA JSP T,FXNV1 MOVEI AR1,(B) PUSHJ P,ATOFOK UNLOCKI ;MARGINAL DANGER THAT FILE COULD JRST PTYO1 ; GET SCEWED BY INTERRUPT HERE SUBTTL PRINT, PRIN1, PRINC, PRINT-OBJECT PRINT: SKIPE AR1,TAPWRT ;INTERNAL "SUBR" VERSION OF PRINT MOVE AR1,VOUTFILES SFA$ JSP F,PRTSTR ;DO SFA CHECKING STUFF SFA$ [SO.PRT,,] JRST $PRINT IFN HNKLOG,[ %PRO: ;PRINT-OBJECT SUBR (4 . 5) PRINTOBJECT: JSP TT,LWNACK ;Check number of arguments LA45,,Q%PRO CAMN T,IN0-5 ;5 arguments? POP P,AR1 ; Ignore it for LISPM compatability POP P,B ;STREAM POP P,AR1 ;SLASHIFY-P POP P,C ;I-PRINLEVEL POP P,A ;Object PUSH P,[TRUE] ;Arrange to return T PUSH P,C ;Save these two values PUSH P,AR1 ;From PRNARG harm and the GC PUSH FXP,P ;Remember our stack pointer PUSH P,A ;Now pretend we're a standard LSUBR (1 . 2) PUSH P,B MOVNI T,2 ;Called with 2 args JSP F,PRNARG SFA% JFCL [Q%PRO] SFA$ JFCL [SO.OUT,,Q%PRO] MOVE R,[PR.ATR,,$TYO] ;AR1 SHOULD BE SET UP BEFORE COMING HERE POP FXP,P ;Flush cruft PRNARG pushed MOVEI D,%PRO3 ;Come back to %PRO3 after checking PRINLEVEL SKIPE V%TERPRI TLZ R,PR.ATR ;TERPRI NON-NIL => NEVER AUTO-TERPRI JRST PRINT0 %PRO3: POP P,A POP P,TT ;I-PRINLEVEL MOVE TT,(TT) MOVEM TT,PRINLV POP P,TT ;SLASHIFY-P SKIPN TT ;Is this really PRINC TLO R,PR.PRC ; Note the fact PUSH P,A JRST PRINT1 ;Print it as if called by PRIN1 %PROX: ] ; END of IFN HNKLOG, %PRINT: JSP F,PRNARG ;LSUBR (1 . 2) SFA% JFCL [Q%PRINT] SFA$ JFCL [SO.PRT,,Q%PRINT] $PRINT: JSP T,GTRDTB ;AR1 SHOULD BE SET UP BEFORE COMING HERE PUSHJ P,ITERPRI CTY1: PUSHJ P,$PRIN1 CTY2: %SPC% POPJ P, PRIN1B: MOVE A,B PRIN1: SKIPE AR1,TAPWRT ;INTERNAL "SUBR" VERSION OF PRIN1 MOVE AR1,VOUTFILES SFA$ JSP F,PRTSTR SFA$ [SO.PR1,,] JRST $PRIN1 %PRIN1: %PR1: JSP F,PRNARG ;LSUBR (1 . 2) SFA% JFCL [Q%PR1] SFA$ JFCL [SO.PR1,,Q%PR1] $PRIN1: MOVE R,[PR.ATR,,$TYO] ;AR1 SHOULD BE SET UP BEFORE COMING HERE %PR1A: JSP T,GTRDTB PUSHJ P,PRINTY JRST TRUE PRINC: SKIPE AR1,TAPWRT ;INTERNAL "SUBR" VERSION OF PRINC MOVE AR1,VOUTFILES SFA$ JSP F,PRTSTR SFA$ [SO.PRC,,] JRST $PRINC %PRINC: %PRC: JSP F,PRNARG ;LSUBR (1 . 2) SFA% JFCL [Q%PRC] SFA$ JFCL [SO.PRC,,Q%PRC] $PRINC: MOVE R,[PR.PRC,,$TYO] ;AR1 SHOULD BE SET UP BEFORE COMING HERE JRST %PR1A ;;; SUBR VERSIONS - *PRINT, *PRIN1, *PRINC IFE SFA,[ IRPS X,,[PRT$:PR1$:PRC$:]Y,,[$PRINT,$PRIN1,$PRINC] X: JSP F,PRNAR$ [Q!X] JRST Y TERMIN ] ;END IFE SFA IFN SFA,[ IRPS X,,[PRT$:PR1$:PRC$:]Y,,[$PRINT,$PRIN1,$PRINC]Z,,[SO.PRT,SO.PR1,SO.PRC] X: JSP F,PRNAR$ [Z,,Q!X] JRST Y TERMIN ] ;END IFN SFA SUBTTL MAIN PRINTOUT ROUTINE ;;; ***** OKAY, OUTPUT LOVERS, HERE'S YOUR MAIN PRINT ROUTINE ***** ;;; CALLED WITH OBJECT TO PRINT IN A, ADDRESS OF "TYO" ROUTINE IN R. ;;; CLOBBERS A (RETURNS GARBAGE); TO SAVE A OVER PRINTY, USE APRINT. ;;; VARIOUS BITS ARE KEPT IN THE LEFT HALF OF R. ;;; SOME ARE PASSED IN, AND OTHERS ARE INITIALIZED AND USED INTERNALLY. PR.PRC==400000 ;MUST BE SIGN BIT! 0 => PRIN1, 1 => PRINC. (PASSED IN) PR.ATR==200000 ;1 => DO AUTO-TERPRI HACKS PR.NUM==4000 ;SYMBOL LOOKS LIKE A NUMBER SO FAR PR.NVB==2000 ;NOT PROVEN YET THAT VERTICAL BAR NEEDED PR.EFC==1000 ;EMBEDDED FUNNY CHARACTER IN SYMBOL FLAG (1 => NONE SEEN) PR.NLS==400 ;NOT PROVEN YET THAT LEADING SLASH NEEDED ;;; PRINTA EXPECTS B,C,T,TT,R SAFE OVER THE "TYO" ROUTINE. ;;; THE "TYO" ROUTINE GENERALLY EXPECTS AR1 AND AR2A SAFE OVER PRINTA. ;;; USES DIRECTLY OR INDIRECTLY A,B,C,T,TT,D,R,F. ;;; IN THE USELESS VERSION OF LISP, THERE ARE ABBREVIATION HACKS: ;;; PRINTY IS THE ENTRY FOR PRIN1/PRINC; ABBREVIATION IS CONTROLLED ;;; BY BIT 1.1 OF (STATUS ABBREVIATE). TYOSW INDICATES WHETHER ;;; A CHAR IS MEANT FOR TTY, FILES, OR BOTH (IN THIS WAY THE TTY ;;; CAN RECEIVE ABBREVIATIONS WHILE FILES RECEIVE FULL S-EXPRS). ;;; PRINTF IS THE ENTRY FOR FLATSIZE/EXPLODE; ABBREVIATION IS ;;; CONTROLLED BY BIT 1.2 OF (STATUS ABBREVIATE). ;;; PRINTA IS THE ENTRY FOR ALL OTHER PRINT HACKERS; IT ;;; NEVER ABBREVIATES. IFE USELESS,[ PRINTY: SKIPE V%TERPRI ;TERPRI NON-NIL => NEVER AUTO-TERPRI PRINTF: ;ENTRY FOR FLATSIZE/EXPLODE PRINTA: TLZ R,PR.ATR ;OTHER GUYS DON'T WANT AUTO-TERPRI HACKS PRINT3: PUSH P,A ;MAIN RECURSIVE ENTRY FOR PRINTING ROT A,-SEGLOG ;NOTE THAT A IS SAFE ON PDL SKIPL TT,ST(A) ;MUST DO A ROT, NOT LSH! SEE PRINX JRST PRINX %LPAR% ;PRINT A LIST. FIRST TYO A ( PRINT4: HLRZ A,@(P) IFN HNKLOG,[ TLNE TT,HNK JRST PRINH0 PRINH6: ] ;END OF IFN HNKLOG PUSHJ P,PRINT3 ;NOW PRINT CAR OF THE LIST HRRZ A,@(P) JUMPE A,PRIN8A ;IF CDR IS NIL, NEED ONLY A ) PRIN7A: MOVEM A,(P) %SPC% ;ELSE SPACE IN BETWEEN LSH A,-SEGLOG ;WE KNOW A IS NON-NIL! SKIPGE TT,ST(A) JRST PRINT4 ;IF CDR IS NON-ATOMIC, LOOP %DOT% ;ELSE DOTTED LIST %SPC% PUSHJ P,PRIN1A ;SO PRINT THE ATOM AFTER THE LISP DOT PRIN8A: %RPAR% ;NOW TYO A ) JRST POP1J ] ;END OF IFE USELESS IFN USELESS,[ PRINTY: MOVEI D,PRINT1 ;ENTRY FOR PRIN1/PRINC SKIPE V%TERPRI TLZ R,PR.ATR ;TERPRI NON-NIL => NEVER AUTO-TERPRI JRST PRINT0 PRINTF: MOVEI D,PRINT2 ;ENTRY FOR FLATSIZE/EXPLODE TLZ R,PR.ATR JRST PRINT0 APRINT: PUSH P,A PUSH P,CPOPAJ PRINTA: MOVEI D,PRIN3A ;ENTRY FOR NO ABBREVIATIONS TLZ R,PR.ATR PRINT0: PUSH P,A ;CLOBBERS ARG (RETURNS GARBAGE) SKIPN V.RSET ;IF IN *RSET MODE, CHECK VALUES OF JRST PRIN0A ; PRINLEVEL AND PRINLENGTH IRP X,,[%LEVEL,%LENGTH]Y,,[%LV,%LN] Y!CHK: SKIPN A,V!X ;NIL IS A VALID VALUE JRST PRT!Y SKOTT A,FX JRST Y!ERR SKIPGE (A) JRST Y!ERR PRT!Y: TERMIN PRIN0A: SETOM PRINLV ;PRINLV HAS -1 SETZM ABBRSW ;ASSUME ABBRSW ZERO JSP T,RSXST MOVEI A,LRCT-2 ;GET (STATUS ABBREVIATE) NW% HRRZ T,@RSXTB NW$ LDB T,[001120,,RSXTB] ;PICK UP CHTRAN HRRZ A,(P) ;MUST LEAVE ARG IN A FOR PRINT3, %PRO3 SETZM PRPRCT JRST (D) ;DISPATCH TO PRINT1, PRINT2, PRINT3, %PRO3 PRINT1: SETOM ABBRSW ;PRIN1/PRINC SKIPE TAPWRT ;OPEN FILES? WHETHER OR NOT TO ABBREVIATE THEM JRST PRIN1Q SKIPN TTYOFF ;IF NO FILES OPEN, THEN ABBREVIATE FOR TTY JRST PRIN3A PRIN1Q: TRNN T,1 ;ULTIMATE DECISION ON FILE ABBREVIATION HRRZS ABBRSW ; COMES FROM (STATUS ABBREVIATE) JRST PRIN3A PRINT2: TRNE T,2 ;FLATSIZE/EXPLODE - DECIDE WHETHER IT SETOM ABBRSW ; WANTS ABBREVIATION OR NOT JRST PRIN3A PRINT3: PUSH P,A ;MAIN RECURSIVE ENTRY FOR PRINTING PRIN3A: ROT A,-SEGLOG ;NOT LSH! SEE PRINX SKIPL TT,ST(A) JRST PRINX ;IF SO, USE AN ATOM PRINTER IFN HNKLOG,[ TLNN TT,HNK ;Is this a hunk? JRST PRN3NH ; Nope... PUSH FXP,PRPRCT PUSH FXP,FLAT1 ;If for some totally random reason it called FLATSIZE.. MOVE A,(P) PUSH P,TT ;TT get's used WAY WAY below! PUSHJ P,USRHNP ;Is this a user hunk? POP P,TT POP FXP,FLAT1 POP FXP,PRPRCT JUMPE T,PRN3NH ;If not, just print an ordinary hunk MOVEI T,FLAT2 MOVEI B,FLATO2 CAIE B,(R) ;Is this really a FLATSIZE hack? CAIN T,(R) JRST FLTHNK ; Yes, just get the FLATSIZE and add it in MOVEI B,TRUTH ;Say this comes from PRINT PUSH FXP,PRINLV ;Don't let calls to FLATSIZE screw us! PUSHJ P,SENDFL ;Send the message to the frob POP FXP,PRINLV MOVE T,(A) ;Get the size PUSHJ P,PRINLP ;print all necessary lparens MOVE A,(P) ;Recover the object PUSHJ P,SENDPR ;Send it to the frob JRST POP1J FLTHNK: SETZ T, PUSHJ P,PRINLP ;Be sure to get any needed parens out there PUSH FXP,FLAT1 ;Remember how much we got so far MOVEI A,FLATO2 ;For test SETZ B, ;We are really comming from FLATSIZE CAIN A,(R) ;Is this from FLATSIZE-OBJECT with PRINTP T? MOVEI B,TRUTH ; Yes, we're really a recursive call from PRINT MOVE A,(P) ;Recover our object from the stack PUSHJ P,SENDFL ;Send the message to the frob MOVE TT,(A) ;Get the result POP FXP,FLAT1 ;Recover flatsize-so-far ADDM TT,FLAT1 ;and add them up JRST POP1J SENDFL: PUSH P,AR1 MOVE AR1,B ;Get whether from PRINT MOVEI B,QFLATSIZE JRST SENDP1 SENDPR: PUSH P,AR1 MOVEI B,Q%PRINT SENDP1: SAVE AR2A R PUSH FXP,PRPRCT ;Save pending RPAREN count PUSH P,[SNDPR0] ;LSUBR return (I hate this sequence) PUSH P,A ;Object PUSH P,B ;Message MOVEI AR1,(AR1) ;Eliminate flags from left half PUSH P,AR1 ;stream or printp if FLATSIZE PUSH FXP,PRINLV MOVEI A,(FXP) ;Fixnum level PUSH P,A PUSH P,NIL ;No slashification MOVEI T,TRUTH SKIPL R ;Are we doing PRIN1 instead of PRINC? MOVEM T,(P) ; Then say to do slashification MOVNI T,5 XCT SENDI ;Ask the SEND interpreter SNDPR0: POP FXP,T POP FXP,PRPRCT RSTR R AR2A AR1 POPJ P, PRN3NH: ]; END IFN HNKLOG, MOVE T,TYOSW ;Save old value of TYOSW HRLM T,-1(P) ; (I.E. that of previous level) JUMPN T,PRINT4 ;If previous level was non-abbrev, SKIPN ABBRSW ; Or if we don't ever want abbrev, JRST PRINT4 ; Then needn't try to abbrev! AOS T,PRINLV ;Else increment level count SKIPE V%LEVEL ;If PRINLEVEL=NIL, or if actual level CAMGE T,@V%LEVEL ; Is less, then don't abbrev JRST PRINT4 SKIPL ABBRSW SETOM TYOSW CAME T,@V%LEVEL ;If we're exactly equal to PRINLEVEL, JRST PRIN3F MOVEI T,1 PUSHJ P,PRINLP %NMBR% ; SHOOT OUT LEVEL ABBREVIATION PRIN3F: SKIPGE ABBRSW ;IF WE ONLY WANT ABBREVIATION, JRST PRINT9 ; NEEDN'T GROVEL OVER THE SUBLIST HRRZS TYOSW ;ELSE SIGNAL NON-ABBREV ONLY MODE PRINT4: PUSH FXP,PRPRCT ;SAVE PARENS COUNTS HLLOS PRPRCT ;CLEAR RIGHT PARENS COUNT, AND AOS PRPRCT ; INCREMENT LEFT PARENS COUNT PUSH FXP,XC-1 ;-1 FOR THIS LEVEL MOVE T,TYOSW ;SAVE CURRENT TYOSW (DETERMINES WHETHER HRLM T,(P) ; ABBREV MODE OUTPUT WANTS A ) AT END) PRINT5: SKIPN TYOSW ;IF WE ARE IN NON-ABBREV ONLY MODE, SKIPN ABBRSW ; OR IF WE NEVER WANT ABBREV, JRST PRINT7 ; THEN DON'T TRY TO ABBREV! AOS T,(FXP) ;ELSE INCREMENT PRINT LENGTH SKIPE V%LENGTH ;IF PRINLENGTH=NIL, OR IF WE'RE LESS CAMGE T,@V%LENGTH ; THAN IT, THEN DON'T ABBREV JRST PRINT7 SKIPL ABBRSW SETOM TYOSW CAME T,@V%LENGTH JRST PRINT6 ;IF WE'RE EXACTLY EQUAL, THEN ABBREV MOVEI T,3 PUSHJ P,PRINLP REPEAT 3, %DOT% PRINT6: SKIPGE ABBRSW ;IF WE DON'T WANT NON-ABBREV ONLY MODE, JRST PRINT8 ; THEN CAN IGNORE REST OF LIST HRRZS TYOSW ;ELSE SIGNAL NON-ABBREV ONLY MODE PRINT7: HRRZ A,(P) HRRZ B,(A) HLRZ A,(A) HRRZ T,-1(FXP) ADDI T,1 SKIPN B HRRM T,PRPRCT IFN HNKLOG,[ TLNE TT,HNK JRST PRINH0 PRINH6: ] ;END OF IFN HNKLOG PUSHJ P,PRINT3 ;SO PRINT THE CAR OF THE LIST SETZM PRPRCT HRRZ A,(P) HRRZ A,(A) JUMPE A,PRINT8 ;IF CDR IS NIL, NEED ONLY A ) NOW PRIN7A: HRRM A,(P) %SPC% ;ELSE SPACE BETWEEN LSH A,-SEGLOG SKIPL TT,ST(A) JRST PRIN7B ; IF AN ATOM, THEN NEED A DOT TLNN TT,HNK ; IF NOT A HUNK, THEN A CDR WHICH IS A LIST, JRST PRINT5 ; SO LOOP. ELSE, WE HAVE A DOTTED LIST PRIN7B: %DOT% %SPC% HRRZ T,-1(FXP) ADDI T,1 MOVEM T,PRPRCT MOVE A,(P) ;SET UP A WITH CDR-OBJECT TO PRINT (HUNK OR ATOM) PUSHJ P,PRINT3 ;JUMP TO GENERAL RECURSIVE PRINTER PRINT8: HLRZ T,(P) ;THIS WILL TELL TYO WHAT TO MOVEM T,TYOSW ; DO WITH THE ) PRIN8A: %RPAR% ;TYO A ) TO END THE LIST IFE USELESS, PRIN8B: ;A normally useless symbol SUB FXP,R70+1 POP FXP,PRPRCT PRINT9: HLRZ T,-1(P) ;RESTORE TYOSW TO WHAT IT WAS MOVEM T,TYOSW ; ON LAST (RECURSIVE!) ENTRY JUMPN T,POP1J ;IF AND ONLY IF WE AOS'ED PRINLV, SKIPE ABBRSW ; WE MUST NOW SOS IT, AND THEN POP1J SOS PRINLV JRST POP1J ] ;END OF IFN USELESS SUBTTL PRINT A HUNK IFN HNKLOG,[ PRINH0: SKIPN VHUNKP ;IF HUNKP IS NIL, THEN PRINT A HUNK JRST PRINH6 ; AS IF IT WERE A LIST CELL IFE USELESS,[ PUSHJ P,USRHNP ;Is this a user's extended hunk? JUMPE T,PRINH8 PUSHJ P,SENDPR JRST PRIN8B PRINH8: ]; -- END of IFE USELESS, CAIN TT,QHUNK0 CAIE A,-1 JRST .+2 JRST PRHN3B PUSH FXP,TT PUSHJ P,PRINT3 ;PRINT FIRST ELT IFN USELESS, SETZM PRPRCT POP FXP,TT MOVSI T,-1 2DIF [LSH T,(TT)]0,QHUNK0 HRR T,(P) ADD T,R70+1 JUMPGE T,PRHN3A ;"HUNK2" CASE, WITH 2 ELEMENTS PUSH P,T PRINH2: MOVEM T,(P) PRHN2B: HRRZ A,(P) HRRZ A,(A) CAIN A,-1 JRST PRINH3 %SPC% %DOT% %SPC% PUSHJ P,PRINT3 HRRZ A,(P) HLRZ A,(A) CAIN A,-1 JRST PRINH3 %SPC% %DOT% %SPC% PUSHJ P,PRINT3 MOVE T,(P) AOBJN T,PRINH2 PRINH3: SUB P,R70+1 ;FINISHED WITH HUNK (EXCEPT FOR CDR) PRHN3A: %SPC% %DOT% %SPC% PRHN3B: HRRZ A,(P) HRRZ A,(A) PUSHJ P,PRINT3 %SPC% %DOT% JRST PRIN8A ] ;END OF IFN HNKLOG SUBTTL PRINT ATOM DISPATCH, AND PRINT AN ARRAY OR A RANDOM PRINX: PUSH P,CPOP1J ;PRINT AN ATOM (ON THE PDL) PRIN1A: ;TT HAS ST ENTRY HRRZ A,-1(P) ;NIL IS SYMBOL, NOT RANDOM!!! JUMPE A,PRINIL 2DIF JRST (TT),.,QLIST .SEE STDISP ;TT MUST HAVE ST ENTRY PRIN1Z: JRST PRINI ;FIXNUM JRST PRINO ;FLONUM DB$ JRST PRINDB ;DOUBLE CX$ JRST PRINCX ;COMPLEX DX$ JRST PRINDX ;DUPLEX BG$ JRST PRINB ;BIGNUM JRST PRINN ;SYMBOL HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS JFCL ;RANDOM IFN .-PRIN1Z-NTYPES+2, WARN [WRONG LENGTH TABLE] IFN USELESS,[ MOVEI T,25. PUSHJ P,PRINLP SETZM PRPRCT ] ;END OF IFN USELESS %NMBR% ;ARRAY (AND RANDOM) TLNN TT,SA JRST PRINX5 HRRZ A,-1(P) MOVE TT,ASAR(A) CAIE TT,ADEAD JRST PRINA2 SKIPA TT,[440700,,[ASCIZ \DEAD-ARRAY\]] PRINA1: PUSHJ P,(R) ILDB A,TT JUMPN A,PRINA1 POPJ P, PRINA2: TLNE TT,AS JRST PRNFL TLNE TT,AS JRST PRNJB SFA$ TLNE TT,AS.SFA ;SFA? SFA$ JRST PRNSR JFFO TT,.+1 HRRZ A,ARYTYP(D) TLC TT,AS ;CROCK FOR NSTORE ARRAYS TLNN TT,AS SETZ A, PUSHJ P,PRINSY %NEG% HRRZ A,-1(P) LDB F,[TTSDIM,,TTSAR(A)] PRINA3: HRRZ A,-1(P) MOVNI TT,(F) MOVE TT,@TTSAR(A) IFE USELESS, MOVE C,@VBASE ;BETTER BE A FIXNUM! IFN USELESS,[ HRRZ C,VBASE CAIE C,QROMAN SKIPA C,(C) PUSHJ P,PROMAN ] ;END OF IFN USELESS PUSHJ P,PRINI9 SOJE F,PRINA4 %CLN% JRST PRINA3 PRINA4: %NEG% PRINX5: HRRZ TT,-1(P) PRINL4: MOVEI C,10 ;N BASE 8 JRST PRINI3 SUBTTL PRINT A FILE OBJECT, PRINT A JOB OBJECT, PRINT AN SFA ;;; PRINT A JOB OBJECT AS #JOB-||-
;;; PRINT A FILE OBJECT AS #FILE--||-
;;; PRINT AN SFA AS #SFA-||-
;;; WHERE IS "IN" OR "OUT", IS THE TRUENAME, ;;; IS THE THING GIVEN AS THE THIRD ARG TO CREATE-SFA ;;; AND
IS THE OCTAL ADDRESS OF THE SAR. IFN SFA,[ PRNSR: MOVEI T,[ASCIZ \SFA-\] JRST PRNF5 ] ;END IFN SFA PRNJB: MOVEI T,[ASCIZ \JOB-\] JRST PRNF5 PRNFL: MOVEI T,[ASCIZ \FILE-\] PRNF5: PUSHJ P,PRNSTO HRRZ A,-1(P) MOVE TT,ASAR(A) SFA$ TLNE TT,AS.SFA ;SFA? SFA$ JRST PRNSR1 ;YES, PRINT DIFFERENTLY PUSH FXP,TT TLNE TT,AS.JOB ;DON'T PRINT DIR FOR JOB ARRAY JRST PRNF6 MOVE TT,TTSAR(A) ;FORMERLY, THIS ROUTINE USED PRINSY TO PRINT IN OR OUT. BUT, SINCE THIS ;ROUTINE CAN BE CALLED FROM THE GARBAGE COLLECTOR, THE POINTERS COULD BE ;MARKED AND THEREFORE INVALID. TO AVOID PRINTING LOSSAGE, PRINTING IS DONE ;MANUALLY. MOVEI T,[ASCII \IN\] ;ASSUME INPUT FILE TLNE TT,TTS MOVEI T,[ASCII \OUT\] PUSHJ P,PRNSTO %NEG% PRNF6: %VBAR% POP FXP,T ;SAVED ASAR MOVNI TT,LPNBUF PUSH FXP,PNBUF+LPNBUF(TT) ;UNFORTUNATELY, SOMEONE MIGHT BE USING AOJL TT,.-1 ; PNBUF, SO WE MUST SAVE IT HRRZ A,-1(P) PUSH FXP,R 20$ MOVE TT,TTSAR(A) ;FOR D20 CLOSED FILE NEEDS SPECIAL HANDLING 20$ TLNN TT,TTS.CL ;CLOSED? (ASAR SAVED IN T) TLNE T,AS.JOB ;DON'T GET TRUENAME FOR JOB ARRRAYS JRST PRNJ1 PUSHJ P,TRU6BT ;GET TRUENAME OF FILE ON FXP PRNJ2: PUSHJ P,6BTNSL ;CONVERT THAT TO A NAMESTRING IN PNBUF POP FXP,R MOVEI TT,-LPNBUF+1(FXP) MOVSI T,-LPNBUF PRNF1: MOVE D,PNBUF(T) ;SWAP PNBUF WITH COPY ON PDL EXCH D,(TT) MOVEM D,PNBUF(T) ADDI TT,1 AOBJN T,PRNF1 MOVEI T,-LPNBUF+1(FXP) PUSHN FXP,1 ;BE SURE STRING ENDS WITH ZEROS PUSHJ P,PRNSTO POPI FXP,LPNBUF+1 ;POP THE CRUD %VBAR% JRST PRINA4 PRNSTO: HRLI T,440700 ILDB A,T JUMPE A,CPOPJ PUSHJ P,(R) JRST .-3 PRNJ1: HRRZ TT,TTSAR(A) HRLI TT,-L.F6BT 20% PUSH FXP,F.RDEV(TT) 20$ PUSH FXP,F.DEV(TT) AOBJN TT,.-1 JRST PRNJ2 IFN SFA,[ PRNSR1: %VBAR% MOVEI TT,SR.PNA ;GET THE PNAME HRRZ A,-1(P) ;PICK UP ARRAY POINTER HRRZ A,@TTSAR(A) PUSH FXP,R ;REMEMBER R OVER RECURSIVE CALL TO PRINT TLO R,PR.PRC PUSHJ P,PRINTA ;PRINT THE NAME POP FXP,R %VBAR% JRST PRINA4 ] ;END IFN SFA SUBTTL PRINT AN ATOMIC SYMBOL ;PRINIL: ;IFN USELESS, PUSHJ P,PLP1 ; MOVEI A,"( ;PRINT () FOR NIL ; PUSHJ P,(R) ; MOVEI A,") ; JRST (R) PRINSY: PUSH P,A PUSH P,CPOP1J JUMPE A,PRINIL PRINN: SKIPA A,-1(P) PRINIL: MOVEI A,[$$$NIL,,] JSP C,MAPNAME JUMPGE R,PRNN2 .SEE PR.PRC IFN USELESS, PUSHJ P,PLP1 PRNN1: JSP C,(C) ;FOR PRINC, JUST OUTPUT THE CHARS POPJ P, MOVEI A,(TT) PUSHJ P,(R) JRST PRNN1 PRNN2A: IFN USELESS,[ HLRZ T,PRPRCT PRNN2B: SOJL T,PRNN2C %LPAR% JRST PRNN2B PRNN2C: HRRZS PRPRCT ] ;END OF IFN USELESS %VBAR% ;FOR NULL PNAME, PRINT || %VBAR% JRST PLP1 PRNN2: JSP C,(C) ;GET FIRST CHAR JRST PRNN2A ;FOR NULL PNAME, JUST PRINT HANGING LEFT PARENS TLO R,PR.NVB+PR.NUM+PR.EFC+PR.NLS SETZ F, ;F COUNTS: <# SLASHES,,# CHARS> HRRZ A,VREADTABLE MOVE D,@TTSAR(A) TLNN D,14 ;IF NOT A DIGIT OR A SIGN, TLZ R,PR.NUM ; THEN IT ISN'T NUMBER-LIKE TLNN D,400 ;IF NOT SLASHIFIED AS FIRST CHAR, AOJA F,PRNN3A ; JUST BUMP CHAR COUNTER TLZ R,PR.EFC ;ELSE ONE FUNNY CHAR SEEN ALREADY TLNE D,171000 ;REAL WEIRDIES FORCE VERTICAL BARS TLZ R,PR.NVB PRNN3: ADD F,R70+1 ;BUMP CHAR COUNT AND SLASH COUNT PRNN3A: JSP C,(C) ;GET NEXT CHAR JRST PRNN4 MOVE D,@TTSAR(A) TLNN D,24 ;IF IT LOOKS LIKE A NUMBER SO FAR TLZN R,PR.NUM ; BUT THIS NEXT CHAR ISN'T DIGIT OR ARROW, JRST PRNN3B TRNE F,777770 ; THEN WE NEED A LEADING SLASH IF THERE WERE TLZ R,PR.NLS ; MORE THAN SEVEN LEADING NUMBER-LIKE CHARS PRNN3B: TLNN D,100 ;IF NOT SLASHIBLE IN FIRST POSITION, PRNN3C: AOJA F,PRNN3A ; JUST BUMP CHAR COUNTER TLNN D,2000 ;VERTICAL BARS CAN'T HELP A SLASH CAIN TT,"| ; OR VERTICAL BAR, SO COUNT THEM AS AOJA F,PRNN3C ; TWO CHARACTERS AND NO SLASHES TLNN D,171000 ;REAL WEIRDIES TLZN R,PR.EFC ; OR TWO EMBEDDED FUNNY CHARS TLZ R,PR.NVB ; FORCE VERTICAL BARS JRST PRNN3 PRNN4: CAIN F,1 ;A SIGN WITH NO FOLLOWING TLNN D,10 ; DIGITS DOESN'T NEED A SLASH CAIA JRST PRNN4A TLNE R,PR.NUM ;IF THE WHOLE THING IS NUMBER-LIKE, TLZ R,PR.NLS ; THEN DEFINITELY NEED A LEADING SLASH PRNN4A: MOVEI T,2(F) TLNN R,PR.NVB JRST PRNN4B HLRZ T,F ;WE AREN'T USING VERTICAL BARS ADDI T,1(F) ; SO MUST COMPUTE UP ROOM TAKEN BY TLNN R,PR.NLS ; CHARS AND SLASHES, PLUS ONE FOR THE SPACE ADDI T,1 ; WHICH MAY FOLLOW PRNN4B: PUSHJ P,PRINLP SKIPN A,-1(P) MOVEI A,[$$$NIL,,] JSP C,MAPNAME TLNE R,PR.NVB JRST PRNN6 %VBAR% ;DO THE VERTICAL BAR THING PRNN5: JSP C,(C) JRST VBARPOPJ CAIE TT,^M CAIN TT,"| JRST PRNN5A MOVE A,VREADTABLE MOVE D,@TTSAR(A) TLNE D,2000 PRNN5A: %SLSH% MOVEI A,(TT) PUSHJ P,(R) JRST PRNN5 VBARPOPJ: %VBAR% POPJ P, PRNN6: MOVEI F,400 PRNN6A: JSP C,(C) POPJ P, 20$ PUSH P,B ;B MUST BE PRESERVED MOVE A,VREADTABLE MOVE D,@TTSAR(A) TLOE R,PR.NLS TLNE D,(F) %SLSH% MOVEI A,(TT) PUSHJ P,(R) 20$ POP P,B MOVEI F,100 JRST PRNN6A ;;; COROUTINE TO DELIVER UP CHARACTERS OF A PRINT NAME. ;;; USES JSP C,(C) TO CALL. USES B, T; YIELDS CHARS IN TT. ;;; SETUP USES A. SKIPS UNLESS NO MORE CHARS. MAPNAME: HLRZ B,(A) HRRZ B,1(B) JSP C,(C) MAPNM1: HLRZ T,(B) MOVE T,(T) TRZ T,1 ;FORCE OFF LOW ORDER BIT, IS UNUSED IN ASCII MAPNM2: SETZ TT, ROTC T,7 SKIPN T ;ONLY CHECK FOR NULLS IF AT THE END OF THE WORD JUMPE TT,MAPNM3 JSP C,1(C) JRST MAPNM2 MAPNM3: HRRZ B,(B) JUMPN B,MAPNM1 JRST (C) ;;; ROUTINE TO FEED FORMATTING INFORMATION TO TYO IF DESIRED, ;;; THEN PRINT ANY PENDING LEFT PARENTHESES. ;;; THE LENGTH OF THE ATOM TO BE PRINTED IS IN T. ;;; USES ONLY A AND T. PRINLP: TLNN R,PR.ATR JRST PLP1 IFN USELESS,[ MOVSI T,(T) ADD T,PRPRCT HLRZ T,T ADD T,PRPRCT ] ;END OF IFN USELESS TRNE T,777000 MOVEI T,777 HRROI A,1(T) ;ALLOW FOR FOLLOWING SPACE PUSHJ P,(R) PLP1: .SEE PRNN1 IFE USELESS, POPJ P, IFN USELESS,[ HLRZ T,PRPRCT PRINLQ: SOJL T,CPOPJ %LPAR% JRST PRINLQ ] ;END OF IFN USELESS SUBTTL PRINT A FIXNUM PRINI: MOVE A,VBASE IFN USELESS, CAIN A,QROMAN IFN USELESS, JRST PRINRM SKOTT A,FX JRST BASER MOVE C,(A) ;TRUE VALUE OF BASE IN C CAIG C,36. CAIGE C,2 JRST BASER PRI2D: HRRZ A,-1(P) JSP T,FXNV1 ;THE TYO ROUTINE MUST SAVE TT HERE IFN USELESS,[ MOVMS TT ;ESTIMATE LENGTH OF FIXNUM JFFO TT,.+2 ; ASSUMING OCTAL BASE MOVEI D,43 MOVNI T,3 IDIVM D,T ;AVOID CLOBBERING EXTRA ACS ADDI T,14 SKIPGE @-1(P) ;ALLOW FOR MINUS SIGN ADDI T,1 PUSHJ P,PRINLP MOVE TT,@-1(P) ] ;END OF IFN USELESS CAIN C,8 ;FOR OCTAL NUMBERS, WE MAY WANT JRST PRI2B ; TO USE A FUNNY SHIFTED FORMAT PRI2C: JUMPL TT,PRI2Q SKIPE V.NOPOINT JRST PRINI2 ;HAPPY PRATT? CAILE C,10. %POS% JRST PRINI2 PRI2Q: %NEG% PRI2A: MOVNS TT PRINI2: JSP T,PRI. ;INSERT DECIMAL POINT IF NECESSARY PRINI9: MOVEI T,1 ;MUST SAVE F - SEE GCPNT1, GCWORRY TLZN TT,400000 ;IF NUMBER COULD BE MOBY, THEN MOVE HIGH ORDER BIT PRINI3: SETZ T, .SEE FP4B1 ;MUSTN'T DISTURB B JSP D,PRINI5 SKIPE TT,T PUSHJ P,PRINI3 FP7A1: HLRZ A,(P) FP7B: MOVEI A,"0(A) CAIE A,". JRST (R) %DCML% POPJ P, PRINI5: DIVI TT-1,(C) CAILE TT,9 ADDI TT,"A-"9-1 ;KLUDGY DIGITS GREATER THAN 9 ARE "A, B, C, ..., Y, Z" PRINI7: HRLM TT,(P) JRST (D) PRI.: CAIN C,10. ;IF THE RADIX IS 10. SKIPE V.NOPOINT ; AND *NOPOINT IS NOT SET, JRST (T) ; THEN KLUDGILY ARRANGE HRLI T,".-"0 ; TO PRINT A "." AFTER THE HLLM T,(P) ; DIGITS ARE PRINTED PUSH P,[FP7A1] JRST (T) PRI2B: MOVM D,TT TRNN D,777 TLNN D,-1 JRST PRI2C MOVEI T,(C) MOVE C,VREADTABLE MOVE D,TT MOVEI TT,LRCT-1 ;RH OF LAST RCT ENTRY IS (STATUS _) HRRZ C,@TTSAR(C) EXCH T,C MOVE TT,D JUMPE T,PRI2C MOVNI D,11 ;PRINT OUT AS ONE OF: TRNE TT,777000 ; NNNNNNNNN_11 JRST PRI2B3 ; NNNNNN_22 MOVNI D,22 ; NNN_33 TLNN TT,777 ; N_41 MOVNI D,33 ; IN ORDER THAT LOSERS NEED NOT TLNN TT,77777 ; COUNT ALL THE ZEROS OF AN MOVNI D,41 ; OCTAL NUMBER. PRI2B3: ASH TT,(D) PUSH FXP,D PUSHJ P,PRI2C %BAK% POP FXP,TT JRST PRI2A IFN USELESS,[ PROMAN: AOS (P) JRST PRINR0 PRINRM: HRRZ A,-1(P) JSP T,FXNV1 PRINR0: MOVEI C,10. JUMPLE TT,PRI2D CAIL TT,4000. JRST PRI2D MOVEI T,15. PUSHJ P,PRINLP SETZ T, PRINR1: IDIVI TT,10. HRLM D,(P) ADDI T,1 JUMPE TT,PRINR2 PUSHJ P,PRINR1 PRINR2: HLRZ TT,(P) SUBI T,1 JUMPE TT,CPOPJ CAIE TT,9 JRST PRINR3 HLRZ A,PRINR9(T) PUSHJ P,(R) HLRZ A,PRINR9+1(T) JRST (R) PRINR3: CAIE TT,4 JRST PRINR4 HLRZ A,PRINR9(T) PUSHJ P,(R) HRRZ A,PRINR9(T) JRST (R) PRINR4: CAIGE TT,5 JRST PRINR6 SUBI TT,5 HRRZ A,PRINR9(T) PRINR5: PUSHJ P,(R) PRINR6: SOJL TT,CPOPJ HLRZ A,PRINR9(T) JRST PRINR5 PRINR9: "I,,"V "X,,"L "C,,"D "M,, ] ;END OF IFN USELESS SUBTTL PRINT A FLONUM (SINGLE OR DOUBLE PRECISION) IFN DBFLAG,[ PRINDB: IFN USELESS,[ MOVEI T,30. ;GROSS ESTIMATE OF LENGTH OF DOUBLE PUSHJ P,PRINLP ] ;END OF IFN USELESS KA HRRZ A,-1(P) KA MOVE T,(A) KA MOVE TT,1(A) KIKL DMOVE T,@-1(P) DFP0: KA MOVEI B,66 ;PRECISION OF "SOFTWARE FORMAT" DOUBLE KIKL MOVEI B,76 ;PRECISION OF "HARDWARE FORMAT" DOUBLE JRST FP0A ] ;END OF IFN DBFLAG PRINO: IFN USELESS,[ MOVEI T,17. ;GROSS ESTIMATE OF LENGTH OF FLONUM PUSHJ P,PRINLP ] ;END OF IFN USELESS MOVE T,@-1(P) ;A FLONUM TO PRINT IS IN T FP0: DB$ MOVEI B,33 ;PRECISION OF A FLONUM IN BITS DB$ SETZ TT, FP0A: JUMPGE T,FP0B %NEG% DB% MOVNS T DB$ KA DFN T,TT DB$ KIKL DMOVN T,T FP0B: ;A POSITIVE FLONUM TO PRINT IS IN T (DB$: AND TT); IF DB$, PRECISION IN BITS IS IN B FP1: IFN DBFLAG,[ MOVE F,T ;MAKE A COPY OF NUMBER WITH JUST THE AND F,[777400,,] ; MOST SIGNIFICANT BIT SET (ASSUME ARG NORMALIZED) PUSH FXP,F ;THIS WILL BE USED FOR A MASK AFTER SCALING PUSH FXP,R70 ; DOWN BY THE CONTENTS OF B (PRECISION) SETZ F, ;F WILL BE THE EXPONENT TO PRINT FOR E/D NOTATION CAMGE T,[0.1] ] ;END OF IFN DBFLAG DB% SETZB TT,F ;TT IS SECOND WORD FOR T; F WILL BE EXPONENT DB% CAMGE T,[0.01] JRST FP4 ;0.01 (OR 0.1) AND 1.0^8 ARE CHOSEN SO THAT THE CAML T,[1.0^8] ; FRACTIONAL PART WILL HAVE AT LEAST ONE JRST FP4E0 ; BIT, BUT NOT LOSE ANY OFF THE RIGHT END DB$ CAILE B,33 ;FOR DOUBLE PRECISION, MUST ARRANGE TO PRINT "D0" DB$ JRST FP4B1 ; AT THE END OF THE NUMBER IFE DBFLAG,[ ;A POSITIVE FLONUM BETWEEN .01 AND 1.0^8 IS IN T FP3: SETZB TT,D ASHC T,-33 ;SPLIT EXPONENT PART OFF - MANTISSA IN TT ASHC TT,-243(T) ;SPLIT NUMBER INTO INTEGRAL AND FRACTIONAL PART MOVSI F,200000 ;COMPUTE POSITION OF LAST SIGNIFICANT BITS ASH F,-243+<43-33>(T) ;F GETS A VALUE EQUAL TO 1/2 LSB PUSH FXP,F PUSH FXP,D ;SAVE FRACTION MOVEI C,10. ;PRINT INTEGER PART AS A DECIMAL FIXNUM PUSHJ P,PRINI3 %DCML% ;PRINT DECIMAL POINT POP FXP,TT ;NOW TT HAS FRACTION INFO BITS, AND (FXP) HAS SLIDING MASK BIT (TOLERANCE) FP3A: MOVE T,TT ;REMAINING INFO BITS IN TT MULI T,10. ;T GETS NEXT DIGIT TO PRINT, MORE OR LESS POP FXP,F JFCL 8,.+1 ;CLEAR OVERFLOW IMULI F,10. ;OVERFLOW ON (FSC 231400000001 0) AND (FSC 175631463150 0) JFCL 8,FP3A1 ;CUT OFF WHEN MASK BIT OVERFLOWS CAMGE TT,F JRST FP3A1 ; OR WHEN REMAINING INFO BITS ARE BELOW MASK MOVN D,F TLZ D,400000 CAMLE TT,D AOJA T,FPX0 ;LAST SIG DIGIT, BUT ROUND UPWARDS PUSH FXP,F PUSHJ P,FPX0 ;OUTPUT A DIGIT, AND GO AROUND FOR ANOTHER JRST FP3A FP3A1: TLNE TT,200000 ;SIZE OF REMAINDER DETERMINES ROUNDING ADDI T,1 FPX0: MOVEI A,"0(T) ;COME HERE TO OUTPUT A DIGIT IN T JRST (R) ] ;END OF IFE DBFLAG IFN DBFLAG,[ ;FALLS THROUGH ;;; IFN DBFLAG ;FALLS IN ;A POSITIVE FLONUM BETWEEN 0.1 AND 10.0^8 IS IN T AND TT; PRECISION IN BITS IS IN B ; ON FXP, A TWO-WORD MASK VALUE, AS YET UNSCALED BY THE CONTENTS OF B FP3: KA ASH TT,10 ;PUT NUMBER IN HARDWARE FORMAT LDB F,[331000,,T] ;GET EXPONENT (CANNOT BE LARGER THAN 200+33) TLZ T,377000 ;CLEAR EXPONENT FROM FRACTION PUSH FXP,TT SETZ D, ASHC TT,-233(F) ;CALCULATE LOW ALIGNED FRACTION WORD PUSH FXP,D MOVE TT,-1(FXP) ASHC T,-233(F) ;CALCULATE HIGH ALIGNED FRACTION WORD MOVEM TT,-1(FXP) ;INTEGER PART IS IN T KA MOVE TT,-3(FXP) ;GET MASK INTO TT AND D KA MOVE D,-2(FXP) KA ASH D,10 ;CONVERT TO HARDWARE FORMAT KIKL DMOVE TT,-3(FXP) LDB F,[331000,,TT] ;GET EXPONENT TLZ TT,377000 ;CLEAR EXPONENT, LEAVING FRACTION SUBI F,(B) ASHC TT,-200+4(F) ;CALCULATE MASK FRACTION VALUE, BINARY POINT BELOW BIT 4.5 KA MOVEM TT,-3(FXP) ;SAVE IT BACK ON FXP KA MOVEM D,-2(FXP) KIKL DMOVEM TT,-3(FXP) MOVE TT,T ;PUT INTEGER PART IN TT MOVEI C,10. ;PRINT INTEGER PART IN RADIX 10. PUSHJ P,PRINI3 ;PRESERVES B %DCML% POP FXP,TT POP FXP,T ASHC T,-4 ;ALIGN FRACTION SO BINARY POINT IS BELOW BIT 4.5 ;FALLS THROUGH ;;; IFN DBFLAG ;FALLS IN ;FRACTION IN T,TT WITH BINARY POINT BELOW BIT 4.5; MASK IN -1(FXP),(FXP) DFP3A: IMULI T,10. ;MULTIPLY FRACTION BY 10. MULI TT,10. ADD T,TT MOVE TT,D LDB A,[370400,,T] ;GET NEXT DIGIT (BITS 4.8-4.5) IN A MOVEI A,"0(A) ;MAKE IT ASCII TLZ T,360000 ;FORM REMAINDER IN TT,D EXCH T,-1(FXP) ;EXCHANGE FRACTION WITH MASK EXCH TT,(FXP) IMULI T,10. ;MULTIPLY MASK BY 10. MULI TT,10. ADD T,TT MOVE TT,D CAMGE T,-1(FXP) JRST DFP3A1 CAMG T,-1(FXP) CAMLE TT,(FXP) JRST DFP3A8 ;LAST DIGIT IF MASK > FRACTION DFP3A1: KA SETCM D,T ;NEGATE MASK KA MOVN F,TT KA TLZ F,400000 KA SKIPN F KA ADDI D,1 KIKL MOVE D,T KIKL MOVE F,TT KIKL DMOVN T,T KA TLZ D,760000 ;FORM 1-MASK KIKL TLZ T,760000 KA CAMLE D,-1(FXP) KIKL CAMLE T,-1(FXP) JRST DFP3A2 KA CAML D,-1(FXP) KIKL CAML T,-1(FXP) KA CAMGE F,(FXP) KIKL CAMGE TT,(FXP) AOJA A,DFP3A9 ;LAST DIGIT, ROUNDED UP, IF FRACTION > 1-MASK DFP3A2: KA EXCH T,-1(FXP) ;EXCHANGE BACK MASK FOR FRACTION KA EXCH TT,(FXP) KIKL DMOVE T,-1(FXP) KIKL MOVEM D,-1(FXP) KIKL MOVEM F,(FXP) PUSHJ P,(R) ;OTHERWISE OUTPUT DIGIT AND JRST DFP3A ; GO AROUND AGAIN DFP3A8: MOVE TT,-1(FXP) ;ROUND LAST DIGIT UP IF FRACTION >= 1/2 TLNE TT,10000 ADDI A,1 DFP3A9: SUB FXP,R70+2 JRST (R) KIKL D10.0: 10.0 ? 0 KIKL D1.0E8: 1.0^8 ? 0 ] ;END OF IFN DBFLAG ;HERE ON FLONUMS < 0.01 (DB%) OR < 0.1 (DB$) FP4: JUMPN T,FP4E ;FLOATING POINT "E" FORMAT DB$ CAILE B,33 ;FOR DOUBLE PRECISION, DB$ PUSH P,[[%D% ? JRST FP4A]] ;PRINT "0.0D0" CLEVERLY PUSHJ P,FP4A ;CLEVER WAY TO PRINT OUT "0.0" QUICKLY %DCML% FP4A: MOVEI A,"0 JRST (R) ;HERE ON FLONUMS >= 1.0E8 FP4E0: KA FDVL T,[1.0^8] ;BE DOUBLY PRECISE IN DIVIDING KA FDVR TT,[1.0^8] ; BY 10^8 TO GET NUMBER IN RANGE KA FADL T,TT KIKL DFDV T,D1.0E8 IFN DBFLAG,[ EXCH T,-1(FXP) EXCH TT,(FXP) KA FDVL T,[1.0^8] ;DIVIDE MASK TOO KA FDV TT,[1.0^8] ;UNROUNDED! KA FADL T,TT KIKL DFDV T,D1.0E8 EXCH T,-1(FXP) EXCH TT,(FXP) ] ;END OF IFN DBFLAG ADDI F,8 CAML T,[1.0^8] JRST FP4E0 ;KEEP DIVIDING UNTIL < 10^8 FP4E1: CAMGE T,[10.0] JRST FP4B KA FDVL T,[10.0] ;NOW REDUCE UNTIL < 10.0 KA FDVRI TT,(10.0) KA FADL T,TT KIKL DFDV T,D10.0 IFN DBFLAG,[ EXCH T,-1(FXP) EXCH TT,(FXP) KA FDVL T,[10.0] ;DIVIDE MASK TOO KA FDV TT,[10.0] ;UNROUNDED! KA FADL T,TT KIKL DFDV T,D10.0 EXCH T,-1(FXP) EXCH TT,(FXP) ] ;END OF IFN DBFLAG AOJA F,FP4E1 ;HERE FOR NON-ZERO FLONUMS < 0.01 (DB%) OR < 0.1 (DB$) FP4E: CAML T,[1.0^-8] ;BE DOUBLY PRECISE IN MULTIPLYING BY 10^8 JRST FP4E2A KA FMPR TT,[1.0^8] KA MOVEM TT,D KA FMPL T,[1.0^8] KA UFA TT,D KA FADL T,D KIKL DFMP T,D1.0E8 IFN DBFLAG,[ EXCH T,-1(FXP) EXCH TT,(FXP) KA FMP TT,[1.0^8] ;UNROUNDED! MULTIPLY MASK TOO KA MOVEM TT,D KA FMPL T,[1.0^8] KA UFA TT,D KA FADL T,D KIKL DFMP T,D1.0E8 EXCH T,-1(FXP) EXCH TT,(FXP) ] ;END OF IFN DBFLAG SUBI F,8 JRST FP4E FP4E2: KA FMPRI TT,(10.0) ;NOW INCREASE UNTIL >= 1.0 KA MOVEM TT,D KA FMPL T,[10.0] KA UFA TT,D KA FADL T,D KIKL DFMP T,D10.0 IFN DBFLAG,[ EXCH T,-1(FXP) EXCH TT,(FXP) KA FMP TT,[10.0] ;UNROUNDED! MULTIPLY MASK TOO KA MOVEM TT,D KA FMPL T,[10.0] KA UFA TT,D KA FADL T,D KIKL DFMP T,D10.0 EXCH T,-1(FXP) EXCH TT,(FXP) ] ;END OF IFN DBFLAG FP4E2A: CAMGE T,[1.0] SOJA F,FP4E2 ;HERE WHEN NUMBER BETWEEN 1.0 (INCL) AND 10.0 (EXCL); F IS THE EXPONENT TO BE PRINTED. FP4B: IFE DBFLAG,[ KIKL TLNN TT,200000 ;DECIDE WHETHER ROUNDING WILL HAVE ANY EFFECT KIKL JRST FP4B1 KIKL HLLZ TT,T ;IF SO, CREATE A FLONUM WHOSE VALUE IS KIKL TLZ TT,777 ; 1/2 LSB OF FRACTION IN T KIKL ADD TT,[777000,,1] FADR T,TT ;ADD LOW PART TO HIGH PART, ROUNDING CAMGE T,[10.0] ;ROUNDING UP MAY TAKE US OUT OF RANGE AGAIN JRST FP4B1 FDVRI T,(10.0) ADDI F,1 ;ADJUST EXPONENT FOR THE DIVISION ] ;END OF IFE DBFLAG ;FOR DB$, JUST LET THE EXTRA INFO BITS SIT THERE, EVEN FOR SINGLE PRECISION! ; AFTER ALL, THE MASK HAS ALSO BEEN COMPUTED TO DOUBLE PRECISION FP4B1: PUSH FLP,F ;DON'T USE FXP! WILL CONFLICT WITH MASK FOR DB$ PUSHJ P,FP3 ;NUMBER HAS BEEN NORMALIZED FOR 1.0 .LE. X < 10.0 DB$ CAILE B,33 DB$ %D% ;FOR DOUBLE PRECISION, "D" INDICATES EXPONENT DB$ CAIG B,33 %E% ;FOR SINGLE PRECISION, "E" INDICATES EXPONENT POP FLP,TT ;POP EXPONENT SKIPLE TT ;PRINT SIGN (BUT PRINT NO SIGN FOR 0) %POS% SKIPGE TT %NEG% MOVEI C,10. MOVMS TT JRST PRINI3 ;PRINT EXPONENT AS A DECIMAL INTEGER SUBTTL PRINT A COMPLEX OR A DUPLEX IFN CXFLAG,[ PRINCX: IFN USELESS,[ MOVEI T,35. SKIPN @-1(P) MOVEI T,18. PUSHJ P,PRINLP ] ;END OF IFN USELESS SKIPE T,@-1(P) ;DON'T PRINT REAL PART IF 0 PUSHJ P,FP0 KA HRRZ A,-1(P) KA MOVE T,(A) KA MOVE TT,1(A) KIKL DMOVE T,@-1(P) JUMPE T,PRNCX2 SKIPL TT %POS% PRNCX2: JUMPE TT,PRNCX4 SKIPGE TT %NEG% MOVM T,TT PUSHJ P,FP0 PRNCX3: MOVEI A,"J ;CROCK JRST (R) PRNCX4: MOVEI A,"0 PUSHJ P,(R) JRST PRNCX3 ] ;END OF IFN CXFLAG IFN DXFLAG,[ PRINDX: IFN USELESS,[ MOVEI T,60. SKIPN @-1(P) MOVEI T,30. PUSHJ P,PRINLP ] ;END OF IFN USELESS KA HRRZ A,-1(P) KA MOVE T,(A) KA MOVE TT,1(A) KIKL DMOVE T,@-1(P) SKIPE T ;DON'T PRINT REAL PART IF 0 PUSHJ P,DFP0 HRRZ A,-1(P) KA MOVE T,2(A) KA MOVE TT,3(A) KIKL DMOVE T,2(A) SKIPN @-1(P) JRST PRNDX2 SKIPL T %POS% PRNDX2: JUMPE T,PRNCX4 SKIPGE T %NEG% JUMPGE T,PRNDX5 KA DFN T,TT KIKL DMOVN T,T PRNDX5: PUSHJ P,DFP0 JRST PRNCX3 ] ;END OF IFN DXFLAG IFN BIGNUM,[ SUBTTL PRINT A BIGNUM PRINB: IFN USELESS,[ HRRZ B,@-1(P) MOVEI T,1 PRINB0: ADDI T,12. HRRZ B,(B) JUMPN B,PRINB0 PUSHJ P,PRINLP ] ;END OF IFN USELESS HRRZ A,-1(P) SKIPGE A,(A) JRST PRINBQ IFE USELESS, HRRZ D,@VBASE IFN USELESS,[ HRRZ D,VBASE CAIE D,QROMAN SKIPA D,(D) MOVEI D,10. ] ;END OF IFN USELESS CAILE D,10. %POS% JRST PRINBZ PRINBQ: %NEG% ;NEGATIVE BIGNUM PRINBZ: MOVEM R,RSAVE HRRZM P,FSAVE ;STORE PDL POSITION SO AR1 AND AR2A CAN BE FOUND PUSH P,AR1 PUSH P,AR2A PUSHJ P,YPOCB PUSH P,A PUSH P,[PRINB4] MOVE B,VBASE IFN USELESS,[ CAIN B,QROMAN SKIPA D,[10.] ] ;END OF IFN USELESS JSP T,FXNV2 MOVE C,D JSP T,PRI. MOVE R,D MOVEI F,1 MOVE T,D PRBAB: MUL T,D JUMPN T,.+4 MOVE T,TT MOVE R,TT AOJA F,PRBAB MOVEM F,NORMF MOVE D,R PRINB3: MOVE C,A HLRZ B,(C) MOVE F,(B) MOVEI R,0 PNFBLP: DIV R,D MOVEM R,(B) MOVE B,(C) TRNN B,-1 JRST PRBFIN MOVE C,(C) MOVE R,F HLRZ B,(C) MOVE F,(B) JRST PNFBLP PRBFNA: HLR A,B PRBFIN: MOVS B,(A) TLNE B,-1 SKIPE (B) JRST .+2 JRST PRBFNA PUSH FXP,F MOVE R,(A) TRNN R,-1 JRST PRBNUF PUSHJ P,PRINB3 PRINBI: POP FXP,TT MOVE F,NORMF MOVE R,RSAVE PRINBJ: SETZ T, JSP D,PRINI5 SOJE F,FP7A1 MOVE TT,T PUSHJ P,PRINBJ JRST FP7A1 PRBNUF: HLRZ A,R MOVE TT,(A) MOVE AR2A,FSAVE MOVE AR1,1(AR2A) ;RESTORE AR1 AND AR2A MOVE AR2A,2(AR2A) HRRZ C,VBASE IFN USELESS, CAIN C,QROMAN IFN USELESS, SKIPA R,[10.] JSP T,FXNV3 MOVE C,R MOVE R,RSAVE SKIPE TT PUSHJ P,PRINI3 JRST PRINBI PRINB4: POP P,A MOVEI B,TRUTH PUSHJ P,RECLAIM POP P,AR2A POP P,AR1 POPJ P, ] ;END OF IFN BIGNUM SUBTTL FLATSIZE, FLATC, EXPLODEC, EXPLODEN, EXPLODE FLATSIZE: PUSH P,CFIX1 ;SUBR 1 SKOTTN A,LS IFN HNKLOG,[ TLNN TT,HNK JRST FLAT5 PUSHJ P,USRHNP ;Is this a user's extended hunk? JUMPE T,FLAT5 SETZ B, ;Say we aren't PRINT SETZ R, ;Say to do slashification PUSHJ P,SENDFL MOVE TT,(A) ;Get the result POPJ P, ;And make it into a FIXNUM ] ; End of IFN HNKLOG, FLAT5: SKIPA R,CFLAT2 ;POPJ IS POSITIVE FLAT4: HRROI R,FLAT2 FLAT3: SETZM FLAT1 PUSHJ P,PRINTF SKIPA TT,FLAT1 FLAT2: AOS FLAT1 CFLAT2: POPJ P,FLAT2 IFN HNKLOG,[ %FLO: ;(FLATSIZE-OBJECT object printp i-depth slash) FLATOBJECT: ;LSUBR (4 . 5) JSP TT,LWNACK ;Check number of arguments LA45,,Q%FLO CAMN T,IN0-5 ;5 args? POP P,AR1 ; Yes, throw one away POP P,AR1 POP P,C POP P,B POP P,A PUSH P,CFIX1 MOVE TT,(C) MOVEM TT,PRINLV MOVE R,[PR.ATR,,FLAT2] SKIPE B ;Is this from inside print? HRRI R,FLATO2 ; Yes, fake out PRINT to think it's from print SKIPN AR1 ;Slashify? TLO R,PR.PRC ; Nope, tell PRINT not to. SETZM FLAT1 PUSHJ P,PRINTF MOVE TT,FLAT1 POPJ P, FLATO2: AOS FLAT1 POPJ P, ]; END of IFN HNKLOG, FLATC: PUSH P,CFIX1 ;SUBR 1 SKOTTN A,LS IFN HNKLOG,[ TLNN TT,HNK JRST FLAT7 PUSHJ P,USRHNP ;Is this a user-extend HUNK? JUMPE T,FLAT7 ;Maybe not SETZ AR1 ;Say not from PRINT SETO R, ;Say no slashification SETZ B, ;Say we aren't print PUSHJ P,SENDFL ;Send it the message to get value to return MOVE TT,(A) ;Get result (better be fixnum) POPJ P, ;We'll definately return a fixnum! (we cons it) ] ; End of IFN HNKLOG, FLAT7: TLNN TT,SY JRST FLAT7A FLATC1: HLRZ TT,(A) ;FAST-FLATC FOR SYMBOLS HRRZ A,1(TT) FLTC1A: SETZ TT, FLATC2: HRRZ B,(A) ;COUNT 5 CHARS PER PNAME WORD ADDI TT,BYTSWD JUMPE B,FLATC3 HRRZ A,(B) ADDI TT,BYTSWD JUMPN A,FLATC2 MOVEI A,(B) FLATC3: HLRZ A,(A) ;LAST PNAME WORD MAY BE PARTIAL SKIPN T,(A) ;WATCH OUT FOR NULL PNAME! SUBI TT,1 TRNE T,177_1 POPJ P, TRNE T,177_10 SOJA TT,CPOPJ SUBI TT,3 TDNE T,[177_17] AOJA TT,CPOPJ TLNN T,(177_26) SUBI TT,1 POPJ P, FLAT7A: JUMPN A,FLAT4 HRRZ A,$$$NIL+1 JRST FLTC1A $EXPLODEC: PUSHJ P,USRHPP ;Is this a user hunk? JUMPN T,$$EXPU ;If so, send an EXPLODEC message MOVE R,EXPL0 ;SUBR 1 ;HRRZI IS NEGATIVE!!! JRST $$EXP1 $$EXPU: PUSH P,A PUSH P,[QEXPLODE] PUSH P,NIL ;SLASHIFY-P PUSH P,NIL ;NUMBER-P JRST $$EXSN $$EXPLODEN: PUSHJ P,USRHPP ;Is this a user hunk? JUMPE T,$$EXP0 ;Nope, hack normally PUSH P,A PUSH P,[QEXPLODE] PUSH P,[TRUTH] ;SLASHIFY-P PUSH P,[TRUTH] ;NUMBER-P $$EXSN: MOVNI T,4 XCT SENDI ;Never returns $$EXP0: HRROI R,EXPL2 ;SUBR 1 $$EXP1: SKOTT A,SY JRST EXPL4 HLRZ T,(A) HRRZ A,1(T) PUSH P,R70 ;FORMING LIST OF CHARS MOVEI B,(P) PUSH P,A PUSH P,B XOR R,EXPL0 PUSH FXP,R EXPLY1: SKIPN A,-1(P) JRST EXPLY9 HLRZ B,(A) MOVE D,(B) HRRZ A,(A) MOVEM A,-1(P) EXPLY2: JUMPE D,EXPLY1 SETZ TT, LSHC TT,7 SKIPE (FXP) JRST EXPLY3 PUSH FXP,D PUSHJ P,RDCH2 POP FXP,D JRST EXPLY4 EXPLY3: MOVEI A,IN0(TT) .SEE HINUM EXPLY4: PUSHJ P,NCONS HRRM A,@(P) HRRZM A,(P) JRST EXPLY2 EXPLY9: SUB P,R70+2 SUB FXP,R70+1 JRST POPAJ EXPLODE: PUSHJ P,USRHPP ;Is it a USERHUNK? JUMPE T,EXPL0 PUSH P,A PUSH P,[QEXPLODE] PUSH P,[TRUTH] ;SLASHIFY-P PUSH P,NIL ;NUMBER-P JRST $$EXSN EXPL0: HRRZI R,EXPL1 ;SUBR 1 EXPL4: PUSH P,R70 HRRZM P,EXPL5 PUSHJ P,PRINTF JRST POPAJ EXPL1: SAVE B C SAVEFX TT R ANDI A,177 PUSHJ P,RDCH3 POP P,C EXPL3: PUSHJ P,NCONS HRRM A,@EXPL5 HRRZM A,EXPL5 EXPL6: RSTRFX R TT JRST POPBJ EXPL2: PUSH P,B SAVEFX TT R MOVEI A,IN0(A) JRST EXPL3 SUBTTL BAKTRACE BAKTRACE: ;PRINT A BAKTRACE JSP TT,LWNACK LA01,,QBAKTRACE MOVNI TT,1 JRST BKTR0 BAKLIST: ;RETURN A LIST (SIMILAR TO PRINTED FORMAT) JSP TT,LWNACK LA01,,QBAKLIST MOVSI TT,400000 BKTR0: MOVEM TT,BACTYF ;TYPE FLAG FOR BAKTRACE/BAKLIST MOVEI A,NIL ;START WITH NIL SKIPE T ;OR USER SUPPLIED ARG POP P,A JSP R,GTPDLP ;GET APPROPRIATE PDL POINTER 0 JFCL MOVEI A,(D) ;SAVE PDL POINTER IN A MOVE B,(A) ;GET TOP OF STACK CAME B,[QBAKTRACE,,CPOPJ] CAMN B,[QBAKLIST,,CPOPJ] SOS A ;SKIP FIRST SLOT IF CALL TO US MOVEI R,60 ;LOOK AT ABOUT 60 STACK LOCATIONS HRRZ TT,C2 ;GET PDL ORIGION SUBM A,TT ;SAVE PDL OFFSET IN TT CAIG TT,(R) ;FEWER THAN 60 LOCATIONS TO LOOK AT? MOVE R,TT ;YES, SO LOOK AT THAT MANY MOVE T,A SETZM CPJSW ;ASSUME *RSET HAS BEEN OFF MOVEI B,CPOPJ BKTR3: MOVE TT,(T) ;CUT OUT STUFF FROM *RSET LOOP, IF USED CAIN B,(TT) TLNN TT,-1 SKIPA SETOM CPJSW ;APPARENTLY *RSET HAS BEEN ON TLZ TT,-1#10000 CAMN TT,[10000,,LSPRET] MOVEI A,-1(T) SOS T SOJG R,BKTR3 MOVEM A,BKTRP ;SET UP FOR BAKTRACE LOOP AND GO THERE MOVE A,BACTYF AOJE A,BKTR2 ;IF TRACING THEN SKIP LIST HACKING STUFF PUSH P,R70 ;SET UP LIST TO HOLD BAKLISTING HRLM P,(P) ;SET UP LAST-OF-LIST POINTER BKTR2: HRRZ A,C2 ;THE PDL-HUNTING LOOP ADDI A,1 CAML A,BKTRP JRST BKTR2X ;EXIT WHEN BACKED UP TO BOTTOM OF PDL AOSN BACTYF STRT [SIXBIT \^MBAKTRACE^M!\] HRRZ A,@BKTRP CAIN A,CPOPJ ;IN *RSET MODE, THIS IS A TAG JRST BKTR1C ;PUT ON PDL UPON ENTRY TO A FUNCTION CAIN A,ILIST3 JRST BKTR1B MOVE D,@BKTRP TLNE D,10000#-1 ;TO BE A PUSHJ RETURN ADDR, THERE MUST CAIN A,BKCOM1 ; BE PC FLAGS IN LH JRST BKTR1 CAIL A,BEGFUN CAIL A,ENDFUN JRST BKTR1A CAIE A,CON2 CAIN A,CON3 JRST BKTR1G CAIN A,PG0A JRST BKTR1E CAIN A,LMBLP1 JRST BKTR1 CAILE A,BRLP1 CAILE A,BRLP2 SKIPA JRST BKTR1H CAIN A,REKRD1 JRST BKTRR3 CAIE A,UNBIND JRST BKTR1A BKTR1: SOS BKTRP JRST BKTR2 BKTR2X: AOSE BACTYF SKIPL BACTYF JRST TERPRI POP P,A JRST RHAPJ BKTR1A: CAMGE A,@VBPORG ;LETS HOPE THAT BPORG ISN'T SCREWED UP CAIGE A,BBPSSG JRST BKTR1 BK1A2: MOVEI AR1,-1(A) BK1A4: HLRZ B,-1(A) ;SOMEWHERE IN BINARY PROGRAMS MOVEI R,PRIN1B ;IF "CALL", THEN SUBR ATOM NAME WILL BE IN B TRC B,37 ;LIKELY NOT AN INSTRUCTION IF ALL THE INDIRECT, TRCE B,37 ; AND INDEXING BITS ARE ONES CAIGE B,(CALL ) JRST BKTR1 CAIG B,(JCALLF 17,) JRST BK1A1 CAIE B,(XCT) ;MIGHT BE A XCT OF A CALL, JRST, PUSHJ TO SUBR JRST .+3 HRRZ A,-1(A) ;IF SO, CYCLE TO TRY TO FIND CALLED SUBR NAME AOJA A,BK1A4 MOVEI R,ERRADR ;HA! MAYBE PUSHJ OR JRST, SO NOW WE HAVE CAIN B,(JRST 0,) ; ONLY BEGINNING ADDRESS OF SUBR. HENCE JRST BK1A1 ; IT HAS TO BE DECODED INTO ATOM NAME. CAIE B,(PUSHJ P,) JRST BKTR1 ;LOSE, DON'T KNOW WHAT KIND OF INST THIS IS HLLZ B,@BKTRP TLNN B,10000 ;USER MODE FLAG - STOPS RANDOM JRST BKTR1 ; DATA NOT ENTERED BY PUSHJ BK1A1: MOVE B,-1(A) ;EITHER "(J)CALL(F)", "JRST", OR "PUSHJ P," TLNE B,7777760 ;LET INDIRECTION HAPPEN, BUT CAN'T CHANCE TLNE B,((17)) ; DOING IT IF THE UUO IS INDEXED, OR JRST BK1A1B ; ADDRESSES AN AC MOVEI B,@-1(A) ;LET INDIRECT DO ITS THING BK1A1C: PUSH P,AR1 ;ORIGINAL PC WHEREFROM SUBR WAS CALLED SKIPGE BACTYF JRST BK1A3 PUSHJ P,(R) ;R HAS EITHER PRIN1B OR ERRADR STRT [SIXBIT \_!\] ; DEPENDING ON WHETHER "CALL" OR "PUSHJ P," POP P,B PUSHJ P,ERRADR STRT [SIXBIT \ !\] JRST BKTR1 BK1A3: CAIE R,ERRADR SKIPA A,B PUSHJ P,ERRDCD ;"ERRDCD" DECODES ADDRESS IN B, GETS ATOM IN A EXCH A,(P) PUSHJ P,ERRDCD PUSH P,[QLA] PUSH P,A MOVNI T,3 JRST BKT1F2 BK1A1B: CAIN R,ERRADR TDZA B,B MOVEI B,QM JRST BK1A1C BKTR1B: MOVE D,BKTRP HRRZ B,-1(D) ;PROBABLY FOR ENTRY TO SOME SUBR, LSUBR, OR EXPR CAIE B,ELSB1 ;LISTING TINGS UP ON THE PDL CAIN B,ESB1 JRST .+3 CAIE B,IAPPLY JRST BKTR1 HLRE B,-1(D) ADDI B,-3(D) HLRZ A,(B) JUMPE A,BKTR1 HRRZM B,BKTRP SKIPGE BACTYF JRST BKT1B1 STRT [SIXBIT \(!\] PUSHJ P,PRIN1 STRT [SIXBIT \ EVALARGS) !\] JRST BKTR1 BKTR1C: HLRZ A,@BKTRP ;PROBABLY ENTERED AN F-TYPE FUNCTION JUMPE A,BKTR1 ;WELL, NIL ISN'T REALLY A FUNCTION BKTR1F: SKIPGE BACTYF JRST BKT1F1 PUSHJ P,PRIN1 STRT [SIXBIT \_ !\] JRST BKTR1 BKT1B1: SKIPA B,[QEVALARGS] BKT1F1: MOVEI B,QLA PUSH P,A PUSH P,B MOVNI T,2 BKT1F2: PUSHJ FXP,LISTX PUSHJ P,NCONS HLRZ B,(P) HRRM A,(B) ;NCONC MOST RECENT GOODIE ONTO END OF LIST HRLM A,(P) ;UPDATE LAST-OF-LIST POINTER JRST BKTR1 BKTR1H: MOVNI T,LERSTP+5-1 ;2 FROM BREAK, 2 FROM EDERRL, 1 FROM BRLP = 5 MOVEI A,QBREAK ;-1 SINCE BKTR1 WILL TAKE OFF ONE MORE JRST BKTR1D BKTR1E: MOVNI T,LPRP ;BACK UP OFF A PROG MOVEI A,QPROG BKTR1D: ADDM T,BKTRP JRST BKTR1I BKTR1G: MOVEI A,QCOND ;FOUND A COND ENTRY BKTR1I: SKIPE CPJSW JRST BKTR1 ;IF *RSET WAS ON, ENTRY IS BE MARKED BY CPOPJ JRST BKTR1F BKTRR3: SKIPA T,XC-3 BKTRR5: MOVNI T,5 ADDM T,BKTRP JRST BKTR1 PGTOP PRT,[PRINT,TYO,EXPLODE,FLATC,BAKTRACE,ETC] ;;@ END OF PRINT 282 ;;@ ULAP 142 UTAPE, LAP, AND AGGLOMERATED SUBRS ;;; ***** MACLISP ****** UTAPE, LAP, AND AGGLOMERATED SUBRS ****** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT [UIO] SUBTTL OLD I/O FUNCTIONS IN TERMS OF NEW I/O PRIMITIVES ;;; (DEFUN UREAD FEXPR (FILENAME) ;;; (UCLOSE) ;;; ((LAMBDA (FILE) ;;; (EOFFN UREAD ;;; (FUNCTION ;;; (LAMBDA (EOFFILE EOFVAL) ;;; (UCLOSE) ;;; EOFVAL))) ;;; (INPUSH (SETQ UREAD FILE)) ;;; (DEFAULTF FILE)) ;;; (OPEN (*UGREAT FILENAME) 'IN))) UREAD: PUSH P,A ;FEXPR PUSHJ P,UCLOSE POP P,A PUSHJ P,UGREAT PUSH P,[UREAD2] PUSH P,A MOVNI T,1 JRST $EOPEN UREAD2: MOVEM A,VUREAD PUSH P,[UREAD1] PUSH P,A PUSH P,[QUREOF] MOVNI T,2 JRST EOFFN UREAD1: HRRZ A,VUREAD PUSHJ P,INPUSH PUSHJ P,DEFAULTF HRRZ A,VUREAD JRST TRUENAME ;RETURN TRUENAME OF FILE TO USER UREOF: PUSH P,B ;+INTERNAL-UREAD-EOFFN - SUBR 2 PUSHJ P,UCLOSE JRST POPAJ ;;; (DEFUN UCLOSE FEXPR (X) ;;; (COND (UREAD ;;; ((LAMBDA (OUREAD) ;;; (AND (EQ OUREAD INFILE) (INPUSH -1)) ;;; (SETQ UREAD NIL) ;;; (CLOSE OUREAD)) ;;; UREAD)) ;;; (T NIL))) UCLOSE: SKIPN A,VUREAD ;FEXPR POPJ P, CAMN A,VINFILE PUSHJ P,INPOP ;SAVES A SETZM VUREAD JRST $CLOSE ;;; (DEFUN UWRITE FEXPR (DEVDIR) ;;; (OR DEVDIR (SETQ DEVDIR (CAR (DEFAULTF NIL)))) ;;; (*UWRITE (CONS DEVDIR ;;; (COND ((STATUS FEATURE DEC10) ;;; (CONS (STATUS JNAME) '(OUT))) ;;; ((STATUS FEATURE DEC20) ;;; '(MACLISP OUTPUT)) ;;; ((STATUS FEATURE ITS) ;;; '(.LISP. OUTPUT)))) ;;; 'OUT ;;; (LIST DEVDIR))) ;;; ;;; (DEFUN UAPPEND FEXPR (FILENAME) ;;; (SETQ FILENAME (*UGREAT FILENAME)) ;;; (*UWRITE FILENAME 'APPEND FILENAME)) ;;; ;;; (DEFUN *UWRITE (NAME MODE NEWDEFAULT) ;INTERNAL ROUTINE ;;; (COND (UWRITE ;;; (SETQ OUTFILES (DELQ UWRITE OUTFILES)) ;;; (CLOSE UWRITE) ;;; (SETQ UWRITE NIL))) ;;; ((LAMBDA (FILE) ;;; (SETQ OUTFILES ;;; (CONS (SETQ UWRITE FILE) ;;; OUTFILES)) ;;; (CAR (DEFAULTF NEWDEFAULT))) ;;; (OPEN NAME MODE))) UAPPEND: PUSHJ P,UGREAT ;FEXPR MOVEI C,(A) MOVEI B,QAPPEND JRST UWRT1 UWRITE: JUMPN A,UWRT0 ;FEXPR PUSHJ P,DEFAULTF HLRZ A,(A) UWRT0: PUSHJ P,NCONS IFN ITS+D20,[ MOVEI C,(A) HLRZ A,(C) MOVEI B,QLSPOUT PUSHJ P,CONS ] ;END OF IFN ITS+D20 IFN D10,[ PUSH P,A PUSHJ P,SJNAME MOVEI B,Q$OUT PUSHJ P,CONS POP P,C HLRZ B,(C) PUSHJ P,XCONS ] ;END OF IFN D10 MOVEI B,Q$OUT UWRT1: PUSH P,C ;*UWRITE BEGINS HERE PUSH P,[UWRT2] PUSH P,A PUSH P,B SKIPE VUWRITE PUSHJ P,UFILE5 MOVNI T,2 JRST $OPEN UWRT2: MOVEM A,VUWRITE HRRZ B,VOUTFILES PUSHJ P,CONS MOVEM A,VOUTFILES POP P,A PUSHJ P,DEFAULTF JRST $CAR ;;; (DEFUN UFILE FEXPR (SHORTNAME) ;;; (COND ((NULL UWRITE) ;;; (ERROR 'NO/ UWRITE/ FILE ;;; (CONS 'UFILE SHORTNAME) ;;; 'IO-LOSSAGE)) ;;; (T (PROG2 NIL ;;; (DEFAULTF (RENAMEF UWRITE (*UGREAT SHORTNAME))) ;;; (SETQ OUTFILES (DELQ UWRITE OUTFILES)) ;;; (SETQ UWRITE NIL) ;;; (OR OUTFILES (SETQ ^R NIL)))))) UFILE0: MOVEI B,QUFILE PUSHJ P,XCONS IOL [NO UWRITE FILE!] UFILE: SKIPN VUWRITE ;FEXPR JRST UFILE0 PUSHJ P,UGREAT MOVEI B,(A) SETZ A, EXCH A,VUWRITE PUSH P,A PUSH P,B HRRZ B,VOUTFILES PUSHJ P,.DELQ MOVEM A,VOUTFILES SKIPN VOUTFILES SETZM TAPWRT POP P,B POP P,A PUSHJ P,$RENAME ;CLOSES THE FILE AS WELL AS RENAMES IT PUSHJ P,DEFAULTF POPJ P, UFILE5: HRRZ A,VUWRITE HRRZ B,VOUTFILES PUSHJ P,.DELQ MOVEM A,VOUTFILES HRRZ A,VUWRITE PUSHJ P,$CLOSE SETZM VUWRITE SKIPN VOUTFILES SETZM TAPWRT POPJ P, ;;; (DEFUN CRUNIT FEXPR (DEVDIR) ;;; (CAR (DEFAULTF (AND DEVDIR (LIST DEVDIR))))) SCRUNIT: SETZ A, CRUNIT: SKIPE A ;FEXPR PUSHJ P,NCONS PUSHJ P,DEFAULTF JRST $CAR ;;; (DEFUN *UGREAT (NAME) ;INTERNAL ROUTINE ;;; (MERGEF NAME ;;; (COND ((STATUS FEATURE ITS) '(* . >)) ;;; ('(* . LSP))))) UGREAT: PUSH P,[6BTNML] UGRT1: PUSHJ P,FIL6BT IFN ITS+D10,[ REPEAT 3, PUSH FXP,[SIXBIT \*\] IT$ PUSH FXP,[SIXBIT \>\] SA$ PUSH FXP,[SIXBIT \___\] SA% 10$ PUSH FXP,[SIXBIT \LSP\] 10$ SETOM -2(FXP) ;FOR D10 DEFAULT PPN IS -1 ] ;END OF IFN ITS+D10 IFN D20,[ PUSHN FXP,L.F6BT MOVE T,[ASCII \LSP\] MOVEM T,-L.6EXT-L.6VRS+1(FXP) ] ;END OF IFN D20 JRST IMRGF ;;; (DEFUN UPROBE FEXPR (FILENAME) ;;; (SETQ FILENAME (MERGEF (*UGREAT FILENAME) NIL)) ;;; (PROBEF FILENAME)) UPROBE: PUSHJ P,UGRT1 ;FEXPR JRST PROBF0 ;;; (DEFUN UKILL FEXPR (FILENAME) ;;; (DEFAULTF (DELETEF FILENAME)))) UKILL: PUSHJ P,$DELETEF JRST DEFAULTF SUBTTL SYMBOL MANIPULATION AND SQUOZE FUNCTIONS ;;; (TTSR| ) GETS THE ARRAY PROPERTY OF , ;;; OR GIVES IT AN ARRAY PROPERTY WITH A DEAD SAR; ;;; IT MARKS THE SAR AS BEING NEEDED BY COMPILED CODE, ;;; AND THEN RETURNS THE ADDRESS OF THE TTSAR AS A FIXNUM. ;;; THIS IS USED PRIMARILY BY LAP. TTSR: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE (TTSR|) MOVEI C,(A) ;SAVES AR1,R,F - SEE FASLOAD PUSHJ P,ARGET JUMPN A,TTSR1 JSP T,SACONS MOVEI T,ADEAD MOVEM T,ASAR(A) MOVE T,[TTDEAD] MOVEM T,TTSAR(A) MOVEI B,(A) MOVEI A,(C) MOVEI C,QARRAY PUSHJ P,PUTPROP TTSR1: MOVSI T,TTS.CN IORM T,TTSAR(A) MOVEI TT,1(A) POPJ P, ;;; BOTH ROUTINES ALWAYS RETURN THE LEFT-JUSTIFIED SQUOZE IN T ;;; AND THE SIXBIT IN R ;;; RSQUEEZE MAY LEAVE RIGHT-JUSTIFIED SQUOZE IN TT RSQUEEZE: ;CANONICAL SQUOZE CONVERSION IT% HRROS (P) ;FOR DEC-10, GIVES DEC-10 SQUOZE SQUEEZE: ;THIS ALWAYS GIVES LEFT-JUSTIFIED SQUOZE MOVEI AR1,6 ;CONVERT PNAME-ATOM TO SQUOZE AND SIXBIT MOVE AR2A,[440600,,SQ6BIT] ;RETURNS SQUOZE IN TT, SIXBIT IN SQ6BIT SETZM SQ6BIT ;CLEAR LOCS USED TO ACCUMULATE SETZM SQSQOZ ; SIXBIT AND SQUOZE HRROI R,SQZCHR PUSHJ P,PRINTA ;"PRINT" OUT CHARS OR PNAME IT% MOVE TT,SQSQOZ SKIPA T,SQSQOZ IMULI T,50 SOJGE AR1,.-1 ; MULTIPLY ITS SQUOZE UP TO SIZE IT% MOVE R,(P) IT% TLNN R,1 MOVE TT,T MOVE R,SQ6BIT POPJ P, SQZCHR: TLNN AR2A,770000 ;IGNORE MORE THAN 6 CHARS POPJ P, SUBI A,40 ;CONVERT TO SIXBIT CAIL A,1 ;LOSSAGE IF NOT SIXBIT CHAR CAILE A,77 ; - ALSO, SPACE IS A LOSS MOVEI A,'. ;LOSING NON-SQUOZE CHAR IDPB A,AR2A ;DEPOSIT SIXBIT CHAR CAIL A,'A ;CHECK FOR LETTER CAILE A,'Z JRST SQNOTL SUBI A,'A-13 ;CONVERT TO SQUOZE VALUE SQOK: EXCH T,SQSQOZ IMULI T,50 ADDI T,(A) EXCH T,SQSQOZ SOJA AR1,CPOPJ ;DECR COUNT AND RETURN TO PRINTA SQNOTL: CAIL A,'0 ;CHECK FOR DIGIT CAILE A,'9 JRST SQNOTD SUBI A,'0-1 ;CONVERT TO SQUOZE VALUE JRST SQOK SQNOTD: CAIE A,'$ ;CHECK FOR $ OR % CAIN A,'% JRST SQ%$ MOVEI A,'. ;ANY CHAR OTHER THAN A-Z, 0-9, $, OR % DPB A,AR2A ; DEFAULTS TO . (E.G. *FOOBAR -> .FOOBA) MOVEI A,45-42 SQ%$: ADDI A,42 ;SQUOZE VALUE FOR $,%,. JRST SQOK 5BTWD: PUSH P,CFIX1 $5BTWD: PUSH FXP,R70 5BTWD0: MOVEI C,(A) HRRZ B,(A) JUMPE B,5BTWD1 HLRZ A,(A) JSP T,FXNV1 LSH TT,-2 MOVEM TT,(FXP) MOVEI A,(B) 5BTWD1: HLRZ A,(A) JSP T,SPATOM JRST 5BTWD9 PUSHJ P,SQUEEZE MOVE R,SQ6BIT POP FXP,D DPB D,[400400,,TT] POPJ P, 5BTWD9: SETZM (FXP) MOVEI A,(C) WTA [BAD ARG - SQUOZE!] JRST 5BTWD0 UNSQOZ: LDB T,[004000,,D] ;HAIRY MESS TO CONVERT SETZM LD6BIT ; SQUOZE TO SIXBIT UNSQZ1: IDIVI T,50 ;(THIS IS SEPARATE ROUTINE SO JUMPE TT,UNSQZ2 ; LAP LOSERS CAN USE IT) CAIL TT,45 ;<1SQUOZE .> JRST UNSQZ3 CAIL TT,13 ;<1SQUOZ A> IS 13 ADDI TT,'A-13 ;CONVERT RANGE A - Z , CAIGE TT,13 ;<1SQUOZ 1> IS 1 ADDI TT,'0-1 ;CONVERT RANGE 0 - 9 UNSQZ2: IOR TT,LD6BIT ROT TT,-6 MOVEM TT,LD6BIT JUMPN T,UNSQZ1 MOVE A,[440600,,LD6BIT] ;MAKE SIXBIT INTO AN ATOM JRST READ6C UNSQZ3: SUBI TT,46-'$ ;[1SQUOZ $] IS 46, [1SQOZ .] IS 45 CAIN TT,45-<46-'$> ;CONVERT RANGE $ - % MOVEI TT,'* ;BUT . IS EXCEPTIONAL JRST UNSQZ2 PUTDDTSYM: MOVEI R,0 ;PUTDDTSYM| IS FOR LAP - OFFSETS VALUE BY LOAD OFFSET PUTDD0: IT$ JSP T,SIDDTP ;LOSE IF NO DDT TO GIVE SYMBOL TO IT% 20% SKIPN .JBSYM" JRST FALSE PUSH FXP,R PUSH P,B 10$ SKIPL R ;SEE LDPUT1 PUSHJ P,RSQUEEZE ;SQUEEZE ATOM'S PNAME DOWN TO SQUOZ CODE POP P,B PUSHJ P,GETDDG ;L-JUST SQUOZ IN T, CANONICAL-JUST IN TT JRST PUTDX ;DONT REDEFINE GLOBALSYMS IFE ITS,[ PUSHJ P,GETDDJ JRST PUTDD4 MOVEI F,(D) ] ;END OF IFE ITS PUTDD2: JSP T,FXNV2 ;GET VALUE OF SECOND ARG POP FXP,R ADDI D,(R) ;ADD IN OFFSET IT$ .BREAK 12,[..SSYM,,TT] 10$ MOVEM D,(F) ;NON-ITS LEAVES IN F A PTR TO SYMTAB JRST TRUE ; SLOT WHERE ENTRY IS TO BE MADE IFE ITS,[ PUTDD4: SOSGE SYMLO JRST FALSE MOVE F,R70+2 SUBB F,.JBSYM" TLO TT,100000 ;LOCAL SYMBOL MOVEM TT,(F) AOJA F,PUTDD2 ] ;END OF IFE ITS PUTDX: POPI FXP,1 JRST FALSE SUBTTL LAPSETUP AND FASLAPSETUP LAPSETUP: JUMPN A,LAPSMH ;ARG = NIL => SETUP SOME SYM PROPERTIES MOVEI T,LAPST2 LAP5HAK: PUSH P,T ;APPLIES THE ROUTINE FOUND IN T ; TO ALL THE GLOBALSYMS PUSH P,[441100,,LAP5P] ;ATOMIC SYMBOL PLACED IN A, ; GLOBALSYM INDEX IN TT MOVSI F,-LLSYMS L5H1: ILDB TT,(P) ;HAFTA GET THE GLOBALSYM INDEX FROM ; PERMUTATION TABLE CAIL TT,LGSYMS ;IF NOT A GLOBALSYM [BUT AN XTRASYM], SKIP IT JRST L5XIT CAIN TT,3 ;****NEVER CHANGE THE GLOBALSYM INDICES FOR: JRST L5SPBND ; SPECBIND 3 CAIN TT,25 ; ERSETUP 25 JRST L5ERSTP ; MAKUNBOUND 34 CAIN TT,34 ; INHIBIT 47 JRST L5MKUNBD ; 0*0PUSH 53 CAIN TT,47 ; NILPROPS 54 JRST L5INHIBI ;THOSE HAVE MORE THAN 6 CHARS IN THEIR PNAME CAIN TT,53 ;AND CANT BE RECONSTRUCTED BY UNSQOZ'ING FROM JRST L50.0P ;FROM THE LAPFIV TABLE CAIN TT,54 JRST L5NILP MOVE D,LAPFIV(F) PUSHJ P,UNSQOZ L5H2: LDB TT,(P) PUSHJ P,@-1(P) L5XIT: AOBJN F,L5H1 JRST POP2J L5ERSTP: MOVEI A,[SIXBIT \ERSETUP \] JRST L5H3 L5SPBND: MOVEI A,[SIXBIT \SPECBIND \] L5H3: HRLI A,440600 PUSHJ P,READ6C JRST L5H2 L5MKUNBD: MOVEI A,[SIXBIT \MAKUNBOUND \] JRST L5H3 L5INHIBIT: MOVEI A,[SIXBIT \INHIBIT \] JRST L5H3 L50.0P: MOVEI A,[SIXBIT \0*0PUSH \] JRST L5H3 L5NILP: MOVEI A,[SIXBIT \NILPROPS\] JRST L5H3 LAPSMH: CAIE A,TRUTH ;(LAPSETUP| T 2) MEANS JRST LAPSM1 ; SET UP THE XCT HACK AREAS 10$ JSP T,FXNV2 ; WITH 2 XCT PAGES 10$ MOVE TT,D 10$ JRST LDXHAK 10% POPJ P, ;FOR NON TOPS-10, NO NEED TO DO ANY SETUP LAPSM1: MOVEI T,(B) ;OTHERWISE, FIRST ARG IS ADDRESS MOVEI R,(A) ; TO HACK, SECOND NON-NIL => MOVE TT,(R) ; TRY THE XCT-PAGE HAK PUSHJ P,PRCHAK ;TRY TO SMASH (SKIP ON FAILURE) JRST TRUE MOVEI A,(AR2A) MOVE B,VPURCLOBRL PUSHJ P,CONS MOVEM A,VPURCLOBRL JRST TRUE LAPST2: MOVE TT,LSYMS(TT) ;GET ACTUAL VALUE FROM GLOBALSYM INDEX MOVEI C,QSYM LSYMPUT: ;EXPECTS SYMBOL IN A, "SYM" OR "GLOBALSYM" MOVEI B,(A) ; IN C, AND VALUE IN TT JSP T,FXCONS EXCH A,B JRST PUTPROP FSLSTP: MOVEI T,FSLST2 PUSHJ P,LAP5HAK MOVE TT,LDFNM2 JRST FIX1 FSLST2: MOVEI C,(A) ;MAKE UP ATOMIC SYMBOLS AND GIVE THEM SYM PROPERTIES JSP T,FXCONS ; OF THE FORM (0 (NIL )) PUSHJ P,NCONS ; WHERE IS THE INDEX OF THE SYMBOL SETZ B, ; (THESE ARE THE "GLOBALSYMS") PUSHJ P,XCONS PUSHJ P,NCONS MOVE B,CIN0 PUSHJ P,XCONS MOVEI B,(A) MOVEI A,(C) MOVEI C,Q%GLOBALSYM JRST PUTPROP R70 ;GLOBALSYM NUMBER -1 LSYMS: GLBSYM A LGSYMS==.-LSYMS ;END OF GLOBALSYMS HACKED BY FASLAP XTRSYM A LLSYMS==.-LSYMS ;END OF ALL GLOBAL SYMBOLS ;;; SIXBIT FOR LAP SYMBOL NAMES; MUST MATCH IRP LIST OF GLBSYM ZZ==0 LAPSIX: .BYTE 6 SIXSYM [ IRPC Q,,[A] 'Q TERMIN 0 ZZ==ZZ+1 ] ;END OF SIXSYM ARGUMENT .BYTE IFN ZZ-LGSYMS, WARN [LAPSIX OUT OF PHASE] EXPUNGE ZZ LAPFIV: GLBSYM [SQUOZE 0,A] XTRSYM [SQUOZE 0,A] HAOLNG LOG2LL5, ;CROCK FOR BINARY SEARCH REPEAT <1_LOG2LL5>-LLSYMS, 377777,,777777 LAP5P: BLOCK /4 ;PERMUTATION, STORED 4/WD, TO GET GLOBALSYMINDEX FROM LAPFIV INDEX GETDDTSYM: PUSHJ P,RSQUEEZE PUSHJ P,GETDDG ;GET GLOBALSYM INDEX, AND NO-SKIP IF WIN JRST FIX1 IFN ITS,[ MOVE D,TT ;SAVE SQUOZE OVER CALL TO SIDDTP JSP T,SIDDTP ;LOSE IF NO DDT FROM WHICH TO GET SYMBOL JRST FALSE MOVE TT,D .BREAK 12,[..RSYM,,TT] JUMPE TT,FALSE MOVE TT,TT+1 JRST FIX1 ] ;END OF IFN ITS IFE ITS,[ PUSHJ P,GETDDJ JRST FALSE JRST FIX1 GETDDJ: SKIPA D,.JBSYM" ;SQUOZ IN TT - FIND SYMBOL IN JOB SYMBOL TABLE GETDD1: ADD D,R70+2 ; SKIP IF FOUND JUMPGE D,CPOPJ MOVE T,(D) TLZ T,540000 TLZN T,200000 ;SYMBOL MUSTN'T BE KILLED CAME T,TT ;MUST BE THE ONE WE WANT JRST GETDD1 MOVE TT,1(D) AOJA D,POPJ1 ] ;END OF IFE ITS GETDDG: MOVEI R,0 ;SQUOZ IN T, SEARCH "GLOBALSYM" TABLE, TLZ T,740000 ; SKIP IF LOSE, LEAVE VALUE IN TT IF WIN REPEAT LOG2LL5,[ CAML T,LAPFIV+<1_>(R) ADDI R,1_ ] ;END OF REPEAT LOG2LL5 CAME T,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM JRST POPJ1 ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE LSH F,-42 LDB TT,LDGET6(F) ;USE TABLE FROM FASLOAD MOVE TT,LSYMS(TT) POPJ P, LGTSPC: MOVEM TT,GAMNT ADD TT,@VBPORG ;INSURE THAT BPEND-BPORG > (TT) SUB TT,@VBPEND JUMPGE TT,GTSPC1 ;MUST RELOCATE, OR GET MORE CORE. MOVE A,VBPEND ;ALREADY OK MOVE TT,(A) POPJ P, PAGEBPORG: MOVE A,VBPORG ;MAKE SURE BPORG IS ON PAGE BOUNDRY MOVE TT,(A) ;NUMERIC VALUE OF BPORG TRNN TT,PAGKSM POPJ P, ADDI TT,PAGSIZ-1 ANDCMI TT,PAGKSM CAMGE TT,@VBPEND JRST PGBP4 PUSH FXP,TT ;NEW VALUE FOR BPORG JSP T,SPECBIND 0 VNORET AOS VNORET PUSH P,CUNBIND SUB TT,(A) PUSHJ P,LGTSPC JUMPE TT,[LERR [SIXBIT \NO CORE - PAGEBPORG!\]] POP FXP,TT PGBP4: JSP T,FIX1A MOVEM A,VBPORG ;GIVE BPORG NEW PAGIFIED VALUE POPJ P, SUBTTL MAKUNBOUND AND PURIFY ;NEVER FLUSHES VALUE CELL MAKUBE: %WTA [SIXBIT \UNCHANGEABLE VALUE - MAKUNBOUND!\] MAKUNBOUND: ;SUBR 1 - FLUSH VALUE OF ATOMIC SYMBOL BAKPRO JSP D,SETCK ;MAKE SURE IT'S A SYMBOL JUMPE A,MAKUBE CAIN A,TRUTH JRST MAKUBE HLRZ T,(A) MOVE B,(T) IFE 0, NOPRO IFN 0,[ TLNE B,300 ;CAN'T RECLAIM VALUE CELL IF PURE JRST MAKUN1 ; OR IF COMPILED CODE NEEDS IT TLZ B,-1 CAIN B,SUNBOUND ;CAN'T RECLAIM SUNBOUND!!! POPJ P, CAIL B,BXVCSG+NXVCSG*SEGSIZ JRST MAKUN1 ;CAN'T RECLAIM CELL NOT IN VALUE CELL AREA EXCH B,FFVC ;SO RECLAIM THE VALUE CELL ALREADY XCTPRO MOVEM B,@FFVC MOVEI B,SUNBOUND ;USE SUNBOUND FOR A VALUE CELL HRRM B,(T) NOPRO POPJ P, ;THAT'S ALL ] ;END IFN 0 MAKUN1: PUSH P,A ;MAKE SURE WE RETURN THE ARGUMENT PUSH P,CPOPAJ MOVEI B,QUNBOUND ;FALL INTO SET WITH "UNBOUND" VALUE JRST SET+1 IFN USELESS,[ $PURIFY: IFN D10, POPJ P, IFN ITS+D20,[ LOCKTOPOPJ SETZ AR1, JSP T,FXNV1 ;GET TWO MACHINE NUMBERS JSP T,FXNV2 ANDCMI TT,1777 ;PAGIFY FIRST DOWNWARD IORI D,1777 ;PAGIFY SECOND UPWARD CAMLE TT,D LERR [SIXBIT \ARG 2 < ARG 1 - PURIFY!\] JUMPE C,FPURF3 ;NULL THIRD ARG MEANS DEPURE MOVE T,LDXLPL HRRZ T,LDXPSP(T) ;GET ADR OF POSSIBLY PURE PAGE CAIG TT,(T) CAIGE D,(T) SKIPA SETZM LDXLPC ;FOR PURE PAGE JUST FORCE FREE COUNT TO ZERO FPURF0: CAIE C,QBPORG JRST FPURF3 PUSHJ P,FPURF7 JRST FPURF2 FPURF3: JSP R,IP0 POPJ P, ] ;END OF IFN ITS+D20 ] ;END OF IFN USELESS PGTOP UIO,[UTAPE, LAP, AND AGGLOMERATED SUBRS] ;;@ END OF ULAP 142 ;;@ ARITH 84 STANDARD ARITHMETIC FUNCTIONS ;;; ***** MACLISP ****** STANDARD ARITHMETIC FUNCTIONS *********** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT ARI ;THE ARITHMETIC PAGE - ARITHMETIC SUBROUTINES IFN BIGNUM,[ SUBTTL ARITHMETIC FUNCTIONS WITH BIGNUM==1 ZEROP: MOVEI R,2 JRST ZMP MINUSP: TDZA R,R PLUSP: MOVEI R,1 ZMP: JSP T,NVSKIP JRST .+2 JFCL XCT .+2(R) JRST FALSE JUMPL TT,TRUE ;FOR MINUSP JUMPG TT,TRUE ;FOR PLUSP JUMPE TT,TRUE ;FOR ZEROP MINUS: JSP T,NVSKIP JRST MNSBG JRST MNSFX MOVNS TT JRST FLOAT1 MNSFX: CAMN TT,[400000000000] JRST ABSOV MOVNS TT JRST FIX1 ADD1: MOVEI R,1 JRST SUB11 SUB1: MOVNI R,1 SUB11: JSP T,NVSKIP JRST A1S1BG JRST A1S1FX JUMPL R,.+3 FAD TT,[1.0] JRST FLOAT1 FSB TT,[1.0] JRST FLOAT1 A1S1FX: CAMN TT,[1_43] JUMPL R,A1S11 ADD TT,R CAMN TT,[1_43] ;DONT WANT TO GET -2E35. BY ADD1 JUMPG R,ABSOV JRST FIX1 A1S11: PUSHJ P,ABSOV ;CANT SUB1 FROM -2E35. AND HRROS (A) A1S1BG: PUSH P,B ;ADD1 AND SUB1 FOR BIGNUM PUSH P,CPOPBJ MOVEI B,IN1 JUMPL R,.DIF JRST .PLUS ABSOV: PUSH P,B ;OVERFLOW FROM ADD1, SUB1, ABS, MOVEI TT,1 ; MINUS, HAIPART, GCD, ETC. PUSHJ P,C1CONS MOVE B,A MOVEI TT,0 PUSHJ P,C1CONS HRRM B,(A) PUSHJ P,BNCONS JRST POPBJ ;;; MOBY DISPATCH TABLES FOR THE VARIOUS ARITHMETIC OPERATIONS CAIA . ;UNUSED WORD JRST GRSWF COMPR: JRST GRSWX JFCL 0 JRST GRBFX JRST GRFXB JRST GRBB SKIPE VZFUZZ 0 FSBR D,TT DIFFA: SUB D,TT JRST PLOV JRST PL2BN JRST PL1BN JRST BNDF SKIPE VZFUZZ ;-3(R) SKIP UNLESS FUZZ HACK TO BE PULLED 0 ;-2(R) OPERATION IDENTITY - VALUE WHEN NO ARGS GIVEN FADR D,TT ;-1(R) FLOATING POINT INSTRUCTION FOR OPERATION PLUSA: ADD D,TT ;0(R) FIXED POINT INSTRUCTION FOR OPERATION JRST PLOV ;1(R) ACTION ON ARITHMETIC OVERFLOW JRST PL2BN ;2(R) BIGNUMBER ACCUMULATION MEETS FIXNUM ARG JRST PL1BN ;3(R) FIXNUM ACCUMULATION MEETS BIGNUM ARG JRST BNPL ;4(R) BIGNUM ACCUMULATION, BIGNUM ARG CAIA 1 FMPR D,TT TIMESA: IMUL D,TT JRST TIMOV JRST TIM2BN JRST TIM1BN JRST BNTIM CAIA 1 FDVR D,TT QUOA: JRST QUOAK JRST QUOOV JRST DV2BN JRST DV1BN JRST BNDV QUOOV: SKIPN RWG JRST OVFLER AOS D,T JFCL 8.,PLOV JRST T14E QUOAK: CAMN D,[400000,,0] ;ORDINARY FIXED POINT DIVISION JRST QUOAK1 ;DOESN'T ALWAYS WIN ON SETZ QUOAK2: IDIVM D,TT MOVE D,TT JRST T14EX2 QUOAK1: CAMN TT,XC-1 ;SETZ/(-1) => POSITIVE SETZ JRST DIVSEZ CAIN TT,1 ;SETZ/1 => SETZ JRST T14EX2 JRST QUOAK2 ;IDIVM WORKS FOR OTHER CASES T1: JUMPE T,NMCK0 ;ONLY ONE ARG GIVEN - GIVE IT OUT MOVE TT,-2(R) ;NO ARGS GIVEN - GIVE OUT OPERATORS IDENTITY JRST FIX1 .QUO: SKIPA R,[QUOA] ;C KEEPS ADDRESS OF FUNCTION TYPE .TIMES: MOVEI R,TIMESA SETZM REMFL JRST T21 .DIF: SKIPA R,[DIFFA] .PLUS: MOVEI R,PLUSA T21: MOVNI T,1 PUSH P,A PUSH P,B JRST T20 QUOTIENT: SKIPA R,[QUOA] TIMES: MOVEI R,TIMESA SETZM REMFL JRST T22 DIFFERENCE: SKIPA R,[DIFFA] PLUS: MOVEI R,PLUSA T22: AOJGE T,T1 T20: MOVE F,T ;D - ACCUMULATED VALUE ADDI F,1(P) ;TT - NEXT VALUE IN LINE HRL F,T T24: MOVNI T,-1(T) HRLS T ;R - ADDRESS OF INSTRUCTION DISPATCH TABLE MOVEM T,PLUS8 ;F - AOBJN POINTER TO ARG VECTOR ON PDL MOVE A,-1(F) JSP T,NVSKIP ;PICK UP FIRST ARG AND DISPATCH TO APPROPRIATE LOOP JRST T2 JRST T3 MOVE D,TT JRST 2,@[.+1] T4: MOVE A,(F) ;FLOATING POINT ARITHMETIC LOOP JSP T,NVSKIP JRST T6 JRST T5 T7: XCT -1(R) ;FLOATING SUM OPERATED WITH FLOATING NEXT ARG XCT -3(R) ;SKIP UNLESS ZFUZZ HACK REQUIRED JSP A,ZFZCHK T7A: AOBJN F,T4 JFCL 8.,T7O T7X: MOVE TT,D ;EXIT ARITHMETIC LOOP WITH ACCUMULATED VALUE T7X1: SUB P,PLUS8 JRST FLOAT1 T7O: JSP T,T7O0 JRST T7X1 ZFZCHK: MOVE T,D JRST 2,@[.+1] FDVR T,TT JFCL 8,ZFZCH9 MOVM T,T CAMGE T,@VZFUZZ SETZ D, ZFZCH9: JRST 2,(A) ;DON'T LET FDVR AFFECT OVERFLOW/UNDERFLOW ;;; IFN BIGNUM ;ARITH OPS FOR BIGNUM==1 CONTINUED T5: EXCH D,AGDBT JSP T,IFLOAT ;FLOATING SUM, NEXT IS FIXED POINT EXCH D,AGDBT JRST T7 T6: CAIN R,QUOA JRST T6A PUSHJ P,FLBIG ;FLOATING SUM, NEXT WAS BIGNUM JRST T7 T6A: PUSHJ P,FLBIGQ ;SPECIAL HACK FOR JPG JRST T7 SETZ D, ;IF BIGNUM TOO LARGE, WE GET JRST T7A ; UNDERFLOW, NOT OVERFLOW T3: MOVE D,TT ;FIXED POINT ARITHMETIC LOOP JRST 2,@[.+1] T15: MOVE A,(F) JSP T,NVSKIP XCT 3(R) ;DISPATCH TO CONVERT SUM TO BIGNUM JRST T14 ;OPERATE ON TWO FIXED POINT MOVEM TT,AGDBT MOVE TT,D ;FIXED POINT SUM CONVERTED TO FLOATING JSP T,IFLOAT ;AND ENTER FLOATING LOOP MOVE D,TT MOVE TT,AGDBT JRST T7 ;IFLOAT CANNOT HAVE SET OFVLO FLG T14: MOVE T,D ;SAVE OLD SUM, JUST INCASE THERE IS OVERFLO XCT 0(R) ;OPERATE FIXED POINT T14EX2: JFCL 8,1(R) ;CHECK FOR OVERFLO, IF SO DISPATCH TO BIGNUM T14E: AOBJN F,T15 T14EX: MOVE TT,D T14EX1: SUB P,PLUS8 JRST FIX1 FXIDEN: JSP T,FXNV1 JRST PDLNKJ FLIDEN: JSP T,FLNV1 JRST PDLNKJ ABS: JSP T,NVSKIP JRST ABSBG SKIPA T,CFIX1 MOVEI T,FLOAT1 JUMPGE TT,PDLNMK CAMN TT,[1_43] ;ABS OF -2**35. IS NO LONGER FIXNUM JRST ABSOV MOVMS TT JRST (T) REMAINDER: SETZB F,PLUS8 JSP T,NVSKIP JRST REMBIG ;BIGNUM SKIPA D,TT JSP T,REMAIR ;FLONUM IS ERROR - RETURNS TO THE NVSKIP EXCH A,B ;FIRST ARG IS FIXNUM JSP T,NVSKIP JRST REMAI2 ;IF SECOND IS BIGNUM NOW, MAYBE GIVE OUT FIRST SKIPA T,D JSP T,REMAIR ;FLONUM IS ERROR JUMPE TT,BPDLNKJ MOVE D,TT SETZ TT, ;IN THE CASE OF (\ SETZ 1), TRY TO WIN IDIV T,D JRST FIX1 REMAI2: SKIPL T,(B) ;WELL, IF FIRST ARG IS SETZ, AND JRST BPDLNKJ ; SECOND ARG IS +SETZ, THEN REMAINDER CAME T,[400000,,] ; SHOULD BE 0, NOT SETZ! JRST BPDLNKJ MOVE A,(A) PUSH P,AR1 ;MUST SAVE AR1 PUSHJ P,BNTRS1 ;SKIPS 2 UNLESS BIGNUM IS POP P,AR1 ; +SETZ (OR SETZ) JRST 0POPJ POP P,AR1 JRST BPDLNKJ FLOAT: TDZA R,R MOVEI R,TRUTH JSP T,NVSKIP JRST FLBIGF JRST FLOAT4 FIX4: JUMPE R,PDLNKJ ;ARG IS ALREADY OF REQUIRED TYPE. IF "CALL"ED, THEN RETURN LISP ANSWER IN A POPJ P, ;ELSE IF "NCALL"ED, RETURN NUMERIC ANSWER IN TT FLOAT4: JSP T,IFLOAT JUMPE R,FLOAT1 POPJ P, IFXERR: WTA [ARG TOO BIG FOR FIXNUM - IFIX!] JRST $IFIX1 $IFIX: PUSH P,CFIX1 $IFIX1: JSP T,FLTSKP POPJ P, CAML TT,[244000,,] JRST IFXERR JSP T,IFIX POPJ P, FIX: JSP T,NVSKIP POPJ P, POPJ P, MOVM T,TT CAML T,[244000,,] JRST FIXBIG JRST FIX2 .GREAT: EXCH A,B .LESS: PUSH P,A PUSH P,B MOVNI T,2 LESSP: SKIPA A,[CAML D,2] GREATERP: HRLZI A,(CAMG D,) MOVEI D,GRFAIL MOVEI R,GRSUCE GTR1: MOVE F,T AOJGE T,GTR9 HRRI A,TT ADDI F,2(P) HRLI F,(T) PUSHJ FXP,SAV5M2 HRLI D,(JRST) MOVEM D,CFAIL HRLI R,(JRST) MOVEM R,CSUCE MOVEI R,COMPR MOVEM A,GRESS0 JRST T24 GTR9: MOVEI D,QMAX+1(A) SOJA T,WNALOSS MIN: SKIPA A,[CAML D,1] MAX: HRLOI A,(CAMG D,) AOJE T,NMCK0 MOVEI D,MXF MOVEI R,MXS SOJA T,GTR1 MXF: MOVE AR1,AR2A SKIPA D,TT MXS: MOVE AR2A,AR1 AOBJN F,GRSUC1 MAXFIN: MOVEI B,(AR1) PUSHJ FXP,RST5M2 2DIF JRST @(B),MAX923,QFIXNUM MAX923: T14EX ;FIXNUM T7X ;FLONUM T13X ;BIGNUM GRSUC2: MOVE D,TT GRSUC1: 2DIF JRST @(AR2A),GRS923,QFIXNUM GRS923: T15 ;FIXNUM T4 ;FLONUM T12 ;BIGNUM GRSUCE: AOBJN F,GRSUC2 GRSFIN: MOVEI A,TRUTH GRSF1: PUSHJ FXP,RST5M2 SUB P,PLUS8 POPJ P, GRFAIL: MOVEI A,NIL JRST GRSF1 GRSWF: SKIPA AR1,[QFLONUM] GRSWX: MOVEI AR1,QFIXNUM MOVE AR2A,AR1 JRST GRESS0 ] ;END OF ARITH OPS WITH BIGNUM==1 IFE BIGNUM,[ SUBTTL ARITHMETIC FUNCTIONS WITH BIGNUM==0 ADD1: JSP T,FLTSKP AOJA TT,FIX1 FAD TT,[1.0] JRST FLOAT1 SUB1: JSP T,FLTSKP SOJA TT,FIX1 FSB TT,[1.0] JRST FLOAT1 REMAINDER: JSP T,FXNV1 JSP T,FXNV2 IDIV TT,TT+1 MOVE TT,TT+1 JRST FIX1 MINUS: JSP T,FLTSKP SKIPA T,CFIX1 MOVEI T,FLOAT1 MOVNS TT JRST (T) ABS: JSP T,FLTSKP SKIPA T,CFIX1 MOVEI T,FLOAT1 MOVMS TT JRST (T) MINUSP: SKIPA R,[JUMPGE TT,FALSE] PLUSP: MOVE R,[JUMPLE TT,FALSE] JSP T,FLTSKP JFCL XCT R JRST TRUE ZEROP: JSP T,FLTSKP JFCL JUMPE TT,TRUE JRST FALSE $IFIX: FIX: TDZA R,R MOVEI R,TRUTH JSP T,FIXFLO TLNN T,FL ;FIXFLO LEFT TYPE BITS IN T JRST FIX4 JSP T,IFIX JUMPE R,FIX1 POPJ P, FIX4: JUMPE R,PDLNKJ POPJ P, FLOAT: TDZA R,R MOVEI R,TRUTH JSP T,FIXFLO TLNN T,FX ;FIXFLO LEFT TYPE BITS IN T JRST FIX4 JSP T,IFLOAT JUMPE R,FLOAT1 POPJ P, FIXFLO: PUSH P,A LSH A,-SEGLOG HLL T,ST(A) ;LEAVES TYPE BITS IN T TLNN T,FX+FL JRST FLOAT3 POP P,A MOVE TT,(A) JRST (T) FLOAT3: POP P,A %WTA NMV3 JRST FIXFLO MIN: SKIPA A,[CAMLE F,1] MAX: HRLOI A,(CAMGE F,) AOJE T,NMCK0 MOVEI D,MINMAX SOJA T,MNMX1 MINMAX: XCT MNMX0 ;CAMG F,TT OR CAML F,TT MOVE F,TT JRST PLUS4 .GREAT: EXCH A,B .LESS: PUSH P,A PUSH P,B MOVNI T,2 LESSP: SKIPA A,[CAML F,2] GREATERP: HRLZI A,(CAMG F,) MOVEI D,GRESS MNMX1: HRLI D,(JRST) MOVEM D,PLUS3 MOVNM T,PLUS8 MOVE R,T AOJGE T,MNMX9 HRRI A,TT MOVEM A,GRESS0 ;THIS IS ALSO MNMX0 ADD R,P MOVE A,1(R) SETOM PLUS0 JSP T,FLTSKP SETZM PLUS0 MOVE F,TT AOJA R,PLUS7 MNMX9: MOVEI D,QMAX+1(A) SOJA T,WNALOSS GRESS: XCT GRESS0 JRST GRUSE MOVE F,TT CAME P,R JRST PLUS9 SUB P,PLUS8 JRST TRUE GRUSE: SUB P,PLUS8 JRST FALSE .DIF: PUSH P,A PUSH P,B MOVNI T,2 DIFFERENCE: MOVE R,[JRST DIF2] MOVE D,R SOJA D,DIF1 SKIPA D,[FSBR F,TT] DIF2: MOVE D,[SUB F,TT] MOVEM D,PLUS3 MOVE D,[FSBR F,TT] MOVEM D,PLUS6 MOVE F,TT JRST PLUS4 .QUO: PUSH P,A PUSH P,B MOVNI T,2 QUOTIENT: MOVE R,[JRST QUO2] MOVE D,R SOJA D,QUO1 SKIPA D,[FDVR F,TT] QUO2: MOVE D,[JRST QUO3] MOVEM D,PLUS3 MOVE D,[FDVR F,TT] MOVEM D,PLUS6 MOVE F,TT JRST PLUS4 QUO3: CAIN TT,1 CAME F,[400000,,0] CAIA SKIPA TT,F IDIVM F,TT EXCH F,TT ;ALL THIS LOSSAGE SO THAT F+1 WONT BE DISTURBED JFCL 8.,.+2 JRST PLUS4 SKIPN RWG JRST OVFLER SKIPGE TT SOSA F,TT AOS F,TT JFCL 8.,OVFLER JRST PLUS4 .TIMES: PUSH P,A PUSH P,B MOVNI T,2 TIMES: MOVE R,[IMUL F,TT] MOVE D,[FMPR F,TT] QUO1: MOVEI F,1 JRST PLUS1 .PLUS: PUSH P,A PUSH P,B MOVNI T,2 PLUS: MOVE R,[ADD F,TT] MOVE D,[FADR F,TT] DIF1: MOVEI F,0 PLUS1: MOVNM T,PLUS8 JUMPE T,PLUS2 ADD T,P MOVEM R,PLUS3 SETZM PLUS0 MOVE R,T PLUS7: MOVEM D,PLUS6 HRLS PLUS8 JRST 2,@[PLUS4] PLUS5: MOVE D,PLUS6 ;FAD F,TT OR FMP F,TT OR ETC. MOVEM D,PLUS3 SETOM PLUS0 EXCH F,TT JSP T,IFLOAT EXCH F,TT PLUS3A: XCT PLUS3 PLUS4: CAMN P,R JRST PLUS2 PLUS9: MOVE A,1(R) JSP T,FLTSKP JRST .+4 SKIPE PLUS0 AOJA R,PLUS3A AOJA R,PLUS5 SKIPE PLUS0 JSP T,IFLOAT AOJA R,PLUS3A PLUS2: MOVE TT,F JFCL 8.,PLUS2V PLUS2A: SUB P,PLUS8 ;FALL THRU TO MAKNUM SKIPN PLUS0 JRST FIX1 JRST FLOAT1 PLUS2V: JSP T,T7O0 JRST PLUS2A ] ;END OF ARITH OPS WITH BIGNUM=0 T7O0: SKIPE VZUNDERFLOW ;NON-NIL => FLOATING UNDERFLOW TLNN T,100 .SEE %PCFXU ; YIELDS ZERO RESULT INSTEAD OF ERROR JRST UNOVER MOVEI TT,0 JRST (T) SUBTTL GENERAL EXPONENTIATION ROUTINE EXPT: JRST 2,@[.+1] ;SUBR 2 - COMPUTE A^B EXCH A,B ;FIND TYPE OF EXPONENT FIRST IFN BIGNUM,[ JSP T,NVSKIP ;EXPONENT IS . . . JRST XPT.B ;IT'S A BIGNUM JRST XPT.X ;IT'S A FIXNUM EXCH A,B ;IT'S A FLONUM JSP T,NVSKIP ;BASE IS . . . JRST XPTBL ;BIGNUM BASE JSP T,IFLOAT ;FIXNUM BASE - FLOAT IT ] ;END OF IFN BIGNUM IFE BIGNUM,[ JSP T,FLTSKP ;EXPONENT IS . . . JRST XPT.X ;IT'S A FIXNUM EXCH A,B ;IT'S A FLONUM JSP T,FLTSKP ;BASE IS . . . JSP T,IFLOAT ;FIXNUM BASE - FLOAT IT ] ;END OF IFE BIGNUM XPTLL: PUSH P,CFLOAT1 ;FLONUM^FLONUM SKIPN (B) ; X^0.0 => 1.0 JRST 1.0PJ JUMPE TT,CPOPJ ; 0.0^X => 0.0 PUSHJ P,LOG.. ;SO COMPUTE FLONUM^FLONUM BY USING THE FORMULA: FMPR TT,(B) ; B (B LOG A) JRST EXP.. ; A = E XPT.X: EXCH A,B ;FIXNUM EXPONENT FOUND MOVE D,TT BG$ JSP T,NVSKIP ;CHECK BASE FOR FIXNUM EXPONENET BG$ JRST XPTBX ;BIGNUM BASE BG% JSP T,FLTSKP JRST XPTXX0 ;FIXNUM BASE PUSH P,CFLOAT1 ;FLONUM BASE => FLONUM RESULT XPTLX: JSP R,XPTZL ;CHECK EASY CASES SKIPA R,TT ;NORMAL CASE - USE THE MULTIPLY XPTLX1: FMPR R,R ; AND SQUARE HACK TRNE D,1 FMPR T,R JFCL 8,XPTOV ;CHECK FOR OVERFLOW LSH D,-1 JUMPN D,XPTLX1 XPTLX2: MOVE TT,T ;ANSWER GOES IN TT POPJ P, XPTOV: JSP T,T7O0 POPJ P, XPTXX0: PUSHJ P,XPTXX JRST FIX1 POPJ P, ;;; SKIPS IF ANSWER IS A BIGNUM XPTXX: JSP R,XPTZX ;FIXNUM^FIXNUM - CHECK EASY CASES JUMPL D,ZPOPJ IFE BIGNUM,[ SKIPA R,TT XPTXX5: IMUL R,R TRNE D,1 IMUL T,R LSH D,-1 JUMPN D,XPTXX5 MOVE TT,T JFCL 8,XPTOV POPJ P, ] ;END OF IFE BIGNUM IFN BIGNUM,[ SKIPGE R,TT JRST XPTXX3 JFFO R,.+1 LSH R,1(F) JUMPE R,2XPT ;XPTZX HAS CHECKED BASE, SO IT'S NOT 0/1/-1 MOVE R,TT XPTXX3: MOVE TT,T ;HERE YOU GO FANS, YOU BASIC MULTIPLY BY SQUARING LOOP. MOVEM D,NORMF TRNE D,1 IMUL T,R JFCL 8.,EXPT6C LSH D,-1 JUMPN D,XPTXX4 MOVE TT,T POPJ P, XPTXX4: MOVE F,R IMUL R,R JFCL 8.,EXPT6B JRST XPTXX3 2XPT: MOVNI F,(F) IMULI D,36.-1(F) MOVEI TT,1 CAIL D,35. JRST 2BGXPT ASH TT,(D) POPJ P, 2BGXPT: IDIVI D,35. ASH TT,(R) JSP T,FIX1A PUSHJ P,NCONS 2BGXP1: MOVE B,CIN0 PUSHJ P,XCONS SOJG D,2BGXP1 PUSHJ P,BGNMAK JRST POPJ1 ] ;END OF IFN BIGNUM IFN BIGNUM,[ XPTBL: PUSH P,A ;BIGNUM^FLONUM PUSHJ P,FLBIG ;SO FLOAT THE BIGNUM, THEN USE SUB P,R70+1 ; FLONUM^FLONUM JRST XPTLL XPT.B: EXCH A,B ;BIGNUM FOUND AS EXPONENT HLRZ D,(TT) HRRZ D,(D) TLNE TT,400000 TLO D,400000 ;D GETS SIGN-BIT IN 4.9, RANDOM-NON-ZERO-BIT IN 3.1 TLO D,1 ;AND ODDP-BIT IN 1.1 JSP T,NVSKIP JRST OVFLER JRST XPTZX0 PUSH P,CFLOAT1 JSP R,XPTZL ;FLONUM^BIGNUM -- CHECK EASY CASES MOVMS TT CAML TT,T ;T SUPPOSED TO HAVE 1.0 JRST OVFLER SKIPN VZUNDERFLOW JRST UNFLER JRST ZPOPJ ;PUTS A RANDOM ZERO IN TT, AND POPJS XPTZX0: PUSH P,CFIX1 JSP R,XPTZX ;FIXNUM^BIGNUM -- CHECK EASY CASES JUMPL D,ZPOPJ ;N^- ==> 0 JRST OVFLER ;;; MUST SKIP 1 AS POPJ SINCE ONLY COME HERE FROM XPTXX EXPT6B: MOVE R,F ;RESTORE R, AND LEAVE OLD D IN NORMF EXPT6C: PUSHJ FXP,SAV5 ;EXPECTS RUNNING SQUARER IN R, ACCUMULATION IN TT PUSHJ P,BNCV ;NOTE THAT D CANT BE ZERO WHEN WE COME HERE MOVE B,A ;ACCUMULATION AS BIGNUM IN B MOVE TT,R PUSHJ P,BNCVTM MOVE A,TT ;RUNNING SQUARER IN A EXPT1A: MOVEM A,-4(P) MOVE D,NORMF EXPT1: TRNN D,1 ;-4(P) AND A HAVE RUNNING SQUARER, B HAS ACCUMULATION JRST EXPT2 MOVEM D,NORMF PUSHJ P,BNMUL MOVE D,NORMF EXCH A,-4(P) EXPT3: LSH D,-1 ;-4(P) NOW HAS ACCUMULATION, A HAS RUNNING SQUARER JUMPE D,EXPT4 MOVE B,A MOVEM D,NORMF PUSHJ P,BNMUL MOVE B,-4(P) JRST EXPT1A EXPT2: MOVEM B,-4(P) JRST EXPT3 EXPT4: JSP R,RSTR5 PUSHJ P,BNCONS JRST POPJ1 XPTBX: SOJG D,XPTBX1 ;BIGNUM^FIXNUM AOJG D,CPOPJ ; X^1 => X MOVEI A,IN0 JUMPL D,CPOPJ ; X^-N => 0 AOJA A,CPOPJ ; X^0 => 1 ;HACK HACK - IN0 => IN1 XPTBX1: MOVE A,TT ;EXPONENT > 1 SOS (P) ;COUNTERACT POPJ1 IN EXPT1 PUSHJ FXP,SAV5 MOVE B,BN.1 ;1, STORED AS A BIGNUM AOJA D,EXPT1 ;RESTORE VALUE OF D ] ;END OF IFN BIGNUM XPTII: PUSH P,CFIX1 ;SUBR 2 NCALLABLE (REAL NAME: ^) JSP T,FXNV1 JSP T,FXNV2 JRST 2,@[.+1] PUSHJ P,XPTXX POPJ P, LERR [SIXBIT \RESULT LARGER THAN FIXNUM - #^!\] XPTI$: PUSH P,CFLOAT1 ;SUBR 2, NCALLABLE (REAL NAME: ^$) JSP T,FLNV1 JSP T,FXNV2 JRST 2,@[XPTLX] ;OVERFLOW MUST BE CLEAR ON ENTRY TO XPTLX XPTZL: JUMPN TT,XPTZL1 ;FLONUM BASE (CFLOAT1 ON PDL) SKIPN D ; 0.0^X => 0.0, 1.0PJ: MOVSI TT,(1.0) ; EXCEPT 0.0^0.0 => 1.0 POPJ P, XPTZL1: JUMPGE D,XPTZL2 ; -Y 1 Y MOVSI T,(1.0) ; X = (---) FDVR T,TT ; X MOVE TT,T MOVMS D XPTZL2: CAMN TT,[-1.0] JRST XPTM1 ;BASE IS -1.0 CAMN TT,[1.0] POPJ P, ;BASE IS 1.0 MOVSI T,(1.0) ;T GETS 1.0 IN ANY CASE JRST (R) XPTZX: JUMPN TT,XPTZX1 ;FIXNUM BASE - PDL HAS CFIX1 JUMPN D,CPOPJ ; 0^X => 0, AOJA TT,CPOPJ ; EXCEPT 0^0 => 1 XPTZX1: CAMN TT,XC-1 ;BASE = -1 JRST XPTM1 CAIN TT,1 ;FOR BASE = 1, ALSO EASY POPJ P, MOVEI T,1 ;T GETS 1 IN ANY CASE JRST (R) XPTM1: TRNN D,1 ;FOR BASE = -1 OR -1.0, SIMPLY MOVMS TT ; ASCERTAIN PARITY OF EXPONENT POPJ P, SUBTTL RANDOM RANDOM: SKIPA F,CFIX1 MOVEI F,CPOPJ AOJG T,RNDM0 AOJLE T,RAND9 POP P,A JUMPE A,IRAND ;ONE ARG OF NIL CAUSES INITIALIZATION PUSH P,F JSP F,RNDM0 MOVE D,TT ;ANY OTHER ARGUMENT SHOULD BE A JSP T,FXNV1 ; FIXNUM N, AND WE GENERATE A JUMPLE TT,RAND1 ; FIXNUM IN THE RANGE 0 TO N-1 TLZ D,400000 IDIV D,TT SKIPA TT,R RAND1: SETZ TT, ;RETURN 0 FOR NON-POSITIVE ARGUMENTS POPJ P, IRAND: MOVE TT,[171622221402] ;A GOOD STARTING NUMBER IRAND0: MOVEI T,LRBLOCK-1 ;INITIALIZE THE RANDOMNESS IRAND3: MOVE D,TT MULI D,3125. DIV D,[377777777741] MOVEM R,TT TLCE T,400000 JRST IRAND5 HRLM R,RBLOCK(T) JRST IRAND3 IRAND5: HRRM R,RBLOCK(T) SOJGE T,IRAND3 MOVEI D,ROFSET MOVEM D,RNOWS RNDM1: MOVEI T,LRBLOCK-1 MOVEM T,RBACK JRST RNDM1A RNDM2: MOVEI D,LRBLOCK-1 MOVEM D,RNOWS JRST RNDM2A RNDM0: SOSGE T,RBACK ;BASIC COMBINATION FOR RANDOMNESS JRST RNDM1 RNDM1A: SOSGE D,RNOWS JRST RNDM2 RNDM2A: MOVE TT,RBLOCK(T) ADDB TT,RBLOCK(D) JRST (F) SUBTTL HAULONG FUNCTION HAULONG: PUSH P,CFIX1 .HAU: BG$ JSP T,NVSKIP BG$ JRST 1HAU BG% JSP T,FLTSKP JRST 4HAU %WTA FXNMER JRST .HAU 4HAU: MOVM D,TT MOVEI TT,35.+1 3HAU1: JFFO D,.+2 TDZA TT,TT SUBI TT,(R) POPJ P, IFN BIGNUM,[ 1HAU: MOVEI F,(TT) ;RECEIVES BN HEADER IN TT HRRZ R,(F) ;LEAVES HAULONG IN TT, PTR TO NEXT TO LAST MOVEI TT,35.+1 ;IN F, CNT OF # OF ZEROS FOR LAST WD IN R JUMPE R,3HAU 2HAU: ADDI TT,35. HRRZ D,(R) JUMPE D,3HAU MOVEI F,(R) MOVEI R,(D) JRST 2HAU 3HAU: HLRZ T,(R) MOVE D,(T) JRST 3HAU1 ] ;END OF IFN BIGNUM SUBTTL HAIPART FUNCTION HAIPART: IFN BIGNUM,[ JSP T,NVSKIP JRST 1HAI ] IFE BIGNUM, JSP T,FLTSKP JRST 0HAI %WTA FXNMER JRST HAIPART 0HAI: MOVM TT,TT JFFO TT,.+2 JRST 0POPJ ;FOR ZERO ARG, JUST RETURN ARG! HRREI F,-36.(D) ;-<# OF BITS IN ARG> NO IN AC F JSP T,FXNV2 JUMPLE D,0HAI1 ADD D,F JUMPG D,PDLNKJ ;MORE DIGITS REQUESTED THAN ARE AVAILABLE LSH TT,(D) ;GETTING HAI PART INTO AC TT JUMPGE TT,FIX1 IFN BIGNUM, JRST ABSOV IFE BIGNUM, JRST OVFLER 0HAI1: JUMPE D,0POPJ ;RETURNS A FIXNUM ZERO CAMGE D,F JRST 0HAI3 MOVNS D 0HAI2: SETO F, ;REQUESTING LOW PART BY NEG COUNT LSH F,(D) ;CREATE MASK TO LET PROPER BITS THRU ANDCM TT,F JRST FIX1 0HAI3: JUMPGE TT,PDLNKJ IFN BIGNUM, JRST ABSOV IFE BIGNUM, JRST OVFLER IFN BIGNUM*USELESS,[ 3HAI: MOVNS D ;ACTUALLY ASKING FOR LOW PART CAILE D,35. JRST 3HAI1 JUMPE D,0POPJ HLRZ TT,(TT) MOVE TT,(TT) JRST 0HAI2 3HAI1: PUSH FXP,D PUSHJ P,1HAU POP FXP,D CAIL D,(TT) JRST PDLNKJ IDIVI D,35. PUSH P,C MOVEI F,C ;F WILL BE POINTER TO LAST OF FORMNG LIST MOVE C,(A) ;C HOLDS POINTER TO FNAL RESULT MOVEI B,(C) ;B GOES CDR'ING DOW INPUT ARG 3HAI2: HLRZ TT,(B) MOVE TT,(TT) PUSHJ P,C1CONS HRRM A,(F) MOVEI F,(A) HRRZ B,(B) SOJG D,3HAI2 ;D HOLDS HOW MANY WORDS TO USE JUMPE R,3HAI3 ;R HOLDS HOW MANY LEFT OVER BITS FROM D WORDS HLRZ TT,(B) MOVE TT,(TT) MOVNI D,1 LSH D,(R) ANDCM TT,D JUMPE TT,3HAI3 PUSHJ P,C1CONS HRRM A,(F) 3HAI3: MOVEI A,(C) PUSH P,AR1 PUSHJ P,BNTRUN ;IN LOPART CASE, MAY NEED TO GET POP P,AR1 ; RID OF LEADING ZEROS POP P,C HRRZ B,(A) ;MAYBE WHAT WE HAVE IS SHORT ENOUGH JUMPN B,BGNMAK ; TO FIT IN A FIXNUM; IF SO, WE CAN JRST CAR ; USE ONE WE JUST CONSED FOR BIGNUM! ] ;END OF IFN BIGNUM*USELESS SUBTTL LENGTH AND BIGP FUNCTIONS LNGTER: WTA [NON-LIST - LENGTH!] JRST LNGTH0 LENGTH: SKIPA T,CFIX1 MOVEI T,CPOPJ LNGTH0: SKIPE V.RSET JRST LNGTH5 ;FOR *RSET MODE, USE SLOW ERROR-CHECKING LOOP LNG1A: MOVEI TT,777777 .SEE $LISTEN ;SAVES R LNGTH1: JUMPE A,LNGTH2 HRRZ A,(A) SOJG TT,LNGTH1 LNGTE1: MOVEI TT,(A) ;MAKNUM JSP T,FXCONS WTA [LIST IS CIRCULAR - LENGTH!] JRST LNGTH0 LNGTH2: XORI TT,777777 ;ONE'S COMPLEMENT! JRST (T) LNGTH5: MOVEI TT,777777 LNGTH6: SKIPN D,A ;DONE IF NIL SEEN JRST LNGTH2 LSH D,-SEGLOG SKIPL ST(D) .SEE LS JRST LNGTER HRRZ A,(A) SOJG TT,LNGTH6 JRST LNGTE1 IFE BIGNUM, BIGP==:FALSE IFN BIGNUM,[ BIGP: PUSHJ P,TYPEP ;SUBR 1 - IS IT A BIGNUM? CAIE A,QBIGNUM SETZ A, ;RETURNS T OR NIL JRST NOTNOT ] ;END OF IFN BIGNUM SUBTTL BOOLE AND ODDP FUNCTIONS BOOLE: SKIPA F,CFIX1 MOVEI F,CPOPJ MOVE R,T ADDI R,2(P) HRLI T,-1(T) MOVEM T,PLUS8 MOVE A,-1(R) JSP T,FXNV1 DPB TT,[350400,,BOOLI] PUSHJ P,BOOLG MOVE D,TT BOOLL: PUSHJ P,BOOLG XCT BOOLI JRST BOOLL BOOLG: CAIL R,(P) JRST BOOL1 MOVE A,(R) JSP T,FXNV1 AOJA R,CPOPJ BOOL1: ADD P,PLUS8 POP P,B JRST (F) ODDP1: %WTA FXNMER ODDP: SKOTT A,FX IFN BIGNUM, JRST ODDP4 IFE BIGNUM, JRST ODDP1 ODDP2: MOVE TT,(A) ODDP21: TRNN TT,1 JRST FALSE JRST TRUE IFN BIGNUM,[ ODDP4: TLNN TT,BN JRST ODDP1 MOVE TT,(A) ODDP3: HLRZ TT,(TT) MOVE TT,(TT) JRST ODDP21 ] ;END OF IFN BIGNUM SUBTTL FSC, ROT, LSH, AND GCD FUNCTIONS $FSC: JSP T,FLTSKP ;SUBR 2 JFCL JSP T,FXNV2 CAIG D,-1 FSC TT,(D) JRST FLOAT1 $ROT: SKIPA R,[ROT TT,(D)] ;SUBR 2 $LSH: HRLZI R,(LSH TT,(D)) ;SUBR 2 PUSH P,CFIX1 SHIFTY: JSP T,FLTSKP JFCL JSP T,FXNV2 XCT R POPJ P, IFN USELESS,[ IFE BIGNUM, GCD: .GCD: PUSH P,CFIX1 ;SUBR 2 - NCALLABLE JSP T,FXNV1 ;GCD OF FIXNUM ARGS ONLY JSP T,FXNV2 MOVM TT,TT ;GCD(-X,Y) = GCD(X,Y) MOVM D,D ;GCD(X,-Y) = GCD(X,Y) .GCD0: JUMPE TT,.GCD2 ;GCD(0,Y) = ABS(Y) JUMPE D,CPOPJ ;GCD(X,0) = ABS(X) CAMGE D,TT EXCH D,TT JRST .GCD1 .GCD3: MOVE D,TT MOVE TT,R .GCD1: IDIV D,TT ;GOOD OLD EUCLIDEAN ALGORITHM JUMPN R,.GCD3 POPJ P, .GCD2: MOVE TT,D POPJ P, IFN BIGNUM,[ GCD0: %WTA FXNMER ;NON-FIXNUM VALUE GCD: SETZ R, ;SUBR 2 - GCD, EVEN OF BIGNUM ARGS JSP T,NVSKIP TRO R,1 ;TURN ON BIT IF BIGNUM JRST .+2 ;FIXNUMS ARE OK TOO JRST GCD0 ;DON'T LIKE FLONUMS EXCH A,B MOVE D,TT JSP T,NVSKIP ;NOW CHECK OTHER ARG TRO R,2 JRST .+2 JRST GCD0 ;I TOLD YOU, I DON'T LIKE FLONUMS! JRST .+1(R) ;SO FIGURE OUT THIS MESS JRST GCDXX ;FIXNUM AND FIXNUM EXCH A,B ;FIXNUM AND BIGNUM JRST GCDBX ;BIGNUM AND FIXNUM JRST GCDBG ;BIGNUM AND BIGNUM GCDXX: MOVM TT,TT ;GCD OF TWO FIXNUMS JUMPL TT,GCDOV1 ;CHECK OUT -400000000000 CASES MOVM D,D JUMPL D,GCDOV PUSH P,CFIX1 ;EVERYTHING OKAY - CAN USE .GCD0 JRST .GCD0 ] ;END OF IFN BIGNUM ] ;END OF IFN USELESS SUBTTL FUNCTIONS: = < > 1+ 1+$ 1- 1-$ $EQUAL: JSP T,FLTSKP ;NUMERIC EQUAL = JRST IEQUAL EXCH A,B MOVE D,TT $EQL1: JSP T,FLTSKP JRST 2EQNF $IEQ: CAME D,TT JRST FALSE JRST TRUE IEQUAL: EXCH A,B MOVE D,TT JSP T,FLTSKP JRST $IEQ JRST 1EQNF $LESS: EXCH A,B $GREAT: JSP T,FLTSKP ;NUMERIC GREATERP AND LESSP <,> JRST IGRT MOVE D,TT EXCH A,B $IGL1: JSP T,FLTSKP JRST 2GPNF $IGL: CAMG D,TT JRST FALSE JRST TRUE IGRT: MOVE D,TT MOVE A,B JSP T,FLTSKP JRST $IGL JRST 1GPNF IADD1: JSP T,FLTSKP ;FIXNUM ADD1 1+ AOJA TT,FIX1 %WTA IARERR JRST IADD1 %WTA $ARERR $ADD1: JSP T,FLTSKP ;FLONUM ADD1 1+$ JRST $ADD1-1 FADRI TT,(1.0) JRST FLOAT1 ISUB1: JSP T,FLTSKP ;FIXNUM SUB1 1- SOJA TT,FIX1 %WTA IARERR JRST ISUB1 %WTA $ARERR $SUB1: JSP T,FLTSKP ;FLONUM SUB1 1-$ JRST $SUB1-1 FSBRI TT,(1.0) JRST FLOAT1 SUBTTL FUNCTIONS: + +$ - -$ * *$ // //$ $ARITH: SETOM PLUS0 SKIPA IARITH: SETZM PLUS0 ;SET UP FOR FIXNUM ARITHMETIC AOJGE T,ARIT0 I$B: JRST 2,@[.+1] SKIPA B,T I$ART2: XCT R POP P,A ;MAIN LOOP FOR FIXNUM AND FLONUM ARITHMETIC ARITH: JSP T,FLTSKP ;MAKE SURE NO MIXED MODES, RETURN MACHINE NUMBER IN TT TDZA T,T MOVNI T,1 CAME T,PLUS0 JRST ARTHER AOJLE B,I$ART2 CAIN B,69.+1 ;SIGNAL FOR CASE WITH ONE ARG EXCH TT,D XCT F IARDS: SKIPE PLUS0 ;DISPATCH TO CONS UP FINAL ANSWER JRST FLOAT1 JRST FIX1 ARIT0: MOVE TT,D JUMPN T,IARDS MOVEI T,69. JRST I$B IDIFFERENCE: SKIPA F,[SUB TT,D] ;- IPLUS: MOVE F,[ADD TT,D] ;+ MOVE R,[ADD D,TT] MOVEI D,0 JRST IARITH IQUOTIENT: SKIPA F,[IDIV TT,D] ;/ ITIMES: MOVE F,[IMUL TT,D] ;* MOVE R,[IMUL D,TT] MOVEI D,1 JRST IARITH $DIFFERENCE: SKIPA F,[FSBR TT,D] ;-$ $PLUS: MOVE F,[FADR TT,D] ;+$ MOVE R,[FADR D,TT] MOVEI D,0 JRST $ARITH $QUOTIENT: SKIPA F,[FDVR TT,D] ;/$ $TIMES: MOVE F,[FMPR TT,D] ;*$ MOVE R,[FMPR D,TT] MOVSI D,(1.0) JRST $ARITH IARZAR: MOVE TT,D JRST FIX1 ;;; ********** NUMBER SUBRS FOR LISP ********** SUBTTL SIN AND COS FUNCTIONS ;;; SIN IS A TOPS-10/TENEX JSYS, SO MUST CALL THIS $SIN. FOO! - GLS $SIN: PUSH P,CFLOAT1 SIN.: JSP T,FLTSKP JSP T,IFLOAT MOVM T,TT ;SIN(-X)=-SIN(X) CAMLE T,C1.0E5 ;ARG SHOULD BE <= 1.0E5 (ELSE RESULT JRST SIN.ER ; WOULD BE GROSSLY INACCURATE) CAMG T,[.001] ;THE RELATIVE ERROR OF APPROXIMATION [BY THIS RATIONAL ; ; FUNCTION] IS BOUNDED BY ABOUT 2.0E-7, BUT OCCASIONALLY ; ; COMES CLOSE TO THIS. SINCE THE ERROR OF TRUNCATION ; ; INHERENT IN TAKING X-(1/6)*X**3 FOR THE TAYLOR SERIES ; ; OF SIN(X) IS MUCH LESS THAN 2.0E-7, IT WILL BE SUFFICIENT ; ; TO TAKE X FOR SIN(X) WHENEVER THE RELATIVE ERROR TERM ; ; [(1/6)*X**3] IS LESS THAN 2.0E-7. SOLVING, WE FIND JRST SIN.XT ; X=.001 WILL DO. EXCH T,TT SIN.0: FDVR TT,PI%2 ;DIVIDE ARG BY PI/2 (ARG IS NOW IN QUADRANTS) MULI TT,400 ;TT GETS CHARACTERISTIC, R GETS MANTISSA SETZB R,F ASHC D,-243(TT) ;D GETS INTEGER PART, R GETS FRACTION (OF ARG) ASHC R,-8. ;R GETS HIGH 27. BITS OF FRACTION, F GETS REST TLO R,200000 ;FLOAT R LSH F,-8. TLO F,145000 ;FLOAT F (NOTE: 145=200-33; R,F NOW FORM 2-WORD FLOATING NUMBER) FADR R,F ;ADD F TO R (THIS WHOLE MESS PRESERVES PRECISION AND NORMALIZES) TRCN D,3 ;R IS NOW A QUADRANT 1 ANGLE - WHAT WAS ORIGINAL QUADRANT? JRST SIN.1 ;QUADRANT 1 - ALL IS WELL TRCE D,3 MOVN T,T ;QUADRANT 2 OR 3 - MUST REVERSE SIGN: SIN(X)=-SIN(X-PI) TRNE D,1 FSBR R,FPWUN ;QUADRANT 2 OR 4 - SUBTRACT 1 TO PUT IN RANGE -1.0 TO 0 SIN.1: SKIPGE T ;TEST SINE SIGN FLAG MOVN R,R ;IF NEGATIVE, RESULT MUST BE NEGATIVE MOVE D,R FMPR D,D ;D <- R*R IS ALWAYS NON-NEGATIVE MOVE TT,SIN.CF+4 ;MOBY APPROXIMATION MOVEI T,3 SIN.2: FMPR TT,D FADR TT,SIN.CF(T) SOJGE T,SIN.2 FMPR TT,R SIN.XT: CAMLE TT,[1.0] ;THIS IS A CROCK TO MAKE SURE ABS(RESULT) NOT >1 MOVSI TT,(1.0) CAMGE TT,[-1.0] MOVSI TT,(-1.0) POPJ P, ;RETURN - RESULT IS IN TT PI%2: 1.570796326 ;A PIECE OF PI (ABOUT 50%) SIN.CF: 1.5707963185 ;COEFFICIENTS FOR SIN APPROXIMATION -0.6459637111 0.07968967928 -0.00467376557 0.00015148419 COS: PUSH P,CFLOAT1 COS.: JSP T,FLTSKP JSP T,IFLOAT SKIPLE T,TT MOVN T,TT FADR T,PI%2 ;PI/2-X IN T, SINCE COS(X) = SIN(PI/2-X) MOVM TT,T ;|PI/2-X| IN TT CAMLE TT,C1.0E5 JRST COS.ER JRST SIN.0 SUBTTL SQRT FUNCTION COMMENT | OLD SQRT ALGORITHM SQRT: PUSH P,CFLOAT1 SQRT.: JSP T,FLNV1 JUMPL TT,SQR$ER ;NEGATIVE ARG IS AN ERROR SQRT..: MOVE D,TT ;D GETS ARG LDB T,[341000,,TT] ;FOR FIRST APPROXIMATION, TRY ADDI T,100 ; HALVING CHARACTERISTIC OF ARGUMENT, DPB T,[331100,,TT] ; AND USE SAME MANTISSA MOVEI T,5 ;NOW DO MOBY ITERATION SQRT.1: MOVE R,TT ; R <- TT MOVE TT,D FDVR TT,R ; R + D/R FADR TT,R ; TT <- --------- FSC TT,-1 ; 2 SOJN T,SQRT.1 POPJ P, | ;END OF OLD SQRT ALGORITHM COMMENT | ANOTHER OLD SQRT ALGORITHM ;;; THIS SQRT ALGORITHM IS BASED ON ONE BY KAHAN, ORIGINALLY ;;; DESIGNED FOR THE IBM 7094. THAT VENERABLE MACHINE LOOKED ;;; LIKE THE PDP-10 (27.-BIT MANTISSA AND 8-BIT EXPONENT). ;;; (THANKS TO RJF FOR HELP IN CODING THIS.) ;;; ;;; THE IDEA IS TO DECOMPOSE THE ARGUMENT X INTO: ;;; F * 2.0^(2*I - J) ;;; WHERE THE FRACTION F IS BETWEEN 0.5 (INCLUSIVE) AND 1.0 ;;; (EXCLUSIVE), AND I AND J ARE INTEGERS, J BEING 0 OR 1. ;;; ONE THEN COMPUTES THE INITIAL APPROXIMATION AS: ;;; A0 = (C + F/2.0 - J/4.0) * 2.0^I ;;; WHERE C IS THE MAGIC CONSTANT 0.4826004, CHOSEN FOR THE ;;; BEST POSSIBLE FIT TO A CURVE. ONE THEN PERFORMS AN ;;; ITERATION CALCULATING: ;;; A = (A + X/A)/2.0 ;;; ALL ARITHMETIC IS DONE WITHOUT ROUNDING EXCEPT LAST ADD. ;;; THREE ITERATIONS SHOULD SUFFICE; A3 IS THE RESULT. ;;; THE INITIAL APPROXIMATION CAN BE CALCULATED QUICKLY BY ;;; MEANS OF THE FOLLOWING TRICK. LET THE EXPONENT BE ;;; E = 2*I - J = 2*N + M ;;; SUCH THAT M IS 0 OR 1; THEN J=M AND I=N+M. MOREOVER, ;;; NOTE THAT THE PDP-10 EXPONENT X=E+200 (OCTAL), BECAUSE ;;; OF EXCESS-200 NOTATION. HENCE X=2*(N+100)+M. ;;; WE FIRST PICK OFF THE M BIT AS A SEPARATE WORD AND ;;; SHIFT IT RIGHT. THANKS TO THE PARTICULAR REPRESENTATION ;;; OF EXPONENT AND FRACTION, THIS PRODUCES A WORD WITH ;;; A FRACTION OF M/2. NOW WE WILL ADD TOGETHER THIS WORD, ;;; THE ORIGINAL ARGUMENT, AND A MAGIC CONSTANT, AND SHIFT ;;; THE SUM RIGHT BY 1. SHIFTING AFTERWARDS GIVES GREATER ;;; ACCURACY AND TAKES FEWER INSTRUCTIONS, BUT FOR PURPOSES ;;; OF EXPOSITION LET US ASSUME THE THREE SUMMANDS TO HAVE ;;; BEEN PRE-SHIFTED. ;;; SHIFTING THE ORIGINAL ARGUMENT RIGHT PRODUCES A WORD WITH ;;; FRACTION F/2+M/2 AND MACHINE EXPONENT N+100. SHIFTING ;;; THE M/2 PRODUCES M/4. THE MAGIC CONSTANT IS CHOSEN SUCH ;;; THAT, WHEN SHIFTED, ITS FRACTION IS C (0.4826004) AND ;;; ITS MACHINE EXPONENT IS 100. ADDING THESE TOGETHER ;;; PRODUCES FRACTION F/2 + 3*M/4 + C AND MACHINE EXPONENT ;;; N+200. HOWEVER, SINCE F IS NORMALIZED, THE ADDITION ;;; OF 3*M/4 IS GUARANTEED TO OVERFLOW INTO THE EXPONENT FIELD; ;;; THIS RESULTS IN SUBTRACTING M/4 FROM THE FRACTION, AND ;;; ADDING M INTO THE MACHINE EXPONENT. THE RESULT IS THUS: ;;; (C + F/2 - M/4) * 2.0^(N+M) ;;; WHICH IS THE DESIRED VALUE. SQRT: PUSH P,CFLOAT1 SQRT.: JSP T,FLNV1 JUMPG TT,SQRT.. JUMPL TT,SQR$ER ;NEGATIVE ARG IS AN ERROR POPJ P, ;ZERO ARGUMENT => ZERO ;;; POSITIVE ARGUMENT IS IN TT NOW SQRT..: MOVE R,TT ;SAVE ARGUMENT IN R FOR LATER MOVS D,TT ANDI D,1000 LSH D,22-1 ;D HAS M/2 AS A SINGLE BIT ADD TT,D ;ADD INTO ORIGINAL ARGUMENT ADD TT,[200756135462] ;EXPONENT 200, FRACTION 2*0.4826004 LSH TT,-1 ;NOW WE HAVE INITIAL APPROXIMATION IRPC ROUND,,[ R]AC,,[DDR] IFSN AC,R, MOVE D,R ; TT + R/TT FDV AC,TT ;COMPUTE TT <- --------- FAD!ROUND TT,AC ; 2 FSC TT,-1 ;LAST TIME ONLY, ADD ROUNDED TERMIN POPJ P, | ;END OF ANOTHER OLD SQRT ALGORITHM ;;; I HAVE NO IDEA HOW THIS WORKS! - GLS ;;; THANKS TO RJF AND KAHAN. ;;; KAHAN CLAIMS THE ERROR LIES BETWEEN -.5 AND +.516 LSB'S SQRT: PUSH P,CFLOAT1 SQRT.: PUSHJ P,NUMFLT JUMPG TT,SQRT.. JUMPL TT,SQR$ER ;NEGATIVE ARG IS AN ERROR POPJ P, ;ZERO ARGUMENT => ZERO ;;; POSITIVE ARGUMENT IS IN TT NOW SQRT..: MOVE R,TT ;SAVE ARG FOR LATER ASH TT,-1 ADD TT,[265116421] ;THAT'S 265116421 (KAHAN BLACK MAGIC) TLON TT,400 JRST SQRT.2 FMPRI TT,301461 ;(301461)=(FSC 1.19140625 100) JRST SQRT.3 SQRT.2: FMPRI TT,300653 ;(300653)=(FSC 0.833984375 100) ;NOW TWO NEWTON ITERATIONS, MODIFIED SQRT.3: MOVE D,R FDV D,TT ;UNROUNDED DIVIDE FAD TT,D ;UNROUNDED ADD ; FSC TT,-1 SUB TT,[1000002645] ;KAHAN SEZ: INSTEAD OF DIVISION BY 2, SUBTRACT 1000002645 FDV R,TT ;UNROUNDED DIVIDE FADR TT,R ;ROUNDED ADD! FSC TT,-1 POPJ P, ;;; A FEW HINTS, PAINFULLY WORKED OUT BY GLS AND RZ: ;;; THE ASH BY -1 DIVIDES THE EXPONENT BY 2, AND MUNCHES ;;; THE MANTISSA IN A BIZARRE WAY. ;;; THE ADDITION OF 265116421 IS GUARANTEED TO CARRY ;;; INTO THE 3.9 BIT, ASSUMING A NORMALIZED INPUT. THIS ;;; WILL COMPLEMENT THE ORIGINAL LOW EXPONENT BIT. ;;; THIS IS THEN TESTED BY THE TLON, WHICH ALSO FORCES ;;; THE 3.9 BIT ON, MAKING THE NEW NUMBER NORMALIZED. ;;; THE SUBTRACTION OF 1000002645 INDEED DIVIDES BY 2, ;;; BY SUBTRACTING 1 FROM THE EXPONENT; AND THE REST DOES ;;; A WEIRD LITTLE PERTURBATION WHICH, HOWEVER, CANNOT ;;; BORROW FROM THE EXPONENT. SUBTTL LOG FUNCTION LOG: PUSH P,CFLOAT1 LOG.: PUSHJ P,NUMFLT LOG..: JUMPLE TT,LOG.ER ;NON-POSITIVE ARG IS AN ERROR MULI TT,400 HRREI TT,-201(TT) ;SAVE CHARACTERISTIC IN TT LSH D,-8. ;REDUCE ARG TO VALUE X BETWEEN 1.0 AND 2.0 TLO D,201000 MOVEI R,0 CAMN D,FPWUN ;LOG(1.0)=0.0 (ALSO FOR WHOLE POWERS OF 2 THIS SAVES TIME) JRST LOG.2 MOVE T,D ; X - SQRT(2) FSBR T,ROOT2 ; T <- ------------- FADR D,ROOT2 ; X + SQRT(2) FDVRB T,D FMPR D,D ; D <- T*T MOVEI F,3 ;MOBY APPROXIMATION TO LOG BASE 2 LOG.1: FMPR R,D FADR R,LOG.CF(F) SOJGE F,LOG.1 FMPR R,T FADR R,[0.5] LOG.2: JSP T,IFLOAT ;FLOAT CHARACTERISTIC FADR TT,R ;ADD TO LOG OF MANTISSA FMPR TT,[0.6931471806] ;MULTIPLY BY LN 2 TO GET LOG BASE E POPJ P, ROOT2: 1.4142135625 ;SQRT(2) LOG.CF: 2.885390073 ;COEFFICIENTS FOR LOG APPROXIMATION 0.9618007623 0.5765843421 0.4342597513 NUMFLT: IFE BIGNUM, JSP T,FLTSKP IFN BIGNUM, JSP T,NVSKIP IFN BIGNUM, JRST NUMFL3 JSP T,IFLOAT POPJ P, IFN BIGNUM,[ NUMFL3: PUSH P,A PUSHJ P,FLBIG JRST POPAJ ] ;END OF IFN BIGNUM SUBTTL ATAN FUNCTION ATAN: PUSH P,CFLOAT1 ATAN.: EXCH A,B PUSHJ P,NUMFLT PUSH FXP,TT MOVEI A,(B) PUSHJ P,NUMFLT POP FXP,D MOVM R,TT ;GET ABSOLUTE VALUE OF Y MOVM F,D ;GET ABSOLUTE VALUE OF X MOVEM R,ATAN.Y ;SAVE ABS(Y) MOVEM F,ATAN.X ;SAVE ABS(X) HLR D,TT ;D HAS ,, MOVEM D,ATAN.S ;SAVE THAT MESS (HAS SIGNS OF X AND Y) MOVE T,R JFCL 8,.+1 FSBR T,F ; ABS(Y)-ABS(X) FADR R,F ; T <- ----------------- FDVRB T,R ; ABS(Y)+ABS(X) FMPR R,R ; R <- T*T MOVE D,ATAN.C+7 ;MOBY APPROXIMATION MOVEI F,6 ATAN.1: FMPR D,R FADR D,ATAN.C(F) SOJGE F,ATAN.1 FMPR D,T MOVM TT,D CAMGE TT,[.7855] CAMGE TT,[.7853] JRST ATAN.3 JUMPGE D,ATAN.2 ;PATCH UP FOR WHEN RATIONAL APPROXIMATION NOT VERY GOOD MOVE D,ATAN.Y ;WE CAN USE Y/X FOR ATAN (Y/X) FDVR D,ATAN.X JRST ATAN.4 ATAN.2: MOVN D,ATAN.X FDVR D,ATAN.Y FADR D,PI%2 JRST ATAN.4 ATAN.3: FADR D,[0.7853981634] ;PI/4 ATAN.4: MOVN TT,D ;NOW WE HAVE A QUADRANT 1 RESULT (CALL IT Q) FADR TT,PI% ;PATCH-UP STUFF TO GET RIGHT QUADRANT SKIPL F,ATAN.S ; X>0 I X<0 EXCH D,TT ;-------------------------I------------------------- FSC D,1 ; D <- PI-Q I D <- Q TRNE F,400000 ; TT <- Q I TT <- PI-Q FADR TT,D ; Y>0 I Y<0 I Y>0 I Y<0 JFCL 8,ATAN.7 ;------------I------------I------------I------------ POPJ P, ; TT<-Q I TT<-2*PI-Q I TT<-PI-Q I TT<-PI+Q PI%: 3.1415926536 ;A WELL-KNOWN NUMBER ATAN.C: 0.9999993329 ;COEFFICIENTS FOR ATAN APPROXIMATION -0.3332985605 0.1994653599 -0.139085335 0.0964200441 -0.0559098861 0.0218612288 -0.004054058 SUBTTL EXP FUNCTION EXP: PUSH P,CFLOAT1 EXP.: JSP T,FLTSKP JSP T,IFLOAT EXP..: SETZ R, MOVEM TT,EXP.S ;SAVE SIGN OF ARG ON PDL MOVM TT,TT ;GET ABSOLUTE VALUE OF ARG CAMLE TT,[88.0] ;WAS REQUESTED POWER > 88.0? JRST EXP.A ;YES, CAN'T REPRESENT SOMETHING THIS BIG FMPR TT,[0.4342944819] ;LOG BASE 10. OF E ;FROM NOW ON WE DO 10.^X, NOT E^X MOVE F,FPWUN ;F HOLDS 10.^ CAMG TT,FPWUN ;IF ARG <=1.0 GO DO RATIONAL APPROXIMATION JRST EXP.RX MULI TT,400 ASHC D,-243(TT) ;D GETS INTEGER PART OF ARG ; CAIG D,43 ;THIS IS OLD CHECK, JONL SAYS OK TO ALLOW JRST EXP.1 ; LARGER RANGE EXP.A: SKIPGE TT,EXP.S ;TOO LARGE - RESULT CAN'T BE REPRESENTED TDZA TT,TT JRST EXP.ER POPJ P, ;NEGATIVE ARG PRODUCES ZERO (UNDERFLOW) EXP.1: CAIG D,7 ;SKIP IF INTEGER PART OF ARG > 7 JRST EXP.2 LDB T,[030300,,D] ;GET TOP 3 BITS OF 6 BIT INTEGER PART ANDI D,7 ;AND THEM OUT OF D MOVE F,INTLG(T) ;F GETS (10.^T)^8. = 10.^(T*8.) FMPR F,F FMPR F,F FMPR F,F EXP.2: FMPR F,INTLG(D) ;MULTIPLY F BY APPROPRIATE 10.^D (0<=D<=7) LDB TT,[103300,,R] ;NOW GET FRACTION PART OF ARG TLO TT,177000 ;THIS STRANGENESS FLOATS FADR TT,TT ; AND NORMALIZES THE FRACTION EXP.RX: MOVEI T,6 ;MOBY APPROXIMATION SKIPA R,EXP.CF+6 EXP.3: FADR R,EXP.CF(T) FMPR R,TT SOJGE T,EXP.3 FADR R,FPWUN FMPR R,R FMPR F,R ;MULTIPLY FRACTION APPROXIMATION BY 10.^ MOVE TT,FPWUN SKIPL EXP.S SKIPA TT,F ;IF ARG>0, RETURN RESULT FDVR TT,F ;IF ARG<0, RETURN 1.0/RESULT POPJ P, EXP.CF: 1.151292776 ;COEFFICIENTS FOR EXP APPROXIMATION 0.6627308843 0.2543935748 0.07295173666 0.01742111988 2.55491796^-3 9.3264267^-4 FPWUN: ;FLOATING POINT 1.0 INTLG: 1.0 ;TABLE OF 10.^X FOR INTEGRAL 0<=X<=7 REPEAT 7, 1.0^<.RPCNT+1> C1.0E5=FPWUN+5 PGTOP ARI,[ARITHMETIC SUBROUTINES] ;;@ END OF ARITH 84 ;;; REMEMBER THE SUNDER HACK, AND DONT HACK THIS $INSRT IFN BIGNUM,[ ;;@ BIGNUM 17 BIGNUM ARITHMETIC PACKAGE ;;; ***** MACLISP ****** BIGNUM ARITHMETIC PACKAGE ************** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT BIG SUBTTL BIGNUM PACKAGE - RANDOM ROUTINES ;THE BIGNUM ARITHMETIC PAGE - SPECIAL STUFF FOR BIGNUM OPERATIONS ONLY YPOCB: PUSH P,[NREVERSE] BCOPY: HRRZ C,A ;COPIES A BIGNUM IN ACCUMULATOR A [INTERNAL FORMAT] PUSH P,A MOVEI AR1,(P) ;CLOBBERS C AR1 TT D BCOP1: JUMPE C,POPAJ HLRZ TT,(C) MOVE TT,(TT) PUSHJ P,C1CONS HRRM A,(AR1) HRRZ AR1,(AR1) ;UPDATE POINTER TO END OF LIST HRRZ C,(C) ;GET NEXT OF LIST TO BE COPIED JRST BCOP1 BNARSV: PUSH P,C ;SAVE ACCUMULATORS PUSH P,AR1 PUSH P,AR2A MOVEM F,FACD MOVEM R,FACF JRST (T) BNARRS: POP P,AR2A ;RESTORE ACCUMULATORS POP P,AR1 POP P,C MOVE F,FACD MOVE R,FACF JRST (T) PLOV: PUSH P,AR1 ;OVERFLO WHILE ADDING OR SUBBING TWO FIXNUMS SKIPN TT,D JRST PLOV2 TLNN TT,400000 MOVNS TT TLZ TT,400000 PUSH FXP,TT PUSHJ P,ABSOV MOVE A,(A) HLR B,(A) POP FXP,(B) SKIPL D TLC A,-1 SKIPA D,A PLOV2: MOVE D,BNM236 POP P,AR1 JRST T13 PL1BN: EXCH D,TT ;FIXNUM SUM MEETS BIGNUM ARG PUSHJ P,BNCVTM EXCH D,TT JRST T11 TIMOV: MOVEM T,AGDBT ;OVERFLO WHILE MULING TWO FIXNUMS PUSHJ P,BNCV MOVE D,A MOVE TT,AGDBT PUSHJ P,BNCVTM JRST BNTIM TIM1BN: JUMPE D,T14EX ;FIXNUM PRODUCT MEETS BIGNUM NEXT ARG EXCH D,TT PUSHJ P,BNCVTM EXCH D,TT JRST T11 T2: MOVE D,TT T12: MOVE A,(F) ;BIGNUM ARITHMETIC LOOP JSP T,NVSKIP XCT 4(R) ;OPERATE ON TWO BIGNUMS JRST 2(R) ;DISPATCH TO OPERATE ON BIGNUM SUM WITH FIXED EXCH D,TT ;CONVERT BIGNUM SUM TO FLOATING PUSHJ P,FLBIG EXCH D,TT JRST T7 ;AND ENTER FLOATING POINT LOOP PL2BN: PUSHJ P,BNCVTM ;BIGNUM SUM MEETS FIXNUM NEXT ARG JRST T11 TIM2BN: JUMPE TT,T14EX1 ;BIGNUM PRODUCT MEETS FIXNUM NEXT ARG PUSHJ P,BNCVTM EXCH D,TT T11: XCT 4(R) ;TRANSFERS TO BNTIM T13: AOBJN F,T12 T13X: MOVE A,D SUB P,PLUS8 JRST BNCONS BNDF: JSP A,BNPL1 ;DIFFERENCE OF TWO BIGNUMS BNPL: JSP A,BNPL1 ;PLUS OF TWO BIGNUMS BNPL1: EXCH A,D MOVE B,TT JSP T,BNARSV PUSHJ P,BNADD(D)-BNPL1 T19A: PUSHJ P,BNTRSZ ;SKIPS 2 IF ALL RIGHT MOVE D,[1_43] JRST T19B MOVE D,A HRRZ B,(A) ;WHAT IF OPERATE RESULTS IN SCRUNCHING JUMPN B,T19C ;ACCUMULATED VALUE INTO ONE WORD? HLRZ D,(A) MOVE D,(D) JUMPGE A,.+2 MOVNS D T19B: JSP T,BNARRS JRST 2,@[T14E] T19C: JSP T,BNARRS JRST T13 BNXTIM: JUMPE TT,0POPJ ;FIXNUM IN TT TIMES ABS(BIGNUM IN A) HRRZ D,(A) SETOM REMFL PUSHJ P,BNCVTM ;CONVERT FIXNUM TO BIGNUM FOR BNMUL BNTIM: JSP T,BNARSV ;PRODUCT OF TWO BIGNUMS MOVE A,D MOVE B,TT PUSHJ P,BNMUL JSP T,BNARRS MOVE D,A SKIPN REMFL JRST T13 SETZM REMFL JRST BNCONS ;FOR BNXTIM, CONS UP A REAL BIGNUM DIVSEZ: SKIPA D,BNM235 ;DIVISION BY 1_43 [-2E35.] REM2BN: JUMPE TT,BPDLNKJ DV2BN: JSP T,BNARSV ;BIGNUM DIVIDEND GETS FIXNUM DIVISOR MOVE A,D JUMPN TT,DV2BN1 SKIPN RWG JRST OVFLER MOVEI TT,1 ;ON ATTEMPT TO DIVIDE BY ZERO [WHEN RWG NOT ZERO] JUMPGE A,.+2 MOVNS TT MOVEM TT,BNV1 MOVE B,BNV2 PUSHJ P,BNADD JRST T19A DV1BN: CAME D,[400000,,] ;FIXNUM DIVIDEND, BIGNUM DIVISOR TDZA TT,TT ;ORDINARILY ZERO SKIPA D,BNM235 ;BUT -4_41/4_41 => 1, NOT 0 JRST T14EX1 BNDV: MOVE B,TT ;BIGNUM QUOTIENT, BIGNUM DIVEND MOVE A,D JSP T,BNARSV PUSHJ P,BNQUO SKIPE REMFL CAMN TT,XC-1 JRST T19A SETZM REMFL JSP T,BNARRS MOVE D,A ;DIVIDE OUT NORMALIZATION JRST DV2BN DV2BN1: MOVEM A,NORMF ;SO DIVIDE A BIGNUM BY A REGULAR FIXNUM PUSHJ P,REVERSE MOVE AR1,NORMF ;AR1 HAS SIGN OF ORIGINAL ARG IN LH HRR AR2A,A ;AR2A HAS SIGN OF PRODUCT ON COPY HLL AR2A,AR1 JUMPGE TT,DV2BN2 MOVNS TT JUMPL TT,DV2BN3 ;FOO! LOUSY SETZ CASE - PRODUCT WILL BE NEGATIVE TLC AR2A,-1 DV2BN2: HRRZ C,(A) MOVE D,TT HLRZ F,(A) MOVE F,(F) MOVEI R,0 DIV R,D MOVE TT,R PUSHJ P,C1CONS BNFXLP: MOVE B,A JUMPE C,D1FIN MOVE R,F HLRZ F,(C) MOVE F,(F) DIV R,D MOVE TT,R PUSHJ P,C1CONS HRRM B,(A) HRRZ C,(C) JRST BNFXLP DV2BN3: MOVE TT,BNM235 JSP T,BNARRS JRST BNDV D1FIN: HLL A,AR2A PUSHJ P,BNTRUN EXCH A,AR2A MOVEI B,NIL PUSHJ P,RECLAIM ;RECLAIM ONLY FREE STORAGE EXCH A,AR2A SKIPN REMFL JRST T19A MOVE D,F JUMPGE AR1,.+2 MOVNS D JSP T,BNARRS MOVEI B,TRUTH PUSHJ P,RECLAIM ;RECLAIM QUOTIENT SPACE, SINCE ONLY REMAINDER NEEDED JRST T14EX SUBTTL GENERAL UTILITY ROUTINES FOR BIGNUM ARITHMETIC BNTRUN: HRR AR1,A ;TRUNCATE OFF LEADING ZEROS FROM BIGNUM HRRZ B,(AR1) ;PRESERVE LH OF AR1 JUMPE B,CPOPJ BNTR4: MOVS C,(B) SKIPE (C) HRR AR1,B HLRZ B,C JUMPN B,BNTR4 HRRZ C,(AR1) HLRM C,(AR1) JUMPE C,CPOPJ ;EXIT IF THERE WERE NO LEADING ZEROS EXCH A,C PUSHJ P,RECLAIM ;OTHERWISE, RECLAIM SPACE OCCUPIED EXCH A,C ; BY LIST HOLDING THEM (B IS ZERO) POPJ P, BNTRSZ: JUMPGE A,BNPJ2 ;SKIPS 2 IF NOT -1_43 IN BIGNUM FORMAT. ELSE NO SKIP BNTRS1: HRRZ AR1,(A) ;MUNGS ONLY AR1 JUMPE AR1,BNPJ2 MOVS AR1,(AR1) TLNE AR1,-1 JRST BNPJ2 HLL AR1,(AR1) ;ALL THIS KLUDGERY SO THAT RANDOM TLNE AR1,-1 ; NUMERIC QUANTITIES WILL NOT GET JRST BNPJ2 ; IN THE RIGHT HALF OF AR1 HRLZ AR1,(AR1) TLC AR1,1 JUMPN AR1,BNPJ2 HLRZ AR1,(A) SKIPN (AR1) POPJ P, BNPJ2: POP P,AR1 JRST 2(AR1) BNCV: PUSH FXP,D PUSHJ FXP,SAV5M1 PUSHJ P,BNCVTM MOVE A,TT PUSHJ P,BCOPY JRST UUOSE1 BNCVTM: JUMPL TT,T16 ;CONVERT NUMBER IN TT TO INTERNAL BIGNUM T17: MOVEM TT,BNV1 MOVE TT,BNV2 POPJ P, T16: MOVNS TT JUMPL TT,T23 ;400000,, PUSHJ P,T17 TLCA TT,-1 T23: MOVE TT,BNM235 ;CONVERTED TO BIGNUM -2E35. POPJ P, SUBTTL BIGNUM ADDITION SUBROUTINE BNSUB: TLC B,-1 ;CHANGE SIGN OF 2ND ARG BNADD: MOVE C,A ;FIRST ARGUMENT TO C HLLZ A,C ;SET UP NULL BIGNUM WITH SIGN OF FIRST ARG PUSH P,A HLLZ F,B ;DITTO SECOND ARG MOVEI R,BNADD2 ;SET UP FOR REAL ADD CAME A,F ;CHECK FOR SAME SIGNS MOVEI R,BNSUB2 ;CHANGE TO SUBTRACT MOVE F,P ;F POINTS TO BOTTOM WORD OF ANSWER MOVEI TT,0 ;ARITHMETIC DONE IN TT BN4: MOVE AR2A,C MOVE C,(C) ;CDR C MOVE B,(B) ;CDR B BN15: MOVEI D,0 ;CLEAR CARRY HLRZ AR1,C ADD TT,(AR1) HLRZ AR1,B XCT -1(R) ;ADD/SUB TT,(AR1) TLZE TT,400000 ;CARRY OR BORROW MOVE D,-2(R) ;PLUS OR MINUS 1 JSP T,FWCONS MOVE AR1,A PUSHJ P,ACONS HRRM A,(F) ;NCONC ONTO ANSWER MOVE F,A ;UPDATE POINTER TO LAST WORD BN20: TRNN B,-1 ;END OF SECOND ARG? JRST @-3(R) BN7: TRNN C,-1 ;END OF FIRST ARG? JRST (R) BN9: MOVE TT,D ;MOVE CARRY TO TT JRST BN4 BN5 1 ;CARRY ADD TT,(AR1) BNADD2: JUMPN D,BN8 ;FIRST ARG DONE; IF CARRY, SIMULATE A ZERO BN14: HRRM B,(F) ;USE REST OF SECOND ARG JRST POPAJ BN8: MOVEI C,[R70,,] JRST BN9 BN5: JUMPN D,BN6 ;2ND ARG EXHAUSTED; IF CARRY, SIMULATE A ZERO BN13: HRRM C,(F) JRST POPAJ BN6: MOVEI B,[R70,,] JRST BN7 BN12 -1 ;BORROW SUB TT,(AR1) BNSUB2: ;COME HERE ONLY IF ABS(1) 36., then the jump to BQC2 seems to be wrong. ; also as far as I can tell, no other case gets to that jump instruction. ; - JONL - 12/13/79 ;;; CAMN T,R ;;; CAMG TT,F ;;; JRST BQ7 ;;; JRST BQC2 JRST BQ7 BQFIN: SKIPE REMFL JRST REMFIN SETZB A,B EXCH A,-1(P) PUSHJ P,RECLAIM EXCH A,-2(P) ;NOTE: RECLAIM RETURNED NIL AOSE NORMF PUSHJ P,RECLAIM POP P,A SUB P,R70+2 JRST BNTRUN BQSUB: MOVEI R,0 ;THIS MULTIPLIES DIVISOR BY PARTIAL QUOTIENT ESTIMATE BQSUB0: MOVE AR2A,A ;AND SUBTRACTS FROM THE PARTIAL REMAINDER MOVE A,(A) ;AND ADDS BACK IF THE ESTIMATE WAS TOO LARGE MOVE B,(B) ;THE NEW PARTIAL REMAINDER IS STORED IN HLRZ T,B ;THE SAME WORDS AS THE OLD PART. REM. MOVE T,(T) MUL T,D MOVS AR1,A ADD TT,R TLZE TT,400000 AOS T EXCH TT,(AR1) SUBB TT,(AR1) TLZE TT,400000 AOS T MOVEM TT,(AR1) TRNN B,-1 JRST BQSUB1 BQSUB7: TRNN A,-1 JRST BQSUB3 MOVE R,T JRST BQSUB0 BQSUB1: JUMPN T,BQSUB6 MOVE A,C POPJ P, BQSUB6: MOVEI B,[R70,,NIL] JRST BQSUB7 ;;; KNUTH SAYS THE FOLLOWING PIECE OF CODE (ADDING BACK) IS ;;; NEEDED IN ONLY ABOUT 3 OR 4 CASES IN 34 BILLION. HERE ;;; ARE TWO NUMBERS ACCIDENTALLY DISCOVERED BY GOSPER WHICH ;;; WILL CAUSE THIS ADDING BACK TO HAPPEN: ;;; THE DIVIDEND IS: ;;; 2791789817939938387128631852330682768655711099796886 ;;; 76652915704481188064205113686384821261582354 ;;; 6679451522036433421137784129286923496509. ;;; THE DIVISOR IS: ;;; 888654299197548479101428655285643704385285845048283 ;;; 973585973531. ;;; TO SEE WHY HE DISCOVERED IT, TRY LOOKING AT THE QUOTIENT! ;;; ;;; HERE ARE TWO MORE NUMBERS WHICH EXCUTE THIS CODE; FURTHERMORE, ;;; THEY CAUSE THE OVER-SUBTRACTED DIVIDEND TO BE SHORTER THAN ;;; THE DIVISOR; THIS IS THE REASON FOR THE COPYING BELOW. ;;; (GOSPER ALSO DISCOVERED THESE NUMBERS!) ;;; THE DIVIDEND IS: ;;; 814814390533794434507378275363751264420699600792121 ;;; 5135985742227369051304412442580926595072. ;;; THE DIVISOR IS: ;;; 10889035741470030830827987437816582766593. BQSUB3: HLLZS (AR2A) ;CHOP OFF END OF ANSWER STORAGE TRZ AR2A,777777 MOVE A,C PUSHJ P,BNTRUN ;TRUNCATE ANSWER, WHICH IS A NEGATIVE NUMBER IN POSITIVE FORM PUSH P,A HRRZ A,-4(P) ;GET (ABSOLUTE VALUE OF) DIVISOR PUSHJ P,BCOPY ;MUST COPY IT, OR ELSE CARRY POP P,B ; TRUNCATION MIGHT CLOBBER IT! PUSHJ P,BNADD ;SET UP ANSWER FOR ADD BACK SKIPA B,A BQSUB4: MOVE B,(B) ;CHOP OFF CARRY MOVE C,(B) HRRZ AR1,(C) JUMPN AR1,BQSUB4 MOVE AR2A,B ;CARRY WILL BE CHOPPED OFF WHEN THIS POPJ'S SOS QHAT ;CORRECT QUOTIENT GUESS POPJ P, SUBTTL BIGNUM TO FLONUM CONVERSION FLBIGF: JUMPN R,FLBIG PUSH P,CFLOAT1 FLBIG: PUSHJ P,SAVX5 ;RECEIVES BIGNUM HEADER IN TT, HLRZ A,TT ;LEAVES SIGN BIT IN AC A HRRZ T,(TT) ;LEAVES RESULT AS NUMERIC IN TT JUMPE T,FLTB1 ;SAVES ALL OTHER ACS PUSHJ P,FLBIGZ FADR TT,D ;ROUND UP SKIPE RWG JFCL 8.,FLBIGX JFCL 8.,FLBIGO FLBIGX: JUMPE A,.+2 MOVNS TT MOVEM TT,-3(FXP) JRST RSTX5 FLBIGZ: PUSHJ P,1HAU ;MUST BE > 27. BITS, OR ELSE WOULDN'T BE HERE MOVEI T,(TT) MOVEI D,27. PUSHJ P,1HAI1 ;1HAI1 LEAVES TRAILING BITS IN TT+1 ASH TT+1,-8. TLO TT,200000 ;INSTALL EXPONENTS TLO TT+1,145000 JFCL 8.,.+1 TRNE T,-1#377 ;INSURE OVERFLOW IF EXPONENT IS TOO LARGE TRO T,377 FSC TT,(T) FSC TT+1,(T) POPJ P, FLTB1: HLRZ TT,(TT) MOVE TT,(TT) ;ONE-WORD BIGNUM? JSP T,IFLOAT MOVE D,TT JRST FLBIGX FLBIGQ: HRROS (P) ;HACK SO THAT (*QUO ) JRST FLBIG ; WILL CAUSE UNDERFLOW, NOT OVERFLOW FLBIGO: PUSHJ P,RSTX5 POP P,T TLNN T,1 ;IF BIT 3.1 IS SET, SO IS 4.7 (SEE T7O0) JRST OVFLER AOJA T,T7O0 SUBTTL FLONUM TO BIGNUM CONVERSION FIXBIG: MOVE TT,T MULI TT,400 JSP T,BNARSV MOVE AR1,A MOVE F,D SUBI TT,200 IDIVI TT,43 SETZ R, ASHC R,(D) MOVE D,TT JUMPE R,FXBFQ MOVE TT,R JSP T,FWCONS PUSHJ P,NCONS MOVE TT,F MOVE C,A FXBFV: JSP T,FWCONS PUSHJ P,NCONS HRRM C,(A) MOVEI C,(A) FXBFZ: SOJLE D,FBFIN MOVEI TT,0 PUSHJ P,C1CONS HRRM C,(A) MOVEI C,(A) JRST FXBFZ FBFIN: SKIPG (AR1) TLC A,-1 JSP T,BNARRS JRST BNCONS FXBFQ: MOVEI C,0 MOVE TT,F JRST FXBFV MNSBG: TLC TT,-1 ;MINUS, FOR BIGNUM MOVE A,TT PUSH P,AR1 PUSH P,[POP4J] PUSHJ P,BNTRSZ ;FOR 100000000000, CONVERT MOVE TT,[1_43] ; TO FIXNUM SETZ, ELSE JRST FIX1 JRST BNCONS ; TO A REGULAR BIGNUM POP4J: POP P,AR1 POPJ P, SUBTTL ABS AND REMAINDER FOR BIGNUMS ABSBG0: MOVE TT,(A) ABSBG: JUMPGE TT,CPOPJ ;ABS FOR BIGNUM HRRZ A,TT JRST BGNMAK REMBIG: EXCH A,B MOVE D,TT ;REMAINDER FOR BIGNUM SETZM PLUS8 ;SO THAT ARITHMETIC LOOP WILL RESTORE TO HERE SETOM REMFL JSP T,NVSKIP JRST BNDV ;REMFL WILL STOP ARITHMETIC LOOP JRST REM2BN JSP T,REMAIR ;FOO! FLONUM ARG NOT COMPREHENSIBLE! GRBB: SETZM NORMF ;GREATERP FOR BIGNUM WITH BIGNUM MOVE A,D MOVE B,TT MOVE AR1,D MOVE AR2A,TT ASH TT,-43 ASH D,-43 CAME D,TT JRST GRB13 SETO C, GRBBL: TRNN AR1,-1 JRST GRB1 TRNN AR2A,-1 JRST GRB2 MOVS AR1,(AR1) MOVS AR2A,(AR2A) MOVE D,(AR1) MOVE TT,(AR2A) JUMPGE A,.+3 MOVNS D MOVNS TT XCT GRESS0 JRST GRBF SETZ C, GRBR: MOVSS AR1 MOVSS AR2A JRST GRBBL SUBTTL GREATERP AND LESSP FOR BIGNUMS GRFXB: SETZM NORMF ;GREATERP FOR FIXNUM WITH BIGNUM PUSH FXP,D MOVE B,TT MOVEI AR2A,QBIGNUM MOVEI AR1,QFIXNUM TLNE D,400000 SKIPA D,XC-1 MOVEI D,1 JRST GRB14 GRBFX: SETZM NORMF ;GREATERP FOR BIGNUM WITH FIXNUM PUSH FXP,TT MOVE A,D MOVEI AR1,QBIGNUM MOVEI AR2A,QFIXNUM TLNE TT,400000 SKIPA TT,XC-1 MOVEI TT,1 JRST GRB14 GRBF: CAMN D,TT JRST GRBR SETO C, JRST GRBR GRB1: TRNN AR2A,-1 JRST GRBBEL MOVEI D,2 MOVEI TT,4 GRB12: TLNE A,1 EXCH D,TT GRB13: MOVEI AR1,QBIGNUM MOVEI AR2A,QBIGNUM GRB14: XCT GRESS0 SKIPA C,[-1] MOVEI C,0 JRST GRBBE2 GRB2: SETOM NORMF MOVEI D,4 MOVEI TT,2 JRST GRB12 GRBBEL: MOVEI AR1,QBIGNUM MOVEI AR2A,QBIGNUM GRBBE2: MOVE D,A MOVE TT,B CAIN AR2A,QFIXNUM POP FXP,TT CAIN AR1,QFIXNUM POP FXP,D SKIPE NORMF MOVNS C SKIPN C XCT CSUCE XCT CFAIL SUBTTL HAIPART FOR BIGNUMS IFN USELESS,[ 1HAI: JSP T,FXNV2 JUMPLE D,3HAI PUSH FXP,D PUSHJ P,1HAU POP FXP,D CAILE D,35. JRST 2HAI PUSH P,CFIX1 ] ;END OF IFN USELESS ;IN USELESS VERSION, 1HAI CALLED ONLY BY FLBIG 1HAI1: ADDI R,-35.-1(D) ;FINAL ANSWER FITS IN ONE WORD HLRZ D,(F) ;SPREAD OUT HIGH WORD AND MOVE D,(D) ;NEXT-TO-HIGH WORD INTO TT,D HRRZ TT,(F) HLRZ TT,(TT) MOVE TT,(TT) ASHC TT,(R) POPJ P, IFN USELESS,[ 2HAI: SUBI TT,(D) JUMPLE TT,CPOPJ PUSHJ FXP,SAV3 ;COPY BIGNUM, BUT TOSS OUT LOW ORDER BITS IDIVI TT,35. ;HOW MANY BITS TO THROW AWAY MOVEI F,(A) HRRZ F,(F) SOJGE TT,.-1 MOVN C,D SUBI D,35. HLRZ TT,(F) MOVE TT,(TT) HRRZ F,(F) ;F IS CDR'ING DOWN INPUT JUMPE F,2HAI0 HLRZ T,(F) MOVE T,(T) ;C HOLDS AMNT TO SHIFT RIGHT BY ASHC T,(C) PUSHJ P,C1CONS MOVEI B,(A) 2HAI2: MOVEI R,(A) ;R HAS PTR TO LAST OF FORMING LIST HRRZ F,(F) JUMPE F,2HAI3 ASHC T,(D) ;MOVE T INTO TT HLRZ T,(F) MOVE T,(T) ASHC T,(C) PUSHJ P,C1CONS HRRM A,(R) JRST 2HAI2 2HAI0: ASH TT,(C) ;DEFINITELY A BUG TO COME HERE,SINCE WE JSP R,RSTR3 JRST FIX1 ;THINK WE ARE RETURNING A BIGNUM 2HAI3: JUMPE T,2HAI4 MOVE TT,T PUSHJ P,C1CONS HRRM A,(R) 2HAI4: MOVEI A,(B) PUSHJ P,BGNMAK POP P,C JRST POP2J ] ;END OF IFN USELESS ;;; THE CODE FOR 3HAI IS PUTCODED. IFN USELESS,[ SUBTTL GCD FOR BIGNUMS GCDBG: MOVEI F,1 ;INITIALIZE SMALLNUM MATRIX MOVEM F,GCD.A MOVEM F,GCD.D SETZM GCD.B SETZM GCD.C HLRZ R,(TT) ;GET LOW ORDER WDS OF ARGS MOVE R,(R) HLRZ F,(D) MOVE T,R ;LOW WD OF U IOR R,(F) PUSH FXP,R JUMPE R,GCDBG4 ;BOTH LOW WDS 0 MOVN R,R ANDM R,(FXP) ;GRTST COMMON PWR OF 2 OR 0 IF > 2^35. PUSH FXP,(F) ;LOW WD OF V. JUMPN T,GCDBG0 ;IF T=0 AND (F) EVEN, XTRA PWR OF 2 WILL EXCH A,B ; COME BACK FROM RECURSION, SO SWAP TO EXCH TT,D ; UNZERO T, THUS GUARANTEEING RECURSION WITH EXCH T,(FXP) ; AT LEAST 1 ODD ARG. GCDBG0: MOVEI R,(TT) ;GET HI WDS IF SAME LENGTH. MOVEI F,(D) HRRZ D,(D) HRRZ TT,(TT) JUMPE D,GCDBG2 JUMPN TT,GCDBG0 EXCH A,B ;B IS LONGER THAN A GCDBG1: SUB FXP,R70+2 PUSH P,B ;A IS LONGER THAN B PUSHJ P,REMAINDER ;SO GCD(A,B) = GCD(REMAINDER(A,B),B) POP P,B JRST GCD GCDBG2: JUMPN TT,GCDBG1 ;U,V UNEQUALLY LONG HLRZ R,(R) ;U,V EQUALLY LONG, HLRZ F,(F) ; GET ACTUAL HI WDS. MOVE TT,(R) MOVE D,(F) POP FXP,R ;TT,D HAVE HI WDS (OR 0 AND NON0 IF UNEQUAL LENGTH) MOVEI F,35. ;T,R HAVE LO WDS MOVEM F,GCD.UH ;SHFT CTR GCDBGU: TRNE T,1 JRST GCDBGV ;U IS ODD GCDBHU: LSH T,-1 LSH D,1 ;TT RIGHT 1 REL TO D JUMPGE D,.+3 LSH D,-1 LSH TT,-1 MOVE F,GCD.C ;HALVING A, B EQUIV TO DOUBLING C,D ADDM F,GCD.C MOVE F,GCD.D ADDM F,GCD.D SOSE GCD.UH JRST GCDBGU GCDBG4: PUSH P,A PUSH P,B MOVE TT,GCD.A PUSHJ P,BNXTIM PUSH P,A ;T <- A*U MOVE A,-1(P) MOVE TT,GCD.B PUSHJ P,BNXTIM POP P,B PUSHJ P,.PLUS ;T <- T+B*V PUSHJ P,BNLWFL EXCH A,-1(P) MOVE TT,GCD.C PUSHJ P,BNXTIM EXCH A,(P) ;W <- C*U MOVE TT,GCD.D PUSHJ P,BNXTIM POP P,B PUSHJ P,.PLUS ;W <- W+D*V PUSHJ P,BNLWFL POP P,B ;U <- T POP FXP,TT CAIN TT,1 JRST GCD PUSH FXP,TT PUSHJ P,GCD MOVEI B,(FXP) SKIPN (B) MOVEI B,BN235 ;CAN ONLY HAPPEN WHEN BOTH LO WDS 0 PUSHJ P,.TIMES SUB FXP,R70+1 POPJ P, GCDBGV: TRNE R,1 JRST GCDBGO ;BOTH U,V ODD GCDBHV: LSH R,-1 LSH TT,1 JUMPGE TT,.+3 LSH TT,-1 LSH D,-1 MOVE F,GCD.A ADDM F,GCD.A MOVE F,GCD.B ADDM F,GCD.B SOSE GCD.UH JRST GCDBGV JRST GCDBG4 BNLWFL: HRRZ B,(A) ;FLUSH LOW 35. ZEROS OF A JUMPE B,BNLWXX HRRZ B,(B) HRRZ C,(B) JUMPE C,BNLWFX ;IF BIGNUM BECOMES FIXNUM HRRM B,(A) POPJ P, BNLWFX: HLRZ A,(B) POPJ P, BNLWXX: SKIPE (A) MOVEI A,IN0-1 POPJ P, GCDBGO: CAML TT,D JRST GCDBGT SUB D,TT SUB R,T MOVN F,GCD.A ADDM F,GCD.C MOVN F,GCD.B ADDM F,GCD.D JRST GCDBHV GCDBGT: SUB TT,D SUB T,R MOVN F,GCD.C ADDM F,GCD.A MOVN F,GCD.D ADDM F,GCD.B JRST GCDBHU GCDBX: SKIPN D,(B) ;FIXNUM IS ZERO - RETURN BIGNUM JRST ABSBG0 ;MAYBE NEED TO TAKE ABS VALUE CAMN D,[400000,,] ;CHECK FOR NASTY -400000000000 CASE JRST GCDOV PUSH P,B ;ELSE TAKE A REMAINDER PUSHJ P,REMAINDER POP P,B JRST .GCD ;GUARANTEED TO HAVE TWO FIXNUMS NOW GCDOV: MOVEI B,(A) ;HANDLE NASTY -400000000000 CASES GCDOV1: PUSHJ P,ABSOV JRST GCD ] ;END OF IFN USELESS PGTOP BIG,[BIGNUM-ONLY ARITHMETICS] ;;@ END OF BIGNUM 17 ] SUBTTL EVAL, EVALHOOK, AND EVAL-WHEN PGBOT EVL POP3UB: POPI P,1 POP2UB: POPI P,2 JRST UNBIND EVALHOOK: JSP TT,LWNACK LA23,,QEVALHOOK MOVE D,T JSP T,SPECBIND ;BIND "EVALHOOK" TO LAST ARG -1_33. 0,VEVALHOOK CAME D,XC-2 JRST EVNH3 PUSH P,[POP2UB] MOVE A,-2(P) JRST EVNH0 EVNH3: PUSH P,[POP3UB] PUSH P,-3(P) PUSH P,-3(P) PUSHJ FXP,AEVAL EVNH0: SKIPN V.RSET ;EVALUATE, BYPASSING HOOK CHECK JRST EV0 .SEE STORE JRST EVAL0 OEVAL: JSP TT,LWNACK ;"EXTERNAL" EVAL - LSUBR (1 . 2) LA12,,QOEVAL ;MAY TAKE ALIST AS SECOND ARG AOJE T,OEVL1 PUSH P,[POP2J] ;PHOO! HAVE TO KEEP THE SAME EVALFRAME PUSH P,-2(P) ; PUSH P,-2(P) PUSHJ FXP,AEVAL ;MAKE UP ALIST, POP OFF 2, AND LEAVE ARG IN A JRST EVAL OEVL1: POP P,A EVAL: SKIPN V.RSET ;"INTERNAL" EVAL - ARG IN A JRST EV0 SKIPN B,VEVALHOOK JRST EVAL0 JSP T,SPECBIND ;SUPER-RANDOM HACK SO THAT MM VEVALHOOK ; CAN INVENT A ^N FOR LISP CALLF 1,(B) JRST UNBIND EVAL0: SKIPE NIL ;RANDOM PLACE TO CHECK FOR NIL CLOBBERED PUSHJ P,NILBAD PUSH P,FXP ;EVAL FRAME FORMAT: HRLM FLP,(P) ; FLP,,FXP PUSH P,A ; SP,, HRLM SP,(P) ; $EVALFRAME PUSH P,[$EVALFRAME] ;SEE APPLY FOR FORMAT OF APPLY FRAMES .SEE L$EVALFRAME ;FALLS THROUGH ;FALLS IN ;;; EVALUATE A FORM IN A EV0: JUMPE A,CPOPJ ;NIL => NIL, ALWAYS!!! MOVEI C,ILIST SKOTT A,LS 2DIF JRST (TT),EVTB1-1,QLIST .SEE STDISP IFN HNKLOG,[ TLNE TT,HNK JRST EV0H ;HUNK? ]; End of IFN HNKLOG, EV0A: MOVE AR1,(A) ;FUNCTION ON 0(P), ADDRESS TO JRST TO IN (TT) HLRZ T,AR1 SKOTT T,LS 2DIF JRST (TT),EVTB2-1,QLIST .SEE STDISP IFN HNKLOG,[ TRNE TT,HNK ;Hunk? JRST EVAPH ; Go apply it EV0ALS: ]; END of IFN HNKLOG, HLRZ TT,(T) CAIN TT,QLAMBDA JRST EXP3 CAIE TT,QFUNARG CAIN TT,QLABEL JRST EXP3 JUMPL C,EV3B SKIPE B,VOEVAL JCALLF 1,(B) ;EVALSHUNT HLRZ A,AR1 TLNN C,777740 ;MAYBE SAVE FUNCTION NAME IN EV0B MOVEM A,EV0B PUSH P,EV0B ;NON-ATOMIC FUNCTION, NOT LAMBDA, PUSH P,C ; LABEL, OR FUNARG PUSH P,AR1 PUSHJ P,EV0 ;SO EVALUATE THE FORM POP P,AR1 POP P,C POP P,EV0B JRST EV4 ;NOW TRY USING THE RESULT AS A FUNCTION IFN HNKLOG,[ ;; Apply a hunk EVAPH: PUSH P,T PUSH P,A MOVE A,T PUSHJ P,USRHNP ;Maybe this is a user-extended hunk? POP P,A JUMPE T,EV0AL0 ;Not ours, just like a list JSP TT,ILIST JRST IAPPLY EV0AL0: POP P,T JRST EV0ALS ;; Evaluate a hunk EV0H: PUSHJ P,USRHNP ;Maybe this is a user-extended hunk JUMPE T,EV0A ;No, go pretend it's a list PUSH P,A PUSH P,[QOEVAL] MOVNI T,2 XCT SENDI ;Let's send it an EVAL message POPJ P, ]; END of IFN HNKLOG, EVTB1: JRST PDLNKJ ;FIXNUMS EVALUATE TO THEMSELVES JRST PDLNKJ ;DITTO FLONUMS DB$ JRST PDLNKJ ;DITTO DOUBLES CX$ JRST PDLNKJ ;DITTO COMPLEXES DX$ JRST PDLNKJ ;DITTO DUPLEXES BG$ POPJ P, ;GUESS WHAT, FELLAHS JRST EE1 ;SOME HAIR FOR SYMBOLS HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS (SHOULD BE CAUGHT BEFORE THIS TABLE) JRST EV2 ;RANDOMS LOSE POPJ P, ;ARRAYS EVAL TO SELVES IFN .-EVTB1-NTYPES+1, WARN [WRONG LENGTH TABLE] EV2: %WTA EMS25 ;UNEVALUABLE DATUM (RANDOMNESS) JRST EV0 EVTB2: JRST EV3A ;FIXNUM AS A FUNCTION IS AN ERROR JRST EV3A ;DITTO FLONUM DB$ JRST EV3A ;DITTO DOUBLE CX$ JRST EV3A ;DITTO COMPLEX DX$ JRST EV3A ;DITTO DUPLEX BG$ JRST EV3A ;DITTO BIGNUM JRST EE2 ;SYMBOLS - THE GOOD CASE HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS JRST EV3A ;IT'S A TRULY RANDOM FUNCTION! JRST ESAR ;IT'S AN ARRAY IFN .-EVTB2-NTYPES+1, WARN [WRONG LENGTH TABLE] EE1: PUSHJ P,EVSYM ;EVALUATE SYMBOL POPJ P, ;WIN JRST EV0 ;LOSE - RETRY EE2: SETZ R, ;ZERO R FOR HACK TO TRAP AUTOLOAD LOSS EE2A: HRRZ T,(T) ;CAR (X) IS ATOMIC JUMPE T,EAL2 ;GET FUNCTION DEFINITION OFF ATOM HLRZ TT,(T) HRRZ T,(T) CAIL TT,QARRAY ;SYMBOL HEADERS FOR FUNCTION MARKERS CAILE TT,QAUTOLOAD ; ARE LINEAR IN MEMORY JRST EE2A 2DIF JRST @(TT),ETT,QARRAY ETT: EAR ;ARRAY ESB ;SUBR EFS ;FSUBR ELSB ;LSUBR AEXP ;EXPR EFX ;FEXPR EFM ;MACRO EAL ;AUTOLOAD EAL: HRRI R,(T) ;NOTE THAT WE SAW AUTOLOAD PROPERTY JRST EE2A EAL2: JUMPL R,EV3J ;FN UNDEF AFTER AUTOLOAD JUMPE R,EV3 ;NO AUTOLOAD PROP - TRY EVALING ATOM MOVEI B,(R) HLRZ T,(A) PUSHJ P,IIAL HLRZ T,(A) SETO R, JRST EE2A EFM: CAIE C,ILIST ;FOUND MACRO EFMER: LERR EMS21 ;IMPROPER USE OF MACRO MOVE B,AR1 HLRZ AR1,(T) ;COMMENT THIS CROCK CAIN A,AR1 PUSHJ P,CONS1 CALLF 1,(AR1) ;SO HAND THE FORM TO THE MACRO JRST EVAL ; AND RE-EVALUATE THE RESULT EFX: HLRZ T,(T) ;FOUND FEXPR HLL T,AR1 ;SO A FEXPR BEHAVES LIKE AN EXPR PUSH P,T ; WHOSE ONE ARG IS CDR OF THE FORM HRLI AR1,400000 .SEE IAP4 ;FOR EXPLANATION OF THIS HACK PUSH P,AR1 ; WHICH ALLOWS FEXPRS AN ALIST ARG, SEE MOVNI T,1 ; THE CODE AT IAPPLY JRST IAPPLY AEXP: HLRZ T,(T) ;FOUND EXPR HLL T,AR1 EXP3: PUSH P,T ;FOUND LAMBDA, LABEL, FUNARG MOVEI A,(AR1) CIAPPLY: MOVEI TT,IAPPLY JRST (C) EFS: HLRZ T,(T) ;FOUND FSUBR MOVEI C,ESB3 ;THIS IS SO WE DON'T EVAL THE ARGS! JRST ESB2 ELSB: PUSH P,CPOPJ ;FOUND LSUBR HLLM AR1,(P) MOVE R,T HLL R,AR1 MOVEI TT,ELSB1 HRRZ A,AR1 JRST (C) ELSB1: MOVEI A,NIL ;A HAS NIL WHEN ENTERING AN LSUBR HLRZ D,(R) SKIPN V.RSET JRST (D) HLRZ R,R PUSHJ P,ARGCK0 ;CHECK OUT NUMBER OF ARGS JRST ESB6 JRST (D) ESAR: SKIPA TT,T ;FOUND SAR EAR: HLRZ TT,(T) ;FOUND ARRAY MOVEI R,(TT) SKOTT TT,SA JRST EV3A EAR3: HRRZ T,ASAR(R) CAIN T,ADEAD JRST EV3A ;AHA! THIS ARRAY IS DEAD! PUSH P,R MOVEI T,EAR1 ;MUST DO SOME HAIR SO THAT JRST ESB4 ; INTERRUPTS WON'T SCREW US EAR1: MOVE T,LISAR ;DO NOT MERGE THIS WITH IAPAR1 JRST @ASAR(T) .SEE ESB3 ESB: HLRZ R,AR1 ;FOUND SUBR HLRZ T,(T) ESB4: MOVEI TT,ESB1 ESB2: MOVEI A,(AR1) ;A GETS LIST OF ARGS HLL T,AR1 PUSH P,T ;STORE ADDRESS OF SUBROUTINE FOR FN JRST (C) ;GO SOMEWHERE OR OTHER ESB1: PUSHJ P,ARGCHK JRST ESB6 MOVE TT,[A,,A+1] MOVEI A,Q..MIS BLT TT,A+NACS-1 JSP R,PDLA2(T) ESB3: HRRZ TT,(P) CAIN TT,EAR1 ;HACK TO HELP EAR1 WIN JRST ESB3C ESB3A: SKIPN V.RSET POPJ P, ;ADDRESS OF SUBR IS ON STACK MOVEI TT,CPOPJ ;WELL, MAYBE DO SOME *RSET HAIR HLL TT,(P) EXCH TT,(P) JRST (TT) ESB3C: HRRZ TT,-1(P) MOVEM TT,LISAR ;SAR PROTECTED BY BEING IN LISAR POP P,-1(P) JRST ESB3A EV3: SKIPE EVPUNT ;PUNT EVALUATION OF SYMBOL? JRST EV3A JUMPL C,EV3B ;C<0 => TOO MANY RE-EVALS OF A FN HLRZ A,AR1 HLRZ A,(A) HRRZ A,@(A) ;GET VALUE OF ATOMIC FUNCTION CAIN A,QUNBOUND ;IT'S UNBOUND. LOSE, LOSE, LOSE... JRST EV3A TLNN C,777740 ;SAVE FN NAME IN EV0B, MAYBE HLRZM AR1,EV0B EV4: ADD C,[1_34.] ;THIS SIZE OF THIS QUANTITY CONSTRAINS EV4B: HRL AR1,A ; THE # OF TIMES WE MAY RE-EVAL THE FN MOVEI A,AR1 JRST EV0A ;;; (EVAL-WHEN (. . . EVAL . . .) e1 e2 . . . en) does a progn on ;;; the ei, and returns non-null only if the evaluations were done. ;;; The context combined with the first arg list determines if any ;;; thing is done - if there is EVAL in this list, then the progn ;;; is done. EWHEN: HRRZ C,(A) SKOTT C,LS JRST FALSE PUSH P,C HLRZ B,(A) MOVEI A,QOEVAL PUSHJ P,MEMQ1 POP P,B JUMPE A,CPOPJ PUSHJ P,IPROGN JRST TRUE SUBTTL SYMEVAL SYMEV0: %WTA NASER SYMEVAL: JUMPE A,CPOPJ ;SUBR 1 JSP T,SPATOM JRST SYMEV0 PUSHJ P,EVSYM POPJ P, ;WON JRST SYMEVAL ;LOST ;;; EVALUATE ATOMIC SYMBOL. SKIPS ON FAILURE (AFTER DOING ERROR). EVSYM: HLRZ T,(A) ;T GETS POINTER TO SYMBOL BLOCK HRRZ T,@(T) ;AR1 GETS VALUE FROM VALUE CELL!!! CAIN T,QUNBOUND JRST EE1A ;FOOBAR! VALUE CELL CONTAINS UNBOUND MOVEI A,(T) ;SO THE VALUE IS THE RESULT OF EVAL POPJ P, EE1A: %UBV MES6 ;UNBOUND VAR JRST POPJ1 ;;; END OF EVSYM ROUTINE SUBTTL APPLY, *APPLY, SUBRCALL, LSUBRCALL, ARRAYCALL, FUNCALL APPLY: CAME T,XC-2 ;"EXTERNAL" APPLY - SUBR (2 . 3) JRST AP4 ;MAY TAKE A THIRD ALIST ARG JSP R,PDLA2(T) APPWT1: JUMPE B,AP3 ;ALLOW NIL AS SECOND ARG SKOTT B,LS ;SECOND ARG TO APPLY MUST BE A LIST JRST APPWTA .APPLY: ;SUBR 2 (*APPLY) AP3: SKIPN V.RSET JRST AP3A PUSH P,B PUSH P,FXP HRLM FLP,(P) PUSH P,A HRLM SP,(P) PUSH P,[$APPLYFRAME] AP3A: MOVEI AR1,(B) ;"INTERNAL" APPLY - HRL AR1,A ; FUNCTION IN A, LIST OF ARGS IN B MOVEI A,AR1 MOVEI C,AP2 ;THIS CROCK LETS US SHARE CODE WITH JRST EV0A ; EVAL BY PREVENTING EVAL'ING OF ARGS APPWTA: EXCH A,B WTA [MUST BE A LIST -- APPLY!] EXCH A,B JRST APPWT1 AP2: MOVEI T,0 ;DE-LISTIFY THE ARGS AND STACK THEM JUMPE A,(TT) ; ON THE PDL, AND ALSO COUNT THEM PUSH P,(A) ;DOING THINGS THIS WAY AVOIDS HLRZS (P) ; DESTROYING ANY OTHER ACS HRRZ A,(A) SOJA T,.-4 AP4: JSP TT,LWNACK ;APPLY WITH AN ALIST (GOOD GRIEF!) LA23,,QAPPLY MOVEM T,APFNG1 SKIPE A,(P) ;PURPOSELY CRIPPLING THE POWER OF JSP T,FXNV1 ; THE ALIST ROUTINE: FOOEY! - GLS PUSHJ P,ALIST ;SO CREATE MORONIC ALIST ENVIRONMENT EXCH T,APFNG1 JSP R,PDLA2(T) SKIPE APFNG1 ;ALIST RETURNING NON-ZERO IN T => PUSH P,CAUNBIND ; TWO BIND BLOCKS WERE PUSHED PUSH P,CAUNBIND JRST AP3 SUBRCALL: JSP TT,FWNACK ;LSUBR (2 . 7) FA234567,,QSUBRCALL JSP TT,JLIST ADDI T,1 JSP R,PDLARG POP P,TT JSP D,PTRCHK PUSHJ P,(TT) RETTYP: POP P,D ;PURELY FOR TYPE CHECKING CAIN D,QFIXNUM JSP T,FXNV1 CAIN D,QFLONUM JSP T,FLNV1 POPJ P, %LSUBRCALL: JSP TT,FWNACK ;FSUBR FA2N,,Q%LSUBRCALL JSP TT,JLIST MOVEI D,(P) ADDI D,(T) MOVEI TT,RETTYP EXCH TT,1(D) JSP D,PTRCHK AOJA T,(TT) PTRCHK: CAIL TT,BEGFUN CAIL TT,ENDFUN JRST .+2 JRST (D) CAML TT,BPSL CAML TT,@VBPORG JRST PTRCKE JRST (D) %ARRAYCALL: JSP TT,FWNACK ;FSUBR FA76543,,Q%ARRAYCALL JSP TT,JLIST MOVEI D,(T) ADDI D,(P) ;FALLS INTO FUNCALL %ARR7: HRRZ A,1(D) SKOTT A,SA SOJA T,%ARR0 MOVEI B,CPOPJ EXCH B,(D) HLRZ TT,@1(D) .SEE ASAR MOVEI F,AS CAIN B,QFIXNUM MOVEI F,AS CAIN B,QFLONUM MOVEI F,AS TRNN TT,(F) JRST %ARR0A FUNCALL: MOVEI D,QFUNCALL ;LSUBR (1 . 777) JUMPE T,WNALOSE ;(FUNCALL F X1 X2 ... XN) IS LIKE FUNCA1: SKIPN V.RSET ; (APPLY F (LIST X1 X2 ... XN)) AOJA T,IAPPLY ;IN *RSET MODE, WE FAKE ADDI T,1 ; OUT THE UUO STUFF MOVEI TT,(P) ; INTO DOING THE APPLY ADDI TT,(T) ; FRAME HACKERY FOR US MOVEI B,CPOPJ EXCH B,(TT) JCALLF 16,(B) ;;; VERY INTERNAL APPLY, FOR USE PARTICULARLY WITH "CALL" UUO'S ;;; ;;; STATE OF WORLD AT ENTRANCE TO IAPPLY: ;;; T HAS -. ;;; PDL HAS ARGS ON IT; BELOW THEM IS A SLOT ;;; WITH THE FUNCTION IN THE RIGHT HALF. ;;; THE FUNCTION'S NAME IS MAYBE IN THE LEFT HALF. ;;; C IS USED PRIMARILY TO POINT TO THIS LATTER SLOT; AND, AS ;;; USUAL, THE LEFT HALF HELPS TO LIMIT FUNCTION RE-EVALS. ;;; IF THERE IS ONLY ONE ARG ON THE STACK, 400000 IN THE LEFT ;;; HALF OF THE PDL SLOT MEANS FUNCTION IS A FEXPR, AND MAY ;;; THEREFORE TAKE AN EXTRA (A-LIST) ARGUMENT. IAPPLY: MOVE C,T ;STATE OF WORLD AT ENTRANCE: ADDI C,(P) ; T HAS - ILP1: HRRZ A,(C) ; NEXT PDL SLOT HAS FUNCTION IN RH, SKOTT A,LS 2DIF JRST (TT),APTB1-1,QLIST ;FN IS NOT LIST STRUCTURE IFN HNKLOG,[ TLNE TT,HNK JRST IAHNK IALIS: ] ; END IFN HNKLOG, HRRZ B,(A) HLRZ A,(A) CAIN A,QLAMBDA JRST IAPLMB ;IT'S A LAMBDA CAIN A,QFUNARG JRST APFNG ;IT'S A FUNARG (MORE GOOD GRIEF!) CAIN A,QLABEL JRST APLBL ;IT'S A LABEL (SUPER GOOD GRIEF!) PUSH P,C PUSH FXP,T HRRZ A,(C) JUMPL C,IAP2A ;JUMP IF WE'VE RE-EVAL'ED TOO MUCH PUSHJ P,EV0 ;ELSE EVAL THE FUNCTIONAL FORM POP P,C ; AND TRY IT AGAIN... POP FXP,T ILP1B: MOVE B,(C) HRRM A,(C) TLNN B,-1 HRLM B,(C) ;PUTS FUNCTION NAME IN LH IF NOT THERE TLO C,400000 JRST ILP1 APTB1: JRST IAP2A ;FIXNUMS ARE NOT FUNCTIONS! JRST IAP2A ;NOR FLONUMS DB$ JRST IAP2A ;NOR DOUBLES CX$ JRST IAP2A ;NOR COMPLEXES DX$ JRST IAP2A ;NOR DUPLEXES BG$ JRST IAP2A ;NOR BIGNUMS ALREADY JRST IAPATM ;SYMBOLS ARE OKAY, BUT JUST BARELY HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS JRST IAP2A ;TRUE RANDOMS ARE OUT! JRST IAPSAR ;IT'S AN ARRAY - OKAY, I GUESS IAPATM: HRRZ B,(A) ;APPLY GOT ATOMIC FUNCTION HRRZS 1(C) ;KILL POSSIBLE 400000 BIT DUE TO FEXPR TDZA R,R IAPAT2: HRRZ B,(B) IAPAT3: JUMPE B,IAPIA1 ;GRAB FUNCTION FROM PROP LIST HLRZ TT,(B) HRRZ B,(B) CAIL TT,QARRAY ;REMEMBER, FUNCTION PROPS ARE CAILE TT,QAUTOLOAD ; LINEAR IN MEMORY JRST IAPAT2 2DIF JRST @(TT),IATT,QARRAY IATT: IAPARR ;ARRAY IAPSBR ;SUBR IAPSBR ;FSUBR IAPLSB ;LSUBR IAPXPR ;EXPR IAPXPR ;FEXPR IAPAT2 ;IGNORE MACROS IAPIAL ;AUTOLOAD IAPIAL: HRRI R,(B) JRST IAPAT2 IAPIA1: JUMPL R,IAP2J JUMPE R,IAP2 MOVEI B,(R) MOVEI T,(A) PUSHJ P,IIAL HRRZ B,(A) SETO R, JRST IAPAT3 IIAL: PUSH P,A HLRZ A,(B) PUSHJ P,AUTOLOAD JRST POPAJ IAPSAR: SKIPA TT,A ;APPLY A SAR IAPARR: HLRZ TT,(B) ;APPLY AN ARRAY MOVEM TT,LISAR ;FOR INTERRUPT PROTECTION ONLY MOVEI R,(T) MOVEI TT,IAPAR1 JRST IAPSB1 IAPSBR: HLRZ TT,(B) ;APPLY A SUBR HRRZ R,(C) IAPSB1: HRRM TT,(C) JRST ESB1 IAPAR1: MOVE TT,LISAR JRST @ASAR(TT) IFN HNKLOG,[ IAHNK: SKIPN ICALLI ;Do we have a CALL interpreter? JRST IALIS PUSH P,T PUSHJ P,USRHNP ;Is this a user hunk? EXCH T,TT POP P,T JUMPE TT,IALIS ;Nope, just pretend it's a list XCT ICALLI ;Otherwise run user's hook ]; -- End IFN HNKLOG, IAPXPR: HLRZ A,(B) JRST ILP1B IAPLSB: MOVEI TT,CPOPJ HRRM TT,(C) MOVE R,B JRST ELSB1 IAP2: SKIPE EVPUNT ;DON'T EVALUATE FUNCTIONAL VARIABLE? JRST IAP2A JUMPL C,IAP2A HRRZ A,(C) ;APPLY FUNCTIONAL FROM VALUE CELL HLRZ A,(A) HRRZ A,@(A) CAIE A,QUNBOUND ;FOOBAR! IT'S UNBOUND JRST ILP1B JRST IAP2A IAPLMB: HLRZ TT,(B) ;APPLY A LAMBDA EXPRESSION MOVEI D,(TT) LSH D,-SEGLOG MOVE D,ST(D) TLNE D,SY JUMPN TT,IAP3 SETZ D, ;IMPORTANT THAT D BE NON-NEG - SEE IAP4 MOVEI C,(TT) HRRZ B,(B) MOVE R,T IPLMB1: JUMPE T,IPLMB2 ;NO MORE ARGS JUMPE TT,QF2A ;TOO MANY ARGS SUPPLIED IAP5: HLRZ A,(TT) SKIPE V.RSET JUMPN A,IAP5C IAP5C: MOVEI AR1,1(T) ADD AR1,P HLLZ D,(AR1) ;SEE COMMENT AT EFX - ALLOWS HRLM A,(AR1) ; A FEXPR TO TAKE AN A-LIST ARG HRRZ TT,(TT) AOJA T,IPLMB1 IAP5B: MOVEI D,(A) LSH D,-SEGLOG MOVE D,ST(D) TLNN D,SY JRST LMBERR JRST IAP5C IPLMB2: JUMPN TT,IAP4 ;TOO FEW ARGS SUPPLIED JUMPN R,IPLMB4 ;NO LAMBDA LIST IN FUN POP P,TT HRRI TT,CPOPJ ;LAMBDA LIST IS NULL SKIPE V.RSET PUSH P,TT HRRZ A,(B) JUMPN A,LMBLP HLRZ A,(B) JRST EVAL IPLMB4: MOVEM SP,SPSV SKIPA IPLM4A: PUSHJ P,BIND ;BIND VALUES TO LAMBDA VARS IPLM4B: POP P,AR1 ;FUN HAS A NON-NL LAMBDA LIST HLRZ A,AR1 SKIPE A ;IF NIL AS VARIABLE, DON'T BIND THIS ARG AOJLE R,IPLM4A ;TO BIND A NON-NIL VARIABLE AOJLE R,IPLM4B ;THIS WINS EVEN IF PREVIOUS INS DOESN'T JUMP SKIPN V.RSET JRST IPLMB5 HRRI AR1,CPOPJ TLNE AR1,-1 PUSH P,AR1 IPLMB5: JSP T,SPECX HRRZ AR1,(B) PUSH P,CUNBIND HLRZ A,(B) JUMPE AR1,EVAL ;A GENERALIZED LAMBDA: NON-NULL LAMBDA LIST LMBLP: PUSH P,B ;FOR GENERAL LAMBDAS, EVALS SEQUENCE OF EXP'S HLRZ A,(B) PUSHJ P,EVAL LMBLP1: POP P,B HRRZ B,(B) LMBLP2: JUMPN B,LMBLP POPJ P, IPROGN: MOVEI A,NIL ;INTERNAL PROGN JRST LMBLP2 IAP3: MOVEI A,(TT) ;APPLY LEXPR MOVN TT,T CAIL TT,XHINUM JRST LXPRLZ MOVEI AR1,CPOPJ HRRM AR1,(C) MOVEI AR1,IN0(TT) MOVEM SP,SPSV PUSHJ P,BIND MOVEI C,(C) EXCH C,ARGLOC HRLI C,ARGLOC PUSH SP,C ;BIND ARGLOC TO LOC OF ARGS ON PDL EXCH AR1,ARGNUM HRLI AR1,ARGNUM PUSH SP,AR1 ;BIND ARGNUM TO NUMBER OF ARGS JSP T,SPECX HRRZ B,(B) PUSHJ P,LMBLP SKIPN T,@ARGNUM JRST UNBIND HRLS T SUB P,T JRST UNBIND CUNBIN: JRST UNBIND IAP4: JUMPGE D,QF3A AOJN R,QF3A JRST IAP4A ;FEXPR OF TWO ARGS SUBTTL FUNCTION, QUOTE, DECLARE, COMMENT, SETQ, AND, OR FUNCTION: SKIPA D,CQFUNCTION ;FEXPR 1 QUOTE: MOVEI D,QQUOTE ;FEXPR 1 JUMPE A,WNAFOSE HRRZ TT,(A) JUMPE TT,$CAR JRST WNAFOSE DECLARE: MOVEI A,QDECLARE ;FSUBR (IGNORES ARG) POPJ P, $COMMENT: MOVEI A,Q$COMMENT ;FSUBR (IGNORES ARG) POPJ P, SETQ: PUSH P,A SET1: PUSHJ FXP,SET0 ;DO ONE STEP OF A "MULTIPLE" SETQ. SKIPE (P) JRST SET1 JRST POP1J SET0: HLRZ A,@(P) ;ASSUMES ARGLIST PTR STORED IN 0(P) JSP D,SETCK ;ENTERED BY PUSHJ FXP,SET0 HRRZ B,@(P) JUMPE B,SETWNA PUSH P,A ;ATOM TO BE SETQ'D HLRZ A,(B) HRRZ B,(B) MOVEM B,-1(P) ;CDR THE ARGLIST PUSHJ P,EVAL POP P,AR1 JSP T,.SET POPJ FXP, $AND: HRLI A,TRUTH $OR: HLRZ C,A PUSH P,C ANDOR: HRRZ C,A JUMPE C,POPAJ MOVSI C,(SKIPE (P)) TLNE A,-1 MOVSI C,(SKIPN (P)) XCT C JRST POPAJ MOVEM A,(P) HLRZ A,(A) PUSHJ P,EVAL EXCH A,(P) HRR A,(A) JRST ANDOR SUBTTL PROG, PROGV, RETURN, GO PROG: HLRZ AR2A,(A) ;FSUBR HRRZ A,(A) PRG1: JUMPE AR2A,PRG1Z ;EITHER THEY ARE NIL OR SKOTT AR2A,LS ; MUST HAVE A LIST FOR PROG VARS JRST PRGER1 PRG1Z: PUSH P,A SETZ C, JSP T,PBIND ;BIND PROG VARIABLES TO NIL POP P,A PUSHJ P,PG0 ;EVALUATE PROG BODY MOVEI A,NIL JRST UNBIND ;UNBIND VARIABLES PG0: PUSH P,PA3 PUSH P,PA4 PUSH P,SP PUSH P,FXP PUSH P,FLP LPRP==.-PG0+1 ;LENGTH OF PROG PDL, IE HOW MUCH PROG HAS MOVEM P,PA4 ;CAUSED TO BE PUSHED HRLS A MOVEM A,PA3 PG1: HLRZ T,PA3 PG1A: JUMPE T,PRXIT ;NORMAL EXIT HLRZ A,(T) HRRZ T,(T) HRLM T,PA3 SKOTT A,LS JRST PG1 PUSHJ P,EVAL PG0A: JRST PG1 ;;; JSP T,VBIND ;LIST OF SYMBOLS IN AR2A, VALUES IN A ;;; BINDS EACH SPECIAL VARIABLE IN THE LIST TO CORRESPODNING VALUES. ;;; IF VALUES LIST TOO SHORT, "UNBOUND" GETS USED FOR PROGV, AND ;;; NIL OTHERWISE. VBIND: MOVEI C,(A) ;INTERPRETED AND COMPILED PROGV COME HERE SKIPA R,[QUNBOUND] ;USE UNBOUND AS VALUE OF EXTRA VARIABLES PBIND: MOVEI R,NIL ;USE NIL AS VALUE OF EXTRA VARS MOVEM SP,SPSV ;BIND PROG VARIABLES JUMPE AR2A,SPECX MOVEI AR1,NIL PBIND1: HLRZ A,(AR2A) ;NEXT VARIABLE HLRZ AR1,(C) ;NEXT VALUE SKIPN C ;HAVE WE RUN OFF THE END OF THE LIST? MOVEI AR1,(R) ;YES, USE DEFAULT VALUE SKOTT A,SY JRST PBIND2 CAIE A,TRUTH ;DONT BIND NON-SYMBOLS, NOR "T" PUSHJ P,BIND PBIND2: HRRZ C,(C) HRRZ AR2A,(AR2A) JUMPN AR2A,PBIND1 JRST SPECX PROGV: HRRZ B,(A) ;FSUBR HRRZ C,(B) HLRZ A,(A) HLRZ B,(B) PUSH P,C PUSH P,B PUSHJ P,EVAL ;GET LIST OF VARIABLES EXCH A,(P) PUSHJ P,EVAL ;GET LIST OF VALUES POP P,AR2A JSP T,VBIND ;BIND VARIABLES POP P,B PUSHJ P,LMBLP ;EVAL REST LIKE LAMBDA BODY JRST UNBIND RETURN: JSP T,BKERST ;SUBR 1 MOVE P,PA4 AOS -LPRP+1(P) ;RETURN CAUSES SKIP PRXIT: POP P,FLP ;PROG EXIT POP P,FXP POP P,TT PUSHJ P,UBD0 POP P,PA4 ERRP4: POP P,PA3 RHAPJ: MOVEI A,(A) CQFUNCTION: POPJ P,QFUNCTION GO: JSP TT,FWNACK FA1,,QGO HLRZ A,(A) GO2: JSP T,SPATOM ;LEAVES TYPE BITS IN TT JRST GO3 GO1: JSP T,BKERST HRRZ T,PA3 PG5: JUMPE T,EG1 HLRZ TT,(T) HRRZ T,(T) CAIN TT,(A) JRST PG5A TLNN A,400000 ;4.9 BIT => GO TAG IS NUMERIC JRST PG5 MOVEI D,(TT) LSH D,-SEGLOG SKIPL D,ST(D) TLNN D,FX+FL JRST PG5 MOVE TT,(TT) CAME TT,(A) JRST PG5 PG5A: MOVE P,PA4 MOVE FLP,(P) MOVE FXP,-1(P) HRRZ TT,-2(P) PUSHJ P,UBD JRST PG1A GO3: TLNN TT,FX+FL JRST GO3A GO3B: MOVE TT,(A) ;SET 4.9 BIT OF A IF TAG IS NUMERIC CAML TT,[-XLONUM] CAIL TT,XHINUM ; BUT NOT INUM TLO A,400000 JRST GO1 GO3A: PUSHJ P,EVAL ;IF ARG TO GO ISN'T ATOMIC, DO ONE EVAL AND TRY AGAIN MOVEI TT,(A) LSH TT,-SEGLOG MOVE TT,ST(TT) TLNE TT,FX+FL JRST GO3B TLNE TT,SY JRST GO1 JRST EG1 SUBTTL DO FUNCTION DO: PUSH P,PA4 SETZM PA4 PUSH FXP,R70 ;A "DO SWITCH" TO MARK EXPANDED FORMAT PUSH P,A HLRZ A,(A) SKOTT A,LS ;HUNKS WIN AS WELL AS LISTS JUMPN A,DO4A HRROM A,(FXP) HLRZ A,@(P) ;SETUP FOR MULTIPLE INDICES HRRZ C,@(P) HLRZ B,(C) JRST DO4 DO4A: MOVE A,(P) ;SINGLE INDEX DO HRRZ B,(A) HRRZ B,(B) HRRZ B,(B) MOVE C,B DO4: HRRZ C,(C) MOVEM A,(P) ; (P) PROG BODY DO4C: SKOTT B,LS JUMPN B,DOERRE PUSH P,B ; -1(P) ENDTEST PUSH P,C ; -2(P) DO VARS LIST MOVE A,-2(P) MOVSI R,600000 ;EVALUATE AND SETUP INITIAL VALUES SKIPN -1(P) MOVSI R,400000 ;200000 BIT SAYS STEPPERS ARE OKAY PUSHJ FXP,DO5 SKIPN -1(P) JRST DO4D DO7: HLRZ A,@-1(P) PUSHJ P,EVAL JUMPN A,DO8 DO7A: MOVE A,(P) PUSHJ P,PG0 ;DO PROG BODY (MAY SKIP ON RETURN STATEMENT) JRST DO2 DO9: MOVE B,-2(P) SUB P,R70+3 ;BREAK OUT OF BODY BY RETURN STATEMENT POP P,PA4 SUB FXP,R70+1 JUMPN B,UNBIND POPJ P, DO8: SKIPN A,(FXP) JRST DO9 ;SIMPLE DO FORMAT HRRZ B,@-1(P) ;DO PASSED ENDTEST, AND RETURNS A VALUE PUSHJ P,IPROGN JRST DO9 DO2: MOVE A,-2(P) MOVEI R,0 ;DO STEPPING FUNCTIONS PUSHJ FXP,DO5 JRST DO7 DO4D: MOVE A,(P) PUSHJ P,PG0 SETZ A, ;DEFAULT VALUE OF ONCE-THROUGH DO IS NIL JRST DO9 DO5: JUMPE A,DO6 ;DOES PARALLEL SETQS - ON LISTS LIKE (I V1 V2) PUSH P,A ;WILL DO (SETQ I V1) IF R < 0 SKIPE -1(FXP) ;WILL DO (SETQ I V2) IF R > 0 HLRZ A,(A) ;IF DOSW SAYS SINGLE INDEX, THEN ONLY ONE LIST DO5Q: MOVEI B,(A) JUMPGE R,DO5F SKOTT A,SY ;A SINGLETON SYMBOL JRST DO5Q1 ;NOPE. TRY FURTHUR CHECKS HRLZS A ;TREAT AS ( NIL) EXCH A,(P) JRST DO5C DO5Q1: SKOTT A,LS JRST DOERR HLRZ A,(B) JSP T,SPATOM JRST DOERR TLNE R,200000 JRST DO5F HRRZ A,(B) JUMPE A,DO5F HRRZ A,(A) JUMPN A,DO5ER DO5F: HLRZ A,(B) HRLM A,(P) HRRZ A,(B) JUMPL R,DO5E JUMPE A,DO5B HRRZ A,(A) JUMPN A,DO5D DO5B: POP P,A SOJA R,DO5C DO5E: JUMPE A,DO5G ;(I) IS SAME AS (I NIL) ON INITIAL VALUE DO5D: HLRZ A,(A) PUSH FXP,R PUSHJ P,EVAL POP FXP,R DO5G: HLL A,(P) EXCH A,(P) ;NOW (P) HAS ATOM,,VALUE DO5C: HRRZ A,(A) SKIPN -1(FXP) MOVEI A,0 ;SO THAT SINGLE FORMAT DO WILL DROP OUT AOJA R,DO5 DO6: TRNN R,-1 ;[(SETQ I V1) FROM ABOVE] POPJ FXP, ;FIRST TIME THROUGH, WE ALLOW OLD BINDINGS JUMPGE R,DO6C ;TO BE REMEMBERED ON THE SPDL FOR UNBINDING HRRZS R MOVEM SP,SPSV DO6A: POP P,AR1 HLRZ A,AR1 PUSHJ P,BIND SOJG R,DO6A JSP T,SPECX POPJ FXP, DO6C: POP P,AR1 ;DURING THE STEPPING PHASE, AS OPPOSED TO HLRZ A,AR1 ;THE INITIALIZATION PHASE, WE LET NO BINDINGS PUSHJ P,BIND ;ACCUMULATE ON THE SPDL JSP T,SETXIT SOJG R,DO6C POPJ FXP, SUBTTL COND, ERRSET, ERR, CATCH, THROW, CASE, IF, *CATCH, *THROW, ; UNWIND-PROTECT, CATCHALL, CATCH-BARRIER COND1: HRRZ A,(B) COND: JUMPE A,CPOPJ ;ENTRY PUSH P,A HLRZ A,(A) HLRZ A,(A) CAIE A,TRUTH PUSHJ P,EVAL CON3: POP P,B JUMPE A,COND1 ;IF FIRST OF COND PAIR IS TRUE HLRZ B,(B) SKIPA COND2: POP P,B HRRZ B,(B) JUMPE B,CPOPJ ;LOOP FOR GENERALIZED COND PAIR PUSH P,B HLRZ A,(B) PUSHJ P,EVAL CON2: JRST COND2 BKERST: SKIPN TT,PA4 JRST BKRST1 TLZ TT,-1 SKIPE B,CATRTN JRST BKRST2 BKRST3: SKIPE B,ERRTN CAILE TT,(B) JRST (T) ;NO TROUBLESOME CATCHS OR ERRSETS BKRST4: MOVEI TT,BKERST BKRST0: MOVEM TT,-LERSTP(B) ;BREAK UP A TROUBLESOME CATCH OR ERRSET, E.G. HRRZI TT,(B) ;WE WAN'T TO GET RID OF THIS FRAME, HANDLE ALL UNWIND-PROTECTS ; INCLUDING THE FRAME WE WANT TO FLUSH PUSHJ FXP,UNWPRO CAILE TT,(P) ;IF P LESS THAN FRAME OF INTEREST, THEN IT WAS AN ; UNWIND-PROTECT FRAME AND UNWPRO THREW IT AWAY. JUST ; RETURN TO OUR CALLER. JRST (T) ;ELSE THROW THE FRAME AWAY BY HAND MOVE P,B ;(PROG (A) (ERRSET (RETURN (FOO A)))) JRST ERR1 ;AND THEN TRY BKERST AGAIN BKRST2: CAILE TT,(B) JRST BKRST3 ;CATCH ISN'T TROUBLESOME, SO TEST FOR ERRSETS JRST BKRST4 ;AH, CATCH IS TROUBLESOME! BKRST1: MOVEI A,LGOR %FAC EMS22 ERRSET: JSP TT,FWNACK FA12,,QERRSET MOVEI C,TRUTH HRRZ B,(A) JUMPE B,ERRST3 PUSH P,A HLRZ A,(B) PUSHJ P,EVAL MOVEI C,(A) POP P,A ERRST3: JSP T,ERSTP MOVEM P,ERRTN MOVEM C,ERRSW HLRZ A,(A) PUSHJ P,EVAL ERRNX: PUSHJ P,NCONS ;NORMAL EXIT JRST ERUN0 ERR: JSP TT,FWNACK FA012,,QERR JUMPE A,ERR2 HRRZ B,(A) JUMPE B,.+3 HLRZ B,(B) JUMPE B,ERR3A HLRZ A,(A) ;EVAL BEFORE UNBLOCKING PUSHJ P,EVAL JRST ERR2 ERR3A: SKIPN ERRTN JRST LSPRET MOVEI T,ERR3 EXCH T,-LERSTP(P) JRST ERR0 ;UNBLOCK THE ERRSET, THEN ERR3: SKIPE A ;EVAL THE ARG TO ERR HLRZ A,(A) PUSH P,T JRST EVAL CATCH: JSP TT,FWNACK FA12,,QCATCH PUSHJ P,CATHRO JSP TT,CATPS1 HLRZ A,(B) PUSHJ P,EVAL MOVEI B,NIL ;CAUSE MOST RECENT CATCH TO BE THROWN JRST THROW1 ;(*CATCH e1 . . . en) ; TAG OR TAG-LIST IS EVALUATED. THEN E1 THROUGH EN ARE EVALED. IF A THROW ; OR *THROW IS DONE THEN IS LIKE A REGULAR CATCH. .CATCH: PUSH P,A ;SAVE POINTER TO ARGS HLRZ A,(A) ;EVAL TAG/TAG-LIST PUSHJ P,EVAL HRLI A,CATSPC\CATLIS ;FLAG IT AS TAG-LIST SKOTT A,LS ;IS IT A LIST? HRRZS A ; NO IT ISN'T LIST .CATC1: POP P,B ;RESTORE POINTER TO ARGS JSP TT,CATPS1 HRRZ B,(B) ;CDR THE LIST OF ARGS PUSHJ P,IPROGN ;IMPLICIT PROGN AROUND THEM JRST THRALL ;THEN BREAK-UP CURRENT CATCH FRAME ; (CATCH-BARRIER E1 . . . En) ; LIST-OF-TAGS IS EVALUATED. THEN E1 THROUGH EN ARE EVALED. IF A THROW ; OR *THROW IS DONE THEN IF TAG IS IN LIST-OF-TAGS, THE CATCH-BARRIER RETURNS, ; ELSE AN UNSEEN-CATCH-TAG ERROR IS GENERATED CATCHB: PUSH P,A ;SAVE POINTER TO ARGS HLRZ A,(A) ;EVAL TAG/TAG-LIST PUSHJ P,EVAL CATCB2: SKOTT A,LS ;IS IT A LIST? JRST CATCB1 ;NOPE, ERROR HRLI A,CATSPC\CATLIS\CATCAB ;YES, FLAG CATCH FRAME CORRECTLY JRST .CATC1 ;REST IS JUST LIKE *CATCH CATCB1: WTA [MUST BE A LIST OF TAGS - CATCH-BARRIER!] JRST CATCB2 ;(CATCHALL function e1 . . . en) ; FUNCTION IS A FUNCTION OF TWO ARGS. E1 THROUGH EN ARE EVALED, AND IF NO ; THROW IS DONE THE VALUE OF EN IS RETURNED. IF ANY THROW IS DONE, FUNCTION ; IS INVOKED WITH THE FIRST ARG BEING THE THROW TAG AND THE SECOND BEING THE ; THROWN VALUE. THE VALUE OF THE FUNCTION IS THEN RETURNED AS THE VALUE ; OF THE CATCHALL. CATCHALL: PUSH P,A ;SAVE POINTER TO ARGS HLRZ A,(A) ;EVAL FUNCTION PUSHJ P,EVAL HRLI A,CATSPC\CATALL ;FLAG AS A CATCHALL JRST .CATC1 ;REST IS LIKE *CATCH ;(UNWIND-PROTECT e u1 u2 . . . un) ; EXECUTES U1 THRU Un WHEN THE "CONTOUR" OF THE UNWIND-PROTECT IS EXITED. ; IF e TERMINATES NORMALLY, THEN U1 THRU UN ARE EVALUATED AND THE VALUE ; RETURNED BY e IS RETURNED. IF A NON-LOCAL EXIT OCCURS THRU AN UNWIND-PRO ; FRAME, THEN U1 THRU UN ARE EVALED AND THE EXIT CONTINUES. UNWINP: HRRZ B,(A) ;GET CDR OF ARG LIST HRLI B,CATUWP\CATSPC ;AN UNWIND-PROTECT FRAME MOVEM B,CATID PUSH FXP,P ;SAVE CURRENT STATE OF STACK JSP T,ERSTP MOVEM P,CATRTN HLRZ A,(A) ;CAR OF ARG LIST PUSHJ P,EVAL ;EVALUATE IT HRRZ TT,(FXP) ;NOW MUST RUN THE UNWIND PROTECT FUNCTIONS PUSHJ FXP,UNWPRO ;UNDO THE UNWIND-PROTECT FRAME POPI FXP,1 ;REMOVE THE SAVED PDL POINTER FROM FXP POPJ P, ;THEN RETURN THE VALUE OF e ;ERROR TRAP FOR UNWIND-PROTECT, SHOULD NEVER GET HERE! UNWERR: LERR [SIXBIT \UNWIND-PROTECT LEFT DUMMY RETURN ADR ON STACK!\] ;COMPILED UNWIND-PROTECT, ENTER WITH JSP TT, CONTINUATION IS AT PC C(TT)+1 PTNTRY:: UNWINC: PUSH P,[UNWERR] ;IF GETS HERE, HMM... AOS TT ;POINT TO START OF CONTINUATION HRLI TT,CATUWP\CATCOM\CATSPC ;AN UNWIND-PROTECT FRAME MOVEM TT,CATID JSP T,ERSTP MOVEM P,CATRTN JRST -1(TT) ;RETURN TO COMPILED CODE ;COME HERE TO CLOSE UP AN UNWIND PROTECT. CALLED WITH JSP T, PTEXIT:: UNWINE: MOVEM TT,-LEP1-4(P) ;SAVE RETURN ADR (AN EXTRA SLOT IS ON P) MOVEI TT,-LEP1(P) ;ADR TO UNWIND TO PUSHJ FXP,UNWPRO ;UNDO THE UNWIND-PROTECT FRAME POPJ P, ;THEN RETURN THE VALUE OF e ;OLD STYLE MACLISP THROW, UNEVALUATED TAG THROW: JSP TT,FWNACK FA12,,QTHROW PUSHJ P,CATHRO PUSH P,A HLRZ A,(B) PUSHJ P,EVAL POP P,B JRST THROW1 ;(*THROW TAG VAL) SUBR .THROW: EXCH A,B ;THROW1 WANTS TAG IN B, VAL IN A JRST THROW1 ;THEN DO A THROW CATHRO: MOVE B,A HRRZ A,(A) JUMPE A,CPOPJ HLRZ A,(A) POPJ P, ;;; WITHOUT-INTERRUPTS: ROUTINES WHEN PWIOINT GETS BOUND AND UNBOUND ;;; CALLED from SPECBIND, new value in ;;; R has new value, T has address of word with address in right half. WIOSPC: PUSH P,TT HRRZ TT,(T) ;Get address we were trying to clobber CAIN TT,PWIOINT ;Our special hack location? JRST WIOSP0 ; yes, hack it POP P,TT EXCH R,@(T) ;Otherwise redo instruction to get real int JRST SPEC4A ;And continue with the SPECBIND if continued WIOSP0: MOVEI TT,(R) ;New value to TT SKIPE REALLY ;If UNWPR1 has it living on the stack SKIPA R,@REALLY ; Get old value for SPEC4A from there MOVE R,UNREAL ; Else normal. JUMPE TT,WIOSP1 ;NIL, use as is CAIE TT,QTTY ;TTY, that's meaningful MOVNI TT,1 ;Else use -1 WIOSP1: PUSHJ P,WIOBN0 ;Store into UNREAL, maybe run CHECKU POP P,TT JRST SPEC4A ;;;CALLED FROM BIND, NEW VALUE IN AR1 WIOBND: HRRZ TT,UNREAL ;CURRENT VALUE HRRM TT,(SP) ;REMEMBER INSTEAD OF MEANINGLESS VALUE MOVEI TT,(AR1) JUMPE TT,WIOBN0 ;NIL, USE AS IS CAIE TT,QTTY ;TTY, THAT'S MEANINGFUL MOVNI TT,1 ;ELSE USE -1 WIOBN0: JUMPL TT,WIOBN1 PUSH P,A PUSH FXP,D PUSH FXP,F MOVE A,TT PUSHJ P,ABIND3 PUSHJ P,CHECKU POP SP,SPSV ;SO RE-OPEN THE BIND-BLOCK POP FXP,F POP FXP,D POP P,A POPJ P, ;RETURN FROM BIND WIOBN1: MOVEM TT,UNREAL POPJ P, ;;; CALLED FROM AFTER UNBIND -- (FXP) HAS OLD VALUE IN LH. CAN ONLY DESTROY T. WIOUNB: EXCH D,(FXP) ;GET OLD VALUE, SAVE D PUSH FXP,F ;SAVE F ALSO -- CHECKU MAY CLOBBER PUSH P,A ;A WILL GET NEW (OLD) VALUE OF UNREAL HLRZ A,D ;FIGURE OUT REAL OLD VALUE CAIN A,-1 ;IF HALFWORD -1, THEN TURN INTO FULLWORD MOVNI A,1 SKIPE REALLY JRST WIOUN1 PUSHJ P,CHECKU ;RUN INTERRUPTS AS APPROPRIATE WIOUN0: POP P,A ;RESTORE AC'S AND RETURN POP FXP,F POP FXP,D POPJ P, WIOUN1: MOVEM A,@REALLY ;Store it in the saved slot JRST WIOUN0 CASEQ:; TDZA R,R ;FLAG IN R WHETHER CASE/Q ;CASE: SETOI R, JUMPE A,CPOPJ ;ENTRY, RETURN NIL IF NO ARGS PUSH P,A ;SAVE POINTER TO ARG LIST HLRZ A,(A) ;GET EXPRESSION TO MATCH AGAINST CASEE:; PUSH FXP,R CAIE A,TRUTH ;FOR SPEED, CHECK FOR SPECIAL KIND PUSHJ P,EVAL ; POP FXP,R JUMPE A,CASES ;NIL IS A SYMBOL MOVE T,A LSH T,-SEGLOG MOVE T,ST(T) TLNE T,FX ;FIXNUM EXPRESSION? JRST CASEF TLNE T,SY ;SYMBOL AS EXPRESSION? JRST CASES WTA [MATCHING EXPRESSION NOT FIXNUM OR SYMBOL!] JRST CASEE ;WIN IF USER TRIES AGAIN CASEF: MOVSI T,FX ;TEST AGAINST FIXNUMS ONLY JRST CASE1 CASES: MOVSI T,SY ;TEST AGAINST SYMBOLS ONLY CASE1: POP P,B ;POINTER TO CASE'S ARGUMENTS PUSH P,A ;EQ TEST AGAINST SYMBOL RETURNED HRRZ A,(B) ;THE LIST OF MATCHING SETS AND EXPRS CASE1E: PUSH P,A HLRZ A,(A) ;THE POINTER TO THE NEXT SET/EXPRS PAIR HLRZ A,(A) ;THE LIST OF MATCHES OR THE SINGLE MATCH CASE1H: CAIN A,TRUTH ;IF T THEN AN 'OTHERWISE' CLAUSE JRST CASEM MOVEI TT,(A) LSH TT,-SEGLOG MOVE TT,ST(TT) TLNN TT,LS ;IS THE MATCHING SET A LIST? JRST CASE1Q ;NO, HANDLE SPECIALLY CASE1D: PUSH P,A HLRZ A,(A) ;GET NEXT ELEMENT CASE1B:;JUMPE R,CASE1A ;DON'T EVALUATE EXPR IF CASEQ ; CAIN A,TRUTH ; JRST CASE1A ; PUSH P,T ;SAVE FLAGS OVER EVAL ; PUSHJ P,EVAL ; POP P,T ; SETO R, ;MAKE SURE FLAG IS STILL CORRECT CASE1A: TLNE T,SY ;IF TESTING FOR SYMBOLS JUMPE A,CASE1Z ;THEN NIL IS A VALID ONE MOVEI TT,(A) LSH TT,-SEGLOG TDNN T,ST(TT) ;MATCHING TYPE? JRST CASE1C CASE1Z: POP P,B JSP TT,CASECK ;NON SKIP IF MATCH JRST CASEM ;MATCH FOUND, PROCESS EXPRESSIONS HRRZ A,(B) ;GET THE CDR JUMPN A,CASE1D ;IF MORE MATCHING IN THIS LIST THEN PROCEED CASE1G: POP P,A ;RESTORE THE LIST OF PAIRS POINTER HRRZ A,(A) ;THE CDR POINTS TO NEXT CONS JUMPN A,CASE1E ;IF NOT END OF LIST THEN PROCEED POPI P,1 ;GET RID OF MATCHING POINTER POPJ P, CASE1Q:;JUMPE R,CASEBQ ;IF CASEQ LEAVE UNEVALUATED ; PUSH P,T ;SAVE FLAG ; CAIE A,TRUTH ; PUSHJ P,EVAL ; POP P,T ; SETO R, ;FLAG MUST BE SET IF DID EVAL CASEBQ: TLNE T,SY ;IF TESTING FOR SYMBOLS JUMPE A,CASEBZ ;THEN NIL IS A VALID ONE MOVEI TT,(A) ;TYPE CHECK UNEVALUATED MATCHING ARG LSH TT,-SEGLOG TDNN T,ST(TT) JRST CASEAQ ;NOT MATCH CASEBZ: JSP TT,CASECK ;NON-SKIP IF MATCH SKIPA JRST CASE1G ;MATCH NOT FOUND CASEM: POP P,A ;GET BACK POINTER TO CONS WITH MATCH HLRZ A,(A) MOVEM A,(P) ;CLOBBER MATCHING ARG WITH EXPR LIST SETZ A, ;MAKE SURE RETURN NIL IF NOTHING TO DO JRST COND2 CASECK: TLNN T,FX ;USE EQ FOR ATOMS, = FOR FIXNUMS JRST CASEEQ MOVE D,(A) ;GET THE FIXNUM CAME D,@-1(P) ;CHECK USING = JRST 1(TT) ;SKIP FOR FAILURE JRST (TT) CASEEQ: CAME A,-1(P) ;EQ CHECK JRST 1(TT) ;SKIP FOR FAILURE JRST (TT) CASEAQ: WTA [DOES NOT MATCH MATCHING EXPRESSION TYPE!] JRST CASE1H CASE1C: POP P,A WTA [DOES NOT MATCH MATCHING EXPRESSION TYPE!] JRST CASE1D IFN 0,[ ;TEMPORARILY(?) REMOVED IF: PUSH P,A HLRZ A,(A) ;TEST EXPRESSION CAIE A,TRUTH PUSHJ P,EVAL POP P,B HRRZ B,(B) SKIPN A JRST IF1A ;FOR FAILURE EVALUATE ALL REMAINING FORMS HLRZ A,(B) CAIE A,TRUTH PUSHJ P,EVAL POPJ P, IF1A: PUSH P,B ;COND REQUIRES POINTER TO LIST ON STACK JRST COND2 ];END IFN 0 SUBTTL "SYSTEM" MACROS - SMALL FSUBR'S TO PARALLEL COMPILER MACROS ;;; CURRENTLY: SETF, PUSH, POP, SETF: PUSH P,A JRST SETF1 SETF2S: PUSHJ FXP,SET0 ;Handle a symbol case as if it were SETQ SETF5: HRRZ B,@(P) ;BASIC LOOP DOWN ARGLIST HRRZ B,(B) JUMPE B,POP1J MOVEM B,(P) SETF1: HLRZ A,@(P) SKOTT A,LS JRST SETF2S ;setting a symbol? HLRZ A,(A) SKOTT A,SY JRST SETF3 ;Random format? MOVEI B,QSTF.X ;or has SETF-X property? PUSHJ P,GET1 ; then go slow route thru SETF3 JUMPN A,SETF3 MOVE B,@(P) HLRZ A,B ;Else check if it is one of the simple HLRZ A,(A) JSP T,IC.RP ; forms that we can un-do by hand JRST SETF1B SETF2C: PUSH FXP,TT ;A "CARCDR"ING, with "icarcdrp" code in TT PUSH P,B ; or else TT has -1 for PLIST HLRZ A,B HRRZ A,(A) PUSHJ P,EVALCAR ;Compute in "(CARCDR )" EXCH A,(P) PUSHJ P,EVALCAR ;Compute in "(SETF (CARCDR ) )" MOVE B,A POP P,A POP FXP,TT JUMPL TT,STF2C2 LDB D,[0606_30 TT] ;Code for the "tail" operation and JUMPE D,STF2C1 LDB D,[2706_30 %CARCDR-2(D)] ; find the "boy" number for it JSP T,CARCDR(D) ;Execute the "tail" operation STF2C1: TRNN TT,1_12. ;Bit 2.3 of code number is 1 iff TDZA D,D ; "head" operation is RPLACD MOVEI D,RPLACD-RPLACA PUSHJ P,RPLACA(D) JRST SETF5 STF2C2: PUSHJ P,SETPLIST JRST SETF5 SETF1B: CAIE A,Q$GET ;Continue discerning for known operation CAIN A,QCXR JRST SETF2G ;GET, CXR CAIN A,Q%ARRAYCALL JRST SETF2A ;ARRAYCALL SETO TT, CAIN A,QPLIST JRST SETF2C ;PLIST (A BIT LIKE CARCDR) MOVE C,A MOVEI B,QMACRO PUSHJ P,GET1 JUMPN A,SETF1C MOVE A,C MOVEI B,QAUTOLOAD PUSHJ P,GET1 JUMPE A,SETF3 PUSH P,A MOVE A,C MOVEI B,QLSTF.X PUSHJ P,GETL5 ; BUT MAYBE WE'VE ALREADY TRIED TO AUTOLOAD? POP P,T JUMPE A,SETF3 MOVE A,T ;IF AUTOLOADABLE, MAY PUT A MACRO ON PUSHJ P,AUTOLOAD ; SO LOAD IN THE AUTOLOADABLE FILE MOVE A,C ; AND TRY AGAIN TO FIND MACRO PROP MOVEI B,QMACRO PUSHJ P,GET1 JUMPN A,SETF1C MOVE A,C MOVEI B,NIL MOVEI C,QSTF.X PUSHJ P,PUTPROP JRST SETF3 SETF1C: HLRZ A,@(P) CALLF 1,Q%MCX. ;MACROs (or STRUCTURE-selector ings) JUMPE A,SETF3 ; - then merely MACROEXPAND-1* and go HLRZ A,(A) ; around loop again HRRZ B,@(P) JSP T,%CONS MOVEM A,(P) JRST SETF1 SETF2A: HLRZ A,B HLRZ B,(B) PUSH P,A PUSH P,B JRST STF2A7 STF2A5: PUSHJ P,STOREE STF2A7: SETZM LISAR PUSHJ P,EVNH0 ;EVALUATE ARRAY REFERENCE WITHOUT HOOKING IT SKIPN A,LISAR ;ALWAYS CHECK FOR THIS GROSS LOSS JRST STF2A5 SKIPN V.RSET JRST STF2A9 JSP T,ARYSIZ ;GET SIZE OF ARRAY IN WORDS IN TT TLNN R,200000 ;=> NEGATIVE INDEX CAIG TT,(R) ;THERE'S PROBABLY A FENCE-POST FOR SX ARRAYS HERE JRST STF2A5 STF2A9: PUSH FXP,R EXCH A,(P) PUSHJ P,EVAL ;EVALUATE THE NEW VALUE POP P,LISAR POP FXP,R JSP T,.STORE POPI P,1 SETZM LISAR CSETF5: JRST SETF5 SETF2G: PUSH P,CSETF5 ;"GET" OR "CXR" HLRZ A,B HRRZ A,(A) ; "(SETF (GET ) ) HRRZ B,(A) PUSH P,B PUSHJ P,EVALCAR ;Eval EXCH A,(P) PUSHJ P,EVALCAR ;Eval PUSH P,A HRRZ A,@-3(P) PUSHJ P,EVALCAR ;Eval HLRZ T,@-3(P) HLRZ T,(T) CAIN T,Q$GET JRST STF2G2 MOVE C,A POP P,B POP P,A PUSHJ P,RPLACX ;REMEMBER return addr was pushed above MOVE A,C POPJ P, STF2G2: MOVE B,A ; at SETF2G POP P,C POP P,A JRST PUTPROP EVALCAR: HLRZ A,(A) ;save a couple of instructons! by coming here JRST EVAL SETF3: POP P,A ;Can't hack it, so give up and let the SETZ B, ; B=() ==> For Value CALLF 2,QISTFX ; +INTERNAL-SETF-X expander expand it. JRST EVAL ; and then do it. ;;; Standard simple PUSH case (for symbols) is as follows: ; (DEFUN PUSH FEXPR (L) ; (DO ((X L (CDDR X)) (SYM) (VAL)) ; ((NULL X) VAL) ; (SETQ SYM (CADR X) VAL (EVAL (CAR X))) ; (SET SYM (CONS VAL (SYMEVAL SYM))))) ;;; Standard simple POP case (for symbols) is as follows: ;(DEFUN POP FEXPR (X) ; (PROG2 ; () ; (COND ((NULL (CDR X)) (CAR (SYMEVAL (CAR X)))) ; ('T (SET (CADR X) (CAR (SYMEVAL (CAR X)))))) ; (SET (CAR X) (CDR (SYMEVAL (CAR X)))))) ;;; Otherwise, we try substituting +INTERNAL-PUSH-X (or +INTERNAL-POP-X) ;;; for the "PUSH" (or "POP"), and let the (autoloadable) macro ;;; expander handle it. $PUSHER: POP P,A %WTA TNILER $PUSH: JSP TT,FWNACK FA2,,Q$PUSH PUSH P,A ;SAVE THE ARGUMENT POINTER PUSHJ P,CADR JUMPE A,$PUSHER ;SPECIAL-CASE CHECK FOR NIL AND T CAIN A,TRUTH JRST $PUSHER JSP T,SPATOM ;CHECK FOR STANDARD CASE JRST $PUSH1 HLRZ A,@(P) ;GET THE "VALUE" TO BE PUSHED PUSHJ P,EVAL ; AND EVALUATE IT EXCH A,(P) ;SAVE THE RESULT, AND GET THE ARG POINTER JSP T,%CADR ;GET THE SECOND "ARGUMENT" PUSH P,A ;SAVE POINTER TO SYMBOL PUSHJ P,EVSYM ;GET SYMBOL'S VALUE JFCL ;IF SKIP RETURN USE NEW USER VALUE MOVE B,-1(P) ;GET THE THING TO BE PUSHED JSP T,%XCONS ;PUSH ON THE "STACK" POP P,AR1 ;GET BACK POINTER TO SYMBOL JSP T,.SET ;STORE BACK THE NEW "STACK" POINTER POPI P,1 POPJ P, $POPER: POP P,A %WTA TNILER $POP: JSP TT,FWNACK FA12,,Q$POP PUSH P,A PUSHJ P,CADR HRRZ B,@(P) JUMPE B,$POP4 ;CHECK OUT OF PLACE INTO WHICH TO POP JUMPE A,$POPER CAIN A,TRUTH JRST $POPER JSP T,SPATOM JRST $POP1 $POP4: HLRZ A,@(P) ;GET THE "STACK" POINTER JUMPE A,$POPER CAIN A,TRUTH JRST $POPER JSP T,SPATOM JRST $POP1 PUSHJ P,EVAL ;AND GET THE "STACK" PUSH P,(A) ;SAVE THE 1ST CONS OF THE "STACK" ON P HRRZ A,@-1(P) ;GET THE PLACE TO POP INTO JUMPE A,$POP2 ;NOT SPECIFIED, JUST RETURN THE TOP OF "STACK" HLRZ A,(A) HLRZ AR1,(P) ;CAR OF STACK IS VALUE BEING POPPED JSP T,.SET1 ;SET THE SYMBOL INTO WHICH IT IS POPPING $POP2: HRRZ AR1,(P) ;NOW CDR THE "STACK" AND RE-SET INTO STK-PTR HLRZ A,-1@(P) JSP T,.SET1 HLRZ A,(P) ;RETURN THE CAR OF THE NEW "STACK" POPI P,2 POPJ P, $POP1: SKIPA C,[QIPOX] ;"PUSH" AND "POP" CANT BE HANDLED $PUSH1: MOVEI C,QIPUX ; So invoke the LISP-coded +INTERNAL-foo-X POP P,A ; which expands it for us SETZ B, ; B=() means "For Value" CALLF 2,(C) JRST EVAL ;and EVAL the result TNILER: SIXBIT \T AND NIL NOT ACCEPTABLE FOR "PUSH" AND "POP"!\ SUBTTL STORE, BREAK, SIGNP STORE: JSP TT,FWNACK FA2,,QSTORE HLRZ B,(A) PUSH P,B HRRZ A,(A) HLRZ A,(A) PUSHJ P,EVAL ;EVALUATE SECOND ARGUMENT FIRST! PUSH P,A STORE7: HRRZ A,-1(P) SETZM LISAR PUSHJ P,EVNH0 ;EVALUATE ARRAY REFERENCE WITHOUT HOOKING IT SKIPN A,LISAR ;ALWAYS CHECK FOR THIS GROSS LOSS JRST STORE5 SKIPN V.RSET JRST STORE9 JSP T,ARYSIZ ;GET SIZE OF ARRAY IN WORDS IN TT TLNN R,200000 ;=> NEGATIVE INDEX CAIG TT,(R) ;THERE'S PROBABLY A FENCE-POST FOR SX ARRAYS HERE JRST STORE5 STORE9: POP P,A SUB P,R70+1 JSP T,.STORE SETZM LISAR POPJ P, BREAK: JSP TT,FWNACK ;FSUBR (1 . 2) FA12,,QBREAK HLRZ B,(A) ;BKPT NAME HRRZ A,(A) JUMPE A,$BRK0 ;NO SECOND ARG => ALWAYS BREAK HLRZ A,(A) ;TO-BREAK-OR-NOT SWITCH PUSH P,B PUSHJ P,EVAL ;THIS IS A CROCK!!! POP P,B JRST $BREAK ;A = BREAKP, B = BREAKID SIGNP: JSP TT,FWNACK ;FSUBR 2 FA2,,QSIGNP PUSH P,(A) HLRZ A,(A) PUSH P,A SIGNP0: PUSHJ P,PNGET HLRZ A,(A) MOVS T,(A) HRRZ A,(A) JUMPN A,SIGNPE MOVNI A,6 CAIE T,@SPTB+6(A) AOJL A,.-1 JUMPGE A,SIGNPE HLLZ A,SPTB+6(A) SUB P,R70+1 EXCH A,(P) HLRZ A,(A) PUSHJ P,EVAL PUSHJ P,NUMBERP JUMPE A,POP1J POP P,T HRRI T,TRUE XCT T JRST FALSE SPTB: IRP Q,,[L,E,LE,G,GE,N] JUMP!Q TT,(ASCII \Q\) TERMIN SUBTTL PROG2, PROGN, EQ, RPLACA, RPLACD PROG1: SKIPA R,XC-1 PROG2: MOVNI R,2 CAMLE T,R JRST PRG12Z HRLI T,-1(T) ADD T,P SUBM T,R MOVE A,(R) MOVEM T,P POPJ P, PRG12Z: MOVEI D,QPROG2 CAIE R,2 MOVEI D,QPROG1 JRST WNALOSE PROGN: AOJG T,FALSE POP P,A PROGN1: JUMPE T,CPOPJ HRLI T,-1(T) ADD P,T POPJ P, EQ: CAMN A,B ;SUBR 2 - POINTER IDENTITY PREDICATE JRST TRUE JRST FALSE RPLACA: SKOTT A,LS JRST RPLCA0 TLNE TT,PUR+VC JRST RPLCA1 HRLM B,(A) POPJ P, RPLACD: ;SUBR 2 - CLOBBER CDR OF FIRST ARG WITH SECOND SKOTT A,LS JRST RPLCD2 TLNE TT,PUR JRST RPLCD1 RPLCD3: HRRM B,(A) POPJ P, RPLCD2: JUMPE A,RPLCD0 ;(RPLACD NIL FOO) IS ALWAYS A LOSS SKIPE T,VCDR CAIN T,QLIST ;IF CDR = NIL OR LIST, THEN BOMBOUT JRST RPLCD0 ;SINCE ARG IS NOT LIST OR NIL CAIN T,QSYMBOL TLNE TT,SY JRST RPLCD3 ;IF NOT CDR = SYMBOL, THEN ANYTHING GOES JRST RPLCD0 PGTOP EVL,[EVAL, APPLY, STUFF OPEN-CODED BY COMPLR] ;;@ GCBIB 246 GARBAGE COLLECTOR AND ALLOCATION STUFF ;;; ***** MACLISP ****** GARBAGE COLLECTOR AND ALLOCATION STUFF ** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT GC SUBTTL GRABBAGE COLLECTORS AND RELATED ITEMS GCRET: TDZA A,A ;GC WITH NORET=NIL GCNRT: MOVEI A,TRUTH ;GC WITH NORET=T HRRI T,UNBIND ;EXPECTS FLAG IN LH OF T PUSH P,T JSP T,SPECBIND 0 A,VNORET JRST AGC GC: PUSH P,[333333,,FALSE] ;SUBR 0 - USER ENTRY TO GC JRST AGC ;TO UNDERSTAND THE 3'S, SEE GSTRT7 MINCEL==6*NFF ;MIN NUMBER WORDS TO RECLAIM FOR EACH SPACE IFG 40-MINCEL, MINCEL==40 IFN KA10+KI10,[ GCCNT: ;FREELIST COUNTING LOOP TO RUN IN AC'S OFFSET -. NIL ;SO THAT THE FOLLOWING INS WILL STOP ON NIL GCCNT1: SKIPE TT,(TT) GCCNT4: AOJA GCCNT0,.-1 ;OR MAYBE AOBJN JRST GCP4A LPROG3==:.-1 GCCNT0: OFFSET 0 .HKILL GCCNT1 GCCNT4 GCCNT0 ] ;END OF IFN KA10+KI10 IFN KL10,[ GCCNT1: SKIPE VGCDAEMON ;FREELIST COUNTING LOOP JRST GCCNT6 SKIPE TT,(TT) AOBJN GCCNT0,.-1 ;SHORT ONE FOR JUST SEEING WHETHER >MINCEL JRST GCP4A GCCNT6: SKIPE TT,(TT) AOJA GCCNT0,.-1 ;LONG ONE FOR COUNTING FOR GCDAEMON JRST GCP4A GCCNT0==:AR1 ] ;END OF IFN KL10 SUBTTL GC - INITIALIZATION WHL==:USELESS*ITS ;FLAG FOR WHO-LINE STUFF XCTPRO AGC4: HRROS NOQUIT ;ENTRY FROM FWCONS, FLCONS, AND THE LIKE NOPRO SUBI A,2 ;ENTER WITH JSP A,AGC4 PUSH P,A XCTPRO AGC: HRROS NOQUIT ;ENTER HERE WITH PUSHJ P,AGC NOPRO SKIPE ALGCF ;CANT SUCCESSFULLY GC WHILE IN ALLOC JRST ALERR AGC1: ;MUST HAVE DONE HRROS NOQUIT BEFORE COMING HERE. ;FIRST WE GET CURRENT RUNTIME IN "HOST MACHINE UNITS" IN GCTM1. ;THIS MUST BE DONE IN AND AROUND THE SAVING OF THE AC'S. IT$ .SUSET [.RRUNT,,GCTM1] MOVEM NACS+1,GCNASV 10$ SETZ NACS+1, 10$ RUNTIM NACS+1, ;GET RUNTIME FOR THIS JOB 10$ MOVEM NACS+1,GCTM1 MOVEI NACS+1,GCACSAV BLT NACS+1,GCACSAV+NACS ;BLT AWAY ARG ACS (AND NIL) INTO PROTECTED PLACE 20$ MOVEI 1,.FHSLF 20$ RUNTM ;GET RUNTIME FOR THIS FORK 20$ MOVEM 1,GCTM1 MOVE NACS+1,[NACS+2,,GCNASV+1] BLT NACS+1,GCNASV+16- ;SAVE NON-MARKED AC'S EXCEPT SP MOVE NACS+1,[UUOH,,GCUUSV] BLT NACS+1,GCUUSV+LUUSV-1 ;SAVE UUOH STUFF, IN CASE STRT IS USED MOVEI A,TRUTH ;SPECBIND TERPRI TO T, TO PREVENT JSP T,SPECBIND ; AUTO-TERPRI IN GC MESSAGES 0 A,V%TERPRI MOVEM SP,GCNASV+17- ;NOW SAVE SP SETZM GCFXP SETZ R, REPEAT NFF,[ SKIPN FFS+.RPCNT ;FIGURE OUT WHICH SPACE(S) EMPTY TLO R,400000_-.RPCNT ] ;END OF REPEAT NFF SKIPN FFY2 ;IF WE RAN OUT OF SYMBOL BLOCKS, TLO R,400000_<-FFY+FFS> ; THEN CREDIT IT TO SYMBOLS MOVN D,R ;THIS IS A STANDARD HACK TO KILL ONE BIT TDZE R,D ;SKIP IF THERE WERE NO BITS JUMPE R,GCGRAB ;JUMP IF EXACTLY ONE BIT ON AGC1Q: SETZM GCRMV AOSE IRMVF ;IF OVERRIDE IS ON, THEN SKIPE VGCTWA SETOM GCRMV ;DO REMOVAL ANYHOW. MOVNI TT,20 ;TOP 40 BITS OF WORD ON JSP F,GCINBT ;INIT MARK BITS FOR LIST, FIXNUM, ETC. MOVE T,[SFSSIZ,,OFSSIZ] ;SAVE AWAY OLD SIZES OF SPACES BLT T,OSASIZ ; (USED FOR ARG TO GC-DAEMON) MOVE T,VGCDAEMON IOR T,GCGAGV IFE WHL, JUMPE T,GCP6 IFN WHL, JUMPE T,GCP5 KAKI MOVSI R,GCCNT KAKI BLT R,LPROG3 KAKI SKIPN VGCDAEMON KAKI HRLI GCCNT4,(AOBJN GCCNT0,) MOVNI R,NFF ;MAY OR MAY NOT HAVE BIGNUMS OR HUNKS GCP4: SETZ GCCNT0, SKIPGE FFS+NFF(R) JRST GCP4B SKIPN VGCDAEMON MOVSI GCCNT0,-MINCEL SKIPE TT,FFS+NFF(R) AOJA GCCNT0,GCCNT1 GCP4A: TLZ GCCNT0,-1 HRRZ F,GCWORN+NFF(R) ;ACCOUNT FOR LENGTHS OF ITEMS IMULI GCCNT0,(F) CAIGE GCCNT0,MINCEL ;IF LESS THEN MINCEL, THEN FREELIST WAS SETZM FFS+NFF(R) ; "PRACTICALLY EMPTY" AND DESERVES SOME BLAME GCP4B: HRLM GCCNT0,NFFS+NFF(R) AOJL R,GCP4 ;FALLS THROUGH ;FALLS IN ;;; PDLS ARE SAFE IFN WHL,[ GCP5: MOVE F,GCWHO SKIPE GCGAGV JRST GSTRT0 TRNN F,1 ;1-BIT MEANS WE WANT TO SEE JRST GCP6 ; THE REASON FOR THE GC JRST GSTR0A ; IN THE WHO-LINE ] ;END OF IFN WHL IFE WHL,[ SKIPN GCGAGV JRST GCP6 ] ;END OF IFE WHL GSTRT0: STRT 17,[SIXBIT \^M;GC DUE TO !\] GSTR0A: SETZB TT,D ;FIGURE OUT REASON FOR GC HLRZ T,(P) CAIN T,111111 ;WAS IT INITIAL STARTUP? (SEE LISP) MOVEI TT,[SIXBIT \STARTUP!\] CAIN T,333333 ;WAS IT USER CALLING GC FUNCTION? MOVEI TT,[SIXBIT \USER!\] CAIN T,444444 ;WAS IT ARRAYS? MOVEI TT,[SIXBIT \ARRAY RELOCATION!\] CAIN T,555555 ;I/O CHANNELS? MOVEI TT,[SIXBIT \I/O CHANNELS!\] CAIN T,666666 ;SUSPEND? MOVEI TT,[SIXBIT \SUSPEND!\] JUMPN TT,GSTRT8 MOVNI T,NFF ;NONE OF THOSE HYPOTHESES WORK GSTRT1: SKIPN FFS+NFF(T) ;MAYBE SOME STORAGE SPACE RAN OUT SKIPA TT,T ADDI D,1 AOJL T,GSTRT1 JUMPE TT,GSTRT7 ;NO, THAT WASN'T IT IFN WHL, SKIPN GCGAGV .ALSO, JRST GSTRT4 MOVNI T,NFF ;YES, IT WAS. PRINT MOBY MESSAGE! SETZ R, GSTRT2: SKIPE FFS+NFF(T) JRST GSTRT5 JUMPE R,GSTRT3 CAIE D,NFF-2 STRT 17,[SIXBIT \, !\] CAMN T,TT STRT 17,[SIXBIT \ AND !\] GSTRT3: SETO R, STRT 17,@GSTRT9+NFF(T) GSTRT5: AOJL T,GSTRT2 STRT 17,[SIXBIT \ SPACE!\] CAIE D,NFF-1 STRT 17,[SIXBIT \S!\] IFN WHL, GSTRT4: MOVE TT,GSTRT9+NFF(TT) JRST GSTRT6 GSTRT7: MOVEI TT,[SIXBIT \ ? !\] ;I DON'T KNOW WHY WE'RE HERE! GSTRT8: IFN WHL,SKIPE GCGAGV STRT 17,(TT) ;PRINT REASON GSTRT6: IFN WHL,[ TRNN F,1 JRST GCWHL9 MOVE D,(TT) MOVE R,1(TT) ROTC D,-22 MOVSI F,(SIXBIT \!\) MOVE T,[220600,,D] GCWHL2: ILDB TT,T CAIE TT,'! JRST GCWHL2 DPB NIL,T GCWHL3: IDPB NIL,T TLNE T,770000 JRST GCWHL3 HRLI D,(SIXBIT \GC:\) MOVE T,[-6,,GCWHL6] .SUSET T GCWHL9: ] ;END OF IFN WHL ;FALLS THROUGH ;;; PDLS ARE SAFE SUBTTL GC - MARK THE WORLD ;FALLS IN GCP6: HRROS MUNGP ;STARTING TO MUNG SYMBOL/SAR MARK BITS MOVE A,[<-20>_-NUNMRK] ;PRE-PROTECT CERTAIN ANDM A,BTBLKS ; RANDOM LIST CELLS MOVNI R,NACS+1 ;PROTECT CONTENTS OF MARKED ACS GCP6Q0: HRRZ A,GCACSAV+NACS+1(R) JSP T,GCMARK AOJL R,GCP6Q0 HRRZ R,C2 ADDI R,1 GCP6Q1: HRRZ A,(R) ;CAUSES MARKING OF CONTENTS JSP T,GCMARK ; OF ACS AT TIME OF GC, AND OF REG PDL CAIGE R,(P) AOJA R,GCP6Q1 MOVEI R,LPROTE-1 GCP6Q2: MOVEI A,BPROTE(R) ;PROTECT PRECIOUS STUFF JSP T,GCMARK SOJGE R,GCP6Q2 IFN BIGNUM,[ MOVEI R,LBIGPRO-1 GCP6Q3: MOVEI A,BBIGPRO(R) JSP T,GCMARK SOJGE R,GCP6Q3 ] ;END OF IFN BIGNUM MOVSI R,TTS IORM R,DEDSAR+TTSAR ;PROTECT DEDSAR IORM R,DBM+TTSAR ;PROTECT DEAD BLOCK MARKER HRRZ R,SC2 GCP6Q4: HRRZ A,(R) JSP T,GCMARK ;MARK SAVED VALUES ON SPEC PDL CAIGE R,(SP) AOJA R,GCP6Q4 SKIPN R,INTAR JRST GCP6Q6 GCP6Q5: MOVE A,INTAR(R) JSP T,GCMARK SOJG R,GCP6Q5 GCP6Q6: ;PROTECT INTERRUPT FUNCTIONS IRP Z,,[0,1,2]X,,[ALARMCLOCK,AUTFN,UDF] MOVEI R,NUINT!Z SKIPE A,V!X(R) JSP T,GCMARK SOJG R,.-2 TERMIN SKIPE A,VMERR JSP T,GCMARK IFN PAGING,[ SKIPN D,LHSGLK ;SKIP IF ANY LH SEGMENTS JRST GCP6R0 .SEE LHVBAR GCP6Q8: MOVEI F,(D) ;CREATE AOBJN POINTER INTO SEGMENT LSH F,SEGLOG HRLI F,-SEGSIZ GCP6Q9: HLRZ A,(F) ;MARK FROM ALL ENTRIES IN THAT SEGMENT JSP T,GCMARK HRRZ A,(F) JSP T,GCMARK AOBJN F,GCP6Q9 LDB D,[SEGBYT,,GCST(D)] ;FOLLOW LINKED LIST OF SEGMENTS JUMPN D,GCP6Q8 GCP6R0: ] ;END OF IFN PAGING ;FALLS THROUGH ;;; PDLS ARE SAFE ;FALLS IN SKIPN GCRMV JRST GCP6B1 JSP R,GCGEN ;IF DOING TWA REMOVAL, TRY MARKING FROM GCP8I ;NON-TRIVIAL P-LISTS OF CURRENT OBARRAY JRST GCP6B2 GCP6B1: MOVE A,VOBARRAY JSP TT,$GCMKAR ;OTHERWISE, JUST MARK OBARRAY BUCKETS GCP6B2: MOVEI A,OBARRAY CAME A,VOBARRAY JSP TT,$GCMKAR MOVE R,GCMKL GCP6A: JUMPE R,GCP6D HLRZ A,(R) MOVE D,ASAR(A) TLNN D,AS ;IF ARRAY POINTER HAS "GC ME" BIT SET, JRST GCP6F TLNE D,AS ;MORE CHECKING ON OBARRAYS JRST GCP6F0 GCP6F1: JSP TT,GCMKAR ; THEN MARK FROM ARRAY ENTRIES GCP6F: HRRZ R,(R) HRRZ R,(R) JRST GCP6A GCP6F0: CAMN A,VOBARRAY ; AND IF THIS ISN'T THE CURRENT OBARRAY, SKIPN GCRMV ; OR IT IS, BUT WE ARENT DOING GCTWA REMOVAL, JRST GCP6F1 JRST GCP6F GCP6D: MOVE A,V%TYI JSP TT,$GCMKAR MOVE A,V%TYO JSP TT,$GCMKAR SKIPN R,PROLIS GCP6D1: JUMPE R,GCP6H ;PROTECT READ-MACRO HLRZ A,(R) ; FUNCTIONS (CAN'T JUST GCMARK WHOLE HLRZ A,(A) ; PROLIS - DON'T WANT TO PROTECT JSP T,GCMARK ; READTABLE SARS) HRRZ R,(R) JRST GCP6D1 GSTRT9: [SIXBIT \LIST!\] .SEE GCWORRY [SIXBIT \FIXNUM!\] .SEE GCPNT [SIXBIT \FLONUM!\] DB$ [SIXBIT \DOUBLE!\] CX$ [SIXBIT \COMPLEX!\] DX$ [SIXBIT \DUPLEX!\] BG$ [SIXBIT \BIGNUM!\] [SIXBIT \SYMBOL!\] IRP X,,[2,4,8,16,32,64,128,256,512,1024] [SIXBIT \HUNK!X!!\] IFE .IRPCNT-HNKLOG, .ISTOP TERMIN [SIXBIT \ARRAY!\] IFN WHL,[ GCWHL6: .RWHO1,,GCWHO1 .RWHO2,,GCWHO2 .RWHO3,,GCWHO3 .SWHO1,,[.BYTE 8 ? 66 ? 0 ? 366 ? 0 ? .BYTE] .SWHO2,,D .SWHO3,,R ] ;IFN WHL ;;; PDLS ARE SAFE SUBTTL GC - CONSIDER THE EFFECTS OF AN ARRAY DISAPPEARING ;;; UPDATE THE GCMKL BY SPLICING OUT ARRAYS TO BE SWEPT. ;;; IF ANY SUCH ARRAYS ARE OPEN FILES, CLOSE THEM. CGCMKL: GCP6H: SKIPN F,GCMKL JRST GCP7 JSP A,GCP6H0 GCP6H1: HLRZ A,(F) TDNE TT,TTSAR(A) JRST GCP6G TDNE T,ASAR(A) JRST GCP6H7 GCP6H8: ANDCAM TT,TTSAR(A) IORM R,TTSAR(A) MOVEI B,ADEAD EXCH B,ASAR(A) TLNN B,AS JRST GCP6G MOVEI AR1,PROLIS ;JUST KILLED A READTABLE GCP6H3: HRRZ AR2A,(AR1) ; - CLEAN UP PROLIS GCP6H4: JUMPE AR2A,GCP6G HLRZ C,(AR2A) HRRZ C,(C) HLRZ C,(C) CAIE C,(A) JRST GCP6H5 HRRZ AR2A,(AR2A) HRRM AR2A,(AR1) JRST GCP6H4 GCP6H5: MOVEI AR1,(AR2A) JRST GCP6H3 GCP6G: HRRZ F,(F) HRRZ F,(F) JUMPN F,GCP6H1 JRST GCP7 GCP6H0: MOVSI T,AS ;SET UP SOME ACS FOR THE GCMKL-LOOK LOOP MOVE R,[TTDEAD] MOVSI TT,TTS JRST (A) ;;; PDLS ARE SAFE ;;; CLEAN UP AND CLOSE A FILE WHEN GARBAGE COLLECTED GCP6H7: MOVE B,TTSAR(A) ;ABOUT TO GC A FILE ARRAY TLNE B,TTS ;IGNORE IF ALREADY CLOSED JRST GCP6H8 PUSH P,F IFN JOBQIO,[ HLL B,ASAR(A) TLNE B,AS JRST GCP6J1 ] ;END OF IFN JOBQIO PUSHJ P,ICLOSE ;OTHERWISE CLOSE THE FILE MOVEI R,[SIXBIT \^M;FILE CLOSED: !\] GCP6H2: SKIPN GCGAGV JRST GCP6H9 STRT 17,(R) HLRZ A,@(P) HRRZ AR1,VMSGFILES TLO AR1,200000 HRROI R,$TYO PUSHJ P,PRINTA GCP6H9: POP P,F JSP A,GCP6H0 ;RE-INIT MAGIC CONSTANTS IN ACS HLRZ A,(F) JRST GCP6H8 IFN JOBQIO,[ ;;; CLEAN UP AND CLOSE AN INFERIOR PROCEDURE WHEN GARBAGE COLLECTED GCP6J1: IFN ITS,[ MOVEI R,[SIXBIT \^M;FOREIGN JOB FLUSHED: !\] SKIPN T,J.INTB(B) JRST GCP6J3 MOVEI R,[SIXBIT \^M;INFERIOR JOB FLUSHED: !\] .CALL GCP6J9 ;IF INFERIOR JOB, OPEN IT ON .VALUE ; THE TEMPORARY I/O CHANNEL .UCLOSE TMPC, ; AND KILL IT JFFO T,.+1 MOVNS TT SETZM JOBTB+21(TT) ;CLEAR ENTRY IN JOB TABLE ] ;END OF IFN ITS GCP6J3: MOVSI T,TTS ;MARK THE JOB OBJECT AS BEING CLOSED ANDCAM T,TTSAR(A) JRST GCP6H2 IFN ITS,[ GCP6J9: SETZ SIXBIT \OPEN\ ;OPEN FILE (INFERIOR PROCEDURE) 1000,,TMPC ;CHANNEL NUMBER ,,F.DEV(B) ;DEVICE NAME (USR) ,,F.FN1(B) ;FILE NAME 1 (UNAME) 400000,,F.FN2(B) ;FILE NAME 2 (JNAME) ] ;END OF IFN ITS ] ;END OF IFN JOBQIO ;;; PDLS ARE SAFE SUBTTL GC - TWA REMOVAL GCP7: HRRZ A,GCMKL JSP T,GCMARK HRRZ A,PROLIS JSP T,GCMARK SKIPN GCRMV JRST GCSWP JSP R,GCGEN ;IF DOING TWA REMOVAL, THEN WIPE OUT GCP8G ; T.W.A.'S AND THEN MARK BUCKETS MOVE A,VOBARRAY JSP TT,$GCMKAR ;FALLS THROUGH ;;; PDLS ARE UNSAFE SUBTTL GC - SWEEP THE WORLD ;FALLS IN GCSWP: .SEE KLINIT ;WHICH CLOBBERS NEXT INSTRUCTION MOVEM FXP,GCFXP ;WE ARE ABOUT TO CLOBBER THE PDL POINTERS MOVNI SP,NFF ;NUMBER OF SPACES TO SWEEP MOVEM SP,GC99 ;MAJOR SWEEP LOOP OVER ALL SPACES GCSW1: IFN KA10+KI10,[ MOVE FXP,GCSWTB+NFF(SP) ;PUT INNER SWEEP LOOP IN AC'S HLLZ FLP,FXP ; AND INITIALIZE COUNT BLT FLP,(FXP) SETZ FXP, ;FREELIST INITIALLY NIL ] ;END OF IFN KA10+KI10 KL SETZB A,FXP ;FXP HAS FREELIST, A HAS COUNT SKIPN FLP,FSSGLK+NFF(SP) JRST GCSW7 ;MINOR SWEEP LOOP OVER ALL SEGMENTS IN A SPACE GCSW2: MOVEM FLP,GC98 JRST @GCSW2A+NFF(SP) ;DISPATCH ON TYPE TO SEPARATE ROUTINES GCSW2A: GCSWS ;LIST GCSWS ;FIXNUM GCSWS ;FLONUM DB$ GCSWD ;DOUBLE CX$ GCSWC ;COMPLEX DX$ GCSWZ ;DUPLEX BG$ GCSWS ;BIGNUM GCSWY ;SYMBOL IFN HNKLOG, GCSWH1 REPEAT HNKLOG,[ IFL .RPCNT-4, GCSWH1 ;HUNKS OF LESS THAN 40 WORDS .ELSE GCSWH2 ;HUNKS OF 40 WORDS OR MORE ] ;END OF REPEAT HNKLOG GCSWA ;SARS IFN .-GCSW2A-NFF, WARN [WRONG LENGTH TABLE] GCSW5: MOVE SP,GC99 MOVE FLP,GC98 LDB FLP,[SEGBYT,,GCST(FLP)] JUMPN FLP,GCSW2 GCSW7: KAKI HRRZ A,@GCSW7A+NFF(SP) HRRM FXP,FFS+NFF(SP) ;SAVE FREELIST - DON'T DISTURB SIGN BIT HRRZ B,GCWORN+NFF(SP) IMULI A,(B) ;ACCOUNT FOR SIZE OF OBJECTS IN THIS SPACE HRRM A,NFFS+NFF(SP) ;SAVE COUNT OF WORDS COLLECTED AOSGE SP,GC99 JRST GCSW1 HRRZS MUNGP ;WE HAVE UNDONE MUNGING OF BITS MOVSI F,TTS ANDCAM F,DEDSAR ;MUST CLEAR BITS IN DEDSAR JSP NACS+1,GCACRS ;RESTORE ACCUMULATORS JRST GCPNT ;NEXT PRINT STATISTICS ;;; PDLS ARE UNSAFE IFN KA10+KI10,[ ;TABLE OF SWEEPERS FOR RUNNING IN ACS AND THE LAST LOCATIONS TO LOAD THEM INTO GCSWTB: GCFSSWP,,LPROG1 ;LIST GCFSSWP,,LPROG1 ;FIXNUM GCFSSWP,,LPROG1 ;FLONUM DB$ GCHSW1,,LPROGH ;DOUBLE CX$ GCHSW1,,LPROGH ;COMPLEX DX$ GCHSW1,,LPROGH ;DUPLEX BG$ GCFSSWP,,LPROG1 ;BIGNUM GSYMSWP,,LPROG6 ;SYMBOL IFN HNKLOG, GCHSW1,,LPROGH REPEAT HNKLOG,[ IFL .RPCNT-4, GCHSW1,,LPROGH ;HUNKS OF LESS THAN 40 WORDS .ELSE GCHSW2,,LPROGK ;HUNKS OF 40 WORDS OR MORE ] ;END OF REPEAT HNKLOG GSARSWP,,LPROG4 ;SARS IFN .-GCSWTB-NFF, WARN [WRONG LENGTH TABLE] ;TABLE OF AC FOR EACH SWEEPER WHICH HOLDS COUNT OF OBJECTS SWEPT GCSW7A: GFSCNT ;LIST GFSCNT ;FIXNUM GFSCNT ;FLONUM DB$ GHCNT1 ;DOUBLE CX$ GHCNT1 ;COMPLEX DX$ GHCNT1 ;DUPLEX BG$ GFSCNT ;BIGNUM GYCNT ;SYMBOL IFN HNKLOG, GHCNT1 REPEAT HNKLOG,[ IFL .RPCNT-4, GHCNT1 ;HUNK OF LESS THAN 40 WORDS .ELSE GHCNT2 ;HUNKS OF 40 WORDS OR MORE ] ;END OF REPEAT HNKLOG GSCNT ;SARS IFN .-GCSW7A-NFF, WARN [WRONG LENGTH TABLE] ] ;END OF IFN KA10+KI10 ;;; PDLS ARE UNSAFE GCSWS: MOVE P,GCST(FLP) ;GET SHIFTED ADDRESS OF BIT BLOCK LSH P,SEGLOG-5 ;SHIFT BACK TO FORM WORD ADDRESS HRLI P,-BTBSIZ ;MAKE AOBJN POINTER OVER WORDS OF BITS LSH FLP,SEGLOG HRLI FLP,-40 ;40 CELLS PER WORD OF BITS KAKI JRST GFSP1 ;FXP HAS RUNNING FREELIST ;FLP HAS AOBJN POINTER OVER CELLS ;P HAS AOBJN POINTER OVER WORDS OF BITS GCFSSWP: ;SWEEPER FOR LIST, FIXNUM, FLONUM, BIGNUM KAKI OFFSET -. ;RELOCATED TO ACS FOR KA AND KI GFSP1: SKIPN SP,(P) ;GET A WORD OF MARK BITS JRST GFSP5 ;IF ALL 40 WORDS MARKED, THIS SAVES TIME GFSP2: JUMPGE SP,GFSP4 ;JUMP IF SINGLE WORD MARKED HRRZM FXP,(FLP) ;ELSE CHAIN INTO FREE LIST HRRZI FXP,(FLP) KAKI GFSCNT: AOJ .,0 ;RH COUNTS RECLAIMED CELLS KL ADDI A,1 GFSP4: ROT SP,1 ;ROTATE NEXT MARK BIT UP AOBJN FLP,GFSP2 ;COUNT OFF 40 WORDS TLOA FLP,-40 ;RESET 40-WORD COUNT IN AOBJN POINTER GFSP5: ADDI FLP,40 ;SKIP OVER 40 WORDS IN SWEEP AOBJN P,GFSP1 ; BLOCKS OF 40 WORDS JRST GCSW5 KAKI LPROG1==:.-1 KAKI OFFSET 0 KAKI .HKILL GFSP1 GFSP2 GFSCNT GFSP4 GFSP5 GCSWY: LSH FLP,SEGLOG HRLI FLP,-SEGSIZ KL MOVEI GYSP7,(300,,0) ;3.8=PURE, 3.7=COMPILED CODE REFS KAKI JRST GYSP1 KL GYSP7==:0 GSYMSWP: ;SWEEPER FOR SYMBOL SPACE KAKI OFFSET -. KAKI GYSP7: (300,,0) ;3.8=PURE, 3.7=COMPILED CODE REFS (NOTE: TSNE WITH ITSELF ALWAYS SKIPS) GYSP1: HLRZ SP,(FLP) TRZN SP,1 ;IF MARKED, TSNE GYSP7,(SP) ; OR IF PURE OR COMPILED CODE NEEDS IT, JRST GYSP3 ; THEN DO NOT SWEEP UP JUMPN SP,GYSP5 ;IF NON-NIL LEFT HALF, RECLAIM THE SYMBOL BLOCK GYSP2: HRRZM FXP,(FLP) ;CHAIN ONTO FREELIST HRRZI FXP,(FLP) GYCNT: KAKI AOJ .,0 KL ADDI A,1 ;INCREMENT OBJECT COUNT GYSP3: HRLM SP,(FLP) AOBJN FLP,GYSP1 JRST GCSW5 KAKI LPROG6==:.-1 KAKI OFFSET 0 KAKI .HKILL GYSP1 GYSP2 GYSP3 GYSP7 GYCNT ;;; PART OF SYMBOL SWEEPER - RESTORES A SYMBOL BLOCK TO FFY2. ;;; ALSO ATTEMPTS TO RETURN THE VALUE CELL IF IT HAS ONE. GYSP5: EXCH SP,FFY2 ;RETURN SYMBOL BLOCK TO FREELIST EXCH SP,@FFY2 TLZ SP,-1 ;MAYBE TRY TO RETURN A VALUE CELL CAIE SP,SUNBOUND JRST GYSP5A SETZ SP, JRST GYSP2 GYSP5A: CAIL SP,BXVCSG+NXVCSG*SEGSIZ JRST GYSP5B ;CAN ONLY RETURN CELLS IN VC SPACE EXCH SP,FFVC MOVEM SP,@FFVC GYSP5B: SETZ SP, JRST GYSP2 ;;; PDLS ARE UNSAFE IFN HNKLOG+DBFLAG+CXFLAG,[ GCSWD: GCSWC: GCSWZ: GCSWH1: HRRZ P,GCWORN+NFF(SP) ;GET SIZE OF OBJECTS KAKI HRRI GH1SP4,(P) KL MOVEI B,(P) SUBI P,1 KAKI HRRI GH1SP5,(P) KL MOVEI C,(P) HRRZ P,GCWORN+NFF(SP) MOVNI SP,40 IDIVM SP,P KAKI HRRI GH1SP6,(P) ;BITS PER BIT BLOCK WORD KL MOVEI AR1,(P) MOVE P,GCST(FLP) ;GET SHIFTED ADDRESS OF BIT BLOCK LSH P,SEGLOG-5 ;SHIFT BACK TO FORM WORD ADDRESS HRLI P,-BTBSIZ ;MAKE AOBJN POINTER OVER WORDS OF BITS LSH FLP,SEGLOG ;MAKE AOBJN POINTER OVER CELLS KAKI HRLI FLP,(GH1SP6) KL HRLI FLP,(AR1) KAKI JRST GH1SP1 ;FXP HAS RUNNING FREELIST ;FLP HAS AOBJN POINTER OVER CELLS ;P HAS AOBJN POINTER OVER WORDS OF BITS GCHSW1: KAKI OFFSET -. GH1SP1: MOVE SP,(P) GH1SP2: JUMPGE SP,GH1SP4 HRRZM FXP,(FLP) HRRZI FXP,(FLP) IFN KA10+KI10,[ GHCNT1: AOJ .,0 GH1SP4: ROT SP,1_HNKLOG GH1SP5: ADDI FLP,<1_HNKLOG>-1 AOBJN FLP,GH1SP2 GH1SP6: HRLI FLP,<-40>_-HNKLOG ] ;END OF IFN KA10+KI10 IFN KL10,[ ADDI A,1 GH1SP4: ROT SP,(B) ADDI FLP,(C) AOBJN FLP,GH1SP2 HRLI FLP,(AR1) ] ;END OF IFN KL10 AOBJN P,GH1SP1 JRST GCSW5 KAKI LPROGH==:.-1 KAKI OFFSET 0 KAKI .HKILL GH1SP1 GH1SP2 GHCNT1 GH1SP4 GH1SP5 GH1SP6 ] ;END OF IFN HNKLOG+DBFLAG+CXFLAG ;;; PDLS ARE UNSAFE IFG HNKLOG-4,[ GCSWH2: HRRZ P,GCWORN+NFF(SP) ;GET SIZE OF OBJECTS KAKI HRRI GH2SP5,(P) KL MOVEI B,(P) SUBI P,1 LSH P,-5 KAKI HRRI GH2SP7,(P) ;BITS PER BIT BLOCK WORD KL MOVEI AR2A,(P) HRRZ P,GCWORN+NFF(SP) LSH P,-5 MOVNI SP,BTBSIZ IDIVM SP,P HRLI P,(P) ;MAKE AOBJN POINTER OVER WORDS OF BITS MOVE SP,GCST(FLP) LSH SP,SEGLOG-5 HRRI P,(SP) LSH FLP,SEGLOG ;MAKE POINTER OVER CELLS KAKI JRST GH2SP1 ;FXP HAS RUNNING FREELIST ;FLP HAS AOBJN POINTER OVER CELLS ;P HAS AOBJN POINTER OVER WORDS OF BITS GCHSW2: KAKI OFFSET -. GH2SP1: SKIPL (P) ;ONLY THE SIGN BIT OF A MARK WORD IS USED JRST GH2SP5 HRRZM FXP,(FLP) HRRZI FXP,(FLP) IFN KA10+KI10,[ GHCNT2: AOJ .,0 GH2SP5: ADDI FLP,1_HNKLOG GH2SP7: ADDI P,<<1_HNKLOG>-1>_-5 ] ;END OF IFN KA10+KI10 IFN KL10,[ ADDI A,1 GH2SP5: ADDI FLP,(B) ADDI P,(AR2A) ] ;END OF IFN KL10 AOBJN P,GH2SP1 JRST GCSW5 KAKI LPROGK==:.-1 KAKI OFFSET 0 KAKI .HKILL GH2SP1 GH2SP2 GHCNT2 GH2SP5 GH2SP7 ] ;END OF IFG HNKLOG-4 GCSWA: LSH FLP,SEGLOG HRLI FLP,-SEGSIZ/2 KL MOVSI B,(TTS,,) KL MOVSI C,(TTS,,) JRST GSSP1 GSARSWP: ;SPECIAL SWEEPER FOR SARS KAKI OFFSET -. GSSP0: ADDI FLP,1 GSSP1: KAKI TDNN GSSP7,TTSAR(FLP) ;TEST IF SAR MARKED (OR OTHERWISE NEEDED) KL TDNN B,TTSAR(FLP) KAKI AOJA GSCNT,GSSP2 ;NO, COUNT IT AS SWEPT KL AOJA A,GSSP2 KAKI ANDCAM GSSP8,TTSAR(FLP) ;YES, TURN OFF MARK BIT KL ANDCAM C,TTSAR(FLP) AOBJN FLP,GSSP0 ; AND TRY NEXT ONE JRST GCSW5 GSSP2: HRRZM FXP,ASAR(FLP) ;CHAIN INTO FREE LIST HRRZI FXP,ASAR(FLP) AOBJN FLP,GSSP0 JRST GCSW5 KAKI GSSP7: TTS,, KAKI GSSP8: TTS,, KAKI GSCNT: 0 KAKI LPROG4==:.-1 KAKI OFFSET 0 KAKI .HKILL GSSP0 GSSP1 GSSP2 GSSP7 GSSP8 GSCNT ;;; PDLS ARE SAFE SUBTTL GC - MAKE SURE ENOUGH WAS RECLAIMED GCPNT: SKIPN GCGAGV JRST GCE0 SETZM GC99 ;GC99 COUNTS ENTRIES PRINTED MOVNI F,NFF GCPNT1: HRRZ T,NFFS+NFF(F) SKIPN TT,SFSSIZ+NFF(F) JRST GCPNT6 SOSLE GC99 JRST GCPNT2 STRT 17,[SIXBIT \^M; !\] ;TERPRI-; EVERY THIRD ONE MOVEI D,3 MOVEM D,GC99 GCPNT2: PUSHJ P,STGPNT STRT 17,@GSTRT9+NFF(F) CAME F,XC-1 ;COMMA AFTER EACH BUT LAST STRT 17,[SIXBIT \, !\] GCPNT6: AOJL F,GCPNT1 STRT 17,[SIXBIT \ WORDS FREE!\] ;FALLS THROUGH ;;; PDLS ARE SAFE SUBTTL GC - CLEANUP AND TERMINATION ;FALLS IN GCE0: MOVNI F,NFF GCE0C0: MOVE AR2A,MFFS+NFF(F) TLNN AR2A,-1 JRST GCE0C1 HRRZ AR1,SFSSIZ+NFF(F) FSC AR1,233 ;FIXNUM TO FLONUM CONVERSION FMPR AR1,AR2A MULI AR1,400 ;FLONUM TO FIXNUM CONVERSION ASH AR2A,-243(AR1) GCE0C1: SKIPGE FFS+NFF(F) JRST GCE0C5 CAIGE AR2A,MINCEL MOVEI AR2A,MINCEL ;MUST SATISFY ABSOLUTE MIN OF CELLS GCE0C5: MOVEM AR2A,ZFFS+NFF(F) HRRZ TT,NFFS+NFF(F) CAIGE TT,(AR2A) ;ALSO MUST SATISFY USER'S MIN PUSHJ P,GCWORRY ;IF NOT, MUST WORRY ABOUT IT GCE0C2: AOJL F,GCE0C0 MOVEI AR2A,1 SKIPN FFY2 PUSHJ P,GRABWORRY ;REMEMBER, F IS ZERO HERE SKIPN FFY2 JRST GCLUZ MOVNI F,NFF ;IF WE RECLAIMED LESS THAN ABSOLUTE GCE0C3: HRRZ TT,NFFS+NFF(F) ; MINIMUM FOR ANY SPACE, SKIPGE FFS+NFF(F) JRST GCE0C9 CAIGE TT,MINCEL ; WE ARE OFFICIALLY DEAD JRST GCLUZ GCE0C9: AOJL F,GCE0C3 SKIPE PANICP JRST GCE0C7 MOVNI F,NFF ;NOW SEE IF WE EXCEEDED MAXIMUM GCE0C6: MOVE TT,SFSSIZ+NFF(F) CAMG TT,XFFS+NFF(F) JRST GCE0K3 HRLZ D,GCMES+NFF(F) HRRI D,1004 ;GC-OVERFLOW PUSHJ P,UINT ;NOQUIT IS ON HERE, SO INTERRUPT GETS STACKED GCE0K3: AOJL F,GCE0C6 GCE0C7: MOVNI F,NFF GCE0C4: MOVE TT,SFSSIZ+NFF(F) CAMG TT,XFFS+NFF(F) ;IF A SPACE LOST TO GC-OVERFLOW, JRST GCE0K2 ; DON'T MAKE IT LOSE FOR GC-LOSSAGE TOO MOVEM TT,XFFS+NFF(F) ;JUST QUIETLY UPDATE ITS GCMAX JRST GCE0K1 GCE0K2: HRRZ T,NFFS+NFF(F) CAMGE T,ZFFS+NFF(F) JRST GCLUZ GCE0K1: AOJL F,GCE0C4 IFN PAGING,[ HRRZ TT,NOQUIT IOR TT,INHIBIT IOR TT,VNORET SKIPN TT PUSHJ P,RETSP ] ;END OF IFN PAGING SKIPE GCGAGV STRT 17,STRTCR ;FALLS THROUGH ;;; PDLS ARE SAFE ;FALLS IN SKIPN VGCDAEMON JRST GCEND MOVEI C,NIL ;CONS UP ARG FOR GCDAEMON MOVEI D,NFF-1 ;WE CHECKED LENGTH OF FREELISTS SO SETZ C, ; WE KNOW CONSES WON'T RE-INVOKE GC GCE0E: MOVE TT,SFSSIZ(D) ;SIZE OF SPACE AFTER GC PUSHJ P,CONS1FX MOVE TT,OFSSIZ(D) ;SIZE OF SPACE BEFORE GC PUSHJ P,CONSFX HRRZ TT,NFFS(D) ;LENGTH OF FREELIST AFTER GC CAIN D,FFX-FFS ;ALLOW FOR THE SPACE USED SUBI TT,4*NFF ; TO CONS UP THE GC-DAEMON ARG CAIN D,FFS-FFS SUBI TT,6*NFF PUSHJ P,CONSFX HLRZ TT,NFFS(D) ;LENGTH OF FREELIST BEFORE GC PUSHJ P,CONSFX HRRZ A,GCMES(D) ;NAME OF SPACE PUSHJ P,CONS MOVE B,C PUSHJ P,CONS MOVE C,A SOJGE D,GCE0E JSR GCRSR .SEE GCRSR0 HRLI A,1003 ;GC-DAEMON PUSH P,A ;FOR INTERRUPT PROTECTION ONLY PUSH FXP,D MOVS D,A PUSHJ P,UINT POPI P,1 ;FLUSH SLOT "FOR INTERRUPT PRO ONLY" MOVE D,(FXP) MOVEM F,(FXP) ;USE AC F BELOW, SINCE GCLUZ REQUIRES IT MOVNI F,NFF ;IF THE RUNNING OF THE GC-DAEMON ATE UP ALL SKIPN FFS+NFF(F) ; OUR SPACE, THEN LOSE BADLY! JRST GCLUZ0 AOJL F,.-2 POP FXP,F JRST POPAJ ;REMEMBER! GCRSR HAS STACKED A SAVED "A" ;;; GC MUST EITHER JRST TO GCEND, OR JSR TO GCRSR BEFORE EXITING. ;;; THIS ASSURES THAT GCTIM WILL PROPERLY REFLECT TIME SPENT IN GC. ;;; THE VALUE IN GCTIM IS IN "HOST MACHINE UNITS". ;;; THESE ARE CONVERTED BEFORE BEING RETURNED TO THE USER. .SEE SGCTIM GCEND: IFN D20,[ MOVEI 1,.FHSLF RUNTM ;UPDATE GCTIM FOR D20 IFN WHL, MOVEM 1,GC98 SUB 1,GCTM1 ADDM 1,GCTIM ] ;END OF IFN D20 MOVE P,GCNASV+14- MOVE SP,GCNASV+17- PUSHJ P,UNBIND JSP NACS+1,GCACR SETZM GCFXP IFE D20,[ IT$ .SUSET [.RRUNT,,NACS+1] 10$ SETZ NACS+1, 10$ RUNTIM NACS+1, IFN WHL, MOVEM NACS+1,GC98 SUB NACS+1,GCTM1 ADDM NACS+1,GCTIM ;UPDATE GCTIME FOR (STATUS GCTIME) ] ;END OF IFE D20 IFN WHL,[ SKIPE NACS+1,GCWHO PUSHJ P,GCWHR ] ;END OF IFN WHL MOVE NACS+1,GCNASV HRRZS NOQUIT JRST CHECKI ;GCRSR: 0 GCRSR0: HRLM C,NOQUIT ;RESTORE ACS, AND CHECK FOR ANY STACKED INTERRUPTS IFN D20,[ MOVEI 1,.FHSLF RUNTM ;UPDATE GCTIM FOR D20 IFN WHL, MOVEM 1,GC98 SUB 1,GCTM1 ADDM 1,GCTIM ] ;END OF IFN D20 MOVE P,GCNASV+14- MOVE SP,GCNASV+17- PUSHJ P,UNBIND JSP NACS+1,GCACR ;RESTORE AC'S SETZM GCFXP IT$ .SUSET [.RRUNT,,NACS+1] 10$ SETZ NACS+1, 10$ RUNTIM NACS+1, IFN WHL*, MOVEM NACS+1,GC98 SUB NACS+1,GCTM1 ADDM NACS+1,GCTIM ;UPDATE GCTIME FOR (STATUS GCTIME) IFN WHL,[ SKIPE NACS+1,GCWHO PUSHJ P,GCWHR ] ;END OF IFN WHL MOVE NACS+1,GCNASV PUSH P,A HLRZ A,NOQUIT PUSH P,GCRSR HRRZS NOQUIT JRST CHECKI ;;; ROUTINE TO INIT MARK BITS FOR LIST, FIXNUM, FLONUM, HUNK, ;;; AND BIGNUM SPACES. INIT BITS IN TT, RETURN ADDRESS IN F. GCINBT: MOVEM TT,BBITSG MOVE AR2A,[BBITSG,,BBITSG+1] BLT AR2A,@MAINBITBLT ;BLT OUT MAIN BIT AREA MOVE A,BTSGLK ;INITIALIZE ALL BIT BLOCKS GCINB0: JUMPE A,(F) MOVEI AR2A,(A) LSH AR2A,SEGLOG ;GET ADDRESS OF SEGMENT HRLI AR2A,(AR2A) MOVEM TT,(AR2A) AOJ AR2A, MOVE T,GCST(A) ;GET END ADDRESS FOR BLT LSH T,SEGLOG-5 TLZ T,-1 CAIE T,(AR2A) BLT AR2A,-1(T) ;***BLT!*** LDB A,[SEGBYT,,GCST(A)] JRST GCINB0 IFN WHL,[ GCWHR: TRNN NACS+1,2 ;SKIP IF GC STATISTICS DESIRED JRST GCWHR2 MOVE NACS+2,GCTIM IDIVI NACS+2,25000./4 ;GC TIME IN FORTIETHS OF A SECOND MOVEM NACS+2,GCWHO2 MOVE NACS+2,GCTIM ;GC TIME IMULI NACS+2,100. ; TIMES 100. IDIV NACS+2,GC98 ; DIVIDED BY TOTAL RUNTIME HRLM NACS+2,GCWHO2 ; EQUALS GC TIME PERCENTAGE TRNE NACS+1,1 JRST GCWHR2 .SUSET [.SWHO2,,GCWHO2] ;JUST SET .WHO2 IF WHO VARS NOT PREVIOUSLY SAVED GCWHR8: MOVE NACS+2,GCNASV+1 ;RESTORE ACS MOVE NACS+3,GCNASV+2 POPJ P, GCWHR2: MOVE NACS+2,[-3,,GCWHR9] ;RESTORE WHO VARS, POSSIBLY WITH .SUSET NACS+2 ; GC STATISTICS CLOBBERED INTO GCWHO2 JRST GCWHR8 GCWHR9: .SWHO1,,GCWHO1 .SWHO2,,GCWHO2 .SWHO3,,GCWHO3 ] ;IFN WHL SUBTTL MISCELLANEOUS GC UTILITY ROUTINES GCACRS: MOVE SP,GCNASV+17- ;RESTORE SP ALSO GCACR: SKIPN GCFXP MOVEM FXP,GCFXP MOVE NIL,[GCACSAV+1,,1] ;RESTORE ALL ACS EXCEPT NACS+1 BLT NIL,NACS MOVE NIL,[GCNASV+1,,NACS+2] BLT NIL,FXP MOVE NIL,GCACSAV SETZM GCFXP .SEE CHNINT ;ETC. JRST (NACS+1) $GCMKAR: MOVE D,ASAR(A) GCMKAR: MOVE F,TTSAR(A) SKIPL D,-1(D) ;MARK FROM ARRAY ENTRIES. JRST (TT) GCMKA1: HLRZ A,(D) JSP T,GCMARK HRRZ A,(D) JSP T,GCMARK AOBJN D,GCMKA1 JUMPE F,(TT) TLNE F,TTS TLNE F,TTS JRST (TT) MOVEI D,FB.BUF(F) ;FOR TTY INPUT FILE ARRAYS, HRLI D,-NASCII/2 ; MUST MARK INTERRUPT FUNCTIONS SETZ F, JRST GCMKA1 ;;; GCGEN GENERATES NON-NULL BUCKETS OF THE CURRENT OBARRAY ;;; AND APPLIES A GIVEN FUNCTION TO THEM. IT IS CALLED AS ;;; JSP R,GCGEN ;;; FOO ;;; GCGEN WILL EFFECTIVELY DO A JRST FOO MANY TIMES, ;;; PASSING SOME NON-NULL OBARRAY BUCKET THROUGH ACCUMULATOR D. ;;; FOO IS EXPECTED TO RETURN BY DOING A JRST GCP8A. ;;; WHEN DONE, GCGEN RETURNS, SKIPPING OVER THE ADDRESS FOO. GCGEN: MOVE F,@VOBARRAY .SEE ASAR MOVE F,-1(F) SUB F,R70+1 TLZ R,400000 GCP8A: TLCE R,400000 JRST GCP8A1 AOBJP F,1(R) ;EXIT HLRZ D,(F) JUMPN D,@(R) JRST GCP8A GCP8A1: HRRZ D,(F) JUMPN D,@(R) JRST GCP8A ;;; MARK AN S-EXPRESSION GIVEN IN A. TRACES IT COMPLETELY, ;;; MARKING ALL SUBITEMS BY SETTING A MARK BIT TO **ZERO** ;;; FOR LIST, FIXNUM, FLONUM, AND BIGNUM SPACES, AND TO ;;; **ONE** FOR SYMBOLS AND SARS. (THIS SPEEDS UP SWEEPING.) ;;; NEVER MARKS VALUE CELLS!!!! (THEY ARE NEVER SWEPT.) ;;; CALLED BY JSP T,GCMARK WITH OBJECT IN A. USES A,B,C,AR1,AR2A. GCMARK: JUMPE A,(T) ;NEEDN'T MARK NIL MOVEI AR2A,(P) ;REMEMBER WHERE P IS GCMRK0: JRST GCMRK1 .SEE KLINIT GCMRK3: TLNN A,GCBSYM ;MAYBE WE FOUND A SYMBOL JRST GCMRK4 ;NOPE HLRZ AR1,(C) ;YUP TROE AR1,1 JRST GCMKND HRLM AR1,(C) PUSH P,(C) ;PUSH PROPERTY LIST PUSH P,(AR1) ;PUSH PNAME LIST SKIPE ETVCFLSP ;A HAC TO SAVE TIME IF THERE NEVER HAVE BEEN JRST GCMRK6 ; VALUE CELLS TAKEN FROM LIST SPACE HRRZ A,@-1(AR1) JRST GCMRK1 ;GO MARK VALUE OF SYMBOL GCMRK6: HRRZ A,-1(AR1) CAIGE A,EVCSG CAIGE A,BVCSG JRST GCMRK7 HRRZ A,(A) CAIE A,QUNBOUND JRST GCMRK1 JRST GCMRK8 GCMRK7: LSH A,-SEGLOG SKIPL A,GCST(A) ;SKIP IF VALUE CELL NOT A LIST CELL?? JRST GCMKND ;SUNBOUND, FOR EXAMPLE???? HRRZ A,-1(AR1) ;POINTING TO A VC IN LIST SPACE JRST GCMRK1 GCMRK4: TLNN A,GCBVC ;MAYBE WE FOUND A VALUE CELL JRST GCMRK5 ;NOPE HRRZ A,(C) ;YUP - MARK ITS CDR (THE VALUE) JRST GCMRK1 GCMRK5: MOVSI AR1,TTS ;MUST BE AN ARRAY IORM AR1,TTSAR(C) ;SET ARRAY MARK BIT TO 1 GCMKND: CAIN AR2A,(P) ;SKIP IF ANYTHING LEFT ON STACK TO MARK JRST (T) ;ELSE RETURN GCMRK8: POP P,A ;GET NEXT ITEM TO MARK GCMRK1: HRRZS C,A ;ZERO LEFT HALF OF A, ALSO SAVE IN C SETZ B, LSHC A,-SEGLOG ;GET PAGE NUMBER OF ITEM (OTHER BITS GO INTO B) SKIPL A,GCST(A) ;CHECK GCST ENTRY FOR THAT PAGE JRST GCMKND ;NOT MARKABLE - IGNORE IT TLNE A,GCBFOO ;MAYBE IT'S A VALUE CELL OR SYMBOL OR SAR JRST GCMRK3 ;IF SO HANDLE IT SPECIALLY LSHC A,SEGLOG-5 ;THIS GETS ADDRESS OF BIT WORD FOR THIS ITEM ROT B,5 ;B TELLS US WHICH BIT (40/WD) MOVE AR1,(A) ;GET WORD OF MARK BITS TDZN AR1,GCBT(B) ;CLEAR THE ONE PARTICULAR BIT JRST GCMKND ;QUIT IF ITEM ALREADY MARKED MOVEM AR1,(A) ;ELSE SAVE BACK WORD OF BITS JUMPGE A,GCMKND .SEE GCBCDR ;JUMP UNLESS MUST MARK THROUGH (REMEMBER THE LSHC) HRR A,(C) ;GET CDR OF ITEM TLNN A,GCBCAR_ ;MAYBE WE ALSO WANT TO MARK THE CAR JRST GCMRK1 ;NO - GO MARK CDR PUSH P,A ;YES - SAVE CDR ON STACK HLR A,(C) ;GET CAR OF ITEM AND GO MARK IT IFE HNKLOG, JRST GCMRK1 IFN HNKLOG,[ TLNN A,GCBHNK_ JRST GCMRK1 ;ORDINARY LIST CELL PUSH P,T ;FOR HUNK, SAVE T AND AR2A SO HRLM AR2A,(P) ; CAN CALL GCMARK RECURSIVELY MOVEI A,(C) LSH A,-SEGLOG HRRZ A,ST(A) ;GET TYPEP OF HUNK 2DIF [HRL C,(A)]GCHNLN,QHUNK0 ;C NOW HAS AOBJN POINTER MOVEI AR2A,(P) ;SET UP AR2A FOR RECURSIVE GCMARK GCMRK2: MOVEM C,-1(P) ;SAVE AOBJN POINTER IN SLOT PUSHED FOR CDR HLRZ A,(C) JUMPE A,GCMK2A JSP T,GCMRK1 ;MARK ODD HUNK SLOT MOVE C,-1(P) GCMK2A: HRRZ A,(C) JUMPE A,GCMK2B JSP T,GCMRK1 ;MARK EVEN HUNK SLOT MOVE C,-1(P) GCMK2B: AOBJN C,GCMRK2 POP P,T ;RESTORE T AND AR2A HLRZ AR2A,T SUB P,R70+1 ;FLUSH AOBJN POINTER JRST GCMKND GCHNLN: -1 REPEAT HNKLOG, -<2_.RPCNT> ;LH'S FOR AOBJN POINTERS ] ;END OF IFN HNKLOG COMMENT | ONE OF THESE DAYS I'LL DEBUG THE MICROCODE FOR THIS - GLS IFN ITS,[ IFE SEGLOG-11,[ IFLE HNKLOG-5,[ ;;; MARK ROUTINE FOR USE WITH KL-10 MICROCODE LSPGCM=:070000,, LSPGCS=:071000,, KLGCVC: SKIPA A,(A) PUSH P,B KLGCM1: LSPGCM A,KLGCM2 KLGCND: CAIN AR2A,(P) JRST (T) POP P,A JRST KLGCM1 KLGCM2: JRST KLGCSY JRST KLGCVC JRST KLGCSA REPEAT HNKLOG, JRST CONC KLGH,\.RPCNT+1 REPEAT 8-.+KLGCM2, .VALUE KLGCSY: HLRZ AR1,(A) TROE AR1,1 JRST KLGCND HRLM AR1,(A) PUSH P,(A) PUSH P,(AR1) HRRZ A,@-1(AR1) JRST KLGCM1 KLGCSA: MOVSI AR1,TTS IORM AR1,TTSAR(A) JRST KLGCND IFN HNKLOG,[ ZZZ==<1_HNKLOG>-1 REPEAT HNKLOG,[ CONC KLGH,\HNKLOG-.RPCNT,: REPEAT 1_,[ PUSH P,ZZZ(A) HLRZ B,(P) PUSH P,B ZZZ==ZZZ-1 ] ;END OF REPEAT 1_ ] ;END OF REPEAT HNKLOG IFN ZZZ, WARN [YOU LOSE] PUSH P,(A) HLRZ A,(A) JRST KLGCM1 ] ;END OF IFN HNKLOG KLGCSW: MOVNI T,3+BIGNUM ;SWEEP KLGS1: SETZB C,AR1 ;ZERO FREELIST AND COUNT SKIPN TT,FSSGLK+3+BIGNUM(T) JRST KLGS1D KLGS1A: MOVE B,GCST(TT) LSH B,SEGLOG-5 TLZ B,-1 MOVEI A,(TT) LSH A,SEGLOG HRLI A,-SEGSIZ LSPGCS A,1 LDB TT,[SEGBYT,,GCST(TT)] JUMPN TT,KLGS1A KLGS1D: MOVEM C,FFS+3+BIGNUM(T) HRRM AR1,NFFS+3+BIGNUM(T) AOJL T,KLGS1 JRST GCSW4A ]]] ;END OF IFLE HNKLOG-5, IFE SEGLOG-11, IFN ITS | ;END OF COMMENT GSGEN: SKIPN AR2A,GCMKL ;GENERATE TAILS OF GCMKL AND APPLY POPJ P, ;FUN IN AR1 TO THEM PUSH P,AR1 MOVEI AR1,GCMKL JRST GGEN1 RTSPC2: JUMPE A,GGEN2 RTSP2A: ADD D,TT GGEN2: HRRZ AR2A,(AR2A) ;GENERAL LOOP FOR GSGEN MOVEI AR1,(AR2A) HRRZ AR2A,(AR2A) GGEN1: JUMPE AR2A,POP1J ;TAIL OF GCMKL IN AR2A, HRRZ A,(AR2A) ;SPACE OCCUPIED IN TT, HLRZ A,(A) ;ALIVEP IN A MOVE TT,(A) HLRZ A,(AR2A) HLRZ A,ASAR(A) JRST @(P) ;ROUTINE WILL RETURN TO GGEN2 GFSPC: PUSH FXP,AR1 PUSHJ P,CNLAC ;COUNT NUMBER OF LIVING ARRAY CELLS POP FXP,AR1 ADD D,@VBPORG ;NOW HAS TOTAL AMOUNT FREE IN BPS [COUNTING DEAD BLOCKS] ADD D,GAMNT ;NOW DIMINISHED BY REQUESTED AMOUNT CAMG D,BPSH JRST GRELAR ;IF ENOUGH SPACE, THEN RELOCATE JRST (R) IFN PAGING,[ GTSP5A: SETZB A,TT ;GIVE OUT NIL AND 0 IF FAIL JUMPLE AR1,CZECHI PUSHJ P,BPSGC JSP R,GFSPC SETZ AR1, JRST GTSP1B ] ;END OF IFN PAGING BPSGC: PUSH FXP,NOQUIT ;SAVE CURRENT STATE OF FLAG HLLZS NOQUIT ;FORCE OFF RIGHT HALFWORD PUSH P,[444444,,BPSGX] ;MAGIC NUMBER,,RETURN ADR JRST AGC BPSGX: POP FXP,NOQUIT ;RESTORE OLD SETTING OF FLAGS POPJ P, ;;; SOME ROUTINES FOR USE WITH GSGEN GCP8K: HLRZ A,(D) JSP T,GCMARK GCP8J: HRRZ D,(D) ;MARK ATOMS ON OBLIST GCP8I: JUMPE D,GCP8A ;WHICH HAVE NON-TRIVIAL MOVE A,D ;P-LIST STRUCTURE. JSP T,TWAP JRST GCP8J JRST GCP8K JRST GCP8J GCP8G: JUMPE D,GCP8A ;REMOVE T.W.A.'S FROM MOVE A,D ;BUCKETS OF OBLIST. JSP T,TWAP JRST GCP8B JRST GCP8B HRRZ D,(D) TLNE R,400000 ;BUCKET COMES FROM LH OF WORD IN OBARRAY HRLM D,(F) ;IF AT THIS POINT R < 0 TLNN R,400000 HRRM D,(F) JSP T,GCP8L JRST GCP8G GCP8C: HRRZ D,(D) GCP8B: HRRZ A,(D) GCP8D: JUMPE A,GCP8A JSP T,TWAP JRST GCP8C JRST GCP8C HRRZ A,(D) HRRZ A,(A) HRRM A,(D) JSP T,GCP8L JRST GCP8B GCP8H: MOVE A,D ;MARK OBLIST BUCKET JSP T,GCMARK JRST GCP8A GCP8L: JUMPE TT,(T) ;IF SCO REMOB'D, THEN REMOVE FROM SCO TABLE HRRZ A,(TT) JUMPN A,(T) HLRZ A,(TT) MOVE B,(A) ;MUST NOT BE INTERRUPTIBLE HERE MOVEI A,0 LSHC A,7 JUMPN B,(T) HRRZ TT,VOBARRAY HRRZ TT,TTSAR(TT) ADDI TT,/2 ROT A,-1 ADD TT,A JUMPL TT,GCP8L5 HRRZS (TT) JRST (T) GCP8L5: HLLZS (TT) JRST (T) TWAP: HLRZ A,(A) JUMPE A,(T) ;NIL IS ALREADY MARKED HLRZ TT,(A) TRZE TT,1 JRST (T) ;NO SKIP IF ALREADY MARKED MOVE B,SYMVC(TT) MOVE TT,SYMARGS(TT) TLNN B,SY.CCN\SY.PUR ;SKIP 1 IF SYMBOL HAS SOME NON-TRIVIAL TLZE TT,-1 ;PROPERTIES: ARGS OR COMPILED CODE REFERENCE JRST 1(T) HRRZ B,(B) HRRZ A,(A) CAIN B,QUNBOUND JUMPE A,2(T) ;SKIP 2 IF TRULY WORTHLESS SYMBOL, ; I.E., UNBOUND AND NO PROPERITES JRST 1(T) ;SKIP 1 IF MEANINGFUL PROPERTIES OR VALUE ;;; PRINT MESSAGE OF FORM "NNN[MM%] " FOR GC STATISTICS OUTPUT STGPNT: PUSH FXP,F ;NEED TO SAVE F (IN CASE OF IFORCE) PUSH FXP,T ;RECLAIMED AMNT IN T, TOTAL FOR SPACE IN TT IMULI T,100. IDIVM T,TT EXCH TT,(FXP) HRRZ AR1,VMSGFILES TLO AR1,200000 MOVEI R,$TYO IFE USELESS, MOVE C,@VBASE ;BASE HAD DAMNED WELL BETTER BE A FIXNUM IFN USELESS,[ HRRZ C,VBASE CAIE C,QROMAN SKIPA C,(C) PUSHJ P,PROMAN ;SKIPS ] ;END OF IFN USELESS PUSHJ P,PRINI2 STRT 17,[SIXBIT \[!\] ;BEWARE THESE BRACKETS!!!!! POP FXP,TT IFE USELESS, MOVEI C,10. IFN USELESS,[ HRRZ C,VBASE CAIE C,QROMAN SKIPA C,[10.] PUSHJ P,PROMAN ] ;END OF IFN USELESS PUSHJ P,PRINI3 ;EFFECTIVELY, PRINI2 WITH *NOPOINT=T STRT 17,[SIXBIT \%] !\] ;BEWARE THESE BRACKETS!!!!! POP FXP,F POPJ P, ;;; VERY IMPORTANT TABLE OF WORDS WITH SINGLE BITS!!! USED FOR MARKING!!! GCBT: REPEAT 36., SETZ_-.RPCNT IFN PAGING,[ SUBTTL RETURN CORE TO TIMESHARING SYSTEM ;;; HAIRY ROUTINE TO DECIDE WHETHER TO RETURN SOME BPS TO THE SYSTEM. ;;; MAY ONLY BE CALLED WHEN NOQUIT SPECIFIES NO INTERRUPTS. RETSP: 10$ POPJ P, ;NOOP ON D10'S RUNNING PAGING LISP IFE D10,[ MOVEI TT,4 ;GTSPC1 IS ALLOWED TO GRAB 4 PAGES MOVEM TT,ARPGCT ; BEFORE INVOKING GC FOR LACK OF CORE PUSHJ P,CNLAC ;COUNT NUMBER OF LIVING ARRAY CELLS MOVE TT,BPSH LSH TT,-PAGLOG ;CURRENT HIGHEST CORE BLOCK IN BPS MOVE R,@VBPORG ADDI R,1(D) LSH R,-PAGLOG ;CORE NEEDED IF ARRAYS WERE PACKED CAML R,TT POPJ P, LSH R,PAGLOG ADDI R,PAGSIZ-1 HRLM R,RTSP1 ;NEW BPSH SUB R,D HRRM R,RTSP3 ;NEW BPEND JUMPE D,RTSP5 HRLM D,RTSP3 ;NUMBER OF CELLS TO MOVE PUSHJ P,GRELAR ;GRELAR LEAVES BPEND-AFTER-RELOCATION IN TT HRL AR1,TT HRR AR1,RTSP3 ;BLOCK PTR SUBI TT,(AR1) JUMPLE TT,RTSP2 MOVNI TT,1(TT) HRRM TT,RTSP1 ADD AR1,R70+1 HLRZ C,RTSP3 ADD C,RTSP3 BLT AR1,(C) MOVEI AR1,RTSPC1 PUSHJ P,GSGEN ;DO PATCH-UP ON ARRAY PARAMETERS JSP T,RSXST ;???? RTSP2: HLRZ TT,RTSP1 MOVE R,TT EXCH R,BPSH HRRZ D,RTSP3 MOVEM D,@VBPEND LSH R,-PAGLOG ;OLD CORE HIGHEST LSH TT,-PAGLOG ;NEW CORE HIGHEST MOVEI F,1(TT) ;MAKE UP A POINTER INTO THE PURTBL ROT F,-4 ADDI F,(F) ROT F,-1 TLC F,770000 ADD F,[450200,,PURTBL] IT$ SUBM TT,R ;FOR ITS, MINUS THE NUMBER OF PAGES TO HACK 20$ SUBI R,(TT) ;FOR D20, THE POSITIVE NUMBER OF PAGES TO HACK AOS D,TT IFN ITS,[ HRLI TT,(R) ;-,, .CALL RTSP9 ;FLUSH THE PAGES .LOSE 1000 ] ;END OF IFN ITS IFN D20,[ SETO 1, ;-1 MEANS DELETE PAGES MOVSI 2,.FHSLF ;FROM SELF HRRI 2,(TT) ;INITIAL PAGE NUMBER MOVEI 3,(R) ;NUMBER OF PAGES TLO 3,PM%CNT ;SET ITERATION BIT PMAP ] ;END OF IFN D20 LSH D,-SEGLOG+PAGLOG MOVE T,[$NXM,,QRANDOM] ;STANDARD ST ENTRY FOR A FLUSHED PAGE RTSP7: TLNN F,730000 TLZ F,770000 IDPB NIL,F ;UPDATE PURTBL ENTRY FOR ONE PAGE REPEAT SGS%PG, MOVEM T,ST+.RPCNT(D) ;UPDATE ST ENTRIES ADDI D,SGS%PG IT$ AOJL R,RTSP7 20$ SOJG R,RTSP7 POPJ P, IFN ITS,[ RTSP9: SETZ SIXBIT \CORBLK\ ;HACK PAGE MAP 1000,,0 ;DELETE PAGES 1000,,%JSELF ;FROM CURRENT JOB 400000,,TT ;AOBJN POINTER: -,, ] ;END OF IFN ITS RTSP5: SETZM GCMKL ;NO ARRAYS ALIVE MOVE TT,R PUSHJ P,BPNDST ;SETQ UP BPEND JRST RTSP2 RTSPC1: JUMPE A,GGEN2 HRRE B,RTSP1 ;- JSP AR1,GT3D JRST GGEN2 ] ;END IFE D10 ] ;END OF IFN PAGING SUBTTL GET SPACE FROM TIMESHARING SYSTEM GTSPC1: HLLOS NOQUIT JSP R,GFSPC ;SEE IF FREE SPACE ABOVE BPEND WILL ADD ENOUGH IFN PAGING,[ SKIPLE AR1,ARPGCT JRST GTSP1B ] ;END OF IFN PAGING PUSHJ P,BPSGC ;WHEN COMPACTIFIED AND RELOCATED JSP R,GFSPC ;IF NOT, GC AND TRY AGAIN GTSP1B: IFE PAGING,[ SETZB A,TT ;GIVE OUT NIL AND 0 IF WE FAIL JRST CZECHI ] ;END OF IFE PAGING IFN PAGING,[ CAML D,HINXM JRST GTSP5A MOVEI T,(D) TRO T,PAGSIZ-1 MOVE R,BPSH LSH D,-PAGLOG LSH R,-PAGLOG SUBM R,D ;NEGATIVE OF NUMBER OF PAGES TO GET ADDM F,ARPGCT MOVEI F,1(R) ;SET UP BYTE POINTER INTO PURTBL ROT F,-4 ADDI F,(F) ROT F,-1 TLC F,770000 ADD F,[450200,,PURTBL] MOVEI TT,1(R) LSH TT,-SEGLOG+PAGLOG HLRZ AR1,(P) ;BEWARE! LH OF CALLING PDL SLOT = -1 TRNN AR1,1 ; MEANS THE GETSP FUNCTION IS CALLING TROA AR1,3 MOVEI AR1,1 IFN ITS,[ HRLI R,(D) HRRI R,1(R) .CALL GTSPC8 .LOSE 1000 ] ;END OF IFN ITS IFN D20,[ PUSH P,D ;SAVE NEGATIVE COUNT PUSH P,R ;AND SAVE CURRENT PAGE NUMBER GTSPC8: AOS R,(P) ;GET NEXT PAGE NUMBER LSH R,PAGLOG ;TURN INTO POINTER TO PAGE SETMM (R) ;CREATE THE PAGE MOVSI 1,.FHSLF ;OUR PROCESS HRR 1,(P) ;CURRENT PAGE NUMBER MOVSI 2,(PA%RD\PA%WT\PA%EX) ;READ, WRITE, EXECUTE SPACS ;SET THEPAGE ACCESS AOJL D,GTSPC8 POP P,R POP P,D ] ;END OF IFN D20 MOVE A,[$XM,,QRANDOM] GTSPC2: TLNN F,730000 TLZ F,770000 IDPB AR1,F ;UPDATE PURTBL ENTRY REPEAT SGS%PG, MOVEM A,ST+.RPCNT(TT) ;UPDATE ST ENTRIES ADDI TT,SGS%PG AOJL D,GTSPC2 MOVEM T,BPSH ;FALLS INTO GRELAR ] ;END OF IFN PAGING GRELAR: HLLOS NOQUIT ;MOBY DELAYED QUIT FEATURE. HRRZ A,BPSH ;LEAVE BPEND-AFTER-RELOCATION AS RESULT MOVEM A,GSBPN ;TEMPORARY BPEND MOVEI AR1,GTSPC3 PUSHJ P,GSGEN ;RELOCATE ARRAYS JSP T,RSXST GREL1: MOVE TT,GSBPN PUSHJ P,BPNDST MOVE TT,(A) CZECHI: HLLZS NOQUIT JRST CHECKI ;CHECK FOR ^G THEN POPJ P, IFN ITS,[ GTSPC8: SETZ SIXBIT \CORBLK\ ;HACK PAGE MAP 1000,,%CBNDR+%CBNDW ;NEED READ AND WRITE ACCESS 1000,,%JSELF ;FOR MYSELF ,,R ;AOBJN POINTER: -,, 401000,,%JSNEW ;WANT FRESH PAGES ] ;END OF IFN ITS SUBTTL ARRAY RELOCATOR CNLAC: MOVEI D,0 ;COUNT NUMBER OF LIVING ARRAY CELLS, IN D MOVEI AR1,RTSPC2 JRST GSGEN BPNDST: JSP T,FIX1A ;STORE NEW VALUE FOR BPEND MOVEM A,VBPEND POPJ P, ;;; COMES HERE FROM GRELAR VIA GSGEN. AR2A HAS TAIL OF GCMKL, TT HAS TOTAL LENGTH OF ARRAY GTSPC3: JUMPE A,GT3G ;RELOCATE AN ARRAY MOVEI AR1,-1(TT) ;LENGTH-1 OF ARRAY IN AR1 HLRZ F,(AR2A) HRRZ A,ASAR(F) SUBI A,1 ;ARRAY AOBJN PTR LOC IN A. MOVE C,GSBPN SUBI C,(AR1) MOVEM C,GSBPN ;LOC NEW BPTR IN C MOVEI B,(C) SUBI B,1(A) ;RELOCATION AMOUNT-1 IN B CAML A,C ;IS ARRAY ALREADY IN PLACE? JRST GT3C ;YES, SO EXIT IFN D10,[ MOVE R,ASAR(F) MOVE F,TTSAR(F) TLNN R,AS.FIL ;IF THE ARRAY IS A FILE OBJECT, JRST GT3H ; IS NOT CLOSED, AND HAS BUFFERS, TLNN F,TTS.CL ; THEN WE MUST LET THE I/O COMPLETE SKIPGE F.MODE(F) .SEE FBT.CM JRST GT3H IFE SAIL,[ TLNN F,TTS.IO ;OUTPUT? JRST GT3Z ;NOPE, JUST WAIT MOVE T,F.CHAN(F) ;GET CHANNEL NUMBER LSH T,27 TLO T,(OUTPUT) ;FLUSH ALL OUTPUT BUFFERS XCT T ] ;END IFE SAIL GT3Z: MOVE F,F.CHAN(F) LSH F,27 IOR F,[WAIT 0,] ;WAIT FOR THE I/O TO SETTLE DOWN XCT F ; SO WE CAN RELOCATE THE BUFFERS GT3H: ] ;END OF IFN D10 SUBI C,(AR1) CAMGE A,C ;BEWARE: C COULD GO NEGATIVE! JRST GT3A ;GOOD, EASY BLT ADDI C,(AR1) ADDI AR1,1(A) ;FIRST DESTINATION LOC GT3B: HRRZI C,(AR1) SUBI AR1,1(B) ;CONSTRUCT SOURCE ADDRESS HRLI C,(AR1) HRRZI T,(C) ADDI T,(B) BLT C,(T) ;SERIES OF SMALL BLTS CAMLE AR1,GSBPN JRST GT3B ADDI AR1,(B) SUB AR1,GSBPN MOVE A,GSBPN SUBI A,1(B) GT3A: MOVE C,GSBPN ADDI AR1,(C) HRL C,A BLT C,(AR1) ;FINAL (OR ONLY) BLT JSP AR1,GT3D GT3C: SOS GSBPN JRST GGEN2 GT3D: ADDI B,1 HLRZ A,(AR2A) ADDM B,ASAR(A) ;UPDATE ARRAY POINTERS BY OFFSET IN B ADDM B,TTSAR(A) MOVE C,ASAR(A) ADDM B,-1(C) ;UPDATE AOBJN PTR BEFORE ARRAY HEADER HRR C,TTSAR(A) ;FOR A BUFFERED FILE OBJECT, WE MUST TLNE C,AS.FIL ; RELOCATE CERTAIN ADDRESSES IN THE ARRAY DATA SKIPGE F.MODE(C) .SEE FBT.CM JRST (AR1) MOVE C,TTSAR(A) IFN ITS+D20,[ ADDM B,FB.IBP(C) ADDM B,FB.BP(C) JRST (AR1) ] ;END OF ITS+D20 IFN D10,[ TLNE C,TTS.CL ;DON'T HACK WITH CLOSED FILE OBJECTS JRST (AR1) MOVE F,FB.HED(C) ADDM B,(F) ;UPDATE CURRENT BUFFER ADDRESS ADDM B,1(F) ;UPDATE BYTE POINTER HRRZ F,(F) MOVE R,F GT3D2: ADDM B,(R) ;UPDATE BUFFER RING POINTERS HRRZ R,(R) CAIE R,(F) ;DONE WHEN WE HAVE GONE AROUND THE RING JRST GT3D2 IFN SAIL,[ MOVE R,F.CHAN(C) ;GET CHANNEL NUMBER LSH R,27 HRR R,FB.HED(C) ;POINTER TO BUFFER HEADER HRR R,(R) ;GET CURRENT ADDR OF BUFFER TLNN C,TTS.IO ;DO APPROPRIATE UUO TO MOVE BUFFER TLOA R,(INPUT) TLO R,(OUTPUT) XCT R JRST (AR1) ] ;END OF IFN SAIL IFE SAIL,[ TLNN C,TTS.IO JRST GT3D4 MOVE R,F.CHAN(C) ;GET CHANNEL NUMBER LSH R,27 ;FOR OUTPUT BUFFERS HRR R,FB.HED(C) ;GET CURRENT ADR OF BUFFER HRR R,(R) TLO R,(OUTPUT) ;DO APPROPRIATE UUO TO MOVE BUFFER XCT R JRST (AR1) GT3D4: MOVSI R,TTS.BM IORM R,TTSAR(A) JRST (AR1) ] ;END OF IFE SAIL ] ;END OF IFN D10 GT3G: HRRZ AR2A,(AR2A) HRRZ AR2A,(AR2A) HRRM AR2A,(AR1) ;CUT OUT DEAD BLOCK JRST GGEN1 PGTOP GC,[GARBAGE COLLECTOR] ;;; ********** MEMORY MANAGEMENT, ETC ********** SUBTTL PURCOPY FUNCTION PGBOT BIB PURCOPY: PUSHJ FXP,SAV5M2 PUSH P,[RST5M2] PUSH FXP,CCPOPJ PUSHJ P,SAVX5 PUSH P,[RSTX5] MOVEI TT,(A) ;USES A,B,T,TT LSH TT,-SEGLOG MOVE TT,ST(TT) TLNE TT,PUR POPJ P, 2DIF JRST (TT),PCOPY9,QLIST .SEE STDISP PCOPY9: JRST PCOPLS ;LIST JRST PCOPFX ;FIXNUM JRST PCOPFL ;FLONUM DB$ JRST PCOPDB ;DOUBLE CX$ JRST PCOPCX ;COMPLEX DX$ JRST PCOPDX ;DUPLEX BG$ JRST PCOPBN ;BIGNUM JRST PCOPSY ;SYMBOL HN$ REPEAT HNKLOG+1, JRST PCOPHN ;HUNKS POPJ P, ;RANDOM MOVSI TT,100 ;ARRAY IFN .-PCOPY9-NTYPES, WARN [WRONG LENGTH TABLE] IORM TT,(A) ;SET "COMPILED CODE NEEDS ME" BIT POPJ P, PCOPLS: HLRZ B,(A) ;PURCOPY A LIST ALREADY PUSH P,B HRRZ A,(A) SKIPE A ;NEVER PURCOPY NIL PUSHJ P,PURCOPY EXCH A,(P) SKIPE A ;NEVER PURCOPY NIL PUSHJ P,PURCOPY POP P,B PCONS: AOSL TT,NPFFS ;PURE FS CONSER SPECPRO INTPPC PUSHJ P,GTNPSG ;NOTE: CLOBBERS TT ADD TT,EPFFS NOPRO HRLM A,(TT) HRRM B,(TT) MOVEI A,(TT) POPJ P, PCOPFX: MOVE TT,(A) PFXCONS: CAIGE TT,XHINUM ;PURE FIXNUM CONSER CAMGE TT,[-XLONUM] JRST PFXC1 MOVEI A,IN0(TT) POPJ P, ;NOTE: EXITS WITH POPJ P,!!! PFXC1: AOSL A,NPFFX SPECPRO INTPPC PUSHJ P,GTNPSG ADD A,EPFFX NOPRO PFXC3: MOVEM TT,(A) POPJ P, PCOPFL: MOVE TT,(A) PFLCONS: AOSL A,NPFFL ;PURE FLONUM CONSER SPECPRO INTPPC PUSHJ P,GTNPSG ADD A,EPFFL NOPRO JRST PFXC3 ;ALSO EXITS WITH POPJ P,!!! IFN CXFLAG,[ PCOPCX: KA MOVE D,1(A) KA MOVE TT,(A) KIKL DMOVE TT,(A) PCXCONS: AOSL A,NPFFC SPECPRO INTPPC PUSHJ P,GTNPSG XCTPRO MOVEI T,1(A) MOVEM T,NPFFC ADD A,EPFFC NOPRO DB% JRST PDBC3 ;WILL DROP IN IF NO DOUBLES ] ;END OF IFN CXFLAG IFN DBFLAG,[ PCOPDB: KA MOVE D,1(A) KA MOVE TT,(A) KIKL DMOVE TT,(A) PDBCONS: AOSL A,NPFFD SPECPRO INTPPC PUSHJ P,GTNPSG XCTPRO MOVEI T,1(A) MOVEM T,NPFFD ADD A,EPFFD NOPRO ] ;END OF IFN DBFLAG IFN DBFLAG+CXFLAG,[ PDBC3: KA MOVEM D,1(A) KA JRST PFXC3 KIKL DMOVEM TT,(A) KIKL POPJ P, ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ PCOPDX: KA REPEAT 4, MOVE TT+<2#.RPCNT>,.RPCNT KIKL DMOVE R,(A) KIKL DMOVE TT,2(A) PDXCONS: AOSL A,NPFFZ SPECPRO INTPPC PUSHJ P,GTNPSG XCTPRO MOVEI T,3(A) MOVEM T,NPFFZ ADD A,EPFFZ NOPRO KA REPEAT 4, MOVEM TT+<2#.RPCNT>,.RPCNT KIKL DMOVEM R,(A) KIKL DMOVEM TT,2(A) POPJ P, ] ;END OF IFN DBFLAG IFN BIGNUM,[ PCOPBN: PUSH P,(A) HRRZ A,(A) PUSHJ P,PURCOPY HLL A,(P) SUB P,R70+1 PBNCONS: AOSL TT,NPFFB ;PURE BIGNUM CONSER SPECPRO INTPPC PUSHJ P,GTNPSG ADD TT,EPFFB NOPRO MOVEM A,(TT) MOVEI A,(TT) POPJ P, ] ;END OF IFN BIGNUM PCOPSY: PUSH P,A ;SAVE POINTER TO SYMBOL HLRZ B,(A) ;FETCH POINTER TO SYMBOL BLOCK MOVE TT,SYMVC(B) TLNE TT,SY.PUR ;IF ALREADY PURE IGNORE COMPLETELY JRST PCOPS1 PUSH P,B ;SAVE SYMVC ADR HRRZ A,SYMPNAME(B) PUSHJ P,PURCOPY ;PURCOPY THE PNAME PUSHJ P,PSYCONS ;GET A PURE SY2 BLOCK POP P,B ;RESTORE SYMVC ADR HLRZ A,(A) ;GET POINTER TO PURE SY2 HRRZ TT,SYMVC(B) ;GET THE VALUE CELL HRRM TT,SYMVC(A) ;COPY INTO NEW PURE SY2 HLLZ TT,SYMARGS(B) ;ALSO COPY THE ARGS PROPERTY HLLM TT,SYMARGS(A) XCTPRO HLRZ B,@(P) ;GET POINTER TO OLD SY2 EXCH B,FFY2 ;THIS IS NEW HEAD OF FREELIST, GET OLD HEAD MOVEM B,@FFY2 ;PLACE CHAIN IN NEWLY FREED CELL NOPRO HRLM A,@(P) ;STORE POINTER TO NEW SY2 BLOCK PCOPS1: LOCKI HRRZ A,(P) ;GET POINTER TO SYMBOL PUSHJ P,SYMHSH ;GET HASH VALUE IDIVI T,OBTSIZ ;MAKE POINTER INTO OBARRAY PUSH FXP,TT MOVEI A,(FXP) MOVE T,VOBARRAY PUSHJ P,@ASAR(T) ;BUCKET ADR MOVEI B,(A) HRRZ A,(P) PUSHJ P,MEMQ1 ;FIND ACTUAL ATOM POP FXP,D JUMPN A,PCOPS3 ;IF IN OBARRAY NO NEED TO GCPROTECT MOVEI T,1 ;GCPROTECT HRRZ A,(P) PUSHJ P,.GCPRO PCOPS3: UNLOCKI ;CLEANUP AND GO HOME JRST POPAJ IFN HNKLOG,[ PCOPHN: SKIPN VHUNKP ;TREAT HUNKS AS LISTS IF HUNKP IS NIL JRST PCOPLS PUSH P,A PUSH FXP,TT PUSHJ P,USRHNP ;Is this a user's extended object? POP FXP,TT JUMPE T,PCOPH5 PUSH P,[QPURCOPY] MOVNI T,2 XCT SENDI PCOPH5: POP P,A PCOPH2: 2DIF [HRRZ B,(TT)]GCWORN,QLIST PUSH P,B .SEE INTXCT ;CAN'T USE FXP 2DIF [AOSL B,(TT)]NPFFS,QLIST ;THIS WORD SERVES AS ARG TO GTNPSG SPECPRO INTPPC PUSHJ P,GTNPSG XCTPRO MOVE D,B ADD D,(P) SOS D ;SINCE ALREADY AOS'ED ONCE 2DIF [MOVEM D,(TT)]NPFFS,QLIST NOPRO 2DIF [ADD B,(TT)]EPFFS,QLIST ;B NOW HAS ADDRESS OF FRESH PURE HUNK PUSH P,A PUSH P,B MOVE D,-2(P) PCOPH3: ADD D,-1(P) ;WE SCAN THE OLD HUNK FROM THE END BACKWARDS HLRZ B,-1(D) ;GOBBLE A CAR AND A CDR HRRZ A,-1(D) PUSH P,B PUSHJ P,PURCOPY ;PURCOPY THE CDR EXCH A,(P) PUSHJ P,PURCOPY ;PURCOPY THE CAR HRLM A,(P) MOVE D,-1(P) ;CALCULATE PLACE IN NEW HUNK ADD D,-3(P) POP P,-1(D) ;POP COPIED CAR/CDR PAIR INTO PURE HUNK SOSE D,-2(P) JRST PCOPH3 POP P,A ;RETURN NEW HUNK SUB P,R70+2 POPJ P, ] ;END OF IFN HNKLOG IFN PAGING,[ SUBTTL GETCOR ;;; THIS ROUTINE IS SPECIFICALLY FOR PEOPLE WHO HAND-CODE LAP. ;;; IT IS USED TO ALLOCATE A NUMBER OF CONSECUTIVE PAGES ;;; OF MEMORY FOR VARIOUS PURPOSES, E.G. HACKING OF PDP-11'S ;;; OR INFERIOR JOBS OR WHATEVER. ;;; THE NUMBER OF PAGES DESIRED SHOULD BE IN TT; THE LOW ADDRESS ;;; OF THE PAGES IS RETURNED IN TT, OR ZERO FOR FAILURE. ;;; THIS ROUTINE DOES NOT ACTUALLY GET CORE; IT MERELY RESERVES ;;; ADDRESS SPACE. ;;; THERE IS CURRENTLY NO PROVISION FOR RETURNING THE MEMORY GRABBED. GETCOR: HLLOS NOQUIT LSH TT,PAGLOG MOVE T,HINXM SUBI T,(TT) CAMGE T,BPSH JRST GTCOR6 MOVEI F,(TT) ;GETTING F THIS WAY FLUSHES LSH F,-PAGLOG ; RANDOM BITS. (IT'S SAFER.) GTCOR4: PUSHJ P,ALIMPG .VALUE ;HOW CAN WE LOSE HERE? SOJG F,GTCOR4 SKIPA TT,HINXM GTCOR6: TDZA TT,TT ;LOSE, LOSE, LOSE ADDI TT,1 JRST CZECHI LHVB0: WTA [BAD SIZE - LH^>] ;WE CAN'T HANDLE THE NXP TRAP THIS WILL CAUSE DIC MOVEI 1,(D) ;PAGE NUMBER LSH 1,PAGLOG ;MAKE AN ADDRESS SETMM (1) ;CREATE THE PAGE MOVSI 1,.FHSLF ;CHANGE ACCESS FOR OUR PROCESS HRRI 1,(D) ;THE PAGE WE JUST CREATED MOVSI 2,(PA%RD\PA%WT\PA%EX) SPACS MOVEI 1,.FHSLF ;REEANBLE NXP TRAPS MOVE 2,[<1_<35.-.ICNXP>>] AIC MOVE C,PDLSTC ;RESTORE AC'S MOVE B,PDLSTB MOVE A,PDLSTA ] ;END OF IFN D20 MOVEI R,(D) ;CALCULATE PURTBL BYTE POINTER ROT R,-4 ADDI R,(R) ROT R,-1 TLC R,770000 ADD R,[430200,,PURTBL] MOVSS D HRRI D,3 DPB D,R ;UPDATE PURTBL LSH D,-22+PAGLOG-SEGLOG ;HORRIBLE HACKERY TO UPDATE ST ADD D,[-,,ST-1] ; WITHOUT AN EXTRA AC: REPEAT SGS%PG, PUSH D,PDLST9-P(F) ; USE PUSHES! (CAN'T OVERFLOW) JRST @PDLSTH IFN ITS,[ PDLST8: SETZ SIXBIT \CORBLK\ ;HACK PAGE MAP 1000,,%CBNDR+%CBNDW ;GET READ AND WRITE ACCESS 1000,,%JSELF ;FOR MYSELF ,,D ;PAGE NUMBER 401000,,%JSNEW ;GET FRESH PAGE ] ;END OF IFN ITS ;;; IFN PAGING ;;; HAIRY PDL OVERFLOW HANDLER PDLOV: MOVE F,INTPDL MOVEM D,IPSWD2(F) ;SAVE D MOVEM R,IPSWD1(F) ;SAVE R SKIPL INTPDL .VALUE ;I WANT TO SEE THIS! - GLS MOVEI F,P ;ALL RIGHT THEN, LET'S PLAY JUMPGE P,PDLH0A ; TWENTY QUESTIONS - IS IT REGPDL? MOVEI F,SP JUMPGE SP,PDLH0A ;SPECPDL? MOVEI F,FXP JUMPGE FXP,PDLH0A ;FXP? MOVEI F,FLP ;IF NOT FLP, THEN IT'S PRETTY RANDOM JUMPGE FLP,PDLH0A HLRZ R,NOQUIT JUMPN R,PDLH3A LERR [SIXBIT \RANDOM PDL OVERFLOW!\] PDLH0A: HRRZ R,(F) ;FETCH RIGHT HALF OF PDL POINTER MOVEI D,(R) CAML R,OC2-P(F) ;IF WE'RE OVER THE ORIGIN OF THE JRST PDLH5 ; OVERFLOW PDL, THEN ERROR OUT HLRZ R,F ADDI R,11(D) ;HERE IS A HACK TO PAGIFY IORI R,PAGSIZ-1 ; UPWARDS, BUT KEEP WELL AWAY SUBI R,10 ; FROM THE PAGE BOUNDARY CAML R,OC2-P(F) ;IF WE'RE ABOVE THE OVERFLOW PDL, MOVE R,OC2-P(F) ; ONLY INCREASE TO THAT PLACE CAMGE D,ZPDL-P(F) ;SKIP IF WE'RE ABOVE PDLMAX JRST PDLH2 ; PARAMETER FOR THIS PDL TLO F,-1 ;SET FLAG TO INDICATE THIS FACT MOVE D,MORPDL-P(F) ;PUSH UP THE PDLMAX ADD D,ZPDL-P(F) ; "SOME MORE" ANDI D,777760 ;BUT KEEP AWAY FROM PAGE TRNN D,PAGKSM ; BOUNDARY (PICKY, PICKY!) SUBI D,20 MOVEM D,ZPDL-P(F) HRRZ D,(F) JRST PDLH2A PDLH2: TLZE F,-1 JRST PDLH2B CAMLE R,ZPDL-P(F) ;IF OUR GUESS WOULD PUT US OVER PDLH2A: MOVE R,ZPDL-P(F) ; PDLMAX, GO ONLY AS FAR AS THAT PDLH2B: SUBI D,(R) ;CALCULATE NEW LEFT HALF FOR PDL PTR HRLM D,(F) ;CLOBBER INTO PDL PTR HRRZ D,(F) ;FIGURE OUT IF WE NEED TOP GET ADDI R,10 ; MORE CORE FOR ALL THIS ANDI R,PAGMSK EXCH R,D CAIG R,(D) ;SKIP IF WE CROSSED NO PAGE BOUNDARY JSR PDLSTH ;ELSE MUST GET NEW PAGE AND UPDATE ST TLZN F,-1 ;SKIP IF WE WERE ABOVE PDLMAX JRST PDLH3A MOVSI D,QREGPDL-P(F) 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 PDLH3A: 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 ;;; IFN PAGING MORPDL: 400 ;AMOUNTS TO INCREMENT PDLS BY 100 ; WHEN OVERFLOW OCCURS (THIS GIVES LSWS+100 ; LOSER A CHANCE TO SSTATUS PDLMAX, 200 ; AT LEAST) PDLMSG: POVPDL ;REG POVFLP ;FLONUM POVFXP ;FIXNUM POVSPDL ;SPEC PDLST9: $XM,,QRANDOM ;TYPICAL ST ENTRIES FOR PDL PAGES FL+$PDLNM,,QFLONUM FX+$PDLNM,,QFIXNUM $XM,,QRANDOM PDLH5: IORI R,PAGSIZ-1 ;BAD PDL OV - REALLY DESPERATE SUBI D,-2(R) ;GIVE US AS MUCH PDL AS IS LEFT JUMPL D,PDLH6 MOVE P,C2 MOVE FXP,FXC2 SETZM TTYOFF STRT UNRECOV STRT @PDLMSG-P(F) JRST DIE PDLH6: HRLM D,(F) HLRZ R,NOQUIT JUMPN R,GCPDLOV ;FOO! HAPPENED IN GC - BOMB OUT! HRRZ B,PDLMSG-P(F) CAIE B,POVSPDL JRST PDLOV5 ;PDLOV5 HANDLE WILL GET US TO TOP LEVEL MOVEM P,F ;FOR SP, TRY TO POP BINDINGS FIRST HRRZ TT,SPSV ; SO *RSET-TRAP WON'T OVERFLOW MOVE P,[-LFAKP-1,,FAKP] ;SO WE HAVE ENOUGH PDL FOR UBD PUSH P,FXP MOVE FXP,[-LFAKFXP-1,,FAKFXP] PUSHJ P,UBD POP P,FXP MOVE P,F JRST PDLOV5 ;PDLOV5 WILL SET UP PDLS ] ;END OF IFN PAGING SUBTTL PURE SEGMENT CONSER ;;; GRBPSG RETURNS ONE PUREIFIABLE SEGMENT. ADR IN AC T ;;; GTNPSG IS INVOKED AS FOLLOWS: ;;; AOSL A,NPFF% ;SKIP UNLESS NO MORE LEFT ;;; SPECPRO INTPPC ;;; PUSHJ P,GTNPSG ;MUST GET MORE ;;; ADD A,EPFF% ;ELSE JUST FIGURE OUT ABSOLUTE ADDRESS ;;; NOPRO ;;; WHERE % IS SOME APPROPRIATE LETTER (E.G. S, X, L, B). ;;; GTNPSG UPDATES NPFF% AND EPFF% BY LOOKING AT THE AOSL, THEN ;;; RETURNS TO THE AOSL. XCTPRO GRBPSG: HLLOS NOQUIT ;GET NEW PURE SEGMENT NOPRO SAVEFX TT D R SKIPN T,PRSGLK ;SKIP IF ANY SEGMENTS IN PURE SEGMENT FREELIST PUSHJ P,GTNPS3 LDB D,[SEGBYT,,GCST(T)] ;IF SO, CDR THAT FREELIST MOVEM D,PRSGLK MOVE TT,[$XM+PUR,,QRANDOM] MOVEM TT,ST(T) ;SETUP ST TABLE CORRECTLY SETZM GCST(T) ;AND ALSO GCST RSTRFX R D TT JRST CZECHI ;GETS A PURE SEGMENT FOR CONSING PURPOSES XCTPRO GTNPSG: HLLOS NOQUIT ;GET NEW PURE SEGMENT NOPRO REPEAT 2, SOS (P) ;BACK UP RETURN ADDRESS TO PRECEDING INST SAVEFX T TT D R SKIPN T,PRSGLK ;SKIP IF ANY SEGMENTS IN PURE SEGMENT FREELIST PUSHJ P,GTNPS3 LDB D,[SEGBYT,,GCST(T)] ;IF SO, CDR THAT FREELIST MOVEM D,PRSGLK IFE HNKLOG, MOVE D,@(P) ;NOW D POINTS TO NPFF- IFN HNKLOG,[ MOVE D,(P) ;THIS ALLOWS REFERENCE TO NPFF- TO BE INDEXED MOVEI D,@(D) ; BY TT, WHICH MUST BE SAFE TO THIS POINT ] ;END OF IFN HNKLOG 2DIF [SKIPN TT,(D)]GTNPS8,NPFFS .VALUE MOVEM TT,ST(T) SETZM GCST(T) LSH T,SEGLOG ADDI T,SEGSIZ MOVEM T,EPFFS-NPFFS(D) ;UPDATE PARAMETERS FOR NEW PURE SEGMENT MOVNI T,SEGSIZ+1 MOVEM T,(D) MOVEI T,SEGSIZ ADDM T,PFSSIZ-NPFFS(D) ;UPDATE STORAGE SIZE RSTRFX R D TT T JRST CZECHI ;;; TYPICAL ST ENTRIES FOR PURE SEGMENTS GTNPS8: LS+$FS+PUR,,QLIST ;LIST FX+PUR,,QFIXNUM ;FIXNUM FL+PUR,,QFLONUM ;FLONUM DB$ DB+PUR,,QDOUBLE ;DOUBLE CX$ CX+PUR,,QCOMPLEX ;COMPLEX DX$ DX+PUR,,QDUPLEX ;DUPLEX BG$ BN+PUR,,QBIGNUM ;BIGNUM 0 ;NO PURE SYMBOLS HN$ REPEAT HNKLOG+1, LS+HNK+PUR,,QHUNK0+.RPCNT ;HUNKS 0 ;NO PURE SARS IFN .-GTNPS8-NFF, WARN [GTNPS8 WRONG LENGTH TABLE] $XM+PUR,,QRANDOM ;SYMBOL BLOCKS ;CALLED TO GET NEW PAGE OF PURE MEMORY ;RETURNS C(PRSGLK) IN T GTNPS3: PUSH FXP,TT ;GTNPSG REQUIRES TT TO BE SAFE IFN PAGING,[ MOVE T,HINXM ;FIGURE OUT IF ANY ROOM LEFT SUBI T,PAGSIZ CAMGE T,BPSH LERR [SIXBIT \NO SPACE FOR NEW PURE PAGE!\] MOVEM T,HINXM ;UPDATE HINXM MOVEI TT,1(T) ] ;END OF IFN PAGING IFE PAGING,[ MOVE TT,HIXM ADDI TT,PAGSIZ CAMLE TT,MAXNXM LERR [SIXBIT \NO SPACE FOR NEW PURE PAGE!\] MOVEM TT,HIXM ] ;END OF IFE PAGING LSH TT,-SEGLOG ;UPDATE ST AND GCST FOR NEW PAGE MOVE D,[$XM+PUR,,QRANDOM] REPEAT SGS%PG, MOVEM D,ST+.RPCNT(TT) MOVE D,PRSGLK REPEAT SGS%PG,[ SETZM GCST+.RPCNT(TT) DPB D,[SEGBYT,,GCST+.RPCNT(TT)] MOVEI D,.RPCNT(TT) ] ;END OF REPEAT SGS%PG MOVEM D,PRSGLK IFN PAGING,[ MOVEI TT,1(T) ;UPDATE PURTBL ROT TT,-PAGLOG-4 ADDI TT,(TT) ROT TT,-1 TLC TT,770000 ADD TT,[430200,,PURTBL] DPB T,TT ;T HAS 11 IN LOW TWO BITS ; (CAN PURIFY, WITH SOME CARE) IFN ITS,[ MOVEI R,1(T) ;NOT AN AOBJN POINTER, LSH R,-PAGLOG ; SO WE GET ONLY ONE PAGE .CALL GTSPC8 .LOSE 1000 ] ;END OF IFN ITS IFN D20,[ PUSHJ FXP,SAV3 SETMM 1(T) ;CREATE THE PAGE MOVEI 1,1(T) ;THEN GET THE PAGE NUMBER LSH 1,-PAGLOG HRLI 1,.FHSLF MOVSI 2,(PA%RD\PA%WT\PA%EX) SPACS PUSHJ FXP,RST3 ] ;END OF IFN D20 ] ;END OF IFN PAGING IFN *D10,[ HRRZ TT,HIXM CORE TT, HALT ] ;END OF IFN *D10 MOVE T,PRSGLK ;FORCE PRSGLK INTO AC T FOR CALLER POP FXP,TT POPJ P, SUBTTL FREE STORAGE SPACE EXPANSION ;;; THIS PORTION OF THE GARBAGE COLLECTOR DETERMINES WHETHER ;;; WE SHOULD JUST GRAB A NEW SEGMENT OF FREE STORAGE FOR SOME ;;; CONSER, OR DO A FULL-BLOWN GARBAGE COLLECTION. IT IS ;;; CONTROLLED BY PARAMETERS SETTABLE VIA (SSTATUS GCSIZE ...). GCGRAB: MOVN R,D JFFO R,.+1 ;DETERMINE WHICH SPACE WANTED MORE SUBI F,NFF MOVEI AR2A,1 ;MACRAK SEZ: GRAB JUST ONE SKIPN FFY2 SETZ F, JUMPE F,GCGRB1 ; ... SEZ MACRAK MOVE D,SFSSIZ+NFF(F) CAML D,GFSSIZ+NFF(F) ;CAN'T JUST GRAB IF ABOVE SIZE JRST AGC1Q ; SPECIFIED FOR "FREE GRABBIES" MOVE D,GFSSIZ+NFF(F) CAMLE D,XFFS+NFF(F) ;CAN'T GRAB IF IT WOULD PUT JRST AGC1Q ; US ABOVE THE MAXIMUM SIZE GCGRB1: PUSH FXP,AR2A PUSHJ P,GRABWORRY POP FXP,AR1 JUMPGE AR2A,AGC1Q ;GO DO FULL-BLOWN GC AFTER ALL IFN WHL,[ MOVE D,[-3,,GCWHL6] MOVE R,GCWHO TRNE R,1 .SUSET D ] ;END OF IFN WHL JRST GCEND ;;; THESE ROUTINES WORRY ABOUT GETTING A NEW IMPURE FREE STORAGE ;;; SEGMENT. (FOR PURE FREE STORAGE SEGMENTS, SEE GTNPSG.) ;;; GCWORRY MUST DO SPECIAL HACKERY FOR SYMBOL AND SAR SPACES, SINCE THEY ;;; REQUIRE MORE THAN ONE CONSECUTIVE SEGMENT, AND PRINTS OUT PRETTY ;;; MESSAGES IF GCGAG IS NON-NIL. MUST HAVE NOQUIT NON-ZERO. ;;; *THE FOLLOWING COMMENT IS HISTORICAL AND SHOULD BE IGNORED* ;;; MUST HAVE NOQUIT NON-ZERO AND ST/GCST PAGES IMPURE WHEN ENTERING! ;THIS ROUTINE ALLOCATES ONE IMPURE SEGMENT AND MARKS IT AS ; $XM,,QRANDOM IN ST TABLE. POINTER TO SEGMENT RETURNED IN TT ; DESTROYS C, D, AR1, R GRBSEG: SKIPE TT,IMSGLK JRST GRBSG1 ;JUMP IF ANY SEGMENTS AVAILABLE PUSHJ P,ALIMPG ;ELSE MUST GRAB A NEW PAGE POPJ P, ;FAIL IF NO NEW PAGES TO BE HAD GRBSG1: LDB D,[SEGBYT,,GCST(TT)] MOVEM D,IMSGLK ;CDR THE FREE SEGMENT LIST MOVE D,[$XM,,QRANDOM] ;MARK NEW SEGMENT IN ST TABLE MOVEM D,ST(TT) SETZM GCST(TT) ;RESET GCST TABLE ENTRY LSH TT,SEGLOG ;RETURN A POINTER TO THE HEAD OF THE SEGMENT AOS (P) POPJ P, ;THIS ROUTINE IS FOR NORMAL ALLOCATION OF SEGMENTS BY THE GC GCWORRY:SUBI AR2A,(TT) ;ENTRY FOR GARBAGE COLLECTOR ADDI AR2A,SEGSIZ-1 ;FIGURE OUT HOW MANY NEW SEGMENTS WE NEED LSH AR2A,-SEGLOG GRABWORRY: HRRZ AR1,VMSGFILES TLO AR1,200000 JUMPE F,.+2 ;ENTRY FOR GCGRAB SKIPN GCGAGV ;MAYBE WE WANT A PRETTY MESSAGE? SOJA AR2A,GCWOR2 ;IF NOT, DECR AR2A (SEE BELOW) STRT 17,[SIXBIT \^M;ADDING !\] SOJG AR2A,GCWR0A ;AR2A GETS DECR'ED HERE, TOO! STRT 17,[SIXBIT \A!\] ;KEEP THE ENGLISH GOOD JRST GCWR0B GCWR0A: MOVEI R,$TYO MOVEI TT,1(AR2A) PUSH FXP,AR2A IFE USELESS, MOVE C,@VBASE ;BASE DAMN WELL BETTER BE A FIXNUM IFN USELESS,[ HRRZ C,VBASE CAIE C,QROMAN SKIPA C,(C) PUSHJ P,PROMAN ] ;END OF IFN USELESS PUSHJ P,PRINI9 POP FXP,AR2A GCWR0B: STRT 17,[SIXBIT \ NEW !\] STRT 17,@GSTRT9+NFF(F) STRT 17,[SIXBIT \ SEGMENT!\] SKIPE AR2A STRT 17,[SIXBIT \S!\] GCWOR2: SKIPE TT,IMSGLK JRST GCWR2A ;JUMP IF ANY SEGMENTS AVAILABLE PUSHJ P,ALIMPG ;ELSE MUST GRAB A NEW PAGE JRST GCWOR7 GCWR2A: LDB D,[SEGBYT,,GCST(TT)] MOVEM D,IMSGLK ;CDR THE FREE SEGMENT LIST MOVE D,FSSGLK+NFF(F) ;CONS NEW SEGMENT ONTO LIST MOVEM TT,FSSGLK+NFF(F) ; OF SEGMENTS FOR THE HRRZ R,BTBAOB ; PARTICULAR SPACE HLL R,GCWORS+NFF(F) LSH D,22- GCWR2B: TLNE R,$FS+FX+FL+BN+HNK+DB+CX+DX .SEE GCWR2C IORI D,(R) ;MAYBE ALLOCATE A BIT BLOCK FOR IOR D,GCWORG+NFF(F) ; THE NEW SEGMENT FOR USE BY MOVEM D,GCST(TT) ; GC IN MARKING CELLS MOVE D,GCWORS+NFF(F) ;UPDATE ST ENTRY FOR THE MOVEM D,ST(TT) ; NEW SEGMENT MOVE D,FFS+NFF(F) ;ADD CELLS OF SEGMENT TO LSH TT,SEGLOG ; THE FREE STORAGE MOVEM D,(TT) ; LIST FOR THIS SPACE MOVE D,[GCWORX,,1] BLT D,LPROG9 HLL TT,GCWORN+NFF(F) HRR GCWRX1,GCWORN+NFF(F) HRRI GCWRX2,-1(GCWRX1) JRST GCWRX1 GCWR2C: HRRZM TT,FFS+NFF(F) TLNN R,$FS+FX+FL+BN+HNK+DB+CX+DX .SEE GCWR2B JRST GCWR4Q HRRZ TT,BTBAOB ;DECIDE WHETHER THIS BIT BLOCK LSH TT,SEGLOG-5 ; LIES IN MAIN BIT BLOCK AREA MOVEI D,-1(TT) CAME D,MAINBITBLT JRST GCWR3A ADDI D,BTBSIZ ;YES - JUST UPDATE MAIN BLT MOVEM D,MAINBITBLT ; POINTER FOR CLEARING JRST GCWR3B ; BIT BLOCKS (SEE GCINBT) GCWR3A: LSH TT,-SEGLOG ;ELSE AOS COUNT OF BIT BLOCKS AOS GCST(TT) ; IN CURRENT BIT BLOCK SEGMENT GCWR3B: MOVE TT,BTBAOB ;AOBJN THE BIT BLOCK AOBJN TT,GCWOR4 ; ALLOCATION POINTER SKIPE TT,IMSGLK ;FOO! OUT OF BIT BLOCKS! JRST GCWR3F PUSHJ P,ALIMPG ;FOO FOO! NEED NEW PAGE! JRST GCWFOO GCWR3F: LDB D,[SEGBYT,,GCST(TT)] MOVEM D,IMSGLK ;CDR LIST OF FREE SEGMENTS MOVE D,[$XM,,QRANDOM] ;UPDATE ST AND GCST FOR MOVEM D,ST(TT) ; NEW BIT BLOCK SEGMENT MOVEI D,(TT) ;GCST ENTRY IS USED TO LSH D,5 ; INDICATE HOW MANY MOVEM D,GCST(TT) ; BLOCKS ARE IN USE MOVE D,BTSGLK ;CONS NEW SEGMENT ONTO LIST DPB D,[SEGBYT,,GCST(TT)] ; OF BIT BLOCK SEGMENTS MOVEM TT,BTSGLK LSH TT,5 ;CALCULATE NEW BIT BLOCK HRLI TT,-SEGSIZ/BTBSIZ ; ALLOCATION POINTER GCWOR4: MOVEM TT,BTBAOB GCWR4Q: JUMPE F,GCWOR6 MOVEI TT,SEGSIZ ;UPDATE VARIOUS GC PARAMETERS ADDM TT,NFFS+NFF(F) ADDB TT,SFSSIZ+NFF(F) CAMLE TT,XFFS+NFF(F) ;MUST STOP IF OVER MAX SOJA AR2A,.+2 ;KEEP COUNT ACCURATE GCWOR6: SOJGE AR2A,GCWOR2 ;ALSO STOP IF WE GOT ALL WE WANT GCWOR7: JUMPE F,CPOPJ SKIPN GCGAGV ;MAYBE WANT MORE PRETTY MESSAGE POPJ P, SKIPL AR2A STRT 17,[SIXBIT \^M; BUT DIDN'T SUCCEED!\] STRT 17,[SIXBIT \ -- !\] STRT 17,@GSTRT9+NFF(F) STRT 17,[SIXBIT \ SPACE NOW !\] MOVEI R,$TYO PUSH FXP,AR2A HRRZ AR1,VMSGFILES TLO AR1,200000 MOVE TT,SFSSIZ+NFF(F) IFE USELESS, MOVE C,@VBASE IFN USELESS,[ HRRZ C,VBASE CAIE C,QROMAN SKIPA C,(C) PUSHJ P,PROMAN ] ;END OF IFN USELESS PUSHJ P,PRINI9 STRT 17,[SIXBIT \ WORDS!\] POP FXP,AR2A POPJ P, ;;; TYPICAL GCST ENTRIES FOR IMPURE SPACES GCWORG: GCBMRK+GCBCDR+GCBCAR,, ;LIST GCBMRK,, ;FIXNUM GCBMRK,, ;FLONUM DB$ GCBMRK,, ;DOUBLE CX$ GCBMRK,, ;COMPLEX DX$ GCBMRK,, ;DUPLEX BG$ GCBMRK+GCBCDR,, ;BIGNUM GCBMRK+GCBSYM,, ;SYMBOL HN$ REPEAT HNKLOG+1, GCBMRK+GCBCDR+GCBCAR+GCBHNK,, ;HUNKS GCBMRK+GCBSAR,, ;SAR IFN .-GCWORG-NFF, WARN [WRONG LENGTH TABLE] 0 ;SYMBOL BLOCKS ;;; TYPICAL ST ENTRIES FOR IMPURE SPACES GCWORS: LS+$FS,,QLIST ;LISP FX,,QFIXNUM ;FIXNUM FL,,QFLONUM ;FLONUM DB$ DB,,QDOUBLE ;DOUBLE CX$ CX,,QCOMPLEX ;COMPLEX DX$ DX,,QDUPLEX ;DUPLEX BG$ BN,,QBIGNUM ;BIGNUM SY,,QSYMBOL ;SYMBOL HN$ REPEAT HNKLOG+1, LS+HNK,,QHUNK0+.RPCNT ;HUNKS SA+$XM,,QARRAY ;SAR IFN .-GCWORS-NFF, WARN [WRONG LENGTH TABLE] $XM,,QRANDOM ;SYMBOL BLOCKS GCWFOO: STRT [SIXBIT \^M;GLEEP#! OUT OF BIT BLOCKS!\] JRST GCWOR7 GCWORX: ;EXTEND FREELIST THROUGH NEW SEGMENT OFFSET 1-. GCWRX1: HRRZM TT,.(TT) ;OCCUPIES A,B,C,AR1 - MUST SAVE AR2A GCWRX2: ADDI TT,. AOBJN TT,GCWRX1 JRST GCWR2C LPROG9==:.-1 OFFSET 0 .HKILL GCWRX1 GCWRX2 GCWORN: -SEGSIZ+1,,1 ;LIST -SEGSIZ+1,,1 ;FIXNUM -SEGSIZ+1,,1 ;FLONUM DB$ -SEGSIZ/2+1,,2 ;DOUBLE CX$ -SEGSIZ/2+1,,2 ;COMPLEX DX$ -SEGSIZ/2+1,,4 ;DUPLEX BG$ -SEGSIZ+1,,1 ;BIGNUM -SEGSIZ+1,,1 ;SYMBOL HN$ REPEAT HNKLOG+1, -SEGSIZ/<1_.RPCNT>+1,,1_.RPCNT ;HUNKS -SEGSIZ/2+1,,2 ;ARRAY SARS IFN .-GCWORN-NFF, WARN [WRONG LENGTH TABLE] -SEGSIZ/2+1,,2 ;SYMBOL BLOCKS SUBTTL IMPURE PAGE GOBBLER ;;; ALLOCATE AN IMPURE PAGE FREE STORAGE USE ALIMPG: IFN PAGING,[ MOVE TT,HINXM ;MUST SAVE AR2A AND F FOR GCWORRY SUBI TT,PAGSIZ CAMGE TT,BPSH ] ;END OF IFN PAGING IFE PAGING,[ MOVE TT,HIXM ADDI TT,PAGSIZ CAMLE TT,MAXNXM ] ;END OF IFE PAGING POPJ P, ;NO PAGES LEFT - RETURN WITHOUT SKIP IFN PAGING,[ MOVEM TT,HINXM ;ELSE UPDATE HINXM IFN ITS,[ MOVEI R,1(TT) LSH R,-PAGLOG .CALL GTSPC8 .LOSE 1000 ] ;END OF IFN ITS IFN D20,[ SETMM 1(TT) ;CREATE THE PAGE MOVEI 1,1(TT) LSH 1,-PAGLOG HRLI 1,.FHSLF MOVSI 2,(PA%RD\PA%WT\PA%EX) SPACS ] ;END OF IFN D20 MOVEI D,1(TT) ;COMPUTE A MAGIC BYTE POINTER LSH D,-PAGLOG ROT D,-4 ADDI D,(D) ROT D,-1 TLC D,770000 ADD D,[430200,,PURTBL] MOVEI C,1 DPB C,D ;UPDATE THE PURTBL HRRZ R,(P) ;GET THE CALLER'S PC+1 CAIN R,GTCOR4+1 ;DON'T HACK IMSGLK FOR GETCOR JRST POPJ1 ] ;END OF IFN PAGING IFN *D10,[ MOVEM TT,HIXM CORE TT, HALT MOVE TT,HIXM ] ;END OF IFN *D10 LSH TT,-SEGLOG IFN PAGING, ADDI TT,SGS%PG MOVE C,IMSGLK ;UPDATE ST AND GCST, AND ADD MOVE AR1,[$XM,,QRANDOM] ; NEW SEGMENTS TO IMSGLK LIST MOVEI D,SGS%PG ALIMP3: MOVEM AR1,ST(TT) SETZM GCST(TT) DPB C,[SEGBYT,,GCST(TT)] MOVEI C,(TT) SOSE D SOJA TT,ALIMP3 MOVEM TT,IMSGLK ;EXITS WITH LOWEST NEW SEGMENT # IN TT JRST POPJ1 ;WINNING RETURN SKIPS SUBTTL RECLAIM FUNCTION IFN BIGNUM+USELESS,[ RECLAIM: HRRZS A ;SUBR 2 JUMPE A,CPOPJ ;GC A PARTICULAR SEXP LOCKI PUSHJ P,RECL1 MOVEI A,NIL UNLKPOPJ RECL1: SKOTT A,LS+PUR 2DIF JRST (TT),RECL9-1,QLIST .SEE STDISP TLNE TT,HNK+VC+PUR ;DON'T RECLAIM VALUE CELLS!!! (OR HUNKS) POPJ P, ; - ALSO DON'T RECLAIM PURE WORDS PUSH P,A ;SAVE ARG JUMPE B,RECL2 ;B=NIL => RECLAIM ONLY TOP LEVEL OF LIST HLRZ A,(A) ;RECLAIM CAR PUSHJ P,RECL1 RECL2: MOVE T,FFS POP P,FFS EXCH T,@FFS ;RECLAIM ONE CELL MOVEI A,(T) ;AND THEN GO AFTER THE CDR JRST RECL1 RECLFW: JUMPE B,RECL9A ;B=NIL => DON'T RECLAIM FULLWORDS TLNE TT,$PDLNM ;DON'T RECLAIM PDL LOCATIONS!!! POPJ P, 2DIF [MOVE T,(TT)]FFS-QLIST ;RECLAIM NUMBER MOVEM T,(A) 2DIF [MOVEM A,(TT)]FFS-QLIST POPJ P, IFN BIGNUM,[ REBIG: MOVE T,FFB ;RECLAIM BIGNUM HEADER EXCH T,(A) MOVEM A,FFB MOVEI A,(T) ;RECLAIM CDR OF BIGNUM JRST RECL1 ] ;END OF IFN BIGNUM RECL9: JRST RECLFW ;FIXNUM JRST RECLFW ;FLONUM DB$ JRST RECLFW ;DOUBLE CX$ JRST RECLFW ;COMPLEX DX$ JRST RECLFW ;DUPLEX BG$ JRST REBIG ;BIGNUM RECL9A: POPJ P, ;SYMBOL HN$ REPEAT HNKLOG+1, .VALUE ;HUNKS POPJ P, ;RANDOM POPJ P, ;ARRAY IFN .-RECL9-NTYPES+1, WARN [WRONG LENGTH TABLE] ] ;END OF IFN BIGNUM+USELESS IFN PAGING,[ SUBTTL VALUE CELL AND SYMBOL BLOCK HACKERY ;;; ROUTINE TO GET MORE VALUE CELL SPACE. ;;; EXPANDS VALUE CELL SPACE BY GETTING NEXT PAGE IN THE HOLE ;;; LEFT FOR THIS PURPOSE, AND EXTENDING THE VALUE CELL FREELIST. ;;; IF NO PAGES LEFT IN THE HOLE, A LIST CELL IS USED. ;;; MAY CLOBBER ONLY A AND TT. XCTPRO MAKVC3: HLLOS NOQUIT NOPRO SOSL NFVCP JRST MAKVC4 PUSHJ P,CZECHI PUSHJ P,CONS1 SETOM ETVCFLSP JRST MAKVC1 MAKVC4: IFN ITS,[ PUSH FXP,R ;MUST SAVE R MOVE R,EFVCS LSH R,-PAGLOG .CALL GTSPC8 ;GET A NEW PAGE .LOSE 10000 POP FXP,R ] ;END OF IFN ITS IFN D20,[ PUSHJ FXP,SAV3 MOVE 1,EFVCS SETMM (1) ;CREATE THE PAGE LSH 1,-PAGLOG HRLI 1,.FHSLF MOVSI 2,(PA%RD\PA%WT\PA%EX) SPACS PUSHJ FXP,RST3 ] ;END OF IFN D20 MOVE A,EFVCS MOVEM A,FFVC LSH A,-SEGLOG MOVE TT,[LS+VC,,QLIST] REPEAT SGS%PG, MOVEM TT,ST+.RPCNT(A) ;UPDATE SEGMENT TABLE MOVSI TT,GCBMRK+GCBVC REPEAT SGS%PG, MOVEM TT,GCST+.RPCNT(A) ;UPDATE GC SEGMENT TABLE LSH A,-PAGLOG+SEGLOG ;UPDATE PURTBL ROT A,-4 ADDI A,(A) ROT A,-1 TLC A,770000 ADD A,[430200,,PURTBL] MOVEI TT,1 DPB TT,A AOS TT,EFVCS ;EXTEND FREELIST THROUGHOUT NEW PAGE HRLI TT,-PAGSIZ+1 HRRZM TT,-1(TT) AOBJN TT,.-1 HRRZM TT,EFVCS MAKVC8: PUSHJ P,CZECHI JRST MAKVC0 ] ;END OF IFN PAGING ;;; SYMBOL BLOCK COPYING ROUTINE - TRIGGERED BY PURE PAGE TRAP, OR EXPLICIT CHECK ;;; B POINTS TO OLD SYMBOL BLOCK ;;; LEAVES POINTER TO NEW SYMBOL BLOCK IN B ;;; CLOBBERS TT, LEAVES POINTER TO VALUE CELL IN A LDPRG9: TLCA B,LDPARG ;FASLOAD CLOBBERING ARGS PROP ARGCL7: TLC B,ARGCL3 ;ARGS CLOBBERING ARGS PROP HRRZ A,(B) JRST MAKVC6 MAKVC9: TLC B,MAKVCX ;MAKVC CLOBBERING IN VALUE CELL JRST MAKVC6 MAKVC5: PUSH P,SPSV ;MUST PRESERVE SPSV AS WE CAN COME HERE FROM ; WITHIN A BIND AND AGC DOES BINDING ALSO PUSHJ P,AGC POP P,SPSV BAKPRO MAKVC6: SKIPN FFY2 ;COME HERE IF HRRM ABOVE CAUSES JRST MAKVC5 ; A PURE PAGE TRAP - MUST COPY MOVE TT,@FFY2 ; SYMBOL BLOCK FOR THAT SYMBOL XCTPRO EXCH TT,FFY2 NOPRO HRLI A,SY.ONE\SY.CCN\SY.OTC ;ASSUME COMPILED CODE NEEDS IT FOR OTHER ; THEN CALL UUO'S MOVEM A,SYMVC(TT) ; (THINK ABOUT THIS SOME MORE) MOVE A,SYMPNAME(B) MOVEM A,SYMPNAME(TT) HRRZ A,(TT) HRLM TT,@(P) EXCH TT,B HLRZ TT,TT JRST (TT) SUBTTL ALLOC FUNCTION $ALLOC: CAIE A,TRUTH ;SUBR 1 - DYNAMIC ALLOC JRST $ALLC5 SETO F, ;ARG=T => MAKE UP LIST EXCH F,INHIBIT ;CROCKISH LOCKI - DOESN'T MUNG FXP MOVNI R,NFF $ALLC6: PUSH FXP,GFSSIZ+NFF(R) ;SAVE UP VALUABLE DATA PUSH FXP,XFFS+NFF(R) ;LOCKI KEEPS IT CONSISTENT PUSH FXP,MFFS+NFF(R) AOJL R,$ALLC6 IFN PAGING, REPEAT 4, PUSH FXP,XPDL+.RPCNT MOVEM F,INHIBIT ;EQUALLY CROCKISH UNLOCKI PUSHJ P,CHECKI PUSH P,R70 IFN PAGING,[ MOVEI R,4 $ALLC9: POP FXP,TT SUB TT,C2-1(R) TLZ TT,-1 JSP T,FIX1A MOVE B,(P) PUSHJ P,CONS MOVEI B,QREGPDL-1(R) PUSHJ P,XCONS MOVEM A,(P) SOJG R,$ALLC9 ] ;END OF IFN PAGING MOVEI R,NFF $ALLC7: SKIPN SFSSIZ-1(R) JRST $ALLC8 ;SPACE SIZE IS ZERO - IGNORE IT POP FXP,TT PUSHJ P,SSGP2A PUSHJ P,NCONS MOVEI B,(A) POP FXP,TT JSP T,FIX1A PUSHJ P,CONS MOVEI B,(A) POP FXP,TT JSP T,FIX1A PUSHJ P,CONS MOVE B,(P) PUSHJ P,CONS MOVEI B,QLIST-1(R) CAIN B,QRANDOM MOVEI B,QARRAY PUSHJ P,XCONS MOVEM A,(P) JRST $ALLC4 $ALLC8: SUB FXP,R70+3 ;FLUSH GARBAGE $ALLC4: SOJG R,$ALLC7 JRST POPAJ $ALLC0: HRRZ A,(AR2A) $ALLC5: JUMPE A,TRUE ;DECODE LIST OF PAIRS HLRZ B,(A) ;ARG IS LIST OF SAME FORM AS HRRZ AR2A,(A) ; A .LISP. (INIT) COMMENT HLRZ C,(AR2A) CAIL B,QREGPDL CAILE B,QSPECPDL JRST $ALLC3 MOVEI D,1_-1 ;SSPDLMAX PUSHJ P,SSGP3$ JRST $ALLC0 $ALLC3: JSP R,SFRET JRST $ALLC0 JRST $ALLC0 SETZ AR1, MOVEI F,(C) SKOTT C,LS JRST $ALLC2 HRRZ AR1,(C) HLRZ C,(C) HLRZ F,(AR1) SKIPE AR1 SKIPA AR1,(AR1) SKIPA F,C HLRZ AR1,(AR1) $ALLC2: MOVEI D,3_-1 ;SSGCSIZE PUSHJ P,SSGP3$ MOVEI C,(F) MOVEI D,5_-1 ;SSGCMAX PUSHJ P,SSGP3$ MOVEI C,(AR1) MOVEI D,7_-1 ;SSGCMIN PUSHJ P,SSGP3$ JRST $ALLC0 PGTOP BIB,[MEMORY MANAGEMENT STUFF] ;;@ END OF GCBIB 246 ;;@ READER 227 READ AND RELATED FUNCTIONS ;;; ************************************************************** ;;; ***** MACLISP ****** READ AND RELATED FUNCTIONS ************** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT [RDR] SUBTTL HIRSUTE READER AND INPUT PACKAGE SUBTTL HAIRY READER BIT DESCRIPTIONS ;OBJECT FLAGS - AS AN OBJECT ACCUMULATES, THE LH OF ACC T ; HAS BITS SET TO DESCRIBE THE STATE OF THE OBJECT ;BIT VALUE MEANING ;3.1 1 TOP LEVEL OBJECT ;3.2 2 FIRST OBJECT OF A LIST ;3.3 4 DOTTED PAIR OBJECT - SECOND HALF ;3.4 10 DELAYED DOT READ ;3.5 20 ALPHA ATOM (I.E., NON-NUMBER ATOM) ;3.6 40 NUMBER ATOM ;3.7 100 DECIMAL NUMBER ;3.8 200 FLOATING NUMBER ;3.9 400 NEGATIVE NUMBER ;4.1 1000 EXPONENT-MODIFIED NUMBER, E.G. ^ OR E (OR SPLICING, IF MACRO) ;4.2 2000 LSH-ED NUMBER, I.E. _ ;4.3 4000 LIST-TYPE OBJECT ;4.4 10000 SIGNED NUMBER ATOM, E.G. +A ;4.5 20000 MACRO-PRODUCED OBJECT ;4.6 40000 BIGNUM BASE 10. ;4.7 100000 BIGNUM BASE IBASE ;4.8 200000 HUNK ;4.9 400000 A form has been seen after a dot. For error checking ; splicing macros. ;CHARACTER FLAGS - THE RH OF AN ENTRY IN THE RCT TABLE ; GENERALLY HAS THE ASCII TRANSLATION FOR THE CHARACTER, ; EXCEPT MACRO-CHARACTERS, WHICH HOLD A FUNCTION TO EXECUTE ; THE LH HAS DESCRIPTOR BITS AS FOLLOWS: ;BIT VALUE MEANING ;3.1 1 ALPHABETIC, I.E. A,B,C,...,Z ;3.2 2 EXTENDED ALPHABETIC, E.G., !,",#,$, ETC. AND LOWERCASE ;3.3 4 DECIMAL DIGIT, I.E. 0,1,2,...,9 ;3.4 10 + OR - ;3.5 20 ^ OR _ ;3.6 40 SECOND CHOICE DENOTER FOR 3.4, 3.5, 4.1, AND 4.3 ;3.7 100 PRINT SHOULD SLASHIFY IF NOT FIRST CHAR ;3.8 200 . KIND OF DOT ;3.9 400 PRINT SHOULD SLASHIFY WHEN IN FIRST POSITION ;4.1 1000 THE RUBOUT CHARACTER, OR THE TTY FORCE FEED CHAR ;4.2 2000 THE READ "QUOTE" CHARACTER, I.E. / ;4.3 4000 MACRO CHARACTER, E.G. ', OR SPLICING MACRO ;4.4 10000 ) ;4.5 20000 . KIND OF DOT ;4.6 40000 ( ;4.7 100000 OR OR ;4.8 200000 CHARACTER OBJECT ;4.9 400000 WORTHLESS CHARACTERS, AND ANY WITH BIT 3.8 ; OR BITS 4.1-4.8 ON. IFN NEWRD,[ ;;;DEFINE READER-SYNTAX BITS ;;;THESE BITS OCCUPY 2.1-3.8. DO NOT USE 3.9 (SEE TYIPEEK) RS.FF==004000,, ;FORCE-FEED CHARACTER RS.VMO==002000,, ;VERTICAL MOTION (LF, FF) RS.SQX==001000,, ;EXPONENT MARKER, STRING QUOTE RS.BRK==000400,, ;SPECIAL ACTION NEEDED ON INPUT RS.SCO==000200,, ;SINGLE-CHARACTER OBJECT RS.WSP==000100,, ;WHITE SPACE - SPACE, TAB, COMMA, CR RS.LP ==000040,, ;LEFT PARENTHESIS RS.DOT==000020,, ;DOTTED-PAIR DOT RS.RP ==000010,, ;RIGHT PARENTHESIS RS.MAC==000004,, ;MACRO-CHARACTER (RS.ALT = SPLICING) RS.SLS==000002,, ;SLASHIFIER RS.RBO==000001,, ;RUBOUT, FORCEFEED RS.SL1==400000 ;SLASH IF FIRST IN PNAME RS.PNT==200000 ;DECIMAL POINT (FOR NUMBERS) RS.SL9==100000 ;SLASH IF NOT FIRST IN PNAME RS.ALT==040000 ;CHANGE MEANING OF OTHER BITS RS.ARR==020000 ;NUMBER MODIFIERS _ AND ^ RS.SGN==010000 ;NUMBERS SIGNS + AND - RS.DIG==004000 ;DIGITS 0 THROUGH 9 RS.XLT==002000 ;EXTENDED LETTERS (LIKE :) RS.LTR==001000 ;REGULAR LETTERS (LIKE X) IRP A,,[FF,VMO,SQX,BRK,SCO,WSP,LP,DOT,RP,MAC,SLS,RBO] RS%!A==_22 TERMIN NWTNE==:TRNE NWTNN==:TRNN DEFINE NWTN ZP,AC,SX TDN!ZP AC,[RS.!SX] TERMIN ] ;END IFN NEWRD IFE NEWRD,[ ;;;DEFINE READER-STYNTAX BITS RS.FF==0 RS.VMO==0 RS.SQX==0 RS.BRK==400000 RS.SCO==200000 RS.WSP==100000 RS.LP==40000 RS.DOT==20000 RS.RP==10000 RS.MAC==4000 RS.SLS==2000 RS.RBO==1000 RS.SL1==400 RS.PNT==200 RS.SL9==100 RS.ALT==40 RS.ARR==20 RS.SGN==10 RS.DIG==4 RS.XLT==2 RS.LTR==1 IRP A,,[FF,VMO,SQX,BRK,SCO,WSP,LP,DOT,RP,MAC,SLS,RBO] RS%!A==RS.!A TERMIN NWTNE==:TLNE NWTNN==:TLNN DEFINE NWTN ZP,AC,SX TLN!ZP AC,RS.!SX TERMIN ] ;END OF IFE NEWRD RS.CMS==RS. ;CHARACTER-MACRO SYNTAX RS.SCS==RS. ;SINGLE-CHAR-OBJ SYNTAX ;SYNTAX FOR CHARS THAT BEGIN OBJECTS RS.OBB==RS. RS.WTH==RS. ;PRETTY MUCH, ANY WORTHY CHAR RS.SEE==RS. ;ALMOST ANY CHAR THAT YOU REALLY SEE SUBTTL READCH AND ASCII FUNCTIONS, $READCH: JSP D,INCALL Q$READCH RDCH$: READCH: PUSHJ P,TYI RDCH3: MOVE TT,A JRST RDCH2 $ASCII: JSP T,FXNV1 RDCH2: CAIN TT,203 ;RARE CASE WHEN READCH IS CALLED FROM WITHIN JRST READCH ; A READLIST - MAY SEE A PSEUDO-SPACE. SA$ CAIN TT,315 ;NORMALIZE CR FOR SAIL SA$ MOVEI TT,15 ANDI TT,177 MOVE B,TT MOVE D,VOBARRAY ADDI TT,OBTSIZ+1 ROT TT,-1 JUMPL TT,.+3 HLRZ A,@1(D) JRST .+2 HRRZ A,@1(D) JUMPN A,CPOPJ JRST RDCHO SUBTTL NEWIO INPUT FUNCTION ARGS PROCESSOR ;;; JSP D,INCALL ;;; Q ;;; PROCESSES ARGUMENTS FOR AN INPUT FUNCTION TAKING STANDARD ;;; ARGUMENTS (EOF VALUE AND/OR FILE ARRAY). SAVES F. ;;; JSP D,XINCALL ;;; Q ;;; IS SIMILAR, BUT INSISTS ON A FIXNUM RESULT (FOR TYI, TYIPEEK), ;;; AND EXPECTS F TO CONTAIN EITHER "FIX1" OR "CPOPJ". ;;; SAVES AR2A (SEE TYIPEEK). XINCALL: JUMPN T,XINCA1 PUSH P,F SFA% JRST 1(D) IFN SFA,[ INCAST: PUSHJ P,INFGET ;GETS VINFILE IN AR1 SKIPE TAPRED CAIN AR1,TRUTH HRRZ AR1,V%TYI HRLZI T,AS.SFA ;CHECK FOR AN SFA TDNN T,ASAR(AR1) ;FOUND AN SFA? JRST 1(D) ;NOPE, RETURN RIGHT AWAY HLRZ TT,(D) ;GET POINTER TO OP BIT MOVE T,(TT) ;GET THE ACTUAL BIT MOVEI TT,SR.WOM ;CHECK AGAINST KNOWN THINGS TDNN T,@TTSAR(AR1) ;CAN IT DO THIS SPECIFIC OPERATION? JRST 1(D) ;NO, RETURN AS NORMAL INCSEO: MOVEI C,INCSEO ;GIVE IT SOMETHING UNIQUE PUSH FXP,D ;MAY NEED TO RETURN IF OVER-RUBOUT PUSH P,AR1 ;REMEMBER THE SFA PUSHJ P,ISTCAL ;YES, PROCESS IT POP FXP,D POP P,AR1 CAIE A,INCSEO ;DID THE SFA RETURN EOF? POPJ P, ;NO, RETURN PUSHJ P,EOF ;HANDLE EOF JRST INCAST ;IF RETURN THEN PROCEED AROUND AGAIN ] ;END IFN SFA XINCA1: TLOA D,1 ;MUST HAVE FIXNUM RESULT INCALL: SFA$ JUMPE T,INCAST ;ZERO ARGS SFA% JUMPE T,1(D) AOJL T,INCAL2 SETZ AR1, EXCH AR1,(P) ;DEFAULT NIL FOR EOF VALUE INCAL4: JUMPE AR1,EOFBN0 ;NOT IF NIL JSP TT,XFOSP ;FILE OR SFA? JRST EOFBN0 ;NOT IF T, OR IF NOT FILE IFN SFA,[ JRST INCAL5 INCST2: HLRZ TT,(D) ;GET POINTER TO OP BIT MOVE T,(TT) ;GET THE ACTUAL BIT MOVEI TT,SR.WOM ;CHECK AGAINST KNOWN THINGS TDNN T,@TTSAR(AR1) ;CAN IT DO THIS SPECIFIC OPERATION? JRST INCALZ ;NO, HANDLE NORMALLY: LOWER LEVEL WILL TRAP POP P,C ;GET EOF VALUE TLNN D,1 ;EXPECTING A FIXNUM RESULT? JRST ISTCAL ;NOPE, CALL THE STREAM AND GO ON PUSH P,C ;REMEMBER EOF VALUE AGAIN INCST3: MOVEI C,INCST3 ;NEW EOF VALUE, SOMETHING UNIQUE PUSHJ P,ISTCAL ;CALL THE SFA POP P,C ;RESTORE EOF VALUE CAIN A,INCST3 ;DID THE SFA RETURN EOF? JRST INCST4 ;YES, HANDLE IT JSP T,FXNV1 ;ELSE THE VALUE RETURNED MUST BE A FIXNUM POPJ P, INCST4: SKIPN A,C ;FOR A NULL EOF VALUE, SNEAKILY MOVEI A,IN0-1 ; SLIP IN -1 JSP T,FXNV1 ;ELSE WHAT WAS PROVIDED POPJ P, ; MUST BE A FIXNUM ] ;END IFN SFA INCAL5: MOVE A,TTSAR(AR1) ;GET ARRAY TYPE BITS TLNN A,TTS ;MUST BE INPUT JRST INCAL1 EXCH A,AR1 PUSHJ P,[IOL [NOT AN INPUT FILESPEC!]] EXCH A,AR1 JRST INCAL4 INCAL1: TLNN A,TTS ;IF TTY ALLOW BINARY MODE TLNN A,TTS ;MUST NOT BE BINARY FILE JRST INCALZ EXCH A,AR1 PUSHJ P,[IOL [NOT ASCII FILE!]] EXCH A,AR1 JRST INCAL4 INCALZ: POP P,A ;RESTORE EOF VALUE INBIND: SKIPE B,AR1 JRST INBN4 PUSHJ P,INFGET ;GETS VINFILE IN AR1 MOVEI B,(AR1) INBN4: CAIN B,TRUTH TDZA C,C SKIPA C,[TRUTH] HRRZ AR1,V%TYI ; PUSHJ P,ATIFOK ; UNLOCKI MOVSI T,-LINBN9 ;OPEN-CODING OF SPECBIND MOVEM SP,SPSV INBN1: HRRZ TT,INBN9(T) HRRZ R,(TT) HRLI R,(TT) PUSH SP,R HLRZ R,INBN9(T) TRNN R,777760 HRRZ R,(R) MOVEM R,(TT) AOBJN T,INBN1 JSP T,SPECX ;END OF SPECBIND PUSH P,CUNBIND JRST EOFBIND INBN9: C,,TAPRED ;TABLE OF VALUE CELLS FOR INBIND B,,VINFILE ; EACH ENTRY IS OF FORM: NIL,,VINSTACK ; ,, $DEVICE,,TYIMAN ; IF NEW VALUE IS AN AC, THEN UNTYI,,UNTYIMAN ; THE AC CONTAINS THE REAL ;; UNRD,,UNREADMAN ; NEW VALUE. ;; READP,,READPMAN LINBN9==.-INBN9 INCAL2: AOJL T,INCAL7 POP P,A ;TWO ARGS POP P,AR1 JUMPE AR1,INBIND CAIN AR1,TRUTH JRST INBIND PUSH P,A ;SAVE EOF VALUE JSP TT,XFOSP SFA% SKIPA SFA% JRST INCAL5 IFN SFA,[ JRST INCST1 JRST INCAL5 JRST INCST2 INCST1: ] ;END IFN SFA EXCH A,AR1 ;OTHER MUST BE FILE ARRAY MOVEM A,(P) ;STORE NEW EOF VALUE JRST INCAL4 ;MAKE SURE OTHER IS CORRECT INCAL7: HRRZ D,(D) ;MORE THAN TWO ARGS: FOOEY. JRST S2WNAL EOFBN0: POPI P,1 ;GET EOF VALUE OFF STACK MOVEI A,(AR1) EOFBIND: TLNN D,1 ;BIND FOR INPUT EOF TRAP JRST EOFBN3 PUSH P,F ;FOR NUMERICAL INPUT FN, FIX1 OR CPOPJ TLO A,400000 EOFBN3: PUSH P,A PUSH P,CEOFBN5 JSP T,ERSTP ;SET UP A FRAME MOVEM P,EOFRTN ;THIS IS AN EOF FRAME SETZM BFPRDP .SEE EOF2 SFA% PUSHJ P,1(D) ;RUN CALLING FUNCTION SFA$ MOVEI C,(A) ;THIS IS THE EOF VALUE FOR SFAS SFA$ PUSHJ P,INCAST ;HANDLE AN SFA, ELSE RUN THE CALLER MOVSI D,-LEP1+1(P) ;RESTORE FRAME STUFF HRRI D,ERRTN BLT D,ERRTN+LEP1-1 SUB P,[LERSTP+2,,LERSTP+2] ;FLUSH FRAME POPJ P, ;RETURN (RESULT IN A OR TT) EOFBN5: POP P,A ;COME HERE ON EOF TLZN A,400000 CEOFBN5: POPJ P,EOFBN5 SKIPN A ;FOR A NULL EOF VALUE, SNEAKILY SKIPA TT,XC-1 ; SLIP IN A -1 INSTEAD JSP T,FXNV1 ;ELSE WHAT WAS PROVIDED POPJ P, ; MUST BE A FIXNUM SUBTTL NEWIO END-OF-FILE HANDLING ;;; HANDLE EOF ON STANDARD FILE ARRAY IN AR1. EOF: PUSHJ FXP,SAV5 HRRZ T,BFPRDP ;CHECK WHETHER IN READ JUMPN T,EOFE EOF2: SFA$ MOVSI TT,AS.SFA SFA$ TDNE TT,ASAR(AR1) ;DID AN SFA GET EOF? SFA$ JRST EOFZ ;YES, NEVER ANY EOFFN MOVEI TT,FI.EOF HRRZ B,@TTSAR(AR1) JUMPE B,EOF5 EXCH B,AR1 SKIPE A,EOFRTN HRRZ A,-LERSTP-1(A) .SEE EOFBIND EXCH A,B CALLF 2,(AR1) JUMPN A,EOF4 EOF8: SKIPE TAPRED ;READING FROM INFILE? PUSHJ P,INPOP ;YES, POP THE INPUT STACK PUSHJ P,EOF7 EOF1: JSP R,PDLA2-5 POPJ P, EOF7: HRRZ A,-2(P) ;SAVED AR1 MOVE TT,TTSAR(A) TLNN TT,TTS ;DON'T CLOSE TTY INPUT, PUSHJ P,ICLOSE ; FOR THAT WAS MERELY OVER-RUBOUT POPJ P, EOF4: CAIN A,TRUTH JRST EOF1 SKIPN T,EOFRTN JRST EOF8 HRRM A,-LERSTP-1(T) .SEE EOFBIND EOF9: MOVE P,EOFRTN .SEE TYPK9 JRST ERR1 EOF5: PUSHJ P,EOF7 EOFZ: SKIPE TAPRED ;NO EOF FUNCTION. READING FROM INFILE? PUSHJ P,INPOP ;YES, POP THE STACK SKIPN EOFRTN JRST EOF1 JRST EOF9 SUBTTL NEWIO INPUSH FUNCTION ;;; HAIRY INPUSH FUNCTION. PUSHES FILE ONTO INSTACK, ;;; OR MAYBE PUSHES INFILE, OR MAYBE POPS. ;;; INPOP POPS INSTACK INTO INFILE ONCE. INPU0: WTA [BAD ARG - INPUSH!] INPUSH: CAIN A,TRUTH ;SUBR 1 HRRZ A,V%TYI JSP TT,AFILEP JRST INPU2 PUSHJ P,ATIFOK UNLOCKI EXCH A,VINFILE HRRZ B,VINSTACK PUSHJ P,CONS MOVEM B,VINSTACK INPU1: SKIPN A,VINFILE JRST INPU12 CAIN A,TRUTH SETZM TAPRED POPJ P, INPU12: PUSHJ P,INFLUZ JRST INPU1 INPU2: SKOTT A,FX JRST INPU0 SKIPN TT,(A) JRST INPU1 JUMPL TT,INPU5 INPU3: HRRZ A,VINFILE ;AN INPUSH LOOP HRRZ B,VINSTACK PUSHJ P,CONS MOVEM A,VINSTACK SOJG TT,INPU3 JRST INPU1 INPOP: MOVNI TT,1 PUSH P,A ;MUST SAVE A (E.G., SEE LOAD) PUSH P,CPOPAJ INPU5: PUSH FXP,TT INPU6: SKIPN A,VINSTACK JRST INPU8 HLRZ AR1,(A) ; PUSHJ P,ATIFOK ; UNLOCKI HLRZ AR1,(A) MOVEM AR1,VINFILE HRRZ A,(A) MOVEM A,VINSTACK AOSGE (FXP) JRST INPU6 INPU7: SUB FXP,R70+1 JRST INPU1 INPU8: MOVEI A,TRUTH MOVEM A,VINFILE JRST INPU7 SUBTTL TYI FUNCTION AND RELATED ROUTINES TYI$: SKIPA F,CFIX1 ;SUBR (NIL . 0) NCALLABLE MOVEI F,CPOPJ PUSH P,F JRST TYI %TYI: SKIPA F,CFIX1 ;LSUBR (0 . 2) NCALLABLE MOVEI F,CPOPJ JSP D,XINCALL SFA% Q%TYI SFA$ [SO.TYI,,],,Q%TYI TYI: MOVEI A,Q%TYI PUSH FXP,BFPRDP HRLZM A,BFPRDP PUSHJ P,@TYIMAN POP FXP,BFPRDP MOVEI A,(TT) ;BARF POPJ P, ;;; MAIN UNTYI ROUTINE ;;; ACCEPTS CHARACTER IN A AND INPUT FILE IN VINFILE. ;;; STICKS CHARACTER BACK INTO CHARACTER BUFFER. ;;; CLOBBERS A,B,AR1,T,TT,D. MUST SAVE C (SEE READ). UNTYI: PUSHJ P,INFGET ;GETS VINFILE IN AR1 SKIPE TAPRED CAIN AR1,TRUTH HRRZ AR1,V%TYI IFN SFA,[ MOVSI TT,AS.SFA ;HANDLE DIFFERENTLY IF AN SFA TDNE TT,ASAR(AR1) ;SKIP IF NOT AN SFA JRST SUNTYI ;SFA UNTYI ] ;END IFN SFA MOVEI D,300000(A) ;USE 200000 BIT (IN CASE OF ^@) MOVEI TT,FI.BBC ;THE 100000 BIT IS A CROCK FOR PRATT ;THAT MEANS DO NOT PUT CHAR OUT ON ECHOFILES HLRZ T,@TTSAR(AR1) ;GET SINGLE BUFFERED CHAR JUMPE T,UNTYI3 ;THERE IS NONE - THIS IS EASY HRRZ B,@TTSAR(AR1) ;FOOEY - WE MUST CONS THE MOVEI TT,-200000(T) ; OLD BUFFERED BACK CHAR JSP T,FXCONS ; INTO THE LIST TO LEAVE ROOM PUSHJ P,CONS ; FOR THE NEW ONE MOVEI TT,FI.BBC HRRZM A,@TTSAR(AR1) UNTYI3: HRLM D,@TTSAR(AR1) ;BUFFER BACK NEW CHAR POPJ P, IFN SFA,[ SUNTYI: PUSH P,C ;CANNOT BASH C MOVEI TT,(A) ;CHARACTER INTO TT JSP T,FXCONS ;GENERATE A LISP FIXNUM MOVSI T,SO.UNT ;UNTYI OPERATION MOVEI C,(A) ;ARGUMENT INTO C (CHARACTER TO UNTYI) PUSHJ P,ISTCAL ;GO TO THE SFA CALLER POP P,C POPJ P, ] ;END IFN SFA ;;; MAIN INPUT FILE ARRAY HANDLER ;;; FILE ARRAY IN VINFILE. ;;; SAVES A,B,C,AR2A; CLOBBERS AR1. ;;; RETURNS CHARACTER IN TT. ;;; ACCUMULATOR D IS ZERO FOR PEEKING, ELSE 1. $PEEK: TDZA D,D $DEVICE: MOVEI D,1 $DEV$: PUSHJ P,INFGET ;GETS VINFILE IN AR1 SKIPE TAPRED CAIN AR1,TRUTH HRRZ AR1,V%TYI IFN SFA,[ MOVSI T,AS.SFA ;BREAK AWAY HERE IF SFA TDNE T,ASAR(AR1) ;SFA? JRST $DEVSFA ;NOPE, CONTINUE AS USUAL ] ;END OF IFN SFA MOVSI T,TTS TDNE T,TTSAR(AR1) JRST $DVLUZ ;INPUT (FILE) CLOSED LOSSAGE! $DEV0: LOCKI MOVE T,TTSAR(AR1) $DEV1: SKIPN TT,FI.BBC(T) JRST $DEV2 TLZN TT,200000 JRST $DEV1A HLRZ TT,TT ;ONE CHAR IS "BUFFERED", SO TAKE IT SKIPE D HRRZS FI.BBC(T) JRST $DEV1B $DEV1A: MOVS TT,(TT) ;THERE IS A BUFFER-BACK LIST SKIPE D HLRZM TT,FI.BBC(T) ;"CDR" IT IF NOT MERELY PEEKING MOVE TT,(TT) ;AND TAKE TOP CHAR $DEV1B: TRZN TT,100000 ;100000 MEANS DON'T OUTPUT TO ECHOFILES JRST $DEVECO UNLKPOPJ .SEE UNTYI ;;; NO CHARS BUFFERED BACK, SO DISPATCH ON FILE TYPE $DEV2: HLRZ R,BFPRDP TLNN T,TTS ;IF THIS ISN'T A TTY, JRST $DEV4 ; THEN FORGET CLEVER HACKS CAIN R,Q%TYI ;IF THIS IS "TYI", THEN JRST $DEVAH ; PULL CLEVER ACTIVATION HACK MOVE F,F.MODE(T) 20$ TLNE F,FBT 20$ JRST $DEVLM JUMPE R,$DEV4 ;NIL MEANS NO CLEVERNESS AT ALL HRRZ R,TI.BFN(T) JUMPN R,$DEVPS TLNN F,FBT ;NO PRE-SCAN FUNCTION IN FILE JRST $DEV4 UNLOCKI ;CANT "PRESCAN" FROM TTY WITH 12.-BIT CHARS PUSHJ P,INFLUZ JRST $DEV$ ;;; LINEMODE FOR TTYs IFN D20,[ $DEVLM: HRLM D,(P) POP FXP,TT ;POP THE LOCKI WORD PUSHJ FXP,SAV5 PUSHN FXP,80. SKIPE TENEXP JRST $DVLMX MOVEI 1,-80.+1(FXP) HRLI 1,440700 MOVE 2,[RD%TOP 400.] SETZ 3, MOVE R,1 ;SAVE BP IN R HRROM TT,INHIBIT ;make up .5LOCKI RDTTY ERJMP IIOERR HRREI F,-400.(2) JRST $DVLMQ $DVLMX: MOVEI 2,-80.+1(FXP) HRLI 2,440700 MOVEI 3,400. MOVEI 4,37 MOVEI 1,-1 HRROM TT,INHIBIT MOVE R,2 SIN ERJMP IIOERR HRREI F,-400.(3) MOVE 1,2 HRR 2,3 $DVLMQ: JUMPN F,$DVLM0 POPI FXP,80. PUSH FXP,TT ;RESTORE LOCKI WORD JRST $DVPSX ;EXIT AND TRY AGAIN IF NOTHING INPUT $DVLM0: PUSH FXP,TT ;RESTORE LOCKI WORD UNLOCKI ;UNLOCK TO PERMIT CONSING MOVEI B,NIL $DVLM1: ILDB TT,R JSP T,FXCONS PUSHJ P,CONS MOVE B,A AOJL F,$DVLM1 POPI FXP,80. PUSHJ P,NREVERSE ;CONS UP THE LIST MOVE C,A JRST $DVPS1 ; AND JOIN "PRESCANNER" CODE ] ;END OF IFN D20 ;;; MOBY WINNING PRESCAN READER FOR TTYs $DEVPS: HRLM D,(P) ;INVOKE THE PRE-SCAN FUNCTION PUSHJ FXP,SAV5 ;FIRST, SAVE THE WORLD THEN CALL THE SCANNER MOVEI AR2A,(R) ;FUNCTION WITH 3 ARGUMENTS: MOVEI A,(AR1) ; (1) THE FILE ARRAY HLRZ B,BFPRDP ; (2) THE FUNCTION TO BUFFER FOR LDB T,[002100,,BFPRDP] ; (3) IF (2) IS 'READ, THE UNLOCKI PUSH FXP,T ; NUMBER OF HANGING OPEN MOVEI C,(FXP) ; PARENTHESES PUSH FXP,BFPRDP PUSH FXP,LPNF CALLF 3,(AR2A) POP FXP,LPNF POP FXP,BFPRDP SUB FXP,R70+1 HRRZ AR1,-1(P) JUMPE A,$DVEF0 ;NIL MEANS OVER-RUBOUT, ERGO EOF MOVEI C,(A) SKIPE V.RSET CAIN R,QTTYBUF ;DON'T NEED TO CHECK RESULT IF JRST $DVPS1 ; IT WAS OUR OLD FRIEND TTYBUF MOVEI B,(C) HLRZ A,(B) ;LOOP TO VERIFY THAT RESULTS FROM TTY JSP F,TYOARG ; PRESCAN ARE INDEED ASCII VALUES HRRZ B,(B) JUMPN B,.-3 $DVPS1: LOCKI $DVPS0: HRRZ AR1,-1(P) MOVE T,TTSAR(AR1) EXCH C,FI.BBC(T) ;SO ADD LIST OF CHARS TO BUFFER-BACK JUMPN C,$DVPS2 ; OOPS, SOME "SNEAKED" IN $DVPSX: JSP R,PDLA2-5 HLRZ D,(P) UNLOCKI JRST $DEV$ ;AND TRY AGAIN! $DVPS2: TLZE C,200000 JRST $DVPS3 MOVE A,FI.BBC(T) MOVEI B,(C) ;BUFFER-BACK LIST "SNEAKED" UP IN THE MEANTIME PUSHJ P,.NCONC ; JUST TACK IT ON END (SINCE IT WAS "LATER") JRST $DVPSX $DVPS3: MOVEI TT,(C) ;BUFFER-BACK CHAR "SNEAKED" UP IN THE MEANTIME MOVEI C,0 EXCH C,FI.BBC(T) ;LIST FROM TTYSCAN PLACED IN C UNLOCKI ;FOO! PERMIT CONSING. FOO! FOO! FOO! JSP T,FXCONS PUSHJ P,NCONS MOVE A,C PUSHJ P,.NCONC JRST $DVPS1 ;;; UNIT INPUT ON REAL DEVICE - INCLUDING "TTY" IN CASE OF CALL TO TYI FUNCT $DEV4: SKIPL F,F.MODE(T) .SEE FBT.CM JRST $DEV5 HRRO TT,(FXP) ;This had better get the saved INHIBIT .SEE $DEV0 MOVEM TT, INHIBIT ;TURN THE LOCKI INTO A .5LOCKI IFN ITS,[ MOVE R,F.CHAN(T) LSH R,27 IOR R,[.IOT 0,TT] SPECPRO INTTYX TYIXCT: XCT R ;INPUT CHARACTER NOPRO $DEV4B: JUMPL TT,$DEVEF ;JUMP ON EOF AOS F.FPOS(T) ;OTHERWISE INCREMENT FILE POSITION (OK EVEN IF F.FLEN NEG) JRST $DEV6 ] ;END OF IFN ITS IFN D20,[ $DEV4C: PUSHJ FXP,SAV3 HRRZ 1,F.JFN(T) SPECPRO INTTYX TYIXCT: BIN ;INPUT CHARACTER ERJMP $DEV4T NOPRO MOVE TT,2 PUSHJ FXP,RST3 AOS F.FPOS(T) ;OTHERWISE INCREMENT FILE POSITION (OK EVEN IF F.FLEN NEG) SKIPN TENEXP JRST $DEV6 TRNN F,10 ;SAIL DOES THIS TOO? TLNE F,FBT ;I DON'T UNDERSTAND THIS JRST $DEV6 CAIN TT,37 ;TENEX ^_ IS CR, BARF MOVEI TT,^M ;^_ -> CR JRST $DEV6 ] ;END OF IFN D20 IFN D10,[ SA$ $DEV4C: ;SAIL WANT'S LINMOD CHECK EVEN FOR TYI MOVE R,[INCHWL TT] TLNN F,FBT SA% $DEV4C: MOVE R,[INCHRW TT] SPECPRO INTTYX TYIXCT: XCT R NOPRO IFN SAIL,[ TRNE F,10 ;FORGET THIS HACK FOR IMAGE MODE JRST $DEV6 MOVEI R,(TT) ;CANONICALIZE ASCII CODES TLNE F,FBT ;I DON'T UNDERSTAND THIS JRST $DEVS4 ;BUT CONVERT IN NON-FULL MODE CAIN R,32 ;TILDE: 32 => 176 HRROI R,176 CAIN R,176 ;RIGHT BRACE: 176 => 175 HRROI R,175 CAIN R,175 ;ALTMODE: 175 => 33 HRROI R,33 CAIN R,33 ;NOT EQUALS: 33 => 32 HRROI R,32 $DEVS4: ANDI TT,600 IORI TT,(R) TLNE F,FBT ;IF FULL CHARACTER SET (BUCKY BITS), JRST $DEV4S ; DON'T DO ANY CONVERSIONS CAIGE TT,40 ;A CONTROL CHARACTER? ADDI TT,%TXCTL+"@ ;YES, CONVERT TO EXTENDED ASCII FORMAT $DEV4S: TRNN TT,%TXCTL+%TXMTA ;USE PRESENCE OF CONTROL BIT TO CHECK FOR INT JRST $DEV6 ; PUSH FXP,TT ;SAVE THE ACTUAL CHARACTER ; SUBI TT,%TXCTL+"@ ; CAIL TT,"a-"@ ;IS IT A LOWER CASE LETTER? ; CAILE TT,"z-"@ ; SKIPA ;NOPE, LEAVE ALONE ; SUBI TT,"a-"@-1 ;ELSE CONVERT TO REAL CONTROL CHARACTER ; SKIPL TT ; CAILE TT,"_ ;IS IT A REAL "CONTROL" CHARACTER? ; JRST $DEV4V ;NO, FIXUP THE WORLD AND PROCEED ] ;END OF IFN SAIL SA% CAIL TT,40 ;CONTROL CHARS CAUSE AN INTERRUPT WHEN READ SA% JRST $DEV6 $DEV4U: HRLM D,(P) MOVEI D,(TT) ;ONLY INTERRUPT IF INT FUNCTION EXISTS ROT D,-1 ;CLEVER ARRAY ACCESS AS PER TTYICH ADDI D,FB.BUF(T) PUSH FXP,R HLRZ R,(D) SKIPGE D HRRZ R,(D) JUMPE R,$DEV4Z MOVEI D,400000(TT) HRLI D,(AR1) ;THERE IS NO OBVIOUS NEED FOR THIS NOW PUSHJ P,UCHINT ;GIVE USER INTERRUPT FOR TTY INT CHAR $DEV4Z: POP FXP,R HLRZ D,(P) ; SA$ $DEV4V: POP FXP,TT ;RESTORE THE CONTROL CHARACTER JRST $DEV6 ] ;END OF IFN D10 IFN D20,[ $DEV4T: GTSTS TLNN 2,(GS%EOF) JRST IIOERR JRST $DEVEF ] ;END OF IFN D20 ;;; A TRICKY HACK TO BE CLEVER ABOUT IMMEDIATE ACTIVATION ;;; WHEN TYI (OR READCH, OR WHATEVER) IS INVOLVED. $DEVAH: SKIPL F,F.MODE(T) ;MUST BE THE TTY FOR THIS TO WORK JRST $DEV5 HRRO TT,(FXP) ;This had better get the saved INHIBIT .SEE $DEV0 MOVEM TT,INHIBIT ;TURN THE LOCKI INTO A .5LOCKI IT% JRST $DEV4C ;IGNORE LINE MODE, AND USE CHARACTER INPUT UUO IFN ITS,[ SPECPRO INTTYX TYICAL: .CALL $DEV4M ;GOBBLE CHAR, EVEN IF NOT ACTIVATED NOPRO .LOSE 1400 MOVE TT,TTSAR(AR1) SKIPN R,FT.CNS(TT) JRST $DVAH1 ;DONE IF NO ASSOCIATED OUTPUT TTY HRLM D,(P) MOVE TT,TTSAR(R) ;UPDATE CHARPOS AND LINENUM FROM CURSOR PUSH FXP,T PUSHJ FXP,CLRO4 ; POSITION OF ASSOCIATED OUTPUT TTY POP FXP,T HLRZ D,(P) MOVE TT,TTSAR(AR1) $DVAH1: EXCH T,TT JRST $DEV4B $DEV4M: SETZ SIXBIT \IOT\ ;I/O TRANSFER 5000,,%TIACT ;READ CHARACTER IMMEDIATELY EVEN IF NOT ACTIVATOR ,,F.CHAN(T) ;CHANNEL # 402000,,T ;SINGLE CHAR RETURNED HERE (T, NOT TT!) ] ;END OF IFN ITS ;;; CODE FOR FILE ARRAYS WITH A BUFFER $DEV5A: PUSHJ P,$DEVBUF ;GET A NEW BUFFER LOAD. WATCH OUT FOR EOF JRST $DEVEF $DEV5: ;BASIC GET-1-CHAR FROM BUFFERED FILE 10$ HRRZ TT,FB.HED(T) 10$ SOSGE 2(TT) 10% SOSGE FB.CNT(T) ;GOBBLE NEXT INPUT CHAR JRST $DEV5A ;MAY NEED TO GET NEW BUFFER 10$ ILDB TT,1(TT) 10% ILDB TT,FB.BP(T) 10$ TLNN T,TTS ;IN IMAGE MODE, WHAT YOU SEES IS WHAT YOU GETS 10$ JUMPE TT,$DEV5 ;IN ASCII MODE, A NULL IS LITTERA NON GRATA JRST $DEV6W ;;; READ IN A NEW BUFFERLOAD - SKIP RETURN ON SUCCESS, NO SKIP ON EOF ;;; EXPECTS ARRAY PTR IN AR1, TTSAR IN T - SAVES D AND F .SEE FPOS5 $DEV5K: ;LOSING SYMBOL FOR DSK:JLK;LISPT PATCH $DEVBUF: PUSH FXP,D MOVE D,FB.BVC(T) ADDM D,F.FPOS(T) ;UPDATE FILEPOS BY NUMBER OF VALID BYTES SETZM FB.BVC(T) IFN ITS,[ EXCH T,TT MOVE D,FB.BFL(TT) ;BYTE COUNT MOVE T,FB.IBP(TT) ;BYTE POINTER TYICA1: .CALL SIOT .LOSE 1400 EXCH T,TT SUB D,FB.BFL(T) ;NEGATIVE OF NUMBERS OF BYTES READ MOVNM D,FB.CNT(T) MOVNM D,FB.BVC(T) ] ;END OF IFN ITS IFN D20,[ PUSHJ FXP,SAV3 ;PRESERVE LOW THREE AC'S HRRZ 1,F.JFN(T) MOVE 2,FB.IBP(T) MOVN 3,FB.BFL(T) SIN ;READ A BUFFERFUL ADD 3,FB.BFL(T) MOVEM 3,FB.CNT(T) ;STORE COUNT OF BYTES READ IN FILE OBJECT MOVEM 3,FB.BVC(T) MOVE D,3 PUSHJ FXP,RST3 ] ;END OF IFN D20 IFN D10,[ MOVE TT,F.CHAN(T) LSH TT,27 IFE SAIL,[ TLNN T,TTS.BM JRST $DEV5R HRRZ TT,FB.HED(T) ;MAYBE BUFFER HAS BEEN RELOCATED? THEN FOR MOVSI D,(BF.IOU) ANDCAB D,@(TT) ;TURNS OFF BUFFER-IN-USE BIT AND ADVANCES BUFFER SKIPGE (D) ;BF.IOU MUST BE BIT 4.9 FOR THIS TO WORK JRST $DEV5S MOVSI TT,TTS.BM ANDCAM TT,TTSAR(AR1) ;TURN OFF "BUFFER-MOVED" BIT, BUT LEAVE BUF ADDR IN D MOVE TT,F.CHAN(T) LSH TT,27 HRR TT,D ] ;END OF IFE SAIL $DEV5R: TLO TT,(IN 0,) XCT TT ;READ A NEW BUFFERFUL JRST $DEV5M ;SUCCESS! SA% ANDCMI TT,-1 XOR TT,[#] XCT TT JRST IIOERR ;LOSEY,LOSEY IFN SAIL,[ MOVE D,FB.HED(T) MOVE D,2(D) MOVEM D,FB.BVC(T) JUMPG D,$DEV5M ] ;END OF IFN SAIL ] ;END OF IFN D10 IFN ITS+D20, JUMPN D,$DEV5M ;D HOLDS "NOT-EOF-P" POP FXP,D ;FALLS THRU TO HERE ON EOF CONDITION POPJ P, ; AND EXITS WITHOUT SKIPPING IFN D10*<1-SAIL>,[ $DEV5S: HRRZ TT,FB.HED(T) HRRZM D,(TT) ;STORE CURRENT BUFFER ADDR IN CONTROL BLOCK TLZ D,-1 ADD D,[0700,,1] TLNE T,TTS.BN TLC D,0700#4400 MOVEM D,1(TT) ;CONSTRUCT NEW BP FOR BUFFER MOVE D,(D) TLNN T,TTS.BN IMULI D,5 MOVEM D,2(TT) ;STORE NEW BYTE COUNT INITO BUFFERCONTROL-BLOCK ;FALL THRU TO $DEV5M ] ;END OF IFN D10*<1-SAIL> $DEV5M: ;MORE INPUT WAS OBTAINED BY BUFFERED INPUT IFN D10,[ MOVE D,FB.HED(T) MOVE D,2(D) ;NUMBER OF VALID BYTES MOVEM D,FB.BVC(T) ] ;END OF IFN D10 .ELSE,[ MOVE TT,FB.IBP(T) MOVEM TT,FB.BP(T) ;INITIALIZE BUFFER POINTER ] ;END OF .ELSE POP FXP,D JRST POPJ1 ;SKIP RETURN ON SUCCESS ;;; WRAP UP, WITH NEW CHAR IN TT. UPDATE "PAGENUM" AND "LINENUM", AND ECHO $DEV6: SETOM INHIBIT ;RECONVERT .5LOCKI TO LOCKI SKIPN F,FI.BBC(T) JRST $DEV6W HRLM D,(P) MOVE R,T PUSHJ FXP,SAV5 JSP T,FXCONS PUSHJ P,NCONS MOVE C,A JRST $DVPS0 $DEV6W: JUMPN D,$DEV6B MOVEI D,(TT) ANDI D,177+%TXCTL ;? THIS MAY SCREW CONTROL CHARS ON SAIL TRZN D,%TXCTL JRST $DEV6A CAIE D,177 TRZ D,140 $DEV6A: TRO D,200000 HRLM D,FI.BBC(T) SETZ D, $DEV6B: CAIN TT,^J AOS AT.LNN(T) CAIE TT,^L JRST $DEVECO SETZM AT.LNN(T) AOS AT.PGN(T) $DEVECO: SKIPE AR1,VECHOFILES ;SKIP UNLESS ECHO FILES SKIPN D ;DON'T ECHO PEEKED-AT CHARS UNLKPOPJ HRLI AR1,200000 ;LIST OF FILES, NO TTY HRLM TT,AR2A PUSH P,AR2A JSP T,GTRDTB ;GET READTABLE LDB TT,[220700,,(P)] ;WATCHIT! CHAR COULD BE 12. BITS UNLOCKI PUSHJ P,TYO6 ;PUSH CHAR INTO ALL ECHO FILES HLRZ TT,(P) POP P,AR2A POPJ P, $DEVEF: UNLOCKI ;COME HERE ON EOF $DVEF1: MOVNI TT,1 JUMPE D,CPOPJ ;ONLY PEEKING, SO MERELY RETURN -1 PUSHJ P,EOF ;SIGNAL EOF JRST $DEVICE ;RETRY IF WE SURVIVE $DVEF0: JSP R,PDLA2-5 ;EOF AFTER TTYSCANNING JRST $DVEF1 ;;; LOSING CODE FOR "$DEVICE"ING A SFA IFN SFA,[ $DEVSFA: PUSH FXP,D ;SAVE D OVER CALL PUSH P,A PUSH P,B PUSH P,C PUSH P,AR1 PUSH P,AR2A SETZ C, ;NIL AS OP DEPENDENT ARGS JUMPE D,$DEVPE ;PEEKING, MIGHT HANDLE THE SFA DIFFERENTLY HRLZI T,SO.TYI ;WE ARE DOING A TYI $DEVP1: PUSHJ P,ISTCAL ;INTERNAL SFA CALL, SFA IN AR1 $DEVP2: POP P,AR2A POP P,AR1 POP P,C POP P,B POP FXP,D SKIPE A ;ALLOW NIL JSP T,FXNV1 ;INSURE FIXNUM AND GET INTO TT JUMPN A,POPAJ ;IF NON-NIL THEN GOT SOMETHING, SO RETURN IT MOVNI TT,1 JUMPE D,POPAJ ;ONLY PEEKING, SO MERELY RETURN -1 PUSHJ P,EOF ;SIGNAL EOF POP P,A JRST $DEVICE ;RETRY IF WE SURVIVE $DEVPE: MOVEI TT,SR.WOM ;CHECK THE WHICH-OPERATIONS MASK FOR TYIPEEK MOVSI T,SO.TIP TDNE T,@TTSAR(A) ;CAN IT DO IT? JRST $DEVP1 ;YES, DO IT DIRECTLY MOVSI T,SO.TYI ;ELSE DO IT AS TYI/UNTYI MOVEI AR1,(A) ;STREAM IN AR1 FOR ISTCAL PUSHJ P,ISTCAL ;DO THE TYI JUMPE A,$DEVP2 ;HIT EOF PUSH P,A ;REMEMBER THE CHAR WE WERE HANDED MOVSI T,SO.UNT ;NOW UNTYI THE CHARACTER MOVEI C,(A) ;THE ARG IS THE CHARACTER MOVE A,-2(P) ;GET THE SFA AS FIRST ARG PUSHJ P,ISTCAL ;DO THE UNTYI POP P,A ;FUDGE THE CHARACTER AS THE RETURNED VALUE JRST $DEVP2 ] ;END IFN SFA INFGT0: PUSHJ P,INFLUZ INFGET: SKIPN AR1,VINFILE ;GET VINFILE IN AR1 JRST INFGT0 POPJ P, $DVLUZ: PUSH P,[$DEV$] INFLZZ: SKIPA T,[[SIXBIT \INFILE CLOSED!\]] INFLUZ: MOVEI T,[SIXBIT \BAD VALUE FOR INFILE!\] PUSH P,A MOVEI A,TRUTH ;INFILE IS A LOSER! EXCH A,VINFILE PUSH P,CPOPAJ %FAC (T) SUBTTL READLIST, IMPLODE, MAKNAM BYTEAC==TT MKNR6C: MOVEM T,MKNCH JSP TT,IRDA SKIPA MKR6DB: IDPB BYTEAC,C PUSHJ P,@MKNCH JRST RDAEND SOJGE D,MKR6DB PUSH FXP,BYTEAC PUSHJ FXP,RDA4 JSP TT,IRDA1 POP FXP,BYTEAC SOJA D,MKR6DB READLIST: JUMPE A,RDL12 MOVEI B,RDLTYI MOVEI C,RDLUNTYI JSP T,SPECBIND 0 A,RDLARG 0 B,TYIMAN 0 C,UNTYIMAN MOVEI A,RDIN PUSHJ P,READ0A SKIPE T,RDLARG ;REALLY OUGHT TO ALLOW CAIN T,-1 ; A TRAILING SPACE JRST UNBIND LERR EMS1 ;TOO MANY CHARS ;;; READLIST PEEK AND TYI ROUTINES. (CF. $DEVICE). ;;; SAVES A,B,C,AR2A; CLOBBERS AR1. RETURNS CHARACTER IN TT. RDLPEK: JRST RDLPK1 ;RDLTYI-1 IS FOR PEEKING (SEE TYIPEEK) RDLTYI: PUSH P,A SKIPN A,RDLARG JRST RDLTY2 CAIN A,-1 LERR EMS3 ;TOO FEW CHARS HRRZ AR1,(A) MOVEM AR1,RDLARG RDLTY1: HLRZ A,(A) RDLTY3: JSP T,CHNV1 JRST POPAJ RDLTY9: SIXBIT \NOT ASCII CHAR!\ RDLTY2: HLLOS RDLARG MOVEI TT,203 ;PSEUDO-SPACE JRST POPAJ RDLPK1: SKIPE TT,RDLARG CAIN TT,-1 JRST M1TTPJ ;RETURN -1 FOR PEEKING AT "EOF" PUSH P,A HLRZ A,@RDLARG JRST RDLTY3 ;ELSE RETURN CHAR, BUT DON'T FLUSH RDLUNTYI: MOVEI TT,(A) JSP T,FXCONS HRRZ B,RDLARG PUSHJ P,CONS MOVEM A,RDLARG POPJ P, READ6C: PUSH FXP,A MOVEI T,R6C1 PUSHJ FXP,MKNR6C SUB FXP,R70+1 JRST RINTERN R6C1: ILDB TT,-1(FXP) JUMPE TT,CPOPJ ADDI TT,40 JRST POPJ1 SUBTTL READ FUNCTION ;;; ********** HIRSUTE READER ********** READ$: MOVEI T,0 JRST READ IREAD: MOVEI T,0 IREAD1: SKIPE VOREAD JCALLF 16,@VOREAD OREAD: JSP D,INCALL SFA% QOREAD SFA$ [SO.RED,,],,QOREAD READ: MOVEI A,QOREAD ;ENABLE TTY PRE-SCAN HRLM A,BFPRDP MOVEI A,RDIN HRRZ T,BFPRDP JUMPN T,READ0 ;OOOOPS, A RE-ENTRANT CALL TO READ PUSHJ P,READ0B ;TOP-LEVEL READ HLLZS BFPRDP SKIPA B,RDBKC READ0: PUSHJ P,REKRD ;RE-ENTRANT READ TLC T,21000 ;LOSING SPLICING MACROS AT TOP LEVEL TLCN T,21000 JRST READST ;JUST GO AROUND AND TRY AGAIN READS0: TLNN B,100000 ;IF WE ENDED WITH A "WHITE-SPACE" CHARACTER TLNN T,60 ; OR IF OBJECT WASN'T AN ATOM, POPJ P, ; THEN DO NOT BUFFER BACK A CHAR JSP R,RVRCT ;OTHERWISE MUST UNTYI A CHARACTER EXCH A,C PUSHJ P,@UNTYIMAN JRST CRETJ ;We got a splicing macro at top level. If it's NIL, we go around again ;Otherwise, we just CDR it. READST: JUMPE A,READ ;If we have NIL, we have nothing! PUSHJ P,RDSMCK ;Check for it being a legal frob w/ CDR null HLRZ A,(A) ;Take the CAR of it. JRST READS0 ;and finish up as if it were what we'd read ;;; ***** HERE IT IS FANS, THE BASIC READER ***** READ0B: HRRZM A,RDINCH ;READ-IN CHANNEL FILTER RD0B1: JSP T,RSXST HRRZ A,VIBASE IFN USELESS,[ CAIN A,QROMAN JRST RD0BRM ] ;END OF IFN USELESS SKOTT A,FX JRST IBSERR MOVE TT,(A) JUMPLE TT,IBSERR CAIL TT,200 JRST IBSERR IFN USELESS, SETZM RDROMP RD0B2A: MOVEM TT,RDIBS BG$ SUBI TT,10. BG$ MOVEM TT,NRD10FL MOVSI T,3 ;TOP LEVEL, FIRST OF LIST FLAGS PUSHJ P,RDOBJ1 ;READ ONE OBJECT HRRZS A SETZB C,AR1 MOVEI AR2A,0 POPJ P, IFN USELESS,[ RD0BRM: MOVEI TT,10. SETOM RDROMP JRST RD0B2A ] ;END OF IFN USELESS RVRCT: MOVE C,VREADTABLE MOVSI TT,-LRCT+2 CAME B,@TTSAR(C) AOBJN TT,.-1 JUMPGE TT,ER3 ;BLAST? - READ MOVEI C,(TT) JRST (R) READ0A: PUSHJ P,REKRD TLNN T,4060 RMCER: LERR EMS5 ;READ MACRO CONTEXT ERROR POPJ P, REKRD: SAVE RDINCH RDIBS PUSHJ P,READ0B REKRD1: RSTR RDIBS RDINCH POPJ P, RDOBJ3: TLNE B,RS%WSP ;TAB,SPACE,COMMA JRST RDOBJ1 TLNN T,1 POPJ P, HRRZ TT,BFPRDP JUMPN TT,RMCER RDOBJ1: JSP TT,RDCHAR ;*** READ ONE OBJECT ROUTINE *** RDOBJ: NWTN N,B,OBB ;OBJECT BEGIN CHAR - NOT USAGE AT TYIPEEK JRST RDOBJ3 MOVEI TT,400000 IORM TT,BFPRDP TLNE B,RS%MAC JRST RDOBM2 ;MACRO CHAR. TLNE B,RS%SCO JRST RDCHO1 ;SINGLE CHAR OBJ. NWTNE B,RS. JRST RDALPH ;RDOBJ WILL EXIT WITH OBJECT READ TLNE B,RS%LP ;IN ACC A, AND RCT ENTRY OF BREAK JRST RDLST ;CHARACTER IN ACC B NWTNE B,RS.DIG JRST RDNUM NWTNE B,RS.SGN JRST RDOBJ6 ;+,- MOVE AR1,B JSP TT,RDCHAR ;DEFAULT IS . TLNN AR1,RS.PNT JRST RDOBJ0 ;WAS DOTTED PAIR POINT ONLY NWTNE B,RS.DIG ;IS NEXT CHAR A DIGIT? JRST RDOBJ5 ;IF SO, THEN MUST BE FLOATING NUM COMING UP TLNN AR1,RS%DOT JRST RDJ2A ;IF NOT DOTTED PAIR, THEN TRY ALPHABETIC RDOBJ0: TLNE AR1,RS%DOT ;*** DOT IS DOTTED-PAIR DOT *** TLNE T,1 JRST ER2 TLOE T,4 ;LOSE IF ALREADY IN DOTTED PAIR JRST ER2 TLNN T,200000 ;SO GET SECOND PART OF DOTTED PAIR JRST RDOBJ ; BUT IF HUNK, THEN DO SOME CHECKING FIRST PUSHJ P,RDSKWH POPJ P, ;ENCOUNTERED %RP, EXIT LOOKING LIKE SECOND TLZ T,4 ; PART OF DOT-PAIR TO SIGNAL HUNK ENDING JRST RDOBJ ;;;. WITH DECIMAL SYNTAX ONLY TURNS INTO SCO, IF FOLLOWED BY BREAK ;;;OR BEGINNING OF ALPHA IF FOLLOWED BY ALPHA RDJ2A: TLNN B,RS% NWTNN B,RS. JRST RDCHO4 JRST RDJ2A1 RDOBJ5: TLOA T,200 ;FOUND FLOATING NUM RDOBJ2: TLO T,10000 ;NUM FORCED WITH "+" RDJ2A1: JSP TT,IRDA IDPB AR1,C AOS D JRST RDNUM2 RDOBJ6: JSP TT,IRDA ;PROCESS OBJ BEGINNING WITH + OR - IDPB B,C SOS D NWTNE B,RS.ALT TLO T,400 ;- JSP TT,RDCHAR JRST @RDOBJ8 ;CHECK FOR WHITE'S + HAC, USING RD8W, OR DONT BOTHER, USING RD8N RDJ6A: TLNE B,RS% JRST RDOBJ4 NWTNN B,RS.PNT JRST ER1 MOVE AR1,B JSP TT,RDCHAR TLNE T,4 JRST ER1 JRST RDOBJ5 ;+.D DECIMAL FLOATING FORMAT RDOBJ7: NWTNE B,RS.DIG JRST RDNUM2 ;+ TLO T,20 ;+ OR + JRST RDA1 ER1: LERR MES2 RDOBJ4: TLO T,20 ;SINGLE CHARA "+" OR "-" JRST RDBK RD8W: NWTNE B,RS. JRST RDOBJ2 JRST RDJ6A RD8N: NWTNE B,RS. JRST RDOBJ7 JRST RDJ6A RDNUM: JSP TT,IRDA ;*** NUMBER ATOM *** RDNUM2: IFE BIGNUM, SETZM AR1 ;FLAG INDICATES HOW MANY DIGITS BEYOND OVERFLOW RDNM10: SETZB F,R ;BASE 10. NUMBER IN R, BASE IBASE IN F TLOA T,40 RDNUM1: JSP TT,RDCHAR NWTNE B,RS.PNT JRST RDNUM4 ;DECIMAL POINT [WITHOUT BREAK BIT SET] SOSLE D IDPB B,C NWTNE B,RS.DIG JRST RDNUM5 TLNE T,300 ;ALPHA CHAR SEEN JRST RDNUM8 NWTNN B,RS.LTR JRST RDNUM7 TLNN T,10000 JRST RDNUM6 NW% MOVEI TT,(B) ;GET CHTRAN NW$ HRRZ TT,B NW$ ANDI TT,177 CAIL TT,"a ;ALLOW FOR LOWER CASE LETTERS SUBI B,"a-"A SUBI B,"A-"0-10. ;LETTERS ARE SUPRA-DECIMAL: JRST RDNUM5 ; A=10., B=11., ..., Z=35. RDNUM8: NW% CAIE A,"E ;UPPER AND LOWER CASE E ALLOWED NW% CAIN A,"e ;MUST TIDY THIS UP SOMEDAY NW$ TLNE B,RS%SQX ;EXPONENT OR (SOMEDAY) STRING-QUOTE JRST RDNM8A NWTNN B,RS.XLT JRST ER1 RDNUM7: TLNE T,37000 ;EXTENDED ALPHA CHAR SEEN JRST ER1 NWTNN B,RS.ARR JRST RDNUM6 NWTNE B,RS.ALT TLOA T,2000 ;_ TLO T,1000 ;^ BG$ SKIPN NRD10FL ;IF WE ARE READING IN BASE 10., THEN BG$ TLO T,100 ; F HAS NOTHING IN IT - SO MUST TAKE R RDNUM9: TLNN T,140000 JRST RDNM9E TLNE T,300 ;FOR EXPONENT-IFIED BIGNUMS, RDNSV WILL HRR AR2A,AR1 ;BE MEANINGLESS HRLI AR2A,0 TLNE T,400 ;BIGNUM OF CORRECT BASE AND SIGN IS PUT IN AR2A TLO AR2A,-1 JRST RDNM9B RDNM9E: TLNE T,300 MOVE F,R TLNE T,400 MOVNS F MOVEM F,RDNSV RDNM9B: TLZ T,500 ;ZERO OUT SIGN AND DECIMAL BITS MOVEI D,BYTSWD*LPNBUF JSP TT,RDCHAR RDNM9C: NWTNN B,RS. JRST ER1 NWTNN B,RS.SGN JRST RDNM10 NWTNE B,RS.ALT ;SKIP IF + TLO T,400 JSP TT,RDCHAR JRST RDNM10 RDNUM0: IDPB B,C RDNUM6: TLZ T,340 ;TWAS REALLY AN ALPHA ATOM TLO T,20 JRST RDA3 RDNM8A: TLZ T,100 TLO T,1200 MOVEM D,RDDSV JRST RDNUM9 RDNMF: JRST 2,@[.+1] ;CLEAR OUT ALL ARITHMETIC OVERFLOW BITS MOVE B,T MOVE TT,F ;FINISHED WITH NUMBER READ, SO PICK UP NUMBER IN BASE IBASE BG$ SKIPN NRD10FL BG$ TLO T,100 TLNN T,300 JRST RDNM2 MOVE TT,R ;PICK UP NUMBER IN BASE 10. IFE BIGNUM,[ JUMPE AR1,RDNM2 ;NUMBER OF OVERFLOW DIGITS IN AR1 TLNN T,200 JRST RDNMER ADDM AR1,D ADDM AR1,RDDSV ] RDNM2: TLNE T,400 MOVNS TT ;NEGATIVE NUMBER, IF INDICATED BG$ TLNE T,140000 BG$ JRST RDBIGN RDNM2A: TLNE T,200 JRST RDFLNM RDFXNM: TLNE T,3000 JRST RDFXEX RDFX1: JSP T,FXCONS RDFL1: MOVE T,B JRST RDNMX RDNUM5: JFCL 8.,.+1 ;BASIC LOOP THAT INCREMENTALLY ADDS IN ONE DIGIT IFE BIGNUM, JUMPN AR1,RDNUMC IFN BIGNUM,[ TLNE T,40000 JRST RDBG10 ] RDNUMD: MOVE TT,R ;BASE 10. VALUE ACCUMULATES IN R IMULI R,10. ;BASE IBASE VALUE IN F NW% ADDI R,-"0(B) NW$ LDB A,[001100,,B] NW$ ADD R,A JFCL 8,RD10OV IFN BIGNUM,[ TLNE T,100000 ;BIGNUM VALUE BASE 10. HELD IN AR1 JRST RDBGIB ;BIGNUM VALUE BASE IBASE HELD IN AR2A RDNUMB: SKIPN NRD10FL JRST RDNUM1 ] IFE BIGNUM, RDNUMB: JFCL 8,.+1 ;MIGHT BE SET IF OVFL ON BASE 10. READIN, WENT TO RD10OV, DID A C1CONS, MOVE TT,F ;DID A GC, HACKED AROUND AND SET IT AGAIN! IMUL F,RDIBS NW% ADDI F,-"0(B) NW$ LDB A,[001100,,B] NW$ ADD F,A JFCL 8,RDIBOV JRST RDNUM1 IFE BIGNUM,[ RDIBOV: MOVE F,T MOVE T,TT ;OVERFLOW WHILE ACCUMULATING NUMBER MUL T,RDIBS ;IN BASE IBASE. TRY TO RECUPERATE LSH T+1,1 ;TO ALLOW, FOR EXAMPLE, 400000000000 LSHC T,35. NW% ADDI T,-"0(B) NW$ ADD T,A EXCH T,F JRST RDNUM1 RD10OV: MOVE R,TT RDNUMC: AOJA AR1,RDNUMB ] RDFXEX: IFN BIGNUM, CAIG A,77 TLNE T,600 JRST ER1 ANDI TT,777 EXCH TT,RDNSV TLNN T,2000 JRST .+3 LSH TT,@RDNSV JRST RDFX1 IFN BIGNUM,[ SKIPGE TT TLO T,400 MOVMS TT RX1: SOSGE RDNSV JRST RDFX2 TLNE T,100000 JRST RDEX3 ] IFE BIGNUM,[ RX1: SOSGE RDNSV JRST RDFX1 ] MUL TT,RDIBS IFN BIGNUM,JUMPN TT,RDEXOF LSH TT+1,1 LSHC TT,35. JRST RX1 IFN BIGNUM,[ RDFX2: TLNE T,100000 JRST RDBIGM TLNE T,400 MOVNS TT JRST RDFX1 ] RDFLNM: TLNN T,1000 JRST RDFL3 MOVE D,RDDSV ADD D,TT AOS D MOVE TT,RDNSV RDFL3: HRREI R,-BYTSWD*LPNBUF-1(D) IFN BIGNUM,[ TLZE T,140000 JRST RDFL3A ] IDIVI TT,400000 SKIPE TT TLC TT,254000 TLC TT+1,233000 FADL TT,TT+1 RDFL3A: MOVM T,R RDFL2A: JUMPGE R,RDL2A2 RDFL2D: SETZ R, CAIG T,30. JRST RDL2D3 FSC TT,54. ;SCALE, SO THERE WONT BE UNDERFLOWS MOVNI R,54. RDL2D0: FDVL TT,[1.0^8] ;LOOP FOR MULTIPLYING-IN NEGATIVE POWER OF 10.0 FDVR TT+1,[1.0^8] FADL TT,TT+1 SUBI T,8 RDL2D3: CAILE T,8 JRST RDL2D0 JUMPE T,RDFL2E RDL2D1: FDVL TT,[10.0] FDVR TT+1,[10.0] FADL TT,TT+1 SOJG T,RDL2D1 RDFL2E: FADR TT,TT+1 FSC TT,(R) JFCL 8,RDL2E1 RDL2E0: JSP T,FPCONS JRST RDFL1 RDL2E1: JSP T,.+1 SKIPE VZUNDERFLOW TLNN T,100 ;RANDOM FP UNDERFLOW BIT JRST RDNMER MOVEI TT,0 JRST RDL2E0 RDL2A0: MOVE TT+2,TT+1 ;LOOP FOR MULTIPLYING-IN POSITIVE POWER OF 10.0 FMPR TT+2,[1.0^8] FMPL TT,[1.0^8] UFA TT+1,TT+2 FADL TT,TT+2 SUBI T,8 RDL2A2: CAIL T,8 JRST RDL2A0 JUMPE T,RDL2A3 RDL2A1: MOVE TT+2,TT+1 FMPRI TT+2,(10.0) FMPL TT,[10.0] UFA TT+1,TT+2 FADL TT,TT+2 SOJG T,RDL2A1 RDL2A3: SETZ R, JRST RDFL2E RDLST: AOS BFPRDP PUSH P,T ;*** READ LIST *** PUSH P,R70 ;POINTER TO LAST OF FORMING LIST HRLZI T,2 JRST RDLST3 RDLSTA: TLZE T,2 ;"ADD" AN ITEM TO A FORMING LIST JRST RDLSAA HLR B,(P) ;IFN NEWRD,?? HRRM A,(B) JRST (TT) RDLSAA: MOVEM A,(P) JRST (TT) RDHNK1: TLZN T,4060 ;IF THE NULL ITEM, FOLLOWED BY %RP JRST RDLSX ; FOR HUNK, THEN EXIT. RDLST1: PUSHJ P,NCONS ;GOT NEXT ITEM FOR LIST (OR HUNK) JSP TT,RDLSTA HRLM A,(P) RDLST0: MOVE B,AR2A ;ZAP OUT OBJECT BITS, EXCEPT FOR "HUNK" AND RDHNKA: TLZA T,-1#200002; "FIRST OBJECT" (MAYBE null splicing macro RDLST3: JSP TT,RDCHAR ; causes return to here with nothing accumulated). RDLS3Y: PUSHJ P,RDOBJ TLZE T,4 JRST RDLST4 ;OJBECT JUST READ WAS PRECEEDED BY A DOT MOVEM B,AR2A TLZE T,20000 JRST RDLS3D ;MACRO-PRODUCED OBJ RETURNED TLNE T,200000 JRST RDHNK1 ;CONTINUING WITH A HUNK TLNE T,24060 ;EXIT IF NO OBJECT READ JRST RDLST1 RDLSX: TLNN B,RS%RP LERR EMS6 ;BLAST, MISSING ")" SOS BFPRDP POP P,A TLZE T,200000 PUSHJ P,MAKHUNK POP P,T RDLSX1: MOVSI B,RS% ;THROWAWAY BREAK-CHARACTER TLO T,4000 POPJ P, RDLS3D: TLNN T,4060 ;MACRO-OBJECT RETURNED WITHIN A LIST JRST RMCER TLNN T,1000 JRST RDLST1 ;NORMAL MACRO OBJECT TLZ T,-1#200002 ;DONT FLUSH "HUNK" OR "1ST OBJ OF LIST" BITS JUMPE A,RDLST0 ;NIL is just ignored MOVEI TT,(A) ;Let's check this out, is this an atom? LSH TT,-SEGLOG ;Get the segment number SKIPL ST(TT) ;Is it a CARCDRable? JRST RDSMER ; yes, let him know he lost JSP TT,RDLSTA JSP AR1,RLAST ;SPLICING MACRO OBJECT HRLM A,(P) JRST RDLST0 RDLST4: JUMPN T,RDLS4A ;OJBECT JUST READ WAS PRECEEDED BY A DOT SKIPN VMAKHUNK JRST ER2 TLO T,200000 ; BUT NOTHING AFTER THE DOT EXCEPT A %RP JRST RDLSX RDLS4A: TLNE T,2 ;*** DOT PAIR *** JRST ER2 TLZ T,60 TLNE T,200000 ;COMBINATION OF "HUNK" AND "DOT" BITS ON JRST RDLSX ; WHEN EXITING FROM RDOBJ MEANS ".)" CASE MOVS TT,(P) HRRM A,(TT) TLZE T,20000 TLZN T,1000 ;OJBECT IMMEDIATELY FOLLOWING "DOT" IS JRST RDLS4B MOVE AR2A,RCT0+". ;MACRO-PRODUCED SPLICING OBJECT AS "DOT"+OBJ JUMPE A,RDLST0 ;THROW AWAY IF RETURN () HRRZ AR2A,(A) JUMPN AR2A,ER2 HLRZ A,(A) HRRM A,(TT) RDLS4B: PUSHJ P,RDSKWH ;SCAN CHARS FOLLOWING OBJ TO RIGHT OF DOT JRST RDLSX ; HOPEFULLY, NEXT INTERESTING ONE IS A %RP TLNE B,RS%DOT JRST RDHNK ;IF ITS ANOTHER DOT, THEN WE HAVE A HUNK TLNE B,RS%MAC NWTNN B,RS.ALT JRST ER2 PUSHJ P,RDOBJM ;SPLICING MACRO AFTER "DOT"+OBJECT JUMPE A,RDLS4B ;THROW AWAY IF RETURN () JRST RDSME2 ;Otherwise, it's gotta be an error! RDHNK: SKIPN VMAKHUNK JRST ER2 TLO T,200000 ;BEGIN NOTICING THAT THIS IS A HUNK MOVS TT,(P) HRRZ A,(TT) ;UNDO THE CDR OF THE CELL PUSHJ P,NCONS HRRM A,(TT) HRLM A,(P) PUSHJ P,RDSKWX ;SCAN CHARS FOLLOWING OBJ TO RIGHT OF DOT JRST RDLSX ; HOPEFULLY, NEXT INTERESTING ONE IS A %RP JRST RDHNKA RDSKWH: TLNE B,RS%RP ;RIGHT PAREN? THEN EXIT NORMALLY POPJ P, NWTN E,B,WTH JRST POPJ1 ;EXIT BY SKIPPING IF "INTERESTING" CHAR IS NOT PARENS RDSKWX: JSP TT,RDCHAR ;IF CHAR IS UNWORTHY, THEN FLUSH IT AND TRY AGAIN JRST RDSKWH RDOBM2: PUSHJ P,RDOBJM ;Get the object. TLNE T,4 ;Was this proceeded by a .? TLNN T,1000 ; And splicing? POPJ P, ; NO JRST RDSMCK ;Yes, do error checking and return RDOBJM: TLO T,20000 ;*** MACRO CHARACTER *** NWTNE B,RS.ALT ;SPLICING? TLO T,1000 ;SPLICING MACRO PUSH P,T PUSH FXP,BFPRDP NW% CALLF 0,(B) ;MACRO CHARACTER HAS LINK IN RH OF IFN NEWRD,[ LDB D, [001100,,B] PUSHJ P, GETMAC HRRZ A, (A) CALLF 0, (A) ] ;END OF IFN NEWRD POP FXP,BFPRDP JSP T,RSXST POP P,T JRST RDLSX1 RDSMCK: JUMPE A,CPOPJ ;NIL is always OK PUSH FXP,T ;Temp MOVEI T,(A) ;Copy LSH T,-SEGLOG ;Get the type bits SKIPL ST(T) ;Can it be CARCDRed? JRST RDSME1 ; No, barf about it (ILLEGAL RETURN VALUE FROM ...) POP FXP,T HRRZ B,(A) ;CDR the frob JUMPN B,RDSMER ; Error if more than one POPJ P, RDALPH: TLO T,20 ;*** PNAME ATOM *** SETOM LPNF RDA0: JSP TT,IRDA1 RDA1: IDPB B,C RDA3: JSP TT,RDCHAR SOJG D,RDA1 MOVEM B,AR2A PUSHJ FXP,RDA4 MOVE B,AR2A JRST RDA0 RDA4: PUSHJ P,PNCONS ;ADDS ANOTHER SEGMENT TO A LONG PNAME LIST AOSN LPNF PUSH P,R70 MOVE B,(P) EXCH A,B PUSHJ P,.NCONC MOVEM A,(P) POPJ FXP, RLAST: JUMPE A,(AR1) RLAST1: HRRZ TT,(A) JUMPE TT,(AR1) LSH TT,-SEGLOG SKIPL ST(TT) JRST RMCER HRRZ A,(A) JRST RLAST1 RDCHO1: MOVE AR1,B NWTNN B,RS.PNT JRST RDCHO3 JSP TT,RDCHAR ;. AS SCO ALSO HAS DECIMAL PT. SYNTAX NWTNE B,RS.DIG JRST RDOBJ5 ;WILL TAKE AS FLOTING PT. NUM NWTN N,B,WTH ;SKIP IF WORTHY CHAR JRST RDCHO3 ;CAN TOSS OUT NEXT UNWORTHY CHAR RDCHO4: PUSH FXP,B ;OTHERWISE, SAVE NEXT CHAR AS IF IT WERE IMPORTANT BREAK CHAR SKIPA C,[RDCHO2] RDCHO3: MOVEI C,RDLSX1 MOVE B,AR1 PUSH P,C RDCHO: JSP TT,IRDA ;*** SINGLE CHARA OBJECT *** SETZM PNBUF IDPB B,C JRST RINTERN RDCHO2: POP FXP,B ;AFTER MAKING UP . AS SCO, MOVEM B,RDBKC ;MAKE NEXT CHAR LOOK LIKE TLO T,20 ;IMPORTANT BREAK CHAR POPJ P, IFN BIGNUM,[ RD10OV: TLO T,40000 JSP A,RDRGSV PUSHJ P,C1CONS MOVE AR1,A JRST RDBG1A RDIBOV: TLO T,100000 JSP A,RDRGSV PUSHJ P,C1CONS MOVE AR2A,A JRST RDBGIA RDBG10: TLNE T,3000 JRST RDNUMD ;GETTING EXPONENT MODIFIER JSP A,RDRGSV RDBG1A: MOVE T,AR1 MOVEI D,-"0(B) NW$ ANDI D,177 MOVEI TT,10. PUSHJ P,.TM.PL MOVE T,TSAVE TLNE T,100000 JRST RDBGIA JSP A,RDRGRS JRST RDNUMB RDBGIB: TLNE T,3000 JRST RDNUMB ;GETTING EXPONENT MODIFIER JSP A,RDRGSV RDBGIA: MOVE T,AR2A MOVE TT,RDIBS MOVEI D,-"0(B) NW$ ANDI D,177 PUSHJ P,.TM.PL JSP A,RDRGRS JRST RDNUM1 .RDMULP: SKIPA T,A .TIMER: MOVEI D,0 ;T IS LIST OF DIGITS, TT IS MULTIPLIER, .TM.PL: HLRZ A,(T) ;D IS CARRY. MOVE R,(A) MUL R,TT ADD R+1,D TLZE R+1,400000 AOS R MOVEM R+1,(A) MOVE D,R HRRZ A,(T) JUMPN A,.RDMULP JUMPE D,CPOPJ MOVE TT,D PUSHJ P,C1CONS HRRM A,(T) POPJ P, ;;; IFN BIGNUM RDRGSV: MOVEM T,TSAVE MOVEM D,DSAVE MOVEM R,RSAVE MOVEM F,FSAVE JRST (A) RDRGRS: MOVE T,TSAVE MOVE D,DSAVE MOVE R,RSAVE MOVE F,FSAVE JRST (A) RDEXOF: TLO T,100000 PUSH FXP,TT+1 PUSHJ P,C1CONS MOVE B,A POP FXP,TT PUSHJ P,C1CONS HRRM B,(A) TLNE T,400 TLO A,-1 JRST RX1 RDEX3: PUSH P,A MOVEM T,TSAVE MOVE T,A MOVE TT,RDIBS PUSHJ P,.TIMER MOVE T,TSAVE POP P,A JRST RX1 RDBIGN: TLNE T,3000 JRST RDBGEX HRLI A,0 ;CREATE BIGNUM SIGN TLNE T,400 TLO A,-1 TLNE T,100000 TLNE T,300 JRST RDCBG HRR A,AR2A RDBIGM: PUSHJ P,BNTRSZ MOVE TT,[400000,,0] JRST RDFX1 PUSHJ P,BNCONS MOVE B,RDBKC POPJ P, ;;; IFN BIGNUM RDBGEX: TLNE T,200 JRST RDBXFL MOVEI D,1 TLNE T,2000 JRST RDBFSH JUMPLE TT,RDBGXM IMUL D,RDIBS ;^(TT) SOJG TT,.-1 RDBGXM: MOVE TT,D MOVEM T,TSAVE HRRZ T,AR2A PUSHJ P,.TIMER MOVE A,AR2A MOVE T,TSAVE JRST RDBIGM RDBFSH: LSH D,(TT) ;_(TT) JRST RDBGXM RDBXFL: ADD TT,RDDSV SUBI TT,BYTSWD*LPNBUF MOVE A,AR2A JRST RDCBG1 RDCBG: TLNN T,300 JRST RDNM2B HRR A,AR1 TLNN T,200 JRST RDBIGM HRREI TT,-BYTSWD*LPNBUF-1(D) RDCBG1: PUSH FXP,TT ;THIS IS THE POWER-OF-TEN EXPONENT MOVE TT,A PUSHJ P,FLBIGZ POP FXP,R JFCL 8.,RDNMER JUMPGE A,RDFL3A DFN TT,TT+1 JRST RDFL3A RDNM2B: TLZ T,140000 ;A BIGNUMBER BASE 10. WAS REALLY A REGNUM JRST RDNM2A ;BASE IBASE, BUT BIG ENOUGH TO OVFLO BASE 10. CALC ] ;END OF IFN BIGNUM SUBTTL READER SINGLE-CHARACTER FILTER ;;; ***** READ ONE CHARACTER (FOR READ) ***** RDCHAR: PUSHJ P,@RDINCH MOVE B,@RSXTB RDCH1: NW% JUMPGE B,(TT) NW$ NWTNE B,RS%BRK NW$ JRST (TT) NWTN E,B,[] JRST RDBK ;BREAKING CHAR FOUND NWTN N,B,WTH JRST RDCHAR ;WORTHLESS CHAR TLNN B,RS%SLS JRST (TT) ;ALPHABETIC CHAR WITH BREAK BIT SOMEHOW SET PUSHJ P,@RDINCH ;/ NW% HRR B,A ;PUT EXTENDED ALPHABETIC SYNTAX ON THIS CHAR NW% HRLI B,2 NW$ MOVEI B,RS.XLT(A) JRST (TT) RDBK: MOVEM B,RDBKC TLNN T,60 JRST (TT) TLNN T,20 ;From here down, we're reading literal token JRST RDNUM4 PUSHJ FXP,RDAEND ;Symbol IFN USELESS, SKIPE RDROMP IFN USELESS, PUSHJ P,RDROM PUSHJ P,RINTERN RDNMX: MOVE B,RDBKC POPJ P, RDNUM4: TLNN T,300 TLNN B,200 JRST RDNM4A PUSHJ P,@RDINCH ;. FOUND MOVE B,@RSXTB NWTN N,B,SEE JRST .-3 ;CONTROL-CHARS ARE IGNORED MOVEI D,BYTSWD*LPNBUF+1 NWTNE B,RS.DIG TLOA T,200 TLO T,100 JRST RDCH1 RDNM4A: TLNE B,RS.SGN TLNN T,3000 JRST RDNMF ;TERMINATES A NUMBER TOKEN, UNLESS A SIGN IS JRST (TT) ;FOLLOWING AN EXPONENTIATOR IFN USELESS,[ RDROM: SKIPGE LPNF SKIPN PNBUF POPJ P, MOVEI D,(C) CAIL D,PNBUF+LPNBUF-1 ;TOO BIG TO DO ANOTHER ILDB ? POPJ P, PUSH FXP,C SETZB TT,D IDPB D,C MOVE C,[440700,,PNBUF] RDROM1: ILDB F,C JUMPN F,RDROM2 PUSH FXP,T JSP T,FXCONS POP FXP,T SUB FXP,R70+1 JRST POPJ1 RDROM2: SETZ R, IRP X,,[M,D,C,L,X,V,I]N,,[1000.,500.,100.,50.,10.,5,1] CAIN F,"X MOVEI R,N TERMIN JUMPE R,RDROM7 ADDI TT,(R) CAIG R,(D) JRST RDROM3 REPEAT 2, SUBI TT,(D) RDROM3: MOVEI D,(R) JRST RDROM1 RDROM7: POP FXP,C POPJ P, ] ;END OF IFN USELESS RDAEND: LSHC B,6 DPB B,[360600,,C] SETZM B LSHC B,-6 DPB B,C SKIPGE LPNF POPJ FXP, PUSHJ P,PNCONS ;DESTROYS TT POP P,B EXCH A,B PUSHJ P,.NCONC POPJ FXP, IRDA: SETOM LPNF ;INITIALIZE FOR READING PNAME-TYPE ATOM IRDA1: MOVE C,PNBP MOVEI D,BYTSWD*LPNBUF JRST (TT) RDIN: PUSHJ FXP,SAV5M1 PUSHJ P,SAVX5 PUSHJ P,@TYIMAN MOVEI A,(TT) ;***** GRUMBLE ***** PUSHJ FXP,RST5M1 JRST RSTX5 SUBTTL BUILT-IN MACRO CHARACTER PROCESSORS ;;; SINGLE QUOTE PROCESSOR: ;;; 'FOO => (QUOTE FOO) RDQTE: PUSHJ P,READ ;FOR THE WHITE SINGLE-QUOTE HAC PUSHJ P,NCONS MOVEI B,QQUOTE JRST XCONS ;;; SEMICOLON COMMENT PROCESSOR: (SPLICING) ;;; ; -- ANYTHING -- => NIL, HENCE IGNORED RDSEMI: PUSHJ P,RDSMI0 JUMPE A,CPOPJ ;OK, FOUND CR LERR EMS10 ;HMMM, HIT E-O-F BEFORE CR RDSMI0: MOVNI T,1 PUSH P,T JSP D,INCALL QRDSEMI ;THIS SHOULD NEVER [!!] BE USED RDSMI1: PUSHJ P,TYI SA$ CAIE A,%TXCTL+"M SA$ CAIN A,%TXCTL+"m SA$ JRST FALSE ;YET ANOTHER GODDAM SAIL CHARACTER SET SCREWUP CAIE A,15 ;CR JRST RDSMI1 JRST FALSE ;;; VERTICAL BAR PROCESSOR: ;;; |ANYTHING| => /A/N/Y/T/H/I/N/G ;;; I.E. IT IS A SUPER SYMBOL QUOTER (ALMOST LIKE ""'S) RDVBAR: SKIPA T,["|] RDDBLQ: MOVEI T,"" PUSH FXP,T PUSH FXP,R70 ;WATCH OUT - THESE SLOTS USED BY RDVB2 JSP T,GTRDTB MOVEI T,RDVB3 PUSHJ FXP,MKNR6C SUB FXP,R70+1 POP FXP,T CAIN T,"| JRST RINTERN PUSHJ P,PNGNK1 ;FOR " MOVE AR1,A JSP T,.SET POPJ P, ;HAPPILY, THE RESULT IS ALSO IN A RDVB2: SETOM -1(FXP) RDVB3: PUSH FXP,D PUSHJ P,TYI POP FXP,D CAIN TT,203 ;RARE CASE WHEN | IS CALLED FROM WITHIN JRST RDVB3 ; A READLIST - MAY SEE A PSEUDO-SPACE. CAIN TT,^J SKIPN -1(FXP) JRST RDVB4 SETZM -1(FXP) JRST RDVB3 RDVB4: SETZM -1(FXP) CAMN TT,-2(FXP) POPJ P, SKIPGE T,@TTSAR(AR2A) TLNN T,2000 JRST POPJ1 PUSH FXP,D PUSHJ P,TYI POP FXP,D CAIN TT,^M SETOM -1(FXP) JRST POPJ1 ;;; SPLICING MACRO CHARACTER FUNCTIONS FOR ^Q AND ^S. CTRLQ: MOVEI A,TRUTH MOVEM A,TAPRED JRST FALSE CTRLS: SETZM TTYOFF JRST TERPRI SUBTTL NEWIO TTY PRESCAN, RUBOUT HANDLER, AND READLINE ;;; INITIAL TTY CHARACTER BUFFERING ROUTINE. ;;; BUFFERS UP A LIST OF CHARACTERS FOR TTY INPUT. ;;; HANDLES ALL APPROPRIATE RUBOUT PROCESSING. ;;; ARGUMENTS ARE A TTY INPUT FILE ARRAY IN A, ;;; THE FUNCTION TO BUFFER FOR IN B (E.G. QOREAD), ;;; AND THE COUNT OF UNMATCHED LEFT PARENS IN C. ;;; RUBOUT ECHOING IS PERFORMED ON THE ASSOCIATED OUTPUT ;;; TTY, IF ANY. HAIRY ERASING RUBOUT IS DONE FOR DISPLAYS. ;;; NO RUBOUT HACKING IS DONE IF THERE IS NO ECHO FILE. ;;; THESE ARE COMPATIBLE WITH THE ITS DEFINITIONS: %TXMTA==:400 ;META BIT %TXCTL==:200 ;CONTROL BIT %TXASC==:177 ;ASCII CODE TTYBUF: JSP T,SPECBIND VECHOFILES 0 A,VINFILE CAIN A,TRUTH HRRZ A,V%TYI PUSH FXP,(C) CAIE C,QOREAD SETZM (FXP) JSP T,GTRDTB ;GET READTABLE;AR2A 4.9 = USEFULP CAIN B,Q%READLINE ;AR2A 4.9 => USEFULP TLO AR2A,200000 ;AR2A 4.8 => READLINE MOVEI TT,LRCT-2 HLRZ C,@TTSAR(AR2A) SKIPE C TLO AR2A,100000 MOVEI TT,FT.CNS ;GET ASSOCIATED OUTPUT TTY SKIPE C,@TTSAR(A) ; (THE SIGN BIT TELLS TYO6 THIS IS ONE FILE) PUSHJ P,TTYBRC ;MAYBE GET CURCOR POSITION IN D PUSH FXP,D PUSH FXP,-1(FXP) ;PARENS COUNT MOVEI TT,F.MODE MOVE R,@TTSAR(A) ;GET INPUT FILE MODE BITS PUSH FXP,R PUSH FXP,XC-1 ;PUSH -1 (NOT IN STRING YET) SETZ B, ;B HOLDS LIST OF CHARACTERS HRRZS BFPRDP ;WE WANT NO CLEVERNESS FROM $DEVICE ;STATE OF THE WORLD: ; B HAS LIST OF BUFFERED CHARS (IN REVERSE ORDER) ; C HAS TTY OUTPUT FILE ARRAY ; AR2A HAS READTABLE ; 4.9 => USEFUL CHAR SEEN ; 4.8 => READLINE INSTEAD OF READ ; 4.7 => (STATUS TTYREAD) = T ; VINFILE HAS TTY INPUT FILE ARRAY ; FXP: STRING TERMINATOR CHAR (-1 IF NOT IN STRING) ; MODE BITS FOR INPUT FILE ; PARENTHESIS COUNT ; SAVED CURSOR POSITION ; ORIGINAL PARENS COUNT TTYB1: PUSHJ P,TTYBCH ;GET A CHARACTER MOVE D,@TTSAR(AR2A) ;GET READTABLE SYNTAX MOVE R,-1(FXP) ;GET MODE BITS IFN SAIL,[ CAIE TT,%TXCTL+"M CAIN TT,%TXCTL+"m JRST TTYB1E ] ;END IFN SAIL CAIE TT,^M JRST TTYB7 TTYB1E: TLNE AR2A,200000 ;CR TERMINATES READLINE JRST TTYB9 TLNN R,FBT ;SKIP IF LINE MODE JRST TTYB2 MOVEI TT,203 ;PSEUDO-SPACE TLNN AR2A,200000 ;SKIP IF HACKING A STRING JSP R,TTYPSH ;ELSE PUSH CHAR ONTO BUFFER SA% MOVEI TT,^M SA$ MOVEI TT,%TXCTL+"M JRST TTYB9 ;ALL DONE TTYB7: IFN SAIL,[ CAIE TT,%TXCTL+"K CAIN TT,%TXCTL+"k ;LOWER CASE K JRST TTYB7E ; TLNN R,FBT ] ;END OF IFN SAIL CAIE TT,^K ;FOR A ^K, WE TERPRI JRST TTYB7F ; AND THEN RETYPE THE BUFFER TTYB7E: SKIPN AR1,C JRST TTYB1 TTYB7G: PUSHJ P,ITERPRI JRST TTYB7N TTYB7F: IFN SAIL,[ CAIE TT,%TXCTL+"L CAIN TT,%TXCTL+"l ;LOWER CASE L JRST TTYB7E ; TLNN R,FBT ] ;END OF IFN SAIL CAIE TT,^L ;RPUSH FXPFOR ^L, WE CLEAR THE SCREEN, JRST TTYB2 ; THEN RETYPE THE BUFFER TTYB7H: SKIPN AR1,C JRST TTYB1 MOVEI TT,F.MODE MOVE R,@TTSAR(AR1) TLNN R,FBT ;IF WE CAN'T CLEAR THE SCREEN, JRST TTYB7G ; WE JUST MAKE LIKE ^K PUSHJ P,CLRSRN TTYB7N: PUSHJ P,TTYBRC ;READ THE TTY CURSOR POSITION MOVEM D,-3(FXP) PUSHJ P,TTYBLT ;ZAP OUT TTY BUFFER JRST TTYB1 IFN D10,[ CLRSRN: PUSH P,A ;SAVE A OVER TYO MOVEI A,14 ;^L PUSHJ P,TYO POP P,A POPJ P, ];END IFN D10 TTYB2: TLNN AR2A,200000 ;READLINE IGNORES SLASHES TLNN D,2000 .SEE SYNTAX ;SLASH JRST TTYB4 JSP R,TTYPSH PUSHJ P,TTYBCH TLO TT,400000 ;SLASHIFIED CHAR TTYB3: TLO AR2A,400000 ;USEFUL FROB SEEN TTYB3A: JSP R,TTYPSH JRST TTYB1 TTYB4: TLNE D,1000 .SEE SYNTAX ;RUBOUT TLNE D,40 .SEE SYNTAX ;NOT SECOND CHOICE JRST TTYB5 JUMPN B,TTYB4C HRRZ T,BFPRDP JUMPE T,TTYB9J ;RETURN TO CALLER FOR EOF SKIPE AR1,C ;OOPS! INSIDE READ ALREADY! PUSHJ P,ITERPRI ; WE MUST SIMPLY TERPRI JRST TTYB1 ; (IF POSSIBLE) AND TRY IT AGAIN TTYB4C: PUSHJ P,RUB1CH ;RUB OUT CHAR SKIPL TT,(A) ;SKIP IF CHAR WAS SLASHIFIED JRST TTYB4G PUSHJ P,RUB1CH ;RUB OUT SLASH TOO JRST TTYB1 TTYB4G: SKIPL (FXP) ;SKIP UNLESS IN STRING JRST TTYB4J TLNE TT,100000 JRST TTYB4M MOVE D,@TTSAR(AR2A) ;GET CHARACTER SYNTAX TLNE D,40000 .SEE SYNTAX ;OPEN PAREN SOS -2(FXP) TLNE D,10000 .SEE SYNTAX ;CLOSE PAREN AOS -2(FXP) JRST TTYB1 TTYB4J: TLNE TT,200000 ;RUBBED OUT BACK OUT OF STRING SETOM (FXP) JRST TTYB1 TTYB4M: HRRZM TT,(FXP) ;RUBBED OUT BACK INTO A STRING JRST TTYB1 TTYB5: TLNE AR2A,200000 ;GO BACK AROUND IF READLINE JRST TTYB3A SKIPGE R,(FXP) ;SKIP IF IN STRING JRST TTYB5H CAIE R,(TT) JRST TTYB3A TLO TT,100000 ;MARK AS STRING END SETOM (FXP) JRST TTYB3A TTYB5H: TLNE D,1000 .SEE SYNTAX ;FORCE FEED TLNN D,40 .SEE SYNTAX ;SECOND CHOICE JRST TTYB5K JSP R,TTYPSH JRST TTYB9A TTYB5K: TLNN D,100000 .SEE SYNTAX ;SPACE JRST TTYB6 TTYB5M: JSP T,TTYATM JRST TTYB3A TTYB6: TLNN D,200000 .SEE SYNTAX ;SINGLE CHAR OBJECT JRST TTYB6C TLO AR2A,400000 ;USEFUL THING SEEN JRST TTYB5M TTYB6C: TLNN D,4000 JRST TTYB6J ;NOT A MACRO CHAR HRRZ R,VTSCSR ; ((#/; . #\CR) (#/| . #/|) (#/" . #/")) MOVS F,(R) MOVS T,(F) CAMN TT,(T) JRST .+4 HLRZ R,F JUMPN R,.-5 JRST TTYB6J ;NOT A STRING-LIKE MACRO CHAR MOVSS T MOVE F,(T) TLO AR2A,400000 ;USEFUL FROB SEEN TLO TT,200000 ;STRING BEGIN MOVEM F,(FXP) JRST TTYB3 TTYB6J: TLNN D,40000 .SEE SYNTAX ;OPEN PAREN JRST TTYB6Q AOS -2(FXP) JRST TTYB3 TTYB6Q: TLNN D,10000 .SEE SYNTAX ;CLOSE PAREN JRST TTYB8 JSP T,TTYATM SOSLE -2(FXP) JRST TTYB3 TTYB9: JSP R,TTYPSH TLNN AR2A,100000 JRST TTYB1 ;ONLY FORCE-FEED ENDS TTYSCAN TTYB9A: JUMPE C,TTYB9B PUSHJ P,TTYBRC MOVEI TT,AT.LNN ;UPDATE LINENUM AND CHARPOS HLRZM D,@TTSAR(C) ; OF ASSOCIATED OUTPUT FILE MOVEI TT,AT.CHS HRRZM D,@TTSAR(C) TTYB9B: MOVEI A,(B) PUSHJ P,NREVERSE MOVEI B,(A) MOVEI C,(A) TTYB9D: JUMPE C,TTYB9J HLRZ A,(C) MOVE TT,(A) TLZE TT,-1 JSP T,FXCONS HRLM A,(C) HRRZ C,(C) JRST TTYB9D TTYB9J: POPI FXP,5 MOVEI A,(B) JRST UNBIND TTYB8: TLNE D,277237 .SEE SYNTAX ;SKIP IF NOT WORTHY CHAR JRST TTYB3 JRST TTYB3A IFN ITS,[ RCPOS: SETZ SIXBIT \RCPOS\ ;READ CURSOR POSITION ,,@TTSAR(AR1) ;TTY CHANNEL # 2000,,D ;MAIN PROGRAM CURSORPOS 402000,,R ;ECHO AREA CURSORPOS ] ;END OF IFN ITS TTYBRC: HRROS AR1,C ;GET CURSOR POSITION IN D TTYBR1: MOVE TT,TTSAR(AR1) PUSHJ P,IFORCE IFN ITS,[ MOVEI TT,F.MODE MOVE F,@TTSAR(AR1) MOVEI TT,F.CHAN ;C HAS OUTPUT FILE FOR ECHOING .CALL RCPOS ;READ CURSOR POSITION INTO D .VALUE TLNE F,FBT MOVE D,R ;MAYBE NEED ECHO AREA CURSOR POPJ P, ] ;END OF IFN ITS IFN D10,[ SETZ D, ;? WHAT TO DO? POPJ P, ] ;END OF IFN D10 IFN D20,[ PUSHJ FXP,SAV3 ;PRESERVE LOW THREE AC'S MOVEI TT,F.JFN HRRZ 1,@TTSAR(AR1) RFPOS MOVE D,2 PUSHJ FXP,RST3 POPJ P, ] ;END OF IFN D20 TTYPSH: IFN 0,[ ANDI TT,%TXCTL+%TXASC ;? FOLD CHARACTER DOWN TO 7 BITS TRZN TT,%TXCTL JRST TTYPS1 CAIE TT,177 TRZ TT,140 TTYPS1: ] ;END OF IFN 0 JSP T,FXCONS ;PUSH CHAR IN TT ON FRONT PUSHJ P,CONS ; OF LIST OF BUFFERED CHARS MOVEI B,(A) JRST (R) TTYATM: JUMPGE AR2A,(T) ;DECIDE WHETHER WE MAY HAVE MOVE R,-1(FXP) ; TERMINATED A TOP LEVEL ATOM, SKIPG -2(FXP) ; AND IF SO GO TO TTYB9 AND OUT TLNE R,FBT ;WE HAVE *NOT* TERMINATED IF: JRST (T) ; NO USEFUL CHARS SEEN YET TLNN AR2A,100000 ; (STATUS TTYREAD) = NIL JRST (T) ; OPEN PARENS ARE HANGING JRST TTYB9 ; TTY INPUT IS IN LINE MODE TTYBCH: PUSHJ P,$DEVICE ;GOBBLE A CHARACTER IFN ITS,[ ANDI TT,%TXCTL+%TXASC ;FOLD CHARACTER TO 7 BITS TRZN TT,%TXCTL POPJ P, CAIE TT,177 TRZ TT,140 MOVEI D,(TT) ;ATTEMPT TO FLUSH INTERRUPT CHARS ROT TT,-1 ADDI TT,FB.BUF ;REALLY SHOULD BE MORE CLEVER HRRZ AR1,VINFILE HLRZ R,@TTSAR(AR1) SKIPGE TT HRRZ R,@TTSAR(AR1) JUMPN R,TTYBCH MOVEI TT,(D) ] ;END OF IFN ITS POPJ P, TTYBLT: SKIPN AR1,C POPJ P, MOVEI A,(B) ;TYPE OUT ALL BUFFERED CHARS PUSHJ P,NREVERSE ; ONTO THE ECHO OUTPUT FILE MOVEI B,(A) SKIPG -4(FXP) ;IF WE ENTERED WITH HANGING JRST TTYBL1 ; PARENS, PRINT THEM PUSH FXP,-4(FXP) TTYBL4: MOVEI TT,"( PUSHJ P,TYOFIL SOSLE (FXP) JRST TTYBL4 SUB FXP,R70+1 MOVEI TT,40 PUSHJ P,TYOFIL TTYBL1: JUMPE B,TTYBL2 ;ECHO ALL CHARS TO ECHO TTY HLRZ C,(B) HRRZ TT,(C) PUSHJ P,TYOFIL HRRZ B,(B) JRST TTYBL1 TTYBL2: PUSHJ P,NREVERSE MOVEI B,(A) ;RESTORE BACKWARDS LIST OF CHARS MOVE C,AR1 ;RESTORE C (NREVERSE CLOBBERED) POPJ P, RUBOUT: MOVEI D,QRUBOUT ;LSUBR (1 . 2) CAMGE T,XC-2 JRST WNALOSE JUMPE T,WNALOSE CAME T,XC-2 SKIPA AR1,V%TYO POP P,AR1 POP P,A JSP F,TYOARG MOVEI A,(TT) PUSHJ P,TOFLOK PUSHJ P,RUB1C1 JRST UNLKTRUE SETZ A, UNLKPOPJ RUB1CH: HLRZ A,(B) ;DELETE CHAR FROM BUFFERED LIST HRRZ B,(B) JUMPE C,CPOPJ ;THAT'S IT IF NO ECHO FILE PUSH P,A HRRZ A,(A) ;GET CHARACTER IN A MOVEI AR1,(C) PUSHJ P,RUB1C1 JRST POPAJ IT$ PUSHJ P,RSTCUR ;MUST RETYPE WHOLE STRING IN PLACE PUSHJ P,TTYBLT IT$ PUSHJ P,CNPL JRST POPAJ IFN ITS,[ RSTCUR: ;RESTORE SAVED CURSOR POSITION HLLZ D,-3(FXP) ;FOR ITS, USE ^P CODES TO SET HRRI D,"V-10 ; CURSOR POSITION PUSHJ P,RSTCU3 HRLZ D,-3(FXP) HRRI D,"H-10 RSTCU3: ADD D,R70+10 JRST CNPCOD ] ;END OF IFN ITS 20$ HALT 20$ WARN [WHAT TO DO ABOUT RSTCUR?] ;;; ROUTINE WHICH ATTEMPTS TO RUB OUT A CHARACTER ON A TTY. ;;; SKIPS ON *FAILURE* TO RUB IT OUT. ;;; OUTPUT TTY FILE ARRAY MUST BE IN AR1. RUB1C1: MOVEI TT,F.MODE MOVE F,@TTSAR(AR1) TLNE F,FBT ;IF CAN'T SELECTIVELY ERASE TLNN F,FBT ; AND MOVE CURSOR AROUND FREELY, JRST TYOFA ; MERELY ECHO RUBBED-OUT CHAR IT% HALT IFN ITS,[ CAIN A,177 ;RUBOUT DOESN'T PRINT, HENCE NEEDN'T KILL POPJ P, MOVEI T,1 CAILE A,^_ ;CHARS FROM 40 TO 176 ARE ONE JRST RUB1C3 ; POSITION WIDE, SO BACK UP AND ERASE CAIN A,^I ;TABS ARE VARIABLE - MUST RETYPE JRST POPJ1 CAIN A,^J ;LINE FEED IS DOWNWARD MOTION - JRST CNPU ; ERASE BY MOVING UP CAIN A,^H ;BACKSPACE IS ERASED BY JRST CNPF ; MOVING FORWARD CAIE A,^M ;FOR CR, DON'T KNOW LENGTH OF PREVIOUS LINE CAIN A,^_ ;FOR ^_, MAY OR MAY NOT HAVE BEEN DOUBLED JRST POPJ1 CAIE A,33 ;ALTMODE IS ALWAYS 1 WIDE TLNE F,FBT ;OTHER CONTROLS ONE WIDE IF IN SAIL MODE JRST RUB1C3 MOVEI T,2 ;OTHERWISE CONTROL CHARS ARE TWO WIDE RUB1C3: MOVEI TT,F.CHAN .CALL RCPOS .VALUE TLNE F,FBT MOVE D,R MOVEI R,(T) CAILE T,(D) PUSHJ P,CNPU CAIE R,2 JRST CNPBL JRST CNPBBL ] ;END OF IFN ITS ;;; READLINE TAKES STANDARD FILE/EOF INPUT ARGUMENTS AND READS ;;; ONE LINE FROM A FILE. IT INVOKES PRE-SCANNING FOR TTY'S. ;;; THE RESULT IS RETURNED AS AN ATOMIC SYMBOL, EXCLUDING THE ;;; CARRIAGE RETURN WHICH TERMINATES THE LINE. LINE FEEDS ;;; ARE IGNORED (NECESSARY FOR SUCCESSIVE READLINE'S). %READLINE: JSP D,INCALL SFA% Q%READLINE SFA$ [SO.RDL,,],,Q%READLINE MOVEI A,Q%READLINE HRLZM A,BFPRDP ;PERMIT TTY PRE-SCAN MOVEI T,%RDLN5 PUSHJ FXP,MKNR6C ;PART OF MAKNAM JRST PNGNK1 ;CREATE NON-INTERNED SYMBOL %RDLN5: PUSH FXP,D %RDLN6: PUSHJ P,@TYIMAN IFN SAIL,[ ANDI TT,%TXCTL+%TXASC ;FOLD CHARACTER DOWN TO 7 BITS TRZN TT,%TXCTL JRST %RDLNZ CAIE TT,177 TRZ TT,140 %RDLNZ: ] ;END IFN SAIL CAIN TT,^J ;IGNORE LINE FEEDS JRST %RDLN6 POP FXP,D CAIN TT,^M ;CR TERMINATES POPJ P, MOVEI A,(TT) JRST POPJ1 PGTOP RDR,[HIRSUTE READER, MAKNAM, ETC.] ;;@ END OF READER 227 ;;@ ARRAY 85 ARRAY PACKAGE ;;; ***** MACLISP ****** ARRAY PACKAGE *************************** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT ARA SUBTTL ARRAY PACKAGE IFN SFA, QSFA IFN JOBQIO, QJOB ;THESE ENTRIES USED ONLY QFILE ; BY ARRAYDIMS FUNCTION ARYTP1: AS.RDT+AS.FX,,QREADTABLE ;READTABLE AS.OBA+AS.SX+AS.GCP,,QOBARRAY ;OBARRAY NPARTP==.-ARYTP1 ;# OF PECULIAR ARRAY TYPES DX$ AS.DX,,QDUPLEX ;DUPLEX DX% -1 CX$ AS.CX,,QCOMPLEX ;COMPLEX CX% -1 DB$ AS.DB,,QDOUBLE ;DOUBLE DB% -1 AS.SX+AS.GCP,,TRUTH ;S-EXPRESSION AS.FX,,QFIXNUM ;FIXNUM AS.FL,,QFLONUM ;FLONUM AS.SX,,NIL ;NSTORE-TYPE LARYTP==.-ARYTP1 ARYTYP==ARYTP1-.LZ (AS.RDT), .SEE ADIMS ;FOR JFFO'S ON THE BITS ;;; TABLE OF EXTRA INSTRUCTIONS FOR ARRAY HEADER. ;;; ENTRIES ARE ZERO IF NO INSTRUCTION NEEDED. ;;; ENTRIES ARE NEGATIVE FOR AN ILLEGAL ARRAY TYPE. ;;; (NOTE THAT THE OPCODE PUSH IS POSITIVE.) ARYIN1: 0 ;READTABLE 0 ;OBARRAY TBLCHK ARYIN1,NPARTP DX$ PUSH P,CDUPL1 ;DUPLEX DX% -1 CX$ PUSH P,CCMPL1 ;COMPLEX CX% -1 DB$ PUSH P,CDBL1 ;DOUBLE DB% -1 0 ;S-EXPRESSION PUSH P,CFIX1 ;FIXNUM PUSH P,CFLOAT1 ;FLONUM 0 ;NSTORE-TYPE TBLCHK ARYIN1,LARYTP ;;;
,, ;;; THE MULTIPLIER IS USED TO ADJUST FOR THE NUMBER OF WORDS ;;; OCCUPIED BY EACH ELEMENT. ARYIN2: DIMFTB,,1 ;READTABLE DIMSTB,,1 ;OBARRAY TBLCHK ARYIN2,NPARTP DX$ DIMZTB,,4 ;DUPLEX DX% 0 CX$ DIMDTB,,2 ;COMPLEX CX% 0 DB$ DIMDTB,,2 ;DOUBLE DB% 0 DIMSTB,,1 ;S-EXPRESSION DIMFTB,,1 ;FIXNUM DIMFTB,,1 ;FLONUM DIMSTB,,1 ;NSTORE-TYPE TBLCHK ARYIN2,LARYTP ;;; TABLES OF INSTRUCTIONS FOR CALLING ARRAY SUBSCRIPT ;;; CALCULATION ROUTINES. DIMSTB IS FOR S-EXPRESSION ;;; ARRAYS, AND DIMFTB FOR FULL-WORD ARRAYS. DIMSTB: JSP TT,1DIMS ;TABLE OF DIMS'S JSP TT,2DIMS JSP TT,3DIMS JSP TT,4DIMS JSP TT,5DIMS DIMFTB: JSP TT,1DIMF ;TABLE OF DIMF'S JSP TT,2DIMF JSP TT,3DIMF JSP TT,4DIMF JSP TT,5DIMF IFN DBFLAG+CXFLAG,[ DIMDTB: JSP TT,1DIMD JSP TT,2DIMD JSP TT,3DIMD JSP TT,4DIMD JSP TT,5DIMD ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ DIMZTB: JSP TT,1DIMZ JSP TT,2DIMZ JSP TT,3DIMZ JSP TT,4DIMZ JSP TT,5DIMZ ] ;END OF IFN DXFLAG SUBTTL ARRAY AND *ARRAY FUNCTIONS TTDEAD=BPURPG(TT) TTDEDC=TTDEAD+,,> ARRAY: JSP TT,FWNACK ;FSUBR FA234567,,QARRAY JSP TT,KLIST ;LIKE *ARRAY, BUT FIRST TWO SUBI T,2 ; ARGS NOT EVALUATED JRST ARRY0 %%ARRAY: JSP TT,LWNACK ;LSUBR (2 . 7) LA234567,,Q%%ARRAY ARRY0: MOVEI TT,(P) ADDI TT,(T) ;TT POINTS TO BELOW ARGS ON PDL HRRZ A,2(TT) ARRY0B: MOVSI F,-LARYTP ;CHECK OUT ARRAY TYPE ARRY0C: HRRZ B,ARYTP1(F) CAIN B,(A) JRST ARRY0F AOBJN F,ARRY0C WTA [BAD ARRAY TYPE - *ARRAY!] MOVEM A,2(TT) JRST ARRY0B ARRY0F: TLZ F,-1 ;F HAS ARRAY TYPE (INDEX INTO ARYTP1) CAIL F,NPARTP ;SKIP IF PECULIAR ARRAY TYPE JRST ARRY2 CAML T,XC-3 JRST ARRY1 ARRY0G: MOVEI D,Q%%ARRAY ;WRONG NUMBER OF ARGS - LOSEY LOSEY JRST WNALOSE ARRY1: HRRZ AR2A,ARRYQ1(F) ;DEFAULT ARRAY TO COPY FROM CAML T,XC-2 SOJA T,ARRY1F ;T REFLECTS # OF DIMS POP P,A ;GET THIRD ARG ARRY1A: HLRZ AR2A,ARRYQ2(F) ;ARRAY TO COPY FROM IF NIL JUMPE A,ARRY1F HRRZ AR2A,ARRYQ2(F) ;ARRAY TO COPY FROM IF T CAIN A,TRUTH JRST ARRY1F MOVEI C,(A) ;THIRD ARG BETTER BE AN ARRAY ITSELF MOVEI D,(T) PUSHJ P,AREGET ; TO COPY NEW ONE FROM MOVEI T,(D) HLLZ TT,ARRYQ1(F) ;SUPPLIED ARRAY BETTER BE TDNE TT,ASAR(A) ; OF CORRECT TYPE JRST ARRY1D MOVEI A,(C) %WTA ARRYQ0(F) ;IF NOT, LOSEY LOSEY JRST ARRY1A ARRYQ0: SIXBIT \NOT READTABLE - *ARRAY!\ SIXBIT \NOT OBARRAY - *ARRAY!\ ARRYQ1: AS.RDT,,VREADTABLE ;REQUIRED BIT,,NO ARG DEFAULT AS.OBA,,VOBARRAY ARRYQ2: VREADTABLE,,[PRDTBL] VNIL,,VOBARRAY ARRYQ3: 0,,2*LRCT ;MAX INDEX+1,,LENGTH OF DATA OBTSIZ+1+200,,OBTSIZ+1+200 ;FOOEY - GLS ARRYQ4: -1,,3 ;STANDARD GC AOBJN POINTER: -/2,,3 ; -,, ARRYQ5: RDTFIX ;FIXUP ROUTINE FOR AFTER BLT OBAFIX ARRY1D: SKIPA AR2A,A ARRY1F: HRRZ AR2A,(AR2A) ;AR2A HAS SAR OF ARRAY TO COPY FROM MOVNI AR1,2(T) ;AR1 HAS NUMBER OF DIMENSIONS PUSH FXP,INHIBIT ;HALF A LOCKI HRRZ R,ARRYQ3(F) ;R HAS LENGTH OF ARRAY DATA HLRZ D,ARRYQ3(F) ;D HAS 1+LARGEST LEGAL INDEX PUSH FXP,D JRST ARRY2F ARRY2: CAML T,XC-2 ;REGULAR ARRAY JRST ARRY0G PUSH FXP,INHIBIT ;HALF A LOCKI MOVEI R,1 ;R ACCUMULATES SIZE OF DATA HRREI D,2(T) ;-<# OF DIMENSIONS> MOVNI AR1,2(T) ;AR1 GETS NUMBER OF DIMENSIONS ARRY2A: POP P,A ARRY2B: JSP T,FXNV1 TLNN TT,-1 JUMPG TT,ARRY2C WTA [ILLEGAL DIMENSION - *ARRAY!] JRST ARRY2B ARRY2C: PUSH FXP,TT IMULI R,(TT) ;PRODUCT OF ALL DIMENSIONS AOJL D,ARRY2A MOVEI D,(R) ;R HAS SIZE OF DATA, AR2A HAS NIL, SETZ AR2A, ; D HAS 1+LARGEST LEGAL INDEX HRRZ A,-1(P) ;PICK UP ARRAY NAME ARRYAE: JUMPE A,ARRY2F ;ALWAYS ALLOW NIL MOVEI TT,(A) ;GET POINTER TO ARRAY'S NAME ARG LSH TT,-SEGLOG ;MAKE POINTER TO ST TABLE MOVE TT,ST(TT) ;GET TABLE ENTRY TLNE TT,SA\SY ;OK IF SAR OR SYMBOL JRST ARRY2F ;WIN IF IT IS %WTA NASER ;ELSE WRNG-TYPE-ARG ERROR HRRZM A,-1(P) ;REPLACE RETURNED ARG JRST ARRYAE ;AND TRY AGAIN WITH ATOM TEST ARRY2F: SETOM INHIBIT ;OTHER HALF OF LOCKI HRLM AR1,TOTSPC ;SAVE NUMBER OF DIMENSIONS MOVEI T,(AR1) ;T ACCUMULATES SIZE OF HEADER MOVEM D,LLIP1 ;SAVE 1+LARGEST LEGAL INDEX MOVSI D,AS.SX TDNN D,ARYTP1(F) ;S-EXP OR FULLWORD ARRAY? AOJA T,ARRY2H ;FULLWORD NEEDS EXTRA WORD IN HEADER ADDI R,1 ;S-EXP PACKS TWO ENTRIES PER WORD LSH R,-1 ARRY2H: HRRZ TT,ARYIN2(F) ;ACCOUNT FOR LENGTHS OF ENTRIES IMULI R,(TT) MOVNM R,BPPNR ;- ADDI T,2 ;TWO WDS IN HEADER FOR JSP AND SAR HRLM T,BPPNR ;SAVE SIZE OF HEADER ADDI R,1(T) ;ONE WORD FOR GC AOBJN POINTER HRRM R,TOTSPC ;SAVE TOTAL SIZE OF ARRAY IN WORDS MOVEM AR2A,(P) ;CLOBBER 2ND ARG WITH SAR OF ARRAY TO COPY PUSH FXP,F ;SAVE ARRAY TYPE ;FALLS THROUGH ;FALLS IN SKIPN A,-1(P) ;ARRAY OF NIL GIVES A SAR JRST ARRY3A ;DON'T DO SARGET FOR NIL PUSHJ P,SARGET JUMPN A,ARRY6 ;ALREADY HAS A SAR ARRY3A: JSP T,SACONS MOVEI B,(A) MOVEI C,QARRAY SKIPE A,-1(P) PUSHJ P,PUTPROP ;AND PUTPROP IT UNLESS ATOM IS NIL JUMPN A,ARRY6 MOVEM B,-1(P) ;WE WANT TO RETURN THE SAR, NOT NIL! MOVEI A,(B) ARRY6: MOVEM A,ADDSAR ;ADDRESS OF THE SAR MOVEI B,ADEAD MOVEM B,ASAR(A) ;THIS SAYS THE OLD ARRAY, IF ANY, IS DEAD MOVE B,GCMKL PUSHJ P,MEMQ1 JUMPE A,ARRY6Q MOVEI B,DEDSAR HRLM B,(A) ARRY6Q: HRRZ TT,TOTSPC MOVEM TT,GAMNT MOVEI AR2A,GCMKL ;RUNNING BACKUP POINTER FOR GCMKL MOVEI C,0 ;TAIL OF GAMKL FOR WINNING DEAD BLOCK MOVEI F,-1 ;SIZE OF SMLST DEAD BLOCK NOT SMLR THAN REQUESTED SKIPA D,BPSH ;RUNNING LOCATION OF BLOCK BEGINNINGS ARRY6A: MOVE AR2A,AR1 HRRZ B,(AR2A) JUMPE B,ARRY7 ;ALL DONE WITH GCMKL HRRZ AR1,(B) HLRZ A,(AR1) MOVE TT,(A) SUB D,TT HLRZ A,(B) HLRZ A,ASAR(A) ;ALIVEP JUMPN A,ARRY6A CAMGE TT,F CAMGE TT,GAMNT JRST ARRY6A MOVE F,TT MOVE C,AR2A MOVE R,D JRST ARRY6A ARRY7: JUMPN C,ARRY7A ;FOUND DEAD BLOCK BIG ENOUGH HRRZ TT,TOTSPC ;ELSE MUST GRAB NEW BLOCK OF REQUISITE SIZE PUSHJ P,AGTSPC JUMPE A,ARRY8 SUB TT,TOTSPC HRRZM TT,INSP HRRZ TT,TOTSPC ;WILL MAKE AN ENTRY JSP T,FIX1A ;ON GCMKL. PUSHJ P,NCONS MOVE B,ADDSAR PUSHJ P,XCONS MOVEI B,(A) MOVEI A,GCMKL PUSHJ P,.NCNC1 MOVE TT,INSP JSP T,FIX1A MOVEM A,VBPEND JRST ARRY5 ARRY7A: HRRZ AR1,(C) ;C POINTS TO GCMKL TAIL WITH DEAD BLK TO BE USED SUB F,GAMNT ;F HAD SIZE OF USEABLE DEAD BLK JUMPN F,ARRY7B MOVE B,ADDSAR ;DEAD BLOCK IS EXACTLY SIZE NEEDED HRLM B,(AR1) ; SIMPLY SPLICE SAR INTO GCMKL AND XIT JRST ARRY4 ARRY7B: ADD R,F ;SLICE UP DEAD BLOCK INTO ARRAY IN HIGHER MOVEI A,DBM ; PART AND NEW DEAD BLK IN LOWER HRLM A,(AR1) MOVE TT,F JSP T,FIX1A HRRZ AR1,(AR1) ;INSTALL NEW DEAD BLOCK MARKER, MOVEI AR2A,(A) ; AND NEW DEAD BLOCK SIZE HRRZ TT,TOTSPC JSP T,FIX1A HRRZ B,(C) PUSHJ P,CONS MOVE B,ADDSAR PUSHJ P,XCONS HRLM AR2A,(AR1) XCTPRO HRRM A,(C) ;PROTECTED, JUST TO BE SAFE NOPRO ARRY4: HRRZM R,INSP ;R NOW HOLDS BEGINNING OF BLOCK FOR NEW ARRAY ARRY5: POP FXP,F ;INDEX INTO ARYTP1 HRRZ R,INSP ;R HELPS PUSH OUT ARRAY HEADER CAIGE F,NPARTP ;MAKE UP AOBJN POINTER FOR GC SKIPA C,ARRYQ4(F) MOVS C,BPPNR ADDI C,2(R) ;ALLOW FOR SIZE OF HEADER, ETC. PUSH R,C SKIPGE ARYIN1(F) ;MAKE DOUBLY SURE ARRAY TYPE EXISTS .VALUE SKIPE TT,ARYIN1(F) ;OOPS! DO WE NEED EXTRA INSTRUCTION? PUSH R,TT ;YES, PUSH IT OUT FIRST HLRZ T,ARYIN2(F) ;BASE ADDRESS OF TABLE OF SUBSCRIPT FUNCTION CALLS HLRZ D,TOTSPC ;NUMBER OF DIMENSIONS ADDI T,-1(D) PUSH R,(T) ;PUSH OUT JSP TO CORRECT PLACE PUSH R,ADDSAR ;PUSH OUT ADDRESS OF SAR ARRY5D: POP FXP,T ;PUSH OUT ARRAY DIMENSIONS, IN ORDER PUSH R,T SOJG D,ARRY5D SETZM 1(R) ;ZERO FIRST WORD OF DATA MOVSI A,1(R) ;MAKE UP BLT POINTER HRRI A,2(R) MOVN C,BPPNR ADDI C,(R) ;C HAS LIMIT FOR BLT POP P,AR1 ;DO WE WANT TO COPY ANOTHER ARRAY? JUMPE AR1,ARRY5F ;NO - ZERO OUT ARRAY HRL A,TTSAR(AR1) ;YES - REARRANGE BLT POINTER SOJA A,ARRY5G ARRY5F: TLZ C,-1 ;FOR ONE-WORD ARRAY, DON'T DO BLT! CAIE C,-1(A) ARRY5G: BLT A,(C) MOVE AR2A,ADDSAR ;PUT CORRECT STUFF INTO SAR ITSELF MOVE TT,INSP ADDI TT,2 HLL TT,ARYTP1(F) MOVEM TT,ASAR(AR2A) ADDI R,1 HRRM R,TTSAR(AR2A) HLRZ D,TOTSPC DPB D,[TTSDIM,,TTSAR(AR2A)] CAIGE F,NPARTP PUSHJ P,@ARRYQ5(F) ;PECULIAR ARRAYS NEED FIXING UP MOVE B,ADDSAR ;RETURN SAR IN B POP P,A ;RETURN ARG 1 IN A UNLKPOPJ ARRY8: SUB P,R70+1 HLRZ TT,TOTSPC MOVNI TT,1(TT) HRLI TT,-1(TT) ADD FXP,TT HRRZ TT,TOTSPC JSP T,FXCONS PUSHJ P,NCONS MOVEI B,Q%%ARRAY PUSHJ P,NCONS UNLOCKI FAC [NO CORE - *ARRAY!] SUBTTL AREGET ROUTINE AREGET: PUSH P,A ;GET AN ARRAY SAR (AND INSIST ON ONE!) MOVEI TT,(A) LSH TT,-SEGLOG MOVE TT,ST(TT) TLNE TT,SA JRST AREGT0 ;A SAR ITSELF IS ACCEPTABLE AREGT2: PUSHJ P,ARGET ;SO IS A SYMBOL WITH AN ARRAY PROPERTY JUMPE A,AREGT1 AREGT0: MOVE TT,ASAR(A) ;A KILLED ARRAY IS AS BAD AS NO ARRAY CAIE TT,ADEAD JRST POP1J ;SUCCESS! RETURN THE SAR IN A AREGT1: POP P,A ;FAILURE! CRAP OUT WTA [NOT AN ARRAY!] JRST AREGET SUBTTL MKDTAR/MKLSAR ROUTINE, AND ARRAYDIMS FUNCTION MKFLAR: SKIPA T,[QFLONUM] MKFXAR: MOVEI T,QFIXNUM JRST MKAR1 MKDTAR: TDZA T,T ;MAKE UP A DATA ARRAY [NO GC PROTECTION FOR ELTS] MKLSAR: MOVEI T,TRUTH ;MAKE UP A LIST ARRAY [GC PROTECTION] LSH TT,1 ;FINDS NUMBER OF DATA WORDS DESIRED IN TT MKAR1: PUSH P,[PX1J] ;A CONTAINS NAME FOR ARRAY PUSH P,A ;A=NIL => GENSYM A NAME PUSH P,T ;A=<-1,,> => JUST RETURN THE SAR PUSH FXP,TT ;LEAVES GENSYMMED NAME OF ARRAY IN A MOVEI A,(FXP) PUSH P,A ;LEAVES ADDRESS OF SAR IN B MOVEI T,0 SKIPN A,-2(P) PUSHJ P,GENSYM HRRZM A,-2(P) MOVNI T,3 JRST %%ARRAY SPECPRO INTZAX SACONS: SKIPN FFA ;SAR CONSER PUSHJ P,AGC MOVE A,@FFA XCTPRO EXCH A,FFA NOPRO HRLI T,((TT)) HLLM T,TTSAR(A) JRST (T) ADIMS0: MOVEI A,(C) WTA [BAD ARG - ARRAYDIMS!] ADIMS: MOVEI C,(A) PUSHJ P,SARGET ;SUBR 1 - ARG MUST BE ARRAY JUMPE A,ADIMS0 LOCKTOPOPJ HRRZ T,ASAR(A) ;OKAY FOR ARRAY TO BE DEAD CAIN T,ADEAD ; - GIVE OUT NIL JRST FALSE MOVEI C,(A) MOVE T,ASAR(C) JFFO T,.+1 HRRZ F,ARYTYP(TT) ;F HAS SYMBOL FOR ARRAY TYPE LDB D,[TTSDIM,,TTSAR(C)] MOVNI D,(D) ;D HAS -<# OF DIMS> MOVNI R,1 TDZA B,B ADIMS1: MOVEI B,(A) ;CONS UP LIST OF DIMENSIONS MOVEI TT,(R) MOVE TT,@TTSAR(C) JSP T,FXCONS PUSHJ P,CONS CAME R,D SOJA R,ADIMS1 MOVEI B,(F) ;CONS TYPE ON FRONT OF LIST JRST XCONS SUBTTL BLTARRAY FUNCTION AND FRIENDS BLTARRAY: EXCH A,B ;GRUMBLE! CALLED BY FILLARRAY PUSH P,B PUSHJ FXP,SAV5M3 PUSHJ P,AREGET MOVEI AR1,(A) HRRZ A,-2(P) BLTAR1: PUSHJ P,AREGET MOVEI AR2A,(A) MOVE T,ASAR(AR1) MOVE TT,ASAR(AR2A) IFN JOBQIO,[ TLNE T,AS.JOB JRST BLTALS TLNE TT,AS.JOB JRST BLTALZ ] ;END OF IFN JOBQIO TLNE T,AS.FIL JRST BLTI1 TLNE TT,AS.FIL JRST BLTO1 LOCKI PUSHJ P,.REA3 JRST BLTALZ ;ARRAY TYPES DON'T MATCH - LOSE LOSE BLTXIT: PUSHJ FXP,RST5M3 UNLOCKI JRST POPAJ BLTALZ: UNLOCKI MOVEI A,(AR2A) WTA [BAD TARGET ARRAY TYPE - BLTARRAY!] MOVEI AR2A,(A) JRST BLTAR1 BLTALS: UNLOCKI MOVEI A,(AR1) WTA [BAD SOURCE ARRAY TYPE - BLTARRAY!] MOVEI AR1,(A) JRST BLTAR1 ;;; SMASH ARRAY WHOSE SAR IS IN AR1 INTO ARRAY WHOSE SAR IS IN AR2A ;;; SKIPS ON SUCCESS - FAILS WHEN ARRAY TYPES DON'T MATCH .REA3: HLLZ TT,ASAR(AR1) HLLZ D,ASAR(AR2A) XOR TT,D TLZ TT,AS.GCP JUMPE TT,.REA3C ;WIN IF ARRAY TYPES MATCH TLNE TT,# ;ASSUME WIN IF BOTH NUMERIC POPJ P, .REA3C: AOS (P) MOVEI A,(AR1) JSP T,ARYSIZ ;RETURNS SIZE IN WORDS IN TT MOVE R,TT MOVEI A,(AR2A) JSP T,ARYSIZ HRRZS (P) CAMG TT,R ;MOVE NUMBER OF WORDS DICTATED JRST .REA3D ; BY THE SMALLER OF THE ARRAYS MOVE TT,R HRROS (P) ;REMEMBER WHETHER ARRAY GETS BIGGER OR SMALLER .REA3D: ADD TT,TTSAR(AR2A) HRRZ R,TTSAR(AR2A) HRL R,TTSAR(AR1) BLT R,-1(TT) ;TRANSFER THE DATA SKIPGE (P) ;IF DIDN'T SWITCH ARRAY SIZES THEN DO CHECK JRST .REA3E TLNE T,AS.SX ;IF S-EXP ARRAY TRNN F,1 ;AND AN ODD NUMBER OF ENTRIES SKIPA HLLZS -1(TT) ;MAKE SURE LAST HALFWORD IS ZERO .REA3E: TRNN D,AS.RDT+AS.OBA C.REA2: POPJ P,.REA2 TRNN D,AS.RDT ;MUST PERFORM A SPECIAL FIXUP FOR JRST OBAFX1 ; READTABLES AND OBARRAYS JRST RDTFIX ;;; JSP T,ARYSIZ ;;; ACCEPTS A SAR IN A; RETURNS THE PRODUCT OF THE DIMENSIONS ;;; IN F, AND THE SIZE OF THE DATA IN WORDS IN TT. ;;; SAVES D AND R. ARYSIZ: HLL T,ASAR(A) ;RETURN ADDRESS IN IN RH OF T TLNE T,AS.RDT+AS.OBA JRST ARYSZ5 ;SPECIAL HANDLING FOR READTABLES AND OBARRAY LDB TT,[TTSDIM,,TTSAR(A)] MOVNS TT MOVE F,@TTSAR(A) ARYSZ3: AOJE TT,ARYSZ4 ;ON EXIT, F HAS PRODUCT OF ALL DIMENSIONS IMUL F,@TTSAR(A) JRST ARYSZ3 ARYSZ4: TLNE T,AS.SX JRST ARYSZ7 ARYSZ6: MOVE TT,F ;NUMERIC ARRAY - SIZES MAY BE 1, 2, 4 IFN DBFLAG+CXFLAG,[ TLNE T,AS.DB+AS.CX LSH TT,1 ] ;END OF IFN DBFLAG+CXFLAG DX$ TLNE T,AS.DX DX$ LSH TT,1 JRST (T) ARYSZ5: MOVEI F,LRCT ;ASSUME A READTABLE TLNE T,AS.RDT JRST ARYSZ6 MOVEI F,OBTSIZ+1+200 ;IF NOT, AN OBARRAY ARYSZ7: MOVEI TT,1(F) ;ALLOW FOR S-EXPRESSION ARRAYS LSH TT,-1 ; HAVING TWO ELEMENTS/WORD JRST (T) OBAFIX: JUMPE AR1,CPOPJ ;FIX UP OBARRAY AFTER A BLTARRAY, ETC. OBAFX1: MOVE T,TTSAR(AR2A) ; BY COPYING ALL THE BUCKETS HRLI T,442200 ;USER INTERRUPTS SHOULD BE SHUT OFF MOVEI D,OBTSIZ OBAFX3: ILDB A,T SETZ B, PUSHJ P,.APPEND ;USE *APPEND TO COPY LISTS DPB A,T SOJG D,OBAFX3 POPJ P, RDTFIX: SKIPA R,PROLIS ;FIX UP A READTABLE AFTER A BLTARRAY, ETC. RDTFX2: HRRZ R,(R) ; BY DUPLICATING ALL PROLIS ENTRIES JUMPE R,CPOPJ ; FOR MACRO CHAR FUNCTIONS HLRZ D,(R) HRRZ TT,(D) HLRZ T,(TT) CAIE T,(AR1) JRST RDTFX2 HRRZ B,(TT) MOVEI A,(AR2A) PUSHJ P,CONS HLRZ B,(D) PUSHJ P,XCONS MOVE B,PROLIS PUSHJ P,CONS MOVEM A,PROLIS JRST RDTFX2 ;FILL OUTPUT FILE IN AR2A FROM ARRAY IN AR1. BLTO1: TLNE T,AS.FIL+AS.RDT+AS.OBA+AS.GCP ;FILES, READTABLES, OBARRAYS, S-EXPS BAD JRST BLTALS EXCH AR1,AR2A PUSHJ P,XOFLOK ;MAKE SURE TARGET ARRAY IS BINARY OUTPUT IFN ITS,[ PUSHJ P,IFORCE ;FORCE OUT CURRENT BUFFER, IF ANY MOVEI A,(AR2A) JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT MOVE D,TT ;MOVE INTO D HRRZ T,TTSAR(AR2A) HRLI T,444400 ;SET UP BYTE POINTER (BYTE = 36. BITS) MOVE TT,TTSAR(AR1) ADDM D,F.FPOS(TT) .CALL SIOT ;TRANSFER DATA TO FILE .LOSE 1400 JSP D,FORCE6 ;UPDATE FILE OBJECT VARIABLES ] ;END OF IFN ITS IFN D20,[ PUSHJ P,IFORCE ;FORCE OUT CURRENT BUFFER, IF ANY MOVEI A,(AR2A) JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT HRRZ 2,TTSAR(AR2A) HRLI 2,440000 ;SET UP BYTE POINTER (BYTE = 36. BITS) MOVN 3,TT ;NEGATIVE OF NUMBER OF BYTES MOVE D,TT MOVE TT,TTSAR(AR1) HRRZ 1,F.JFN(TT) ;GET JFN FOR FILE ADDM D,F.FPOS(TT) SOUT ;TRANSFER DATA TO FILE SETZB 2,3 ;FLUSH CRUD FROM AC'S JSP T,FORCE6 ;UPDATE FILE OBJECT VARIABLES ] ;END OF IFN D20 IFN D10,[ MOVEI A,(AR2A) JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT MOVE T,TTSAR(AR2A) MOVE F,TTSAR(AR1) MOVE B,F.CHAN(F) ;GET CHANNEL NUMBER FOR I/O FILE LSH B,27 TLO B,(OUT 0,) ;CONSTRUCT AN OUT INSTRUCTION MOVE A,FB.HED(F) ;GET ADDRESS OF BUFFER HEADER BLOCK BLTO3: MOVE D,1(A) ;GET BYTE POINTER INTO BUFFER ADDI D,1 ;ADDRESS OF FIRST FREE WORD IN BUFFER HRLI D,(T) ;ADDRESS OF NEXT DATA WORD TO TRANSFER SKIPN R,2(A) ;GET COUNT OF FREE BUFFER WORDS IN R JRST BLTO4 ;OOPS, NONE - GO OUTPUT THIS BUFFER CAILE R,(TT) ;IF REST OF DATA FITS IN BUFFER, MOVEI R,(TT) ; TRANSFER NO MORE THAN NECESSARY SUB TT,2(A) ;SUBTRACT FREE WORDS IN BUFFER FROM COUNT OF REMAINING DATA MOVNS R ADDM R,2(A) ;ADJUST BUFFER FREE COUNT FOR WORDS TRANSFERRED MOVNS R ADDB R,1(A) ;ADJUST BYTE POINTER, GET FINAL ADDRESS BLT D,(R) JUMPL TT,BLTXIT ;DIDN'T COMPLETELY FILL THIS LAST BUFFER, SO EXIT BLTO4: XCT B ;OUTPUT THIS BUFFER CAIA HALT ;? THE OUTPUT LOST SOMEHOW MOVE D,FB.BFL(F) ADDM D,F.FPOS(F) ;UPDATE FILEPOS JUMPG TT,BLTO3 ;GO AROUND AGAIN IF MORE DATA LEFT ] ;END OF IFN D10 JRST BLTXIT ;FILL ARRAY IN AR2A FROM FILE IN AR1. BLTI1: TLNE TT,AS.FIL+AS.RDT+AS.OBA+AS.GCP ;FILES, READTABLES, OBARRAYS, S-EXPS BAD JRST BLTALZ PUSHJ P,XIFLOK ;MAKE SURE SOURCE IS AN INPUT BINARY FILE IFN ITS+D20,[ MOVEI A,(AR2A) JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT MOVE T,TTSAR(AR2A) MOVE F,TTSAR(AR1) SKIPN R,FB.CNT(F) ;GET NUMBER OF DATA WORDS IN INPUT BUFFER JRST BLTI4 ;NONE, GO DO DIRECT INPUT CAILE R,(TT) ;TRANSFER NO MORE WORDS THAN MOVEI R,(TT) ; THE TARGET ARRAY WILL HOLD SUBI TT,(R) ;ADJUST COUNT FOR NUMBER OF WORDS TRANSFERRED MOVN D,R ADDM D,FB.CNT(F) ;ADJUST BYTE COUNT IN FILE OBJECT IBP FB.BP(F) ;BYTE POINTER TO POINT TO FIRST BYTE WE WANT MOVE D,FB.BP(F) HRLI D,(D) ;ADDRESS OF FIRST WORD OF INPUT DATA HRRI D,(T) ADDI T,(R) ;UPDATE POINTER INTO TARGET ARRAY SUBI R,1 ;FOR CORRECT UPDATING, R IS 1 TOO BIG ADDM R,FB.BP(F) ;UPDATE FILE BYTE POINTER BLT D,-1(T) ;TRANSFER DATA JUMPLE TT,BLTXIT ;EXIT IF WE GOT ENOUGH DATA MOVE D,FB.BVC(F) ADDM D,F.FPOS(F) SETZM FB.BVC(F) BLTI4: IFN ITS,[ MOVE R,TT MOVE D,TT ;GET COUNT OF BYTES MOVE TT,F HRLI T,444400 ;MAKE BYTE POINTER (BYTE = 36. BITS) .CALL SIOT ;INPUT MORE DATA .LOSE 1400 SUB R,D ADDM R,F.FPOS(TT) ;UPDATE THE FILE POSITION JUMPE D,BLTXIT ;JUMP IF WE GOT ALL THE DATA ] ;END OF IFN ITS IFN D20,[ HRRZ 1,F.JFN(F) ;GET JFN FOR FILE MOVEI 2,(T) HRLI 2,444400 ;MAKE BYTE POINTER (BYTE = 36. BITS) MOVN 3,TT SIN ;INPUT MORE DATA ADD TT,3 ;NOT ADDI!!! ADDM TT,F.FPOS(F) ;UPDATE THE FILE POSITION MOVE D,3 SETZB 2,3 ;FLUSH JUNK FROM AC'S JUMPE D,BLTXIT ;JUMP IF WE GOT ALL THE DATA ] ;END OF IFN D20 ] ;END OF IFN ITS+D20 IFN D10,[ MOVEI A,(AR2A) JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT MOVE T,TTSAR(AR2A) MOVE F,TTSAR(AR1) MOVE B,F.CHAN(F) ;GET CHANNEL NUMBER FOR FILE LSH B,27 TLO B,(IN 0,) ;CONSTRUCT AN IN INSTRUCTION MOVE A,FB.HED(F) ;GET ADDRESS OF BUFFER HEADER BLOCK BLTI3: SKIPN R,2(A) ;CHECK NUMBER OF WORDS IN THIS BUFFER JRST BLTI5 ;NONE - GO READ SOME MORE CAILE R,(TT) ;DON'T TRANSFER MORE WORDS MOVEI R,(TT) ; THAN THE TARGET ARRAY NEEDS SUBI TT,(R) ;ADJUST COUNT OF WORDS NEEDED MOVN D,R ADDM D,2(A) ;ADJUST COUNT IN BUFFER HEADER MOVE D,1(A) ;GET BYTE POINTER TO INPUT BUFFER HRLI D,1(D) HRRI D,(T) ;FORM BLT POINTER ADDI T,(R) ;UPDATE POINTER INTO TARGET ARRAY ADDM R,1(A) ;UPDATE INPUT BUFFER BYTE POINTER BLT D,-1(T) ;TRANSFER DATA TO TARGET ARRAY JUMPLE TT,BLTXIT ;EXIT IF WE GOT ENOUGH DATA BLTI5: XCT B ;GET MORE DATA JRST BLTI6 ;JUMP IF AN ERROR OCCURRED MOVE D,FB.BFL(F) ADDM D,F.FPOS(F) ;UPDATE FILE POSITION JRST BLTI3 BLTI6: MOVE D,B ;CONSTRUCT A TEST FOR END OF FILE XOR D,[#] XCT D HALT ;LOSE TOTALLY IF NOT END OF FILE ] ;END OF IFN D10 HRRZ C,FI.EOF(TT) ;GET EOF FUNCTION FOR FILE UNLOCKI JUMPE C,BLTI8 MOVEI A,(AR1) JCALLF 1,(C) ;CALL USER EOF FUNCTION BLTI8: MOVEI A,(AR2A) PUSHJ P,NCONS MOVEI B,(AR1) PUSHJ P,XCONS MOVEI B,QFILLARRAY PUSHJ P,XCONS IOL [EOF - FILLARRAY!] ;ELSE GIVE IO-LOSSAGE ERROR SUBTTL *REARRAY FUNCTION .REARRAY: ;THIS CODE COULD STAND MUCH IMPROVEMENT JSP TT,LWNACK LA1234567,,Q.REARRAY AOJE T,.REA1 ;ONE ARG, DELETE THE ARRAY MOVEI D,(P) ADDI D,(T) HRLI D,(T) HRRZ A,(D) SUBI T,1 PUSH FXP,T .REA4B: PUSHJ P,AREGET MOVE T,ASAR(A) ;GET SAR TLNN T,AS.FIL\AS.JOB ;DON'T ALLOW JOB OR FILE ARRAY JRST .REA4A XCT .REA6A ;ISSUE WTA ERROR JRST .REA4B .REA4A: LOCKI PUSH P,A HLRZ T,ASAR(A) HRRZ A,1(D) .REA4: MOVSI F,-LARYTP .REA5: HRRZ B,ARYTP1(F) CAIN B,(A) JRST .REA7 AOBJN F,.REA5 .REA6: UNLOCKI POP FXP,T .REA6A: WTA [BAD ARRAY TYPE - *REARRAY!] MOVEM A,1(D) PUSH FXP,T LOCKI JRST .REA4 .REA7: HLRZ TT,ARYTP1(F) XORI TT,(T) ANDCMI TT,AS JUMPN TT,.REA6 .REA7A: PUSH P,C.REA2 PUSH P,R70 ;*ARRAY WILL CREATE A FRESH SAR PUSH P,1(D) AOBJN D,.-1 UNLOCKI MOVE T,(FXP) JRST %%ARRAY .REA2: LOCKI HRRZ AR1,(P) ;AR1 HAS THE OLD ARRAY SAR MOVEI AR2A,(A) ;AR2A HAS THE NEW ARRAY SAR PUSHJ P,.REA3 ;COPY OLD ARRAY DATA INTO NEW ARRAY JRST .REALOSE MOVEI B,ADEAD ;NOW INTER-CLOBBER THE TWO SARS EXCH B,ASAR(AR2A) MOVEM B,ASAR(AR1) ;STORE NEW CONTENTS OF ASAR TLNE B,AS ADDI B,1 MOVEM AR1,1(B) ;INSTALL CORRECT SAR IN ARRAY MOVE B,TTSAR(AR2A) HLLOS TTSAR(AR2A) MOVEM B,TTSAR(AR1) ;STORE NEW CONTENTS OF TTSAR MOVEI A,(AR1) MOVE B,GCMKL PUSHJ P,MEMQ1 JUMPE A,.REALOSE MOVEI B,DEDSAR HRLM B,(A) MOVE B,GCMKL MOVEI A,(AR2A) PUSHJ P,MEMQ1 JUMPE A,.REALOSE HRLM AR1,(A) UNLOCKI POP FXP,T HRLI T,-1(T) ADD P,T JRST POPAJ .REALOSE: SUB P,R70+1 UNLOCKI POP FXP,T PUSHJ FXP,LISTX PUSHJ P,NCONS MOVEI B,Q.REARRAY PUSHJ P,XCONS FAC [*REARRAY LOST!] GETSP: JSP TT,LWNACK LA12,,QGETSP POP P,A MOVEI D,GETSP1 HRL D,VPURE AOJE T,GETSP0 HRLI D,(A) POP P,A GETSP0: JSP T,FXNV1 ;RETURNS BPEND-BPORG IF SPACE IS AVAILABLE TLCE D,-1 TLZ D,-1 LOCKTOPOPJ PUSH P,D AGTSPC: MOVEM TT,GAMNT ADD TT,@VBPORG ;INSURE THAT BPEND-BPORG > (TT) SUB TT,@VBPEND JUMPGE TT,GTSPC1 ;MUST RELOCATE, OR GET MORE CORE. MOVE A,VBPEND ;ALREADY OK MOVE TT,(A) POPJ P, GETSP1: JUMPE TT,FALSE SUB TT,@VBPORG JRST FIX1 .REA1: MOVE A,(P) ;REMOVES ARRAY BY PUTTING ADDRESS OF PUSHJ P,SARGET ; ERROR ROUTINE IN SAR, ETC. JUMPE A,POP1J MOVE T,ASAR(A) ;GET SAR TLNE T,AS.JOB\AS.FIL ;MUST NOT BE FILE OR JOB ARRAY JRST .REA1A MOVEI B,ADEAD XCTPRO MOVEM B,ASAR(A) MOVE B,[TTDEAD] MOVSI T,TTS TDNE T,TTSAR(A) IOR B,T MOVEM B,TTSAR(A) NOPRO JRST POPAJ .REA1A: POP P,A ;ARRAY IS FILE OR JOB OBJECT XCT .REA6A ;ISSUE WTA ERROR PUSH P,A JRST .REA1 SUBTTL MULTI-DIMENSIONAL ARRAY ACCESS ROUTINES ;;; THESE ARE LIKE THE FXNV ROUTINES; THEY TAKE A FIXNUM ;;; FROM AN ARGUMENT AC, CHECK ITS TYPE, AND PUT ITS VALUE ;;; IN R. THIS VALUE IS CHECKED TO ENSURE IT IS WITHIN THE ;;; NEXT DIMENSION VALUE. TT IS STEPPED ALONG THE VECTOR ;;; OF DIMENSIONS IN THE ARRAY HEADER. AYNV1 ADDITIONALLY ;;; PUTS THE ADDRESS OF THE SAR IN LISAR. SFXPRO AYNV1: HRRZ R,(TT) MOVEM R,LISAR AOJA TT,AYNV0 AYNV5: SKIPA A,AR2A AYNV4: MOVEI A,(AR1) JRST AYNV0 AYNV3: SKIPA A,C AYNV2: MOVEI A,(B) ;LEFT HALF OF B MAY BE NON-ZERO AYNV0: MOVEI R,(A) LSH R,-SEGLOG MOVE R,ST(R) TLNN R,FX JRST AYNVER ;LOSE IF NOT A FIXNUM SKIPL R,(A) ;MUST NOT BE NEGATIVE, CAML R,(TT) ; AND MUST BE BELOW NEXT DIMENSION CAIA AOJA TT,(T) ;RETURN TO CALLER, BUMPING POINTER IN TT SKIPA D,[[SIXBIT \ARRAY SUBSCRIPT EXCEEDS BOUNDS!\]] AYNVER: MOVEI D,[SIXBIT \NON-FIXNUM ARRAY SUBSCRIPT!\] PUSH P,D MOVEI R,(TT) AYNVE1: HLRZ D,-1(R) ;WE MUST BACK UP THE POINTER TO THE JSP TT, CAIE D,(JSP TT,) ; WHICH IS WHERE THE ASAR POINTS SOJA R,AYNVE1 HRRZ D,(R) SUB TT,ASAR(D) ;SAVE TT AS AN ABSOLUTE OFFSET FROM THE ASAR EXCH D,(P) ; (SINCE DURING THE ERROR THE ARRAY MAY MOVE) XCT AYNVSFX ;SYNCHRONIZE WITH THE INTERRUPT LOCKOUT MECHANISM POP P,D ADD TT,ASAR(D) ;RESTORE THE TT POINTER USING THE JRST AYNV0 ; (POSSIBLY NEW) ASAR, AND TRY AGAIN .SEE 1DIMS ;THE 1-DIMENSIONAL ACCESS ROUTINES ARE IN LOW CORE 2DIMS: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 2DIMS1: ADDI R,(F) JRST ARYGET 2DIMF: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 2DIMF1: ADDI R,(F) JRST ANYGET IFN DBFLAG+CXFLAG,[ 2DIMD: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 2DIMD1: ADDI R,(F) JRST ADYGET ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ 2DIMZ: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 2DIMZ1: ADDI R,(F) JRST AZYGET ] ;END OF IFN DXFLAG ;;; THERE ARE FOUR SEPARATE 1DIM- AND 2DIM- ROUTINES FOR SPEED. ;;; FOR THE OTHERS, WHICH ARE LESS COMMON, WE PREFER TO SAVE ;;; SPACE. WE ENCODE THE ARRAY TYPE IN THE LEFT HALF OF B: ;;; 0 S-EXPRESSION ;;; 1 FIXNUM, FLONUM ;;; 2 DOUBLE, COMPLEX ;;; 3 DUPLEX ;;; PLEASANTLY, IF THIS NUMBER IS N, AN ARRAY ELEMENT IS OF SIZE ;;; 2^N HALFWORDS, BUT WE DO NOT USE THIS FACT. IFN DXFLAG, 3DIMZ: TLOA B,2 IFN DBFLAG+CXFLAG, 3DIMD: TLOA B,2 3DIMF: TLO B,1 3DIMS: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 ADDI F,(R) IMUL F,(TT) JSP T,AYNV3 3DIMX: HLRZ T,B TLZ B,-1 JRST .+1(T) JRST 2DIMS1 ;S-EXPRESSION JRST 2DIMF1 ;FIXNUM, FLONUM IFN DBFLAG+CXFLAG, JRST 2DIMD1 ;DOUBLE, COMPLEX .ELSE .VALUE IFN DXFLAG, JRST 2DIMZ1 ;DUPLEX .ELSE .VALUE IFN DXFLAG, 4DIMZ: TLOA B,2 IFN DBFLAG+CXFLAG, 4DIMD: TLOA B,2 4DIMF: TLO B,1 4DIMS: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 ADDI F,(R) IMUL F,(TT) JSP T,AYNV3 ADDI F,(R) IMUL F,(TT) JSP T,AYNV4 JRST 3DIMX IFN DXFLAG, 5DIMZ: TLOA B,2 IFN DBFLAG+CXFLAG, 5DIMD: TLOA B,2 5DIMF: TLO B,1 5DIMS: JSP T,AYNV1 MUL R,(TT) JSP T,AYNV2 ADDI F,(R) IMUL F,(TT) JSP T,AYNV3 ADDI F,(R) IMUL F,(TT) JSP T,AYNV4 ADDI F,(R) IMUL F,(TT) JSP T,AYNV5 JRST 3DIMX NOPRO SUBTTL FILLARRAY AND LISTARRAY FILLARRAY: ;SUBR 2 SKOTT B,LS JRST BLTARRAY MOVEI C,(B) FILLA0: PUSH P,A PUSHJ P,AREGET ;GET SAR OF ARRAY HLLZ D,ASAR(A) TLNE D,AS.JOB+AS.FIL+AS.RDT+AS.OBA JRST FILLUZ ;CAN'T FILL JOB OR FILE OR READTABLE OR OBARRAY JSP T,ARYSIZ ;GET SIZE OF ARRAY IN F SETZ TT, ;TT WILL BE USED FOR INCREMENTAL INDEX TLNN D,AS.SX JRST FILLA2 FILLA1: JUMPE C,FILLA4 ;FILL LOOP FOR S-EXP ARRAYS HLRZ B,(C) HRLM B,@TTSAR(A) HRRZ C,(C) SOJE F,POPAJ JUMPE C,FILLA5 HLRZ B,(C) HRRM B,@TTSAR(A) HRRZ C,(C) SOJE F,POPAJ AOJA TT,FILLA1 FILLA4: HRLM B,@TTSAR(A) SOJE F,POPAJ FILLA5: HRRM B,@TTSAR(A) SOJE F,POPAJ ADDI F,1 ROT F,-1 ;ROT, NOT LSH; SEE BELOW MOVEI D,1 ;MULTIPLIER FOR ELEMENT SIZE JRST FILLA7 FILLA2: TLNN D,AS.FX+AS.FL IFN DBFLAG+CXFLAG, JRST FILLD1 .ELSE .VALUE MOVEI B,(A) ;FILL LOOP FOR FULLWORD ARRAYS FILLA3: JUMPE C,FILLA6 HLRZ A,(C) HRRZ C,(C) MOVEI R,(TT) TLNN D,AS JSP T,FLNV1X JSP T,FXNV1 EXCH TT,R MOVEM R,@TTSAR(B) SOJE F,POPAJ AOJA TT,FILLA3 IFN DBFLAG+CXFLAG,[ FILLD1: TLNN D,AS.DB+AS.CX DX$ JRST FILLZ1 DX% .VALUE MOVE F,D FILLD3: JUMPE C,FILLD6 ;FILL LOOP FOR DOUBLE AND COMPLEX ARRAYS HLRZ A,(C) HRRZ C,(C) MOVEI R,(TT) DB$ CX$ TLNN F,AS.DB DB$ CX$ JSP T,CXNV1X DB$ JSP T,DBNV1 DB% JSP T,CXNV1 EXCH TT,R MOVEM R,@TTSAR(B) ADDI TT,1 MOVEM D,@TTSAR(B) SOJE F,POPAJ AOJA TT,FILLD3 FILLD6: ADDI TT,1 MOVEM D,@TTSAR(B) MOVEI D,2 SOJA TT,FILLA9 ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ FILLZ1: TLNN D,AS.DX .VALUE PUSH FXP,TT PUSH FXP,F FILLZ3: JUMPE C,FILLZ6 ;FILL LOOP FOR DUPLEX ARRAYS HLRZ A,(C) HRRZ C,(C) JSP T,DXNV1 MOVE T,TT MOVE TT,-1(FXP) KA MOVEM R,@TTSAR(B) KA ADDI TT,1 KA MOVEM F,@TTSAR(B) KA ADDI TT,1 KIKL DMOVEM R,@TTSAR(B) KIKL ADDI TT,2 MOVEM T,@TTSAR(B) ADDI TT,1 MOVEM D,@TTSAR(B) ADDI TT,1 MOVEM TT,-1(FXP) SOSE (FXP) JRST FILLZ3 POPI FXP,2 JRST POPAJ FILLZ6: KA MOVEM R,@TTSAR(B) KA ADDI TT,1 KA MOVEM F,@TTSAR(B) KA ADDI TT,1 KIKL DMOVEM R,@TTSAR(B) KIKL ADDI TT,2 MOVEM T,@TTSAR(B) ADDI TT,1 MOVEM D,@TTSAR(B) SUBI TT,3 MOVEI D,4 JRST FILLA8 ] ;END OF IFN DXFLAG OPNCLR: MOVEI F,LONBFA ;USED BY $OPEN TO CLEAR ARRAY SETZB TT,R ;SAR OF FILE ARRAY IS IN A MOVEI B,(A) PUSH P,A FILLA6: MOVEI D,1 FILLA9: MOVEM R,@TTSAR(B) FILLA8: SOJE F,POPAJ TLO F,400000 ;AVOID HLLZS BELOW MOVEI A,(B) FILLA7: LOCKI ;IF LIST RUNS OUT, DUPLICATE INTO ADD TT,TTSAR(A) ; REMAINING ELEMENTS WITH A BLT IMULI F,(D) ;ACCOUNT FOR SIZE OF ELEMENTS ADDI F,(TT) ADDI F,-1(D) HRLI TT,(TT) ADDI TT,(D) BLT TT,(F) SKIPL F ;FOR AN ODD LENGTH S-EXP ARRAY, ZERO RH OF HLLZS (F) ; LAST WORD SO GC WON'T MARK IT SPURIOUSLY POP P,A UNLKPOPJ FILLUZ: POP P,A WTA [CAN'T FILL THIS OBJECT WITH LIST - FILLARRAY!] JRST FILLA0 LISTARRAY: JSP TT,LWNACK LA12,,QLISTARRAY HRLZI D,377777 ;INITIAL SETTING FOR COUNT AOJE T,LISTA3 POP P,B ;COUNT INITIALIZED TO 2ND ARG IF PRESENT JSP T,FXNV2 LISTA3: POP P,A LISTAZ: PUSHJ P,AREGET MOVE T,(A) ;GET SAR BITS TLNE T,AS.JOB ;CAN'T BE JOB ARRAY JRST LISJOB TLNE T,AS.FIL ;OR FILE ARRAY JRST LISFIL JSP T,ARYSIZ ;GET SIZE OF ARRAY JUMPL D,LISTA7 ;SET COUNT TO SIZE IF 2ND ARG NEGATIVE CAMGE D,F ;OR IF 2ND ARG BIGGER THAN SIZE MOVE F,D LISTA7: MOVEI C,(A) SETZB A,B TLNN T,AS.SX JRST LISTA5 MOVEI TT,-1(F) LSHC TT,-1 ;FIGURE OUT IF ODD OR EVEN JUMPGE D,LISTA2 ; NUMBER OF ITEMS TO LIST LISTA1: HRRZ B,@TTSAR(C) ;S-EXP ARRAY LISTING LOOP PUSHJ P,XCONS LISTA2: HLRZ B,@TTSAR(C) PUSHJ P,XCONS SOJGE TT,LISTA1 POPJ P, LISTA5: TLNN T,AS.FX+AS.FL IFN DBFLAG+CXFLAG, JRST LISTD5 .ELSE .VALUE SKIPA D,T ;FULLWORD ARRAY LISTING LOOP LISTA6: MOVEI B,(A) MOVEI TT,-1(F) MOVE TT,@TTSAR(C) TLNN D,AS ;CONS UP FLONUM OR FIXNUM? JSP T,FLCONX ;FLONUM CONS WITH SKIP RETURN JSP T,FXCONS ;FIXNUM CONS PUSHJ P,CONS SOJG F,LISTA6 POPJ P, LISJOB: WTA [JOB ARRAY ILLEGAL - LISTARRAY!] JRST LISTAZ LISFIL: WTA [FILE ARRAY ILLEGAL - LISTARRAY!] JRST LISTAZ IFN DBFLAG+CXFLAG,[ LISTD5: TLNN T,AS.DB+AS.CX DX$ JRST LISTZ5 DX% .VALUE SKIPA R,T LISTD6: MOVEI B,(A) ;DOUBLE/COMPLEX ARRAY LISTING LOOP KA HRROI TT,-1(F) KA ROT TT,1 ;SNEAKY, HUH? KA MOVE D,@TTSAR(C) KA SUBI TT,1 KA MOVE TT,@TTSAR(C) KIKL MOVEI TT,-1(F) KIKL LSH TT,1 KIKL DMOVE TT,@TTSAR(C) DB$ CX$ TLNN R,AS.DB DB$ CX$ JSP T,CXCONX ;COMPLEX CONS WITH SKIP RETURN DB$ JSP T,DBCONS DB% JSP T,CXCONS PUSHJ P,CONS SOJG F,LISTD5 POPJ P, ] ;END OF IFN DBFLAG+CXFLAG IFN DXFLAG,[ LISTZ5: TLNN T,AS.DX .VALUE PUSH FXP,F SKIPA TT,F LISTZ6: MOVEI B,(A) LSH TT,2 KA MOVE R,@TTSAR(C) KA ADDI TT,1 KA MOVE F,@TTSAR(C) KA ADDI TT,2 KA MOVE D,@TTSAR(C) KA SUBI TT,1 KA MOVE TT,@TTSAR(C) KIKL DMOVE R,@TTSAR(C) KIKL ADDI TT,2 KIKL DMOVE TT,@TTSAR(C) JSP T,DXCONS PUSHJ P,CONS SOSE TT,(FXP) JRST LISTZ6 POPI FXP,1 POPJ P, ] ;END OF IFN DXFLAG PGTOP ARA,[ARRAY STUFF] ;;@ END OF ARRAY 85 ;;@ FASLOA 245 FASLOAD ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT FSL SUBTTL HAIRY RELOCATING LOADER (FASLOAD) ;;; BUFFER PARAMETERS LLDAT==:770 ;LENGTH OF LOADER'S ATOMTABLE ARRAY ILDAT==:1000 ;AMOUNT TO INCREMENT ATOMTABLE ARRAY LLDSTB==:400 ;SIZE OF LDPUT'S SYMBOL TABLE ARRAY (IN 2-WD ENTRIES) ;;; PDL OFFSETS LDAGEN==:0 ;SAR FOR ATOMTABLE LDPRLS==:-1 ;PURE CLOBBERING LIST LDDDTP==:-2 ;DDT FLAG LDBGEN==:-3 ;SAR FOR I/O BUFFER LDNPDS==:4 ;NUMBER OF REGPDL SLOTS TAKE UP BY FASLOAD TEMPORARIES ;;; FASLOAD USES AN ARRAY OF ATOMS TO AVOID CONSTANTLY CREATING ;;; THE SAME ATOMS OVER AND OVER; IN PARTICULAR, THIS SAVES MUCH ;;; TIME IN INTERN FOR ATOMIC SYMBOLS. THIS TABLE IS CREATED ;;; INCREMENTALLY DURING THE LOAD FROM DATA IN THE FASL FILE. THE ;;; ARRAY HAS ONE ONE-WORD ENTRY FOR EACH ATOM. ENTRY 0 IS FOR NIL; ;;; THE OTHERS MAY BE IN ANY ORDER. THE FORMAT OF EACH ATOMTABLE ;;; ENTRY IS AS FOLLOWS: ;;; 4.9-4.1 IF NON-ZERO, THE THE LEFT HALF OF THE ENTRY ;;; (4.9-3.1) CONTAINS THE ADDRESS OF THE VALUE ;;; CELL OF THE ATOM (SYMBOLS ONLY). THIS WORKS ;;; BECAUSE ALL VALUE CELLS ARE ABOVE ADDRESS 777. ;;; NOTE THAT OTHER LEFT HALF BITS DESCRIBED HERE ;;; HAVE MEANING ONLY IF BITS 4.9-4.1 ARE ZERO. ;;; 3.4 THIS BIT IS TURNED ON IF THE ATOM IS PROTECTED ;;; FROM THE GARBAGE COLLECTOR BECAUSE IT IS POINTED ;;; BY SOME LIST STRUCTURE WHICH IS PROTECTED. THIS ;;; IS A HACK SO THAT USELESS ENTRIES WON'T BE MADE ;;; IN THE GC PROTECTION ARRAY (SEE GCPRO). ;;; 3.3-3.2 INDICATES THE TYPE OF ATOM: 0 => SYMBOL, ;;; 1 => FIXNUM, 2 => FLONUM, 3 => BIGNUM. ;;; 3.1 THIS BIT IS TURNED ON IF THE ATOM IS EVER ;;; REFERENCED, DIRECTLY OR INDIRECTLY, BY COMPILED ;;; CODE (IT MIGHT NOT BE IF USED ONLY IN MUNGABLES). ;;; IT INDICATES THAT THE ATOM MUST SOMEHOW BE ;;; PROTECTED FROM THE FEROCIOUS GARBAGE COLLECTOR. ;;; 2.9-1.1 CONTAINS THE ADDRESS OF THE ATOM. (SURPRISE!) ;;; NOTE THAT ONCE AN ATOM IS IN THE TABLE, THE FASL FILE WILL ;;; REFER TO THE ATOM BY ITS TABLE INDEX, SO THAT IT CAN BE ;;; RETRIEVED EXTREMELY QUICKLY. ;;; FORMAT OF FASL FILES: ;;; ;;; THE "NEW" FASLOAD SCHEME (AS OF 1/31/73) USES A NEW FORMAT FOR ;;; ITS FILES. A FASL FILE CONSISTS OF TWO HEADER WORDS, FOLLOWED BY ;;; A SERIES OF FASL BLOCKS; THE TWO HEADER WORDS ARE BOTH SIXBIT, ;;; THE FIRST BEING "*FASL+" (FOR HISTORICAL REASONS, "*FASL* IS ;;; ALSO ACCEPTED) AND THE SECOND THE CONTENTS OF LOCATION LDFNM2 IN ;;; THE LISP WHICH ASSEMBLED THE FILE (A VERSION NUMBER IN SIXBIT). ;;; EACH FASL BLOCK CONSISTS OF A WORD OF NINE FOUR-BIT RELOCATION ;;; BYTES, FOLLOWED BY NINE PIECES OF FASL DATA. THE LENGTH OF EACH ;;; DATA ITEM IS DEPENDENT ON THE RELOCATION TYPE; THUS FASLBLOCKS ;;; ARE OF VARYING LENGTH. THE LAST BLOCK MAY HAVE FEWER THAN NINE ;;; DATA ITEMS. THE RELOCATION TYPES AND THE FORMATS OF THE ;;; ASSOCIATED DATA ITEMS ARE AS FOLLOWS: ;;; ;;; TYPE 0 ABSOLUTE ;;; ONE ABSOLUTE WORD TO BE LOADED. ;;; ;;; TYPE 1 RELOCATABLE ;;; ONE WORD, THE RIGHT HALF OF WHICH IS RELOCATABLE; I.E. AT LOAD ;;; TIME THE LOAD OFFSET IS TO BE ADDED TO THE RIGHT HALF. ;;; ;;; TYPE 2 SPECIAL ;;; A WORD TO BE LOADED, WHOSE RIGHT HALF CONTAINS THE INDEX OF AN ;;; ATOM (HOPEFULLY OF TYPE PNAME) THE ADDRESS OF THE VALUE CELL OF ;;; WHICH IS TO REPLACE THE RIGHT HALF OF THE LOADED WORD. (IF NO ;;; VALUE CELL EXISTS, ONE IS TO BE CREATED.) ;;; ;;; TYPE 3 SMASHABLE CALL ;;; SIMILAR TO TYPE 4 (Q.V.) EXCEPT THAT THE INSTRUCTION IS ONE OF ;;; THE SERIES OF CALL UUOS WHICH MAY BE "SMASHED" FOR PURIFICATION ;;; PURPOSES. AT PRESENT THESE UUOS ARE: CALL, JCALL, NCALL, NJCALL. ;;; ;;; TYPE 4 QUOTED ATOM ;;; ONE WORD TO BE LOADED WHOSE RIGHT HALF CONTAINS THE INDEX OF AN ;;; ATOM WHOSE ADDRESS IS TO REPLACE THE RIGHT HALF OF THE WORD ;;; LOADED. ;;; ;;; TYPE 5 QUOTED LIST ;;; A SERIES OF WORDS REPRESENTING AN S-EXPRESSION TO BE CONSTRUCTED ;;; BY THE LOADER. THE FORMAT OF THESE WORDS IS BEST EXPLAINED BY ;;; THE ALGORITHM USED TO CONTRUCT THE S-EXPRESSION: THE LOADER ;;; EXAMINES BITS 4.7-4.9 OF SUCCESSIVELY READ WORDS, AND DISPATCHES ;;; ON THEM: ;;; 0 THE ATOM WHOSE INDEX IS IN THE RIGHT HALF OF THE WORD ;;; IS PUSHED ONTO A STACK. ;;; 1 THE LOADER POPS AS MANY ITEMS OFF THE STACK AS ;;; SPECIFIED BY THE NUMBER IN THE RIGHT HALF OF THE WORD ;;; AND MAKES A LIST OF THEM, SO THAT THE LAST ITEM POPPED ;;; BECOMES THE FIRST ITEM OF THE LIST; THIS LIST IS THEN ;;; PUSHED ONTO THE STACK. ;;; 2 THE LOADER POPS ONE ITEM OFF THE STACK AND PROCEEDS AS ;;; FOR 1, EXCEPT THAT THE ITEM FIRST POPPED IS USED TO ;;; END THE LIST INSTEAD IF NIL. (THIS ALLOWS FOR DOTTED ;;; PAIRS.) ;;; 3 THE TOP ITEM ON THE STACK IS EVALUATED AND STORED BACK ;;; ON THE TOP OF THE STACK. ;;; 4 THE RIGHT HALF OR THE WORD SPECIFIES THE LENGTH OF A ;;; HUNK TO BE MADE BY TAKING THAT MANY ITEMS FROM THE TOP ;;; OF THE STACK; THIS HUNK IS THEN PUSHED BACK. ;;; 5 UNUSED. ;;; 6 UNUSED. ;;; 7 THE LEFT HALF OF THE WORD SHOULD BE -1 OR -2, ;;; INDICATING THE SECOND LAST WORD OF THE DATA; IF -1, ;;; THE RIGHT HALF OF THIS WORD AND THE ADDRESS OF (WHAT ;;; SHOULD BE) THE SINGLE ITEM ON THE STACK (WHICH IS ;;; POPPED OFF) ARE MADE RESPECTIVELY INTO THE LEFT AND ;;; RIGHT HALVES OF A WORD TO BE LOADED INTO BINARY ;;; PROGRAM SPACE; IF -2, THE S-EXPRESSION IS PLACED INTO ;;; THE NEXT SLOT OF THE ATOMTABLE (SEE TYPE 12). THE ONE ;;; WORD REMAINING IS THE HASH KEY OF THE S-EXPRESSION AS ;;; COMPUTED BY SXHASH; THIS IS USED BY THE LOADER TO SAVE ;;; GCPRO SOME WORK. ;;; ;;; TYPE 6 GLOBALSYM ;;; ONE WORD; THE RIGHT HALF IS AN INDEX INTO THE TABLE LSYMS IN ;;; LISP. THE INDICATED VALUE IS RETRIEVED, NEGATED IF BIT 4.9 OF ;;; THE DATA WORD IS 1, AND ADDED TO THE RIGHT HALF OF THE LAST ;;; WORD LOADED INTO BINARY PROGRAM SPACE. THIS ALLOWS LAP CODE ;;; TO REFER TO SELECTED LOCATIONS INTERNAL TO LISP WITHOUT ;;; GETTING SYMBOLS FROM DDT. ;;; ;;; TYPE 7 GETDDTSYM ;;; IF THE FIRST WORD IS -1, THEN THE LOAD OFFSET IF ADDED INTO ;;; THE LEFT HALF OF THE WORD MOST RECENTLY LOADED INTO BINARY ;;; PROGRAM SPACE (THIS IS HOW LEFT HALF RELOCATION IS ;;; ACCOMPLISHED). OTHERWISE, THE FIRST WORD CONTAINS IN BITS ;;; 1.1-4.5 A SYMBOL IN SQUOZE CODE. THE LOADER GETS THE VALUE OF ;;; THIS SYMBOL FROM DDT IF POSSIBLE, NEGATES IT IF BIT 4.9 IS 1, ;;; THEN ADDS THE RESULT TO THE FIELD OF THE LAST WORD LOADED AS ;;; SPECIFIED BY BITS 4.6-4.7: ;;; 3 = ENTIRE WORD ;;; 2 = AC FIELD ONLY ;;; 1 = RIGHT HALF ONLY ;;; 0 = ENTIRE WORD, BUT SWAP HALVES OF VALUE BEFORE ADDING. ;;; THESE FOUR FIELDS CORRESPOND TO OPCODE, AC, ADDRESS, AND INDEX ;;; FIELDS RESPECTIVELY IN A LAP INSTRUCTION. IF BIT 4.8 IS A 1, ;;; THEN ANOTHER WORD FOLLOWS, CONTAINING THE VALUE OF THE SYMBOL ;;; AS OBTAINED FROM DDT AT ASSEMBLE TIME. IF THE VERSION NUMBER ;;; OF THAT LISP (AS DETERMINED FROM THE SECOND FILE HEADER WORD) ;;; IS THE SAME AS THAT OF THE LISP BEING LOADED INTO, THEN THIS ;;; VALUE IS USED AND DDT IS NOT CONSULTED AT LOAD TIME; THIS IS ;;; FOR SPEED. IF THE VERSION NUMBERS ARE DIFFERENT, THEN DDT IS ;;; CONSULTED. ;;; ;;; TYPE 10 ARRAY REFERENCE ;;; ONE WORD TO BE LOADED, WHOSE RIGHT HALF CONTAINS THE ATOMINDEX ;;; OF AN ATOMIC SYMBOL. IF THE SYMBOL HAS AN ARRAY PROPERTY, IT ;;; IS FETCHED; OTHERWISE ONE IS CREATED. THE RIGHT HALF OF THE ;;; WORD TO BE LOADED IS REPLACED WITH THE ADDRESS OF THE SECOND ;;; WORD OF THE ARRAY POINTER (I.E. OF THE TTSAR). IN THIS WAY ;;; ACCESSES TO ARRAYS CAN BE OPEN-CODED. ;;; ;;; TYPE 11 UNUSED ;;; ;;; TYPE 12 ATOMTABLE INFO ;;; A HEADER WORD, POSSIBLY FOLLOWED BY OTHERS, DEPENDING ON BITS ;;; 4.7-4.9: ;;; 0 THE RIGHT HALF IS THE NUMBER OF WORDS FOLLOWING, WHICH ;;; CONSTITUTE THE PNAME OF A PNAME-TYPE ATOM, IN THE ;;; ORDER OF THEIR APPEARANCE ON A PROPERTY LIST. THE ATOM ;;; IS INTERNED. ;;; 1 THE ONE WORD FOLLOWING IS THE VALUE OF A FIXNUM TO BE ;;; CREATED. ;;; 2 THE FOLLOWING WORD IS THE VALUE OF A FLONUM. ;;; 3 THE RIGHT HALF IS THE NUMBER OF FIXNUM COMPONENTS OF A ;;; BIGNUM FOLLOWING, MOST SIGNIFICANT WORD FIRST. BIT 3.1 ;;; IS THE SIGN OF THE BIGNUM. ;;; 4 THE FOLLOWING TWO WORDS ARE A DOUBLE-PRECISION NUMBER. ;;; 5 THE FOLLOWING TWO WORDS ARE A COMPLEX NUMBER. ;;; 6 THE FOLLOWING FOUR WORDS ARE A DUPLEX NUMBER. ;;; 7 UNUSED. ;;; THE ATOM THUS CREATED IS ASSIGNED A PLACE IN THE ATOMTABLE ;;; MAINTAINED BY THE LOADER (AS AN ARRAY) USING CONSECUTIVE ;;; LOCATIONS; FROM THAT POINT ON OTHER DATA ITEMS REFERRING TO ;;; THAT ITEM CAN DO SO BY THE INDEX OF THE ATOM IN THIS TABLE. ;;; SEE ALSO TYPES 5 AND 16, WHICH ALSO MAKE ENTRIES IN THE ;;; ATOMTABLE. ;;; ;;; TYPE 13 ENTRY INFO ;;; TWO WORDS. THE LEFT HALF OF THE FIRST WORD IS THE ATOMINDEX ;;; OF THE NAME OF THE FUNCTION BEING DEFINED; THE RIGHT HALF ;;; THAT OF THE SUBR TYPE (THE PROPERTY UNDER WHICH TO CREATE THE ;;; ENTRY POINT, E.G. SUBR OR FSUBR). THE RIGHT HALF OF THE ;;; SECOND WORD IS THE LOCATION OF THE ENTRY POINT AS A ;;; RELOCATABLE POINTER: THE LOAD OFFSET MUST BE ADDED TO IT. THE ;;; LEFT HALF OF THE SECOND WORD CONTAINS THE ARGS PROPERTY, IN ;;; INTERNAL ARGS PROPERTY FORMAT, AS SPECIFIED IN THE ORIGINAL ;;; LAP CODE BY THE ARGS CONSTRUCT. ;;; ;;; TYPE 14 LOC ;;; THE WORD IS A RELOCATABLE QUANTITY SPECIFYING WHERE TO ;;; CONTINUE LOADING. IT IS NOT PERMITTED TO LOC BELOW THE ;;; ORIGIN OF THE ASSEMBLY. IF THE LOC IS TO A LOCATION HIGHER ;;; THAN ANY YET LOADED INTO, THEN FASLOAD ZEROS OUT ALL WORDS ;;; ABOVE THAT HIGHEST LOCATION UP TO THE LOCATION SPECIFIED. ;;; FASLOAD KEEPS TRACK OF THE HIGHEST LOCATION EVER LOADED INTO; ;;; THIS VALUE PLUS ONE BECOMES THE VALUE OF BPORG AT THE END OF ;;; ASSEMBLY, REGARDLESS OF THE STATE OF THE LOCATION POINTER ;;; WHEN LOADING TERMINATES. THIS TYPE IS NEVER USED BY LAP ;;; CODE, BUT ONLY BY MIDAS .FASL CODE. ;;; ;;; TYPE 15 PUTDDTSYM ;;; FIRST WORD, THE SYMBOL IN SQUOZE CODE. IF BIT 4.9=0, THE ;;; SYMBOL IS DEFINED TO DDT IF POSSIBLE WITH THE ADDRESS OF THE ;;; WORD OF BINARY PROGRAM SPACE ABOUT TO BE LOADED INTO AS ITS ;;; VALUE. IF BIT 4.9=1, THE VALUE IS GOBBLED FROM THE FOLLOWING ;;; WORD. BIT 4.8 (OF THE WORD CONTAINING THE SQUOZE) MEANS ;;; RELOCATE THE LEFT HALF OF THE VALUE BY THE LOAD OFFSET, AND ;;; BIT 4.7 LIKEWISE FOR THE RIGHT HALF. WHETHER OR NOT THE ;;; SYMBOL ACTUALLY GETS PUT IN DDT'S SYMBOL TABLE IS A FUNCTION ;;; OF THREE CONDITIONS: FIRST, THAT THERE IS A DDT WITH A SYMBOL ;;; TABLE; SECOND, THE VALUE OF THE LISP VARIABLE "SYMBOLS"; ;;; THIRD, BIT 4.6 OF THE FIRST PUTDDTSYM WORD. THE FIRST ;;; CONDITION OF COURSE MUST BE SATISFIED. IF SO, THEN THE SYMBOL ;;; IS PUT IN THE SYMBOL TABLE ONLY IF SYMBOLS HAS A NON-NIL ;;; VALUE. FURTHERMORE, IF THAT VALUE IS THE ATOM SYMBOLS ITSELF, ;;; THEN THE SYMBOL IS PUT ONLY IF BIT 4.6 IS ON (INDICATING A ;;; "GLOBAL" SYMBOL). ;;; ;;; TYPE 16 EVAL MUNGEABLE ;;; A SERIES OF WORDS SIMILAR TO THOSE FOR TYPE 5, BUT WITH NO ;;; FOLLOWING HASH KEY. AN S-EXPRESSION IS CONSTRUCTED AND ;;; EVALUATED. THIS IS USED FOR THE SO-CALLED "MUNGEABLES" IN A ;;; FILE OF LAP CODE. IF THE LEFT HALF OF THE LAST WORD IS -1, ;;; THE VALUE IS THROWN AWAY. IF IT IS -2, THE VALUE IS ENTERED ;;; IN THE ATOMTABLE. ;;; ;;; TYPE 17 END OF BINARY ;;; ONE WORD, WHICH MUST BE "*FASL+" (OR "*FASL*") IN SIXBIT. ;;; THIS SHOULD BE THE LAST DATA WORD IN THE FILE. ANY RELOCATION ;;; BYTES LEFT OVER AFTER A TYPE 17 ARE IGNORED. THIS SHOULD BE ;;; FOLLOWED EITHER BY END OF FILE OR A WORD FULL OF ^C'S. ;;; INTERNAL AUTOLOAD ROUTINE IALB: HRRZ A,(A) ;SUBR 1 MOVEI B,QA%DDD PUSHJ P,MERGEF JRST LOAD FASLOAD: JSP TT,FWNACK FA01234,,QFASLOAD SKIPE FASLP JRST LDALREADY PUSH P,FLP ;FOR DEBUGGING PURPOSES PUSH P,FXP .SEE LDEOMM PUSH P,SP 10$ SETOM LDEOFP ;FLAG FOR CRUFTY D10 DUMP MODE I/O EOF PUSHJ P,FIL6BT MOVE T,DFNWD ;DEFAULT FILE-NAME WORD - "*" MOVE TT,DFFNWD ;DEFAULT FASL-FILE-NAME WORD - "FASL" 20$ SKIPE -L.6VRS-L.6EXT+1(FXP) ;EXTENSION (2ND FILE NAME) NULL? CAMN T,-L.6VRS-L.6EXT+1(FXP) ; OR EQUAL TO *? IF EITHER CASE, MOVEM TT,-L.6VRS-L.6EXT+1(FXP) ; THEN USE "FASL" IFN D20,[ MOVE TT,[ASCII \0\] SKIPE -L.6VRS+1(FXP) ;VERSION NUMBER NULL? CAMN T,-L.6VRS+1(FXP) ; OR EQUAL TO *? IF EITHER CASE, MOVEM TT,-L.6VRS+1(FXP) ; THEN USE "0" ] ;END OF IFN D20 PUSHJ P,DMRGF PUSHJ P,6BTNML MOVEI B,TRUTH JSP T,SPECBIND 0 A,LDFNAM ;MUST BIND LDFNAM FOR RECURSIVE FASLOADING 0 B,VNORET FASLP PUSH P,[LDXXY1] PUSH P,A PUSH P,[QFIXNUM] MOVNI T,2 JRST $OPEN LDXXY1: MOVEM A,FASLP PUSH P,A HRRZM A,LDBSAR MOVE A,LDFNAM SETZM LDTEMP ;CROCK! ;FALLS THROUGH ;FALLS IN ;;; COME HERE TO "DO IT SOME MORE" LDDISM: PUSHJ P,LDGDDT ;SET UP DDT FLAG: 0 => NO DDT; PUSH P,TT ;-1,,0 => DDT, NO SYMBOLS; 1,,X => DDT, SYMBOLS ;X MAY BE 0, OR SAR FOR SYMBOL TABLE ARRAY ; (SEE LDPUT) SKIPN F,VPURE ;SET UP CALL PURIFY FLAGS: ;400000,,XXX => NO PURIFY HACKERY TLOA F,400000 ;200000,,XXX => SUBST XCTS FOR CALLS, ; PUT CALLS IN SEPARATE PAGES ;100000 BIT MEANS FASLOAD INTO HISEG (D10 ONLY) HRRZ F,VPURCLOBRL ;0,, => SUBST PUSHJS AND ; JRSTS FOR CALLS PUSH P,F ; ANY CALLS NOT IMMEDIATELY SMASHABLE MOVE A,VPURE ; ARE CONSED ONTO THE PURE LIST PUSHJ P,FIXP ;LEAVES VALUE IN TT IF INDEED FIXNUM JUMPE A,LDXXX1 MOVSI F,200000 IORM F,(P) IFN *HISEGMENT,[ JUMPGE TT,LDXQQ7 ;IF PURE IS A NEGATIVE FIXNUM, DO HISEG HACKERY IFE SAIL,[ HRROI T,.GTSGN ;FIND WHETHER HISEG SHARABLE (FROM GETTAB T, ;6.03 MONITOR CALLS) JRST .+2 TLNN T,(SN%SHR) ] ;END OF IFE SAIL SA$ SKIPL .JBHRL ;IS HISEG CURRENTLY WRITE-PROTECTED? JRST LDXQQ5 PUSH FXP,TT LOCKI ;LOCK OUT INTS AROUND USE OF TMPC SKIPN SGANAM JSP T,FASLUH MOVEI T,.IODMP MOVE TT,SGADEV SETZ D, OPEN TMPC,T ;OPEN UP .SHR FILE DEVICE IN DUMP MODE JSP T,FASLUH MOVE T,SGANAM MOVE TT,SGAEXT SETZ D, MOVE R,SGAPPN LOOKUP TMPC,T JSP T,FASLUR SA$ MOVS T,R SA% JUMPGE R,FASLUR SA% HLRE T,R MOVNS T ;T GETS LENGTH OF .SHR FILE PUSHJ P,LDRIHS ;GO READ IN HIGH SEGMENT (FROM WITHIN LOSEG!) LDRTHS: RELEASE TMPC, ;FLUSH TEMP CHANNEL UNLOCKI POP FXP,TT MOVE F,SVPRLK ;CAN NOW USE SAVED PURE SEGMENTS FROM LAST TIME SETZM SVPRLK MOVEM F,PRSGLK LDXQQ5: MOVSI F,100000 IORM F,(P) ;SET FLAG SAYING WE'RE HACKING THE HISEG MOVMS TT PUSHJ P,LDXHHK ;SET UP XCT PAGES USING HISEG MOVE A,V.PURE PUSHJ P,FIXP ;LEAVES VALUE IN TT IN INDEED FIXNUM JUMPE A,LDXXX1 ;IF FIXNUM, IT IS AN ESTIMATE OF PURE FREE STG CAIG TT,10 ;IF 10 OR LESS, MULTIPLY BY 1024. LSH TT,12 CAILE TT,0 ;CHECK FOR REASONABLENESS CAILE TT,MEMORY+.RL1-ENDHI JRST LDYERR MOVSI D,-NFF-1 SUB TT,PFSSIZ(D) ;SUBTRACT FROM ESTIMATE THE CURRENT AOBJN D,.-1 ; SIZES OF EXISTING PURE AREAS MOVE D,PRSGLK LDXQQ2: JUMPE D,LDXQQ3 ;ALSO ACCOUNT FOR ANY PURE SEGMENTS SUBI TT,SEGSIZ ; ALREADY IN THE FREELIST LDB D,[SEGBYT,,GCST(D)] JRST LDXQQ2 LDXQQ3: JUMPLE TT,LDXXX1 ;JUMP IF GUESSTIMATE ALREADY SATISFIED ADDI TT,SEGSIZ-1 ;ROUND UP TO AN INTEGRAL ANDI TT,SEGMSK ; NUMBER OF SEGMENTS MOVE D,HBPORG ADDI D,SEGSIZ-1 ;ALSO ROUND UP HISEG BPORG ANDI D,SEGMSK MOVE R,D ADD D,TT SUBI D,1 TLNE D,-1 JRST FASLNX ;COMPLAIN IF NOT ENOUGH MEMORY MOVEM D,HBPORG ;UPDATE HISEG BPORG PAST ALLOCATED SEGMENTS AOS HBPORG CAMG D,HBPEND JRST LDXQQ6 MOVEM D,HBPEND ;IF NEW HISEG BPORG TOO LARGE, SA% HRLZI D,(D) SA% CORE D, SA$ CORE2 D, ; MUST REQUEST MORE CORE FOR HISEG JRST FASLNX ;COMPLAIN IF NOT ENOUGH MEMORY LDXQQ6: LSH R,-SEGLOG ;UPDATE SEGMENT TABLES, LSH TT,-SEGLOG ; AND ADD PURE SEGMENTS TO FREELIST MOVE D,[$XM+PUR,,QRANDOM] MOVE F,PRSGLK LDXQQ8: MOVEM D,ST(R) SETZM GCST(R) DPB F,[SEGBYT,,GCST(R)] MOVEI F,(R) ADDI R,1 SOJG TT,LDXQQ8 MOVEM F,PRSGLK JRST LDXXX1 ] ;END OF IFN *HISEGMENT IFN D10*,[ LDXQQ7: HS% MOVMS TT PUSHJ P,LDXHAK ;SET UP XCT HACK PAGES WITHOUT HISEG ] ;END IFN D10* ;FALLS THROUGH ;FALLS IN LDXXX1: MOVE TT,[-LLDAT+1,,1] ;INIT ATOMTABLE AOBJN INDEX MOVEM TT,LDAAOB MOVEI TT,LLDAT ;CREATE ATOMTABLE ARRAY MOVSI A,400000 PUSHJ P,MKLSAR PUSH P,A ;SAVE SAR OF ATOM-TABLE ARRAY FOR GC PROTECTION HRRZM B,LDASAR ;SAVE ADDRESS OF SAR PUSHJ P,LDLRSP ;LOCKI, AND SET UP ARRAY POINTERS SETZ TT, ;ENTRY 0 IN ATOMTABLE IS FOR NIL SETZM @LDAPTR MOVEI TT,LDFERR ;INIT ADDRESS FOR PREMATURE EOF MOVEM TT,LDEOFJ SKIPE F,LDTEMP ;IF LDTEMP IS NON-NIL, IT IS THE SAVED I/O BUFFER POINTER JRST LDXXX9 JSP T,LDGTW1 ;GET FIRST WORD OF FILE TRZ TT,1 ;COMPATIBILITY CROCK CAME TT,[SIXBIT \*FASL*\] ;IT BETTER BE THIS VALUE! JSP D,LDFERR LDXXX9: JSP T,LDGTWD ;GET VERSION OF LISP FILE WAS ASSEMBLED IN XOR TT,LDFNM2 MOVEM TT,LDF2DP ;NON-ZERO IFF VERSIONS DIFFERENT MOVE AR1,[000400,,LDBYTS] ;INIT RELOCATION BYTES POINTER SETZM LDHLOC HRRZ R,@VBPORG HS$ 10$ MOVE TT,LDPRLS(P) HS$ 10$ TLNE TT,100000 ;SKIP UNLESS LOADING INTO HISEG HS$ 10$ HRRZ R,HBPORG HRRM R,LDOFST ;INITIALIZE LOAD OFFSET JRST LDABS0 ;R HAS ADDRESS TO LOAD NEXT WORD INTO SUBTTL ROUTINE TO SET UP PAGES FOR XCT HACK (NON-PAGING, FIXED NUMBER OF SLOTS) IFE PAGING,[ ;;; TT HAS NUMBER OF WORDS (1K BLOCKS IF <8) DESIRED. LDXHHK: HRROS (P) ;THIS ENTRY USES THE HISEG LDXHAK: SKIPE LDXSIZ ;MAYBE WE NEED TO SET UP PAGES FOR XCT HACKERY POPJ P, ;IF NOT, JUST EXIT JUMPLE TT,LDXERR CAIG TT,10 ;IF 10 OR LESS, MULTIPLY BY 1024. LSH TT,12 ADDI TT,PAGSIZ-1 ;ROUND UP TO A WHOLE NUMBER OF PAGES ANDI TT,PAGMSK TLNE TT,-1 JRST LDXERR PUSH FXP,TT MOVE D,(FXP) ;GET ESTIMATED NUMBER OF LINKS MOVEM D,LDXSIZ ;SAVE AS SIZE OF XCT AREA MOVEM D,LDXSM1 ;ALSO NEED THAT VALUE MINUS 1 SOS LDXSM1 MOVE TT,@VBPORG ;CREATE TWO AREAS IN BPS THAT BIG: HRRZ T,TT ; THE FIRST FOR THE XCTS TO POINT TO, ADD TT,D ; THE SECOND TO RESTORE THE FIRST FROM HRL T,TT MOVE R,(P) TLNE R,1 HRL T,HBPORG MOVEM T,LDXBLT ;SAVE BLT POINTER FOR RESTORING TLNN R,1 ;USING HISEG, DON'T TAKE SECOND AREA FROM LOSEG ADD TT,D ;ADD IN FOR SECOND AREA JSP T,FXCONS ;NEW VALUE FOR BPORG PUSH P,A TLNN R,1 LSH D,1 MOVE TT,D PUSHJ P,LGTSPC ;NOW TRY TO GET REQUIRED CORE JUMPE TT,FASLNX MOVE R,-1(P) TLNN R,1 JRST LDXHK3 MOVE D,(FXP) ;GOBBLE SECOND AREA OUT OF HISEG ADD D,HBPORG TLNN D,-1 JRST LDXHK2 LDXHK1: SETZM LDXSIZ ;HAVEN'T REALLY WON AFTER ALL JRST FASLNX LDXHK2: MOVEM D,HBPORG SUBI D,1 CAMG D,HBPEND ;MAY NEED TO EXTEND HISEG JRST LDXHK3 MOVEM D,HBPEND SA% HRLZI D,(D) SA% CORE D, SA$ CORE2 D, JRST LDXHK1 LDXHK3: POP P,VBPORG ;GIVE BPORG NEW VALUE MOVE T,LDXBLT ;ZERO OUT BOTH AREAS MOVE TT,@VBPORG HRL T,T SETZM (T) ADDI T,1 BLT T,-1(TT) TLNN R,1 JRST LDXHK5 MOVS T,LDXBLT ;WHEN USING HISEG, NEED AN EXTRA MOVE TT,HBPORG ; BLT TO ZERO OUT SECOND AREA BLT T,-1(TT) LDXHK5: HRRZ T,LDXBLT ;SET UP LDXDIF WITH THE DIFFERENCE HLRZ TT,LDXBLT ; BETWEEN THE ORIGINS OF AREA 1 AND SUB T,TT .SEE LDPRC6 HRRM T,LDXDIF ; AREA 2 TO MAKE INSTALLING ENTRIES EASIER POPI FXP,1 JRST TRUE ] ;END IFE PAGING SUBTTL PAGING, VARIABLE NUMBER OF XCT PAGES, DYNAMICALLY ALLOCATED IFN PAGING,[ LDXHAK: PUSH FXP,AR1 ;AR1 MUST BE PRESERVED, AT ALL COSTS! LOCKI ;INTERRUPTS MUST BE OFF OVER CALL TO GRBSEG PUSHJ P,GRBSEG ;GET ONE SEGMENT OF TYPE RANDOM JRST LDXIRL ;RELEASE INTERRUPTS AND GIVE NON-SKIP RETURN UNLOCKI PUSHJ P,GRBPSG ;GET ONE PURE SEGMENT INTO AC T POP FXP,AR1 LSH T,SEGLOG ;MAKE PURE SEGMENT INTO ADDRESS HRRZM T,LDXPSP(TT) ;REMEMBER PURE SEGMENT ADDRESS HRLI T,(T) ;BUILD A BLT POINTER TO ZERO PURE PAGE HRRZI D,SEGSIZ-1(T) ;LAST LOC TO ZERO SETZM (T) ;ZERO FIRST LOC ADDI T,1 BLT T,(D) ;AND ALL THE REST HRLZI T,LDXOFS(TT) ;BUILD BLT POINTER TO CLEAR NEW IMPURE SEG HRRI T,LDXOFS+1(TT) SETZM LDXOFS(TT) BLT T,SEGSIZ-1(TT) ;CLEAR THE WHOLE SEGMENT MOVNI T,LDHSH1+1 ;NUMBER OF ENTRIES IN TABLE IMULI T,LDX%FU ;MAKE INTO NEGATIVE PERCENTAGE PUSH FXP,TT IDIVI T,100. POP FXP,TT MOVEM T,LDXLPC ;AND THE COUNT MOVE T,LDXLPL ;REMEMBER LOC OF LAST PAGE USED MOVEM TT,LDXLPL ;SAVE THIS PAGE LOCATION JUMPE T,LDXFLC ;STORE IN POINTER LOC IF NO PREVIOUS SEGMENTS HRLM TT,(T) ;LINK INTO LIST AOS (P) POPJ P, LDXFLC: MOVEM TT,LDXPNT AOS (P) POPJ P, LDXIRL: UNLOCKI POP FXP,AR1 POPJ P, ] ;END IFN PAGING SUBTTL MAIN FASLOAD LOOP ;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED, ;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES: ;;; AR1 BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES ;;; R AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE ;;; F AOBJN INDEX FOR ACCESSING WORDS FROM INPUT BUFFER ARRAY LDREL: HRRI TT,@LDOFST ;[RELOCATABLE WORD] LDABS: MOVEM TT,(R) ;[ABSOLUTE WORD] LDABS1: AOBJN R,LDBIN ;JUMP IF ROOM LEFT OF WHAT WE GRABBED LDABS0: 10$ MOVE TT,LDPRLS(P) ;FOR D10, MUST PASS LDPRLS IN TT TO LDGTSP PUSHJ P,LDGTSP PUSHJ P,LDRSPT LDBIN: SKIPE INTFLG ;[LOAD BINARY WORD (OR SOME OTHER MESS)] PUSHJ P,LDTRYI ;GIVE A POOR INTERRUPT A CHANCE IN LIFE TLNN AR1,770000 JRST LDBIN2 ;OUT OF RELOCATION BYTES - MUST GET MORE LDBIN1: JSP T,LDGTWD ;GET WORD FROM INPUT FILE ILDB T,AR1 ;GET CORRESPONDING RELOCATION BYTE JSP D,@LDTTBL(T) ; - IT TELLS US WHERE TO GO LDBIN2: JSP T,LDGTWD ;GET WORD OF RELOCATION BYTES MOVEM TT,LDBYTS SOJA AR1,LDBIN1 ;INIT BYTE POINTER AND GO GET DATA WORD LDTTBL: LDABS ; 0 ABSOLUTE LDREL ; 1 RELOCATABLE LDSPC ; 2 SPECIAL LDPRC ; 3 PURIFIABLE CALL LDQAT ; 4 QUOTED ATOM LDQLS ; 5 QUOTED LIST LDGLB ; 6 GLOBALSYM PATCH LDGET ; 7 GET DDT SYMBOL PATCH LDAREF ; 10 ARRAY REFERENCE LDFERR ; 11 UNUSED LDATM ; 12 ATOMTABLE ENTRY LDENT ; 13 ENTRY POINT INFO LDLOC ; 14 LOC TO ANOTHER PLACE LDPUT ; 15 PUT DDT SYMBOL LDEVAL ; 16 EVALUATE MUNGEABLE LDBEND ; 17 END OF BINARY ;;; LOADER GET SPACE ROUTINE. PUTS SOME DISTANCE BETWEEN BPORG AND BPEND. ;;; R MUST BE SET UP ALREADY. FOR D10, TT MUST HAVE LDPRLS. ;;; THE LEFT HALF OF R IS ADJECTED TO REFLECT THE SPACE OBTAINED. LDGTSP: HS$ 10$ TLNE TT,100000 ;CHECK IF LOADING INTO HISEG HS$ 10$ JRST LDGSP3 ;IF SO, EXPAND THAT MOVE TT,@VBPEND ;SEE IF ENOUGH ROOM LEFT TO GRAB MORE SUB TT,@VBPORG SUBI TT,100 ;RANDOMLY CHOSEN QUANTITY JUMPGE TT,LDGSP1 ;YES - GO GRAB IT SAVEFX AR1 D R F MOVEI TT,4*PAGSIZ ;GET MANY BLOCKS OF BPS LDGS0A: MOVEM TT,GAMNT PUSHJ P,GTSPC1 JUMPN TT,LDGS0H MOVE TT,GAMNT CAIG TT,100 JRST FASLNC MOVEI TT,100 JRST LDGS0A LDGS0H: RSTRFX F R D AR1 LDGSP1: MOVEI TT,(R) ADDI TT,PAGSIZ ;TRY TO GOBBLE CAMLE TT,@VBPEND ; WORDS, BUT IN ANY CASE MOVE TT,@VBPEND ; NO MORE THAN BEYOND BPEND JSP T,FIX1A MOVEM A,VBPORG MOVEI TT,(R) SUB TT,@VBPORG HRLI R,(TT) ;INIT AOBJN POINTER IN R POPJ P, IFE PAGING+<1-D10>,[ LDGSP3: MOVE TT,HBPEND SUBI TT,(R) ;DO NOT MERGE THIS WITH FOLLOWING SUBI! MAYBE R>777700 SUBI TT,100 ;RANDOMLY CHOSEN QUANTITY JUMPGE TT,LDGSP6 MOVE TT,HBPEND ADDI TT,4*PAGSIZ TLNE TT,-1 MOVSI TT,(MEMORY) ADDI TT,PAGSIZ-1 ANDCMI TT,#PAGMSK ;*NOT* SAME AS ANDI TT,PAGMSK !!! MOVE T,TT SUBI T,1 CAMG T,HBPEND JRST LDGSP4 SA% HRLZI T,(T) SA% CORE T, SA$ CORE2 T, JRST FASLNC MOVE AR2A,[$XM+PUR,,QRANDOM] AOS B,HBPEND MOVEI C,(B) SUBI C,(TT) LSHC B,-SEGLOG HRLI B,(C) LDGSP5: MOVEM AR2A,ST(B) SETZM GCST(B) AOBJN B,LDGSP5 LDGSP4: MOVEM TT,HBPEND SOS HBPEND LDGSP6: MOVE TT,HBPEND MOVEM TT,HBPORG SUBM R,TT HRLI R,(TT) POPJ P, ] ;END OF IFE IFE PAGING+<1-D10> SUBTTL SPECIAL VALUE CELL AND QUOTED ATOM REFERENCES LDSPC: MOVE T,TT ;[SPECIAL] HLR TT,@LDAPTR ;GET ADDRESS OF SPECIAL CELL TRNE TT,777000 ;WAS SUCH AN ADDRESS REALLY THERE? JRST LDABS ;YES, WIN TRNE TT,6 ;NO, IF THIS ATOM ISN'T A SYMBOL JSP D,LDFERR ; THEN LOSE!!! HRRZ TT,T ;IS THERE AN ATOM THERE AT ALL HRRZ A,@LDAPTR SKIPN D,A JSP D,LDFERR ;NO, LOSE HLRZ B,(A) HRRZ A,(B) CAIE A,SUNBOUND JRST LDSPC1 PUSH P,D ;NONE THERE - MUST MAKE ONE MOVEI B,QUNBOUND JSP TT,MAKVC ;RETURN SY2 POINTER IN B LDSPC1: HLRZ TT,(B) ;GET SYMBOL FLAG BITS TRO TT,SY.CCN\SY.OTC ;NEEDED-BY-COMPILED-CODE, OTHER THAN CALL TRNN TT,SY.PUR ;WAS VALUE CELL PURE? HRLM TT,(B) ;NO, THEN MUST PROTECT VALUE CELL MOVE TT,T ;SAVE ADDRESS OF VALUE CELL HRLM A,@LDAPTR ; IN ATOMTABLE HRR TT,A ;AT LAST WE WIN JRST LDABS LDQAT: MOVE D,@LDAPTR ;[QUOTED ATOM] TRNE D,-1 ;DON'T HACK ANYTHING FOR NIL TLNE D,777000 ;EXIT IF SPECIAL, OR SYM BLK ALREADY HACKED JRST LDQATX TLON D,1 ;ELSE TURN ON REFERENCE BIT MOVEM D,@LDAPTR TLNE D,6 ;IF NON-SYMBOL, THEN MAYBE GCPROTECT IT JRST LDQAT1 HLRZ T,(D) ;IF SYMBOL, THEN MAYBE SET ITS "CCN" BITS HLL T,(T) ;FETCH SYMBOL BITS TLO T,SY.CCN\SY.OTC ;FLAG SYMBOL AS NEEDED FOR OTHER THAN CALL TLNN T,SY.PUR ;DON'T TRY TO WRITE IF PURE HLLM T,(T) LDQATX: HRRI TT,(D) JRST LDABS LDQAT1: TLOE D,10 ;IF NON-SYMBOL, AND IF NOT YET GC PROTECTED JRST LDQATX MOVEI A,(D) CAIGE A,IN0+XHINUM CAIGE A,IN0-XLONUM CAIA JRST LDQAT2 PUSHJ P,SAVX3 PUSH P,AR1 PUSHJ P,%GCPRO PUSHJ P,LDRSPT POP P,AR1 PUSHJ P,RSTX3 HRRI D,(A) LDQAT2: MOVEM D,@LDAPTR JRST LDQATX SUBTTL QUOTED LIST REFERENCES LDQLS: MOVSI D,11 ;[QUOTED LIST] SKIPL LDPRLS(P) ;CAN'T COUNT ON ANYTHING IN PURE MOVSI D,1 ; FREE STORAGE PROTECTING ANYTHING PUSHJ P,LDLIST ;GOBBLE UP A LIST MOVEM TT,(R) ;PUT WORD IN BPS JSP T,LDGTWD ;GET HASH KEY FOR LIST TLZ A,-1 SKIPE VGCPRO JRST LDQLS4 PUSH FXP,D PUSH FXP,AR1 TLZ A,-1 SKIPE D,TT JRST LDQLS3 PUSH P,A PUSHJ P,SXHSH0 POP P,A LDQLS3: SKIPN V.PURE ;SKIP FOR PURE HACKERY JRST LDQLS1 PUSH FXP,D ;SAVE HASH KEY PUSH P,A ;SAVE LIST MOVNI T,1 ;THIS MEANS JUST LOOKUP PUSHJ P,LDGPRO POP P,B POP FXP,D JUMPN A,LDQLS2 ;ON GCPRO LIST, SO USE IT MOVE A,B PUSHJ P,PURCOPY ;NOT ON GCPRO LIST, SO PURCOPY IT LDQLS1: MOVEI T,1 ;THIS MEANS PROTECT OR HAND BACK COPY PUSHJ P,LDGPRO ;PROTECT LIST FROM FEROCIOUS GC! LDQLS2: POP FXP,AR1 POP FXP,D LDQLS5: JUMPE D,LDEVL7 ;MAYBE THIS LIST GOES INTO ATOMTABLE HRRM A,(R) ;SAVE ADDRESS OF LIST (WHICH MAY JRST LDABS1 ; BE DIFFERENT NOW) BACK INTO WORD LDQLS4: JSP T,LDQLPRO JRST LDQLS5 LDQLPRO: HRRZ B,LDEVPRO ;GC-PROTECT HAPPENS BY PUSHING ONTO A LIST PUSHJ P,CONS MOVEM A,LDEVPRO JRST %CAR LDGPRO: SKIPE GCPSAR ;PROTECT SOMETHING ON THE GCPSAR JRST .GCPRO PUSHJ P,.GCPRO ;THE LOOKUP CAUSES THE CREATION OF A NEW ARRAY JRST LDRSPT ;SO WE HAVE TO RESTORE PTRS AFTERWARDS SUBTTL PURIFIABLE CALL LDPRC: MOVE D,@LDAPTR ;[PURIFIABLE CALL] TRNN D,-1 ;MUST HAVE NON-NIL ATOM TO CALL JSP D,LDFERR TLNE D,777000 JRST LDPRC1 ;JUMP IF ATOM HAS SPECIAL CELL TLNE D,6 JSP D,LDFERR ;LOSE IF NUMBER TLO D,1 ;ELSE TURN ON REFERENCE BIT MOVEM D,@LDAPTR HLRZ T,(D) ;FETCH SY2 DATA HLL T,(T) TLO T,SY.CCN ;ONLY CCN, NOT OTC!! TLNN T,SY.PUR ;ONLY IF IMPURE HLLM T,(T) LDPRC1: HRR TT,D ;PUT ADDRESS OF ATOM IN CALL SKIPGE T,LDPRLS(P) ;SKIP FOR PURIFYING HACKERY JRST LDABS ;OTHERWISE WE'RE DONE TLNN T,200000 ;SKIP FOR XCT STUFF SETZ T, ;ELSE DO ORDINARY SMASH PUSHJ P,PRCHAK ;*** SMASH! *** JRST LDABS1 MOVEI A,(R) ;NOT SMASHED - CONS ONTO PURE LIST MOVE B,LDPRLS(P) PUSHJ P,CONS MOVEM A,LDPRLS(P) JRST LDABS1 ;;; ROUTINE TO CLOBBER A CALL INTO BPS, POSSIBLY DOING XCT HACK. ;;; SKIPS ON *** FAILURE *** TO CLOBBER. ;;; T NON-ZERO => TRY XCT HACK; OTHERWISE ORDINARY SMASH. ;;; TT HAS UUO INSTRUCTION TO HACK. ;;; R HAS ADDRESS TO PUT UUO INTO. ;;; MUST PRESERVE AR1, R, F. IFE PAGING,[ ;VERSION FOR NON-PAGING ONLY, NEWER VERSION SUPPORTS EXTENDABLE NUMBER OF SEGMENTS PRCHAK: JUMPE T,LDPRC5 ;T ZERO => ORDINARY SMASH MOVE T,TT ;SAVE CALL IN T IDIV TT,LDXSM1 ;COMPUTE HASH CODE FOR CALL MOVNM D,LDTEMP ;SAVE NEGATIVE THEREOF HLRZ TT,LDXBLT ADD D,TT ;ADDRESS TO BEGIN SEARCH CAMN T,(D) ;WE MAY WIN IMMEDIATELY JRST LDPRC7 SKIPN (D) JRST LDPRC6 ADD TT,LDXSM1 ;ELSE MAKE UP AN AOBJN POINTER SUBI TT,-1(D) ; AND SEARCH FOR MATCHING CALL MOVNI TT,(TT) HRL D,TT LDPRC2: CAMN T,(D) JRST LDPRC7 ;FOUND MATCHING CALL SKIPN (D) JRST LDPRC6 ;FOUND EMPTY SLOT AOBJN D,LDPRC2 HRLZ D,LDTEMP ;WRAPPED OFF THE END OF THE XCT AREA HLR D,LDXBLT ; - MAKE UP NEW AOBJN POINTER LDPRC3: CAMN T,(D) ;SECOND COPY OF THE LOOP JRST LDPRC7 ;FOUND MATCHING CALL SKIPN (D) JRST LDPRC6 ;FOUND EMPTY SLOT AOBJN D,LDPRC3 LDPRC4: MOVE TT,T ;TOTAL LOSS - MUST DO SMASH LDPRC5: HRRZ AR2A,R ;PUT ADDRESS OF CALL IN AR2A MOVEM TT,(AR2A) ;PUT CALL IN THAT PLACE JRST LDSMSH ;NOW TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE LDPRC6: SKIPG LDXSIZ ;FOUND EMPTY SLOT JRST LDPRC4 ;CAN'T USE IT IF PAGES PURIFIED MOVEM T,(D) ;SAVE CALL INTO XCT AREA 2 MOVEM T,@LDXDIF ;ALSO SAVE INTO AREA 1 LDPRC7: ADD D,LDXDIF ;MAKE UP AN XCT TO POINT TO HRLI D,(XCT) ; CALL IN AREA 1 MOVEM D,(R) POPJ P, ] ;END IFE PAGING IFN PAGING,[ ;NEW STYLE SEARCH FOR PROPER LINK LOCATION; ADDS A NEW UUOLINKS SEGMENT IF ; OUT OF SPACE OR IF PARTIALLY EMPTY UUOLINK SEGMENT HAS BEEN PURIFIED PRCHAK: JUMPN T,PRCHA1 ;DON'T SMASH IMMEDIATLY IF T NON-ZERO PRCSMS: HRRZ AR2A,R ;PUT ADDRESS OF CALL IN AR2A MOVEM TT,(AR2A) ;PUT CALL IN THAT PLACE JRST LDSMSH ;TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE PRCHA1: PUSH FXP,R ;NEED D/R PAIR OF ACS MOVE D,TT ;GET COPY OF THE CALL IDIVI D,LDHSH1 ;COMPUTE FIRST HASH VALUE MOVEM R,LDXHS1 MOVE D,TT ;THEN THE SECOND HASH VALUE IDIVI D,LDHSH2 AOS R ;IT BEING ZERO COULD BE A DISASTER MOVEM R,LDXHS2 SKIPN T,LDXPNT ;GET POINTER JRST PRCH2A ;FIRST TIME THROUGH ALWAYS ADD NEW SEGMENT PRCH1A: HRRZ D,LDXPSP(T) ;GET POINTER TO PURE PAGE MOVEI R,LDXOFS(D) ;POINTER TO FIRST WORD OF DATA ADDI D,SEGSIZ-1 ;THIS IS THE LAST WORD IN THE SEGMENT ADD R,LDXHS1 ;START FROM THE FIRST HASH VALUE PRCH1B: CAMN TT,(R) ;MATCH? JRST PRCHA3 ;YUP, SO USE THIS SLOT SKIPN (R) ;END OF CHAIN? JRST PRCHA4 ;YES, ON TO NEXT SEGMENT ADD R,LDXHS2 ;STEP BY HASH VALUE CAILE R,(D) ;MUST NOT RUN OFF END OF SEGMENT SUBI R,LDHSH1 ;SO TAKE IT MOD LDHSH1 JRST PRCH1B ;AND TRY THIS SLOT PRCHA4: HLRZ D,LDXPSP(T) ;GET POINTER TO NEXT SEGMENT JUMPE D,PRCHA2 MOVEI T,(D) JRST PRCH1A PRCHA3: HRRZ D,LDXPSP(T) ;SUBTRACTING THIS WILL GIVE ABSOLUTE SEG OFFSET SUBM R,D ADDI D,(T) ;THEN PRODUCE POINTER TO FROB TO XCT POP FXP,R ;RESTORE POINTER TO CODE HRLI D,(XCT) MOVEM D,(R) ;THEN STORE THE NEW INSTRUCTION POPJ P, ;GET HERE WITH C(R) POINTING TO SLOT TO ADD NEW ENTRY TO IN PURE TABLE, DUE TO ; THE DESIGN OF THE MECHANISM, IN THE CASES THAT R IS INVALID, A NEW UUO PAGE ; WILL HAVE TO BE ADDED AND R WILL NOT BE USED. IF THAT IS CHANGED, THIS ; ROUTINE MUST BE FIXED PRCHA2: AOSLE LDXLPC ;IF THIS SEGMENT IS FULL JRST PRCH2A ; ADD A NEW ONE MOVEM TT,(R) ;STORE THE CALL IN THE POTENTIALLY PURE SEGMENT HRRZ D,LDXPSP(T) ;THEN BUILD POINTER TO IMPURE SEGMENT SUBM R,D ADDI D,(T) ;D CONTAINS ADR IN IMPURE SEGMENT MOVEM TT,(D) ;STORE THE CALL INSTRUCTION THERE POP FXP,R ;GET ADR OF ACTUAL CODE HRLI D,(XCT) ;THEN INSTRUCTION TO PLANT THERE MOVEM D,(R) POPJ P, PRCH2A: PUSH FXP,TT ;SAVE TT OVER SEGMENT GRAB PUSHJ P,LDXHAK ;ADD A NEW SEGMENT LERR [SIXBIT \CANNOT ADD NEW UUOLINKS SEGMENT - FASLOAD!\] POP FXP,TT MOVE T,LDXLPL ;GET POINTER TO THE PAGE JUST ADDED MOVEI D,LDXOFS(T) ;FIRST DATA ADR ADD D,LDXHS1 ;ADR TO INSTALL CALL INTO MOVEM TT,(D) ;STORE THE CALL TO BE POTENTIALLY SMASHED HRLI D,(XCT) ;THE XCT INSTRUCTION POP FXP,R MOVEM D,(R) ;PLANT IN CODE HRRZ D,LDXPSP(T) ;PURE SEGMENT POINTER ADD D,LDXHS1 ADDI D,LDXOFS MOVEM TT,(D) ;PLANT CALL IN POTENTIALLY PURE SEGMENT POPJ P, ;HERE TO TRY TO SMASH CALL IN IMPURE SEGMENT. CALLED ONLY IF FLAG IS SET. ; POINTER TO WORD IN THE SEGMENT IS IN D. DESTROYS A, B, C, T PRTRTS: HRRZ AR2A,D ;PUT ADDRESS OF CALL IN AR2A PUSH FXP,D ;SAVE VALUABLE AC'S PUSH FXP,TT PUSH FXP,T PUSHJ P,LDSMSH ;TRY TO SMASH THE CALL JFCL ;WE DON'T REALLY CARE IF IT WINS OR NOT POP FXP,T POP FXP,TT POP FXP,D POPJ P, ] ;END IFN PAGING ;;; SMASH A CALL-TYPE UUO IN MEMORY TO BE A PUSHJ OR JRST OR WHATEVER. ;;; AR2A HAS THE LOCATION OF THE CALL. ;;; RETURN SKIPS IF IT CAN'T BE SMASHED. ;;; DESTROYS A, B, C, T, TT, D; SAVES AR1, AR2A, R, F. ;;; MUST NOT USER ANY PDL EXCEPT THE REGPDL (P). .SEE PURIFY LDSMSH: MOVE T,(AR2A) LSH T,-33 ;T GETS THE CALL UUO OPCODE CAIL T,CALL_-33 CAILE T,CALL_-33+NUUOCLS POPJ P, ;RETURN IF NOT REALLY A CALL HRRZ A,(AR2A) MOVEI B,SBRL PUSHJ P,GETLA ;TRY TO GET SUBR, FSUBR, OR LSUBR PROP LDB D,[270400,,(AR2A)] JUMPE A,LDSMNS ;JUMP IF NOT ANY OF THOSE HLRZ B,(A) HRRZ T,(AR2A) HLRZ T,(T) HLRZ T,1(T) ;GET ARGS PROPERTY FOR FUNCTION NAME SOJL T,LDZA2 ;JUMP IF THERE ISN'T ANY CAIG T,NACS ;ARGS PROPERTY IS SCREWY IF THIS SKIPS! TLOA T,(CAIE D,) ;IF ARGS PROP OK, TEST FOR THAT EXACT NUMBER OF ARGS IN UUO LDZA2: MOVE T,[CAILE D,NACS] ;IF NO OR BAD ARGS PROP, JUST CHECK FOR RANGE CAIN B,QFSUBR MOVE T,[CAIE D,17] CAIN B,QLSUBR MOVE T,[CAIE D,16] XCT T ;AC FIELD OF CALL IS 0-5 FOR SUBRS, 16 LSUBR, 17 FSUBR JRST POPJ1 ;SKIP RETURN IF CALL DOESN'T MATCH FUNCTION TYPE OR # ARGS HRRZ A,(A) ;ELSE WIN - SMASH THE CALL HLRZ A,(A) ;SUBR ADDRESS NOW IN A SKIPA TT,(AR2A) LDZAOK: HRLI A,(@) .SEE ASAR MOVSI T,(PUSHJ P,) ;CALL BECOMES PUSHJ TLNE TT,20000 ADDI A,1 ;HACK NCALLS CORRECTLY - ENTER AT ROUTINE+1 TLNE TT,1000 MOVSI T,(JRST) ;JCALL BECOMES JRST LDZA1: IOR T,A MOVEM T,(AR2A) ;***SMASH!*** POPJ P, LDSMNS: HRRZ A,(AR2A) ;TRY TO GET ARRAY PROPERTY MOVEI B,QARRAY PUSHJ P,$GET MOVEI T,(A) LSH T,-SEGLOG MOVE T,ST(T) TLNN T,SA JRST POPJ1 ;LOSE IF NOT SAR LDB T,[TTSDIM,,TTSAR(A)] CAIE T,(D) ;MUST HAVE CORRECT NUMBER OF ARGS JRST POP1J MOVSI T,TTS IORM T,TTSAR(A) ;SET "COMPILED-CODE-NEEDS-ME" BIT IN SAR MOVE TT,(AR2A) TLNN TT,20000 JRST LDZAOK MOVSI T,(ACALL) ;FOR AN NCALL-TYPE UUO, SMASH IT TO TLNE TT,1000 ; BE A CROCKISH ACALL OR AJCALL MOVSI T,(AJCALL) JRST LDZA1 SUBTTL GETDDTSYM HACKERY LDGET: CAMN TT,XC-1 JRST LDLHRL MOVE D,TT ;[GET DDT SYMBOL PATCH] TLNN D,200000 ;MAYBE THE ASSEMBLER LEFT US A VALUE? JRST LDGET2 JSP T,LDGTWD ;FETCH IT THEN SKIPE LDF2DP JRST LDGET2 ;CAN'T USE IT IF VERSIONS DIFFER LDGET1: TLNE D,400000 ;MAYBE NEGATE SYMBOL? MOVNS TT LDB D,[400200,,D] ;GET FIELD NUMBER XCT LDXCT(D) ;HASH UP VALUE FOR FIELD MOVE T,LDMASK(D) ;ADD INTO FIELD ADD TT,-1(R) ; MASKED APPROPRIATELY AND TT,T ANDCAM T,-1(R) IORM TT,-1(R) JRST LDBIN LDGET2: UNLOCKI ;UNLOCK INTERRUPTS PUSH FXP,. ;RANDOM FXP SLOT PUSH FXP,AR1 ;SAVE UP ACS PUSH FXP,D PUSH FXP,R PUSH FXP,F MOVEI R,0 TLZ D,740000 REPEAT LOG2LL5,[ CAML D,LAPFIV+<1_>(R) ADDI R,1_ ] ;END OF REPEAT LOG2LL5 CAME D,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM JRST LDGT5A ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE LSH F,-42 LDB TT,LDGET6(F) MOVE TT,LSYMS(TT) JRST LDGT5B LDGT5A: MOVEI TT,R70 CAMN D,[SQUOZE 0,R70] JRST LDGT5B PUSHJ P,UNSQOZ ;CONVERT SQUOZE TO A LISP SYMBOL MOVEI C,(A) MOVEI B,QSYM ;TRY TO FIND SYM PROPERTY PUSHJ P,$GET JUMPN A,LDGETJ ;WIN IFN ITS,[ JSP T,SIDDTP ;MAYBE WE CAN GET VALUE FROM DDT? JRST LDGETX LDB T,[004000,,-2(FXP)] .BREAK 12,[..RSYM,,T] JUMPE T,LDGETX ;LOSE, LOSE, LOSE ] ;END OF IFN ITS IFN D10,[ SKIPN .JBSYM" JRST LDGETX LDB D,[004000,,-2(FXP)] LDGET4: MOVE TT,D IDIVI D,50 JUMPE R,LDGET4 PUSHJ P,GETDDJ JRST LDGETX ] ;END OF IFN D10 LDGT5B: MOVEM TT,-4(FXP) ;WIN, WIN - USE RANDOM FXP SLOT MOVEI A,-4(FXP) ; TO FAKE UP A FIXNUM JRST LDGETJ LDGETX: MOVEI A,(C) PUSHJ P,NCONS MOVEI B,QGETDDTSYM ;DO A FAIL-ACT PUSHJ P,XCONS PUSHJ P,LDGETQ LDGETJ: POP FXP,F ;RESTORE ACS POP FXP,R POP FXP,D POP FXP,AR1 PUSHJ P,LDLRSP ;LOCKI AND RESTORE ARRAY POINTERS MOVE TT,(A) PUSHJ P,TYPEP ;FIGURE OUT WHAT WE GOT BACK POP FXP,-1(FXP) ;POP RANDOM SLOT (REMEMBER THE LOCKI!) CAIN A,QFIXNUM JRST LDGET1 LDGETV: CAIN A,QFLONUM ;USE A FLONUM IF WE GET ONE JRST LDGET1 LDGETW: PUSHJ P,LDGDDT ;FOR ANYTHING ELSE TRY DDT AGAIN MOVEM TT,LDDDTP(P) JRST LDGET2 LDGET6: REPEAT 4,[<11_24.>+<<<3-.RPCNT>*11>_30.> LAP5P(R) ] IFN ITS,[ LDGDDT: JSP T,SIDDTP JRST ZPOPJ ;0 => TOP LEVEL, OR NOT INFERIOR TO DDT .BREAK 12,[..RSTP,,TT] ;-1,,0 => INFERIOR TO DDT, BUT NO SYMBOL TABLE SKIPN TT ;1,,0 => INFERIOR TO DDT WITH SYMBOL TABLE TLOA TT,-1 MOVSI TT,1 POPJ P, ] ;END OF IFN ITS IFN D20,[ LDGDDT==:ZPOPJ ;FOR NOW, NEVER A DDT ] ;END IFN D20 IFN D10,[ LDGDDT: SKIPE TT,.JBSYM" MOVSI TT,1 POPJ P, ] ;END OF IFN D10 LDXCT: MOVSS TT ;INDEX FIELD HRRZS TT ;ADDRESS FIELD LSH TT,23. ;AC FIELD JFCL ;OPCODE FIELD LDMASK: -1 ;INDEX FIELD 0,,-1 ;ADDRESS FIELD 0 17, ;AC FIELD -1 ;OPCODE FIELD LDLHRL: HRLZ TT,LDOFST ADDM TT,-1(R) JRST LDBIN SUBTTL ARRAY, GLOBALSYM, AND ATOMTABLE ENTRY STUFF LDAREF: PUSH FXP,TT ;[ARRAY REFERENCE] MOVE D,@LDAPTR TLNN D,777001 TLO D,11 MOVEM D,@LDAPTR TRNN D,-1 JRST LDARE1 ;SKIP IF HACKING 'NIL' TLNE D,777000 ;IF NO VC THEN MUST HACK SYMBOL JRST LDARE1 HLRZ T,(D) HLL T,(T) TLO T,SY.CCN\SY.OTC ;COMPILED CODE NEEDS, OTHER THAN CALL REF TLNN T,SY.PUR ;CAN'T WRITE IF PURE HLLM T,(T) LDARE1: MOVEI A,(D) PUSHJ P,TTSR+1 ;NCALL TO TTSR HLL TT,(FXP) SUB FXP,R70+1 JRST LDABS LDGLB: SKIPL TT ;[GLOBALSYM PATCH] SKIPA TT,LSYMS(TT) ;GET VALUE OF GLOBAL SYMBOL MOVN TT,LSYMS(TT) ;OR MAYBE NEGATIVE THEREOF ADD TT,-1(R) ;ADD TO ADDRESS FIELD OF HRRM TT,-1(R) ; LAST WORD LOADED JRST LDBIN LDATM: LDB T,[410300,,TT] ;[ATOMTABLE ENTRY] JRST LDATBL(T) LDATBL: JRST LDATPN ;PNAME JRST LDATFX ;FIXNUM JRST LDATFL ;FLONUM BG$ JRST LDATBN ;BIGNUM BG% JRST LDATER DB$ JRST LDATDB ;DOUBLE DB% JRST LDATER CX$ JRST LDATCX ;COMPLEX CX% JRST LDATER DX$ JRST LDATDX ;DUPLEX DX% JRST LDATER .VALUE ;UNDEFINED LDATPN: MOVEI D,(TT) ;[ATOMTABLE PNAME ENTRY] PUSH FXP,R CAILE D,LPNBUF JRST LDATP2 MOVEI C,PNBUF-1 LDATP1: JSP T,LDGTWD ADDI C,1 MOVEM TT,(C) SOJG D,LDATP1 SETOM LPNF JRST LDATP4 LDATP2: PUSH FXP,D LDATP3: JSP T,LDGTWD JSP T,FWCONS PUSH P,A SOJG D,LDATP3 POP FXP,T MOVNS T PUSHJ FXP,LISTX SETZM LPNF LDATP4: PUSH FXP,AR1 PUSHJ P,RINTERN POP FXP,AR1 POP FXP,R LDATP8: MOVE TT,LDAAOB MOVEM A,@LDAPTR AOBJP TT,LDAEXT MOVEM TT,LDAAOB JRST LDBIN LDATFX: JSP T,LDGTWD ;[ATOMTABLE FIXNUM ENTRY] PUSH FXP,TT MOVEI A,(FXP) PUSH P,AR1 PUSHJ P,GCLOOK POP P,AR1 POP FXP,TT SKIPE A LDATX0: TLOA A,10 JRST LDATX2 LDATX1: TLO A,2 JRST LDATP8 LDATX2: SKIPE V.PURE JRST LDATX3 JSP T,FXCONS JRST LDATX1 LDATX3: PUSHJ P,PFXCONS JRST LDATX0 LDATFL: JSP T,LDGTWD ;[ATOMTABLE FLONUM ENTRY] PUSH FLP,TT MOVEI A,(FLP) PUSH P,AR1 PUSHJ P,GCLOOK POP P,AR1 POP FLP,TT SKIPE A LDATL0: TLOA A,10 JRST LDATL2 LDATL1: TLO A,4 JRST LDATP8 LDATL2: SKIPE V.PURE JRST LDATL3 JSP T,FLCONS JRST LDATL1 LDATL3: PUSHJ P,PFLCONS JRST LDATL0 IFN BIGNUM,[ LDATBN: PUSH FXP,TT ;[ATOMTABLE BIGNUM ENTRY] MOVEI D,(TT) MOVEI B,NIL LDATB1: JSP T,LDGTWD SKIPE V.PURE JRST LDATB2 JSP T,FWCONS PUSHJ P,CONS JRST LDATB3 LDATB2: PUSHJ P,PFXCONS PUSHJ P,PCONS LDATB3: MOVE B,A SOJG D,LDATB1 POP FXP,TT TLNE TT,1 TLO A,-1 SKIPE V.PURE JRST LDATB6 PUSH P,AR1 PUSHJ P,BNCONS PUSH P,A ;SAVE NEWLY-CONSTRUCTED BIGNUM PUSHJ P,GCLOOK ;SEE IF ONE ALREADY AVAILABLE POP P,B POP P,AR1 JUMPN A,LDATB8 MOVE A,B JRST LDATB7 LDATB6: PUSHJ P,PBNCONS LDATB8: TLO A,10 LDATB7: TLO A,6 JRST LDATP8 ] ;END OF IFN BIGNUM LDAEXT: MOVE T,TT ;[ATOMTABLE EXTEND] HRLI T,-ILDAT MOVEM T,LDAAOB ADDI TT,ILDAT ASH TT,1 UNLOCKI .SEE ERROR5 ;.REARRAY MAY PULL AN ERINT PUSH FXP,AR1 PUSH FXP,R PUSH FXP,F PUSH P,[LDRFRF] PUSH P,LDASAR PUSH P,[TRUTH] PUSH FXP,TT MOVEI A,(FXP) PUSH P,A MOVNI T,3 JRST .REARRAY LDRFRF: SUB FXP,R70+1 ;[RETURN FROM .REARRAY FUNCTION] POP FXP,F POP FXP,R POP FXP,AR1 PUSHJ P,LDLRSP JRST LDBIN SUBTTL ENTRY POINT LDENT: HRRZ C,@LDAPTR ;[ENTRY POINT INFO] MOVSS TT HRRZ A,@LDAPTR PUSH P,A PUSH P,C SKIPN B,VFASLOAD JRST LDNRDF CAIN B,TRUTH ;IF C(FASLOAD) IS T MOVEI B,SBRL ;THEN USE (SUBR LSUBR FSUBR) HRRZ A,(P) ;IS PROPERTY BEING DEFINED ONE OF INTEREST? PUSHJ P,MEMQ1 JUMPE A,LDNRDF ;NOPE, SO PRINT NO MESSAGES MOVE B,VFASLOAD CAIN B,TRUTH ;IF C(FASLOAD) IS T MOVEI B,SBRL ;THEN USE (SUBR LSUBR FSUBR) HRRZ A,-1(P) ;ATOM THAT IS BEING HACKED PUSHJ P,GETL ;DID THIS PREVIOUSLY HAVE A PROP OF INTEREST? JUMPE A,LDNRDF ;NOPE, NO MESSAGES TO BE PRINTED PUSH P,A PUSH FXP,AR1 PUSH FXP,R PUSH FXP,F MOVEI A,TRUTH JSP T,SPECBIND 0 A,V%TERPRI STRT 17,[SIXBIT \^M;CAUTION#! !\] MOVE A,-2(P) PUSHJ P,MSGFCK TLO AR1,200000 PUSHJ P,$PRIN1 ;SAVES AR1 HRRZ B,@(P) HLRZ B,(B) MOVEI TT,[SIXBIT \, A SYSTEM !\] 10% CAIL B,ENDFUN 10$ CAIGE B,BEGFUN MOVEI TT,[SIXBIT \, A USER !\] STRT 17,(TT) HLRZ A,@(P) PUSHJ P,$PRIN1 ;AR1 IS STILL GOOD HRRZ TT,@(P) HLRZ TT,(TT) MOVEI T,(TT) LSH T,-SEGLOG HRRZ T,ST(T) CAIE T,QRANDOM JRST LDENT4 STRT 17,[SIXBIT \ AT !\] ;USE OF PRINL4 HERE DEPENDS ON PRIN1 PUSHJ P,PRINL4 ; LEAVING ADDRESS OF TYO IN R (AND FILES IN AR1) LDENT4: STRT 17,[SIXBIT \, IS BEING REDEFINED^M; AS A !\] HRRZ A,-1(P) PUSHJ P,$PRIN1 STRT 17,[SIXBIT \ BY FASL FILE !\] MOVE A,LDFNAM PUSHJ P,$PRIN1 PUSHJ P,TERP1 PUSHJ P,UNBIND POP FXP,F POP FXP,R POP FXP,AR1 SUB P,R70+1 LDNRDF: MOVE B,(P) MOVE A,-1(P) PUSHJ P,REMPROP POP P,C MOVE A,(P) JSP T,LDGTWD PUSH FXP,TT MOVEI B,@LDOFST CAILE B,(R) JSP D,LDFERR PUSHJ P,PUTPROP POP FXP,TT HLRZ T,TT HLRZ B,@(P) HLRZ D,1(B) CAIN D,(T) ;NEEDN'T DO IT IF ALREADY SAME JRST LDPRG3 LDPARG: ;ELSE TRY TO CLOBBER IT IN PURTRAP LDPRG9,B, HRLM T,1(B) LDPRG3: SUB P,R70+1 JRST LDBIN SUBTTL PUTDDTSYM FROM FASL FILE ;;; THE WORD IN TT HAS SQUOZE FOR DEFINED SYMBOL, PLUS FOUR BITS: ;;; 4.9 1 => FOLLOWING WORD IS VALUE, 0 => LOAD LOC IS VALUE ;;; 4.8 LH IS RELOCATABLE ;;; 4.7 RH IS RELOCATABLE ;;; 4.6 IS GLOBAL (0 => SYMBOLS = 'T LOADS, BUT = 'SYMBOLS DOES NOT) LDPUT: SKIPN A,V$SYMBOLS JRST LDPUT3 ;FORGET IT IF "SYMBOLS" IS () CAIE A,Q$SYMBOLS JRST LDPUT7 TLNN TT,40000 ;IF "SYMBOLS" IS BOUND TO "SYMBOLS", THEN JRST LDPUT3 ; LOAD ONLY GLOBALS LDPUT7: IFE ITS,[ SKIPN .JBSYM" JRST LDPUT3 PUSH FXP,AR1 ] ;END OF IFE ITS JUMPL TT,LDPUT2 MOVE D,R LDPUT0: IT% PUSH FXP,D IT% PUSH FXP,F TLZ TT,740000 TLO T,%SYGBL+%SYHKL ;GLOBAL AND HALF-KILLED IFN ITS,[ SKIPG A,LDDDTP(P) JRST LDBIN ;FORGET IT IF DDT HAS NO SYMBOL TABLE MOVE T,TT TRNE A,-1 ;MAY HAVE TO CREATE SYMBOL TABLE ARRAY JRST LDPUT5 UNLOCKI PUSH FXP,AR1 PUSHJ P,SAVX5 MOVEI TT,LLDSTB*2+1 MOVSI A,-1 PUSHJ P,MKFXAR PUSHJ P,RSTX5 POP FXP,AR1 PUSHJ P,LDLRSP HRRM A,LDDDTP(P) LDPUT4: MOVSI TT,-LLDSTB ;USE TT FOR TWO THINGS HERE! MOVEM TT,@TTSAR(A) LDPUT5: SETZ TT, AOS TT,@TTSAR(A) ;GET AOBJN POINTER JUMPGE TT,LDPUT4 MOVEM T,@TTSAR(A) ;SAVE SQUOZE FOR SYMBOL ADD TT,R70+1 MOVEM D,@TTSAR(A) ;SAVE ITS VALUE MOVE T,TT SETZ TT, MOVEM T,@TTSAR(A) ;SAVE BACK INCREMENTED AOBJN PTR JUMPL T,LDBIN PUSHJ P,LDPUTM ;MAY BE TIME TO OUTPUT BUFFER ] ;END OF IFN ITS IFN D10,[ LDPUT1: MOVE T,TT IDIVI TT,50 JUMPE D,LDPUT1 MOVEI B,-1(FXP) MOVSI R,400000 PUSHJ P,PUTDD0 POP FXP,F POP FXP,R POP FXP,AR1 ] ;END OF IFN D10 JRST LDBIN IFN ITS,[ LDPUTM: SETZ TT, MOVN T,@TTSAR(A) MOVSI T,(T) HRR T,TTSAR(A) AOSGE T .BREAK 12,[..SSTB,,T] POPJ P, ] ;END OF IFN ITS, LDPUT2: MOVE D,TT JSP T,LDGTWD EXCH TT,D TLNN TT,100000 JRST LDPT2A MOVE T,LDOFST ADD T,D HRRM T,D LDPT2A: TLNN TT,200000 JRST LDPUT0 HRLZ T,LDOFST ADD D,T JRST LDPUT0 LDPUT3: JUMPGE TT,LDBIN ;DON'T WANT TO PUT DDT SYM, BUT JSP T,LDGTWD ; MAYBE NEED TO FLUSH EXTRA WORD JRST LDBIN LDLOC: MOVEI TT,@LDOFST MOVEI D,(R) CAMLE D,LDHLOC MOVEM D,LDHLOC CAMG TT,LDHLOC JRST LDLOC5 MOVE D,LDHLOC SUBI D,(R) MOVSI D,(D) ADD R,D HRR R,LDHLOC SETZ TT, SUB F,R70+1 ;BEWARE THIS BACK-UP CROCK! ADD AR1,[040000,,] JRST LDABS LDLOC5: HRRZ D,LDOFST CAIGE TT,(D) JSP D,LDFERR MOVEI D,(TT) SUBI D,(R) MOVSI D,(D) ADD R,D HRRI R,(TT) JRST LDBIN SUBTTL EVALUATE MUNGEABLE LDEVAL: SETZ D, ;[EVALUATE MUNGEABLE] PUSHJ P,LDLIST ;IF D IS LEFT 0 AFTER LDLIST, THEN WANT ENTRY INTO ATOMTABLE MOVEI B,(P) ;B HAS ADDR OF FASLOAD TEMPS ON STACK PUSH P,A PUSHJ P,LDEV0 SUB P,R70+1 JUMPN D,LDBIN JSP T,LDQLPRO ;PUSHES GOODY ONTO THE LDEVPRO LIST LDEVL7: TLO A,16 ;AND GOES OFF TO ENTER INTO THE ATOMTABLE SKOTT A,SY+FL+FX JRST LDATP8 TLNE TT,SY TLZ A,6 TLNE TT,FX TLZ A,4 TLNE TT,FL TLZ A,2 JRST LDATP8 LDEV0: UNLOCKI ;EVALUATES AN S-EXPRESSION IN A JUMPE D,LDEV2 ;ALLOWS FOR RECURSIVE FASLOADING SETZM FASLP ;EXCEPT WHEN EVALUATING FOR ENTRY INTO ATOMTABLE PUSH P,A MOVE C,LDPRLS(B) TLNN C,600000 HRRZM C,VPURCLOBRL IFN D10*HISEGMENT,[ TLNN C,100000 JRST LDEV4 HRRZM R,HBPORG JRST LDEV5 LDEV4: ] ;END OF IFN D10*HISEGMENNT MOVEI TT,(R) JSP T,FXCONS MOVEM A,VBPORG LDEV5: HRRZ TT,LDOFST ;IN CASE EVALUATION CHANGES BPORG, SUBI TT,(R) ; MUST CHANGE LDOFST TO BE AN HRRM TT,LDOFST ; ABSOLUTE QUANTITY MOVNI T,LFTMPS PUSH FXP,BFTMPS+LFTMPS(T) AOJL T,.-1 POP P,A LDEV2: PUSH FXP,B PUSH FXP,AR1 PUSH FXP,D PUSH FXP,R PUSH FXP,F PUSHJ P,EVAL POP FXP,F POP FXP,R POP FXP,D POP FXP,AR1 POP FXP,B JUMPE D,LDEV1 HS$ 10$ MOVE C,LDPRLS(B) HS$ 10$ TLNE C,100000 HS$ 10$ SKIPA R,HBPORG MOVE R,@VBPORG HRRZ T,LDBGEN(B) MOVEM T,FASLP MOVEI T,LFTMPS-1 POP FXP,BFTMPS(T) SOJGE T,.-1 HRRZ TT,LDOFST ;NOW RE-RELOCATE THE LOAD OFFSET ADDI TT,(R) HRRM TT,LDOFST HRRZ T,VPURCLOBRL HRRM T,LDPRLS(B) LDEV1: PUSH P,A 10$ MOVE TT,LDPRLS(B) ;FOR D10, PASS LDPRLS IN TT TO LDGTSP PUSHJ P,LDGTSP POP P,A JRST LDLRSP ;GET SPACE, LOCKI, AND RESTORE PTRS SUBTTL END OF FASLOAD FILE LDBEND: TRZ TT,1 ;CROCK! CAME TT,[SIXBIT \*FASL*\] JSP D,LDFERR MOVEI TT,LDFEND MOVEM TT,LDEOFJ IFN ITS,[ SKIPLE A,LDDDTP(P) TRNN A,-1 CAIA PUSHJ P,LDPUTM ;MAYBE HAVE TO FORCE LDPUT'S BUFFER ] ;END OF IFN ITS HLLZS LDDDTP(P) ;WILL USE FOR SWITCH LATER JSP T,LDGTWD TRZ TT,1 ;COMPATIBILITY CROCK CAME TT,[SIXBIT \*FASL*\] JRST LDBEN1 HLLOS LDDDTP(P) MOVEM F,LDTEMP JRST LDFEND LDBEN1: TRZ TT,1 CAME TT,[14060301406] 10% JSP D,LDFERR 10$ JUMPN TT,LDFERR LDFEND: TLZ R,-1 ;END OF FILE CAMGE R,LDHLOC MOVE R,LDHLOC HRRZS TT,R IFE PAGING,[ MOVE C,LDPRLS(P) TLNN C,100000 JRST LDFEN2 HRRZM R,HBPORG JRST LDFEN3 LDFEN2: JSP T,FXCONS MOVEM A,VBPORG LDFEN3: ] ;END OF IFE PAGING IFN PAGING,[ JSP T,FXCONS MOVE D,(A) EXCH A,VBPORG MOVE TT,(A) SKIPL LDPRLS(P) JRST LDZPUR HLLOS NOQUIT ANDI TT,PAGMSK ANDI D,PAGMSK LSHC TT,-PAGLOG SUBI D,(TT) ROT TT,-4 ADDI TT,(TT) ROT TT,-1 TLC TT,770000 ADD TT,[450200,,PURTBL] MOVEI T,1 LDNPUR: TLNN TT,730000 TLZ TT,770000 IDPB T,TT SOJGE D,LDNPUR PUSHJ P,CZECHI LDZPUR: ] ;END OF IFN PAGING PUSH FXP,F ;SAVE POINTER TO I/O BUFFER ;FALLS THROUGH ;FALLS IN ;;; "GROVELING" OVER THE ATOMTABLE USED TO OCCUR HERE, TO GCPROTECT ;;; BY PLACEING IN THE GCPSAR ANY ATOM NOT OTHERWISE PROTECTED. BUT ;;; NOWADAYS, THEY ARE ALL PROTECTED, EITHER BY BEING POINTED TO BY ;;; SOME PROTECTED LIST STRUCTURE, OR BY THE CODE AT LDQATX. SUBTTL SMASH DOWN PURE LIST LDSDPL: SKIPL TT,LDPRLS(P) ;[SMASH DOWN PURE LIST] TLNE TT,200000 JRST LDEOMM MOVEM TT,VPURCLOBRL MOVEI F,VPURCLOBRL LDSDP1: SKIPN TT,LDPRLS(P) JRST LDEOMM SKIPN INTFLG JRST LDSDP2 SKIPE INTFLG PUSHJ P,LDTRYI LDSDP2: HRRZ T,(TT) MOVEM T,LDPRLS(P) HLRZ AR2A,(TT) PUSHJ P,LDSMSH JRST LDSDP3 HRRZ F,(F) JRST LDSDP1 LDSDP3: MOVE TT,LDPRLS(P) HRRM TT,(F) JRST LDSDP1 SUBTTL END OF FASLOAD, AND RANDOM ROUTINES ;[END OF MOBY MESS!!!] LDEOMM: POP FXP,LDTEMP ;GET POINTER TO I/O BUFFER MOVE TT,LDDDTP(P) MOVE A,LDBSAR TRNE TT,-1 JRST LDEOM1 PUSHJ P,$CLOSE ;CLOSE FILE ARRAY SETZM LDBSAR MOVE A,VBPORG IFN D10*HISEGMENT,[ MOVE TT,HBPORG MOVE T,LDPRLS(P) TLNE T,100000 JSP T,FXCONS ] ;END OF D10*HISEGMENT UNLOCKI POPI P,LDNPDS PUSHJ P,UNBIND HRRZ TT,-2(P) ;FOR DEBUGGING PURPOSES, HRRZ D,-1(P) ; MAKE SURE PDLS ARE OKAY HRRZ R,(P) SUB P,R70+3 JRST PDLCHK LDEOM1: UNLOCKI POPI P,LDNPDS ;POP OFF REGPDL SLOTS, BUT PUSH P,A ;PUT LDBSAR BACK ON PDL JRST LDDISM LDTRYI: UNLOCKI ;[TRY AN INTERRUPT] LDLRSP: LOCKI ;[LOCKI AND RESTORE POINTERS] LDRSPT: HRRZ TT,LDASAR ;[RESTORE ARRAY POINTERS] HRRZ TT,TTSAR(TT) HRRM TT,LDAPTR HRRZ TT,LDBSAR IFE D10,[ HRRZ TT,TTSAR(TT) HRRM TT,LDBPTR ] ;END IFE QIO*D10 .ELSE HLLZS LDBPTR POPJ P, LDLIST: MOVEI C,-1(P) .SEE LDOWL JRST LDLIS1 LDLIS0: JSP T,LDGTWD LDLIS1: LDB T,[410300,,TT] ;[CONSTRUCT LIST] JRST LDLTBL(T) LDLTBL: JRST LDLATM ;ATOM JRST LDLLST ;LIST JRST LDLDLS ;DOTTED LIST JRST LDOWL ;EVALUATE TOP FROB ON STACK IFN HNKLOG, JRST LDLHNK ;HUNK .ELSE JRST FASHNE REPEAT 2, .VALUE JRST LDLEND ;END OF LIST LDLATM: MOVE A,@LDAPTR ;FOR ATOM, MAYBE SET USAGE BIT, TLNN A,777011 ; THEN SHOVE ON STACK IOR A,D MOVEM A,@LDAPTR PUSH P,A TRNN A,-1 JRST LDLIS0 ;SKIP SY2 CHECK IF SYMBOL 'NIL' TLNN A,777006 ;IF HAS VALUE CELL, OR IS NUMBER, DON'T DO SY2 TLNN D,1 ;IF SETTING USAGE BIT THEN ALSO DO SO IN SY2 JRST LDLIS0 HLRZ T,(A) ;GET SY2 WORD HLL T,(T) TLO T,SY.CCN\SY.OTC ;MUST FLAG ATOM AS NEEDED TLNN T,SY.PUR ;SET MEMORY UNLESS PURIFIED HLLM T,(T) JRST LDLIS0 LDLLST: TDZA A,A ;FOR LIST, USE NIL AS END LDLDLS: POP P,A ;FOR DOTTED LIST, USE TOP ITEM HRRZS TT JUMPE TT,LDLLS3 LDLLS1: POP P,B ;NOW POP N THINGS AND CONS THEM UP PUSHJ P,XCONS SOJG TT,LDLLS1 LDLLS3: PUSH P,A SKIPE INTFLG PUSHJ P,LDTRYI JRST LDLIS0 LDOWL: MOVE A,(P) MOVEI B,(C) ;B HAS ADDR OF FASLOAD TEMPS ON STACK PUSH P,C PUSHJ P,LDEV0 POP P,C MOVEM A,(P) JRST LDLIS0 IFN HNKLOG,[ LDLHNK: ANDI TT,-1 ;FLUSH LH CONTROL BITS PUSH FXP,D PUSHJ FXP,ALHNKL ;(TT) HAS NUMBER OF ITEMS WANTED POP FXP,D PUSH P,A ; POP THEM OFF PDL INTO A HUNK JRST LDLIS0 ;SAVES C ] ;END OF IFN HNKLOG LDLEND: HLRZ D,TT TRC D,777776 TRNE D,777776 JSP D,LDFERR POP P,A MOVSS TT HRRI TT,(A) POPJ P, ;;; SECOND FILE NAME OF THIS LISP WHEN ASSEMBLED (VERSION NUMBER ;;; THIS LOCATION IS REFERENCED BY FASLAP WHEN CREATING A BINARY ;;; FILE. IT CONTAINS THE VALUE OF .FNAM2 PLUS EXTRA BITS ;;; TO DISTINGUISH SOME CONDITIONAL ASSEMBLY FLAGS. ;;; THE CONTENTS OF THIS LOCATION ARE PRIMARILY USED TO DETERMINE ;;; WHETHER FASLOAD MAY USE VALUES OF DDT SYMBOLS SUPPLIED BY ;;; FASLAP; IT DOES SO ONLY IF FASLAP'S VERSION NUMBER, AS ;;; DETERMINED BY THIS LOCATION, IS THE SAME AS FASLOAD'S. ZZ==-1 ZZZ==0 ;;; 2nd item used to be "ML", but it really meant "ITS" ;;; 3rd item used to be "BIBOP", but is now for D20 IRP X,,[D10,ITS,D20,BIGNUM,CMU,SAIL,HISEGMENT,PAGING] ZZ==ZZ_1 ZZZ==\X TERMIN LDFNM2: <.FNAM2&ZZ>\ZZZ EXPUNGE ZZ ZZZ IFN ITS,[ LDGTW0: SUB F,FB.BFL(TT) HRLZI F,(F) HRRI F,FB.BUF LDGTWD: MOVE TT,@LDBPTR AOBJN F,(T) LDGTW1: HRRZ TT,LDBSAR HRRZ TT,TTSAR(TT) PUSH FXP,FB.IBP(TT) MOVE F,FB.BFL(TT) SUBI F,1 .CALL LDGTW9 .LOSE 1400 POPI FXP,1 ADDI F,1 CAME F,FB.BFL(TT) SOJA F,LDGTW0 JSP D,@LDEOFJ LDGTW9: SETZ SIXBIT \SIOT\ ;"STRING" I/O TRANSFER ,,F.CHAN(TT) ;CHANNEL # ,,0(FXP) ;BYTE POINTER 400000,,F ;BYTE COUNT ];END IFN ITS IFN D20,[ LDGTW0: SUB F,FB.BFL(TT) ;MAKE F INTO AOBJN POINTER HRLZI F,(F) HRRI F,FB.BUF ;POINTING INTO THE BUFFER LDGTWD: AOBJP F,LDGTW1 SUBI F,1 ;READJUST TO ACCESS CORRECT WORD MOVE TT,@LDBPTR AOJA F,(T) ;FIXUP AOBJN POINTER THEN RETURN LDGTW1: HRRZ TT,LDBSAR HRRZ TT,TTSAR(TT) PUSHJ FXP,SAV3 ;SAVE ACS WHICH WILL BE DESTROYED HRRZ 1,F.JFN(TT) ;JFN INTO AC 1 MOVE 2,FB.IBP(TT) ;BYTE POINTER INTO AC 2 MOVN 3,FB.BFL(TT) ;READ THIS MANY BYTES SIN ;DO THE INPUT ERJMP LDGTWE ;WE CAN IGNORE ERROR IF IT IS EOF LDGTE1: MOVN F,3 ;GET POSITIVE NUMBER OF BYTES LEFT UNREAD PUSHJ FXP,RST3 ;RESTORE SAVED ACS CAME F,FB.BFL(TT) ;DID WE READ ANYTHING? SOJA F,LDGTW0 ;YES, SO EMPTY THE BUFFER BEFORE GIVING EOF JSP D,@LDEOFJ LDGTWE: MOVEI 1,.FHSLF ;GET OUR LAST ERROR GETER HRRZS 2 ;ONLY WANT ERROR CODE CAIN 2,IOX4 ;EOF? JRST LDGTE1 MOVEI 1,.PRIOU ;OUTPUT ERROR TO PRIMARY OUTPUT CHANNEL HRLOI 2,.FHSLF ;LAST ERROR FOR OUR PROCESS SETZ 3, ;NO LIMIT TO AMOUNT OF OUTPUT ERSTR .LOSE ;FAILED .LOSE ;FAILED PUSHJ FXP,RST3 ;RESTORE SAVED AC'S JSP D,@LDEOFJ ;MAKE BELIEVE WE HIT EOF ] ;END IFN D20 IFN D10,[ LDGTW0: POP P,AR1 POP P,T MOVE TT,FB.HED(TT) ;GET BUFFER HEADER ADDRESS MOVN F,2(TT) ;NUMBER OF WORDS IN BUFFER HRLZI F,-1(F) ADDI F,1 ;NOW THE ACTUAL FIRST WORD LDGTWD: MOVE TT,LDBSAR ;GET POINTER TO SAR HRRZ TT,TTSAR(TT) MOVE TT,FB.HED(TT) ;GET PTR TO BUFFER HEADER HRRZ TT,1(TT) ;GET PTR TO FIRST WORD OF BUFFER - 1 HRLI TT,F ;INDEXED OFF OF F MOVE TT,@TT AOBJN F,(T) LDGTW1: PUSH P,T PUSH P,AR1 MOVE AR1,LDBSAR MOVE TT,TTSAR(AR1) ;WAIT! YOU LOSER, TT MUST HAVE TTSAR IN IT MOVE T,F.CHAN(TT) LSH T,27 IFE SAIL,[ TLNN TT,TTS.BM JRST LDGTW6 ;$DEV5R PUSH FLP,F HRRZ T,FB.HED(TT) ;MAYBE BUFFER HAS BEEN RELOCATED? THEN FOR MOVSI F,(BF.IOU) ANDCAB F,@(T) ;TURNS OFF BUFFER-IN-USE BIT AND ADVANCES BUFFER SKIPGE (F) ;BF.IOU MUST BE BIT 4.9 FOR THIS TO WORK JRST LDGTW4 ;$DEV5S MOVSI T,TTS.BM ANDCAM T,TTSAR(AR1) ;TURN OFF "BUFFER-MOVED" BIT, BUT LEAVE BUF ADDR IN F MOVE T,F.CHAN(TT) ;$DEV5Q: LSH T,27 HRR T,F POP FLP,F ] ;END OF IFE SAIL LDGTW6: TLO T,(IN 0,) ;$DEV5R: XCT T ;READ A NEW BUFFERFUL JRST LDGTW0 ;$DEV5M (?) ;SUCCESS! POP P,AR1 POP P,T JSP D,@LDEOFJ IFE SAIL,[ LDGTW4: HRRZ T,FB.HED(TT) HRRZM F,(T) ;STORE CURRENT BUFFER ADDR IN CONTROL BLOCK TLZ F,-1 ADD F,[4400,,1] MOVEM F,1(T) ;CONSTRUCT NEW BP FOR BUFFER MOVE F,(F) MOVEM F,2(T) ;STORE NEW BYTE COUNT INITO BUFFERCONTROL-BLOCK POP FLP,F JRST LDGTW0 ] ;END OF IFE SAIL ] ;END OF IFN D10 PGTOP FSL,[FASLOAD] ;;@ END OF FASLOA 245 ;;@ QIO 651 NEW MULTIPLE FILE I/O FUNCTIONS ;;; ***** MACLISP ****** NEW MULTIPLE FILE I/O FUNCTIONS ********* ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** PGBOT [QIO] SUBTTL I/O CHANNEL ALLOCATOR ;;; ALCHAN ALLOCATES AN I/O CHANNEL FOR USE. ;;; THE "CHANNEL NUMBER" IS AN INDEX INTO THE CHANNEL TABLE. .SEE CHNTB ;;; FOR ITS AND DEC10, THIS IS ALSO THE CHANNEL NUMBER USED TO ;;; COMMUNICATE WITH THE TIMESHARING SYSTEM. (FOR DEC20, A ;;; SEPARATE JFN MUST BE ALLOCATED WITH THE GTJFN JSYS.) ;;; ALCHAN EXPECTS THE SAR FOR THE FILE ARRAY TO BE IN A, ;;; AND RETURNS THE CHANNEL NUMBER IN F, SKIPPING IF SUCCESSFUL. ;;; THE FILE ARRAY MUST HAVE ITS TTS.CL BIT SET. ;;; THE CHANNEL NUMBER IS INSTALLED IN THE FILE'S F.CHAN SLOT. ;;; USER INTERRUPTS TURNED OFF, PLEASE. CLOBBERS R. ;;; MAY INVOKE A GARBAGE COLLECTION TO FREE UP CHANNELS. ALCHAN: HRRZS (P) ALCHN0: MOVNI F,LCHNTB-2 ;SCAN CHANNEL TABLE ALCHN1: SKIPN R,CHNTB+LCHNTB-1(F) JRST ALCHN3 ;FOUND A FREE CHANNEL JUMPL R,ALCH1A ;NEGATIVE, RESERVED MOVE R,TTSAR(R) TLNE R,TTS JRST ALCHN2 ;SEMI-FREE ALCH1A: AOJLE F,ALCHN1 ;DON'T CHECK CHANNEL 0 (NEVER FREE) SKIPGE (P) ;SKIP IF FIRST TIME POPJ P, ;LOSEY LOSEY HRROS (P) ;SET SWITCH PUSH P,[555555,,ALCHN0] JRST AGC ;HOPE GC WILL RECLAIM A FILE ARRAY ALCHN2: MOVEI F,LCHNTB-1(F) IT$ .CALL ALCHN9 ;CLOSE CHANNEL TO BE SURE IT$ .LOSE 1400 IFN D10,[ MOVEI R,(F) LSH R,27 IOR R,[RELEASE 0,0] ;RELEASE CHANNEL TO BE SURE XCT R ] ;END OF IFN D10 SKIPA ALCHN3: MOVEI F,LCHNTB-1(F) MOVE R,TTSAR(A) ;INSTALL CHANNEL NUMBER MOVEM F,F.CHAN(R) MOVEM A,CHNTB(F) ;RESERVE CHANNEL JRST POPJ1 ;WIN WIN - SKIP RETURN IFN ITS,[ ALCHN9: SETZ SIXBIT \CLOSE\ ;CLOSE I/O CHANNEL 400000,,F ;CHANNEL # ] ;END OF IFN ITS ;;; ALFILE CREATES A MINIMAL FILE ARRAY (OF LENGTH LOPOFA), ;;; AND ALLOCATES A CHANNEL FOR IT. IT EXPECTS A DEVICE NAME ;;; IN TT (FOR DEC20, TT AND D) WHICH IS INSTALLED IN THE ;;; F.DEV AND F.RDEV SLOTS OF THE FILE ARRAY. ;;; THIS IS USEFUL FOR ROUTINES WHICH WANT TO HACK ON A ;;; RANDOM CHANNEL BUT DON'T NEED A FULL-BLOWN FILE ARRAY. ;;; A FILE ARRAY IS NEEDED FOR THE SAKE OF THE CHANNEL TABLE .SEE CHNTB ;;; AND FOR THE GARBAGE COLLECTOR; IF THE FILE ARRAY IS ;;; GARBAGE COLLECTED, SO IS THE ASSOCIATED CHANNEL. ;;; THE FILE ARRAY ALSO MUST CONTAIN AT LEAST A DEVICE ;;; NAME SO PRIN1 CAN WIN. .SEE PRNFL ;;; CLOBBERS PRACTICALLY ALL ACS. ;;; THE ARRAY GC POINTER IS SET TO PROTECT THE FIRST SLOT ONLY. ;;; RETURNS FILE ARRAY IN A, CHANNEL NUMBER IN F. ;;; SKIPS ON SUCCESS; FAILS IF ALCHAN CAN'T GET A CHANNEL. ALFILE: LOCKI PUSH FXP,TT MOVEI TT,LOPOFA ;LENGTH OF PLAIN OLD FILE ARRAY MOVSI A,-1 ;GET ONLY A SAR PUSHJ P,MKLSAR MOVSI TT,TTS ;SET CLOSED BIT IORB TT,TTSAR(A) MOVSI T,AS ;SET FILE ARRAY BIT (MUST DO IORB T,ASAR(A) ; IN THIS ORDER!) HRROS -1(T) ;GC SHOULD PROTECT ONLY ONE SLOT POP FXP,T MOVEM T,F.DEV(TT) ;INSTALL DEVICE NAME 20% MOVEM T,F.RDEV(TT) MOVSI T,FBT.CM ;PREVENT GC FROM TRYING TO MOVEM T,F.MODE(TT) ; UPDATE NONEXISTENT POINTERS PUSHJ P,ALCHAN JRST UNLKPJ AOS (P) ;WE SKIP IFF ALCHAN DOES MOVSI TT,TTS ANDCAM TT,TTSAR(A) UNLKPJ: UNLKPOPJ SUBTTL FILE OBJECT CHECKING ROUTINES ;;; JSP TT,XFILEP ;;; SKIPS IFF THE OBJECT IN AR1 IS A FILE ARRAY. CLOBBERS R. SFA% AFOSP: AFILEP: MOVEI AR1,(A) SFA% XFOSP: XFILEP: MOVEI R,(AR1) LSH R,-SEGLOG MOVE R,ST(R) TLNN R,SA JRST (TT) MOVE R,ASAR(AR1) ;MUST ALSO HAVE FILE BIT SET TLNN R,AS JRST (TT) JRST 1(TT) FILEP: JSP TT,AFILEP ;SUBR 1 JRST FALSE JRST TRUE IFN SFA,[ ; PARALLEL TOO AFILEP/XFILEP BUT SKIPS ONCE FOR FILE-OBJECT, AND TWICE ; FOR SFA-OBJECT AFOSP: MOVEI AR1,(A) XFOSP: MOVEI R,(AR1) LSH R,-SEGLOG MOVE R,ST(R) TLNN R,SA ;MUST BE A SAR JRST (TT) MOVE R,ASAR(AR1) ;DOES IT HAVE FILE BIT SET? TLNE R,AS JRST 1(TT) ;YES, SINGLE SKIP TLNE R,AS.SFA ;AN SFA? JRST 2(TT) ;YES, DOUBLE SKIP JRST (TT) ;ELSE ERROR RETURN ] ;END IFN SFA ;;; THESE ROUTINES ACCEPT A FILE ARRAY IN AR1 AND CHECK WHETHER ;;; IT IS OF THE DESIRED TYPE. IF NOT, A WTA ERROR OCCURS. ;;; LEAVES TTSAR IN TT AND USER INTS LOCKED IF SUCCESSFUL. ;;; CLOBBERS T, TT, AND R. SAVES D (SEE FILEPOS) AND F. OFILOK: JSP T,FILOK0 ;TYPICAL INVOCATION: TTS,,TTS ; DESIRED BITS,,MASK SIXBIT \NOT OUTPUT FILE!\ ; ERROR MSG IF FAIL IFILOK: JSP T,FILOK0 0,,TTS SIXBIT \NOT INPUT FILE!\ ATFLOK: JSP T,FILOK0 0,,TTS SIXBIT \NOT ASCII FILE!\ ATOFOK: JSP T,FILOK0 TTS,,TTS SIXBIT \NOT ASCII OUTPUT FILE!\ ATIFOK: JSP T,FILOK0 0,,TTS SIXBIT \NOT ASCII INPUT FILE!\ TFILOK: JSP T,FILOK0 TTS,,TTS SIXBIT \NOT TTY FILE!\ TIFLOK: JSP T,FILOK0 TTS,,TTS SIXBIT \NOT TTY INPUT FILE!\ TOFLOK: JSP T,FILOK0 TTS,,TTS SIXBIT \NOT TTY OUTPUT FILE!\ XIFLOK: JSP T,FILOK0 TTS,,TTS SIXBIT \NOT BINARY INPUT FILE!\ XOFLOK: JSP T,FILOK0 TTS,,TTS SIXBIT \NOT BINARY OUTPUT FILE!\ FILOK: JSP T,FILOK0 0,,0 NFILE: SIXBIT \NOT FILE!\ FILOK0: LOCKI CAIE AR1,TRUTH ;T => TTY FILE ARRAY JRST FILOK1 MOVSI TT,TTS TSNE TT,(T) ;IF DON'T CARE ABOUT I/O TDNE TT,(T) ; OR SPECIFICALLY WANT OUTPUT SKIPA AR1,V%TYO ; THEN USE TTY OUTPUT HRRZ AR1,V%TYI ;USE TTY INPUT ONLY IF NECESSARY FILOK1: JSP TT,XFILEP ;SO IS IT A FILE ARRAY? JRST FILNOK ;NOPE - LOSE MOVE TT,TTSAR(AR1) XOR TT,(T) HLL T,TT MOVE TT,TTSAR(AR1) ;WANT TO RETURN TTSAR IN TT TLNE T,@(T) JRST FILNOK TLNN TT,TTS POPJ P, ;YEP - WIN SKIPA TT,[[SIXBIT \FILE HAS BEEN CLOSED!\]] FILNOK: MOVEI TT,1(T) EXCH A,AR1 UNLOCKI %WTA (TT) EXCH A,AR1 JRST FILOK0 SUBTTL CONVERSION: NAMELIST => SIXBIT ;;; A NAMELIST IN A IS CONVERTED TO "SIXBIT" FORMAT ON THE FIXNUM PDL. ;;; "SIXBIT" FORMAT IS ACTUALLY SIXBIT FOR SOME OPERATING SYSTEMS, ;;; BUT MAY BE ANY ANY FORM WHATSOEVER AS LONG AS ALL ROUTINES WHICH ;;; CLAIM TO UNDERSTAND "SIXBIT" FORM AGREE ON WHAT THAT FORM IS. ;;; (SOME ROUTINES WHICH DO I/O DEPEND ON THIS FORMAT, FOR EXAMPLE ;;; ITS ROUTINES WHICH USE THE OPEN SYMBOLIC SYSTEM CALL.) ;;; "SIXBIT" FORMAT IS DEFINED AS FOLLOWS: ;;; ;;; FOR ITS: ;;; ;;; ;;; ;TOP OF STACK ;;; AN OMITTED COMPONENT CAN BE REPRESENTED BY EITHER A ZERO ;;; WORD OR SIXBIT \*\ (THE LATTER BEING THE CANONICAL CHOICE). ;;; ;;; FOR DEC10: ;;; ;;; ;;; ;TOP OF STACK ;;; AN OMITTED COMPONENT CAN BE REPRESENTED BY EITHER A ZERO ;;; WORD OR SIXBIT \*\ (THE LATTER BEING THE CANONICAL CHOICE), ;;; EXCEPT FOR THE PPN, FOR WHICH 777777 INDICATES AN OMITTED HALFWORD. ;;; ;;; FOR DEC20: ;;; ;;; ;;; ;;; ;TOP OF STACK ;;; THE ENTRIES HERE ARE NOT SINGLE WORDS, BUT ARE OF ;;; RESPECTIVE LENGTHS (IN WORDS) L.6DEV, L.6DIR, L.6FNM, ;;; L.6EXT, L.6VRS. ;;; ;;; NOTE THAT FOR ALL SIXBIT FORMATS THE TOTAL LENGTH OF THE ;;; SIXBIT FORMAT IS L.F6BT. THIS DIVIDES INTO TWO PARTS: ;;; THE DEVICE/DIRECTORY, OF LENGTH L.D6BT, AND THE FILE NAME ;;; PROPER, OF LENGTH L.N6BT. ;;; ;;; THERE ARE FOUR KINDS OF FILE NAME SPECIFICATIONS. ;;; ONE IS A FILE OBJECT, WHICH IMPLIES THE NAME USED TO OPEN IT. ;;; ONE IS AN ATOMIC SYMBOL, WHICH IS TREATED AS A NAMESTRING. ;;; THE OTHER TWO ARE NAMELISTS, UREAD-STYLE AND NEWIO-STYLE. ;;; NEWIO-STYLE NAMELISTS HAVE NON-ATOMIC CARS, WHILE UREAD-STYLE ;;; NAMELISTS HAVE ATOMIC CARS. UREAD-STYLE NAMELISTS ARE MOSTLY ;;; FOR COMPATIBILITY WITH OLDIO, AND FOR USER CONVENIENCE. ;;; ;;; IN A NEWIO-STYLE NAMELIST, THE CAR IS A DEVICE/DIRECTORY ;;; SPECIFICATION, AND THE CDR A FILE NAME SPECIFICATION. ;;; IN PRINCIPLE EACH IS A LIST OF ARBITRARY LENGTH. ;;; IN PRACTICE, THERE IS A LIMIT FOR EACH OF THE PDP-10 ;;; IMPLEMENTATIONS. THE CANONICAL NAMELIST FORMAT FOR ;;; EACH SYSTEM IS AS FOLLOWS: ;;; ITS: (( ) ) ;;; TOPS10: (( ( )) ) ;;; SAIL: (( ( )) ) ;;; CMU: (( ) ) ;;; CMU ALSO ALLOWS TOPS10-STYLE NAMELISTS. ;;; TENEX: (( ) ) ;;; TOPS20: (( ) ) ;;; ;;; ALL COMPONENTS ARE NOMINALLY ATOMIC SYMBOLS, EXCEPT AND , ;;; WHICH ARE FIXNUMS. IF THE USER SUPPLIES A COMPONENT WHICH IS NOT ;;; A SYMBOL (AND IT CAN EVEN BE NON-ATOMIC IF THERE IS NO AMBIGUITY ;;; AS TO FORMAT), THEN IT IS EXPLODEC'D WITH BASE=10., PRINLEVEL=PRINLENGTH=NIL, ;;; AND *NOPOINT=T. A COMPONENT MAY BE "OMITTED" BY USING THE ATOMIC ;;; SYMBOL *. THIS DOES NOT MEAN A WILDCARD, BUT ONLY AN OMITTED COMPONENT. ;;; ;;; IF THE USER SUPPLIES A NAMELIST NOT IN CANONICAL FORM, THE CAR AND CDR ;;; ARE INDEPENDENTLY CANONICALIZED. THE CAR CAN BE ACANONICAL ONLY BY ;;; BEING A SINGLETON LIST; IN THIS CASE AN ATTEMPT IS MADE TO DECIDE ;;; WHETHER IT IS A DEVICE OR DIRECTORY SPECIFICATION. THIS IS DONE IN ;;; DIFFERENT WAYS ON DIFFERENT SYSTEMS. ON TOPS10, FOR EXAMPLE, AN ATOMIC ;;; SPECIFICATION IS NECESSARY A DEVICE AND NOT A PPN. ON THE OTHER HAND, ;;; ON ITS A LIST OF STANDARD DEVICE NAMES IS CHECKED. ;;; THE CDR CAN BE ACANONICAL BY BEING TOO SHORT, OR BY BEING A DOTTED LIST, ;;; OR BOTH. COMPONENTS ARE TAKEN IN ORDER UNTIL AN ATOMIC CDR IS REACHED. ;;; IF THIS CDR IS NIL, ALL REMAINING COMPONENTS ARE TAKEN TO BE *. ;;; OTHERWISE, ALL REMAINING COMPONENTS ARE * EXCEPT THE LAST, WHICH IS ;;; THAT ATOM IN THE CDR. ;;; ;;; A UREAD-STYLE NAMELIST IS NOMINALLY IN THE FORM (A B C D), WHERE ;;; A, AT LEAST, MUST BE ATOMIC. IT IS INTERPRETED AS IF IT WERE CONVERTED ;;; TO THE FORM ((C D) A B) [DEC20: ((C D) A * B)], AND THEN TREATING IT AS ;;; AN ORDINARY NAMELIST. (IF C AND D ARE MISSING, THEN (*) IS USED INSTEAD ;;; OF NIL AS THE CAR OF THE CONSTRUCTED NAMELIST. NML6BT: JSP T,QIOSAV ;SAVE REGISTERS NML6B5: PUSH P,A HLRZ A,(A) ;CHECK CAR OF NAMELIST JSP T,STENT JUMPGE TT,NML6B2 ;JUMP IF UREAD-STYLE NAMELIST PUSHJ P,NML6DV ;CONVERT DEVICE/DIRECTORY SPECIFICATION JRST NML6B0 ;SKIPS UNLESS CONVERSION FAILED HRRZ A,@(P) PUSHJ P,NML6FN ;CONVERT FILE NAMES (LEAVES TAIL IN A) JUMPE A,POP1J ;SUCCEED UNLESS TOO MANY FILE NAMES NML6BZ: POPI FXP,L.N6BT ;POP FILE NAME CRUD NML6B0: POPI FXP,L.D6BT ;POP DEVICE/DIRECTORY CRUD POP P,A ;POP ORIGINAL ARGUMENT WTA [INCORRECTLY FORMED NAMELIST!] JRST NML6B5 NML6B2: HRRZ A,(P) ;HERE FOR UREAD-STYLE NAMELIST PUSHJ P,NML6UF ;CONVERT FILE NAMES, BUT AT MOST TWO OF THEM PUSHJ P,NML6DV ;NOW CONVERT THE DEVICE/DIRECTORY JRST NML6BZ ;NOTE THAT POPI'S COMMUTE AT NML6BZ! ;AT THIS POINT THE WORDS ON FXP ARE IN THE WRONG ORDER, SO WE SHUFFLE THE STACK. IFN ITS+D10,[ POP FXP,TT ;DIRECTORY POP FXP,T ;DEVICE EXCH T,-1(FXP) ;EXCH DEVICE WITH FN1 EXCH TT,(FXP) ;EXCH DIR WITH FN2 PUSH FXP,T ;PUSH FN1 PUSH FXP,TT ;PUSH FN2 ] ;END OF IFN ITS+D10 IFN D20,[ MOVEI T,-L.F6BT+1(FXP) HRLI T,-L.N6BT PUSH FXP,(T) ;COPY THE FILE NAMES TO THE TOP AOBJN T,.-1 ; OF THE STACK MOVEI T,-L.F6BT-L.N6BT+1(FXP) HRLI T,-L.F6BT+1(FXP) BLT T,-L.N6BT(FXP) ;COPY ENTIRE "SIXBIT" SET DOWNWARD POPI FXP,L.N6BT ;POP OFF EXTRANEOUS CRUD ] ;END OF IFN D20 JRST POP1J ;;; CONVERT FILE NAME LIST IN A TO "SIXBIT" FORM ON FXP. ;;; RETURNS THE UNUSED TAIL OF THE LIST IN A. ;;; NML6UF IS LIKE NML6FN, BUT NEVER GOBBLES MORE THAN TWO NAMES. IFN D20,[ DFNWD: ASCII \*\ ;DEFAULT FILE-NAME WORD DFFNWD: ASCII \FASL\ NML6FN: TDZA T,T NML6UF: SETO T, ;UREAD-STYLE DISTINCTION ONLY MATTERS TO DEC20 HRLM T,(P) PUSH FXP,DFNWD PUSHN FXP,L.6FNM-1 ;PUSH ROOM FOR THE FILE NAME PUSH FXP,DFNWD PUSHN FXP,L.6EXT-1 ;PUSH ROOM FOR THE FILE EXTENSION PUSH FXP,DFNWD PUSHN FXP,L.6VRS-1 ;PUSH ROOM FOR THE FILE VERSION ] ;END OF IFN D20 IFE D20,[ DFNWD: SIXBIT \*\ ;DEFAULT FILE-NAME WORD DFFNWD: ;DEFAULT FASL-FILE-NAME WORD 10% SIXBIT \FASL\ 10$ SIXBIT \FAS\ NML6FN: NML6UF: REPEAT L.N6BT, PUSH FXP,DFNWD ;PUSH ROOM FOR THE FILE NAMES ] ;END OF IFE D20 JUMPE A,CPOPJ ;NULL LIST => ALL NAMES OMITTED PUSH P,A JSP T,STENT JUMPGE TT,NML6F3 ;ATOM MEANS LAST COMPONENT HLRZ A,(A) 20% PUSHJ P,SIXMAK ;CONVERT FIRST COMPONENT TO SIXBIT, 20% MOVEM TT,-1(FXP) ; AND CALL IT FILE NAME 1 IFN D20,[ PUSHJ P,PNBFMK ;CONVERT FIRST COMPONENT TO ASCIZ, MOVEI T,-L.6FNM-L.6EXT-L.6VRS+1(FXP) ; AND CALL IT THE FILE NAME HRLI T,PNBUF BLT T,-L.6EXT-L.6VRS(FXP) MOVEI T,177_1 ;MASK FOR LAST BYTE IN AN ASCII WORD ANDCAM T,-L.6EXT-L.6VRS(FXP) ;MAKE SURE LAST BYTE IS NULL ] ;END OF IFN D20 HRRZ A,@(P) JUMPE A,POP1J ;EXIT IF ALL DONE MOVEM A,(P) IFN D20,[ JSP T,STENT JUMPGE TT,NML6F3 ;ATOM MEANS LAST COMPONENT HLRZ A,(A) PUSHJ P,PNBFMK ;CONVERT NEXT COMPONENT TO ASCIZ, MOVEI T,-L.6EXT-L.6VRS+1(FXP) ; AND CALL IT THE EXTENSION HRLI T,PNBUF BLT T,-L.6VRS(FXP) MOVEI T,177_1 ;MASK FOR LAST BYTE IN AN ASCII WORD ANDCAM T,-L.6VRS(FXP) ;MAKE SURE LAST BYTE IS NULL HRRZ A,@(P) JUMPE A,POP1J ;EXIT IF ALL DONE HRRZ T,(A) ;IF 3 COMPONENTS REMAIN, THEN VERSION EXISTS HRRZ T,(T) SKIPN T SKIPL -1(P) ;FOR UREAD-STYLE NAMELISTS, READ AT MOST SKIPA ; TWO COMPONENTS JRST NML6F4 MOVEM A,(P) NML6F5: ] ;END OF IFN D20 JSP T,STENT JUMPGE TT,NML6F3 ;ATOM MEANS LAST COMPONENT HLRZ A,(A) NML6F2: IFE D20,[ PUSHJ P,SIXMAK ;CONVERT LAST COMPONENT TO SIXBIT, 10$ TRZ TT,-1 ; TRUNCATING TO 3 CHARS FOR DEC10, MOVEM TT,(FXP) ; AND CALL IT FILE NAME 2 ] ;END OF IFN D20 IFN D20,[ PUSHJ P,PNBFMK ;CONVERT LAST COMPONENT TO ASCIZ, MOVEI T,-L.6VRS+1(FXP) ; AND CALL IT THE VERSION HRLI T,PNBUF BLT T,(FXP) MOVEI T,177_1 ;MASK FOR LAST BYTE IN AN ASCII WORD ANDCAM T,(FXP) ;MAKE SURE LAST BYTE IS NULL ] ;END OF IFN D20 NML6F4: HRRZ A,@(P) JRST POP1J NML6F3: SETZM (P) 20% JRST NML6F2 20$ JRST NML6F4 ;;; CONVERTS A DEVICE/DIRECTORY SPECIFICATION IN A TO "SIXBIT" FORM ON FXP. ;;; PERFORMS DEVICE/DIRECTORY DISAMBIGUATION. SKIPS ON SUCCESS. NML6DV: PUSH FXP,DFNWD ;PUSH ROOM FOR DEV NAME 20$ PUSHN FXP,L.6DEV-1 ;PUSH ROOM FOR THE DEVICE NAME 10$ PUSH FXP,[-1] ;FOR DIR NAME 10% PUSH FXP,DFNWD ;FOR DIR NAME 20$ PUSHN FXP,L.6DIR-1 ;PUSH ROOM FOR THE DIRECTORY NAME NML6D0: JUMPE A,POPJ1 ;NULL SPEC => DEFAULTS HRRZ B,(A) HLRZ A,(A) PUSH P,B NML6PP: 10$ JSP T,SPATOM ;FOR DEC-10, A NON-ATOMIC ITEM MUST BE A PPN 10$ JRST NML6D7 20$ PUSHJ P,PNBFMK ;GET THE "SIXBIT" FORM OF DEVICE IFE D20,[ PUSH P,A PUSH P,B PUSHJ P,SIXMAK POP P,B POP P,A ] ;END IFE D20 SKIPE (P) ;FOR MORE THAN ONE ITEM IN LIST, THEN THE JRST NML6D1 ; FIRST MUST BE A DEVICE PUSHJ P,IDND ;DISAMBIGUATE THIS MESS - SKIP IF DEVICE JRST NML6D8 ;NO SKIP MEANS NO INFO - MAYBE DIRECTORY NAME? JRST NML6D1 ;SKIP ONE MEANS DEFINITELY A DEVICE NAME POP P,B JRST NML6D0 ;SKIP TWO MEANS PPN/DIRECTORY TRANSLATION NML6D1: ;IT'S DEFINITELY A DEVICE NAME 20% MOVEM TT,-L.D6BT+1(FXP) IFN D20,[ MOVEI T,-L.6DEV-L.6DIR+1(FXP) HRLI T,PNBUF BLT T,-L.6DIR+1(FXP) MOVEI T,177_1 ;MASK FOR LAST BYTE IN AN ASCII WORD ANDCAM T,-L.6DIR(FXP) ;MAKE SURE LAST BYTE IS NULL ] ;END OF IFN D20 SKIPN (P) JRST POP1J1 ;SUCCESS IF NO DIRECTORY SPEC HLRZ A,@(P) IFN D10,[ PUSHJ P,PPNGET ;TRY PPN PROPERTY SKIPN A ;USE IT IF IT EXISTS HLRZ A,@(P) ;ELSE USE THE USER SPECIFIED FROB ] ;END IFN D10 HRRZ B,@(P) MOVEM B,(P) ;HERE IS WHERE IT HITS THE FAN - NO TWO SYSTEMS HAVE THE SAME DIRECTORY SPEC FORMAT! IFN ITS, PUSHJ P,SIXMAK ;FOR ITS IT IS A PLAIN SIXBIT NAME IFN D20, PUSHJ P,PNBFMK ;FOR D20 IT IS ASCII IFN D10,[ NML6D8: SETO TT, CAIN A,Q. ;* AS A PPN STRING IS TAKEN TO MEAN (* *) JRST NML6D4 JSP T,SPATOM JRST NML6D7 ;NON-ATOMIC => TOPS10-STYLE SA% SKIPN CMUP JRST POP1J ;AN ATOMIC DIRECTORY IS ILLEGAL FOR TOPS10/SAIL IFE SAIL,[ PUSHJ P,PNBFMK MOVEI TT,PNBUF ;0,,ADDRESS OF CMU PPN STRING CMUDEC TT, ;CMUDEC WILL CONVERT A STRING TO A PPN WORD JRST POP1J ;FAIL IF NOT A VALID CMU PPN JRST NML6D4 ] ;END OF IFE SAIL NML6D7: HLRZ B,(A) ;B GETS PROJECT HRRZ C,(A) HLRZ A,(C) ;A GETS PROGRAMMER HRRZ C,(C) JUMPN C,POP1J ;FAIL IF THREE ITEMS IN THE PPN SPEC IFE SAIL,[ CAIN B,Q. ;* MEANS AN OMITTED COMPONENT SKIPA D,[,,-1] JSP T,FXNV2 ;OTHERWISE EXPECT A FIXNUM CAIN A,Q. SKIPA TT,[,,-1] JSP T,FXNV1 TLNN TT,-1 TLNE D,-1 JRST POP1J ;NUMBERS MUST FIT INTO HALFWORDS HRLI TT,(D) ] ;END OF IFE SAIL IFN SAIL,[ PUSH P,B CAIN A,Q. ;* MEANS AN OMITTED COMPONENT SKIPA TT,[0,,-1] PUSHJ P,SIXMAK ;OTHERWISE GET SIXBIT PUSHJ P,SARGHT ;RIGHT JUSTIFY IT PUSH FXP,TT POP P,A CAIN A,Q. ;* MEANS AN OMITTED COMPONENT SKIPA TT,[0,,-1] PUSHJ P,SIXMAK ;OTHERWISE GET SIXBIT PUSHJ P,SARGHT ;RIGHT JUSTIFY IT POP FXP,D TLNN TT,-1 TLNE D,-1 JRST POP1J ;NO MORE THAN 3 CHARS APIECE MOVSS TT HRRI TT,(D) ] ;END OF IFN SAIL ] ;END OF IFN D10 ;NOW WE HAVE THE SNAME/PPN IN TT FOR ITS/D10, OR DIRECTORY IN PNBUF FOR D20 10% NML6D8: NML6D4: 20% MOVEM TT,(FXP) IFN D20,[ MOVEI T,-L.6DIR+1(FXP) HRLI T,PNBUF BLT T,(FXP) MOVEI T,177_1 ;MASK FOR LAST BYTE IN AN ASCII WORD ANDCAM T,(FXP) ] ;END OF IFN D20 SKIPN (P) ;WE WIN IFF THERE ARE NO MORE ITEMS TO PARSE AOS -1(P) JRST POP1J IFN SAIL,[ ;RIGHT JUSTIFY SIXBIT WORD IN TT SARGHT: SKIPE TT ;IF NOTHING THERE WE DON'T WANT TO LOOP TRNE TT,77 ;ANYTHING IN HIGH SIXBIT BYTE? POPJ P, ;YUP, IT IS THEREFORE LEFT-JUSTIFIED LSH TT,-6 ;ELSE GET RID OF THE LEADING BLANK JRST SARGHT ;AND PROCEED WITH TEST ] ;END IFN SAIL ;;; INSUFFERABLE DEVICE NAME DISTINGUISHER - SKIP.RETURN IF ARG IS DEVICE ;;; A NAME IS IN TT IN SIXBIT (ITS/CMU) OR IN PNBUF IN ASCII (D20). ;;; ACC A HOLDS POINTER TO THE SYMBOL FROM WHICH "NAME" WAS TRANSLATED. ;;; TRIES TO DECIDE WHETHER A NAME IS A DEVICE NAME OR A DIRECTORY NAME. ;;; FOR ITS, IT IS A DEVICE NAME IFF, AFTER STRIPPING OFF TRAILING DIGITS, ;;; IT IS IN THE TABLE OF KNOWN DEVICE NAMES. ;;; FOR CMU, WE USE THE DEVCHR UUO TO TEST EXISTENCE. ;;; FOR D20, WE USE THE STDEV JSYS TO TEST EXISTENCE. ;;; SKIPS IF A DEVICE NAME. MUST PRESERVE A AND TT. IFN ITS,[ ;;; BEWARE! THIS TABLE IS SORTED ALPHABETICALLY, AND THAT IS REQUIRED BY ;;; THE SUPER-HAIRY BINARY SORT HACK ABOVE. TABLE MUST BE AN EXACT POWER OF ;;; TWO IN LENGTH SO WE CAN USE SUPER-WINNING BINARY SEARCH METHOD. IDNTB: IRP X,,[AI,AIAR,AIDIR,AR,ARC,BOJ,CLA,CLI,CLO,CLU,COM,COR DIR,DK,DM,DMAR,DMDIR,DSK,ERR,JOB,LPT,MC,MCAR,MCDIR,ML,MLAR,MLDIR MT,NUL,OJB,P,PK,PTP,PTR,S,SPY,ST,STY,SYS,T,TPL,TTY,TY,USR,UT] SIXBIT \X\ TERMIN LIDNTB==:.-IDNTB HAOLNG LOG2IDNTB,<.-IDNTB-1> REPEAT <1_LOG2IDNTB>-LIDNTB,[-1 ] ;END OF REPEAT <1_LOG2IDNTB>-LIDNTB, IDNDLS: REPEAT 6,[ROTC TT-1,<.RPCNT+1>*6 ] ;END OF REPEAT 6, POPJ P, ;STANDARD EXIT IF TOO MANY SHIFTS ] ;END OF IFN ITS PPNGET: PUSH P,B ;Don't go around clobbering stuff PUSH FXP,TT ;CHECK TO SEE IF SYMBOL HAS PPN PROPERTY JSP T,SPATOM ; AND USE `(DSK ,(proj prog)) IF FOUND MOVE A,CIN0 ;A LISP "0", IN ORDER TO CONFUSE "GET" MOVEI B,QPPN PUSHJ P,$GET POP P,B ;B may still contain the directory name. JRST RSTX1 IDND: PUSH P,A 20$ LOCKI ;LOCK OUT INTERRUPTS AROUND THE JSYS PUSHJ P,PPNGET JUMPE A,IDNDA HRRZM A,(P) ;AHA! A PPN TRANSLATION! AOS -1(P) ;SKIP 2 FOR PPN TRANSLATION JRST IDNDS IDNDA: IFN D20,[ HRROI A,PNBUF STDEV ;CONVERT DEVICE STRING TO DEVICE DESIGNATOR SKIPA ;ERROR - NO SUCH DEVICE - NO SKIP ON FAILURE ] ;END OF IFN D20 IFN D10,[ MOVE F,TT DEVCHR F, ;GET CHARACTERISTICS OF DEVICE SKIPE F ; ZERO WORD MEANS DEVICE DOESN'T EXIST ] ;END OF IFN D10 IFN ITS,[ IDNDA: MOVE F,TT ;SAVE TT IN F MOVNI R,6 IDND1: SETZ TT-1, ;WE WILL STRIP DIGITS AND NULLS FROM END ROTC TT-1,-6 ; BY ROTATING THEM INTO THE PREVIOUS AC ROT TT-1,6 JUMPE TT-1,IDND2 CAIL TT-1,'0 CAILE TT-1,'9 JRST IDND3 ;EXIT IF NEITHER DIGIT NOR NULL IDND2: AOJL R,IDND1 POPJ P, ;SHIFTED OUT ALL CHARACTERS? IDND3: ROT TT-1,-6 XCT IDNDLS+6(R) ;SHIFT BACK SETZB R,T REPEAT LOG2IDNTB,[ CAML TT,IDNTB+<1_>(R) ADDI R,1_ ] ;END OF REPEAT LOG2IDNTB EXCH TT,F ;RESTORE TT CAMN F,IDNTB(R) ;FALL THRU IF RECOGNIZED DEVICE ] ;END OF IFN ITS ;;; FALL THRU TO HERE IF IT IS A DEVICE IDNDS: AOS -1(P) ;AND IF DEVICE, THEN SKIP ONE ON RETURN IDNDX: ; BUT IF NOT, THEN NO SKIP 20% JRST POPAJ 20$ POP P,A 20$ UNLKPOPJ SUBTTL CONVERSION: SIXBIT => NAMELIST ;;; THIS ROUTINE TAKES "SIXBIT" FORMAT ON FXP AND, ;;; POPPING THEM, RETURNS THE EQUIVALENT CANONICAL NAMELIST. ;;; OMITTED COMPONENTS BECOME *'S. ;;; THE NAMELIST FUNCTION MERELY CONVERTS ARG TO SIXBIT, ;;; THEN BACK TO (CANONICAL) NAMELIST FORM. NAMELIST: PUSHJ P,FIL6BT ;SUBR 1 6BTNML: JSP T,QIOSAV ;MUST ALSO PRESERVE F PUSHN P,1 ;FOR D20, POP THE VERSION (TENEX)/GENERATION (TOPS20) AND CONS IT UP IFN D20,[ REPEAT L.6VRS, POP FXP,PNBUF+L.6VRS-.RPCNT-1 PUSHJ P,6BTNL3 ] ;END OF IFN D20 ;POP THE FILE NAME 2 (ITS)/EXTENSION (D10, TENEX)/TYPE (TOPS20) AND CONS UP IFN ITS+D10, POP FXP,TT IFN D10, TRZ TT,-1 ;D10 EXTENSION IS AT MOST 3 CHARACTERS IFN D20,[ MOVEI T,PNBUF HRLI T,-L.6EXT+1(FXP) BLT T,PNBUF+L.6EXT-1 POPI FXP,L.6EXT ] ;END OF IFN D20 PUSHJ P,6BTNL3 ;POP THE FILE NAME 1 (ITS)/FILE NAME (D10, D20) AND CONS UP IFN ITS+D10, POP FXP,TT IFN D20,[ MOVEI T,PNBUF HRLI T,-L.6FNM+1(FXP) BLT T,PNBUF+L.6FNM-1 POPI FXP,L.6FNM ] ;END OF IFN D20 PUSHJ P,6BTNL3 ;NOW FOR THE DEVICE/DIRECTORY PORTION PUSHN P,1 ;FIRST THE DIRECTORY (WHAT A MESS!) IFN ITS,[ POP FXP,TT PUSHJ P,6BTNL3 ] ;END OF IFN ITS IFN D10,[ POP FXP,TT PUSHJ P,PPNATM PUSHJ P,6BTNL4 ] ;END OF IFN D10 IFN D20,[ MOVEI T,PNBUF HRLI T,-L.6DIR+1(FXP) BLT T,PNBUF+L.6DIR-1 POPI FXP,L.6DIR PUSHJ P,6BTNL3 ] ;END OF IFN D20 ;FINALLY, THE DEVICE NAME 20% POP FXP,TT IFN D20,[ MOVEI T,PNBUF HRLI T,-L.6DEV+1(FXP) BLT T,PNBUF+L.6DEV-1 POPI FXP,L.6DEV ] ;END OF IFN D20 PUSHJ P,6BTNL3 POP P,A POP P,B JRST CONS SA$ 6BTNL9: SKIPA A,[Q.] 6BTNL3: 20% PUSHJ P,SIXATM 20$ PUSHJ P,PNBFAT 6BTNL4: MOVE B,-1(P) PUSHJ P,CONS MOVEM A,-1(P) POPJ P, SUBTTL CONVERSION: SIXBIT => NAMESTRING ;;; THIS ROUTINE TAKES A "SIXBIT" FORMAT FILE SPEC ON FXP ;;; AND GENERATES AN UNINTERNED ATOMIC SYMBOL WHOSE ;;; PRINT NAME IS THE EXTERNAL FORM OF FILE SPECIFICATION. ;;; OMITTED NAMES ARE EITHER NOT INCLUDED IN THE NAMESTRING ;;; OR REPRESENTED AS "*". ;;; THE NAMESTRING AND SHORTNAMESTRING MERELY CONVERT THEIR ;;; ARGUMENTS TO SIXBIT AND THEN INTO NAMESTRING FORM. SHORTNAMESTRING: ;SUBR 1 TDZA TT,TT NAMESTRING: ;SUBR 1 SETO TT, HRLM TT,(P) PUSHJ P,FIL6BT 6BTNMS: MOVEI TT,PNGNK2 HLL TT,(P) ;TO MAKE A NAMESTRING, GET IT INTO PNBUF PUSH P,TT JRST 6BTNS ; AND THEN PNGNK2 WILL MAKE A SYMBOL IFN D20,[ X6BTNSL: MOVEI T,L.F6BT ;MAKES STRING IN PNBUF, BUT NO POPPING PUSH FXP,-L.F6BT+1(FXP) ; THE FILE NAMES (WE COPY THEM FIRST) SOJG T,.-1 ] ;END OF IFN D20 6BTNSL: SETO TT, ;IF RETURN ADDRESS SLOT ON THE PDL IS HRLM TT,(P) ; POSITIVE, THEN DO "SHORTNAMESTRING" 6BTNS: JSP T,QIOSAV ;CONVERT "SIXBIT" TO A STRING IN PNBUF ; (BETTER BE BIG ENOUGH!) SETOM LPNF ;SET FLAG SAYING IT FITS IN PNBUF 20% MOVEI R,^Q ;R CONTAINS THE CHARACTER FOR QUOTING 20$ MOVEI R,^V ; PECULIAR CHARACTERS IN COMPONENTS MOVE C,PNBP SKIPL -LQIOSV(P) ;SKIP UNLESS SHORTNAMESTRING JRST 6BTNS0 ;DEVICE NAME (NOT FOR SHORTNAMESTRING, THOUGH) MOVEI TT,-L.D6BT-L.N6BT+1(FXP) SKIPE T,(TT) CAMN T,DFNWD JRST 6BNS0A ;JUMP IF DEVICE NAME OMITTED PUSHJ P,6BTNS1 MOVEI T,": ;9 OUT OF 10 OPERATING SYSTEMS AGREE: IDPB T,C ; ":" MEANS A DEVICE NAME. 6BNS0A: ;FOR ITS AND D20, DIRECTORY NAME COMES NEXT IFN ITS+D20,[ MOVEI TT,-L.6DIR-L.6FNM-L.6EXT-L.6VRS+1(FXP) SKIPE T,-L.6DIR-L.N6BT+1(FXP) CAMN T,DFNWD JRST 6BTNS0 ;DIRECTORY NAME OMITTED 20$ MOVEI T,"< ;D20 DIRECTORY NAME APPEARS IN <> 20$ IDPB T,C PUSHJ P,6BTNS1 20$ MOVEI T,"> 20% MOVEI T,"; ;";" MEANS DIRECTORY NAME TO ITS IDPB T,C ] ;END OF IFN ITS+D20 6BTNS0: MOVEI TT,-L.N6BT+1(FXP) ;NOW WE ATTACK THE FILE NAME PUSHJ P,6BTNS1 ;NOW THE FILE NAME 2/EXTENSION/TYPE IFN ITS, MOVEI T,40 IFN D10+D20, MOVEI T,". 10$ PUSH FXP,(FXP) ;EXTRA SLOT FOR D10, IN ORDER 10$ HLLZS (FXP) ; ZERO OUT HALF A WORD MOVEI TT,-L.N6BT+L.6FNM+1(FXP) 10$ SKIPE (TT) IDPB T,C IT% SKIPE (TT) PUSHJ P,6BTNS1 10$ POPI FXP,1 ;FLUSH THE "EXTRA" SLOT IFN D20,[ ;FOR D20, THE VERSION/GENERATION COMES LAST MOVEI TT,-L.6VRS+1(FXP) SKIPE T,(TT) CAMN T,DFNWD JRST 6BTNS8 MOVEI T,"; SKIPN TENEXP MOVEI T,". IDPB T,C PUSHJ P,6BTNS1 ] ;END OF IFN D20 IFN D10,[ ;FOR D10, THE DIRECTORY COMES LAST MOVEI TT,-L.F6BT+L.6DEV+1(FXP) MOVE T,(TT) CAME T,XC-1 ;FORGET IT IF BOTH HALVES OMITTED SKIPL -LQIOSV(P) ;NO DIRECTORY FOR SHORTNAMESTRING JRST 6BTNS8 MOVEI T,91. ;A LEFT BRACKET IDPB T,C IFE SAIL,[ SKIPN CMUP JRST 6BTNS4 HLRZ T,(TT) CAIG T,10 ;ONLY PROJECTS ABOVE 10 ARE IN CMU FORMAT JRST 6BTNS4 PUSHN FXP,2 ;THERE IS A BUG IN DECCMU, BUT PUSHING ZERO WORDS MOVEI T,-1(FXP) ; GETS US AROUND IT HRL T,TT DECCMU T, JRST 6BTNS4 ;ON FAILURE, JUST USE DEC FORMAT MOVEI TT,-1(FXP) TLOA TT,440700 IDPB T,C ;COPY CHARACTERS INTO PNBUF ILDB T,TT JUMPN T,.-2 POPI FXP,2 JRST 6BTNS5 ] ;END OF IFE SAIL 6BTNS4: HLLZ TT,-L.F6BT+L.6DEV+1(FXP) PUSHJ P,6BTNS6 ;OUTPUT PROJECT MOVEI T,", ;COMMA SEPARATES HALVES IDPB T,C HRLZ TT,-L.F6BT+L.6DEV+1(FXP) PUSHJ P,6BTNS6 ;OUTPUT PROGRAMMER 6BTNS5: MOVEI T,93. ;A RIGHT BRACKET IDPB T,C ] ;END OF IFN D10 6BTNS8: PUSHJ FXP,RDAEND ;FINISH OFF THE LAST WORD OF THE STRING SETZM 1(C) POPI FXP,L.F6BT ;POP CRUD OFF STACK MOVEM C,-LQIOSV+2(P) ;CROCK DUE TO SAVED AC C POPJ P, ;;; COME HERE TO ADD A COMPONENT TO THE GROWING NAMESTRING IN PNBUF. ;;; FOR ITS AND D10, THE SIXBIT IS IN TT, AND MUST BE CONVERTED. ;;; FOR DEC20, TT HAS A POINTER TO THE ASCIZ STRING TO ADD. 6BTNS1: IFN ITS+D10,[ SKIPN TT,(TT) ;A ZERO WORD GETS OUTPUT AS "*" MOVE TT,DFNWD 6BTNS2: SETZ T, LSHC T,6 JUMPE T,6BTNS3 10$ CAIE T,133-40 ;FOR DEC-10, BRACKETS MUST 10$ CAIN T,135-40 ; BE QUOTED 10$ JRST 6BTNS3 CAIE T,': 10% CAIN T,'; 10$ CAIN T,'. 6BTNS3: IDPB R,C ;^Q TO QUOTE FUNNY CHARS ADDI T,40 IDPB T,C JUMPN TT,6BTNS2 POPJ P, ] ;END OF IFN ITS+D10 IFN D20,[ SKIPN (TT) MOVEI TT,DFNWD SETZ D, HRLI TT,440700 6BTNS2: ILDB T,TT JUMPE T,CPOPJ TRZE D,1 ;D IS THE PRECEDING-CHAR-WAS-^V FLAG JRST 6BTNS3 IRPC X,,[:;<>=_*@ ,] ;EVEN NUMBER OF GOODIES! IFE .IRPCNT&1, CAIE T,"X .ELSE,[ CAIN T,"X IDPB R,C ;QUOTE FUNNY CHARACTER ] ;END OF .ELSE TERMIN SKIPE TENEXP JRST 6BNS3A ;TOPS-20 Requires more characters to be quoted IRPC X,,[(){}/!"#%&'\|`^~] IFE .IRPCNT&1, CAIE T,"X .ELSE,[ CAIN T,"X IDPB R,C ;QUOTE FUNNY CHARACTER ] ;END OF .ELSE TERMIN CAIE T,91. ;LEFT-SQUARE-BRACKET CAIN T,93. ;RIGHT-SQUARE-BRACKET IDPB R,C 6BNS3A: CAIN T,(R) ;REMEMBER A ^V TRO D,1 6BTNS3: IDPB T,C JRST 6BTNS2 ] ;END OF IFN D20 IFN D10,[ ;;; CONVERT ONE HALF OF A PPN, PUTTING ASCII CHARS IN PNBUF 6BTNS6: JUMPE TT,6BNS6A CAME TT,[-1,,] AOJA TT,6BTNS7 ;ADDING ONE PRODUCES A FLAG BIT 6BNS6A: MOVEI TT,"* ;AN OMITTED HALF IS OUTPUT AS "*" IDPB TT,C POPJ P, 6BNS7A: LSH TT,3+3*SAIL ;ZERO-SUPPRESS OCTAL (TOPS10/CMU), LEFT-JUSTIFY CHARS (SAIL) 6BTNS7: TLNN TT,770000_<3*<1-SAIL>> JRST 6BNS7A ;NOTE THAT THE FLAG BIT GETS SHIFTED TOO 6BNS7B: SETZ T, LSHC T,3+3*SAIL SA% ADDI T,"0 SA$ ADDI T,40 IDPB T,C TRNE TT,-1 ;WE'RE DONE WHEN THE FLAG BIT LEAVES THE RIGHT HALF JRST 6BNS7B POPJ P, ] ;END OF IFN D10 SUBTTL CONVERSION: NAMESTRING => SIXBIT ;;; THIS ONE IS PRETTY HAIRY. IT CONVERTS AN ATOMIC ;;; SYMBOL IN A, REPRESENTING A FILE SPECIFICATION, ;;; INTO "SIXBIT" FORMAT ON FXP. THIS INVOLVES ;;; PARSING A FILE NAME IN STANDARD ASCII STRING FORMAT ;;; AS DEFINED BY THE HOST OPERATING SYSTEM. ;;; FOR D20, THE OPERATING SYSTEM GIVES US SOME HELP. ;;; FOR ITS AND D10, WE ARE ON OUR OWN. IFN ITS+D10,[ ;;; THE GENERAL STRATEGY HERE IS TO CALL PRINTA TO EXPLODEC THE NAMESTRING. ;;; A PARSING COROUTINE TAKES THE SUCCESSIVE CHARACTERS AND INTERPRETS THEM. ;;; EACH COMPONENT IS ASSEMBLED IN SIXBIT FORM, AND WHEN IT IS TERMINATED ;;; BY A BREAK CHARACTER, IT IS PUT INTO ONE OF FOUR SLOTS RESERVED ON FXP. ;;; FOR CMU, WE ALSO ASSEMBLE THE CHARACTERS INTO PNBUF IN ASCII FORM, ;;; SO THAT WE CAN USE THE CMUDEC UUO TO CONVERT A CMU-STYLE PPN. ;;; AR1 HOLDS THE BYTE POINTER FOR ACCUMULATING A NAME. ;;; AR2A HOLDS MANY FLAGS DESCRIBING THE STATE OF THE PARSE: NMS==:1,,525252 ;FOR BIT-TYPEOUT MODE NMS.CQ==:1 ;CONTROL-Q SEEN NMS.CA==:2 ;CONTROL-A SEEN IFN D10,[ NMS.DV==:10 ;DEVICE SEEN (AND TERMINATING :) NMS.FN==:20 ;FILE NAME SEEN NMS.DT==:40 ;. SEEN NMS.XT==:100 ;EXTENSION SEEN NMS.LB==:200 ;LEFT BRACKET SEEN NMS.CM==:400 ;COMMA SEEN NMS.RB==:1000 ;RIGHT BRACKET SEEN NMS.ND==:10000 ;NON-OCTAL-DIGIT SEEN NMS.ST==:20000 ;* SEEN ] ;END OF IFN D10 ;;; CONTROL-A IS THE SAIL CONVENTION FOR QUOTING MANY CHARACTERS, BUT WE ;;; ADOPT IT FOR ALL ITS AND D10 SYSTEMS. NMS6BF: POP P,A POPI FXP,L.F6BT+1+1 NMS6B0: WTA [BAD NAMESTRING!] NMS6BT: MOVEI TT,(A) ;DON'T ALLOW FIXNUMS AS NAMESTRINGS LSH TT,-SEGLOG MOVSI R,FX TDNE R,ST(TT) ;A FIXNUM? JRST NMS6B0 ;YES, ILLEGAL AS A NAMESTRING PUSH P,A PUSHN FXP,L.F6BT+1 ;FOUR WORDS FOR FINISHED NAMES, ONE FOR ACCUMULATION MOVEI AR1,(FXP) ;AR1 HOLDS THE BYTE POINTER FOR ACCUMULATING A NAME HRLI AR1,440600 PUSH FXP,PNBP ;PARSE THE PPN INTO PNBUF SETZM PNBUF+LPNBUF-1 SETZ AR2A, ;ALL FLAGS INITIALLY OFF HRROI R,NMS6B1 .SEE PR.PRC PUSHJ P,PRINTA ;PRINTA WILL CALL NMS6B1 WITH SUCCESSIVE CHARS IN A TLNE AR2A,NMS.CA+NMS.CQ JRST NMS6BF ;ILLEGAL FOR A QUOTE TO BE HANGING MOVEI A,40 PUSHJ P,(R) ;FORCE A SPACE THROUGH TO TERMINATE LAST COMPONENT IFN D10,[ TLNE AR2A,NMS.LB TLNE AR2A,NMS.RB CAIA JRST NMS6BF ;LOSE IF LEFT BRACKET SEEN BUT NO RIGHT BRACKET ] ;END OF IFN D10 JUMPE AR1,NMS6BF ;AR1 IS ZEROED IF THE PARSING CORUTINE DETECTS AN ERROR POP P,A POPI FXP,2 MOVE T,DFNWD ;CHANGE ANY ZERO COMPONENTS TO "*" SKIPN -3(FXP) MOVEM T,-3(FXP) ;DEVICE NAME IT$ SKIPN -2(FXP) IT$ MOVEM T,-2(FXP) ;SNAME IFN D10,[ MOVE TT,-2(FXP) ;TREAT HALVES OF PPN SEPARATELY TLNN TT,-1 ;A ZERO HALF BECOMES -1 TLO TT,-1 TRNN TT,-1 TRO TT,-1 MOVEM TT,-2(FXP) ] ;END OF IFN D10 SKIPN -1(FXP) MOVEM T,-1(FXP) ;FILE NAME 1 SA$ MOVSI T,(SIXBIT \___\) SKIPN (FXP) MOVEM T,(FXP) ;FILE NAME 2/EXTENSION POPJ P, ;;; THIS IS THE NAMESTRING PARSING COROUTINE NMS6B1: JUMPE AR1,CPOPJ ;ERROR HAS BEEN DETECTED, FORGET THIS CHARACTER CAIN A,^A JRST NMS6BQ CAIN A,^Q TLCE AR2A,NMS.CQ ;FOR A CONTROL-Q, SET THE CONTROL-Q BIT CAIA ;IF IT WAS ALREADY SET, IT'S A QUOTED ^Q POPJ P, ;OTHERWISE EXIT CAIN A,40 ;SPACE? TLZN AR2A,NMS.CQ ;YES, QUOTED? SKIPA ;NO TO EITHER TEST JRST NMS6B9 ;YES TO BOTH, IS QUOTED SPACE CAILE A,40 ;SKIP OF CONTROL CHARACTER OR SPACE JRST NMS6B7 ;WE HAVE ENCOUNTERED A BREAK CHARACTER - DECIDE WHAT TO DO WITH COMPONENT NMS6B8: SKIPN D,(AR1) POPJ P, ;NO CHARACTERS ASSEMBLED YET IT$ SKIPN -2(AR1) ;IF WE HAVE A FILE NAME 1, THIS MUST BE FN2 10$ TLNN AR2A,NMS.DT ;WE HAVE SEEN A DOT, THIS MUST BE THE EXTENSION JRST NMS6B5 ;OTHERWISE THIS IS FILE NAME 1 IT$ SKIPE -1(AR1) ;LOSE IF WE ALREADY HAVE A FILE NAME 2 10$ TLNE AR2A,NMS.XT+NMS.LB+NMS.CM+NMS.RB JRST NMS6BL ;LOSE IF EXTENSION AFTER BRACKETS OR OTHER ONE IT$ MOVEM D,-1(AR1) 10$ HLLZM D,-1(AR1) 10$ TLO AR2A,NMS.XT ;SET FLAG: WE'VE SEEN THE EXTENSION ;COME HERE TO RESTORE THE BYTE POINTER FOR THE NEXT COMPONENT NMS6B6: JUMPE AR1,CPOPJ ;IF AN ERROR HAS BEEN DETECTED, EXIT HRLI AR1,440600 MOVE D,PNBP ;RESET THE PNBUF BYTE POINTER ALSO MOVEM D,1(AR1) 10$ TLZ AR2A,NMS.ND+NMS.ST ;RESET NON-OCTAL-DIGIT AND STAR SEEN FLAGS SETZM (AR1) ;CLEAR ACCUMULATION WORD POPJ P, ;COME HERE FOR FILE NAME 1 NMS6B5: 10$ TLNE AR2A,NMS.FN+NMS.DT+NMS.XT+NMS.LB+NMS.CM+NMS.RB 10$ JRST NMS6BL ;LOSE IF TOO LATE FOR A FILE NAME MOVEM D,-2(AR1) ;SAVE FILE NAME 1 JRST NMS6B6 ;HERE WITH A NON-CONTROL NON-SPACE CHARACTER NMS6B7: TLZN AR2A,NMS.CQ TLNE AR1,NMS.CA JRST NMS6B9 ;IF CHARACTER QUOTED (FOR ^Q, FLAG IS RESET) CAIN A,": JRST NMS6DV ;: SIGNALS A DEVICE NAME IT$ CAIN A,"; IT$ JRST NMS6SN ;; MEANS AN SNAME IFN D10,[ CAIN A,". JRST NMS6PD ;PERIOD MEANS TERMINATION OF FILE NAME CAIN A,133 JRST NMS6LB ;LEFT BRACKET CAIN A,", JRST NMS6CM ;COMMA CAIN A,135 JRST NMS6RB ;RIGHT BRACKET CAIN A,"* JRST NMS6ST ;STAR ] ;END OF IFN D10 ;HERE TO DUMP A CHARACTER INTO THE ACCUMULATING COMPONENT NMS6B9: IFN D10,[ IFE SAIL,[ SKIPN CMUP JRST .+4 SKIPE PNBUF+LPNBUF-1 TDZA AR1,AR1 ;ASSUME A COMPONENT THAT FILLS PNBUF IS A LOSER IDPB A,1(AR1) ;STICK ASCII CHARACTER IN PNBUF ] ;END OF IFE SAIIL CAIL A,"0 CAILE A,"7 TLO AR2A,NMS.ND ;SET FLAG IF NON-OCTAL-DIGIT NMS6B4: ] ;END OF IFN D10 CAIGE A,140 ;CONVERT LOWER CASE TO UPPER, SUBI A,40 ; AND ASCII TO SIXBIT TLNE AR1,770000 IDPB A,AR1 ;DUMP CHARACTER INTO ACCUMULATING NAME POPJ P, NMS6BQ: TLCA AR2A,NMS.CA ;COMPLEMENT CONTROL-A FLAG NMS6BL: SETZ AR1, ;ZEROING AR1 INDICATES A PARSE ERROR POPJ P, NMS6DV: SKIPE D,(AR1) ;ERROR IF : SEEN WITH NO PRECEDING COMPONENT 10$ ;ERROR AFTER OTHER CRUD 10$ TLNE AR2A,NMS.DV+NMS.FN+NMS.DT+NMS.XT+NMS.LB+NMS.CM+NMS.RB 10% SKIPE -4(AR1) ;ERROR IF DEVICE NAME ALREADY SEEN JRST NMS6BL MOVEM D,-4(AR1) 10$ TLO AR2A,NMS.DV JRST NMS6B6 ;RESET BYTE POINTER IFN ITS,[ NMS6SN: SKIPE D,(AR1) ;ERROR IF ; SEEN WITHOUT PRECEDING COMPONENT SKIPE -3(AR1) ;ERROR IF WE ALREADY HAVE AN SNAME JRST NMS6BL MOVEM D,-3(AR1) JRST NMS6B6 ;RESET BYTE POINTER ] ;END OF IFN ITS IFN D10,[ NMS6PD: TLNE AR2A,NMS.DT+NMS.XT+NMS.LB+NMS.CM+NMS.RB JRST NMS6BL PUSHJ P,NMS6B8 ;DOT SEEN - SEE IF IT TERMINATED THE FILE NAME TLO AR2A,NMS.DT ;SET PERIOD (DOT) FLAG POPJ P, NMS6LB: TLNE AR2A,NMS.LB+NMS.CM+NMS.RB JRST NMS6BL ;LEFT BRACKET ERROR IF ALREADY A BRACKET PUSHJ P,NMS6B8 ;DID WE TERMINATE THE FILE NAME OR EXTENSION? TLO AR2A,NMS.LB ;SET LEFT BRACKET FLAG NMS6L1: SA% HRLI AR1,440300 SA$ HRLI AR1,440600 POPJ P, NMS6CM: LDB D,[360600,,AR1] CAIE D,44 ;ERROR IF NO CHARACTERS AFTER LEFT BRACKET TLNN AR2A,NMS.LB ;ERROR IF NO LEFT BRACKET! JRST NMS6BL SA% TLNE AR2A,NMS.ND+NMS.CM+NMS.RB SA$ TLNE AR2A,NMS.CM+NMS.RB JRST NMS6BL ;ERROR IF NON-OCTAL-DIG, COMMA, OR RGT BRACKET PUSHJ P,NMS6PP ;HACK HALF A PPN JUMPE AR1,CPOPJ HRLM D,-3(AR1) TLO AR2A,NMS.CM ;SET COMMA FLAG SETZM (AR1) ;CLEAR COLLECTING WORD JRST NMS6L1 ;RESET BYTE POINTER NMS6RB: LDB D,[360600,,AR1] SA% SKIPN CMUP TLNE AR2A,NMS.CM ;MUST HAVE COMMA BEFORE RB IN NON-CMU CAIN D,44 ;ERROR IF NO CHARS SINCE COMMA/LEFT BRACKET JRST NMS6BL TLNE AR2A,NMS.LB ;ERROR IF NO LEFT BRACKET TLNE AR2A,NMS.RB ;ERROR IF RIGHT BRACKET ALREADY SEEN JRST NMS6BL IFE SAIL,[ SKIPN CMUP JRST .+3 TLNN AR2A,NMS.CM ;FOR CMU, NO COMMA MEANS A CMU-STYLE PPN JRST NMS6R1 ] ;END OF IFE SAIL PUSHJ P,NMS6PP ;FIGURE OUT HALF A PPN JUMPE AR1,CPOPJ HRRM D,-3(AR1) NMS6R2: TLO AR2A,NMS.RB ;SET RIGHT BRACKET FLAG JRST NMS6B6 ;RESET THE WORLD IFE SAIL,[ NMS6R1: MOVEI D,PNBUF CMUDEC D, ;CONVERT CMU-STYLE PPN TO A WORD JRST NMS6BL ;LOSE LOSE MOVEM D,-3(AR1) ;WIN - SAVE IT AWAY JRST NMS6R2 ] ;END OF IFE SAIL NMS6ST: TLOE AR2A,NMS.ST ;SET STAR FLAG, SKIP IF NOT ALREADY SET TLO AR2A,NMS.ND ;TWO STARS = A NON-DIGIT FOR PPN PURPOSES JRST NMS6B4 NMS6PP: SA% TLNE AR2A,NMS.ND SA% SETZ AR1, ;NON-DIGIT IN PPN IS AN ERROR HRRZI D,-1 TLNE AR2A,NMS.ST ;STAR => 777777 POPJ P, LDB TT,[360600,,AR1] CAIGE TT,22 SETZ AR1, ;MORE THAN SIX DIGITS LOSES MOVNS TT MOVE D,(AR1) LSH D,(TT) ;RIGHT-JUSTIFY THE DIGITS POPJ P, ] ;END OF IFN D10 ] ;END OF IFN ITS+D10 IFN D20,[ ;;; THE STRATEGY HERE IS TO USE GTJFN TO PARSE THE STRING, ;;; THEN GET THE VARIOUS COMPONENTS BACK SINGLY WITH JFNS. NMS6BB: MOVE A,AR1 NMS6BA: UNLOCKI NMS6B0: %WTA (T) NMS6BT: MOVEI T,[SIXBIT \FIXNUM ILLEGAL AS NAMESTRING\] LOCKI ;LOCK OUT INTERRUPTS (BECAUSE OF JSYS'S) MOVEI TT,(A) ;DON'T ALLOW FIXNUMS AS NAMESTRINGS LSH TT,-SEGLOG MOVSI R,FX TDNE R,ST(TT) ;A FIXNUM? JRST NMS6BA ;YES, ILLEGAL AS A NAMESTRING PUSHJ P,PNBFMK ;STRING OUT CHARACTERS INTO PNBUF MOVEI T,[SIXBIT \NAMESTRING TOO LONG!\] JUMPE AR2A,NMS6BA ;LOSE IF DIDN'T FIT IN PNBUF SETZ B, IDPB B,AR1 ;TERMINATE STRING WITH A NULL (ZERO) BYTE MOVE AR1,A ;SAVE ORIGINAL ARG IN CASE OF ERROR MOVEI T,[SIXBIT \LONG GTJFN FAILED IN NAMESTRING!\] MOVEI 1,LFGB20 SKIPE TENEXP MOVEI 1,LFGB10 MOVE 2,PNBP GTJFN ;GET A JFN FOR PARSED NAMESTRING IOJRST 0,NMS6BB ; PRESUMABLY, THE COMPONENTS CANT BE "TOO LONG" ;R=0 => NMS6BT TDZA R,R ;CONVERT JFN IN 1 TO "SIXBIT" ON FXP JFN6BT: MOVEI R,1 ; SKIP ON FAILURE POP FXP,F ;POP LOCKI WORD (COME IN LOCKED, EXIT UNLOCKED) MOVE D,FXP .SEE TRUENAME MOVE 2,1 ;"INDEXABLE FILE HANDLE" RETURNED BY GTJFN SETZM PNBUF MOVE T,[PNBUF,,PNBUF+1] BLT T,PNBUF+LPNBUF-1 PUSHJ P,JFN6BB ;INITIALIZE PNBUF AN AC 1 .SEE JS%DEV JS%DIR JS%NAM JS%TYP JS%GEN JS%OUT==:<.JSAOF*111111111111> MOVSI 3,(JS%DEV&JS%OUT) JFNS ERJMP JFN6BY ;IF ERROR THEN TRY DEVST MOVNI T,L.6DEV ;STACK UP DEVICE FIELD ON FXP, AND PUSHJ P,JFN6BA ;ZERO PNBUF, SETUP 1 IRP LEN,,[L.6DIR,L.6FNM,L.6EXT]FLD,,[DIR,NAM,TYP] MOVSI 3,(JS%!FLD&JS%OUT) JFNS ;GET ASCIZ STRING FOR NEXT COMPONENT MOVNI T,LEN ;STACK UP ONE FIELD ON FXP, AND PUSHJ P,JFN6BA ;ZERO PNBUF, SETUP 1 TERMIN MOVSI 3,(JS%GEN&JS%OUT) JFNS ;GET ASCIZ STRING FOR VERSION NUMBER SKIPN T,PNBUF JRST JFN6BC CAMN T,[ASCII \99999\] CAME 1,[010700,,PNBUF] JRST .+2 SETZ T, JFN6BC: SKIPN T MOVE T,DFNWD PUSH FXP,T ;STACK UP THE FEW WORDS OF "VERSION" REPEAT L.6VRS-1, PUSH FXP,PNBUF+1+.RPCNT JFN6BX: PUSH FXP,F ;PUSH LOCKI WORD BACK JUMPN R,JFN6BU ;NON-ZERO ==> ENTRY FROM TRUENAME ETC MOVEI 1,(2) RLJFN ;RELEASE THE JFN FOR NMS6BT JSP T,RLJLUZ JFN6BU: UNLKPOPJ RLJLUZ: LERR [SIXBIT \A "RLJFN" HAS LOST SOMEWHERE!\] JFN6BY: MOVEI T,[SIXBIT \DEVICE FAILURE IN NAMESTRING!\] CAIE 2,.PRIIN ;PRIMARY INPUT? CAIN 2,.PRIOU ;OR PRIMARY OUTPUT SKIPA ;YES JRST JFN6ER ;NOPE, FAIL PUSH FXP,[ASCII/PRIMA/] PUSH FXP,[ASCIZ/RY/] PUSHN FXP,\<+L.6DIR+L.6FNM+L.6EXT+L.6VRS> JRST JFN6BX JFN6ER: MOVE FXP,D ;FLUSH ALL CRUD OFF FXPDL PUSH FXP,F ;PUSH LOCKI WORD BACK JUMPE R,NMS6BB ;FOR NMS6BT, GO GIVE WTA ERROR AOS (P) ;FOR JFN6BT, SKIP ON FAILURE UNLKPOPJ ;;; SUBROUTINE TO "ADD" ONE ITEM OF INFORMATION TO THE FORMING SIXBIT JFN6BA: HRLS T HRRI T,PNBUF PUSH FXP,(T) ;STACK UP PNBUF, TO LIMIT GIVEN IN T AOBJN T,.-1 JFN6BB: MOVE 1,PNBP ;STRING PTR FOR NEXT CALL TO JNFS MOVNI T,LPNBUF SKIPN PNBUF+LPNBUF(T) POPJ P, SETZM PNBUF+LPNBUF(T) ;CLEAR OUT PNBUF AOJL T,.-3 POPJ P, LFGB20: GJ%ACC+GJ%OFG+GJ%FLG 99999. ;BLOCK FOR LONG FORM OF GTJFN .NULIO,, .NULIO REPEAT,4 440700,, R70 ;DEFAULT STRINGS FOR dev:fnm.ext REPEAT 3, 0 LFGB10: GJ%ACC+GJ%OFG+GJ%FLG 99999. ;BLOCK FOR LONG FORM OF GTJFN .NULIO,, .NULIO 0 ;DEFAULT DEVICE? REPEAT,4 0 ;DEFAULT STRINGS FOR fnm.ext ;REPEAT,4 440700,, R70 ;DEFAULT STRINGS FOR fnm.ext REPEAT 3, 0 ] ;END OF IFN D20 SUBTTL CONVERSION: ANY FILE SPEC => SIXBIT ;;; TAKE ARGUMENT IN A (MAY BE FILE ARRAY, NAMELIST, ;;; OR NAMESTRING), FIGURE IT OUT AND SOMEHOW RETURN ;;; "SIXBIT" FORMAT ON FXP. ;;; IFL6BT SAYS THAT T MEANS TTY INPUT, NOT TTY OUTPUT. ;;; SAVES C AR1 AR2A IFL6BT: CAIN A,TRUTH HRRZ A,V%TYI JRST FIL6B0 IFN SFA,[ FILSFA: MOVEI B,QNAME ;EXTRACT THE "FILENAME" FROM THE SFA SETZ C, ;NO ARGS PUSHJ P,ISTCSH ;SHORT CALL, THEN USE RESULT AS NEW NAME ] ;END IFN SFA FIL6BT: CAIN A,TRUTH HRRZ A,V%TYO FIL6B0: SKIPN A ;NIL => USE "DEFAULTF" FIL6DF: HRRZ A,VDEFAULTF ;USE "DEFAULTF" FIL6B1: MOVEI R,(A) LSH R,-SEGLOG SKIPGE R,ST(R) JRST NML6BT ;LIST => NAMELIST TLNN R,SA JRST FIL6B2 ;NOT ARRAY => NAMESTRING MOVE R,ASAR(A) SFA$ TLNE R,AS.SFA ;AN SFA? SFA$ JRST FILSFA ;YES, EXTRACT NAME FROM IT AND TRY AGAIN TLNN R,AS JRST NMS6B0 ;INCOMPREHENSIBLE NAMESTRING LOCKI ;FOR FILE, GOBBLE NAMES OUT OF FILE OBJECT POP FXP,D ;POP LOCKI WORD MOVE TT,TTSAR(A) ADDI TT,F.DEV HRLI TT,-L.F6BT PUSH FXP,(TT) ;PUSH ALL WORDS OF FILE SPEC AOBJN TT,.-1 PUSH FXP,D ;PUSH BACK LOCKI WORD UNLKPOPJ ;UNLOCK AND EXIT FIL6B2: JSP T,QIOSAV JRST NMS6BT QIOSAV: SAVE B C AR1 AR2A PUSHJ P,(T) RSTR AR2A AR1 C B POPJ P, LQIOSV==5 ; 5 THINGS - 4 AC'S AND ONE RET ADDR .SEE 6BTNS8 ;RELIES ON AC C BEING SAVED IN CERTAIN SPOT SUBTTL MERGEF, TRUENAME, PROBEF AND MERGING ROUTINES ;;; MERGEF TAKES TWO FILE SPECS OF ANY KIND, MERGES THEM, ;;; AND RETURNS A NAMELIST OF THE RESULTING SPECS. ;;; AS A CROCK, (MERGEF X '*) SIMPLY MAKES THE SECOND FILE NAME BE *. ;;; (FOR D20, THE VERSION BECOMES NULL) MERGEF: PUSH P,B PUSHJ P,FIL6BT POP P,A CAIE A,Q. JRST MRGF1 20% MOVE T,DFNWD 20% MOVEM T,(FXP) 20$ REPEAT L.6VRS, SETZM -.RPCNT(FXP) JRST 6BTNML MRGF1: PUSHJ P,FIL6BT PUSHJ P,IMRGF JRST 6BTNML ;;; IMRGF MERGES TWO SETS OF SPECS ON THE FIXNUM PDL. ;;; DMRGF MERGES A SET WITH THE DEFAULT FILE NAMES. ;;; DEC-10 PPN'S MERGE HALVES OF THE PPN SEPARATELY; ;;; AN UNSPECIFIED HALF IS -1 OR 0, *NOT* (SIXBIT \*\)!! ;;; SAVES F (SEE LOAD). DMRGF: ;FIRST SEE WHETHER WE REALLY NEED TO CONVERT THE DEFAULTS TO "SIXBIT" IFN ITS+D10,[ MOVE TT,DFNWD REPEAT L.F6BT,[ IFN ITS\<.RPCNT-1>,[ CAME TT,.RPCNT-3(FXP) ;MUST MERGE IF FILE NAME IS ZERO OR * SKIPN .RPCNT-3(FXP) JRST DMRGF5 ] ;END OF IFN ITS\<.RPCNT-1> .ELSE,[ MOVE T,.RPCNT-3(FXP) AOJE T,DMRGF7 SOJE T,DMRGF7 TRNE T,-1 TRNN T,-1 JRST DMRGF5 SKIPA DMRGF7: SETZM .RPCNT-3(FXP) ] ;END OF .ELSE ] ;END OF REPEAT L.F6BT ] ;END OF IFN ITS+D10 IFN D20,[ MOVE TT,DFNWD ZZZ==0 IRP FOO,,[L.6VRS,L.6EXT,L.6FNM,L.6DIR,L.6DEV] ZZZ==ZZZ+FOO CAME TT,-ZZZ+1(FXP) SKIPN -ZZZ+1(FXP) JRST DMRGF5 TERMIN EXPUNGE ZZZ ] ;END OF IFN D20 POPJ P, ;MERGE WOULDN'T DO ANYTHING - FORGET IT DMRGF5: PUSH FLP,F ;MERGE WITH DEFAULT FILE NAMES HRRZ A,VDEFAULTF PUSHJ P,FIL6BT POP FLP,F 20% ;JRST IMRGF IFN D20,[ PUSHJ P,IMRGF SKIPE TT,-L.F6BT+L.6DEV+1(FXP) CAMN TT,DFNWD JRST .+2 POPJ P, PUSH P,A JSP T,TNXUDI MOVEI D,-L.F6BT+L.6DEV+1(FXP) HRLI D,-L.6DIR MOVNI T,1 ;Initialize pointer into PNBUF DMRGF6: AOJ T, ;Loop copying default directory onto FXP MOVE R,PNBUF(T) MOVEM R,(D) JUMPE R,POPAJ ;Terminate loop when no end of string AOBJN D,DMRGF6 ; or when no more room JRST POPAJ ;;; CODE TO GET THE CONNECTED DIRECTORY NAME INTO THE PNBUF TNXUDI: MOVE TT,[PNBUF,,PNBUF+1] SETZM PNBUF ;CLEAR PNBUF BLT TT,PNBUF+LPNBUF-1 LOCKI GJINF ;GET JOB INFORMATION MOVE 1,PNBP ;POINTER INTO PNBUF DIRST ;GET EQUIVALENT ASCII STRING JRST TNXU9D ;HMM... MOVE 1,PNBP TNXUD0: ILDB D,1 ;SCAN DEVICE-NAME PART CAIN D,0 JRST TNXUD2 ;WIN! NOT PUNCTUATION ANYWAY! CAIE D,^V CAIE D,": JRST TNXUD0 ILDB D,1 CAIE D,"< JRST TNXU9P MOVE 2,PNBP TNXUD3: ILDB D,1 ;TRANSFER DIRECTORY-NAME PART CAIN D,0 JRST TNXU9P CAIE D,^V JRST TNXUD5 IDPB D,2 ILDB D,1 TNXUD6: IDPB D,2 JRST TNXUD3 TNXUD5: CAIE D,"> JRST TNXUD6 MOVEI D,0 MOVEI A,9 IDPB D,2 ;PAD LIKE ASCIZ WITH AN EXTRA WORD OF 0'S SOJG A,.-1 TNXUD2: SETZB 1,2 UNLOCKI JRST (T) TNXU9P: MOVE 1,[440700,,[ASCIZ \Punctuated string in PNBUF loses in TNXUDI\]] JRST TNXDIE TNXU9D: SKIPA 1,[440700,,[ASCIZ \DIRST loses in TNXUDI\]] TNXST9: MOVE 1,[440700,,[ASCIZ \GETTAB loses in TNXSET\]] TNXDIE: PSOUT HALTF ] ;END OF IFN D20 IMRGF: MOVE TT,DFNWD ;MERGE TWO SETS OF NAMES ON FXP, ; "POPPING" THE TOP ONE OFF IFN ITS+D10,[ MOVEI T,L.F6BT MRGF2: 10$ MOVE R,D POP FXP,D 10$ CAIE T,2 ;PPN IS PENULTIMATE FROB - DON'T COMPARE TO * CAME TT,-3(FXP) SKIPN -3(FXP) MOVEM D,-3(FXP) SOJG T,MRGF2 IFN D10,[ MOVE D,-2(FXP) ;R HAS PPN 2 - GET PPN 1 IN D AOJE D,MRGF3 SOJE D,MRGF3 TLNN D,-1 HLLM R,-2(FXP) TRNN D,-1 HRRM R,-2(FXP) SKIPA MRGF3: SETZM -2(FXP) ] ;END OF IFN D10 ] ;END OF IFN ITS+D10 IFN D20,[ IRP FOO,,[VRS,EXT,FNM,DIR,DEV] CAME TT,-L.6!FOO-L.F6BT+1(FXP) SKIPN -L.6!FOO-L.F6BT+1(FXP) JRST IM!FOO!1 POPI FXP,L.6!FOO JRST IM!FOO!2 IM!FOO!1: IFLE L.6!FOO-3, REPEAT L.6!FOO, POP FXP,-L.F6BT(FXP) .ELSE,[ MOVEI T,L.6!FOO POP FXP,-L.F6BT(FXP) SOJG T,.-1 ] ;END OF .ELSE IM!FOO!2: TERMIN ] ;END OF IFN D20 C6BTNML: POPJ P,6BTNML ;;; (TRUENAME ) RETURNS THE RESULT OF .RCHST ON ITS, ;;; I.E. THE REAL FILE NAMES AFTER TRANSLATIONS, LINKS, ETC. ;;; THE RESULT IS A NAMELIST. TRUNM9: EXCH A,AR1 %WTA NFILE ;SUBR 1 TRUENAME: ;MUST SAVE AR1 - SEE PRNF6-PRNJ2 IFN SFA,[ CAIN A,TRUTH ;T? HRRZ A,V%TYO ; Use TYO EXCH AR1,A JSP TT,XFOSP ;FILE OR SFA OR NOT? JRST TRUNM9 ;NOT JRST TRUNMZ ;FILE EXCH A,AR1 JSP T,QIOSAV MOVEI B,QTRUENAME SETZ C, ;NO THIRD ARG JRST ISTCSH ;SHORTY INTERNAL STREAM CALL TRUNMZ: EXCH A,AR1 ] ;END IFN SFA PUSH P,C6BTNML TRU6BT: CAIN A,TRUTH HRRZ A,V%TYO TRUNM2: EXCH AR1,A LOCKI JSP TT,XFILEP JRST TRUNM8 EXCH A,AR1 HRRZ TT,TTSAR(A) IFN ITS+D10,[ POP FXP,T ;POP THE LOCKI WORD HRLI TT,-L.F6BT PUSH FXP,F.RDEV(TT) AOBJN TT,.-1 PUSH FXP,T ;PUSH LOCKI WORD BACK UNLKPOPJ ] ;END OF ITS+D10 IFN D20,[ PUSH P,A MOVE 1,F.JFN(TT) PUSHJ P,JFN6BT ;GET "SIXBIT" ON FXP, AND UNLOCKI JRST POPAJ ; ON SUCCESS, LEAVES "SIXBIT" FORMS ON FXPDL POP P,A JRST TRUNM0 ] ;END OF IFN D20 TRUNM8: UNLOCKI EXCH AR1,A TRUNM0: %WTA NFILE ;NOT FILE SFA$ MOVE T,C6BTNML ;IF NOT CALLED AS A SUBR, ONLY ACCEPT A FILE SFA$ CAME T,(P) JRST TRUNM2 SFA$ POPI P,1 SFA$ JRST TRUENAME ;;; (STATUS UREAD) SUREAD: SKIPN A,VUREAD POPJ P, PUSHJ P,TRUENAME HLRZ B,(A) HRRZ A,(A) HRRZ C,(A) 20$ HRRZ C,(C) 20$ HRRM C,(A) HRRM B,(C) POPJ P, ;;; (STATUS UWRITE) SUWRITE: SKIPE A,VUWRITE PUSHJ P,TRUENAME JRST $CAR ;(CAR NIL) => NIL ;;; ROUTINE TO SET UP ARGS FOR TWO-ARGUMENT FILE FUNCTION. ;;; PUT TWO SETS OF FILE NAMES ON FXP. IF THE ARGS ARE ;;; X AND Y, THEN THE NAMES ON FXP ARE (MERGEF X NIL) AND ;;; (MERGEF Y (MERGEF X NIL)). THE FIRST ARG IS LEFT IN AR1. 2MERGE: PUSH P,A PUSH P,B PUSHJ P,FIL6BT PUSHJ P,DMRGF POP P,A PUSHJ P,FIL6BT MOVEI T,L.F6BT PUSH FXP,-2*L.F6BT+1(FXP) SOJG T,.-1 PUSHJ P,IMRGF ;NOW WE HAVE THE MERGED FILE SPECS POP P,AR1 ;FIRST ARG POPJ P, ;;; (PROBEF X) TRIES TO DECIDE WHETHER FILE X EXISTS. ;;; ON ITS AND D10 THIS IS DONE BY TRYING TO OPEN THE FILE. ;;; ON D20 WE USE THE GTJFN JSYS. ;;; RETURNS REAL FILE NAMES ON SUCCESS, NIL ON FAILURE. PROBEF: ;SUBR 1 IFN SFA,[ JSP TT,AFOSP ;DO WE HAVE AN SFA? JRST PROBEZ ;NOPE JRST PROBEZ ;NOPE MOVEI B,QPROBEF ;PROBEF OPERATION SETZ C, ;NO ARGS JRST ISTCSH ;SHORT CALL, RETURN RESULTS PROBEZ: ] ;END IFN SFA PUSHJ P,FIL6BT PROBF0: PUSHJ P,DMRGF IFN ITS,[ LOCKI SETZ TT, ;ASSUME NO CONTROL ARG MOVSI T,'USR ;CHECK FOR USR DEVICE CAMN T,-3-1(FXP) ;MATCH? TRO TT,10 ;SET BIT 1.4 (INSIST ON EXISTING JOB) .CALL PROBF8 JRST PROBF6 .CALL PROBF9 .LOSE 1400 .CLOSE TMPC, UNLOCKI ] ;END OF IFN ITS IFN D10,[ LOCKI MOVEI T,.IODMP ;I/O MODE (DUMP MODE) MOVE TT,-3-1(FXP) ;DEVICE NAME SETZ D, OPEN TMPC,T JRST PROBF6 ;NO SUCH FILE IF NO SUCH DEVICE! IFE SAIL,[ MOVEI T,3 ;ONLY NEED 3 ARGS OF EXTENDED LOOKUP MOVE D,-1-1(FXP) ;FILE NAME HLLZ R,0-1(FXP) ;EXTENSION MOVE TT,-2-1(FXP) ;PPN ] ;END IFE SAIL IFN SAIL,[ MOVE T,-1-1(FXP) ;FILE NAME HLLZ TT,0-1(FXP) ;EXTENSION CAMN TT,[SIXBIT \___\] SETZ TT, SETZ D, ;UNUSED MOVE R,-2-1(FXP) ;PPN ] ;END IFN SAIL LOOKUP TMPC,T JRST PROBF5 ;FILE DOESN'T EXIST PUSHJ P,D10RFN ;READ BACK FILE NAMES RELEASE TMPC, ;RELEASE TEMP CHANNEL UNLOCKI JRST 6BTNML ;FORM NAMELIST ON SUCCESS D10RFN: MOVEI F,TMPC ;WE WILL GET DEVICE NAME FROM MONITOR SA% DEVNAM F, SA$ PNAME F, SKIPA ;NONE SO RETAIN OLD NAME MOVEM F,-3-1(FXP) ;ELSE STORE NEW DEVICE NAME IFE SAIL,[ MOVEM TT,-2-1(FXP) ;STORE DATA AS RETURNED FROM EXTENDED LOOKUP MOVEM D,-1-1(FXP) HLLZM R,0-1(FXP) ] ;END IFE SAIL IFN SAIL,[ MOVEM T,-1-1(FXP) ;SAIL HAS NO EXTENDED LOOKUP!!!!! HLLZM TT,0-1(FXP) ; SO, WE CAN'T STORE PPN; JUST ASSUME IT IS ; WHAT WE GAVE IT ] ;END IFN SAIL POPJ P, ] ;END OF IFN D10 IFN D20,[ PUSHJ P,6BTNSL ;GET NAMESTRING IN PNBUF LOCKI MOVSI 1,(GJ%OLD+GJ%ACC+GJ%SHT) .SEE .GJDEF MOVE 2,PNBP GTJFN ;GET A JFN (INSIST ON EXISTING FILE) JRST UNLKFALSE PUSH FLP,1 ;SAVE JFN OVER JFN6BT PUSHJ P,JFN6BT ;CONVERT JFN TO "SIXBIT" FORMAT ON FXP TDZA B,B MOVEI B,TRUTH ;SKIPS ON FAILURE POP FLP,1 RLJFN ;RELEASE THE JFN JSP T,RLJLUZ JUMPN B,FALSE ] ;END OF IFN D20 10% JRST 6BTNML IFN ITS+D10,[ 10$ PROBF5: RELEASE TMPC, PROBF6: UNLOCKI POPI FXP,L.F6BT ;POP "SIXBIT" CRUD FROM FXP JRST FALSE ;RETURN FALSE ON FAILURE ] ;END OF IFN ITS+D10 IFN ITS,[ PROBF8: SETZ SIXBIT \OPEN\ ;OPEN FILE (ASCII UNIT INPUT) 4000,,TT ;CONTROL ARG (DON'T CREATE BIT SET FOR USR) 1000,,TMPC ;CHANNEL # ,,-3-1(FXP) ;DEVICE NAME ,,-1-1(FXP) ;FILE NAME 1 ,,0-1(FXP) ;FILE NAME 2 400000,,-2-1(FXP) ;SNAME PROBF9: SETZ SIXBIT \RFNAME\ ;READ REAL FILE NAMES 1000,,TMPC ;CHANNEL # 2000,,-3-1(FXP) ;DEVICE NAME 2000,,-1-1(FXP) ;FILE NAME 1 2000,,0-1(FXP) ;FILE NAME 2 402000,,-2-1(FXP) ;SNAME ] ;END OF IFN ITS SUBTTL RENAMEF FUNCTION, CNAMEF FUNCTION ;;; (RENAMEF X Y) RENAMES (MERGEF X (NAMELIST NIL)) TO BE ;;; (MERGEF Y (MERGEF X (NAMELIST NIL))). ;;; IF X IS AN OUTPUT FILE ARRAY, IT IS RENAMED AND CLOSED. $RENAMEF: PUSHJ P,2MERGE ;2MERGE LEAVES ARG 1 IN AR1 MOVEI A,(AR1) HLLOS NOQUIT JSP TT,XFILEP ;SKIP IF FILE ARRAY JRST RENAM2 MOVE TT,TTSAR(A) HLL AR1,TT TLNE TT,TTS.CL JRST RENM2A IFN D10+ITS,[ PUSHJ P,JCLOSE IFN ITS,[ .CALL RENAM7 ;ITS RENAME! - MUST RENAME WHILE OPEN IOJRST 0,RENAM6 ] ;END OF IFN ITS IFN D10,[ MOVE F,F.CHAN(TT) ;ttsar left in TT by JCLOSE MOVE T,-1(FXP) ;D10 RENAME! - will construct instruction HLLZ TT,(FXP) SA$ CAMN TT,[SIXBIT \___\] SA$ SETZ TT, SETZ D, MOVE R,-2(FXP) LSH F,27 IOR F,[RENAME 0,T] XCT F IOJRST 0,RENAM6 ] ;END OF IFN D10 RENAM1: MOVE TT,TTSAR(A) MOVE D,-1(FXP) ;UPDATE THE FILE NAMES OF ARRAY MOVEM D,F.FN1(TT) 10% MOVE R,(FXP) 10$ HLLZ R,(FXP) MOVEM R,F.FN2(TT) IFN D10,[ MOVEM D,F.RFN1(TT) ;TRUENAMES for D10, and CLOSE/RELEASE MOVEM F,F.RFN2(TT) MOVE R,-2(FXP) MOVEM R,F.PPN(TT) MOVEM R,F.RPPN(TT) SA$ XOR F,[#] SA$ XCT F SA$ XOR F,[#] SA% XOR F,[#] XCT F ] ;END OF IFN D10 IFN ITS,[ .CALL RFNAME ;TRUENAMES for ITS and CLOSE file .LOSE 1400 .CALL CLOSE9 .LOSE 1400 ] ;END OF IFN ITS ] ;END OF IFN D10+ITS IFN D20,[ PUSH P,F.JFN(TT) PUSHJ P,JCLOSE RENAM0: PUSHJ P,X6BTNSL POP P,T MOVSI 1,(GJ%FOU+GJ%NEW+GJ%ACC+GJ%SHT) MOVE 2,PNBP GTJFN IOJRST 0,RENAM5 MOVEI 2,(1) JUMPE AR1,RENM0A TLNE AR1,TTS.CL ;THE "CLOSED" BIT WAS TRANSFERRED JRST RENM0A MOVEI 1,(T) HRLI 1,(CO%NRJ) CLOSF IOJRST 0,RENAM4 RENM0A: MOVEI 1,(T) RNAMF IOJRST 0,RENAM4 MOVE 1,2 RLJFN ;? SHOULD GC DO THE RELEASE? JSP T,RLJLUZ JUMPE AR1,RENM0B MOVE TT,TTSAR(AR1) MOVEI T,F.DEV(TT) HRLI T,-L.F6BT+1(FXP) BLT T,F.DEV+L.F6BT-1(TT) RENM0B: JUMPE AR1,RENM1A ] ;END OF IFN D20 POPI FXP,L.F6BT ;WHEN 1ST ARG IS FILE ARRAY, THEN RETURN THAT SKIPA A,AR1 RENM1A: PUSHJ P,6BTNML ;OTHERWISE, RET VAL IS THE (NEW) NAMELIST POPI FXP,L.F6BT JRST CZECHI RENAM2: MOVEI AR1,NIL ;FILE TO BE RENAMED IS SPECIFIED BY NAMELIST ; OR NAMESTRING RENM2A: ;SPECIFIED BY A CLOSED FILE ARRAY IFN ITS,[ .CALL RENAM8 ;ORDINARY RENAME IOJRST 0,RENAM6 JRST RENM1A ] ;END OF IFN ITS IFN D10,[ MOVEI T,.IODMP ;TO RENAME A FILE, WE OPEN A DUMP MODE CHANNEL MOVE TT,-7(FXP) ;GET DEVICE NAME SETZ D, OPEN TMPC,T ;OPEN CHANNEL JRST RENAM4 MOVE T,-5(FXP) ;FILE NAME HLLZ TT,-4(FXP) ;EXTENSION SA$ CAMN TT,[SIXBIT \___\] SA$ SETZ TT, SETZ D, MOVE R,-6(FXP) ;PPN LOOKUP TMPC,T ;LOOK UP FILE IOJRST 0,RENAM5 MOVE T,-1(FXP) ;NEW FILE NAME HLLZ TT,(FXP) ;NEW EXTENSION SETZ D, MOVE R,-2(FXP) ;NEW PPN RENAME TMPC,T ;RENAME FILE IOJRST 0,RENAM5 RELEASE TMPC, JUMPE AR1,RENM1A JRST RENAM1 ] ;END OF IFN D10 IFN D20,[ MOVEI T,L.F6BT PUSH FXP,-2*L.F6BT+1(FXP) ;COPY OLD FILE NAMES TO TOP OF FXP SOJG T,.-1 PUSHJ P,6BTNSL ;STRING OUT INTO PNBUF PUSH P,A MOVSI 1,(GJ%OLD+GJ%ACC+GJ%SHT) MOVE 2,PNBP GTJFN ;GET A JFN FOR OLD FILE NAMES IOJRST 0,RENAM6 EXCH 1,(P) ;PUSH JFN, AND RESTORE ACC A JRST RENAM0 ; AND JOIN GENERAL RENAME ] ;END OF IFN D20 IFN ITS,[ RENAM7: SETZ SIXBIT \RENMWO\ ;RENAME WHILE OPEN ,,F.CHAN(TT) ;CHANNEL # ,,-1(FXP) ;NEW FILE NAME 1 400000,,(FXP) ;NEW FILE NAME 2 RENAM8: SETZ SIXBIT \RENAME\ ;RENAME ,,-7(FXP) ;DEVICE NAME ,,-5(FXP) ;OLD FILE NAME 1 ,,-4(FXP) ;OLD FILE NAME 2 ,,-6(FXP) ;SNAME ,,-1(FXP) ;NEW FILE NAME 1 400000,,(FXP) ;NEW FILE NAME 2 ] ;END OF IFN ITS IFN D20,[ RENAM4: MOVE 1,2 RLJFN JSP T,RLJLUZ RENAM5: JUMPE AR1,RNAM5A TLNE AR1,TTS.CL ;THE "CLOSED" BIT WAS TRANSFERRED JRST RNAM5A MOVEI 1,(T) HRLI 1,(CO%NRJ) CLOSF IOJRST 0,RNAM5A RNAM5A: MOVE 1,T RLJFN JSP T,RLJLUZ ] ;END OF IFN D20 IFN D10,[ RENAM4: SKIPA C,[NSDERR] RENAM5: RELEASE TMPC, ] ;END OF IFN D10 RENAM6: PUSHJ P,CZECHI RENAM9: PUSHJ P,6BTNML ;ERROR MESSAGE IS IN C PUSHJ P,NCONS PUSH P,A PUSHJ P,6BTNML POP P,B PUSHJ P,CONS MOVEI B,Q$RENAMEF XCIOL: PUSHJ P,XCONS ;XCONS, THEN IOL %IOL (C) 10$ NSDERR: SIXBIT \NO SUCH DEVICE!\ IFN ITS,[ RFNAME: SETZ SIXBIT \RFNAME\ ;READ FILE NAMES ,,F.CHAN(TT) ;CHANNEL # 2000,,F.RDEV(TT) ;DEVICE NAME 2000,,F.RFN1(TT) ;FILE NAME 1 2000,,F.RFN2(TT) ;FILE NAME 2 402000,,F.RSNM(TT) ;SNAME ] ;END OF IFN ITS CNAMEF: PUSHJ P,2MERGE ;LEAVES FIRST ARG IN AR1 JSP TT,XFILEP JRST CNAME1 MOVE TT,TTSAR(AR1) TLNN TT,TTS.CL ;FILE-ARRAY MUST BE CLOSED JRST CNAME2 ADDI TT,L.F6BT MOVEI F,L.F6BT ;COUNTER TO TRANSFER WORDS CNAME3: MOVE T,(FXP) MOVEM T,F.DEV-1(TT) 20$ POPI FXP,1 20% POP FXP,F.RDEV-1(TT) SUBI TT,1 SOJG F,CNAME3 POPI FXP,L.F6BT MOVEI A,(AR1) POPJ P, CNAME2: SKIPA C,[CNAER2] CNAME1: MOVEI C,CNAER1 CNAMER: PUSHJ P,6BTNML ;ERROR MESSAGE IS IN C PUSHJ P,NCONS PUSH P,A PUSHJ P,6BTNML POP P,B PUSHJ P,CONS MOVEI B,QCNAMEF PUSHJ P,XCONS ;XCONS, THEN IOL %IOL (C) CNAER1: SIXBIT/NOT FILE ARRAY!/ CNAER2: SIXBIT/FILE ARRAY NOT CLOSED!/ SUBTTL DELETEF FUNCTION ;;; (DELETEF X) DELETES THE FILE X. (THAT SOUNDS LOGICAL...) $DELETEF: ;SUBR 1 JSP TT,AFOSP ;SKIP IF FILE OR SFA JRST $DEL3 IFN SFA,[ JRST $DELNS ;A FILE, NOT AN SFA MOVEI B,Q$DELETE ;DELETE OPERATION SETZ C, ;NO OP SPECIFIC ARG JRST ISTCSH ;FAST INTERNAL SFA CALL $DELNS: ] ;END IFN SFA MOVE TT,TTSAR(A) TLNE TT,TTS.CL ;SKIP IF OPEN JRST $DEL3 HLLOS NOQUIT IFN ITS,[ .CALL $DEL6 ;USE DELEWO FOR AN OPEN FILE IOJRST 0,$DEL9A PUSHJ P,JCLOSE MOVE T,F.CHAN(TT) ;CHANNEL INTO T FOR CLOSE9 .CALL CLOSE9 ;ACTUALLY PERFORM THE CLOSE .LOSE 1400 ] ;END OF IFN ITS IFN D10,[ MOVE F,F.CHAN(TT) MOVE R,F.RPPN(TT) LSH F,27 IOR F,[RENAME 0,T] SETZB T,TT XCT F IOJRST 0,$DEL9A PUSHJ P,JCLOSE XOR F,[#] XCT F ;40 BIT MEANS AVOID SUPERSEDING A FILE XOR F,[#] XCT F ] ;END OF IFN D10 IFN D20,[ HRRZ 1,F.JFN(TT) HRLI 1,(CO%NRJ) ;DON'T RELEASE JFN PUSHJ P,JCLOSE CLOSF IOJRST 0,$DEL9A TLZ 1,-1 DELF IOJRST 0,$DEL9A ] ;END OF IFN D20 JRST CZECHI IFN ITS,[ $DEL6: SETZ SIXBIT \DELEWO\ ;DELETE WHILE OPEN 400000,,F.CHAN(TT) ;CHANNEL # ] ;END OF IFN ITS $DEL3: PUSHJ P,FIL6BT PUSHJ P,DMRGF ;MERGE ARG WITH DEFAULTS IFN ITS,[ .CALL $DEL7 IOJRST 0,$DEL9 ] ;END OF IFN ITS IFN D10,[ MOVEI T,.IODMP MOVE TT,-3(FXP) ;GET DEVICE NAME SETZ D, OPEN TMPC,T ;OPEN TEMP DUMP MODE CHANNEL JRST $DEL4 MOVE T,-1(FXP) ;FILE NAME HLLZ TT,(FXP) ;EXTENSION SA$ CAMN TT,[SIXBIT \___\] SA$ SETZ TT, SETZ D, MOVE R,-2(FXP) ;PPN LOOKUP TMPC,T IOJRST 0,$DEL5 SETZB T,TT ;ZERO FILE NAMES MEANS DELETE MOVE R,-2(FXP) ;MUST SPECIFY CORRECT PPN RENAME TMPC,T ;DELETE THE FILE IOJRST 0,$DEL5 RELEASE TMPC, ;RELEASE TEMP CHANNEL ] ;END OF IFN D10 IFN D20,[ PUSHJ P,X6BTNSL ;GET NAMESTRING FOR FILE IN PNBUF MOVE 1,[GJ%OLD+GJ%ACC+GJ%SHT+.GJLEG] MOVE 2,PNBP GTJFN ;GET A JFN FOR THE FILE IOJRST 0,$DEL9 TLZ 1,-1 DELF ;DELETE IT IOJRST 0,$DEL5 ] ;END OF IFN D20 JRST 6BTNML IFN ITS,[ $DEL7: SETZ SIXBIT \DELETE\ ;DELETE FILE ,,-3(FXP) ;DEVICE NAME ,,-1(FXP) ;FILE NAME 1 ,,0(FXP) ;FILE NAME 2 400000,,-2(FXP) ;SNAME ] ;END OF IFN ITS IFN D20,[ $DEL5: RLJFN ;RELEASE THE TEMP JFN JSP T,RLJLUZ ] ;END OF IFN D20 IFN D10,[ $DEL4: SKIPA C,[NSDERR] $DEL5: RELEASE TMPC, ;RELEASE THE TEMP CHANNEL ] ;END OF IFN D10 $DEL9: PUSHJ P,6BTNML $DEL9A: PUSHJ P,CZECHI PUSHJ P,ACONS MOVEI B,Q$DELETEF JRST XCIOL SUBTTL CLOSE FUNCTION ;;; (CLOSE X) CLOSES THE FILE ARRAY X. THE ARRAY ITSELF ;;; IS *NOT* FLUSHED - MAY WANT TO RE-OPEN IT. CLOSE0: SFA% WTA [NOT FILE - CLOSE!] SFA$ WTA [NOT FILE OR SFA - CLOSE!] $CLOSE: JSP TT,AFOSP ;LEAVES OBJECT IN A JRST CLOSE0 ;NOT A FILE IFN SFA,[ JRST ICLOSE ;A FILE-ARRAY, DO INTERNAL STUFF MOVEI B,Q$CLOSE ;CLOSE OPERATION SETZ C, ;NO THIRD ARG JRST ISTCSH ;SHORT INTERNAL SFA CALL ] ;END IFN SFA ICLOSE: HLLOS NOQUIT MOVE TT,TTSAR(A) TLNE TT,TTS.CL JRST ICLOS6 PUSHJ P,JCLOSE IFN ITS,[ .CALL CLOSE9 ;CLOSE FILE .LOSE 1400 ] ;END OF IFN ITS IFN D10,[ LSH T,27 SA$ IOR T,[CLOSE 0,0] SA$ XCT T SA$ XOR T,[#] SA% IOR T,[RELEASE 0,0] XCT T ] ;END OF IFN D10 IFN D20,[ HRRZ 1,F.JFN(TT) CLOSF ;DOES AN IMPLICIT RLJFN JFCL ] ;END OF IFN D20 SKIPA A,[TRUTH] ;RETURN T IF DID SOMETHING, ELSE NIL ICLOS6: MOVEI A,NIL JRST CZECHI CLOSE9: SETZ SIXBIT \CLOSE\ ;CLOSE CHANNEL 401000,,(T) ;CHANNEL # ;;; FILE PRE-CLOSE CLEANUP - RETURNS CHANNEL IN T, TTSAR IN TT JCLOSE: MOVE TT,TTSAR(A) TLNE TT,TTS.CL ;SKIP UNLESS ALREADY CLOSED .LOSE TLNE TT,TTS.IO ;SKIP UNLESS OUTPUT FILE ARRAY PUSHJ P,IFORCE ;FORCE OUTPUT BUFFER MOVE TT,TTSAR(A) TLNE TT,TTS.TY SKIPN T,FT.CNS(TT) JRST CLOSE4 SETZM FT.CNS(TT) ;UNLINK TWO TTY'S WHICH MOVE T,TTSAR(T) ; WERE TTYCONS'D TOGETHER SETZM FT.CNS(T) ; IF ONE IS CLOSED CLOSE4: HRRZ T,F.CHAN(TT) MOVSI D,TTS.CL ;TURN ON "FILE CLOSED" IORM D,TTSAR(A) ; BIT IN ARRAY SAR SETZM CHNTB(T) ;CLEAR CHANNEL TABLE ENTRY POPJ P, SUBTTL FORCE-OUTPUT ;;; (FORCE-OUTPUT X) FORCES THE OUTPUT BUFFER OF OUTPUT FILE ARRAY X. FORCE: IFN SFA,[ EXCH AR1,A JSP TT,XFOSP ;AN SFA? JRST FORSF1 JRST FORSF1 EXCH AR1,A JSP T,QIOSAV MOVEI B,QFORCE SETZ C, JRST ISTCSH FORSF1: EXCH AR1,A ] ;END IFN SFA PUSH P,AR1 MOVEI AR1,(A) PUSHJ P,FORCE1 POP P,AR1 POPJ P, FORCE1: PUSHJ P,OFILOK ;DOES A LOCKI PUSHJ P,IFORCE IFN ITS,[ .CALL FORCE9 CAIN D,%EBDDV ;"WRONG TYPE DEVICE" ERROR IS OKAY CAIA .VALUE ;ANY OTHER ERROR LOSES ] ;END OF IFN ITS JRST UNLKTRUE IFN ITS,[ FORCE9: SETZ SIXBIT \FORCE\ ;FORCE OUTPUT BUFFER TO DEVICE ,,F.CHAN(TT) ;CHANNEL # 403000,,D ;ERROR # ] ;END OF IFN ITS ;;; INTERNAL OUTPUT BUFFER FORCE ROUTINE. EXPECTS USER ;;; INTERRUPTS OFF, AND FILE ARRAY TTSAR IN TT. ;;; CLOBBERS T, TT, D, AND F. IFORCE: TLNE TT,TTS.CL LERR [SIXBIT \CAN'T FORCE OUTPUT ON CLOSED FILE!\] SKIPGE F,F.MODE(TT) .SEE FBT.CM ;CAN'T FORCE A CHARMODE FILE POPJ P, MOVE F,FB.BFL(TT) IFN ITS,[ SUB F,FB.CNT(TT) JUMPE F,IFORC1 MOVE D,F ;NUMBER OF BYTES TO TRANSFER MOVE T,FB.IBP(TT) ;INITIAL BYTE POINTER .CALL SIOT ;OUTPUT THE (PARTIAL) BUFFER .LOSE 1400 IFORC1: ] ;END OF IFN ITS IFN D10,[ MOVE T,F.CHAN(TT) LSH T,27 IOR T,[OUT 0,0] XCT T ;OUTPUT THE CURRENT BUFFER CAIA HALT ;? OUTPUT ERROR ] ;END OF IFN D10 IFN D20,[ SUB F,FB.CNT(TT) JUMPE F,FORCE5 PUSHJ FXP,SAV3 ;PRESERVE ACS 1-3 MOVE 1,F.JFN(TT) MOVE 2,FB.IBP(TT) ;INITIAL BYTE POINTER MOVN 3,F ;NEGATIVE OF BYTE COUNT SOUT ;OUTPUT (PARTIAL) BUFFER ERJMP OIOERR PUSHJ FXP,RST3 ] ;END OF IFN D20 ADDM F,F.FPOS(TT) ;UPDATE FILE POSITION IFN ITS+D20, FORCE5: JSP D,FORCE6 ;INITIALIZE POINTER AND COUNT POPJ P, IFN ITS+D20,[ FORCE6: MOVE T,FB.BFL(TT) ;ROUTINE TO INITIALIZE BYTE POINTER AND COUNT MOVEM T,FB.CNT(TT) MOVE T,FB.IBP(TT) MOVEM T,FB.BP(TT) JRST (D) ];END IFN ITS+D20 IFN ITS,[ IOTTTT: SETZ SIXBIT \IOT\ ;I/O TRANSFER ,,F.CHAN(TT) ;CHANNEL # 400000,,T ;DATA POINTER (DATA?) SIOT: SETZ SIXBIT \SIOT\ ;STRING I/O TRANSFER ,,F.CHAN(TT) ;CHANNEL # ,,T ;BYTE POINTER 400000,,D ;BYTE COUNT ] ;END OF IFN ITS SUBTTL STATUS FILEMODE ;;; (STATUS FILEMODE ) RETURNS A LIST DESCRIBING ;;; THE FILE: NIL ==> FILE HAS BEEN CLOSED; OTHERWISE ;;; THE CAR OF THIS LIST IS A VALID OPTIONS ;;; LIST FOR THE OPEN FUNCTION. THE CDR OF THIS LIST ;;; CONTAINS INFORMATIVE ITEMS WHICH ARE NOT NECESSARILY ;;; USER-SETTABLE FEATURES ABOUT THE FILE. ;;; PRESENTLY SUCH GOODIES INCLUDE: ;;; RUBOUT AN OUTPUT TTY THAT CAN SELECTIVELY ERASE ;;; CURSORPOS AN OUTPUT TTY THAT CAN CURSORPOS WELL ;;; SAIL FOR AN OUTPUT TTY, HAS SAIL CHARACTER SET ;;; FILEPOS CAN FILEPOS CORRECTLY (RANDOM ACCESS) ;;; NON-FILE ARGUMENT CAUSES AN ERROR. SFMD0: %WTA NFILE SFILEMODE: JSP TT,AFOSP ;MUST BE A FILE OR SFA JRST SFMD0 IFN SFA,[ JRST SFMD0A ;IF FILE THEN HANDLE NORMALLY SETZ C, ;IF WE GO TO THE SFA, NO THIRD ARG MOVEI T,SO.MOD ;CAN THE SFA DO (STATUS FILEMODE)? MOVEI TT,SR.WOM TDNE T,@TTSAR(A) ;CAN IT DO THE OPERATION? JRST ISTCAL ;YES, CALL THE SFA AND RETURN MOVEI B,QWOP ;OTHERWISE, DO A WHICH-OPERATIONS PUSHJ P,ISTCSH PUSH P,A ;SAVE THE RESULTS MOVEI A,QSFA JSP T,%NCONS ;MAKE A LIST POP P,B JRST CONS ;RETURN ((SFA) {WHICH-OPERATIONS}) SFMD0A: ] ;END IFN SFA LOCKI MOVE TT,TTSAR(A) ;GET TTSAR BITS TLNE TT,TTS.CL ;RETURN NIL IF THE FILE IS CLOSED JRST UNLKFALSE MOVE R,F.FLEN(TT) ;IF LENGTH > 0 THEN BLOCK MODE, ELSE SINGLE MOVEI A,QBLOCK SKIPGE F,F.MODE(TT) .SEE FBT.CM MOVEI A,QSINGLE UNLOCKI PUSHJ P,NCONS MOVEI B,QDSK ;TWO MAJOR TYPES - TTY OR DSK TLNE TT,TTS.TY MOVEI B,QTTY PUSHJ P,XCONS MOVEI B,Q$ASCII ;ASCII, IMAGE, OR FIXNUM TLNE TT,TTS.IM MOVEI B,QIMAGE TLNN TT,TTS.IO TLNN TT,TTS.TY JRST SFMD1 TLNN F,FBT.FU ;INPUT TTY: FULL CHAR SET MEANS FIXNUM FILE SFMD1: TLNE TT,TTS MOVEI B,QFIXNUM PUSHJ P,XCONS MOVEI B,Q$IN ;INPUT, OUTPUT, OR APPEND MODE TLNE TT,TTS MOVEI B,Q$OUT TLNE F,FBT MOVEI B,QAPPEND PUSHJ P,XCONS MOVEI B,QECHO ;OTHER RANDOM MODE BITS - ECHO TLNE F,FBT.EC PUSHJ P,XCONS MOVEI B,QSCROLL ;SCROLL TLNE F,FBT.SC PUSHJ P,XCONS MOVEI C,(A) SETZ A, MOVEI B,QSAIL TLNE F,FBT.SA ;SAIL MODE PUSHJ P,XCONS MOVEI B,QRUBOUT TLNE F,FBT.SE ;RUBOUT-ABLE PUSHJ P,XCONS IFN USELESS*ITS,[ MOVEI B,QCURSORPOS ;CURSORPOS-ABLE TLNE F,FBT.CP PUSHJ P,XCONS ] ;END OF IFN USELESS*ITS MOVEI B,QFILEPOS ;FILEPOS-ABLE SKIPL R .SEE F.FLEN ;NEGATIVE => CAN'T FILEPOS PUSHJ P,XCONS MOVEI B,(C) JRST XCONS SUBTTL LOAD FUNCTION ;;; (LOAD FOO) LOADS THE FILE FOO. IT FIRST PROBEF'S TO ;;; ASCERTAIN THE EXISTENCE OF THE FILE, AND CHECKS THE FIRST ;;; WORD TO SEE WHETHER IT IS AN ASCII OR FASL FILE. ;;; IF NO SECOND FILE NAME IS GIVEN, "FASL" IS TRIED FIRST, ;;; AND THEN ">" IF NO FASL FILE EXISTS. ;;; IF A FASL FILE, IT GIVES THE FILE NAMES TO FASLOAD. ;;; IF AN ASCII FILE, IT IS OPENED, (INFILE ^Q, *, +, -, INSTACK) ;;; BOUND TO (, T, *, +, -, NIL), AND A READ-EVAL ;;; LOOP PERFORMED UNTIL END OF FILE OCCURS LEAVING INSTACK=NIL ;;; AND INFILE=T. LOAD: JUMPE A,CPOPJ ;IF GIVEN NIL AS ARG, RETURN NIL PUSHJ P,FIL6BT ;SUBR 1 MOVE F,-L.6EXT-L.6VRS+1(FXP) PUSHJ P,DMRGF ;DMRGF SAVES F LOCKI CAME F,DFNWD JUMPN F,LOAD3 MOVE TT,DFFNWD MOVEM TT,<-L.6EXT-L.6VRS+1>-1(FXP) ;-1 for LOCKI word IFN D20,[ MOVE TT,[ASCII \0\] SKIPE <-L.6VRS+1>-1(FXP) ;VERSION NUMBER NULL? CAMN T,<-L.6VRS+1>-1(FXP) ; OR EQUAL TO *? IF EITHER CASE, MOVEM TT,<-L.6VRS+1>-1(FXP) ; THEN USE "0" ] ;END OF IFN D20 JSP T,FASLP1 JRST LOAD1 ;FILE NOT FOUND JRST LOAD2 ;FASL FILE LOAD5: UNLOCKI ;EXPR FILE FOUND PUSHJ P,6BTNML PUSH P,[LOAD6] PUSH P,A MOVNI T,1 JRST $EOPEN ;OPEN AS A FILE OBJECT LOAD6: HRRZ B,VIPLUS ;WE WANT +, -, * TO WORK AS FOR TOP LEVEL, HRRZ C,V. ; BUT NOT SCREW THE OUTSIDE WORLD HRRZ AR1,VIDIFFERENCE MOVEI AR2A,TRUTH JSP T,SPECBIND 0 A,VINFILE 0 B,VIPLUS 0 C,V. 0 AR1,VIDIFFERENCE 0 AR2A,TAPRED VINSTACK JRST LOAD7A LOAD7: PUSHJ P,TLEVAL ;USE THE EVAL PART OF THE TOP LEVEL HRRZM A,V. LOAD7A: PUSHJ P,TLREAD ;USE THE READ PART OF THE TOP LEVEL JRST LOAD7 LOAD8: HRRZ B,VINFILE ;EOF TESTING SKIPN VINSTACK CAIE B,TRUTH JRST LOAD7A PUSHJ P,UNBIND JRST TRUE LOAD1: IFN ITS+D10,[ IT$ MOVSI TT,(SIXBIT \>\) ;OTHERWISE TRY ">" SA$ MOVSI TT,(SIXBIT \___\) SA% 10$ MOVSI TT,(SIXBIT \LSP\) ;FOR D10, "LSP" MOVEM TT,-1(FXP) ;REMEMBER ADJUSTMENT FOR LOCKI WORD ] ;END OF IFN ITS+D10 IFN D20,[ MOVE TT,[ASCIZ \LSP\] ZZ==<-L.6EXT-L.6VRS+1>-1 ;REMEMBER: ADJUSTMENT FOR LOCKI WORD MOVEM TT,ZZ(FXP) SETZM ZZ+1(FXP) MOVEI T,ZZ+2(FXP) HRLI T,-1(T) BLT T,ZZ+L.6EXT-1(FXP) ;ZERO OUT REMAINING WORDS ] ;END OF IFN D20 LOAD3: MOVEI A,QLOAD JSP T,FASLP1 JRST LOAD4 ;LOSE COMPLETELY JRST LOAD2 ;FASL FILE JRST LOAD5 ;EXPR CODE LOAD2: UNLOCKI ;FASL FILE - GO FASLOAD IT PUSHJ P,6BTNML HRRZ B,VDEFAULTF JSP T,SPECBIND 0 B,VDEFAULTF ;DON'T LET FASLOAD CLOBBER DEFAULTF PUSHJ P,FASLOAD JRST UNBIND LOAD4: IOJRST 0,.+1 PUSH P,A UNLOCKI PUSHJ P,6BTNML ;LOSEY LOSEY PUSHJ P,NCONS POP P,B JRST XCIOL ;;; (FASLP ) TELLS WHETHER THE FILE IS A FASL FILE. ;;; ERROR IF FILE DOES NOT EXIST. $FASLP: PUSHJ P,FIL6BT PUSHJ P,DMRGF MOVEI A,Q$FASLP LOCKI JSP T,FASLP1 JRST LOAD4 SKIPA A,[TRUTH] MOVEI A,NIL UNLOCKI POPI FXP,L.F6BT ;POP CRUD OFF STACK POPJ P, ;;; ROUTINE TO TEST A FILE FOR FASL-NESS. ;;; WARNING! MUST SAVE "A" - SEE "LOAD:", "LOAD3:" AND "$FASLP:" ;;; JSP T,FASLP1 ;;; JRST NOTFOUND ;FILE NOT FOUND, OR OTHER ERROR ;;; JRST FASL ;FILE IS A FASL FILE ;;; ... ;FILE IS NOT A FASL FILE ;;; FXP MUST HOLD THE "SIXBIT" FILE NAMES, WITH A LOCKI WORD ABOVE THEM. ;;; USER INTERRUPTS MUST BE LOCKED OUT. FASLP1: IFN ITS,[ .CALL FASLP9 ;OPEN FILE ON TEMP CHANNEL JRST (T) .CALL FASLP8 ;RESTORE REFERENCE DATE JFCL ; (ONLY WORKS FOR DISK CHANNELS - IGNORE FAILURE) HRROI D,TT .IOT TMPC,D ;READ FIRST WORD .CLOSE TMPC, JUMPL D,2(T) ;NOT A FASL FILE IF ZERO-LENGTH TRZ TT,1 CAMN TT,[SIXBIT \*FASL*\] JRST 1(T) ;FASL FILE IF FIRST WORD CHECKS JRST 2(T) FASLP8: SETZ SIXBIT \RESRDT\ ;RESTORE REFERENCE DATE 401000,,TMPC ;CHANNEL # FASLP9: SETZ SIXBIT \OPEN\ ;OPEN FILE 5000,,6 ;IMAGE BLOCK INPUT 1000,,TMPC ;CHANNEL NUMBER ,,-4(FXP) ;DEVICE NAME ,,-2(FXP) ;FILE NAME 1 ,,-1(FXP) ;FILE NAME 2 400000,,-3(FXP) ;SNAME ] ;END OF IFN ITS IFN D10,[ PUSH P,T MOVEI T,.IODMP MOVE TT,-4(FXP) SETZ D, OPEN TMPC,T ;OPEN TEMP CHANNEL TO FILE POPJ P, MOVE T,-2(FXP) ;FILE NAME HLLZ TT,-1(FXP) ;EXTENSION SA$ CAMN TT,[SIXBIT \___\] SA$ SETZ TT, SETZ D, MOVE R,-3(FXP) ;PPN LOOKUP TMPC,T ;LOOK UP FILE NAMES JRST FASLP2 SETZB TT,R PUSH FXP,NIL ;USE A WORD ON FXP AS D10 CAN'T DO I/O TO AC'S HRROI D,-1(FXP) ;D AND R ARE THE DUMP MODE COMMAND LIST INPUT TMPC,D ;GET FIRST WORD OF FILE SA% CLOSE TMPC,CL.ACS ;DON'T UPDATE ACCESS DATE RELEASE TMPC, POP FXP,TT ;GET THE WORD READ FROM THE FILE POP P,R SA$ WARN [RESTORE REF DATE FOR SAIL PROBEF?] ;FALLS THROUGH ] ;END OF IFN D10 IFN D20,[ PUSH FLP,(FXP) ;SAVE THE LOCKI WORD, BUT OFF FXP POPI FXP,1 PUSH P,T PUSHJ P,X6BTNS ;GET NAMESTRING IN PNBUF PUSH FXP,(FLP) ;PUT LOCKI WORD BACK IN ITS PLACE POPI FLP,1 POP P,R PUSH P,A PUSH P,B MOVSI 1,(GJ%OLD+GJ%ACC+GJ%SHT) .SEE .GJDEF MOVE 2,PNBP GTJFN ;GET A JFN FOR THE FILE NAME JRST RSTR2 ;JUST EXITS THRU R, RESTORING A AND B MOVE 2,[440000,,OF%RD+OF%PDT] .SEE OF%BSZ OF%MOD SETZ TT, OPENF ;OPEN FILE, PRESERVING ACCESS DATE JRST FASLP2 BIN ;GET ONE 36.-BIT BYTE MOVE TT,2 CLOSF ;CLOSE THE FILE JFCL ;IGNORE ERROR RETURN SKIPA ;JFN HAS BEEN RELEASED BY THE CLOSE FASLP2: RLJFN ;RELEASE THE JFN JFCL POP P,B POP P,A ] ;END OF IFN D20 IFN D10+D20,[ TRZ TT,1 CAMN TT,[SIXBIT \*FASL*\] JRST 1(R) ;FASL FILE IF FIRST WORD CHECKS JRST 2(R) ] ;END OF IFN D10+D20 IFN D10,[ FASLP2: RELEASE TMPC, POPJ P, ] ;;; (DEFUN INCLUDE FEXPR (X) ;;; ((LAMBDA (F) ;;; (EOFFN F '+INTERNAL-INCLUDE-EOFFN) ;;; (INPUSH F)) ;;; (OPEN (CAR X)))) INCLUDE: HLRZ A,(A) ;FSUBR .INCLUD: ;SUBR PUSH P,[INCLU1] PUSH P,A MOVNI T,1 JRST $EOPEN INCLU1: MOVEI TT,FI.EOF MOVEI B,QINCEOF MOVEM B,@TTSAR(A) JRST INPUSH INCEOF==:FALSE ;INCLUDE'S EOF FUNCTION - SUBR 2 SUBTTL OPEN FUNCTION (INCLUDING SAIL EOPEN) ;;; (OPEN ) OPENS A FILE AND RETURNS A ;;; CORRESPONDING FILE OBJECT. IT IS ACTUALLY AN LSUBR ;;; OF ZERO TO TWO ARGUMENTS. THE DEFAULTS TO THE ;;; CURRENT DEFAULT FILE NAMES. THE DEFAULTS ;;; TO NIL. ;;; IF IS A NAMELIST OR NAMESTRING, A NEW FILE ARRAY ;;; IS CREATED. IF IS A FILE ARRAY ALREADY, IT IS ;;; CLOSED AND RE-OPENED IN THE SPECIFIED MODE; ITS FORMER ;;; MODES SERVE AS THE DEFAULTS FOR THE . ;;; THE DETERMINES A LARGE NUMBER OF ATTRIBUTES ;;; FOR OPENING THE FILE. FOR EACH ATTRIBUTE THERE ARE ;;; TWO OR MORE MUTUALLY EXCLUSIVE VALUES WHICH MAY BE ;;; SPECIFIED AS FOLLOWS. VALUES MARKED BY A * ARE THOSE ;;; USED AS DEFAULTS WHEN THE IS A NAMELIST OR ;;; NAMESTRING. IF THE IS AN ATOM, IT IS THE ;;; SAME AS SPECIFYING THE LIST OF THAT ONE ATOM. ;;; DIRECTION: ;;; * IN INPUT FILE ;;; * READ SAME AS "IN" ;;; OUT OUTPUT FILE ;;; PRINT SAME AS "OUT" ;;; APPEND OUTPUT, APPENDED TO EXISTING FILE ;;; DATA MODE: ;;; * ASCII FILE IS A STREAM OF ASCII CHARACTERS. ;;; SYSTEM-DEPENDENT TRANSFORMATIONS MAY ;;; OCCUR, SUCH AS SUPPLYING LF AFTER CR, ;;; OR BEING CAREFUL WITH OUTPUT OF ^P, ;;; OR MULTICS ESCAPE CONVENTIONS. ;;; FIXNUM FILE IS A STREAM OF FIXNUMS. THIS ;;; IS FOR DEALING WITH FILES THOUGHT OF ;;; AS "BINARY" RATHER THAN "CHARACTER". ;;; FOR TTY'S, THIS IS INTERPRETED AS ;;; "MORE-THAN-ASCII" OR "FULL CHARACTER ;;; SET" MODE, WHICH READS 9 BITS AT SAIL ;;; AND 12. ON ITS. ;;; IMAGE FILE IS A STREAM OF ASCII CHARACTERS. ;;; ABSOLUTELY NO TRANSFORMATIONS ARE MADE. ;;; DEVICE TYPE: ;;; * DSK STANDARD KIND OF FILE. ;;; CLA (ITS ONLY) LIKE DSK, BUT REQUIRES BLOCK MODE, ;;; AND GOBBLES THE FIRST TWO WORDS, INSTALLING ;;; THEM IN THE TRUENAME. USEFUL PRIMARILY FOR ;;; A CLI-MESSAGE INTERRUPT FUNCTION. ;;; TTY CONSOLE. IN PARTICULAR, ONLY TTY INPUT ;;; FILES HAVE INTERRUPT CHARACTER FUNCTIONS ;;; ASSOCIATED WITH THEM. ;;; BUFFERING MODE: ;;; * BLOCK DATA IS BUFFERED. ;;; SINGLE DATA IS UNBUFFERED. ;;; PRINTING AREA: ;;; ECHO (ITS ONLY) OPEN TTY IN ECHO AREA ;;; SOME OF THESE VALUES ARE OF COURSE SYSTEM-DEPENDENT. ;;; YOUR LOCAL LISP SYSTEM WILL ATTEMPT TO DO THE RIGHT THING, ;;; HOWEVER, IN ANY CASE. ;;; IF THE OPTIONS LIST IS INVALID IN ANY WAY, OPEN MAY EITHER ;;; GIVE A WRNG-TYPE-ARGS ERROR, OR BLITHELY ASSUME A CORRECTED ;;; VALUE FOR AN ATTRIBUTE. IN GENERAL, ERRORS SHOULD OCCUR ;;; ONLY FOR TRULY CONFLICTING SPECIFICATIONS. ON THE OTHER ;;; HAND, SPECIFYING BLOCK MODE FOR A DEVICE THAT THE SYSTEM ;;; WANTS TO HANDLE ONLY IN CHARACTER MODE WILL JUST GO AHEAD ;;; AND USE CHARACTER MODE. IN GENERAL, ONE SHOULD USE ;;; (STATUS FILEMODE) TO SEE HOW THE FILE WAS ACTUALLY OPENED. SA% $EOPEN: $OPEN: MOVEI D,Q$OPEN ;LSUBR (0 . 2) CAMGE T,XC-2 JRST WNALOSE SETZB A,B ;BOTH ARGUMENTS DEFAULT TO NIL CAMN T,XC-2 POP P,B SKIPE T POP P,A IFN SFA,[ JSP TT,AFOSP ;WERE WE HANDED AN SFA AS FIRST ARG? JFCL JRST $OPNNS ;NOPE, CONTINUE AS USUAL MOVEI C,(B) ;ARG TO SFA IS THE LIST GIVEN TO OPEN MOVEI B,Q$OPEN ;OPERATION JRST ISTCSH ;SHORT INTERNAL CALL $OPNNS: ] ;END IFN SFA ;THE TWO ARGUMENTS ARE NOW IN A AND B. ;WE NOW PARSE THE OPTIONS LIST. F WILL HOLD OPTION VALUES, ; AND D WILL INDICATE WHICH WERE SPECIFIED EXPLICITLY BY THE USER. OPEN0J: PUSH P,T ;SAVE NUMBER OF ARGS ON P (NOT FXP!) SETZB D,F JSP TT,AFILEP ;IS THE FIRST ARGUMENT A FILE OBJECT? JRST OPEN1A MOVEI TT,F.MODE MOVE F,@TTSAR(A) ;IF SO, USE ITS MODE AS THE DEFAULTS IT$ SKIPE B ;MAKE CHUCK RICH HAPPY - DON'T LET "ECHO" CARRY IT$ TLZ F,FBT.EC+FBT.CP+FBT.SC ; OVER IF A NON-NULL OPTIONS LIST WAS GIVEN OPEN1A: JUMPE B,OPEN1Y ;JUMP OUT IF NO OPTIONS SUPPLIED MOVEI C,(B) MOVEI TT,(B) LSH TT,-SEGLOG SKIPG ST(TT) JRST OPEN1C MOVSI AR2A,(B) ;IF A SINGLE, ATOMIC OPTION WAS GIVEN, AR2A MOVEI C,AR2A ; IS A FAKE CONS CELL SO IT LOOKS LIKE A LIST OPEN1C: JUMPE C,OPEN1L ;JUMP OUT IF LAST OPTION PROCESSED HLRZ AR1,(C) OPN1F1: JUMPE AR1,OPEN1G ;IGNORE NIL AS A KEYWORD MOVSI TT,-LOPMDS OPEN1F: HRRZ R,OPMDS(TT) ;COMPARE GIVEN OPTION AGAINST VALID ONES CAIN AR1,(R) JRST OPEN1K ;JUMP ON MATCH AOBJN TT,OPEN1F EXCH A,AR1 ;ERRONEOUS KEYWORD INTO AR1 WTA [IS ILLEGAL KEYWORD - OPEN!] EXCH A,AR1 OPEN1G: HRRZ C,(C) ;CDR DOWN LIST UNTIL ALL DONE JRST OPEN1C OPEN1K: TDNN D,OPMDS(TT) ;SEE IF THERE IS A CONFLICT JRST OPEN1Z OPEN1H: EXCH A,B WTA [ILLEGAL OPTIONS LIST - OPEN!] EXCH A,B JRST OPEN0J OPEN1Z: HLRZ R,OPMDS(TT) TLO D,(R) TLZ F,(R) TRZ F,(R) IOR F,OPBITS(TT) JRST OPEN1G ;;; LEFT HALF IS SET OF MODE BITS WHICH THE OPTION IN THE RIGHT ;;; HALF WILL CONFLICT WITH IF ANY ONE ELSE SELECTS THEM. OPMDS: FBT.AP+1,,Q$IN FBT.AP+1,,QOREAD FBT.AP+1,,Q$OUT FBT.AP+1,,Q%PRINT FBT.AP+1,,QAPPEND 000014,,Q$ASCII 000014,,QFIXNUM 000014,,QIMAGE 000002,,QDSK IT$ FBT.CA+2,,QCLA 000002,,QTTY FBT.CM,,QBLOCK FBT.CM,,QSINGLE 0,,QNODEFAULT IT$ FBT.EC,,QECHO IT$ FBT.SC,,QSCROLL LOPMDS==.-OPMDS ;;; MODE BITS ACTUALLY TO BE SET FOR AN OPTION IN THE OPMDS TABLE. OPBITS: 0 ;IN 0 ;READ 1 ;OUT 1 ;PRINT FBT.AP,,1 ;APPEND 0 ;ASCII 4 ;FIXNUM 10 ;IMAGE 0 ;DSK IT$ FBT.CA,,0 ;CLA 2 ;TTY 0 ;BLOCK FBT.CM,, ;SINGLE FBT.ND,, ;NODEFAULT IT$ FBT.EC,, ;ECHO IT$ FBT.SC,, ;SCROLL TBLCHK OPBITS,LOPMDS ;STATE OF THE WORLD: ; FIRST ARG TO OPEN IN A ; SECOND ARG IN B ; D CONTAINS BITS FOR ACTUALLY SPECIFIED OPTIONS IN LEFT HALF ; F CONTAINS BITS FOR OPTIONS .SEE FBT.CM ;AND FRIENDS ; 1.4-1.3 0 => ASCII, 1 => FIXNUM, 2 => IMAGE ; 1.2 0 => DSK, 1 => TTY ; 1.1 0 => IN, 1 => OUT ; BITS 1.4-1.1 ARE USED TO INDEX VARIOUS TABLES LATER ; ACTUAL NUMBER OF ARGS ON P ;WE NOW EMBARK ON DEFAULTING AND MAKING CONSISTENT THE VARIOUS MODES OPEN1L: TLNE D,FBT.CM ;SKIP IF SINGLE VS. BLOCK WAS UNSPECIFIED JRST OPEN1Y TRNE F,2 ;SKIP UNLESS TTY TLO F,FBT.CM ;FOR TTY, DEFAULT TO SINGLE, NOT BLOCK, MODE OPEN1Y: IT$ TRC F,3 IT$ TRCE F,3 IT$ TLZ F,FBT.EC+FBT.SC ;ECHO AND SCROLL MEANINGFUL ONLY FOR TTY OUTPUT TRNN F,2 ;SKIP IF TTY JRST OPEN1S TLZ F,FBT.AP ;CAN'T APPEND TO A TTY TRNN F,1 TLO F,FBT.CM ;CAN'T DO BLOCK TTY INPUT TRNE F,4 ;FIXNUM TTY I/O USES FULL CHAR SET TLO F,FBT.FU ;NOW WORRY ABOUT FILE NAMES AND ALLOCATING A FILE OBJECT OPEN1S: PUSH P,A PUSH P,B PUSH FXP,F CAIE A,TRUTH ;T MEANS TTY FILE ARRAY... JRST OPEN1M TRNN F,1 SKIPA A,V%TYI ;TTY INPUT IF MODE BITS SAY INPUT HRRZ A,V%TYO ; AND OUTPUT OTHERWISE OPEN1M: PUSH P,A PUSHJ P,FIL6BT ;GET FILE NAME SPECS MOVE F,-L.F6BT(FXP) ;GET MODE BITS TLZN F,FBT.ND ;MERGE WITH DEFAULT NAMES? PUSHJ P,DMRGF ;MERGE IN DEFAULT NAMES (SAVES F) HRLZI F,FBT.ND ANDCAM F,-L.F6BT(FXP) ;TURN OFF FBT.ND BIT IN SAVED FLAGS MOVE A,(P) ;GET (POSSIBLY MUNGED FOR T) FIRST ARG JSP TT,AFILEP ;SKIP IF WE GOT A REAL LIVE SAR JRST OPEN1N PUSHJ P,ICLOSE ;CLOSE IT IF NECESSARY ;;; WARN [SHOULD WE RELEASE THE JFN AT THIS POINT?] MOVE A,(P) MOVE D,-3(P) ;IF ONLY ONE ARG TO OPEN, AND AOJE D,OPEN1Q ; THAT A SAR, RE-USE THE ARRAY MOVE F,-L.F6BT(FXP) MOVEI TT,F.MODE XOR F,@TTSAR(A) TDNE F,[FBT.CM,,17] JRST OPEN1P PUSHJ P,OPNCLR ;IF TWO ARGS, BUT SAME MODE, JRST OPEN1Q ; CLEAR ARRAY, THAN RE-USE ;WE MUST ALLOCATE A FRESH ARRAY OPEN1N: MOVSI A,-1 ;ARRANGE TO GET A FRESH SAR ;WE HAVE A SAR, BUT MUST ALLOCATE A NEW ARRAY BODY OPEN1P: MOVE F,-L.F6BT(FXP) ;GET MODE BITS AGAIN ;DETERMINE SIZE OF NEW ARRAY IFN ITS+D20,[ HLRZ TT,OPEN9A(F) ;FOR ITS AND D20, DESIRABLE SIZES ARE IN A TABLE SKIPGE F .SEE FBT.CM HRRZ TT,OPEN9A(F) ] ;END OF IFN ITS+D20 IFN D10,[ ;FOR D10, WE MUST ASK THE OPERATING SYSTEM FOR THE PROPER BUFFER SIZE MOVE TT,-3(FXP) ;GET DEVICE NAME CAMN TT,[SIXBIT \PTY\] JRST .+3 CAME TT,[SIXBIT \TTY\] TRZ F,2 ;? NOT A TTY UNLESS IT IS *THE* TTY TRNN F,2 TLZA F,FBT.CM ;ONLY THE TTY CAN BE SINGLE MODE, TLO F,FBT.CM ; AND THE TTY MUST BE SINGLE MODE! SA$ TRNE F,2 ;FOR SAIL, *THE* TTY SHOULD DEFAULT TO LINEMODE SA$ TLO F,FBT.LN MOVEM F,-4(FXP) ;SAVE BACK MODE BITS PUSHN FXP,1 ;PUSH A SLOT FOR BUFFER SIZE DATA JUMPL F,OPEN1R .SEE FBT.CM IFE SAIL,[ HLRZ T,OPEN9C(F) ;GET DESIRED I/O MODE MOVEI D,T DEVSIZ D, ;ON SUCCESS, GET SETO D, SKIPG D MOVE D,[2,,3+LIOBUF] ;ON FAILURE, USE 2 BUFFERS AT LIOBFS WORDS APIECE HLRZ TT,D CAIGE TT,NIOBFS ] ;END IFE SAIL IFN SAIL,[ MOVE D,TT ;DEVICE NAME IN D BUFLEN D, ;GET BUFFER SIZE SKIPN D ;NO WAY!! (BUT BETTER CHECK ANYWAY) MOVEI D,LIOBUF+1 ;DEFAULT ADDI D,2 ;WE NEED ACTUAL SIZE OF BUFFER, NOT SIZE-2 ] ;END IFN SAIL HRLI D,NIOBFS ;HOWEVER, WE MUST USE AT LEAST NIOBFS BUFFERS MOVEM D,(FXP) ;SAVE THIS DATA HLRZ TT,D IMULI D,(TT) ;GET TOTAL SPACE OCCUPIED BY BUFFERS HLRZ TT,OPEN9A(F) ADDI TT,(D) ;ADD TO SIZE OF REST OF FILE ARRAY CAIA OPEN1R: HRRZ TT,OPEN9A(F) ;FOR CHARACTER MODE, TABLE HAS TOTAL ARRAY SIZE ] ;END OF IFN D10 PUSHJ P,MKLSAR ;MAKE AN ARRAY - SIZE IN TT, SAR (IF ANY) IN A 10$ POP FXP,D OPEN1Q: LOCKI ;LOCK OUT USER INTERRUPTS ;FALLS THROUGH ;FALLS IN ;STATE OF THE WORLD: ; USER INTERRUPTS LOCKED OUT ; SAR FOR FILE ARRAY IN A ; FOR D10, BUFFER SIZE INFORMATION IN D ; P: FIRST ARGUMENT, OR TTY SAR IF ARGUMENT WAS T ; SECOND ARGUMENT ; FIRST ARGUMENT ; (NEGATIVE OF) ACTUAL NUMBER OF ARGS ; FXP: LOCKI WORD ; FILE NAMES IN "SIXBIT" FORMAT (L.F6BT WORDS) ; MODE BITS MOVSI TT,TTS.IM+TTS.BN+TTS.TY+TTS.IO ANDCAM TT,TTSAR(A) MOVE F,-1-L.F6BT(FXP) ;GET MODE BITS HLLZ TT,OPEN9B(F) IORB TT,TTSAR(A) ;SET CLOSED BIT AND FILE TYPE BITS IFN D10,[ JUMPL F,OPEN1T .SEE FBT.CM HLRZM D,FB.NBF(TT) ;STORE NUMBER OF BUFFERS SUBI D,3 HRRZM D,FB.BWS(TT) ;STORE BUFFER DATA SIZE IN WORDS OPEN1T: ] ;END OF IFN D10 MOVSI TT,AS.FIL IORB TT,ASAR(A) ;NOW CAN TURN ON FILE ARRAY BIT MOVEI T,-F.GC HRLM T,-1(TT) ;SET UP GC AOBJN POINTER MOVEM A,(P) ;SAVE THE FILE ARRAY SAR PUSHJ P,ALCHAN ;ALLOCATE A CHANNEL JRST OPNALZ ;LOSE IF NO FREE CHANNELS MOVE TT,TTSAR(A) HRRZM F,F.CHAN(TT) ;SAVE THE CHANNEL NUMBER IN THE FILE OBJECT POP FXP,T ;BEWARE THE LOCKI WORD! MOVEI D,F.DEV(TT) HRLI D,-L.F6BT+1(FXP) BLT D,F.DEV+L.F6BT-1(TT) ;COPY FILE NAMES INTO FILE OBJECT POPI FXP,L.F6BT ;FLUSH THEM FROM THE STACK EXCH T,(FXP) ;PUT LOCKI WORD ON STACK, PUSH FXP,T ;WITH MODE BITS ABOVE IT ;FALLS THROUGH ;FALLS IN ;STATE OF THE WORLD: ; USER INTERRUPTS LOCKED OUT ; TTSAR OF FILE ARRAY IN TT ; P: SAR FOR FILE ARRAY ; SECOND ARGUMENT TO OPEN ; FIRST ARGUMENT ; -<# OF ACTUAL ARGS> ; FXP: MODE BITS (THEY OFFICIALLY LIVE HERE, NOT IN T) ; LOCKI WORD ;PDLS MUST STAY THIS WAY FROM NOW ON FOR THE SAKE OF IOJRST'S. .SEE OPENLZ OPEN3: MOVE T,(FXP) ;GET MODE BITS ;NOW WE ACTUALLY TRY TO OPEN THE FILE IFN ITS,[ MOVE D,OPEN9C(T) TLNE T,FBT.AP ;APPEND MODE => TRO D,100000 ; ITS WRITE-OVER MODE TLNE T,FBT.EC ;MAYBE OPEN AN OUTPUT TTY TRO D,%TJPP2 ; IN THE ECHO AREA (PIECE OF PAPER #2) .CALL OPENUP IOJRST 4,OPNLZ0 .CALL RCHST ;READ BACK THE REAL AND TRUE NAMES .LOSE 1400 ] ;END OF IFN ITS IFN D10,[ JUMPL T,OPEN3M .SEE FBT.CM ;NEED NOT ALLOCATE A CHANNEL FOR *THE* TTY MOVE F,F.CHAN(TT) SA$ MOVEI R,(F) MOVEI D,(F) IMULI D,3 ADDI D,BFHD0 ;COMPUTE ADDRESS OF BUFFER HEADER MOVEM D,FB.HED(TT) ;REMEMBER BUFFER HEADER ADR SETZM (D) ;CLEAR BUFFER POINTER (TO FORCE NEW BUFFERS) SETZM 1(D) ;CLEAR OLD BYTE POINTER SETZM 2(D) ;CLEAR BYTE COUNT TRNE T,1 MOVSS D ;IF OUTPUT BUFFER, PUT ADDRESS IN LEFT HALF PUSH FXP,TT ;SAVE THE TTSAR MOVE T,OPEN9C(T) ;GET THE I/O MODE FROM THE TABLE MOVE TT,F.DEV(TT) LSH F,27 IOR F,[OPEN 0,T] XCT F ;OPEN THE FILE JRST OPNAND SA$ SHOWIT R, MOVE R,-1(FXP) ;GET MODE BITS XOR F,[#] TRNE R,1 XOR F,[#] MOVE TT,(FXP) ;GET BACK TTSAR HRR F,FB.NBF(TT) ;GET NUMBER OF BUFFERS IN RH OF UUO MOVEI TT,FB.BUF(TT) EXCH TT,.JBFF ;.JBFF IS THE ORIGIN FOR ALLOCATING BUFFERS XCT F ;TELL THE MONITOR TO ALLOCATE BUFFERS MOVEM TT,.JBFF ;RESTORE OLD VALUE OF .JBFF AND F,[0 17,] ;ISOLATE CHANNEL NUMBER AGAIN IOR F,[LOOKUP 0,T] MOVE TT,(FXP) ;GET TTSAR BACK IN TT TRNE R,1 ;WE NEED TO PERFORM A LOOKUP FOR SA$ TLNE R,FBT.AP ; EITHER "IN" OR "APPEND" MODE SA$ CAIA JRST OPEN3C MOVE T,F.FN1(TT) MOVE R,F.PPN(TT) HLLZ TT,F.FN2(TT) SA$ CAMN TT,[SIXBIT \___\] SA$ SETZ TT, SETZ D, XCT F ;PERFORM THE LOOKUP IOJRST 4,OPNLZ1 ;LOSEY LOSEY OPEN3C: MOVE D,-1(FXP) ;GET MODE BITS TRNN D,1 ;NEED TO PERFORM AN ENTER FOR JRST OPEN3D ; EITHER "OUT" OR "APPEND" MODE SA$ TLNN D,FBT.AP ;APPEND MODE MEANS READ-ALTER, DO LOOKUP FIRST XOR F,[#] MOVE TT,(FXP) ;GET TTSAR MOVE T,F.FN1(TT) MOVE R,F.PPN(TT) HLLZ TT,F.FN2(TT) SA$ CAMN TT,[SIXBIT \___\] SA$ SETZ TT, SETZ D, XCT F ;DO THE ENTER (OR POSSIBLY LOOKUP FOR SAIL) IOJRST 4,OPNLZ1 ;LOSEY LOSEY IFN SAIL,[ MOVE D,-1(FXP) ;GET THOSE MODE BITS ONCE MORE TLNN D,FBT.AP ;APPEND MODE MEANS READ-ALTER JRST SOPEN3C ;NORMAL CASE SO JUMP AHEAD XOR F,[#] ;MUMBLE MOVE TT,(FXP) ;GET TTSAR MOVE T,F.FN1(TT) PUSH FXP,R ;SAVE SIZE INFO MOVE R,F.PPN(TT) HLLZ TT,F.FN2(TT) CAMN TT,[SIXBIT \___\] SETZ TT, SETZ D, XCT F ;PERFORM THE ENTER IOJRST 4,OPNLZS ;LOSEY LOSEY XOR F,[#] XCT F ;SET UP BUFFER HEADER BYTE POINTER AND COUNT XOR F,[#] ;NOW THE UGETF, HEH, HEH XCT F POP FXP,R ;RESTORE SIZE INFO JRST OPEN3D ;GO, GO, GO SOPEN3C: ] ;END IFN SAIL XOR F,[#] XCT F ;SET UP BUFFER HEADER BYTE POINTER AND COUNT ;AS A RESULT OF THE LOOKUP OR ENTER, THE SIZE INFORMATION IS IN R OPEN3D: MOVE D,TT POP FXP,TT HLLZM D,F.RFN2(TT) ;SAVE AWAY THE REAL, TRUE FILE NAMES MOVEM T,F.RFN1(TT) MOVE D,F.CHAN(TT) ;GET CHANNEL FOR DEVCHR DEVCHR D, ;DEVICE CHRACTERISTICS TLNE D,(DV.DIR) ;IF NON-DIRECTORY ZERO TRUENAMES JRST OPN3D1 SETZM F.RFN2(TT) SETZM F.RFN1(TT) OPN3D1: MOVE D,F.CHAN(TT) SA% DEVNAM D, ;GET REAL NAME OF DEVICE SA$ PNAME D, MOVE D,F.DEV(TT) ;USE GIVEN DEVICE NAME ON FAILURE MOVEM D,F.RDEV(TT) MOVE F,F.CHAN(TT) ;TRY TO DETERMINE REAL PPN SA% DEVPPN F, SA% CAIA SA% JRST OPEN3F SA% TRZ D,770000 CAMN D,[SIXBIT \SYS\] JRST OPEN3E SA% GETPPN F, ;IF ALL ELSE FAILS, ASSUME YOUR OWN PPN SA% JFCL ;CAN'T REALLY FAIL - THIS JFCL IS FOR ULTRA SAFETY SA$ SKIPE F,F.PPN(TT) ;IF PPN WAS SPECIFIED SA$ JRST OPEN3F ;USE IT AS TRUE PPN SA$ SETZ F, SA$ DSKPPN F, ;FOR SAIL, USE THE DSKPPN (ALIAS) JRST OPEN3F OPEN3E: SA% MOVE F,[%LDSYS] SA% GETTAB R, SA% MOVE F,R70+1 ;ASSUME SYS: IS 1,,1 IF GETTAB FAILS SA$ MOVE F,[SIXBIT \ 1 3\] ;IT'S [1,3] ON SAIL OPEN3F: MOVEM F,F.RPPN(TT) JRST OPEN3N OPEN3M: MOVE D,F.DEV(TT) ;FOR THE TTY, JUST COPY THE DEVICE NAME MOVEM D,F.RDEV(TT) OPEN3N: ] ;END OF IFN D10 IFN D20,[ MOVE T,F.DEV(TT) CAME T,[ASCII \TTY\] ;SKIP IF OPENING *THE* TTY JRST OPEN3D MOVEI 1,.PRIIN ;CONSIDER USING THE PRIMARY JFN TLNE TT,TTS.IO ; OF THE APPROPRIATE DIRECTION MOVEI 1,.PRIOU MOVEI 3,0 ;NO JFN FOR TTY ; GTSTS ;MAKE SURE IT IS OPEN ; JUMPGE 2,OPEN3D .SEE GS%OPN ; MOVSI D,(GS%RDF+GS%NAM) ;MAKE SURE IT CAN DO THE KIND OF I/O WE WANT ; TLNE TT,TTS.IO ; MOVSI D,(GS%WRF+GS%NAM) ; TDC 2,D ; TDCN 2,D MOVE T,(FXP) ;RESTORE FLAG BITS JRST OPEN3E ;HERE TO ALLOCATE A FRESH JFN AND OPEN THE FILE OPEN3D: PUSH FXP,TT ;SAVE THE TTSAR MOVEI T,F.DEV(TT) HRLI T,-L.F6BT PUSH FXP,(T) ;COPY THE GIVEN DEVICE NAMES ONTO THE STACK AOBJN T,.-1 PUSHJ P,6BTNSL ;CONVERT TO A NAMESTRING IN PNBUF POP FXP,TT ;GET TTSAR MOVE T,(FXP) ;RESTORE MODE BITS IN T MOVSI 1,(GJ%ACC+GJ%SHT) .SEE .GJDEF TRNE T,1 TLNE T,FBT.AP TLOA 1,(GJ%OLD) ;FOR INPUT OR APPEND, WE WANT AN EXISTING FILE TLO 1,(GJ%FOU+GJ%NEW) ;FOR OUTPUT, A NON-EXISTENT FILE MOVE 2,PNBP GTJFN ;GET A JFN IOJRST 4,OPNLZ0 MOVE 3,1 ;SAVE JFN OPEN3E: MOVE 2,OPEN9C(T) ;GET OPEN MODE TLNE T,FBT.AP ;APPEND MODE, SET APPEND, READ BITS, CLR WRITE TRC 2,OF%APP+OF%WR+OF%RD OPENF ;OPEN THE FILE IOJRST 4,OPNLZR HRRZM 1,F.JFN(TT) ;SAVE THE JFN IN THE FILE OBJECT ] ;END OF IFN D20 ;FALLS THROUGH ;FALLS IN 10$ MOVE T,(FXP) ;FOR D10, FLAGS IN T MIGHT HAVE BEEN DESTROYED JUMPL T,OPEN3G .SEE FBT.CM MOVE D,OPEN9D(T) ;SOME INITIALIZATION FOR BLOCK MODE FILES HRRZM D,FB.BYT(TT) ;SET UP BYTE SIZE IFN ITS+D20,[ HRRI D,FB.BUF-1(TT) MOVEM D,FB.IBP(TT) ;SET UP INITIAL BUFFER POINTER HRRZ D,OPEN9B(T) ] ;END OF IFN ITS+D20 10$ MOVE D,FB.BWS(TT) IMUL D,FB.BYT(TT) ;SET UP BUFFER LENGTH (IN BYTES) MOVEM D,FB.BFL(TT) OPEN3G: SETZM F.FPOS(TT) ;FILEPOS=0 (UNTIL FURTHER NOTICE) ;NOW DETERMINE THE SIZE OF THE FILE, AND SET THE ACCESS POINTER (IF APPLICABLE) ;MODE BITS ARE IN T, TTSAR IS IN TT; FOR D10, FILE SIZE INFO IN R; ;FOR D20, JFN IS IN 1 IFN ITS,[ SKIPL F.FLEN(TT) ;THIS WAS SET BY RCHST BEFORE; -1 = NOT RANDOM JRST OPEN3P ; ACCESS TLZ T,FBT.AP ;CAN'T APPEND IF NOT RANDOMLY ACCESSIBLE JRST OPEN3Q OPEN3P: HRLZI D,1 ;ASSUME 1000000 FOR FAILING FILLEN (USR DEVICE) .CALL FILLEN ;DETERMINE LENGTH OF FILE MOVEM D,F.FLEN(TT) TLNN T,FBT.AP JRST OPEN3Q MOVE D,F.FLEN(TT) ;FOR APPEND MODE, SET THE ACCESS MOVEM D,F.FPOS(TT) ; POINTER TO THE END OF THE FILE .CALL ACCESS .LOSE 1400 ] ;END OF IFN ITS IFN D10,[ JUMPL T,OPEN3Q ;DON'T DO ANY OF THIS FOR TTY MOVE D,F.CHAN(TT) DEVCHR D, TLNE D,(DV.DIR) JRST OPEN3K SA$ TLZ T,FBT.AP ;ASSUME A NON-DIRECTORY DEVICE CAN'T APPEND SETOM F.FLEN(TT) ; OR PERFORM RANDOM ACCESS JRST OPEN3Q ;FILE SIZE INFORMATION IS IN R OPEN3K: SA% HLRE R,R ;FOR TOPS-10/CMU, THE LEFT HALF OF R SA% SKIPL R ; IS A WORD COUNT IF NEGATIVE AND A BLOCK COUNT SA% IMULI R,200 ; IF POSITIVE SA$ MOVSS R ;SAIL JUST HAS SWAPPED NEGATIVE WORD COUNT MOVMS R IMUL R,FB.BYT(TT) MOVEM R,F.FLEN(TT) ;STORE FILE LENGTH SA% ;SHOULD FALL THRU TO OPEN3Q IFN SAIL,[ TLNN T,FBT.AP JRST OPEN3Q MOVEM R,F.FPOS(TT) ;FOR APPEND MODE, SET POINTER TO EOF MOVE F,F.CHAN(TT) LSH F,27 IOR F,[UGETF 0,R] ;THIS UUO WILL CLOBBER R ;SA% IOR F,[USETI 0,-1] XCT F ;SET MONITOR'S POINTER TO EOF ;HACK UP ON SAIL'S RECORD OFFSET FEATURE SETZM FB.ROF(TT) ;ASSUME NO RECORD OFFSET TLNN D,200000 ;SKIP IF DSK/UDP (DEVCHR RESULT IS STILL IN D) JRST OPEN3Q MOVEM T,(FXP) PUSH FXP,TT XOR F,[#] MOVE T,[SIXBIT \GODMOD\] MOVEI TT,20 ;SIXBIT \GODMOD\ ? 20 => GET RECORD OFFSET IN D XCT F POP FXP,TT MOVE T,(FXP) ;CONVERT RECORD OFFSET TO A BYTE OFFSET SUBI D,1 ; FROM THE LOGICAL ORIGIN OF THE FILE IMUL D,FB.BFL(TT) MOVNM D,FB.ROF(TT) ;STORE AS A NEGATIVE OFFSET IN BYTES ] ;END OF IFN SAIL ] ;END OF IFN D10 IFN D20,[ SIZEF ;GET SIZE OF FILE JRST OPN3JA ; NOT A SIZEABLE FILE? MOVE 2,[2,,.FBBYV] MOVEI 3,D GTFDB ;R GETS LENGTH IN "FILE-BYTES" LDB C,[300600,,D] ; C GETS "FILE-BYTE" SIZE (IN BITS) MOVEI 2,36. IDIVI 2,(C) MOVE D,2 ;D HAS # OF "FILE-BYTES" PER WORD TLNN T,FBT.AP JRST OPEN3L SETO 2, SFPTR ;SET FILE POSITION TO END FOR APPENDING JRST OPEN3J RFPTR ;READ BACK THE ACTUAL POSITION IOJRST 4,OPENLZ MOVE R,2 ;R HAS FILEN IN "FILE-BYTES", D HAS # OF "FILE-BYTES" PER WORD OPEN3L: TRNE T,4 JRST OPN3LB ;FIXNUM MODE - 7-BIT-BYTE FILEN TO WORD COUNT OPN3LA: CAIN D,5 ;ASCII MODE FILE ARRAY - CHECK IF JRST OPN3LC ; "FILE-BYTE" SIZE IS ALREAD 7 BITS IMULI R,5 ; IF NOT, CONVERT COUNT TO 7-BIT-BYTE COUNT OPN3LB: CAIN D,1 JRST OPN3LC ADDI R,-1(D) IDIVI R,(D) OPN3LC: MOVEM R,F.FLEN(TT) ;STORE THE CALCULATED LENGTH-OF-FILE TLNE T,FBT.AP MOVEM R,F.FPOS(TT) ;SET FILE POSITION TO END (FOR APPEND MODE) JRST OPEN3Q OPEN3J: CAIE 1,SFPTX2 ;ILLEGAL TO RESET POINTER FOR THIS FILE? IOJRST 4,OPENLZ OPN3JA: TLZ T,FBT.AP ;IF SO, JUST SAY WE CAN'T APPEND SETOM F.FLEN(TT) ] ;END OF IFN D20 OPEN3Q: MOVEM T,(FXP) ;SAVE BACK POSSIBLY ALTERED MODE BITS IFN ITS,[ TLNN T,FBT.CA ;FOR THE CLA DEVICE, JRST OPEN3H ; GOBBLE DOWN THE FIRST TWO WORDS, MOVEI T,F.RFN1(TT) ; WHICH ARE THE SIXBIT FOR THE HRLI T,444400 ; UNAME-JNAME OF THE SENDER, AND MOVEI D,2 ; USE THEM FOR THE TRUENAMES .CALL SIOT ; OF THE FILE ARRAY IOJRST 4,OPENLZ MOVE T,(FXP) ;RESTORE MODE BITS OPEN3H: ] ;END OF IFN ITS TRNE T,1 JRST OPEN3V HRRZ D,DEOFFN ;FOR INPUT, GET THE DEFAULT EOFFN MOVEM D,FI.EOF(TT) SETZM FI.BBC(TT) ; SETZM FI.BBF(TT) ;NOT IMPLEMENTED YET JRST @OPEN3Z(T) ;DISPATCH TO APPROPRIATE PLACE OPEN3V: HRRZ D,DENDPAGEFN ;FOR OUTPUT, GET THE DEFAULT ENDPAGEFN MOVEM D,FO.EOP(TT) MOVE D,DPAGEL ;DEFAULT PAGEL MOVEM D,FO.PGL(TT) MOVE D,DLINEL ;DEFAULT LINEL MOVEM D,FO.LNL(TT) SETZM FB.BVC(TT) JRST @OPEN3Z(T) ;DISPATCH TO APPROPRIATE PLACE OPEN3Z: OPNAI1 ;ASCII DSK INPUT OPNAO1 ;ASCII DSK OUTPUT OPNTI1 ;ASCII TTY INPUT OPNTO1 ;ASCII TTY OUTPUT OPNBI1 ;FIXNUM DSK INPUT OPNBO1 ;FIXNUM DSK OUTPUT OPNTI1 ;FIXNUM TTY INPUT OPNTO1 ;FIXNUM TTY OUTPUT OPNAI1 ;IMAGE DSK INPUT OPNAO1 ;IMAGE DSK OUTPUT OPNTI1 ;IMAGE TTY INPUT OPNTO1 ;IMAGE TTY OUTPUT OPNBO1: OPNAO1: JUMPL T,OPNAT3 .SEE FBT.CM MOVE D,FB.BFL(TT) MOVEM D,FB.BVC(TT) JRST OPNA6 OPNBI1: OPNAI1: SETZM FB.BVC(TT) OPNA6: IFN ITS+D20,[ JUMPL T,OPNAT3 .SEE FBT.CM MOVE D,FB.IBP(TT) ;INITIALIZE BUFFER BYTE POINTER HRRZ R,OPEN9B(T) TRNN T,1 ADDI D,(R) ;FOR AN INPUT BUFFER, FB.BP MUST BE ADJUSTED; MOVEM D,FB.BP(TT) ; THE FIRST "EMPTY" BUFFER ISN'T A REAL ONE MOVE D,FB.BFL(TT) TRNN T,1 SETZ D, MOVEM D,FB.CNT(TT) ] ;END OF IFN ITS+D20 JRST OPNAT3 OPNTI1: 10$ JUMPGE T,OPNAI1 .SEE FBT.CM ;ONLY *THE* TTY HAS THESE HACKS SETZM TI.BFN(TT) SETZM FT.CNS(TT) IFN ITS,[ MOVE D,[STTYW1] MOVEM D,TI.ST1(TT) MOVE D,[STTYW2] MOVEM D,TI.ST2(TT) .CALL TTYGET IOJRST 4,OPENLZ ;TURN OFF AUTO-INT, SUPER-IMAGE TLZ F,%TSINT+%TSSII TRNE T,10 ;TTY IMAGE INPUT => TLO F,%TSSII ; ITS SUPER-IMAGE INPUT .CALL TTYSET IOJRST 4,OPENLZ ] ;END OF IFN ITS IFN SAIL,[ MOVEI D,[SACTW1 ? SACTW2 ? SACTW3 ? SACTW4] HRLI D,TI.ST1(T) SETACT D MOVSS D BLT D,TI.ST4(T) SETO D, GETLIN D AOSN D ;IF NOT -1 THEN OK TO USE CHARACTERISTICS SETZ D, ; ELSE CAN MAKE NO ASSUMPTIONS ABOUT TTY TLNE D,460000 ;CHECK DISLIN, DMLIN, DDDLIN TLOA T,FBT.FU TLZ T,FBT.FU MOVEM T,(FXP) ] ;END OF IFN SAIL IFN D20,[ MOVE 2,CCOCW1 MOVEM 2,TI.ST1(TT) MOVE 3,CCOCW1 MOVEM 3,TI.ST2(TT) MOVE 1,F.JFN(TT) SFCOC ;SET CCOC WORDS MOVEI 2,TT%WKF+TT%WKN+TT%WKP+TT%ECO+<.TTASC_6> .SEE TT%DAM TRNE T,10 XORI 2,<.TTBIN#.TTASC>_6 .SEE TT%DAM SFMOD ] ;END OF IFN D20 JRST OPNAT3 OPNTO1: 10$ JUMPGE T,OPNAO1 .SEE FBT.CM ;ONLT *THE* TTY HAS THESE HACKS! SETZM FT.CNS(TT) IFN ITS,[ .CALL CNSGET ;SET FO.RPL, FO.LNL, AND GET TTYOPT IN D IOJRST 4,OPENLZ MOVSI R,200000 ;INFINITE PAGEL INITIALLY MOVEM R,FO.PGL(TT) SOS FO.LNL(TT) TLZ T,FBT.SA+FBT.CP+FBT.SE TLNE D,%TOSA1 ;SKIP UNLESS WE HAVE SAIL CHARS TLO T,FBT.SA ;SET SAIL BIT TLNE D,%TOMVU ;IF WE CAN MOVE BACK, ASSUME WE TLO T,FBT.CP ; ARE A DISPLAY TERMINAL (THIS IS OK ACCORDING ; TO ITSTTY) TLNE D,%TOERS ;REMEMBER THE SELECTIVE ERASE BIT TLO T,FBT.SE .SEE RUB1CH MOVEM T,(FXP) TLNN T,FBT.EC JRST OPNTO5 .CALL SCML ;FOR ECHO AREA, SET NUMBER OF ECHO LINES TO 5 .LOSE 1400 OPNTO5: .CALL TTYGET .LOSE 1400 TLNE F,%TSROL ;TURN ON SCROLL MODE IF TTY DEFAULTLY SCROLLS TLO T,FBT.SC MOVEM T,(FXP) TLZ F,%TSFCO TLNE T,FBT.FU TLO F,%TSFCO TLNE T,FBT.SC ;IF SCROLL MODE SET SCROLLING TLO F,%TSROL .CALL TTYSAC .LOSE 1400 PUSHJ FXP,CLRO4 ;INITIALIZE LINENUM AND CHARPOS JRST OPNA6 ] ;END OF IFN ITS IFN D10,[ MOVSI D,200000 ;INFINITY (???) EXCH D,FO.PGL(TT) MOVEM D,FO.RPL(TT) SETZM AT.CHS(TT) ;SIGH SETZM AT.LNN(TT) IFE SAIL,[ SETO R, TRMNO. R, ;GET UNIVERSAL I/O INDEX FOR TERMINAL JRST OPNTO6 MOVEI D,.TOWID MOVE F,[2,,D] ;2-WD BLOCK: <.TOWID> ? TRMOP. F, ;TRY DETERMINING WIDTH OF TERMINAL OPNTO6: MOVEI F,111 ;DEFAULT WIDTH IS 73. SUBI F,1 ;REDUCE BY 1 SO NO WRAP-AROUND HAPPENS MOVEM F,FO.LNL(TT) JRST OPNA6 ] ;END OF IFE SAIL ;IFN SAIL, FALLS THROUGH TO OPNAT3 ] ;END OF IFN D10 IFN D20,[ MOVE 1,F.JFN(TT) RFMOD ;READ JFN MODE WORD FOR TERMINAL LDB D,[.BP TT%WID,2] SUBI D,1 MOVEM D,FO.LNL(TT) ;SET LINEL LDB D,[.BP TT%LEN,2] MOVEM D,FO.RPL(TT) TRNN 1,TT%PGM MOVSI D,200000 ;FOR NON-PAGED MODE, USE INFINITY MOVEM D,FO.PGL(TT) PUSHJ FXP,CLRO4 ;INITIALIZE LINENUM AND CHARPOS JRST OPNA6 ] ;END OF IFN D20 IFN ITS,[ TTYGET: SETZ SIXBIT \TTYGET\ ;GET TTYST1, TTYST2, TTYSTS ,,F.CHAN(TT) ;TTY CHANNEL # 2000,,D ;TTYST1 2000,,R ;TTYST2 402000,,F ;TTYSTS TTYSET: SETZ SIXBIT \TTYSET\ ;SET TTYST1, TTYST2, TTYSTS ,,F.CHAN(TT) ;TTY CHANNEL # ,,TI.ST1(TT) ;TTYST1 ,,TI.ST2(TT) ;TTYST2 400000,,F ;TTYSTS SCML: SETZ SIXBIT \SCML\ ;SET NUMBER OF COMMAND LINES ,,F.CHAN(TT) ;TTY CHANNEL # 401000,,5 ;NUMBER OF LINES CNSGET: SETZ SIXBIT \CNSGET\ ;GET CONSOLE PARAMETERS ,,F.CHAN(TT) ;TTY CHANNEL # 2000,,FO.RPL(TT) ;VERTICAL SCREEN SIZE 2000,,FO.LNL(TT) ;HORIZONTAL SCREEN SIZE 2000,,D ;TCTYP (THROW AWAY) 2000,,D ;TTYCOM (THROW AWAY) 402000,,D ;TTYOPT ;TTYTYP NOT GOTTEN ] ;END OF IFN ITS OPNAT3: TRNE T,2 JRST OPNAT5 SETZM AT.CHS(TT) SETZM AT.LNN(TT) OPNAT5: MOVEI D,1 MOVEM D,AT.PGN(TT) OPEN4: POP FXP,F.MODE(TT) POP P,A ;SAR FOR FILE ARRAY - RETURNED MOVEI TT,-1 SETZM @TTSAR(A) ;ILLEGAL FOR LOSER TO ACCESS AS ARRAY MOVSI TT,TTS ANDCAM TT,TTSAR(A) ;UNCLOSE IT POPI P,3 ;FLUSH 2 ARGS AND # OF ARGS 20$ SETZB 2,3 ;MAKE SURE AC'S CONTAIN NO JUNK UNLKPOPJ ;WE HAVE WON! ;;; VARIOUS ERROR HANDLERS - ARRIVE WITH A MESSAGE IN C. OPNALZ: MOVEI C,[SIXBIT \ALL I/O CHANNELS ALREADY IN USE!\] POP FXP,-L.F6BT-1(FXP) ;FAKE OUT CORRECT PDL CONDITIONS POPI FXP,L.F6BT-1 OPENLZ: MOVE F,F.CHAN(TT) ;REMEMBER, C HAS ERROR MSG SETZM CHNTB(F) ;CLOSE CHANNEL AND DEALLOCATE IFN ITS,[ .CALL ALCHN9 .LOSE 1400 ] ;END OF IFN ITS IFN D10,[ LSH F,27 IOR F,[RELEASE 0,0] XCT F ] ;END OF IFN D10 IFN D20,[ HRRZ 1,F.JFN(TT) CLOSF HALT ] ;END OF IFN D20 OPNLZ0: POP P,AR1 ;FILE OBJECT SAR POP P,A ;SECOND ARG POP P,B ;FIRST ARG POP P,T ;ARG COUNT JUMPN T,OPNLZ3 MOVEI A,(AR1) PUSHJ P,NAMELIST JRST OPNLZ2 OPNLZ3: PUSHJ P,ACONS EXCH A,B PUSHJ P,ACONS CAMN T,XC-2 HRRM B,(A) OPNLZ2: MOVEI B,Q$OPEN POPI FXP,1 UNLOCKI JRST XCIOL IFN D10,[ OPNAND: MOVEI C,NSDERR ;NO SUCH DEVICE OPNLZ1: POPI FXP,1 JRST OPNLZ0 ] ;END OF IFN D10 IFN SAIL,[ OPNLZS: POPI FXP,2 JRST OPNLZ0 ] ;END IFN SAIL IFN D20,[ OPNLZR: JUMPE C,OPNLZ0 EXCH A,C RLJFN JFCL EXCH A,C JRST OPNLZ0 ] ;END OF IFN D20 IFN ITS,[ OPENUP: SETZ SIXBIT \OPEN\ ;OPEN FILE 5000,,(D) ;I/O MODE BITS ,,F.CHAN(TT) ;CHANNEL # ,,F.DEV(TT) ;DEVICE NAME ,,F.FN1(TT) ;FILE NAME 1 ,,F.FN2(TT) ;FILE NAME 2 400000,,F.SNM(TT) ;SNAME FILLEN: SETZ SIXBIT \FILLEN\ ;GET FILE LENGTH (IN WORDS) ,,F.CHAN(TT) ;CHANNEL # 402000,,F.FLEN(TT) ;PUT RESULT IN F.FLEN OF THE FILE OBJECT ACCESS: SETZ SIXBIT \ACCESS\ ;SET FILE ACCESS POINTER ,,F.CHAN(TT) ;CHANNEL # 400000,,F.FPOS(TT) ;POSITION RCHST: SETZ SIXBIT \RCHST\ ;READ CHANNEL STATUS ,,F.CHAN(TT) ;CHANNEL # 2000,,F.RDEV(TT) ;DEVICE NAME 2000,,F.RFN1(TT) ;FILE NAME 1 2000,,F.RFN2(TT) ;FILE NAME 2 2000,,F.RSNM(TT) ;SNAME 402000,,F.FLEN(TT) ;ACCESS POINTER ] ;END OF IFN ITS ;;; TABLES FOR OPEN FUNCTION ;;; ALL TABLES ARE INDEXED BY THE RIGHT HALF OF THE MODE WORD. IT$ RBFSIZ==:200 ;RANDOM BUFFER SIZE 20$ RBFSIZ==:200 10$ RBFSIZ==:0 ;;; SIZES FOR FILE ARRAYS: ,, ;;; FOR D10, THIS IS THE SIZE EXCLUSIVE OF THE BUFFER; FOR ITS AND D20, INCLUSIVE. ;;; SIZES ARE IN WORDS. OPEN9A: FB.BUF+RBFSIZ,,FB.BUF ;ASCII DSK INPUT FB.BUF+RBFSIZ,,FB.BUF ;ASCII DSK OUTPUT ,,FB.BUF+NASCII/2 ;ASCII TTY INPUT FB.BUF+RBFSIZ,,FB.BUF ;ASCII TTY OUTPUT FB.BUF+RBFSIZ,,FB.BUF ;FIXNUM DSK INPUT FB.BUF+RBFSIZ,,FB.BUF ;FIXNUM DSK OUTPUT ,,FB.BUF+NASCII/2 ;FIXNUM TTY INPUT FB.BUF+RBFSIZ,,FB.BUF ;FIXNUM TTY OUTPUT FB.BUF+RBFSIZ,,FB.BUF ;IMAGE DSK INPUT FB.BUF+RBFSIZ,,FB.BUF ;IMAGE DSK OUTPUT ,,FB.BUF+NASCII/2 ;IMAGE TTY INPUT FB.BUF+RBFSIZ,,FB.BUF ;IMAGE TTY OUTPUT ;;; ,, ;;; THE RIGHT HALF IS NOT REALLY USED FOR D10. OPEN9B: IRP X,,[A,X,I]J,,[,+BN,+IM] ;ASCII/FIXNUM/IMAGE IRP Y,,[D,T]K,,[,+TY] ;DSK/TTY IRP Z,,[I,O]L,,[,+IO] ;IN/OUT IFSE X!!Y!!Z,IDI, LDGTW5: .SEE LDGTWD ;CROCK TTS,,RBFSIZ TERMIN TERMIN TERMIN ;;; ,, ;;; RELEVANT ONLY FOR BLOCK MODE FILES. ONLY THE RIGHT HALF IS USED FOR D10. OPEN9D: 010700,,5 ;ASCII DSK INPUT 010700,,5 ;ASCII DSK OUTPUT 0 ;ASCII TTY INPUT (IRRELEVANT) 010700,,5 ;ASCII TTY OUTPUT 004400,,1 ;FIXNUM DSK INPUT 004400,,1 ;FIXNUM DSK OUTPUT 0 ;FIXNUM TTY INPUT (IRRELEVANT) IT$ 001400,,3 ;FIXNUM TTY OUTPUT 10$ SA% 010700,,5 10$ SA$ 001100,,4 20$ 010700,,5 010700,,5 ;IMAGE DSK INPUT 010700,,5 ;IMAGE DSK OUTPUT 0 ;IMAGE TTY INPUT (IRRELEVANT) 10% 041000,,4 ;IMAGE TTY OUTPUT 10$ SA% 010700,,5 10$ SA$ 001100,,4 ? WARN [IMAGE TTY OUTPUT?] ;;; OPEN9C CONTAINS THE OPEN MODE WORD. FOR D10, THE MODE IS ALWAYS ;;; BLOCK MODE IF THIS TABLE IS USED. FOR D20, THERE IS NO DIFFERENCE ;;; IN THIS TABLE FOR BLOCK VERSUS SINGLE MODE. OPEN9C: IFN ITS,[ ;;; RECALL THE MEANINGS OF THE FOLLOWING BITS IN ITS: ;;; 1.3 0 => ASCII, 1 => IMAGE ;;; 1.2 0 => UNIT (CHARACTER) MODE, 1 => BLOCK MODE ;;; 1.1 0 => INPUT, 1 => OUTPUT ;;; ITS BLOCK MODE IS NOT USED FOR BUFFERED FILES; RATHER, SIOT IS USED. 0 ;ASCII DSK INPUT 1 ;ASCII DSK OUTPUT 0 ;ASCII TTY INPUT %TJDIS+1 ;ASCII TTY OUTPUT (DISPLAY IF POSSIBLE) 4 ;FIXNUM DSK INPUT 5 ;FIXNUM DSK OUTPUT %TIFUL+0 ;FIXNUM TTY INPUT (>7 BITS ON IMLACS AND TVS) %TJDIS+1 ;FIXNUM TTY OUTPUT 0 ;IMAGE DSK INPUT 1 ;IMAGE DSK OUTPUT 0 ;IMAGE TTY INPUT (SUPER-IMAGE INPUT) %TJSIO+1 ;IMAGE TTY OUTPUT (SUPER-IMAGE OUTPUT) ] ;END OF IFN ITS IFN D10,[ .IOASC ;ASCII DSK INPUT .IOASC ;ASCII DSK OUTPUT .IOASC ;ASCII TTY INPUT .IOASC ;ASCII TTY OUTPUT .IOBIN ;FIXNUM DSK INPUT .IOBIN ;FIXNUM DSK OUTPUT .IOASC ;FIXNUM TTY INPUT .IOASC ;FIXNUM TTY OUTPUT .IOASC ;IMAGE DSK INPUT .IOASC ;IMAGE DSK OUTPUT .IOIMG ;IMAGE TTY INPUT .IOIMG ;IMAGE TTY OUTPUT ] ;END OF IFN D10 IFN D20,[ .SEE OF%BSZ OF%MOD 070000,,OF%RD ;ASCII DSK INPUT 070000,,OF%WR ;ASCII DSK OUTPUT 070000,,OF%RD ;ASCII TTY INPUT 070000,,OF%WR ;ASCII TTY OUTPUT 440000,,OF%RD ;FIXNUM DSK INPUT 440000,,OF%WR ;FIXNUM DSK OUTPUT 440000,,OF%RD ;FIXNUM TTY INPUT 440000,,OF%WR ;FIXNUM TTY OUTPUT 070000,,OF%RD ;IMAGE DSK INPUT 070000,,OF%WR ;IMAGE DSK OUTPUT 100000,,OF%RD ;IMAGE TTY INPUT 100000,,OF%WR ;IMAGE TTY OUTPUT ] ;END OF IFN D20 IFN SAIL,[ ;EOPEN FOR SAIL -- HANDLE 'E' FILES ;;; DO AN OPEN, THEN, IF THE FILE IS OPEN IN NON-IMAGE NON-TTY ASCII MODE SKIP ;;; OVER E'S COMMENT BY DOING SUCCESIVE IN'S $EOPEN: MOVEI TT,(P) ;MUST CALCULATE WHERE RETURN ADR IS ADD TT,T ;SUBTRACT NUMBER OF ARGS GIVEN PUSH FXP,(TT) ;REMEMBER USER'S RETURN ADR MOVEI R,$EOPN1 ;NEW RETURN ADR MOVEM R,(TT) JRST $OPEN ;NOW OPEN THE FILE $EOPN1: MOVEI TT,F.MODE ;GET MODE OF FILE HRRZ TT,@TTSAR(A) SKIPE TT ;ASCII, DSK, INPUT? POPJ FXP, ;NOPE, JUST RETURN PUSH P,A ;REMEMBER FILE ARRAY PUSH FXP,[440700,,[ASCIZ \COMMENT \]] $EOPN2: ILDB T,(FXP) ;GET NEXT CHARACTER TO LOOK FOR JUMPE T,$EOPN5 ;LOOKS LIKE WE FOUND AN 'E' FILE, SKIP INDEX PUSH P,[$EOPN3] ;RETURN ADR PUSH P,-1(P) ;THE FILE ARRAY TO READ FROM MOVNI T,1 ;ONE ARG JRST %TYI+1 ;TYI ONE CHARACTER FROM THE FILE (NCALL) $EOPN3: JUMPL TT,$EOPN4 ;EOF -- ERROR! LDB T,(FXP) ;GET THE CURRENT CHARACTER CAIN T,(TT) ;MATCH? JRST $EOPN2 ;YES, KEEP SCANNING THE FILE PUSH P,[$EOPN6] ;NOPE, FILEPOS TO BOF PUSH P,-1(P) ;FILE ARRAY PUSH P,CIN0 ;ZERO - LOGICAL BOF MOVNI T,2 ;TWO ARGS -- SET FILEPOS JRST FILEPOS $EOPN6: POPI FXP,1 ;BYTE POINTER POP P,A ;FILE ARRAY RETURNED IN A POPJ FXP, ;RETURN TO USER ;HERE WHEN FOUND AN 'E' FILE, SKIP TO AFTER ^L AFTER NEXT ^V $EOPN5: PUSH P,[$EOPN7] ;RETURN ADR PUSH P,-1(P) ;THE FILE ARRAY TO READ FROM MOVNI T,1 ;ONE ARG JRST %TYI+1 ;TYI ONE CHARACTER FROM THE FILE (NCALL) $EOPN7: JUMPL TT,$EOPN4 ;EOF -- ERROR! CAIE TT,^V ;FOUND ^V? JRST $EOPN5 ;NOPE, KEEP ON LOOPING $EOPN8: PUSH P,[$EOPN9] ;RETURN ADR PUSH P,-1(P) ;THE FILE ARRAY TO READ FROM MOVNI T,1 ;ONE ARG JRST %TYI+1 ;TYI ONE CHARACTER FROM THE FILE (NCALL) $EOPN9: JUMPL TT,$EOPN4 ;EOF -- ERROR! CAIE TT,^L ;FOUND ^L? JRST $EOPN8 ;NOPE, KEEP ON LOOPING POPI FXP,1 ;GET RID OF BYTE POINTER POP P,A ;RETURN FILE ARRAY POPJ FXP, ;TO USER $EOPN4: POP P,A ;FILE ARRAY -- EOF, WE LOST FAC [EOF READING A FILE WHICH LOOKED LIKE AN 'E' FILE - EOPEN!] ] ;END IFN SAIL SUBTTL DEFAULTF, ENDPAGEFN, EOFFN ;;; (DEFAULTF X) SETS THE DEFAULT NAMELIST TO X. ;;; X IS MERGEF'D WITH THE OLD NAMELIST FIRST. ;;; IT FOLLOWS THAT (DEFAULTF NIL) = (NAMELIST NIL). DEFAULTF: PUSHJ P,FIL6BT PUSHJ P,DMRGF PUSHJ P,6BTNML MOVEM A,VDEFAULTF POPJ P, SSCRFILE==DEFAULTF ;;; (EOFFN F) GETS INPUT FILE F'S END-OF-FILE FUNCTION. ;;; (EOFFN F X) SETS THE FUNCTION TO BE X. ;;; (ENDPAGEFN F) GETS OUTPUT FILE F'S END-OF-PAGE FUNCTION. ;;; (ENDPAGEFN F X) SETS IT TO BE X. ENDPAGEFN: JSP TT,LWNACK ;LSUBR (1 . 2) LA12,,QENDPAGEFN MOVEI TT,ATOFOK MOVEI B,DENDPAGEFN MOVEI C,QENDPAGEFN JRST EOFFN0 EOFFN: JSP TT,LWNACK ;LSUBR (1 . 2) LA12,,QEOFFN MOVEI TT,IFILOK MOVEI B,DEOFFN MOVEI C,QEOFFN EOFFN0: AOJN T,EOFFN5 POP P,AR1 JUMPE AR1,EOFFN2 IFN SFA,[ PUSH FXP,TT JSP TT,XFOSP ;SFA? JRST EOFFNZ JRST EOFFNZ ;NOPE POPI FXP,1 MOVEI A,(AR1) ;CALL THE SFA, AND RETURN ITS ANSWER HRRZI B,(C) ;THE OPERATION -- EOFFN OR ENDPAGEFUN SETZ C, ;WE WANT THE SFA TO RETURN A VALUE JRST ISTCSH ;SHORT INTERNAL CALL EOFFNZ: POP FXP,TT ] ;END IFN SFA PUSHJ P,(TT) MOVEI TT,FI.EOF .SEE FO.EOP HRRZ A,@TTSAR(AR1) UNLKPOPJ EOFFN2: HRRZ A,(B) POPJ P, EOFFN5: POP P,A POP P,AR1 JUMPE AR1,EOFFN7 IFN SFA,[ PUSH FXP,TT JSP TT,XFOSP ;CHECK IF WE HAVE AN SFA JRST EOFFNY JRST EOFFNY ;NOPE POPI FXP,1 JSP T,%NCONS ;LISTIFY IT SO IT IS IDENTIFIABLE AS AN ARG MOVEI B,(C) ;THE OPERATION MOVEI C,(A) ;AS THE ARG TO THE SFA MOVEI A,(AR1) ;THE SFA ITSELF JRST ISTCSH ;DO THE SHORT INTERNAL CALL EOFFNY: POP FXP,TT ;UNDO PUSHES ] ;END IFN SFA PUSHJ P,(TT) MOVE TT,TTSAR(AR1) HRRZM A,FI.EOF(TT) .SEE FO.EOP UNLKPOPJ EOFFN7: HRRZM A,(B) POPJ P, SUBTTL LISTEN FUNCTION ;;; (LISTEN X) LISTENS TO THE SPECIFIED TTY X. $LISTEN: SKIPA F,CFIX1 ;LSUBR (0 . 1) NCALLABLE MOVEI F,CPOPJ HRRZ AR1,V%TYI JUMPE T,$LSTN3 MOVEI D,Q$LISTEN AOJN T,S1WNAL POP P,AR1 ;FILE ARRAY SPECIFIED $LSTN3: IFN SFA,[ JSP TT,XFOSP ;FILE OR SFA? JRST $LSTNS JRST $LSTNS ;NOT AN SFA JSP T,QIOSAV MOVEI A,(AR1) ;SFA IN A MOVEI B,Q$LISTEN ;OPERATION SETZ C, ;NO THIRD ARG PUSHJ P,ISTCSH ;SHORT INTERNAL SFA INVOCATION MOVE TT,(A) ;BE PREPARED IF NCALL'ED POPJ P, $LSTNS: ] ;END IFN SFA PUSHJ P,TIFLOK ;IT BETTER BE TTY INPUT IFN ITS,[ .CALL LISTEN ;SO LISTEN ALREADY SETZ R, ;ON FAILURE, JUST ASSUME 0 ] ;END OF IFN ITS IFN D10,[ SKIPL T,F.MODE(TT) .SEE FBT.CM SA$ JRST $LSTN4 ? WARN [REALLY OUGHT TO BE SMARTER] SA% JRST $LSTN5 IFE SAIL,[ TLNE T,FBT.LN SKIPA D,[SKPINL] MOVSI D,(SKPINC) ] ;END OF IFE SAIL IFN SAIL,[ MOVE D,[SNEAKS R,] JRST $LSTN6 $LSTN4: MOVE D,F.CHAN(TT) LSH D,27 IOR D,[TTYSKP 0,] ] ;END OF IFN SAIL $LSTN6: XCT D $LSTN5: TDZA R,R MOVEI R,1 ] ;END OF IFN D10 IFN D20,[ HRRZ 1,F.JFN(TT) SIBE ;SKIP IF INPUT BUFFER EMPTY SKIPA R,2 ;NUMBER OF WAITING CHARS IN 2 SETZ R, ] ;END OF IFN D20 MOVEI TT,FI.BBC MOVE A,@TTSAR(AR1) ;ALSO COUNT IN ANY BUFFERED TLZE A,-1 ; UP CHARACTERS PENDING AOS R JSP T,LNG1A ADD TT,R UNLOCKI JRST (F) IFN ITS,[ LISTEN: SETZ SIXBIT \LISTEN\ ;LISTEN AT A TTY, ALREADY ,,F.CHAN(TT) ;TTY CHANNEL # 402000,,R ;NUMBER OF TYPED-AHEAD CHARS ] ;END OF IFN ITS SUBTTL LINEL, PAGEL, CHARPOS, LINENUM, PAGENUM ;;; VARIOUS FUNCTIONS TO GET AND SET A FILE'S LINEL, PAGEL, ;;; CHARPOS, LINENUM, AND PAGENUM. LINEL: SKIPA D,CFIX1 MOVEI D,CPOPJ JSP F,FLFROB ;LSUBR (1 . 2) FO.LNL,,QLINEL DLINEL,,ATOFOK PAGEL: SKIPA D,CFIX1 MOVEI D,CPOPJ JSP F,FLFROB ;LSUBR (1 . 2) FO.PGL,,QPAGEL DPAGEL,,ATOFOK CHARPOS: SKIPA D,CFIX1 MOVEI D,CPOPJ JSP F,FLFROB ;LSUBR (1 . 2) AT.CHS,,QCHARPOS 0,,ATOFOK LINENUM: SKIPA D,CFIX1 MOVEI D,CPOPJ JSP F,FLFROB ;LSUBR (1 . 2) AT.LNN,,QLINEN 0,,ATFLOK PAGENUM: SKIPA D,CFIX1 MOVEI D,CPOPJ JSP F,FLFROB ;LSUBR (1 . 2) AT.PGN,,QPAGENUM 0,,ATFLOK IFN SFA,[ FLFWNA: HRRZ D,(F) ;FUNCTION NAME JRST WNALOSE ;WNA ERROR FLNSFL: EXCH AR1,A WTA [NOT SFA OR FILE!] ] ;END IFN SFA FLFROB: IFN SFA,[ CAME T,XC-1 ;WRONG NUMBER OF ARGS? CAMN T,XC-2 SKIPA JRST FLFWNA MOVEI TT,(P) ;TOP OF STACK CONTAINS FILE ARG? CAMN T,XC-2 ;UNLESS TWO ARGS MOVEI TT,-1(P) MOVE A,(TT) ;GET THE ARG CAIN A,TRUTH MOVE A,V%TYO MOVEM A,(TT) ;RE-STORE IT INCASE IT HAS BEEN ALTERED JUMPE A,FLFRF1 ;IF NIL THEN HANDLE SPECIALLY EXCH A,AR1 JSP TT,XFOSP JRST FLNSFL ;NOT AN SFA OR FILE JRST FLFRFL AOSE T ;HAVE TWO ARGS? POP P,AR1 ;YES, IT WILL BECOME SECOND ARG TO SFA EXCH AR2A,(P) ;SAVE AR2A ON STACK, GET SFA PUSH P,A ;SAVE OLD AR1 PUSH P,C PUSH P,B MOVEI A,(AR2A) ;SFA INTO A HRRZ B,(F) ;OPERATION NAME INTO B MOVEI C,(AR1) ;THIRD ARG PUSHJ P,ISTCSH POP P,B POP P,C POP P,AR1 POP P,AR2A JSP T,FXNV1 ;MAKE SURE RESULT IS A FIXNUM POPJ P, FLFRFL: EXCH A,AR1 FLFRF1: ] ;END IFN SFA AOJN T,FLFRB5 PUSH P,AR1 MOVE AR1,-1(P) MOVEM D,-1(P) JUMPE AR1,FLFRB3 FLFRB1: HRRZ TT,1(F) PUSHJ P,(TT) HLRZ TT,(F) MOVM TT,@TTSAR(AR1) .SEE STERPRI ;LINEL MAY BE NEGATIVE UNLOCKI FLFB1A: POP P,AR1 POPJ P, FLFRB3: HLRZ TT,1(F) JUMPE TT,FLFRB1 MOVE TT,(TT) JRST FLFB1A FLFRB5: POP P,A JSP T,FXNV1 PUSH P,AR1 MOVE AR1,-1(P) MOVEM D,-1(P) MOVE D,TT JUMPE AR1,FLFRB7 FLFRB6: HRRZ TT,1(F) PUSHJ P,(TT) HLRZ TT,(F) MOVMS D EXCH D,@TTSAR(AR1) SKIPGE D MOVNS @TTSAR(AR1) UNLOCKI FLFRB8: MOVE TT,D JRST FLFB1A FLFRB7: HLRZ TT,1(F) JUMPE TT,FLFRB6 MOVMM D,(TT) JRST FLFRB8 SUBTTL IN ;;; (IN X) INPUTS ONE FIXNUM FROM THE BINARY FILE X AND ;;; RETURNS IT. $IN: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE - ACS 1 PUSH P,AR1 IFN SFA,[ JSP TT,AFOSP ;FILE OR SFA OR NOT? JFCL ;NOT, LET OTHER CODE GIVE ERROR JRST $INNOS ;NOT SFA, PROCEED POP P,AR1 PUSHJ FXP,SAV5M1 ;SAVE ALL BUT A MOVEI B,Q$IN ;IN OPERATION SETZ C, ;NO THIRD ARG PUSHJ P,ISTCSH ;SHORT +INTERNAL-SFA-CALL PUSHJ P,RST5M1 MOVE T,CFIX1 CAMN T,(P) ;NCALL'ED? POPI P,1 ;YUP, WILL RETURN ARGS IN BOTH A AND TT JSP T,FXNV1 ;INSURE A FIXNUM POPJ P, ;RETURN $INNOS: ] ;END IFN SFA MOVEI AR1,(A) PUSHJ P,XIFLOK ;LOCKI, and put TTSAR in TT IFN ITS+D20,[ MOVEI R,(TT) ;SAVE A COPY OF TTSAR SKIPL F.MODE(TT) .SEE FBT.CM JRST $IN2 ;FOR ITS AND D20, HANDLE SINGLE MODE FILES IFN ITS,[ PUSH FXP,[%TIACT] ;ASSUME A TTY TLNN TT,TTS.TY ;A TTY? SETZM (FXP) ;NO, SO NO FLAG BITS MOVE T,[444400,,TT] ;READ ONE 36.-BIT BYTE INTO TT MOVEI D,1 .CALL INSIOT .LOSE 1400 POPI FXP,1 JUMPN D,$IN7 ;IF WE GOT NO WORD, ASSUME EOF ] ;END OF IFN ITS IFN D20,[ PUSH P,2 ;PRESERVE AC'S HRRZ 1,F.JFN(TT) BIN ;READ ONE 36.-BIT BYTE INTO TT ERJMP $INTST MOVE TT,2 POP P,2 ] ;END OF IFN D20 AOS F.FPOS(R) JRST $IN1 IFN D20,[ $INTST: PUSH FXP,2 GTSTS TLNN 2,(GS%EOF) JRST IIOERR POP FXP,TT POP P,2 JRST $IN7 ] ;END OF IFN D20 ] ;END OF IFN ITS+D20 IFN D10,[ SKIPGE F.MODE(TT) .SEE FBT.CM LERR [SIXBIT \SINGLE MODE BINARY NOT AVAILABLE - IN!\] ] ;END OF IFN D10 $IN2: 10$ HRRZ D,FB.HED(TT) 10% SOSGE FB.CNT(TT) ;ARE THERE ANY BYTES LEFT? 10$ SOSGE 2(D) JRST $IN3 ;NO, GO GET ANOTHER BUFFER FULL 10% ILDB TT,FB.BP(TT) ;YES, GOBBLE DOWN THE NEXT BYTE 10$ ILDB TT,1(D) $IN1: POP P,AR1 UNLKPOPJ ;GET THE NEXT INPUT BUFFER $IN3: MOVE F,FB.BVC(TT) ADDM F,F.FPOS(TT) ;UPDATE FILE POSITION IFN D20\ITS,[ MOVE T,FB.IBP(TT) MOVEM T,FB.BP(TT) ;REINITIALIZE BYTE POINTER MOVE D,FB.BFL(TT) ;GET BUFFER LENGTH INTO D ] ;END OF IFN D10\ITS IFN ITS,[ MOVE R,D ;GET NEXT BUFFER-LOAD .CALL SIOT .LOSE 1400 SUBB R,D ;GET COUNT OF BYTES OBTAINED ] ;END OF IFN ITS IFN D20,[ PUSH P,B PUSH P,C HRRZ 1,F.JFN(TT) MOVE 2,T MOVN 3,D SIN ;GET NEXT BUFFER-LOAD ADD D,3 ;GET COUNT OF BYTES OBTAINED POP P,C POP P,B ] IFN D10,[ HRRZ F,F.CHAN(TT) LSH F,27 IFE SAIL,[ TLNN TT,TTS.BM JRST INB6 ;$DEV5R HRRZ D,FB.HED(TT) ;MAYBE BUFFER HAS BEEN RELOCATED? THEN FOR MOVSI R,(BF.IOU) ANDCAB R,@(D) ;TURNS OFF BUFFER-IN-USE BIT AND ADVANCES BUFFER SKIPGE (R) ;BF.IOU MUST BE BIT 4.9 FOR THIS TO WORK JRST INB4 ;$DEV5S MOVSI F,TTS.BM ANDCAM F,TTSAR(AR1) ;TURN OFF "BUFFER-MOVED" BIT, BUT LEAVE BUF ADDR IN F MOVE F,F.CHAN(TT) ;$DEV5Q: LSH F,27 HRR F,R ] ;END OF IFE SAIL INB6: TLO F,(IN 0,) ;$DEV5R: XCT F ;GET NEXT INPUT BUFFER JRST $IN4 ;SUCCESS XOR F,[#] XCT F ;SKIP IF EOF JRST IIOERR ;HALT FOR OTHER LOSS $IN4: MOVE D,FB.HED(TT) MOVE D,2(D) ;GET, FROM HEADER, NUMBER OF BYTES READ ] ;END OF IFN D10 $IN5M: MOVEM D,FB.BVC(TT) ;STORE "VALID COUNT" - # OF OF BYTES OBTAINED IFN D20\ITS, MOVEM D,FB.CNT(TT) JUMPN D,$IN2 ;EXIT IF WE GOT ANY (ELSE EOF?) IFN D20,[ PUSH P,B GTSTS ;GET FILE STATUS TLNN 2,(GS%EOF) ;SKIP ON EOF JRST IIOERR ;HALT FOR OTHER LOSS POP P,B ] ;END OF IFN D20 $IN7: MOVEI A,(AR1) ;NO DATA WORDS - EOF HRRZ T,FI.EOF(TT) UNLOCKI POP P,AR1 JUMPE T,$IN8 JCALLF 1,(T) ;CALL USER EOF FUNCTION IFN D10*<1-SAIL>,[ INB4: HRRZ F,FB.HED(TT) HRRZM R,(F) ;STORE CURRENT BUFFER ADDR IN CONTROL BLOCK TLZ R,-1 ADD R,[4400,,1] MOVEM R,1(F) ;CONSTRUCT NEW BP FOR BUFFER MOVE D,(R) MOVEM D,2(F) ;STORE NEW BYTE COUNT INITO BUFFERCONTROL-BLOCK JRST $IN5M ] ;END OF D10*<1-SAIL> $IN8: PUSH P,B ;NO USER EOF FUNCTION PUSHJ P,NCONS MOVEI B,Q$IN PUSHJ P,XCONS POP P,B IOL [EOF - IN!] ;SIGNAL ERROR IFN ITS,[ INSIOT: SETZ SIXBIT \SIOT\ ;STRING I/O TRANSFER ,,F.CHAN(TT) ;CHANNEL # ,,T ;BYTE POINTER ,,D ;BYTE COUNT 404000,,(FXP) ] ;END IFN ITS IFN D10*<1-SAIL>,[ IB4: HRRZ D,FB.HED(TT) HRRZM R,(D) ;STORE CURRENT BUFFER ADDR IN CONTROL BLOCK TLZ R,-1 ADD R,[4400,,1] MOVEM R,1(D) ;CONSTRUCT NEW BP FOR BUFFER MOVE R,(R) MOVEM R,2(D) ;STORE NEW BYTE COUNT INITO BUFFERCONTROL-BLOCK MOVEM R,FB.BVC(F) ;STORE "VALID COUNT" - # OF OF BYTES OBTAINED JRST $IN2 ] ;END OF IFE D10*<1-SAIL> SUBTTL OUT ;;; (OUT X N) OUTPUTS THE FIXNUM N TO THE FILE X. RETURNS T. $OUT: PUSH P,AR1 ;SUBR 2 - ACS 1 IFN SFA,[ JSP TT,AFOSP ;FILE OR SFA OR NOT? JFCL ;NOT, LET OTHER CODE GIVE ERROR JRST $OUTNS ;NOT SFA, PROCEED POP P,AR1 JSP T,QIOSAV MOVEI C,(B) ;ARG IS FIXNUM TO OUTPUT MOVEI B,Q$OUT ;OUT OPERATION JRST ISTCSH ;SHORT +INTERNAL-SFA-CALL $OUTNS: ] ;END IFN SFA JSP T,FXNV2 MOVEI AR1,(A) PUSHJ P,XOFLOK SKIPL F.MODE(TT) .SEE FBT.CM JRST $OUT2 ;OUTPUT ONE BYTE TO A SINGLE MODE BINARY FILE 10$ LERR [SIXBIT \SINGLE MODE BINARY NOT AVAILABLE - OUT!\] IFN ITS,[ MOVE R,D MOVEI D,1 MOVE T,[444400,,R] .CALL SIOT .LOSE 1400 ] ;END OF IFN ITS IFN D20,[ PUSH P,B HRRZ 1,F.JFN(TT) MOVE 2,D BOUT ERJMP OIOERR POP P,B ] ;END OF IFN D20 IFN ITS+D20,[ AOS F.FPOS(TT) JRST $OUT1 ] ;END OF IFN ITS+D20 $OUT3: PUSH FXP,D 10% SETZM FB.CNT(TT) ;DOING OWN BUFFERED I/O, -1 IN FB.CNT IS N.G. PUSHJ P,IFORCE ;FORCE OUT CURRENT OUTPUT BUFFER POP FXP,D $OUT2: 10$ HRRZ R,FB.HED(TT) 10% SOSGE FB.CNT(TT) ;SEE IF THERE IS ROOM FOR ANOTHER BYTE 10$ SOSGE 2(R) JRST $OUT3 ;NO, GO OUTPUT THIS BUFFER FIRST 10% IDPB D,FB.BP(TT) ;STICK BYTE IN BUFFER 10$ IDPB D,1(R) $OUT1: POP P,AR1 JRST UNLKTRUE SUBTTL FILEPOS, LENGTHF ;;; FILEPOS FUNCTION ;;; (FILEPOS F) RETURNS CURRENT FILE POSITION ;;; (FILEPOS F N) SETQ FILEPOS TO X ;;; FOR ASCII FILES, THE POSITION IS MEASURED IN CHARACTERS; ;;; FOR FIXNUM FILES, IN FIXNUMS (WORDS). ZERO IS THE ;;; BEGINNING OF THE FILE. ERROR IF FILE IS NOT RANDOMLY ;;; ACCESSIBLE. FILEPOS: AOJE T,FPOS1 ;ONE ARG => GET AOJE T,FPOS5 ;TWO ARGS => SET MOVEI D,QFILEPOS ;ARGH! ARGH! ARGH! ... JRST S2WNALOSE IFN D20,[ FPOS0E: POP P,B JRST FPOS0D ] ;END OF IFN D20 FPOS0B: SKIPA C,FPOS0 FPOS0C: MOVEI C,[SIXBIT \ILLEGAL ACCESS POINTER!\] FPOS0D: MOVEI A,(B) ;COME HERE FOR TWO-ARG CASE, PUSHJ P,NCONS ; MESSAGE IN C JRST FPOS0A FPOS0: MOVEI C,[SIXBIT \FILE NOT RANDOMLY ACCESSIBLE!\] SETZ A, ;HERE FOR ONE-ARG ERROR, MESSAGE IN C FPOS0A: MOVEI B,(AR1) PUSHJ P,XCONS MOVEI B,QFILEPOS UNLOCKI JRST XCIOL ;ONE-ARGUMENT CASE: GET FILE POSITION FPOS1: POP P,AR1 ;ARG IS FILE IFN SFA,[ JSP TT,XFOSP ;DO WE HAVE AN SFA? JRST FP1SF1 ;NOPE JRST FP1SF1 ;NOPE MOVEI A,(AR1) ;YES, CALL THE STREAM MOVEI B,QFILEPOS SETZ C, ;NO ARGS JRST ISTCSH FP1SF1: ] ;END IFN SFA PUSHJ P,FILOK ;DOES LOCKI SKIPGE F.FLEN(TT) JRST FPOS0 ;ERROR IF NOT RANDOMLY ACCESSIBLE SKIPGE D,F.FPOS(TT) JRST FPOS1A 10$ MOVE R,FB.HED(TT) ADD D,FB.BVC(TT) 10% SUB D,FB.CNT(TT) ;FOR BUFFERED FILES, ADJUST FOR COUNT 10$ SUB D,2(R) FPOS1A: TLNN TT,TTS SKIPN B,FI.BBC(TT) JRST FPOS2 TLZE B,-1 ;ALLOW FOR ANY BUFFERED BACK CHARS SUBI D,1 FPOS1C: JUMPE B,FPOS2 HRRZ B,(B) SA% SKIPLE D SA$ CAMLE D,FB.ROF(TT) ;FOR SAIL, MAY BE AS LOW AS RECORD OFFSET SOJA D,FPOS1C FPOS2: MOVE TT,D ;RETURN POSITION AS FIXNUM UNLOCKI JRST FIX1 ;TWO-ARGUMENT CASE: SET FILE POSITION FPOS5: POP P,B ;SECOND ARG IS T, NIL, OR FIXNUM POP P,AR1 ;FIRST IS FILE IFN SFA,[ JSP TT,XFOSP ;DO WE HAVE AN SFA? JRST FP5SF1 ;NOPE, CONTINUE JRST FP5SF1 ;NOPE MOVEI A,(B) ;LISTIFY THE ARG JSP T,%NCONS MOVEI C,(A) ;PASS IT AS THE ARG TO THE SFA MOVEI A,(AR1) ;THE SFA MOVEI B,QFILEPOS ;FILEPOS OPERATION JRST ISTCSH FP5SF1: ] ;END IFN SFA SETZ D, JUMPE B,FPOS5A ;NIL MEANS ABSOLUTE BEGINNING OF FILE CAIE B,TRUTH ;T MEANS END OF FILE JSP T,FXNV2 ;OTHERWISE A FIXNUM POSITION FPOS5A: PUSHJ P,FILOK ;DOES LOCKI, SAVES D 10$ TLNN TT,TTS.IO ;OUTPUT LOSES FOR D10 SKIPGE F.FLEN(TT) ;NOT RANDOMLY ACCESSIBLE? JRST FPOS0C SA% JUMPL D,FPOS0C ;FOR NON-SAIL, NEGATIVE POSITION ILLEGAL SA$ CAMGE D,FB.ROF(TT) ;FOR SAIL, MAY BE DOWN TO RECORD OFFSET SA$ JRST FPOS0C IFN ITS+D20,[ TLNN TT,TTS.IO JRST FPOS6 PUSH FXP,D PUSHJ P,IFORCE ;FORCE OUTPUT BUFFER POP FXP,D MOVE R,F.FPOS(TT) ;CALCULATE PRESENT FILE POSITION SKIPL F.MODE(TT) ADD R,FB.BVC(TT) SKIPL F.MODE(TT) SUB R,FB.CNT(TT) CAMLE R,F.FLEN(TT) ;ADJUST LENGTH UPWARD IF NECESSARY MOVEM R,F.FLEN(TT) FPOS6: ] ;END OF IFN ITS+D20 CAMLE D,F.FLEN(TT) JRST FPOS0C ;LOSE IF SPECIFIED POSITION GREATER THAN LENGTH SA$ CAIN B,NIL ;R IS BY DEFAULT 0, BUT FOR SAIL SA$ MOVE D,FB.ROF(TT) ; NIL MEANS USE THE RECORD OFFSET CAIN B,TRUTH MOVE D,F.FLEN(TT) IFE D10,[ TLNE TT,TTS.IO ;DETERMINE IF BYTE WE DESIRE IS IN THE BUFFER JRST FPOSZ ; IF AN INPUT FILE MOVE R,F.FPOS(TT) ;POSITION OF FIRST BYTE IN BUFFER CAMGE D,R ;IF TARGET TOO SMALL THEN MUST DO I/O JRST FPOSZ ADD R,FB.BVC(TT) ;ADD IN NUMBER OF BYTES IN THE BUFFER CAML D,R ;IF TARGET TOO LARGE THEN ALSO MUST DO I/O JRST FPOSZ MOVE R,F.FPOS(TT) ;IN RANGE, GET POS OF FIRST BYTE IN BUFFER SUBM D,R ;MAKE R INTO BYTE OFFSET INTO BUFFER MOVE D,FB.IBP(TT) ;RESTORE BYTE POINTER MOVEM D,FB.BP(TT) MOVE D,FB.BVC(TT) ;GET VALID NUMBER OF BYTES IN BUFFER SUBI D,(R) ;NUMBER OF BYTES REMAINING MOVEM D,FB.CNT(TT) ; IS THE NEW COUNT KAKI SKIPE R KAKI IBP FB.BP(TT) ;SKIP APPROPRIATE NUMBER OF BYTES KAKI SOJG R,.-1 KL ADJBP R,FB.BP(TT) KL MOVEM R,FB.BP(TT) SETZM FI.BBC(TT) ;CLEAR BUFFERED BACK CHARACTER JRST UNLKTRUE FPOSZ: ] ;END IFE D10 MOVEM D,F.FPOS(TT) IFN ITS,[ .CALL ACCESS ;SET FILE POSITION IOJRST 0,FPOS0D ;JUMP ON FAILURE ] ;END OF IFN ITS IFN D20,[ PUSH P,B CAME D,F.FLEN(TT) ;BE ULTRA CAUTIOUS SKIPA 2,D SETO 2, HRRZ 1,F.JFN(TT) SFPTR ;SET FILE POINTER IOJRST 0,FPOS0E POP P,B ] ;END OF IFN D20 IFN D10,[ IDIV D,FB.BFL(TT) ;DIVIDE FILE POSITION BY BUFFER LENGTH MOVE T,F.CHAN(TT) LSH T,27 TLO T,(USETI 0,0) HRRI T,1(D) ;BLOCKS ARE NUMBERED 1-ORIGIN XCT T ;POSITION FILE TO CORRECT BLOCK IMUL D,FB.BFL(TT) ;CALCUALTE F.FPOS MOVEM D,F.FPOS(TT) MOVE T,FB.HED(TT) SETZM 2(T) ;ZERO THE REMAINING BYTE COUNT HRLZI D,400000 ;NOW WE HAVE TO ZERO ALL USE BITS FPOS6C: HRRZ T,(T) ;GET POINTER TO NEXT BUFFER SKIPL (T) ;THIS ONE IN USE? JRST FPOS6B ;NOPE, SO WE ARE DONE XORM D,(T) ;CLEAR THE USE BIT JRST FPOS6C ;AND LOOP OVER ALL BUFFERS FPOS6B: ] ;END OF IFN D10 10% TLNE TT,TTS.IO 10% JRST FPOS6A SETZM FB.BVC(TT) SETZM FI.BBC(TT) ; SETZM FI.BBF(TT) ;NOT IMPLEMENTED YET FPOS6A: IFN ITS+D20,[ SKIPGE F.MODE(TT) JRST UNLKTRUE ;THAT'S ALL FOR SINGLE MODE FILES TLNE TT,TTS.IO JRST FPOS7 ;JUMP FOR OUTPUT FILES ] ;END OF IFN ITS+D20 MOVE T,TT 10$ PUSH FXP,R ;R HAS DESIRED BYTE WITHIN BLOCK PUSHJ P,$DEVBUF ;GET NEW INPUT BUFFER JFCL ;IGNORE EOF 10% JRST UNLKTRUE IFN D10,[ POP FXP,R MOVE TT,FB.HED(T) MOVN D,R ADDM D,2(TT) ;DECREASE COUNT BY NUMBER OF SKIPPED BYTES KAKI SKIPE R KAKI IBP 1(TT) ;SKIP APPROPRIATE NUMBER OF BYTES KAKI SOJG R,.-1 KL ;DUE TO TOPS-10 LOSSAGE, ADJBP WILL LEAVE BYTE POINTER ALIGNED INCORRECTLY. KL ; THEREFORE, TO GUARUNTEE CORRECT BIT ALIGNMENT, 1 IBP MUST BE DONE BY HAND KL JUMPLE R,UNLKTRUE KL IBP 1(TT) KL SOJLE R,UNLKTRUE KL ADJBP R,1(TT) KL MOVEM R,1(TT) ] ;END OF IFN D10 JRST UNLKTRUE IFN ITS+D20,[ FPOS7: JSP D,FORCE6 ;INITIALIZE OUTPUT POINTERS JRST UNLKTRUE ] ;END OF IFN ITS+D20 ;;; LENGTHF -- SUBR, 1 ARG, NCALLABLE ;;; RETURNS THE LENGTH OF AN OPEN FILE $LENWT: EXCH A,AR1 SFA% WTA [NOT A FILE - LENGTHF!] SFA$ WTA [NOT A FILE OR SFA - LENGTHF!] $LENGTHF: PUSH P,CFIX1 ;STANDARD ENTRY, RETURN FIXNUM ;ALTERNATE ENTRY, RETURN NUMBER IN TT EXCH A,AR1 ;FILE/SFA INTO AR1 JSP TT,XFOSP ;MUST BE EITHER JRST $LENWT IFN SFA,[ JRST $LENFL EXCH AR1,A JSP T,QIOSAV MOVEI B,Q$LENGTHF SETZ C, PUSHJ P,ISTCSH ;SHORT INTERNAL SFA CALL MOVE T,CFIX1 CAMN T,(P) ;WE WILL RETURN RESULTS IN A AND TT, SO NO NEED TO RECONS POPI P,1 JSP T,FXNV1 POPJ P, $LENFL: ] ;END IFN SFA EXCH A,AR1 MOVEI TT,F.FLEN ;GET FILE LENGTH MOVE TT,@TTSAR(A) POPJ P, ;RETURNS TO CFIX1 OR CPOPJ SUBTTL CONTROL-P CODES AND TTY INITIALIZATION ;;; PUSH A ^P CODE INTO A TTY FILE ARRAY IN AR1. ;;; THE CHARACTER TO FOLLOW THE ^P IS IN D. ;;; IF THE CHARACTER IS "H, "I, OR "V, THEN THE SECOND ;;; CHARACTER IS IN THE LEFT HALF OF D. ;;; CHARPOS, LINENUM, AND PAGEL ARE CORRECTLY UPDATED. ;;; I/O LOSSES DUE TO INTERRUPTS BETWEEN ^P AND THE ;;; NEXT CHARACTER ARE SCRUPULOUSLY AVOIDED. ;;; CLOBBERS T, TT, D, AND F. SAVES R (SEE RUB1C3). ;CNPCHK DOES A .5LOCKI. THEN SKIPS IF CAPABILITY EXITS. CNPCHK: .5LKTOPOPJ .SEE INTTYR .SEE CRSRP7 HLLOS NOQUIT IT% POPJ FLP, 20$ WARN [HOW TO GET TTY OPTIONS BITS INTO TT FOR CNPCOD?] IFN ITS,[ MOVE T,TTSAR(AR1) .CALL VAROPT ;GET TTYOPT INTO TT POPJ FLP, ;OH WELL, ASSUME NOTHING IS LEGAL XCT CNPOK-"A(D) ;IS THIS FUNCTION DOABLE? POPJ FLP, ;WOULD HAVE NO AFFECT ANYWAY SO JUST RETURN AOS (FLP) POPJ FLP, ] ;END OF IFN ITS CNPCOD: PUSHJ FLP,CNPCHK ;DOES A .5LOCKI. THEN SKIPS IF CAPABILITY EXITS JRST CZECHI ; BUT IF NOT EXISTS, THEN JUST FAILS TO SKIP CNPCUR: MOVE TT,F.MODE(T) PUSH FXP,D JUMPL TT,CNPCD1 .SEE FBT.CM IT% LERR [SIXBIT \LOSE ON BUFFERED FILES - CNPCOD!\] IFN ITS,[ MOVE TT,FB.CNT(T) SUBI TT,3 JUMPGE TT,CNPCD1 MOVE TT,T ;IF THERE ISN'T ROOM IN THE CURRENT BUFFER PUSHJ P,IFORCE ; FOR THE WHOLE ^P CODE SEQUENCE, FORCE MOVE T,TTSAR(AR1) ; OUT THE BUFFER TO AVOID TIMING ERRORS ] ;END OF IFN ITS CNPCD1: IT% JRST CZECHI 20$ WARN [HOW ACTUALLY TO DO THE TERMINAL CONTROL BY "CNPCOD"] IFN ITS,[ SETZM ATO.LC(T) ;IF USING ^P CODES, THEN FORGET WE DID LF MOVEI TT,^P ;OUTPUT A ^P PUSHJ P,TYOF6 HRRZ TT,(FXP) ;OUTPUT THE CHARACTER PUSHJ P,TYOF6 HLRZ TT,(FXP) JUMPE TT,CNPCD2 TRZ TT,400000 ;OUTPUT ANY ADDITIONAL MAGIC ARGUMENT PUSHJ P,TYOF6 CNPCD2: POP FXP,TT XCT CNPC9-"A(TT) ;ACCOUNT FOR THE EFFECTS OF THE ^P CODE .LOSE CNPC9: JRST CNP.A ;A ADVANCE TO FRESH LINE JRST CNP.B ;B MOVE BACK 1, WRAPAROUND JRST CNP.C ;C CLEAR SCREEN JRST CNP.D ;D MOVE DOWN, WRAPAROUND JRST CZECHI ;E CLEAR TO EOF JRST CNP.F ;F MOVE FORWARD 1, WRAPAROUND JFCL JRST CNP.H ;H SET HORIZONTAL POSITION JRST CNP.I ;I NEXT CHARACTER IS ONE-POSITION PRINTING CHAR JFCL JRST CZECHI ;K KILL CHARACTER UNDER CURSOR JRST CZECHI ;L CLEAR TO END OF LINE JRST CNP.M ;M GO INTO **MORE** STATE, THEN HOME UP JRST CZECHI ;N GO INTO **MORE** STATE JFCL JRST CZECHI ;P OUTPUT A ^P JRST CZECHI ;Q OUTPUT A ^C JRST CZECHI ;R RESTORE CURSOR POSITION JRST CZECHI ;S SAVE CURSOR POSITION JRST CNP.T ;T TOP OF SCREEN (HOME UP) JRST CNP.U ;U MOVE UP, WRAPPING AROUND JRST CNP.V ;V SET VERTICAL POSITION JFCL JRST CNP.X ;X BACKSPACE AND ERASE ONE CHAR JFCL JRST CNP.Z ;Z HOME DOWN JRST CNP.IL ;[ INSERT LINE ;BEWARE THE BRACKETS! JRST CNP.DL ;\ DELETE LINE JRST CZECHI ;] SAME AS L (OBSOLETE) JRST CZECHI ;^ INSERT CHARACTER JRST CZECHI ;_ DELETE CHARACTER VAROPT: SETZ SIXBIT \TTYVAR\ ,,F.CHAN(T) ;CHANNEL [SIXBIT \TTYOPT\] ;READ THE TTYOPT VARIABLE 402000,,TT ;RETURN RESULT INTO TT ;TABLE OF INSTRUCTIONS TO DETERMINE IF A ^P CODE IS DOABLE ON THE TERMINAL CNPOK: SKIPA ;A OK ON ALL TTY'S TLNN TT,%TOMVB ;B ON TTY'S THAT CAN DO IT DIRECTLY SKIPA ;C THIS HAS SOME AFFECT ON ALL TTY'S SKIPA ;D TLNN TT,%TOERS ;E REQUIRES %TOERS SKIPA ;F JFCL SKIPA ;H TLNN TT,%TOMVU ;I JFCL TLNN TT,%TOMVU ;K ASSUME ONLY ON DISPLAY TERMINALS TLNN TT,%TOERS ;L SKIPA ;M SKIPA ;N JFCL SKIPA ;P SKIPA ;Q TLNN TT,%TOMVU ;R MAKE SAME ASSUMPTION AS K AND S TLNN TT,%TOMVU ;S TLNN TT,%TOMVU ;T WHEREAS C IS MEANINGFUL FOR NON-DISPLAYS, I ; DO NOT FEEL THIS IS TLNN TT,%TOMVU ;U TLNN TT,%TOMVU ;V JFCL ;X TTY'S THAT CAN BACKSPACE AND DON'T OVERSTRIKE ; OR THAT CAN ERASE PUSHJ P,[TLNN TT,%TOMVB ;MUST BE ABLE TO BACK-UP POPJ P, TLNN TT,%TOERS ;IF CAN ERASE IS OK TLNN TT,%TOOVR ;OR IF DOESN'T OVERSTRIKE AOS (P) POPJ P,] JFCL TLNN TT,%TOMVU ;Z SAME CRITERIA AS ^PT TLNN TT,%TOLID ;[ TLNN TT,%TOLID ;\ TLNN TT,%TOERS ;] SAME AS ^PL TLNN TT,%TOCID ;^ TLNN TT,%TOCID ;_ ;; WARN [CURSORPOS S AND R SHOULD SAVE AND RESTORE POSITION INFO FOR TTY] ;;; STILL WITHIN AN IFN ITS CNP.X: ;SAME AS ^P K ^P B CNP.B: MOVE D,FO.LNL(T) ;MOVE BACKWARDS SUBI D,1 SOSGE AT.CHS(T) ;WRAP AROUND IF AT LEFT MARGIN MOVEM D,AT.CHS(T) JRST CZECHI CNP.M: ;DOES **MORE**, THEN HOMES UP CNP.C: AOS AT.PGN(T) ;CLEAR SCREEN - AOS PAGENUM CNP.T: SETZM AT.LNN(T) ;HOME UP - CLEAR LINENUM AND CHARPOS CNP.IL: ;INSERT LINE - CLEAR CHARPOS CNP.DL: ;DELETE LINE - CLEAR CHARPOS SETZM AT.CHS(T) JRST CZECHI CNP.A: SKIPN AT.CHS(T) ;CRLF, UNLESS AT START OF LINE JRST CZECHI SETZM AT.CHS(T) ;CLEAR CHARPOS, THEN INCR LINENUM CNP.D: AOS D,AT.LNN(T) ;MOVE DOWN CAML D,FO.PGL(T) ;WRAP AROUND OFF BOTTOM TO TOP SETZM AT.LNN(T) JRST CZECHI CNP.F: AOS D,AT.CHS(T) ;MOVE FORWARD - WRAP AROUND CAML D,FO.LNL(T) ; OFF END TO LEFT MARGIN SETZM AT.CHS(T) JRST CZECHI CNP.H: HLRZ D,TT ;SET HORIZONTAL POSITION TRZ D,400000 ;CLEAR LISP'S FLAG (IF PRESENT) SUBI D,7 ;ACCOUNT FOR ITS'S 8 SKIPGE FO.LNL(T) ;IF NEGATIVE, THEN ASSUME C(D) IS ACTUAL HPOS JRST CNP.H1 CAMLE D,FO.LNL(T) ;PUT ON RIGHT MARGIN IF TOO BIG MOVE D,FO.LNL(T) CNP.H1: SUBI D,1 MOVEM D,AT.CHS(T) JRST CZECHI CNP.I: AOS AT.CHS(T) ;NOT REALLY THE RIGHT THING, BUT CLOSE JRST CZECHI CNP.Z: SETZM AT.LNN(T) ;HOME DOWN (GO UP FROM TOP!) CNP.U: MOVE D,FO.RPL(T) ;MOVE UP SUBI D,1 ;WRAP AROUND FROM TOP TO BOTTOM SOSGE AT.LNN(T) ; USING "REAL" PAGE LENGTH MOVEM D,AT.LNN(T) JRST CZECHI CNP.V: HLRZ D,TT ;SET VERTICAL POSITION SUBI D,7 ;IF TOO LARGE, PUT ON BOTTOM CAMLE D,FO.RPL(T) MOVE D,FO.RPL(T) SUBI D,1 MOVEM D,AT.LNN(T) JRST CZECHI ;;; VARIOUS ROUTINES FOR PRINTING ^P CODES CNPBBL: MOVEI D,"B PUSHJ P,CNPCOD CNPBL: MOVEI D,"B PUSHJ P,CNPCOD CNPL: MOVEI D,"L JRST CNPCOD CNPU: MOVEI D,"U JRST CNPCOD CNPF: MOVEI D,"F JRST CNPCOD CLRSRN: MOVEI D,"C JRST CNPCOD ] ;END OF IFN ITS 20$ CLRSRN: POPJ P, ;PUNT THIS FOR NOW ;;; ROUTINE FOR OPENING UP THE INITIAL TTY FILE ARRAYS. ;;; SKIPS ON SUCCESS (FAILS IF THIS JOB NEVER HAD THE TTY). OPNTTY: IFN ITS,[ .SUSET [.RTTY,,T] ;GET .TTY USER VARIABLE TLNE T,%TBWAT ;IF SUPERIOR SET %TBWAT, IT CERTAINLY JRST OPNT0 ; ANTICIPATES OUR OPENING TTY - LET'S OBLIGE TLNE T,%TBNOT ;ELSE DON'T OPEN IF WE DON'T HAVE THE TTY POPJ P, OPNT0: ] ;END OF IFN ITS ;;; 20$ WARN [SHOULD WE NOT OPEN TTY IF DETACHED, OR CHECK .PRIIN?] AOS (P) HRRZ A,V%TYO MOVEI TT,FO.EOP PUSH P,@TTSAR(A) PUSH P,[OPNT1] ;OPEN UP TTY OUTPUT ARRAY PUSH P,A MOVNI T,1 JRST $OPEN OPNT1: MOVEI AR1,(A) POP P,A MOVEI TT,FO.EOP MOVEM A,@TTSAR(AR1) MOVEI TT,FO.LNL MOVE TT,@TTSAR(AR1) MOVEM TT,DLINEL ;SET UP DEFAULT LINEL FROM INITIAL JOB CONSOLE MOVEI TT,FO.PGL MOVE TT,@TTSAR(AR1) MOVEM TT,DPAGEL ;SET UP DEFAULT PAGEL " PUSH P,[OPNT1A] PUSH P,AR1 MOVNI T,1 JRST STTYTYPE OPNT1A: MOVEM A,VTTY ;INITIALIZE "TTY" TO (STATUS TTYTYPE) HRRZ A,V%TYI MOVEI TT,TI.BFN PUSH P,@TTSAR(A) IFN ITS+D20+SAIL,[ MOVEI TT,TI.ST1 PUSH FXP,@TTSAR(A) MOVEI TT,TI.ST2 PUSH FXP,@TTSAR(A) IFE ITS,[ MOVEI TT,TI.ST3 PUSH FXP,@TTSAR(A) MOVEI TT,TI.ST4 PUSH FXP,@TTSAR(A) ] ;END OF IFE ITS ] ;END OF IFN ITS+D20+SAIL PUSH P,COPNT2 ;OPEN UP TTY INPUT ARRAY PUSH P,V%TYI MOVNI T,1 JRST $OPEN OPNT2: IFN ITS+D20+SAIL,[ IT% POP FXP,T IT% POP FXP,F POP FXP,R ;BEWARE THE LOCKI WORD! POP FXP,D ] ;END OF IFN ITS+D20+SAIL LOCKI MOVE TT,TTSAR(A) POP P,TI.BFN(TT) IFN ITS+D20+SAIL,[ MOVEM D,TI.ST1(TT) MOVEM R,TI.ST2(TT) IT% MOVEM F,TI.ST3(TT) IT% MOVEM T,TI.ST4(TT) IT$ .CALL TTY2ST IT$ .LOSE 1400 SA$ MOVEI T,TI.ST1(TT) SA$ SETACT T IFN D20,[ HRRZ 1,F.JFN(TT) MOVE 2,TI.ST1(TT) MOVE 3,TI.ST2(TT) SFCOC HRRZ 1,F.JFN(TT) RFMOD IOR 2,TI.ST3(TT) HRRZ 1,F.JFN(TT) SFMOD SETZB 2,3 ] ;END OF IFN D20 ] ;END OF IFN ITS+D20+SAIL UNLOCKI HRRZ A,V%TYI HRRZ B,V%TYO PUSHJ P,SSTTYCONS ;CONS THEM TOGETHER AS CONSOLE COPNT2: POPJ P,OPNT2 SUBTTL CLEAR-INPUT, CLEAR-OUTPUT ;;; (CLEAR-INPUT X) CLEARS ANY PENDING INPUT. ;;; CURRENTLY ONLY EFFECTIVE FOR TTY'S. CLRIN: PUSH P,AR1 ;SUBR 1 MOVEI AR1,(A) IFN SFA,[ JSP TT,XFOSP ;Check for maybe a SFA JFCL ; not file or SFA, OFILOK errs CAIA ; FILE, fall through JRST CLRISF ; Go tell the SFA how. ] PUSHJ P,IFILOK ;MAKE SURE ARGUMENT IS AN INPUT FILE TLNE TT,TTS.TY PUSHJ FXP,CLRI3 ;IF A TTY, CLEAR ITS INPUT JRST $OUT1 CLRI3: IFN ITS,[ .CALL CLRIN9 ;RESET TTY INPUT AT ITS LEVEL .LOSE 1400 ] ;END OF IFN ITS IFN D10,[ MOVE D,F.DEV(TT) CAMN D,[SIXBIT \TTY\] CLRBFI ] ;END OF IFN D10 IFN D20,[ PUSH P,A HRRZ 1,F.JFN(TT) CFIBF ;CLEAR FILE INPUT BUFFER POP P,A ] ;END OF IFN D20 SETZM FI.BBC(TT) ;CLEAR BUFFERED-BACK CHARS ; SETZM FI.BBF(TT) ;CLEAR BUFFERED-BACK FORMS POPJ FXP, IFN ITS,[ CLRIN9: SETZ SIXBIT \RESET\ ;RESET I/O CHANNEL 400000,,F.CHAN(TT) ;CHANNEL # ] ;END OF IFN ITS ;;; (CLEAR-OUTPUT X) CLEARS ANY OUTPUT NOT ACTUALLY ON ;;; THE OUTPUT DEVICE YET. CURRENTLY ONLY EFFECTIVE FOR TTY'S. CLROUT: PUSH P,AR1 ;SUBR 1 MOVEI AR1,(A) IFN SFA,[ JSP TT,XFOSP ;Check for maybe a SFA JFCL ; not file or SFA, OFILOK errs CAIA ; FILE, fall through JRST CLROSF ; Go tell the SFA how. ] ;End IFN SFA, PUSHJ P,OFILOK TLNE TT,TTS ;SKIP IF TTY PUSHJ FXP,CLRO3 JRST $OUT1 IFN SFA,[ CLROSF: SKIPA T,[SO.OCL] ;CLEAR-OUTPUT CLRISF: MOVEI T,SO.ICL ; CLEAR-INPUT SETZ C, ;Arg of () PUSHJ P,ISTCAL ;pass the buck to the SFA POP P,AR1 ;And return, unlocking etc. POPJ P, ]; End IFN SFA, CLRO3: IFN ITS,[ .CALL CLRIN9 ;RESET CHANNEL .LOSE 1400 CLRO4: .CALL RCPOS1 ;RESET CHARPOS AND LINEL .LOSE 1400 HLL T,F.MODE(TT) TLNE T,FBT.EC MOVE D,R ;FOR ECHO MODE, USE ECHO MODE CURSORPOS HLRZM D,AT.LNN(TT) HRRZM D,AT.CHS(TT) ] ;END OF IFN ITS IFN D10,[ MOVE D,F.DEV(TT) CAMN D,[SIXBIT \TTY\] CLRBFO ] ;END OF IFN D10 IFN D20,[ PUSH P,A HRRZ 1,F.JFN(TT) CFOBF ;CLEAR FILE OUTPUT BUFFER CAIA CLRO4: PUSH P,A PUSH P,B HRRZ 1,F.JFN(TT) RFPOS ;READ FILE POSITION HLRZM 2,AT.LNN(TT) ;STORE LINENUM HRRZM 2,AT.CHS(TT) ;STORE CHARPOS POP P,B POP P,A ] ;END OF IFN D20 10% PUSH FXP,T 10% TLNN T,FBT.CM ;IF BLOCK MODE, RESET 10% JSP D,FORCE6 ; LISP BUFFER POINTERS 10% POP FXP,T POPJ FXP, IFN ITS,[ RCPOS1: SETZ SIXBIT \RCPOS\ ;READ CURSOR POSITION ,,F.CHAN(TT) ;CHANNEL # 2000,,D ;MAIN CURSOR POSITION 402000,,R ;ECHO CURSOR POSITION ] ;END OF IFN ITS ;;; STANDARD **MORE** PROCESSOR TTYMOR: PUSHJ P,STTYCONS ;SUBR 1 JUMPE A,CPOPJ ;STTYCONS LEFT ARG IN AR1 PUSH P,AR1 PUSH P,A SETZ A, ;RESET NOINTERRUPT STATUS PUSHJ P,NOINTERRUPT ; SO INTERRUPT CHARS WILL TAKE EFFECT HRRZ AR1,-1(P) STRT AR1,[SIXBIT \####MORE####!\] ;# IS QUOTE CHAR TTYMO3: PUSH P,[TTYMO1] PUSH P,R70 PUSH P,-2(P) MOVNI T,2 JRST TYIPEEK+1 TTYMO1: PUSH P,[TTYMO2] PUSH P,-1(P) MOVNI T,1 CAILE TT,40 CAIN TT,177 JRST %TYI+1 ;SWALLOW SPACE OR RUBOUT POPI P,2 TTYMO2: CAIE TT,^S ;DON'T IGNORE ^S CAIN TT,33 ;OR JRST TTYMOZ CAIGE TT,40 ;COMPLETELY IGNORE CONTROL CHARS JRST TTYMO3 ? SA$ WARN [SAIL TTYMOR?] TTYMOZ: POPI P,1 POP P,AR1 IT% POPJ P, IFN ITS,[ MOVE D,[10,,"H] ;GO TO BEGINNING OF LINE PUSHJ P,CNPCOD PUSHJ P,CNPL ;CLEAR TO END OF LINE HRLI AR1,600000 ;FLAG TO TERPRI (THIS IS ACTUAL FILE ARRAY) JRST TERP1 ;DO SEMI-INTERNAL TERPRI ] ;END OF IFN ITS IFN SFA,[ SUBTTL SFA FUNCTIONS (INTERNAL AND USER) ; (SFA-CREATE ; ; ) STCREA: SKOTT A,LS\SY JRST STCRE1 ;HERE TO CREATE A NEW SFA: SFA-FUNCTION IN A, LISP FIXNUM IN B STCREN: SKOTT B,FX ;FIXNUM AS SECOND ARG? JRST STCRE2 ;NOPE, ERROR PUSH P,A PUSH P,B PUSH P,C MOVE TT,(B) ;GET THE LENGTH OF THE USER AREA ADDI TT,+1 ;TO INSURE GETTING ENOUGH HALFWORDS LSH TT,-1 ;THEN CONVERT TO NUMBER OF WORDS MOVSI A,-1 ;JUST NEED THE SAR PUSHJ P,MKLSAR ;GET A GC-PROTECTED ARRAY POP P,C LOCKI ;GOING TO HACK WITH THE ARRAY MOVE TT,TTSAR(A) ;POINTER TO THE ARRAY DATA AREA POP P,B ;LENGTH OF THE USER DATA AREA MOVE T,(B) MOVEM T,SR.UDL(TT) ;REMEMBER LENGTH OF USER DATA EXCH A,(P) ;RESTORE FUNCTION AND SAVE SAR ADR HRLI A,(CALL 3,) ;A CALL FUNCTION GOES IN UN-MARKED-FROM SLOT MOVEM A,SR.CAL(TT) ;STORE THE CALL INSTRUCTION HRRZM A,SR.FUN(TT) ;STORE THE FUNCTION HRRZM C,SR.PNA(TT) ;STORE THE PRINTNAME ROT T,-1 ;LENGTH OF USER AREA IN T SKIPGE T ;CONVERT INTO NUMBER OF WORDS NEEDED ADDI T,1 ADDI T,SR.LEN-SR.FML ;NUMBER OF SYSTEM WORDS MARKED MOVNI R,(T) ;NUMBER OF WORDS TO MARK HRLZI R,(R) ;IN LEFT HALF HRRI R,SR.FML(TT) ;POINTER TO FIRST MARKED LOCATION IN RH HRRZ D,@(P) ;GET SAR MOVEM R,-1(D) ;STORE GC MARKING AOBJN POINTER HRLZI TT,AS.SFA ;TURN THE ARRAY INTO AN SFA IORM TT,@(P) ;TURN ON SFA BIT IN THE SAR UNLOCKI ;ALLOW INTERRUPTS AGAIN ;THE FOLLOWING CODE SIMULATES: ; (SFA-CALL 'WHICH-OPERATIONS NIL) HRRZ A,(P) ;FIRST ARG TO SFA IS SFA-OBJCT ITSELF MOVEI B,QWOP ;WHICH-OPERATIONS SETZ C, ;NO THIRD ARG MOVEI TT,SR.CAL ;CALL INSTRUCTION SLOT XCT @TTSAR(A) ;DO CALL INDIRECTLY THROUGH TTSAR JUMPE A,STCRE3 ;THE SFA CAN'T DO ANYTHING, BUT WHY WORRY... SKOTT A,LS ;BETTER HAVE GOTTEN A LIST BACK JRST SCREBS ;BAD SFA IF DIDN'T GET BACK A LIST! STMASK: SETZ F, ;F ACCUMLATES KNOWN SYSTEM OPERATIONS MASK STCRE4: MOVE R,[-STKNOL,,STKNOT] ;AOBJN POINTER OVER KNOWN OPERATIONS HLRZ B,(A) ;CAR IS THE OPERATION STCRE5: HRRZ T,(R) ;KNOWN OPERATIOON CAIE T,(B) ;MATCH? JRST STCRE6 ;NOPE, KEEP LOOPING HRRZ T,R ;GET POINTER HLLZ TT,(R) ;GET MASK CAIL T,STKNOT+18. ;LEFT HALF VALUE? MOVSS TT ;NOPE, ASSUMED WRONG TDOA F,TT ;ACCUMLATE THIS OPERATION AND EXIT LOOP STCRE6: AOBJN R,STCRE5 ;CONTINUE LOOPING UNTIL ALL LOOPED OUT HRRZ A,(A) ;CDR DOWN THE WHICH-OPERATIONS LIST JUMPN A,STCRE4 ;DON'T JUMP IF DON'T HAVE TO STCRE3: POP P,A ;POINTER TO SAR MOVEI TT,SR.WOM ;POINT TO KNOWN OPERATIONS MASK MOVEM F,@TTSAR(A) ;STORE IN ARRAY POPJ P, ;THEN RETURN SAR STCRE2: EXCH B,A ;C(B) WAS NOT A FIXNUM WTA [FIRST ARG MUST BE A FIXNUM -- SFA-CREATE!] EXCH B,A JRST STCREN SCREBS: FAC [WAS RETURNED FROM WHICH-OPERATIONS BUT SHOULD HAVE BEEN A LIST -- SFA-CREATE!] STCRE1: FAC [CALLED WITH SFA, NOT IMPLIMENTED -- SFA-CREATE!] ;SFA OPERATION/INTERNAL BIT CORRESPONDANCE TABLE STKNOT: ;LH BITS SO.OPN,,Q$OPEN SO.CLO,,Q$CLOSE SO.REN,,Q$RENAMEF SO.DEL,,Q$DELETEF SO.TRP,,Q%TERPRI SO.PR1,,Q%PR1 SO.TYI,,Q%TYI SO.UNT,,QUNTYI SO.TIP,,QTYIPEEK SO.IN,,Q$IN SO.EOF,,QEOFFN SO.TYO,,Q%TYO SO.PRO,,Q%PRO SO.FOU,,QFORCE SO.RED,,QOREAD SO.RDL,,Q%READLINE SO.PRT,,Q%PRINT SO.PRC,,Q%PRC ;RH BITS SO.MOD,,QFILEMODE SO.POS,,QFILEPOS SO.ICL,,QCLRIN SO.OCL,,QCLROUT SO.OUT,,Q$OUT STKNOL==:.-STKNOT ;LENGTH OF TABLE ;;; (SFA-CALL ) STCAL1: WTA [SHOULD BE AN SFA OBJECT -- SFA-CALL!] STCALL: SKOTT A,SA ;MUST BE AN ARRAY HEADER JRST STCAL1 HRLZI TT,AS.SFA ;NOW CHECK FOR SFA-NESS TDNN TT,ASAR(A) JRST STCAL1 ;AN ARRAY BUT NOT A REAL SFA MOVEI TT,SR.CAL XCT @TTSAR(A) ;INVOKE THE SFA POPJ P, ;INTERNAL SFA CALL, BIT INDICATNG OP IN T, SFA-OBJECT IN AR1, ; THIRD ARG TO SFA IN C. RETURNS VALUE OF SFA IN A. DESTORYS ALL ; ACS. ISTCAL: JFFO T,ISTCA0 ;MUST HAVE ONE BIT SET LERR [SIXBIT \+INTERNAL-SFA-CALL CALLED WITH NO OP IN T!\] ISTCA0: HRRZ B,STKNOT(TT) ;GET SYMBOL REPRESENTING OPERATION MOVEI A,(AR1) ;SFA GETS ITSELF AS FIRST ARG MOVEI TT,SR.WOM ;CHECK FOR LEGAL OP -- USE WHICH OP MASK TDNN T,@TTSAR(A) ;MAKE SURE THIS INTERNAL OP IS DOABLE JRST ISTCA1 ;ENTER HERE FOR 'SHORT' INTERNAL CALL PROTOCOL, A, B, AND C SET UP CORRECTLY ISTCSH: MOVEI TT,SR.CAL ;EXECUTE THE CALL TO THE SFA XCT @TTSAR(A) POPJ P, ;RETURN TO CALLER WITH RESULT IN A ISTCA1: PUSH P,[ISTCA2] ;RETURN ADDRESS PUSH P,A ;LISTIFY IMPORTANT INFO PUSH P,B PUSH P,C MOVNI T,3 ;3 ARGS JRST LIST ;DO IT! ISTCA2: FAC [ATTEMPT TO INVOKE SFA ON AN UNSUPPORTED OPERATION -- +INTERNAL-SFA-CALL!] ;;; (SFAP ) RETURNS T IF IS AN SFA, ELSE NIL STPRED: JSP TT,AFOSP ;CHECK IF A FILE OR SFA JRST FALSE ;NEITHER, RETURN NIL JRST FALSE ;FILE, RETURN FALSE JRST TRUE ;SFA, RETURN TRUE ;;; (SFA-GET ) ;;; (SFA-STORE ) STSTOR: SKIPA F,[STSTOD] ;SFA-STORE DISPATCH TABLE STGET: MOVEI F,STGETD ;SFA-GET DISPATCH TABLE SKIPA STDISW: WTA [NOT AN SFA -- SFA-GET/SFA-STORE!] JSP TT,AFOSP ;INSURE WE HAVE AN SFA, A ==> AR1 JRST STDISW ;NOT AN SFA JRST STDISW ;A FILE-OBJECT, BUT STILL NOT AN SFA SKOTT B,FX ;FIXNUM AS SECOND ARG? JRST STDIS1 ;NOPE, MUST BE A SYSTEM-LOCATION NAME MOVE R,(B) ;GET THE ACTUAL FIXNUM MOVEI TT,SR.UDL ;CHECK AGAINST THE MAXIMUM VALUE CAML R,@TTSAR(AR1) ;IN RANGE? JRST STDIOB ;NOPE, GIVE OUT-OF-BOUNDS CALL ROT R,-1 ;MAKE INTO AN OFFSET AND A FLAG BIT (RH/LH) JRST @-1(F) ;GIVE USER LOCATION ACCESS RETURN STDIOB: EXCH A,B ;GIVE AN OUT-OF-BOUNDS ERROR FAC [USER-INDEX OUT-OF-BOUNDS -- SFA-GET/SFA-STORE!] STDIS1: MOVE T,[-STRSLN,,0] ;FIND SYS-LOC THAT 2ND ARG IS EQ TO STDIS2: CAME B,STSYSL(T) ;MATCH THIS ENTRY? AOBJN T,STDIS2 ;NOPE, CONTINUE THE LOOP ADDI T,(F) ;MAKE CORRECT TABLE ADDRESS SKIPGE T ;BUT DID WE REALY FIND A MATCH? JRST @(T) ;YES, SO DISPATCH EXCH A,B FAC [ILLEGAL SYSTEM-LOCATION NAME -- SFA-GET/SFA-STORE!] ;SFA SYSTEM-NAME TABLE STSYSL: QFUNCTION ;FUNCTION QWOP ;WHICH-OPERATIONS QPNAME ;PNAME STRSLN==:.-STSYSL ;SFA-GET DISPATCH TABLE AND FUNCTIONS STGETU ;USER LOCATION STGETD: STGFUN ;FUNCTION STGWOM ;OPERATIONS MASK STGPNA ;PRINT NAME STGETU: MOVEI TT,SR.FUS(R) ;INDEX INTO ARRAY HLRZ A,@TTSAR(AR1) ;TRY THE LEFT HALF SKIPGE R ;BUT IS IT THE RIGHT HALF? HRRZ A,@TTSAR(AR1) ;YUP, SO FETCH THAT POPJ P, ;RETURN SLOT'S VALUE STGPNA: SKIPA TT,[SR.PNA] ;RETURN THE PNAME STGFUN: MOVEI TT,SR.FUN ;RETURN THE FUNCTION HRRZ A,@TTSAR(AR1) POPJ P, STGWOM: MOVEI TT,SR.WOM ;RETURN THE WHICH-OPERATIONS MASK MOVE D,@TTSAR(AR1) ;GET THE MACHINE NUMBER AND CONS UP A FIXNUM SETZ A, ;START OFF WITH NIL STGWO1: JFFO D,STGWO2 ;ANY MORE LEFT TO DO? POPJ P, ;NOPE, RETURN WITH CONSED UP LIST IN A STGWO2: HRRZ B,STKNOT(R) ;GET ATOM CORRESPONDING TO MASK BIT JSP T,%XCONS ;ADD TO THE HEAD OF THE LIST HRLZI T,400000 ;NOW TURN OFF THE BIT WE JUST HACKED MOVNS R ;MUST NEGATE TO ROTATE ROT T,(R) ;SHIFT INTO CORRECT BIT POSITION TDZ D,T ;TURN OFF THE BIT JRST STGWO1 ;AND DO THE REMAINING BITS ;SFA-STORE DISPATCH TABLE AND ROUTINES STSTOU ;USER LOCATION STSTOD: STSFUN ;FUNCTION STSWOM ;OPERATIONS MASK STSPNA ;PRINT NAME STSTOU: MOVEI A,(C) ;PDLNMK THE THING WE ARE GOING TO STORE JSP T,PDLNMK MOVEI TT,SR.FUS(R) ;INDEX INTO ARRAY JUMPL R,STSTU1 ;RIGHT HALF HRLM A,@TTSAR(AR1) ;STORE IN THE LEFT HALF POPJ P, ;RETURN SLOT'S VALUE STSTU1: HRRM A,@TTSAR(AR1) ;LEFT HALF POPJ P, STSPNA: SKIPA TT,[SR.PNA] ;STORE THE PNAME STSFUN: MOVEI TT,SR.FUN ;STORE THE FUNCTION HRRZM C,@TTSAR(AR1) MOVEI A,(C) ;RETURN THE STORED VALUE CAIE TT,SR.FUN ;WERE WE HACKING THE FUNCTION? POPJ P, ;NO, SO WE ARE DOINE HRLI C,(CALL 3,) ;WE MUST ALSO FIX THE CALL INSTRUCTION MOVEI TT,SR.CAL MOVEM C,@TTSAR(AR1) POPJ P, STSWO1: EXCH A,C WTA [MUST BE A LIST -- SFA-STORE (WHICH-OPERATIONS)!] EXCH A,C STSWOM: SKOTT C,LS ;IS THE ARGUMENT A LIST? JRST STSWO1 ;NOPE, WRONG TYPE ARG ERROR PUSH P,AR1 ;SAVE THE SFA FOR STMASK ROUTINE MOVEI A,(C) ;EXPECTS WHICH-OPERATIONS LIST IN A JRST STMASK ;THEN GENERATE A NEW MASK AND RETURN ] ;END IFN SFA PGTOP QIO,[NEW I/O PACKAGE] ;;@ END OF QIO 651 SUBTTL INTERRUPT HANDLERS PGBOT INT IFN ITS,[ PIHOLD: .SPICLR,,R70 ;WORD TO ".SUSET" TO TURN OFF INTERRUPT SYSTEM PINBL: .SPICLR,,XC-1 ;WORD TO ".SUSET" TO TURN ON INTERRUPT SYSTEM ;;; NEW-STYLE INTERRUPT TRANSFER VECTOR .SEE IMASK ;;; STANDARD VALUES TO PUT IN .MASK AND .MSK2 USER VARIABLES. ;;; INTERRUPTS NORMALLY ENABLED ARE: ;;; PARITY ERROR ;;; WRITE INTO READ-ONLY MEMORY ;;; MEMORY PROTECTION VIOLATION ;;; ILLEGAL OPERATION ;;; PDL OVERFLOW ;;; I/O CHANNEL ERROR ;;; RUN TIME CLOCK ;;; REAL TIME CLOCK ;;; ALSO, FOR THE USELESS SWITCH: ;;; CLI DEVICE INTERRUPT ;;; SYSTEM GOING DOWN/REVIVED ;;; SYSTEM BEING DEBUGGED ;;; CONTROL OF TTY JUST GIVEN BACK TO LISP ;;; (SSTATUS MAR) MAY ALSO ENABLE THE MAR INTERRUPT .SEE SSMAR STDMSK=%PIPAR+%PIWRO+%PIMPV+%PIILO+%PIPDL+%PIIOC+%PIRUN+%PIRLT IFN USELESS, STDMSK=STDMSK+%PIDWN+%PIDBG+%PIATY DBGMSK=STDMSK-<%PIPAR+%PIMPV+%PIILO+%PIATY> ;;; ALL I/O CHANNELS ARE ENABLED, AND ALL JOB CHANNELS FOR USELESS SWITCH. STDMS2==177777 IFN JOBQIO, STDMS2==STDMS2+<377,,> DBGMS2==STDMS2 DEFINE INTGRP HANDLER+PIRQC=0,IFPIR=0,DF1=STDMSK+%PIMAR-<%PIPDL+%PIPAR+%PIWRO+%PIMPV+%PIILO>,DF2=STDMS2 PIRQC IFPIR DF1 DF2 HANDLER TERMIN INTVEC: D_6+3,,INTPDL ;PDL FOR PUSHING INTERRUPT STUFF ;ACS D, R, F ARE SAVED ALONG WITH OTHER CRUD INTGRP MEMERR,PIRQC=%PIPAR+%PIWRO+%PIMPV+%PIILO,DF1=STDMSK+%PIMAR-%PIPDL ;MEMORY AND OPCODE ERRORS INTGRP PDLOV,PIRQC=%PIPDL ;PDL OVERFLOW INTGRP IOCERR,PIRQC=%PIIOC ;I/O CHANNEL ERROR IFN USELESS, INTGRP CLIINT,PIRQC=%PICLI ;CLI INTERRUPT IFN USELESS, INTGRP TTRINT,PIRQC=%PIATY ;TTY RETURNED TO JOB IFN USELESS, INTGRP SYSINT,PIRQC=%PIDWN+%PIDBG ;SYS DOWN OR BEING DEBUGGED IFN JOBQIO, INTGRP JOBINT,IFPIR=[377,,] ;INFERIOR PROCEDURES INTGRP CHNINT,IFPIR=177777 ;I/O CHANNEL INTERRUPTS TTYDF1==:.-3 .SEE UINT0 TTYDF2==:.-2 IFN USELESS, INTGRP MARINT,PIRQC=%PIMAR ;MAR BREAK INTGRP RUNCLOCK,PIRQC=%PIRUN ;RUNTIME ALARMCLOCK INTGRP REALCLOCK,PIRQC=%PIRLT ;REAL TIME ALARMCLOCK LINTVEC==:.-INTVEC ;LENGTH OF INTERRUPT VECTOR ;;; NOTE THE EFFECT OF HAVING THE ALARMCLOCKS LAST: ;;; IOC AND CHANNEL INTERRUPT HAPPEN FIRST, BUT WHEN ;;; THE PION HAPPENS INSIDE UINT0 THE ALARMCLOCK GETS ;;; ITS TURN IMMEDIATELY. FURTHERMORE, THE REAL TIME ;;; CLOCK GETS SLIGHTLY HIGHER PRECEDENCE. ] ;END OF IFN ITS IFN D20,[ ;;; TOPS-20 INTERRUPT HANDLER ;;; INTERRUPTS NOMRALLY ENABLED ARE: ;;; PDL OVERFLOW ;;; ILLEGAL INSTRUCTION ;;; ILLEGAL MEMORY READ ;;; ILLEGAL MEMORY WRITE ;;; NONEXISTANT PAGE REFERENCE ;;; VARIOUS CHARACTERS ENABLED FOR INTERRUPTS: ;;; ^A, ^B, ^D, ^E, ^F, ^G, ^V, ^W, ^X, ^Z ;;; CHANNEL ASSIGNMENTS: ;;; 1) PDL OV ;;; 2) ILLEGAL INSTRUCTION, ILL MEM R & W, OTHER SYNC INTERRUPTS ;;; 3) ASYNCHRONOUS INTERRUPTS DISMSK==0 ;GENERATE IMPORTANT INTERRUPTS MASK IRP FOO,,[.ICPOV,.ICILI,.ICIRD,.ICIWR,.ICNXP] DISMSK==DISMSK+<1_<35.-FOO>> TERMIN STDMSK==DISMSK ;GENERATE STANDARD INTERRUPT MASK IRP FOO,,[.ICDAE] STDMSK==STDMSK+<1_<35.-FOO>> TERMIN STDMSK==STDMSK+<770000,,007777> ;ALSO INCLUDE ALL USER ASSIGNABLE CHANNELS DBGMSK==STDMSK ;FOR NOW, MASKS ARE EQUIVALENT ;CHANNEL TABLE (ASSIGNS A PRIORITY LEVEL AND HANDLER ADR TO EACH CHANNEL) CHNTAB: REPEAT 6, 3,,INTASS+<.RPCNT*3> ;FIRST 6 ASSIGNABLE INTERRUPTS 0 ? 0 ? 0 ;ARITHMETIC OVERFLOWS 1,,$PDLOV ;PLDOV 0 ? 0 ;E-O-F AND DATA-ERROR 0 ? 0 ? 0 ;RESERVED TO DEC 2,,INTILO ;ILLEGAL INSTRUCTION 2,,INTIRD ;ILLEGAL MEMORY READ 2,,INTIWR ;ILLEGAL MEMORY WRITE 0 ? 0 ? 0 ? 0 ;RESERVED, AND ? 2,,INTNXP ;NON-EXISTANT PAGE 0 ; CHANNEL 23. LOSES! REPEAT CINTSZ-6, 3,,INTASS+<6+.RPCNT>*3 ;REMAINING ASSIGNABLE INTERRUPTS IFN .-CHNTAB-36., WARN [WRONG NUMBER ENTRIES IN CHNTAB?] ;LEVEL TABLE - WHERE TO STORE PC FOR INTERRUPT AT EACH PI LEVEL LEVTAB: 0,,INTPC1 0,,INTPC2 0,,INTPC3 ;;; TOPS-20 INTERRUPT HANDLING ROUTINES ;;; CALLED AT STARTUP TO REINITIALIZE THE INTERRUPT SYSTEM ENBINT: MOVEI 1,.FHSLF ;MANIPULATE OURSELVES MOVE 2,[LEVTAB,,CHNTAB] ;INTERRUPT PC STORAGE TAB,,CHANNEL LOC TAB SIR ;SPECIFY THE TABLES SETZ T, ;LOOP OVER AND ASSIGN TTY INTERRUPT CHANNELS ENBIN2: SKIPG 1,CINTAB(T) ;THIS ENTRY USED FOR TTY INTERRUPT? JRST ENBIN1 ;NOPE, GO ON MOVSS 1 ;CHARACTER GOES IN LEFT HALF HRRI 1,(T) ;CHANNEL IN RIGHT HALF CAIL T,6 ;RELOCTAION NECESSARY? ADDI 1,24.-6 ;YES, MAKE REAL CHANNEL NUMBER ATI ;ASSIGN TERMINAL INTERRUPT CHANNEL ENBIN1: CAIGE T,CINTSZ-1 ;DONE? AOJA T,ENBIN2 MOVEI 1,.FHSLF ;ENABLE APPROPRIATE CHANNELS MOVE 2,[STDMSK] ;ENABLE STANDARD INTERRUPTS MOVEM 2,IMASK ;THIS IS CURRENT INTERRUPT MASK MOVEM 2,OIMASK ;THIS IS ALSO THE OLD-MASK AIC MOVEI 1,.FHSLF ;ENABLE OUR INTERRUPT SYSTEM XCTPRO EIR SETZB 1,2 ;DON'T LEAVE RANDOMNESS IN PROTECTED ACS NOPRO POPJ P, ;REENABLES INTERRUPTS AFTER THEY HAVE BEEN DISABLED BY DALINT OR DISINT REAINT: PUSH P,1 PUSH P,2 XCTPRO AOSE INTALL ;DISABLED ALL INTS? SKIPA 2,OIMASK ;NO, USE OLD INTERRUPT MASK SKIPA 2,IMASK ;ELSE USE CURRENT MASK MOVEM 2,IMASK ;THIS IS NOW THE CURRENT MASK MOVEI 1,.FHSLF ;REENABLE INTERRUPTS FOR OURSELF AIC POP P,2 POP P,1 NOPRO POPJ P, ;THIS ROUTINE DISABLES ALL INTERRUPTS FROM OCCURING ;THE FLAG INTALL IS SET SAYING TO TELL THE RE-ENABLE ROUTINE TO RESTORE ; INTERRUPTS FROM IMASK RATHER THAN OIMASK WARN [THINK ABOUT USING 'DIR' FOR DALINT] DALINT: PUSH P,1 PUSH P,2 XCTPRO MOVEI 1,.FHSLF ;DEFER ALL INTERRUPTS SETO 2, DIC SETOM INTALL ;FLAG THAT ALL INTERRUPTS HAVE BEEN DISABLED POP P,2 POP P,1 NOPRO POPJ P, ;DISABLE ALL BUT IMPORTANT INTERRUPTS ;IMASK IS MOVED TO OIMASK, AND IMASK IS SETUP TO NEW CURRENT MASK VALUE DISINT: PUSH P,1 ;WE WILL NEED TWO WORKING ACS PUSH P,2 XCTPRO MOVE 2,IMASK ;GET CURRENT INTERRUPT MASK MOVEM 2,OIMASK ;UPDATE OLD MASK AND 2,[DISMSK] ;ONLY ALLOW IMPORTANT INTERRUPTS MOVEM 2,IMASK ;NEW MASK MOVEI 1,.FHSLF AIC ;MAKE SURE THE IMPORTANT INTERRUPTS ARE ON SETCA 2, DIC ;BUT ONLY THE IMPORTANT INTERRUPTS POP P,2 POP P,1 NOPRO POPJ P, ;;; DISMISS AN INTERRUPT DSMINT: XCTPRO AOS DSMSAV ;POINT TO NEXT FREE LOCATION (A SMALL STACK) MOVEM 1,@DSMSAV ;SAVE AC 1 MOVEI 1,.FHSLF ;TURN OFF SYSTEM INTS WHILE MUNGING INTPDL DIR MOVE 1,INTPDL ;NOW UNDO INTPDL POP 1,F POP 1,R POP 1,D POP 1,@-1(1) ;RESTORE RETURN PC SUB 1,R70+1 ;THROW AWAY RETURN PC POINTER POP 1,IMASK ;RESTORE OLD IMASK SUB 1,R70+2 MOVEM 1,INTPDL MOVEI 1,.FHSLF EIR ;NOW ALLOW INTERRUPTS MOVEI 1,.FHSLF AOS DSMSAV ;SAVE AC 2 ON TOP OF STACK MOVEM 2,@DSMSAV MOVE 2,IMASK ;TELL TOPS-20 ABOUT OLD IMASK AIC MOVE 2,@DSMSAV ;RESTORE AC'S SOS DSMSAV MOVE 1,@DSMSAV SOS DSMSAV NOPRO DEBRK ;THEN DISMISS THE CURRENT INTERRUPT ;;; INTPDL BUILDER: RETURNS INTPDL IN F, ACCEPTS PC POINTER ON FLP INTSUP: XCTPRO ;NEED PROTECTION AS WE WILL USE MARKED ACS MOVEM 1,SUPSAV ;SAVE NEEDED REGISTER MOVEI 1,.FHSLF ;TURN OFF THE INTERRUPT SYSTEM WHILE TOUCHING DIR ; INTPDL MOVE 1,INTPDL PUSH 1,NIL ;IPSWD1 AND IPSWD2 PUSH 1,NIL PUSH 1,IMASK ;IMASK UPON ENTRY PUSH 1,F ;SAVE THE PC POINTER HRRZS (1) ;BUT ONLY RH PUSH 1,(F) ;AND SAVE THE PC PUSH 1,D ;SAVE PRESERVED ACS PUSH 1,R HLRZS F ;RH NOW HAS ADR OF F PUSH 1,(F) ;SAVES F MOVE F,1 ;COPY OF INTPDL TO F MOVEM F,INTPDL ;SAVE INTPDL MOVEI 1,.FHSLF ;REEANBLE INTERRUPTS EIR MOVE 1,SUPSAV NOPRO JRST (T) ;RETURN TO CALLER ;;; THE ACTUAL INTERRUPT HANDLERS ;PDL OVERFLOW $PDLOV: MOVEM T,PDLSVT ;SAVE T SO THAT WE HAVE AN AC TO USE MOVE T,INTPDL ;FUDGE INTPDL STACK FRAME PUSH T,NIL ;IPSWD1 AND IPSWD2 UNUSED PUSH T,NIL PUSH T,IMASK ;SAVE IMASK UPON ENTRY PUSH T,LEVTAB ;RH IS INTERRUPT PC ADR, @ AND () FIELDS OFF PUSH T,@LEVTAB ;SAVE PC PUSH T,D PUSH T,R PUSH T,F MOVEM T,INTPDL ;STORE NEW INTPDL POINTER MOVE T,PDLSVT ;RESTORE AC T JRST PDLOV ;THEN PROCESS PDL OV ;;; PRIORITY LEVEL 2 INTERRUPT HANDLERS ;INTERRUPT AFTER NEWLY CREATED PAGE INTNXP: MOVEM T,LV2SVT MOVE T,@LEVTAB+1 HLRZ T,(T) ;GET THE INSTRUCTION THAT CAUSED THE GRIEF TRZ T,000037 ;ANY INDEX OR INDIRECTION IS OK CAIE T,(SETMM) ;SPECIAL WAY TO CREATE A PAGE, SO ALL IS OK JRST INTMPV ;OTHERWISE IS BAD NEWS MOVE T,LV2SVT ;ELSE RESTORE T DEBRK ;AND RETURN INSTANTLY ;ILLEGAL MEMORY READ INTIRD: MOVEM T,LV2SVT ;TREAT ILLEGAL MEMORY READ AS MPV ;HERE ON MEMORY PROTECTION VIOLATION, T SAVED ON FXP INTMPV: MOVEI T,%PIMPV ;TURN INTO AN MPV JRST INTMER ;AND TREAT LIKE OTHER MEMORY ERRORS ;ILLEGAL MEMORY WRITE INTIWR: MOVEM T,LV2SVT MOVSI T,(%PIWRO) ;WRITE INTO READ-ONLY MEMORY JRST INTMER ;ILLEGAL OP INTILO: MOVEM T,LV2SVT MOVEI T,%PIILO ;ILLEGAL OPERATION ;COMMON MEMORY ERROR HANDLER, T IS PUSHED ON FXP AND CONTAINS THE ERROR BIT ;FUDGE INTPDL AND JRST OFF TO MEMERR INTMER: MOVEM F,LV2SVF ;SAVE F IN KNOWN PLACE MOVEM T,LV2ST2 ;ALSO SAVE FLAGS MOVE F,[LV2SVF,,INTPC2] ;WHERE F IS,,WHERE PC IS JSP T,INTSUP ;SETUP INTPDL, RETURN INTPDL IN F MOVE T,LV2ST2 ;GET BACK FLAG BITS MOVEM T,IPSWD1(F) ;STORE MEMORY ERROR BITS MOVE T,LV2SVT ;RESTORE ACTUAL CONTENTS OF T JRST MEMERR ;THEN PROCESS THE MEMORY ERROR ;;; ASSIGNABLE INTERRUPT HANDLER INTASS: REPEAT CINTSZ,[ MOVEM T,LV3SVT ;SAVE AC T MOVEI T,.RPCNT ;INDEX INTO CINTAB JRST ASSIN1 ;THEN USE COMMON CODE ] ASSIN1: SKIPN CINTAB(T) ;ASSIGNED CHANNEL? JRST ASSRET ;NOPE, RANDOM INTERRUPT; JUST RETURN SKIPG CINTAB(T) ;'CHANNEL' INTERRUPT (A CHARACTER?) HALT ;NO, SOME OTHER TYPE, BUT NONE SUPPORTED YET... MOVEM F,LV3SVF MOVE F,[LV3SVF,,INTPC3] MOVEM T,LV3ST2 ;SAVE INTERRUPT TABLE INDEX JSP T,INTSUP ;SETUP INTPDL MOVE T,LV3ST2 HRRZ T,CINTAB(T) ;GET THE INTERRUPT CHARACTER TRO T,400000 ;FLAG AS INTERNAL MOVEM T,IPSWD2(F) ;STORE ON INTPDL MOVE T,LV3SVT ;RESTORE ORIGIONAL CONTENTS OF T JRST CHNINT ;THEN PROCESS THE CHANNEL INTERRUPT ASSRET: MOVE T,LV3SVT ;RESTORE ORIGIONAL CONTENTS OF T DEBRK ;THEN RETURN TO MAIN PROGRAM ] ;END IFN D20 IFN SAIL,[ ;SAIL NEWIO INTERRUPT CODE ;CALLED TO REINITIALIZE THE INTERRUPT SYSTEM ENBINT: MOVEI T,INTRPT ;FLAGS,,INTERRUPT LOCATION MOVEM T,.JBAPR ;LOCATION SO MONITOR KNOWS SETZM INTALL ;DID A 'DALINT' LAST (ALL INTS ARE MASKED) SETOB T,REEINT ;ALL INTERRUPTS INCLUDING REENTER SETOM REENOP ;BUT MUST SET BOTH FLAGS IWKMSK T ;ALL GET US OUT OF IWAIT INTMSK T ;ALL ARE MASKED ON MOVE T,[STDMSK] ;ENABLE STANDARD INTERRUPTS MOVEM T,IMASK ;THIS IS CURRENT INTERRUPT MASK MOVEM T,OIMASK ;THIS IS ALSO THE OLD-MASK INTENB T, ;TELL OPERATING SYSTEM WHICH INTS TO GENERATE MOVEI T,REETRP ;REENTER TRAP ADR MOVEM T,.JBREN ;ALLOW REENTER AS MEANS OF IOC INTERRUPT POPJ P, ;REENABLES INTERRUPTS AFTER THEY HAVE BEEN DISABLED BY DALINT OR DISINT REAINT: PUSH FXP,T AOSE INTALL ;DISABLED ALL INTS? SKIPA T,OIMASK ;NO, USE OLD INTERRUPT MASK SKIPA T,IMASK ;ELSE USE CURRENT MASK MOVEM T,IMASK ;THIS IS NOW THE CURRENT MASK INTMSK T ;THEN UNMASK CORRECT SET OF INTERRUPTS SKIPG REEINT JRST REAIN1 MOVEI T,CPOPJ MOVEM T,.JBOPC POP FXP,T JRST REETR1 ;FUDGE A REENTER IF ONE WAS REQUESTED REAIN1: POP FXP,T SETOM REEINT POPJ P, ;DISABLE ALL BUT IMPORTANT INTERRUPTS ;IMASK IS MOVED TO OIMASK, AND IMASK IS SETUP TO NEW CURRENT MASK VALUE DISINT: PUSH FXP,T ;WE WILL NEED A WORKING AC MOVE T,IMASK ;GET CURRENT INTERRUPT MASK MOVEM T,OIMASK ;UPDATE OLD MASK ANDCM T,[INTPAR\INTPOV\INTILM\INTNXM] ;ONLY ALLOW THESE INTERRUPTS MOVEM T,IMASK ;NEW MASK INTMSK T ;TELL OPERATING SYSTEM SETZM REEINT ;ALSO DISALLOW REENTERS POP FXP,T POPJ P, ;THIS ROUTINE DISABLES ALL INTERRUPTS FROM OCCURING ;THE FLAG INTALL IS SET SAYING TO TELL THE RE-ENABLE ROUTINE TO RESTORE ; INTERRUPTS FROM IMASK RATHER THAN OIMASK DALINT: INTMSK R70 ;MASK OFF ALL INTERRUPTS SETOM INTALL ;FLAG THAT ALL INTERRUPTS HAVE BEEN DISABLED POPJ P, ;HERE TO PROCESS AN INTERRUPT ;OPERATING SYSTEM JUMPS TO HERE WITH ALL ACS SAVED AND SET UP WITH INTERRUPT ;STATUS; THE OBJECT IS TO SAVE INTERRUPT DEPENDANT DATA AND THEN REENABLE ;THE INTERRUPT SYSTEM AS SOON AS POSSIBLE....NOTE THAT THIS MUST DISABLE ;INTERRUPTS DEPENDING UPON WHICH ONE WAS GENERATED. ;--INTERRUPT-- --DISABLES-- ;MEMORY ERROR ALL EXCEPT PDL OV ;I I AND REENTER ;PDL OV ALL EXCEPT MEMORY ERROR AND PDL OV ;CLOCK CLOCK INTRPT: MOVE A,INTPDL ;DON'T WORRY ABOUT SPACEWAR BUTTONS SETZM REENOP ;NO ^C/REENTER TRAPS NOW MOVE B,.JBCNI ;GET INTERRUPT PUSH A,B ;SAVE INTERRUPT CONDITIONS PUSH A,10 ;SAVE ARGUMENT TO INTERRUPT (FOR I) PUSH A,IMASK ;DEFERRED INTERRUPT MASK CURRENTLY ACTIVE JFFO B,.+1 ;GET INTERRUPT NUMBER INTO AC B+1 PUSH A,B+1 ;STORE THIS ON INTPDL PUSH A,.JBTPC ;SAVE ADR INTERRUPT EMANATES FROM PUSH A,NIL ;SAVE DUMMY WORDS TO HOLD ACS D, R, F PUSH A,NIL PUSH A,NIL MOVEM A,INTPDL ;THIS IS NEW INTERRUPT PDL POINTER UWAIT ;UWAIT WILL RESTORE USER AC'S EXCH F,INTPDL ;SAVE F, GET POINTER TO INTPDL MOVEM D,IPSD(F) ;SAVE D MOVEM R,IPSR(F) ;SAVE R MOVEI R,(F) ;COPY INTPDL INTO R EXCH F,INTPDL ;RESTORE STATE OF F AND INTPDL MOVEM F,IPSF(R) ;THEN SAVE F MOVE F,IPSDF2(R) ;GET BIT NUMBER MOVE R,SAIIMS(F) ;THIS WILL BE NEW IMASK (F HAS INT NUMBER) MOVEM R,IMASK INTMSK R DEBREAK ;NOW GO TO USER LEVEL BUT NOT TO USER PROGRAM JRST @SAIDSP(F) ;DISPATCH ON INTERRUPT INDEX ;DISMISS AN INTERRUPT DSMINT: PUSH FXP,T MOVE T,INTPDL MOVE F,IPSDF1(T) ;RESTORE APR FLAGS TO THOSE AT INTERRUPT TIME MOVEM F,IMASK INTMSK F POP T,F POP T,R POP T,D PUSH P,(T) ;RETURN PC POPI T,5 MOVEM T,INTPDL ;RESTORE INTPDL POP FXP,T SKIPL REEINT HALT ;FOR DEBUGGING, THIS SHOULD NOT HAPPEN UNLESS ;CODE IS NOT PAIRED CORRECTLY ; (DISINT[DALINT]/REAINT) SKIPG REENOP POPJ P, MOVEM T,REESVT ;WE NEED AT LEAST ONE AC MOVE T,INTPDL ;USE T AS THE INTPDL ADD T,R70+10 ;WE MUST RESERVE THE SPACE WE WILL NEED MOVEM T,INTPDL SUB T,R70+5 ;BUT LEAVE 4 DUMMY WORDS + 1 FOR PC POP P,(T) ;PC IS THAT WHICH WE WILL POPJ TO JRST REETR1 ;INTERRUPT HANDLING ROUTINES (DISPATCHED TO VIA SAIDSP) INTERR: OUTSTR [ASCIZ\AN ILLEGAL INTERRUPT HAS BEEN RECIEVED. THIS IS AN INTERNAL LISP ERROR\] HALT PARINT: MOVSI R,(%PIPAR) ;FLAG THAT IS PARITY ERROR JRST SAIMER NXMINT: SKIPA R,[%PIMPV] ILMINT: MOVSI R,(%PIWRO) SAIMER: MOVE F,INTPDL ;INT PDL POINTER INTO F MOVEM R,IPSWD1(F) ;STORE WHERE MEMERR CAN FIND BITS JRST MEMERR ;PROCESS MEMORY ERROR ;HERE FOR I INTERRUPT EYEINT: MOVE F,INTPDL ;INT PDL POINTER INTO F SETZB R,IPSWD2(F) ;FORCE EXTERNAL CALL ; MOVM R,IPSWD2(F) ;GET I ARG (POSITIVE FORM ONLY) ; CAILE R,177 ;ONLY CHARACTERS UP TO 177 HAVE MEANING ; TDZA R,R ;FORCE R TO ZERO ; TLO R,400000 ;FLAG THAT THIS IS AN INTERNAL CALL ; MOVEM R,IPSWD2(F) ;RESTORE ARGUMENT TO CHNINT CLRBFI JRST CHNINT ;FUDGE THE CHANNEL INTERRUPT ;NEW INTERRUPT MASK BITS, INDEXED BY CURRENT INTERRUPT NUMBER SAIIMS: 0 ? 0 ? 0 ? 0 ? 0 ? 0 ? 0 ;NOT CURRENTLY ENABLED AT ANY TIME INTPOV ;PAR ERROR: ONLY ALLOW PDL OV -INTCLK-1 ;CLOCK INT: ALLOW ALL OTHERS 0 ? 0 ? 0 ? 0 ;NOT USED, IMP INTERRUPTS --1 ;I: ALL EXCEPT I AND CLOCK 0 ;CHANGING QUEUES, NOT USED INTPOV\INTILM\INTNXM\INTPAR\INTPOV ;PDL OV: ALL MEMORY ERRS AND PDL OV 0 ;PDP-11 INT, NOT USED INTPOV ;ILM: ONLY PDL OV INTPOV ;NXM: ONLY PDL OV 0 ? 0 ? 0 ;OVERFLOW AND OLD CLOCK TICK ;DISPATCH TABLE, INDEXED BY INTERRUPT NUMBER SAIDSP: REPEAT 11,INTERR ;INTERRUPT ERROR, THIS CANNOT HAPPEN PARINT ;PARITY ERROR CLOCKI ;CLOCK INTERRUPT INTERR ? INTERR ? INTERR ? INTERR ;VARIOUS IMP INTERRUPTS EYEINT ;I INTERRUPT INTERR ? INTERR ? INTERR ;CHANGING QUEUES, UNUSED, UNUSED PDLOV ;PDL OV INTERR ? INTERR ;PDP-11 INTERRUPT, UNUSED ILMINT ;ILL MEM REF NXMINT ;NON-EXISTANT MEMORY INTERR ? INTERR ? INTERR ;UNUSED, UNUSED, OLD CLOCK INT INTERR ? INTERR ;UNUSED INTERR ;FLOATING OVERFLOW INTERR ? INTERR ;UNUSED INTERR ;INTEGER OVERFLOW REPEAT 4, INTERR ;UNUSED ] ;END IFN SAIL IFN D10*,[ SUBTTL DEC-10 ONLY NEWIO INTERRUPT CODE ;***A NOTE OF CAUTION ;WHENEVER THE INTPDL IS TOUCHED, IT IS DONE SO IN A CERTAIN ORDER OF ;INSTRUCTIONS. THIS IS NECESSARY TO PREVENT TIMING ERRORS FROM SCREWING ;UP THE PDL SLOT ALLOCATION (THIS PREVENTS SAVED AC'S, FOR EXAMPLE, TO ;BE OVERWRITTEN BY NESTED INTERRUPTS). DO NOT CHANGE ANY ORDERING OF ;THIS CODE WITHOUT METICULOUS CHECKING TO SEE THAT RANDOM, ASYNCHRONOUS ;INTERRUPTS WILL NOT CAUSE TOTAL LOSSAGE. ;INTERRUPT ENABLING/DISABLING ;ENABLE NORMAL INTERRUPTS, CALLED AT STARTUP ENBINT: MOVEI T,REETRP ;REENTER TRAP ADR MOVEM T,.JBREN MOVEI T,APRTRP ;THIS LOCATION FOR ALL APR TRAPS MOVEM T,.JBAPR ;INFORM TOPS-10 VIA JOBDAT MOVEI T,STDMSK MOVEM T,IMASK ;THIS IS CURRENT INTERRUPT MASK MOVEM T,OIMASK ;ALSO IS OLD INTERRUPT MASK SETOM REEINT ;REENTER INTERRUPTS ARE OK SETOM REENOP ;BUT MUST SET BOTH FLAGS SETZM INTALL ;WE HAVEN'T DISABLED ALL INTERRUPTS APRENB T, POPJ P, ;NO OTHER TRAPS VIA THIS MECHANISM ;RE-ENABLE AFTER DISABLE INTERRUPTS REAINT: PUSH FXP,T AOSE INTALL ;DISABLED ALL INTS? SKIPA T,OIMASK ;NO, USE OLD INTERRUPT MASK SKIPA T,IMASK ;ELSE USE CURRENT MASK MOVEM T,IMASK ;THIS IS NOW THE CURRENT MASK APRENB T, SKIPLE REENOP JRST REAIN2 SKIPG REEINT JRST REAIN1 REAIN2: MOVEI T,CPOPJ MOVEM T,.JBOPC POP FXP,T JRST REETR1 ;FUDGE A REENTER IF ONE WAS REQUESTED REAIN1: SETOM REEINT SETOM REENOP POP FXP,T POPJ P, ;DISABLE ALL BUT IMPORTANT INTERRUPTS DISINT: PUSH FXP,T MOVE T,IMASK ;GET CURRENT MASK MOVEM T,OIMASK ;REMEMBER IT FOR RESETING PURPOSES ANDI T,AP.POV ;ONLY ALLOW IMPORTANT INTERRUPTS MOVEM T,IMASK ;THIS IS CURRENT STATE OF SYSTEM SETZM REEINT ;NO REENTER'S NOW APRENB T, POP FXP,T POPJ P, ;DISABLE ALL INTERRUPTS DALINT: PUSH FXP,T SETOM INTALL ;HAVE DISABLED ALL INTERRUPTS SETZB T,REEINT APRENB T, POP FXP,T POPJ P, ;APR TRAP HANDLING APRTRP: SETZM REENOP ;ABSOLUTLY NO ^C/REENTER INTERRUPTS NOW! MOVEM T,APRSVT SETZ T, APRENB T, ;NO INTERRUPTS DURING TRAP SETUP MOVE T,INTPDL ;USE T AS THE INTPDL REPEAT 4, PUSH T, ;2 INTERRUPT WORDS AND 2 DEFFERED WORDS PUSH T,.JBTPC ;INTERRUPT PC PUSH T,D ;SAVE AC'S AS ITS INTERRUPT WOULD DO PUSH T,R PUSH T,F MOVEM T,INTPDL MOVE D,IMASK ;THIS IS GOING TO GO IN INT MASK1 WORD MOVEM D,IPSDF1(T) SETZ D, MOVE F,.JBCNI ;GET ACTUAL PROCESSOR BITS TRNE F,AP.PAR TLO D,(%PIPAR) ;PARITY ERROR TRNE F,AP.POV ;PDL OV? JRST $PDLOV TRNE F,AP.ILM ;PURE PAGE ERROR? (SHOULD THIS BE MPV?) TLO D,(%PIWRO) TRNE F,AP.NXM ;NON-EXISTANT MEMORY TRO D,%PIMPV MOVEM D,IPSWD1(T) MOVE T,APRSVT JUMPN D,MEMERR OUTSTR [ASCIZ \UNRECOGNIZED APR INTERRUPT\] HALT $PDLOV: MOVE T,APRSVT JRST PDLOV ;DISMISS AN INTERRUPT DSMINT: PUSH FXP,T MOVE T,INTPDL MOVE F,IPSDF1(T) ;RESTORE APR FLAGS TO THOSE AT INTERRUPT TIME MOVEM F,IMASK APRENB F, POP T,F POP T,R POP T,D PUSH P,(T) ;RETURN PC POPI T,5 MOVEM T,INTPDL ;RESTORE INTPDL POP FXP,T SKIPL REEINT HALT ;FOR DEBUGGING, THIS SHOULD NOT HAPPEN UNLESS ;CODE IS NOT PAIRED CORRECTLY (DISINT[DALINT]/REAINT) SKIPG REENOP POPJ P, MOVEM T,REESVT ;WE NEED AT LEAST ONE AC MOVE T,INTPDL ;USE T AS THE INTPDL ADD T,R70+10 ;WE MUST RESERVE THE SPACE WE WILL NEED MOVEM T,INTPDL SUB T,R70+5 ;BUT LEAVE 4 DUMMY WORDS + 1 FOR PC POP P,(T) ;PC IS THAT WHICH WE WILL POPJ TO JRST REETR1 ];END IFN D10* ;THE FOLLOWING CODE IS FOR TOPS-10 AND SAIL IFN D10,[ ;HERE FOR A USER CHARACTER INTERRUPT, MAKE AN INTSTACK FRAME AND CALL CHNINT UCHINT: SETZM REEINT ;DON'T ALLOW ^C/REENTERS TO GO THROUGH MOVEM T,REESVT ;WE NEED AT LEAST ONE AC MOVE T,INTPDL ;USE T AS THE INTPDL ADD T,R70+10 ;MUST SET INTPDL TO AFTER ITS REAL USE SO THAT ;RECURSIVE INTERRUPTS USE DIFFERENT STACK AREAS MOVEM T,INTPDL SUB T,R70+4 ;WE WILL KEEP A DUMMY FOUR WORDS PUSH T,[0,,CPOPJ] ;PC FLAGS 0 AS THEY MAY GET RESTORED BY JRST 2, PUSH T,D ;SAVE AC'S AS ITS INTERRUPT WOULD DO PUSH T,R PUSH T,F MOVEM D,IPSWD2(T) MOVE D,IMASK ;PUT OLD IMASK IN WORD 1 MASK MOVEM D,IPSDF1(T) MOVE T,REESVT SETOM REENOP SETOM REEINT JRST CHNINT ;REENTER TRAP ADR REETRP: AOSG REENOP AOSLE REEINT ;REENTER ALLOWED? JRSTF @.JBOPC ;NOPE, FLAG AND GO ON MOVEM T,REESVT ;WE NEED AT LEAST ONE AC MOVE T,INTPDL ;USE T AS THE INTPDL ADD T,R70+10 ;MUST SET INTPDL TO AFTER ITS REAL USE SO THAT ;RECURSIVE INTERRUPTS USE DIFFERENT STACK AREAS MOVEM T,INTPDL SUB T,R70+4 ;WE WILL KEEP A DUMMY FOUR WORDS PUSH T,.JBOPC ;INTERRUPT PC REETR1: PUSH T,D ;SAVE AC'S AS ITS INTERRUPT WOULD DO PUSH T,R PUSH T,F SETZM IPSWD2(T) ;FORCE MASK TO ZERO AS IS USED SPECIALLY MOVE D,IMASK ;STORE IMASK AS WORD1 MASK MOVEM D,IPSDF1(T) MOVE T,REESVT SETOM REENOP SETOM REEINT JRST CHNINT ] ;END IFN D10 ;;; WHEN THE INTERRUPT OCCURS, ACS D, R, AND F HAVE BEEN SAVED. ;;; BY CONVENTION AN INTERRUPT HANDLER MOVES THE INTPDL POINTER ;;; INTO F, GETS A VALID FXP POINTER INTO FXP, AND PUSHES THE OLD ;;; CONTENTS OF FXP ONTO THAT PDL. ;;; STANDARD INTERRUPT EXIT ;;; WILL RESTORE FXP AND D+R+F, AND DISMISS THE INTERRUPT. INTXIT: MOVE FXP,(FXP) ;POP FXP,FXP SKIPN NOQUIT ;CHECK FOR USER INTS STACKED BY INT HANDLER SKIPN INTFLG .SEE CHECKI JRST INTXT2 SKIPE GCFXP ;HOW CAN GCFXP BE NON-ZERO WITH NOQUIT ZERO? .LOSE PUSH FXP,IPSD(F) ;ARRANGE TO RESTORE D AND THE PC PUSH P,IPSPC(F) ; (INCLUDING FLAGS!) AFTER CHECKING PUSH P,CPXDFLJ ; FOR STACKED INTERRUPTS MOVEI R,CKI0 MOVEM R,IPSPC(F) INTXT2: IFN D20+D10, JRST DSMINT ;DISMISS THE INTERRUPT IFN ITS,[.CALL INTXT9 ;RETURN PC IS ON TOP OF INTPDL, .LOSE 1000 ; AND ALSO THE OLD DEFER WORDS INTXT9: SETZ SIXBIT \DISMIS\ ;DISMISS INTERRUPT 5000,,D_6+3 ;POP ACS D, R, AND F FIRST 400000,,INTPDL ;INTERRUPT STACK POINTER ] ;END IFN ITS ;;; STANDARD LOSING INTERRUPT EXIT ;;; RESTORES FXP, AND D+R+F AS INTXIT DOES. ;;; ALSO EXPECTS A .LOSE ERROR CODE IN R. INTLOS: MOVE FXP,(FXP) ;POP FXP,FXP INTLS1: IFN D10+D20, JRST DSMINT ;DISMISS THE INTERRUPT IFN ITS,[.CALL INTLS9 .LOSE 1000 INTLS9: SETZ SIXBIT \DISMIS\ ;DISMISS INTERRUPT 5000,,D_6+3 ;POP ACS D, R, AND F FIRST ,,INTPDL ;INTERRUPT STACK POINTER ,,IPSPC(F) ;NEW PC ;IN ORDER TO SPECIFY ,,IPSDF1(F) ;NEW .DF1 ; THE .LOSE CODE, ONE ,,IPSDF2(F) ;NEW .DF2 ; MUST MENTION ALL THIS TOO 400000,,R ;.LOSE ERROR CODE ] ;END IFN ITS ;;; EXIT INTERRUPT, GOING TO USER INTERRUPT HANDLER. ;;; ARGUMENT FOR THE UINT ROUTINE IS IN D. ;;; PDLS ARE IN GOOD SHAPE BY NOW, OF COURSE. XUINT: SKIPE GCFXP ;BE EXTRA SURE ABOUT THE IT$ .LOSE ; GOODNESS OF THE PDLS! IFN , HALT ;;;; POP FXP,FXP ;AT THIS POINT SHOULD BE SAME AS SUB FXP,R70+1 MOVE FXP,(FXP) PUSH P,IPSPC(F) ;PUSH INTERRUPT PC ON STACK FOR UINT PUSH P,CPXDFLJ ;ARRANGE FOR AC D AND FLAGS TO BE RESTORED PUSH FXP,IPSD(F) ;PUSH AC D (BEFORE INTERRUPT) ON FXP MOVEM D,IPSD(F) ;CAUSE D TO SURVIVE THE DISMIS IFN D10+D20,[ MOVEI D,UINT ;NEW PC MOVEM D,IPSPC(F) ;STORE WHERE OLD PC WENT JRST DSMINT ;THEN DISMISS THE INTERRUPT ] ;END IFN D10+D20 IFN ITS,[.CALL XUINT9 .LOSE 1000 XUINT9: SETZ SIXBIT \DISMIS\ ;DISMISS INTERRUPT 5000,,D_6+3 ;POP ACS D, R, AND F FIRST ,,INTPDL ;INTERRUPT STACK POINTER 1000,,UINT ;NEW PC ,,TTYDF1 ;NEW .DF1 400000,,TTYDF2 ;NEW .DF2 ] ;END IFN ITS ;;; MEMORY AND OPCODE ERRORS: PARITY, PURE, MPV, ILOP. ;;; ASSUME NO MORE THAN ONE HAPPENS AT A TIME. MEMERR: IT$ .SUSET [.RJPC,,JPCSAV] MOVE F,INTPDL MOVE D,FXP SKIPE GCFXP MOVE FXP,GCFXP PUSH FXP,D MOVN R,IPSWD1(F) ;THIS SEQUENCE KILLS THE LOW-ORDER ANDCA R,IPSWD1(F) ; BIT FROM THE INTERRUPT WORD ; FOR D10, WILL CONTAIN APR FLAGS OF MERIT SKIPE R ;LOSE IF MORE THAN ONE BIT WAS SET IT$ .LOSE IFN D10+D20, HALT MOVE R,IPSWD1(F) HRRZ D,IPSPC(F) IT$ CAIN D,THIRTY+5 ;DDT DOES X IN LOCATION 34 IT$ JRST $XLOSE TLNE R,(%PI) ;WAS IT A PARITY ERROR? JRST PARERR TLNE R,(%PI) ;WRITE INTO READ-ONLY? JRST PURPGI TRNE R,%PI ;ILLEGAL OPERATION? JRST ILOPER TRNN R,%PI ;MEMORY PROTECT VIOLATION? .VALUE ;NO??? WHAT HAPPENED??? CAIE D,UBD1 ;LET SPECPDL RESTORATION HAPPEN JRST MPVERR ; EVEN IF ONE SLOT GOT CLOBBERED AOS IPSPC(F) ;BUMP PC PAST OFFENDING INSTRUCTION JRST INTXIT MPVERR: SKIPA D,[UIMMPV] PURERR: MOVEI D,UIMWRO JRST MEMER5 ILOPER: IFN D20,[ SKIPN TENEXP JRST ILOPR1 ; THIS A CRUFTY BUT ADEQUATE THEORY OF ERJMP'S HLRZ R,0(D) CAIE R,320700 ;ERJUMP? JRST ILOPR1 HLRZ R,-1(D) CAIE R,104000 ;JSYS? JRST ILOPR1 HRRZ R,0(D) HRRM R,IPSPC(F) ;CLOBBER RESTART ADDRESS JRST INTXIT ILOPR1: ] ;END IFN D20 SKIPA D,[UIMILO] PARERR: MOVEI D,UIMPAR MEMER5: HRRZ R,INTPDL ;MACHINE ERROR! WHAT TO DO? CAIN R,INTPDL+LIPSAV ;IF THE ERROR HAPPENED WITHIN AN INTERRUPT SERVER, SKIPN VMERR ; OR IF USER SUPPLIED NO ERROR FUNCTION, JRST MEMER7 ; CRAP OUT BACK TO DDT MOVEI D,100000(D) HRL D,IPSPC(F) PUSHJ FXP,$IWAIT JRST XUINT ;CALL USER INTERRUPT HANDLER ; JRST INTXIT ;MAY RE-DO LOSING INSTR, BUT SO WHAT? ; THAT'S A FEATURE, NOT A BUG. ANDI D,777 MEMER7: IFN ITS,[ HRRZ R,MEMER8(D) JRST INTLOS MEMER8: OFFSET -. UIMPAR:: 1+.LZ %PIPAR UIMILO:: 1+.LZ %PIILO UIMWRO:: 1+.LZ %PIWRO UIMMPV:: 1+.LZ %PIMPV OFFSET 0 $XLOST: .VALUE [ASCIZ \: YOUR X LOST PROCEED \] JRST THIRTY+5 ;LET THE X RETURN CORRECTLY $XLOSE: MOVEI R,$XLOST ;CAUSE INTERRUPT DURING AN X MOVEM R,IPSPC(F) ; TO GO TO $XLOST (CROCK) JRST INTXIT ] ;END IFN ITS IFE ITS,[ MOVEI A,MEMER8(D) ;TRANSFER TO ONE OF THE LER3'S BELOW EXCH A,IPSPC(F) ANDI A,-1 JRST INTXIT MEMER8: OFFSET -. UIMPAR:: LER3 [SIXBIT \PC AT WHICH MEMORY PARITY ERROR OCCURRED!\] UIMILO:: LER3 [SIXBIT \PC WITH ILLEGAL INSTRUCTION CODE!\] UIMWRO:: LER3 [SIXBIT \PC AT WHICH ATTEMPT TO WRITE INTO PURE PAGE!\] UIMMPV:: LER3 [SIXBIT \PC WITH MEMORY PROTECTION VIOLATION!\] OFFSET 0 ] ;END OF IFE ITS ;;; IFN D10,[ ;;; OUTSTR @MEMER8(D) ;GIVE ERROR IF USER DOESN'T WANT IT ;;; EXIT 1, ;;; JRST .-2 ;;; ] ;END IFN D10 ;;; ;;; IFN D20,[ ;;; HRRO 1,MEMER8(D) ;GIVE ERROR ;;; PSOUT ;;; HALTF ;THEN STOP EXECUTION NICELY ;;; ] ;END IFN D20 ;;; ;;; IFN D10+D20,[ ;;; MEMER8: ;;; OFFSET -. ;;; UIMPAR::[ASCIZ \?Parity error in job ;;; \] ;;; UIMILO::[ASCIZ \?Illegal op executed ;;; \] ;;; UIMWRO::[ASCIZ \?Write into read-only memory ;;; \] ;;; UIMMPV::[ASCIZ \?Memory protection violation ;;; \] ;;; OFFSET 0 ;;; ] ;END IFN D10+D20 ;;; I/O CHANNEL ERROR HANDLER IFN ITS,[ IOCERR: MOVE F,INTPDL MOVE R,FXP SKIPE GCFXP MOVE FXP,GCFXP PUSH FXP,R .SUSET [.RBCHN,,R] SKIPN R JRST IOCER8 .CALL SCSTAT .LOSE 1400 LSH D,-33 HRRZ R,IPSPC(F) MACROLOOP NIOCTR,ZZI,* ;ZZI MACROS DEFINE IOC TRAPS SKIPL R JRST IOCER8 IOCERA: HRRM R,IPSPC(F) ;CLOBBER RETURN PC HLRZ R,R CAIN R,400000+D ;WANT TO STICK IOC ERROR MOVEI R,400000+IPSD(F) ; CODE INTO SPECIFIED AC, CAIN R,400000+R ; BUT MUST BEWARE OF D AND R MOVEI R,400000+IPSR(F) MOVEM D,-400000(R) JRST INTXIT IOCER8: SKIPN IOCINS ;ANY USER IOC ERROR HANDLER? JRST IOCER9 ;NOPE, LET DUPERIOR HAVE THE ERROR MOVE R,IPSPC(F) ;PC IN R ;ERROR CODE IN D (SEE ABOVE) ;CALL USER WITH PC IN R AND ERROR CODE IN D. ;THE USER'S ROUTINE MUST NOT MUNG ANY AC'S OTHER THAN R AND D, THOUGH THE ;STACKS MAY BE USED. IF THE USER'S INSTRUCTION SKIPS, THE RIGHT ;HALF OF R CONTAINS THE PC TO DISPATCH TO AFTER THE DISMIS, AND THE LEFT HALF ;OF R CONTAINS 400000+ PUSHJ FLP,@IOCINS SKIPA JRST IOCERA IOCER9: MOVEI R,1+.LZ %PIIOC JRST INTLOS ] ;END IFN ITS ;;; INTERRUPT FROM I/O CHANNEL. ;;; PRESENTLY ONLY TWO KINDS ARE HANDLED: ;;; TTY INPUT: INTERRUPT CHAR TYPED. ;;; TTY OUTPUT: **MORE**. CHNINT: MOVE F,INTPDL MOVE D,IPSWD2(F) ;GET WORD TWO INTERRUPT BITS MOVE R,FXP ;FXP MAY BE IN A BAD STATE IF SKIPE GCFXP ; WITHIN GC, SO RESTORE IT AND MOVE FXP,GCFXP ; THEN PUSH ITS OLD VALUE PUSH FXP,R ;REMEMBER, PDL OVERFLOW ISN'T DEFERRED NOW IFN ITS,[ MOVN R,D AND R,D ;R GETS LOWEST SET BIT ANDCM D,R ;D GETS ALL OTHER BITS SKIPE D .SUSET [.SIIFPIR,,D] ;PUT ANY OTHER BITS BACK (THEY'RE DEFERRED) MOVE D,R JFFO D,.+1 ;FIND CHANNEL NUMBER MOVNS R ; FOR SOME PENDING ADDI R,43 ; INTERRUPT BIT PUSH FXP,R ;SAVE CHANNEL NUMBER SKIPN R ;CHANNEL 0 ?? JRST CHNI2 ;YES, THIS CAN HAPPEN IN STRANGE CASES SKIPN CHNTB(R) ;UNOPEN DEVICE ?? .VALUE ;BUT DON'T ALLOW INTERRUPTS FROM CLOSED CHAN CHNI1H: .CALL SCSTAT ;GET STATUS FOR THE CHANNEL .VALUE ANDI D,77 ;GET ITS INTERNAL PHYSICAL DEVICE TYPE SKIPE D CAILE D,2 JRST CHNI5 ];END IFN ITS IFN D10+D20,[ MOVE R,D PUSH FXP,V%TYI ;SAR ADR ON STACK ] ;END IFN D10+D20 IFN ITS,[ HRRZ D,CHNTB(R) MOVE D,TTSAR(D) TLNE D,TTS ;IF IT'S NOT A TTY INPUT ARRAY, WE DON'T TLNE D,TTS ;HAVE INTERRUPT CHAR DISPATCH TABLE JRST CHNI5 ; SO JUST TREAT AS ENDPGFUN (I.E. RANDOM CHANL) .ITYIC R, ;TYPE 0 IS TTY INPUT JRST CHNI8 ;TIMING ERROR OR SOMETHING - IGNORE ] ;END IFN ITS IFN D10,[ TRNE R,400000 ;IF NOT INTERNAL GET FROM USE JRST CHNIZ ;ELSE WE HAVE ALREADY OUTCHR ["?] INCHRW R SA$ TRO R,%TXCTL ;CONTROLLIFY THE CHARACTER CHNIZ: ] ;END IFN D10 SA% IFN D10+D20, ANDI R,37 ;MAP ALL CHARS INTO CTRL CHARACTERS SA$ ANDI R,777 PUSH FXP,R ;SAVE INTERRUPT CHARACTER PUSH FXP,TT ; AND ALSO TT HRRZ TT,-2(FXP) ;FETCH CHANNEL NUMBER ;FOR D-10, THIS IS ADR OF SAR TTYI1: IT$ HRRZ TT,CHNTB(TT) HRRZ TT,TTSAR(TT) IFN D10+D20,[ HRL TT,F.CHAN(TT) ;NOW GET CHANNEL # HLRZM TT,-2(FXP) ;MAKE THE CHANNEL NUMBER CORRECT ON THE STACK ] ;END IFN D10+D20 JSP D,TTYICH ;GET BACK INTERRUPT FN IN R POP FXP,TT JUMPE R,CHNI2 ;NULL FUNCTION - IGNORE MOVEI D,(R) LSH D,-SEGLOG MOVE D,ST(D) TLNN D,FX JRST CHNI4 MOVE R,(R) ;"FUNCTION" IS A FIXNUM IFN ITS+SAIL,[ MOVEI D,(R) ;IF ANY OF THE SUPRA-ASCII ANDCM D,(FXP) ; MODIFIER BITS ARE SET IN THE MOVSS (FXP) ; "FUNCTION", INSIST THAT THE ANDM R,(FXP) ; CORRESPONDING BITS APPEAR IN MOVSS (FXP) ; THE CHARACTER TYPED. SIMILARLY, IOR D,(FXP) ; THE SAME BITS SET IN THE LEFT HALF TRNE D,%TX ; MEAN THAT THOSE BITS MUST BE OFF. JRST CHNI2 ] ;END IFN ITS+SAIL ANDI R,177 MOVEI D,TRUTH ;MOOOOBY SKIP CHAIN OF SYSTEM INTS CAIN R,^A ;^A (SETQ ^A T) HRRZM D,SIGNAL CAIN R,^C ;^C (SETQ ^D NIL) SETZM GCGAGV CAIN R,^D ;^D (SETQ ^D T) HRRZM D,GCGAGV CAIN R,^G ;^G (^G) ;QUIT JRST CN.G CAIN R,^R ;^R (SETQ ^R T) HRRZM D,TAPWRT CAIN R,^T ;^T (SETQ ^R NIL) SETZM TAPWRT CAIN R,^V ;^V (SETQ ^W NIL) SETZM TTYOFF CAIN R,^W ;^W (PROG2 (SETQ ^W T) JRST CN.W ; (CLEAR-OUTPUT T)) CAIN R,^X ;^X (ERROR 'QUIT) ;^X QUIT JRST CN.X CAIN R,^Z ;^Z CRAP OUT TO DDT JRST CN.Z CHNI2: SUB FXP,R70+2 JRST INTXIT CHNI4: POP FXP,D ;REAL LIVE USER INTERRUPT FUNCTION TRO D,400000 ;2.9 => TTY INPUT INTERRUPT CHAR CHNI4A: POP FXP,R HRL D,CHNTB(R) SKIPE UNREAL JSP R,CHNI4C ;BARF! (NOINTERRUPT 'TTY) OR (NOINTERRUPT T) PUSHJ FXP,$IWAIT ;CALLS UISTAK AND SKIPS IF IN GC JRST XUINT ;RUNS USER INTERRUPT JRST INTXIT IFN ITS,[ CHNI5: HRRZ D,CHNTB(R) ;CHECK OUT FILE ARRAY HRRZ D,TTSAR(D) SKIPN FO.EOP(D) ;SKIP IF ENDPAGEFN JRST CHNI8 MOVEI D,200000+<2*FO.EOP+1> ;2.8 => RANDOM FILE INTERRUPT JRST CHNI4A ;**MORE** => ENDPAGEFN GETS RUN CHNI8: SUB FXP,R70+1 JRST INTXIT ];END IFN ITS ;;; ROUTINE TO STACK UP INTERRUPT IN INTAR -- USED BY CHNINT, JOBINT, AND FNYINT CHNI4C: MOVE F,UNREAR ;STACK UP INTERRUPT IN THE CAIL F,LUNREAR ; NOINTERRUPT QUEUE JRST TMDAMI ;OOPS! TOO MANY DAMN INTERRUPTS! MOVE F,[400000+LUNREAR-1,,UNREAR+LUNREAR-2] CHNI4H: POP F,1(F) TLNE F,377777 JRST CHNI4H MOVEM D,UNREAR+1 AOS UNREAR HRRZ F,INTPDL JRST 2(R) ; COMMENT FOR @ CHANGE IFN JOBQIO,[ ;;; INTERRUPT FROM INFERIOR PROCEDURE(S) JOBINT: MOVE F,INTPDL MOVE D,IPSWD2(F) MOVE R,FXP SKIPE GCFXP ;IF IN GC, FXP MAY BE MOVE FXP,GCFXP ; SCREWED UP PUSH FXP,R MOVN R,D AND R,D ;R GETS LOWEST SET BIT ANDCM D,R ;D GETS ALL OTHER BITS SKIPE D .SUSET [.SIIFPIR,,D] ;PUT ANY OTHER BITS BACK (THEY'RE DEFERRED) MOVE D,R JFFO D,.+1 MOVNS R ;-22 < R < -11 SKIPN D,JOBTB+21(R) .VALUE ;NO JOB ARRAY??? HRRZ R,TTSAR(D) SKIPN J.INTF(R) JRST INTXIT ;NO INTERRUPT FUNCTION - IGNORE INTERRUPT MOVSI D,(D) TRO D,200000+<2*J.INTF+1> SKIPGE UNREAL JSP R,CHNI4C ;GORP! (NOINTERRUPT T) PUSHJ FXP,$IWAIT JRST XUINT JRST INTXIT ] ;END OF IFN JOBINT ;;; TTSAR OF TTY INPUT FILE ARRAY IN TT. ;;; INPUT INTERRUPT CHARACTER IN R. ;;; RETURN ADDRESS IN D. ;;; RETURNS INTERRUPT FUNCTION IN R. TTYICH: IT$ TRZ R,%TX ;FOLD 12.-BIT CHAR SA$ ANDI R,777 SA% TRZN R,%TX ; DOWN TO 7 IF NECESSARY SA% JRST TTYIC1 SA% CAIE R,177 SA% TRZ R,140 TTYIC1: ROT R,-1 ;CLEVER ARRAY ACCESS ADDI TT,FB.BUF(R) ;INTERRUPT FNS ARE IN "BUFFER" HLR R,(TT) SKIPGE R HRRZ R,(TT) ;SIGN BIT OF R GETS CLEARED JRST (D) SUBTTL VARIOUS SYSTEM TTY INPUT CHAR INTERRUPT HANDLERS. CN.W: HRRZM D,TTYOFF ;IMMEDIATE TTYOFF (^W) PUSH FXP,T PUSH FXP,TT HRRZ TT,V%TYO MOVE T,ASAR(TT) TLNN T,AS.FIL ;Is it a File Array? JRST CN.W0 ; No, don't do it at all! MOVE TT,TTSAR(TT) TLNE TT,TTS ;IFF it's a TTY PUSHJ FXP,CLRO3 ; ALSO DO (CLEAR-OUTPUT T) CN.W0: POP FXP,TT POP FXP,T JRST CHNI2 IFN D20,[ CN.Z: PUSH FXP,T PUSH FXP,TT MOVEI T,CN.Z0 ;RETURN TO SUPERIOR (MAY BE IDDT) MOVE TT,INTPDL EXCH T,IPSPC(TT) MOVEM T,CN.ZX POP FXP,TT POP FXP,T JRST CHNI2 ;ALPT$G PROCEEDS CN.Z0: HALTF ALTP: JRST 2,@CN.ZX ] ;END IFN D20 IFN D10,[ CN.Z: SKIPE R,.JBDDT ;ANY DDT IN CORE? JRST (R) EXIT 1, ;RETURN TO MONITOR IF NO DDT, CONT CONTINUES ALTP: JRST CHNI2 ;PROCEED ON ALTP$G ] ;END IFN D10 IFN ITS,[ CN.Z: PUSH FXP,TT ;WE NEED ONE AC TO HOLD CHANNEL NUMBER HRRZ TT,-2(FXP) .CALL CKI2I .VALUE POP FXP,TT .VALUE [ASCIZ \:DDT \] JRST CHNI2 CKI2I: SETZ SIXBIT \RESET\ 400000,,TT ] ;END IFN ITS CTRLG: HRROI D,-3 ;^G - SUBR 0 PIPAUSE ;DISABLE THE INTERRUPT SYSTEM FOR NOW SETZM UNREAR ;CLEAR OUT ALL STACKED INTERRUPTS SETZM INTAR HRREM D,INTFLG SKIPE NOQUIT ;HOW CAN NOQUIT BE NON-ZERO? IT$ .LOSE ; MAYBE THE USER SCREWED UP IFN D10+D20, HALT JRST CKI0 ;PROCESS THE FORCED QUIT CN.X: SKIPA D,[-6] ;ERRSETABLE (^X) QUIT CN.G: HRROI D,-7 ;IMMEDIATE (^G) QUIT SKIPE UNREAL JRST CN.G1 SETZM INTAR ;KILL ALL INTERRUPTS STACKED UP HRREM D,INTFLG PUSHJ FXP,$IWAIT SKIPA D,[CKI0] JRST CHNI2 ;CAN'T PROCESS QUIT NOW MOVEM D,IPSPC(F) ;IF CAN QUIT NOW, ARRANGE FOR SERVER JRST CHNI2 ; TO RETURN TO INTERRUPT CHECKER CN.G1: SETZM UNREAR ;KILL STACKED UNREAL INTERRUPTS EXCH D,UNRC.G ;ELSE STACK UP AN UNREAL TRNE D,1 ; ^G OR ^X INTERRUPT MOVEM D,UNRC.G ;DON'T LET A ^X DISPLACE A ^G JRST CHNI2 IFN ITS,[ ;;; REAL TIME ALARMCLOCK REALCLOCK: MOVSI R,400000 ;SHUT CLOCK BACK OFF .REALT R, MOVEI R,Q$TIME JRST RCLOK1 ;;; RUNTIME ALARMCLOCK RUNCLOCK: MOVEI R,Q$RUNTIME RCLOK1: MOVE F,INTPDL MOVE D,FXP SKIPE GCFXP MOVE FXP,GCFXP PUSH FXP,D SKIPN VALARMCLOCK ;IGNORE IF THERE IS NO JRST INTXIT ; ALARMCLOCK FUNCTION MOVSI D,(R) ;TYPE 0, SUBTYPE 0 IS ALARMCLOCK SKIPL UNREAL ;SKIP IF (NOINTERRUPT T) JRST RCLOK2 MOVEM D,UNRRUN-Q$RUNTIME(R) ;STACK UP INTERRUPT JRST INTXIT IFN USELESS,[ FNYINT: MOVE F,INTPDL ;COMMON HANDLER FOR FUNNY INTERRUPTS MOVE D,FXP SKIPE GCFXP MOVE FXP,GCFXP PUSH FXP,D MOVE R,(R) SKIPN (R) JRST INTXIT ;EXIT IF NO USER HANDLER HLRZ D,R CAIE D,UIFTTR ;SPECIAL HACK FOR TTY-RETURN JRST FNYIN0 HRRZ R,IPSPC(F) ;GET PC OF INTERRUPT CAIE R,TYICAL ;INTERRUPTED FROM CANONICAL INPUT WAIT? CAIN R,TYICA1 HRLI D,Q$IN ;YES, ARG TO INT FUN IS 'IN CAIN R,TYIXCT ;ANOTHER CANNONICAL PLACE HRLI D,Q$IN FNYIN0: SKIPGE UNREAL JSP R,CHNI4C ;MUST STACK UP IF UNREAL ] ;END OF IFN USELESS RCLOK2: PUSHJ FXP,$IWAIT ;WILL STACK AND SKIP IF GC JRST XUINT ;GIVE USER CLOCK INTERRUPT JRST INTXIT IFN USELESS,[ ;;; CLI INTERRUPT HANDLER CLIINT: JSP R,FNYINT UIFCLI,,VCLI ;;; RETURN OF TTY TO THE JOB TTRINT: JSP R,FNYINT UIFTTR,,VTTR ;;; SYSTEM GOING DOWN OR BEING DEBUGGED SYSINT: JSP R,FNYINT UIFSYS,,VSYSD ;;; MAR BREAK MARINT: MOVEI R,%PIMAR ANDCAM R,IMASK .SUSET [.SMASK,,IMASK] .SUSET [.SMARA,,R70] MOVEI R,1+.LZ %PIMAR SKIPN VMAR JRST INTLS1 ;IN CASE (STATUS MAR) GETS LOUSED UP JSP R,FNYINT UIFMAR,,VMAR ] ;END OF IFN USELESS ] ;END IFN ITS ;;; STACK UP A USER INTERRUPT WHICH MUST BE DELAYED. ;;; ARGUMENT IS IN D AS FOR UINT; IT IS SAVED IN THE INTAR QUEUE. ;;; ASSUMES FREE USE OF ACCUMULATOR R. ;;; PI INTERRUPTS MUST BE DISABLED!!!! .SEE PIOF YESIN1: POP P,UISTAK ;THIS IS A HORRIBLE CROCK ;UISTAK: 0 UISTK1: MOVE R,INTFLG ;IF WE ARE ABOUT TO QUIT ANYWAY, AOJL R,@UISTAK ; THEN FORGET THE WHOLE THING AOS R,INTAR CAILE R,LINTAR JRST TMDAMI ;TOO MANY DAMN INTERRUPTS MOVE R,[400000+LINTAR-1,,INTAR+LINTAR-2] UISTK2: POP R,1(R) TLNE R,377777 JRST UISTK2 MOVSM D,INTAR+1 SETOM INTFLG JRST @UISTAK TMDAMI: SKIPN GCFXP ;TOO MANY DAMN INTERRUPTS JRST TMDAM2 IRP X,,[P,FLP,FXP,SP] MOVE X,GC!X TERMIN TMDAM2: ; LERR [SIXBIT \TOO MANY DEFERRED INTERRUPTS!\] IFN ITS,[ .VALUE [ASCIZ \:TOO MANY DEFERRED INTERRUPTSCONTIN \] .LOSE ] ;END OF IFN ITS 10$ OUTSTR [ASCIZ \TOO MANY DEFERRED INTERRUPTS\] 10$ EXIT 1, 10$ JRST .-1 IFN D20,[ HRROI 1,[ASCIZ \ ?Too many deffered interrupts \] HALTF ] ;END IFN D20 ;QMARK -- THIS IS HERE SO BAKTRACE WILL FIND IT AS LAST SUBR (ARGG!!) QMARK: MOVEI A,QM POPJ P, ;;; PURE PAGE TRAP HANDLER ;;; COMES HERE WITH LOSING PC IN D. .SEE MEMERR PURPGI: IFN D10*<1-SAIL>,[ SKIPE KA10P SOSA D,IPSPC(F) ;MAKE PC POINT TO OFFENDING INSTRUCTION SKIPA ANDI D,-1 ] ;END OF IFN D10*<1-SAIL> CAIN D,STQPUR JRST PPGI5 PPGI5A: IFN PAGING,[ MACROLOOP NPURTR,ZZP,*, ;ZZP MACROS DEFINE WHAT PLACES HAVE HANDLERS ] ;END IFN PAGING JUMPGE D,PURERR PPGI3: HRRM D,IPSPC(F) JRST INTXIT PPGI5: HRRZS A ;FORGET LEFT HALF CAIN A,PWIOINT ;BINDING INTERRUPT INHIBITS: NORMAL PURTRAP JRST PPGI5A MOVEM A,STQLUZ ;REMEMBER WHICH VALUE CELL WE TRIED TO GRONK MOVE D,[TIRPATE,,NIL] MOVEM D,(SP) SKIPE GCFXP .VALUE AOS IPSPC(F) ;DON'T RETRY THE LOSING INSTRUCTION! PUSHJ FXP,$IWAIT ;LET SPDL GET CAUGHT UP SKIPA T,STQLUZ ;ERROR HANDLER WANTS LOCATION IN T JRST PURERR ;INTWAIT MAY SKIP PPGI6: HRRZI D,NILSETQ ;TRIED TO PUT A VALUE PROPERTY ON NIL JRST PPGI3 SUBTTL USER INTERRUPT ROUTINES ;;; USER INTERRUPT TYPES FOR NEWIO ;;; ;;; FORM OF ARGUMENT TO UINT (ALSO STORED IN THIS FORM ;;; IN INTAR, ONLY WITH HALVES SWAPPED; WHY, I DON'T KNOW): ;;; ;;; 4.9-3.1 ARGUMENT FOR INTERRUPT FUNCTION ;;; 2.9 IF 1, SPECIFIES A TTY INPUT CHARACTER INTERRUPT. ;;; ARGUMENT IS TTY INPUT FILE ARRAY. ;;; 2.8-2.4 MUST BE ZERO. ;;; 2.3-1.1 CHARACTER WHICH CAUSED INTERRUPT, AS ;;; READ BY .ITYIC. THIS MAY BE A 12.-BIT ;;; CHARACTER, AND SO MAY HAVE TO BE FOLDED ;;; BEFORE SELECTING THE INTERRUPT FUNCTION. ;;; THIS IS PASSED AS THE SECOND ARGUMENT. ;;; 2.8 IF 1, SPECIFIES AN INTERRUPT RELATED TO A FILE ;;; ARRAY OR SIMILAR OBJECT, E.G. THE **MORE** ;;; INTERRUPT FOR TTY OUTPUT. ;;; ARGUMENT IS THE FILE ARRAY. ;;; 2.7-1.1 IS THE INDEX OF THE INTERRUPT FUNCTION ;;; WITHIN THE ARRAY, WHERE THE LOW BIT SPECIFIES ;;; LEFT OR RIGHT HALF AS USUAL. ;;; 2.7 IF 1, SPECIFIES A MACHINE ERROR. ;;; THE ARGUMENT IS THE LOCATION OF THE LOSS. ;;; BITS 1.9-1.1 SPECIFY THE NATURE OF THE ERROR. UIMPAR==:0 ;ODDP ;PARITY ERROR UIMILO==:1 ;EVAL ;ILLEGAL OPERATION UIMWRO==:2 ;DEPOSIT ;WRITE INTO READ-ONLY MEMORY UIMMPV==:3 ;EXAMINE ;MEMORY PROTECT VIOLATION ;;; IF 2.9-2.7 ARE ZERO, THEN: ;;; 2.2-2.1 TYPE OF INTERRUPT ;;; 1.9-1.1 SPECIFIC INTERRUPT ;;; CURRENT TYPES AND SPECIFIC INTERRUPTS ARE: ;;; 0 RANDOM ASYNCHRONOUS (DELAYED BY (NOINTERRUPT T)) ;;; 0 ALARMCLOCK UIFCLI==:1 ;CLI-MESSAGE ;USELESS UIFMAR==:2 ;MAR-BREAK ;USELESS UIFTTR==:3 ;TTY-RETURN ;USELESS UIFSYS==:4 ;SYS-DEATH ;USELESS IFE USELESS, NUINT0==:1 .SEE GCP6Q6 IFN USELESS, NUINT0==:5 .SEE GCP6Q6 ;;; 1 RANDOM SYNCHRONOUS ;;; 0 AUTOLOAD ;;; 1 ERRSET FN ;;; 2 *RSET-TRAP ;;; 3 GC-DAEMON ;;; 4 GC-OVERFLOW ;;; 5 PDL-OVERFLOW NUINT1==:6 .SEE GCP6Q6 ;;; 2 ERINT (SYNCHRONOUS) ;;; 0 UNDF-FNCTN ;;; 1 UNBND-VRBL ;;; 2 WRNG-TYPE-ARG ;;; 3 UNSEEN-GO-TAG ;;; 4 WRNG-NO-ARGS ;;; 5 GC-LOSSAGE ;;; 6 FAIL-ACT ;;; 7 IO-LOSSAGE NUINT2==:10 .SEE GCP6Q6 ;;; WE NORMALLY DON'T PUSHJ HERE AT ALL FROM PI LEVEL! ;; (THINK ABOUT HOW TO SIMPLIFY THE CODE HERE.) UINT: PUSHJ P,UINTPU SKIPN NOQUIT SKIPE INHIBIT JRST UINT2 SKIPGE INTFLG JRST UINT3 PUSHJ P,UINT0 .SEE UINTPU ;PEOPLE COME HERE TO UNDO UINTPU ;NOTE: THE PUSH'S OF UINTPU MUST SYNC WITH THE POP'S HERE UINTEX: IFN ,[ POP FXP,OIMASK POP FXP,IMASK ] ;END IFN SKIPL (FXP) JRST UINTX1 PIONAGAIN IT$ .SUSET [.SDF1,,R70] IT$ .SUSET [.SDF2,,R70] UINTX1: SUB FXP,R70+1 ;GET RID OF REENABLE INTERRUPTS FLAG POP FXP,R .SEE UINTPU JRST CHECKI ;PDL-OVERFLOW MAY HAVE BEEN STACKED .SEE PDLOV UINT2: JSR UISTAK ;DELAY A USER INTERRUPT, SINCE INHIBIT SWITCH IS ON JRST UINTEX UINT3: HRRZ D,INTFLG ;CHECK INTERRUPT FLAG TO SEE THAT IS SAYS "QUIT" CAIE D,-1 ;AND NOT SOME INCONGRUOUS USER PI JRST CKI2 HHCTB: .VALUE ; LERR EMS11 ;HOW THE HELL CAN THIS BE? UINTPU: ;PUSH PI STATE, THEN DISABLE PUSH FXP,R ;SAVE R FOR UISTAK, ETC. PUSH FXP,T IFE ITS,[ PUSH FXP,IMASK ;SAVE APRENB MASKS PUSH FXP,OIMASK MOVN T,INTALL ;GET PI STATE FROM INTERNAL WORD EXCH T,-2(FXP) SKIPGE -2(FXP) PIPAUSE ] ;END IFE ITS IFN ITS,[ .SUSET [.RPICLR,,T] EXCH T,(FXP) SKIPGE (FXP) PIPAUSE ] ;END OF IFN ITS POPJ P, ;;; SAVE THE WORLD FOR A USER INTERRUPT, INVOKE IT, AND RESTORE. ;;; ;;; SAVED QUANTITIES INCLUDE ALL ACCUMULATORS, THE PDL POINTERS ;;; (FOR FRETURN), AND THE SUPER-WRITABLE STUFF (TEMPORARIES IN ;;; LOW CORE USED BY INTERRUPTABLE FUNCTIONS). ;;; MANY GLOBAL SWITCHES ARE BOUND AND RESET. ;;; FOR ASYNCHRONOUS USER INTERRUPTS, THE (NOINTERRUPT T) STATE ;;; MAY BE ENTERED; THE PREVIOUS NOINTERRUPT STATE IS SAVED. ;;; MUST NOT COME HERE WITHOUT FIRST USING THE $IWAIT ;;; ROUTINE TO DECIDE WHETHER OR NOT WE ARE IN GC. ;;; ALSO MUST CHECK THE NOINTERRUPT SWITCH BEFORE COMING HERE ;;; IF THAT IS RELEVANT TO THE PARTICULAR USER INTERRUPT. ;;; INTERRUPTS MUST BE TURNED OFF WITH PIOF BEFORE COMING HERE. ;;; THE WORD DESCRIBING THE USER INTERRUPT MUST BE IN D. YESINT: SKIPN NOQUIT SKIPE INHIBIT JRST YESIN1 UINT0: IT$ .SUSET [.SDF1,,TTYDF1] ;MUST ALLOW PDL OVERFLOW AND MEMORY IT$ .SUSET [.SDF2,,TTYDF2] ; ERRORS TO GO THROUGH, BUT NO OTHERS IT$ PION IFN D10+D20,[ SETZM INTALL ;UNDO THE 'DALINT' PUSHJ P,DISINT ;DISABLE APPROPRIATE INTERRUPTS ] ;END IFN D10+D20 HRRZS (P) ;WILL HRROS IF ASYNCHRONOUS PUSHJ P,SAVX5 ;SAVE NUMERIC ACS PUSH FXP,UNREAL BG$ PUSH FXP,BNV1 MOVSI R,-LSWS PUSH FXP,SWS(R) AOBJN R,.-1 JSP T,SPECBIND ;MUST SPECBIND LISAR LISAR SETZM PA4 ;PA4 MUST BE IN THE "SWS" AREA IFN USELESS, SETZM TYOSW SETZM INHIBIT SETZM EOFRTN ;DO NOT SETZM CATRTN! GJS WANTS SETZM BFPRDP ; TO THROW OUT OF USER INTERRUPTS SETOM ERRSW MOVE T,[-LINTPDL,,INTPDL] ;MUSTN'T CALL UINT0 FROM CAME T,INTPDL ; WITHIN A PI SERVER .LOSE REPEAT 3, PUSH FXP,R70 ;RANDOM SLOTS FOR NUMERIC ARGS; ; ; ALSO 4.9 OF TOP ONE => RETURN VALUE MATTERS UIXPUSH==:5+1+BIGNUM+LSWS+3 ;AMOUNT OF STUFF PUSHED ON FXP UISWS==:-+1 ;WHERE SWS STARTS WHEN SAVED ON FXP UISAVT==:UISWS-6-BIGNUM ;WHERE ACCUMULATOR T GETS SAVED PUSH P,[$UIFRAME] ;FRAME MARKER AND PDLS SAVED PUSH P,FXP ; SO THAT THROW AND FRETURN WIN HRLM FLP,(P) .SEE UIBRK PUSHJ FXP,SAV5 ;SAVE ARGUMENT ACS AND 40 ON PUSH P,40 ; REGPDL FOR GC PROTECTION PUSH P,PA3 UIFRM==-3-NACS ;LOCATION OF FRAME ON REGPDL UISAVA==UIFRM+2 ;LOCATION OF AC A ON REGPDL MOVEI A,UIFRM(P) MOVEM A,UIRTN MOVSI AR2A,(CALLF 1,) HLRZ A,D ;GET FIRST ARG FOR INTERRUPT FN TRZN D,400000 ;DECODE INTERRUPT TYPE JRST UINT30 HRRZM D,(FXP) ;TTY INPUT INTERRUPT CHAR MOVEI R,(D) MOVE TT,TTSAR(A) JSP D,TTYICH ;FETCH INTERRUPT FN MOVSI AR2A,(CALLF 2,) HRRI AR2A,(R) MOVEI B,(FXP) ;SECOND ARG IS CHARACTER JRST UINT31 UINT30: TRZN D,200000 JRST UINT32 MOVEI TT,(D) ;RANDOM FILE INTERRRUPT ROT TT,-1 HRR AR2A,@TTSAR(A) ;FETCH INTERRUPT FUNCTION SKIPL TT HLR AR2A,@TTSAR(A) UINT31: HRROS UIFRM-1(P) ;ASYNCHRONOUS INTERRUPT JRST UINT40 UINT32: TRZN D,100000 JRST UINT33 HRRZM A,-1(FXP) MOVEI A,QODDP(D) ;MACHINE ERROR MOVEI B,(FXP) MOVEI C,-1(FXP) MOVEI AR1,-2(FXP) MOVSI AR2A,(CALLF 4,) HRR AR2A,VMERR JRST UINT40 UINT33: LDB TT,[110200,,D] ;BITS 2.2-2.1 ARE CLASS ANDI D,777 ;1.9-1.1 ARE SUBTYPE XCT UINT90(TT) ;FETCH INTERRUPT FUNCTION XCT UINT91(TT) ;SPECIAL HACKS UINT40: SKIPGE UIFRM-1(P) SETOM UNREAL PIONAGAIN ;***** RE-ENABLE INTERRUPTS ***** IT$ .SUSET [.SDF1,,R70] IT$ .SUSET [.SDF2,,R70] TRNN AR2A,-1 ;ONLY PROCESS INTERRUPT IF INT FUNCTION NON-NIL TDZA A,A ;FORCE A RETURNED VALUE OF NIL IF IT MATTERS XCT AR2A ;APPLY INTERRUPT FUNCTION HRRZ T,UIFRM+1(P) CAIE T,(FXP) PUSHJ P,UINT45 HLRZ T,UIFRM+1(P) CAIE T,(FLP) PUSHJ P,UINT46 PIPAUSE SKIPGE (FXP) ;IF RETURN VALUE MATTERS MOVEM A,UISAVA(P) ; SAVE IT FOR RETURN PUSHJ P,UNBIND ;RESTORE LISAR, ETC. UINT0X: HRLI R,UISWS(FXP) HRRI R,SWS BLT R,SWS+LSWS-1 ;RESTORE SUPER-WRITABLE STUFF SUB FXP,[-UISWS+1,,-UISWS+1] BG$ POP FXP,BNV1 POP P,PA3 POP P,40 PUSHJ FXP,RST5M1 POP P,-2(P) ;KNOCK OFF PDLS AND UIFRAME, SAVING SUB P,R70+1 ; SAVED CONTENTS OF A FOR POPAJ BELOW POP FXP,D ;OLD STATE OF UNREAL SKIPL -1(P) ;IF INTERRUPT WASN'T ASYNCHRONOUS, JRST UINT88 ; MUSTN'T ATTEMPT TO RESTORE UNREAL EXCH D,UNREAL ;WELL, WE WANT TO RESTORE IT. WAS IT ON JUMPE D,UINT88 ; JUST NOW? IF NOT, RETURN. SKIPE A,UNREAL ;DID WE JUST TURN IT OFF BY RESTORING IT? JRST UINT0Z ;NO, IT'S STILL ON - RETURN. UINT0N: HRRZ T,-1(P) ;IS THE CHECKU ROUTINE ITSELF CALLING ME? CAIGE T,ENOINT ; DON'T WANT TO GET STUCK IN INFINITELY CAIGE T,NOINTERRUPT ; RECURSIVE CALLS PUSHJ P,CHECKQ ;HACKISH ENTRY INTO CHECKU JRST UINT88 UINT0Z: SKIPLE UNREAL JUMPLE D,UINT0N UINT88: PUSHJ P,RSTX5 PIONAGAIN ;RE-ENABLE INTERRUPTS JRST POPAJ EUINT0:: .SEE PDLOV ;END OF UINT0 UINT45: SKIPA B,[QFIXNUM] UINT46: MOVEI B,QFLONUM EXCH A,B PUSHJ P,UINT49 EXCH A,B POPJ P, UINT49: FAC [PDL OUT OF PHASE IN USER INTERRUPT (SYSTEM ERROR)!] UINT90: HRR AR2A,VALARMCLOCK(D) ;ALARMCLOCK SERIES HRR AR2A,VAUTFN(D) ;RANDOM SYNCHRONOUS HRR AR2A,VUDF(D) ;ERINT SERIES .VALUE ;?? UINT91: HRROS UIFRM-1(P) ;ALARMCLOCK (ASYNCHRONOUS) JFCL ;RANDOM SYNCHRONOUS SETOM (FXP) ;ERINT (VALUE MATTERS) .VALUE ;?? CKI0: PUSH FXP,D HRRZ D,INTFLG CAIN D,-1 JRST CKI1 ;DELAYED USER INTERRUPT PIPAUSE CKI2: SETZM UNREAR CKI2A: SETZM UNRC.G ;CHECKU JOINS IN AT THIS POINT SETZM INTFLG ; RESET TTY NO RESET TRNE D,4 ;^X -6 -2 JRST CKI3 ;^G -7 -3 IFN ITS+D20,[ PUSH FXP,D MOVEI F,LCHNTB-1 ;RESET ALL TTY FILES CKI2F: SKIPN AR1,CHNTB(F) JRST CKI2F1 MOVE TT,TTSAR(AR1) TLNN TT,TTS.CL ;DON'T RESET THE FILE IF IT IS CLOSED TLNN TT,TTS.TY JRST CKI2F1 MOVEI T,CLRI3 TLNE TT,TTS.IO MOVEI T,CLRO3 PUSHJ FXP,(T) CKI2F1: SOJG F,CKI2F POP FXP,D ] ;END OF IFN ITS+D20 10$ CLRBFO 10$ CLRBFI CKI3: CKI3B: TRNN D,2 SKIPE PSYMF RQITR: LERR [SIXBIT \QUIT!\] ;SO ERROR OUT FOR ^X IFN USELESS*ITS,[ MOVE T,IMASK TRNN T,%PIMAR JRST CKI4A .SUSET [.RMARA,,SAVMAR] .SUSET [.SMARA,,R70] ;AVOID TRIPPING THE MAR DURING THE ERRPOP CKI4A: ] ;END OF IFN USELESS*ITS PIONAGAIN PUSHJ FXP,ERRPOP PIPAUSE IFN USELESS*ITS,[ TRNE T,%PIMAR ;ERRPOP PRESERVES T .SUSET [.SMARA,,SAVMAR] ] ;END OF IFN USELESS*ITS MOVE A,VERRLIST MOVEM A,VIQUOTIENT JSP A,ERINI0 MOVE P,C2 ;DRASTIC ACTION FOR ^G SETZM TTYOFF STRT 17,@RQITR JRST LSPRT1 ;WILL PION WITHIN ERINIT CKI1: SKIPE INHIBIT ;RETURN TO SERVICE THE DELAYED INTERRUPT JRST POPXDJ ;BUT NO SERVICE WHEN INHIBIT = -1 PUSHJ P,UINTPU SETZM INTFLG PUSH P,A PUSH P,A HLLOS INHIBIT SKIPG A,INTAR LERR EMS13 ;LOST USER INTERRUPT CKI1A: MOVS D,INTAR(A) ;FOR GC PROTECTION MOVSM D,(P) SOSG INTAR ;CYCLE THROUGH THE DELAYED INTERRUPTS SETZM INTFLG ;TO PREVENT TIMING SCREWS, CLEAR INTFLG IF ; NO MORE INTERRUPTS PENDING PUSHJ P,UINT0 SKIPLE A,INTAR JRST CKI1A SUB P,R70+1 POP P,A SETZM INHIBIT PUSHJ P,UINTEX JRST POPXDJ SUBTTL UUOH HANDLER (INCLUDING STRT) ;UUOH: 0 ;UUO HANDLER UUOH0: MOVEM T,UUTSV LDB T,[331100,,40] CAIL T,CALL_-33 JRST UUOH0B ;PROBABLY A LISP "CALL" UUO UUOH2: CAILE T,UUOMAX SETZ T, JRST @UUOH2A(T) UUOH2A: ERRBAD ;0 IS ILGL, ILGL, ILGL ERROR1 ;LERR ;UNCORRECTABLE LISP ERROR UUOACL ;ACALL ;KLUDGE FOR NCALLING ARRAYS UUOAJC ;AJCALL ;JRST VERSION OF ACALL ERROR1 ;LER3 ;LERR, BUT ALSO PRINT ACCUMULATOR A ERROR5 ;ERINT ;CORRECTABLE ERROR WITH SIXBIT MSG POF1 ;PP Z$X ;PRINT OUT Z FROM DDT STRTOUT ;STRT ;SIXBIT STRING TYPE OUT ERROR5 ;SERINT ;CORRECTABLE ERROR WITH S-EXP MSG TOF1 ;TP Z$X ;TYPEP PRINTOUT OF Z FROM DDT ERRIOJ ;IOJRST ;HAIRY FROB TO GET I/O ERROR MSGS STRTOUT ;STRT7 ;ASCII STRING TYPE OUT IFN .-UUOH2A-1-UUOMAX, WARN [UUOH2A OUT OF PHASE] UUOACL: PUSH P,UUOH BAKPRO UUOAJC: MOVE T,@40 .SEE ASAR TLNE T,AS AOJA T,.+2 ;FOR NUMBER ARRAYS, ENTER AT HEADER+1 PUSH P,[UUONVL] ;FOR OTHER ARRAYS, USE NUMVAL CHECK ROUTINE XCTPRO EXCH T,UUTSV SPECPRO INTACT JRST @UUTSV NOPRO ;;; DISPATCH ON "CALL" TYPE UUO, TRAPPING TO INTERPRETER IF NECESSARY UUOH0B: CAILE T,NJCALF_-33 JRST UUOH2 MOVEM TT,UUTTSV MOVEM R,UURSV LDB TT,[270400,,40] CAIG TT,15 ;LISP "CALL" TYPE UUOS TDZA R,R MOVEI R,-15(TT) HRRZ T,40 UUOH0A: MOVEM T,UUOFN TLZ T,-1 MOVEI TT,(T) LSH TT,-SEGLOG SKIPGE TT,ST(TT) JRST @UUNAF(R) TLNN TT,SY JRST UUOH0C TLZ R,700000 ;400000 => AUTOLOAD, 200000 => MACRO, ; 100000 => ALREADY DID AUTOLOAD UUOH1: HRRZ T,(T) JUMPE T,UUOH1A HLRZ TT,(T) HRRZ T,(T) CAIL TT,QARRAY CAILE TT,QAUTOLOAD JRST UUOH1 2DIF JRST @(TT),UUOTRT,QARRAY UUOH0C: TLNN TT,SA JRST UUOH3A HRRZ TT,ASAR(T) ;HANDLE CASE OF A SAR EFFICIENTLY CAIN TT,ADEAD JRST UUOH3A MOVSI T,(T) HRRI T,T JRST @UUAT(R) UUOH1A: JUMPL R,UUALT1 TLNE R,200000 JRST UUOMER PUSH P,A PUSH P,B SKIPGE A,UUOFN JRST UUOUER HLRZ T,(A) ;OPENCODED SYMEVAL HRRO T,@(T) UUOH3B: POP P,B POP P,A SKIPN EVPUNT ;SHOULD WE ALLOW FUNCTIONAL VARIABLES? CAIN T,QUNBOUND ;YES, IS IT BOUND? JRST UUOH3A ;NO TO EITHER QUESTION, SO ERROR JRST UUOH0A ;;UUO TRANSFER TABLE, ONCE FUNCTION TYPE IS KNOWN UUOTRT: IRPS LL,X,[A+S+FS+L+E+FE+MC-AL-] IFSE X,+, @UU!LL!T(R) IFSE X,-, UU!LL!T TERMIN ;;; MOBY DISPATCH TABLE FOR DECODING UUO CALL TYPES! ;;; R=0 => COMPILED ROUTINE CALLING A SUBR TYPE ;;; R=1 => COMPILED ROUTINE CALLING A LSUBR TYPE ;;; R=2 => COMPILED ROUTINE CALLING A FSUBR TYPE UUAT: UUOARR ;CALLING SUBR - IT'S AN ARRAY **WIN** UUOS1A ;CALLING LSUBR - IT'S AN ARRAY UUOS2A ;CALLING FSUBR - IT'S AN ARRAY UUST: UUOS0 ;CALLING SUBR - IT'S A SUBR **WIN** UUOS1 ;CALLING LSUBR - IT'S A SUBR UUOS2 ;CALLING FSUBR - IT'S A SUBR UUFST: UUOS10 ;CALLING SUBR - IT'S AN FSUBR UUOS11 ;CALLING LSUBR - IT'S AN FSUBR UUOSBR ;CALLING FSUBR - IT'S AN FSUBR **WIN** UULT: UUOS7 ;CALLING SUBR - IT'S AN LSUBR UUOLSB ;CALLING LSUBR - IT'S AN LSUBR **WIN** UUOS9 ;CALLING FSUBR - IT'S AN LSUBR UUET: UUOEXP ;CALLING SUBR - IT'S AN EXPR UUOS5 ;CALLING LSUBR - IT'S AN EXPR UUOS6 ;CALLING FSUBR - IT'S AN EXPR UUFET: UUOS3 ;CALLING SUBR - IT'S A FEXPR UUOS4 ;CALLING LSUBR - IT'S A FEXPR UUOEX2 ;CALLING FSUBR - IT'S A FEXPR UUNAF: UUOS ;CALLING SUBR - IT'S A NONATOMICFUN UUL2N ;CALLING LSUBR - IT'S A NONATOMICFUN UUF2N ;CALLING FSUBR - IT'S A NONATOMICFUN UUALT: HRRZM T,UUALT9 ;FOUND AN AUTOLOAD PROPERTY TLOA R,400000 UUMCT: TLO R,200000 ;MACROS ARE IGNORED, SORT OF JRST UUOH1 UUALT1: TLOE R,100000 ;CALLING ANYTHING - IT'S AN AUTOLOAD JRST UUOH3C ;LOSE IF JUST DID AN AUTOLOAD ALREADY PUSH P,A HLRZ A,@UUALT9 ;OTHERWISE AUTOLOAD THE FUNCTION MOVE T,UUOFN PUSHJ P,AUTOLOAD ;BETTER SAVE R, BY GEORGE! POP P,A MOVE T,UUOFN JRST UUOH1 ;NOW TRY IT AGAIN ;;; MAY CALL UUOBNC AND UUOBAK ONLY WHEN *RSET IS KNOWN ;;; TO BE NON-NIL - AVOIDS CERTAIN TIMING ERRORS. UUOBNC: POP P,UUOBKG ;UUOBKG WITH NO CPOPJ HRROS UUOBKG ;FOR UUO GUYS THAT CALL IAPPLY, JRST UUOBK0 ; WHICH ITSELF SETS UP A CPOPJ UUOBAK: POP P,UUOBKG ;WATCH THIS CROCK! JRST UUOBK7 ;;;UUOBKG: 0 UUBKG1: SKIPN V.RSET ;CHECK TO SEE WHETHER IN *RSET MODE JRST @UUOBKG ;SAVES ALL ACS; T HAS -<# OF ARGS> UUOBK7: HRRZS UUOBKG UUOBK0: SKIPE NIL PUSHJ P,NILBAD PUSH FXP,TT ;PDLS MUST BE AS FRETURN WOULD WANT PUSH FXP,R ; TO RESTORE THEM TO JUMPGE T,UUOBK1 ;IF T>0, THEN ASSUME 0, AND THE JSP TT,ARGP0 ; ARGS WILL BE FILLED IN LATER MOVNI TT,(T) SKIPGE A SETZ TT, HRLM TT,(P) JRST UUOBK8 UUOBK1: PUSH P,R70 UUOBK8: MOVEI TT,-2(FXP) HRLI TT,(FLP) PUSH P,TT HRRZ TT,40 HRLI TT,(SP) PUSH P,TT JUMPLE T,UUOBK5 PUSH P,R70 JRST UUOBK6 UUOBK5: PUSH P,[$APPLYFRAME] UUOBK6: MOVS R,40 HRRI R,CPOPJ SKIPL UUOBKG ;MAYBE DON'T WANT THE CPOPJ PUSH P,R HRRZS UUOBKG POP FXP,R POP FXP,TT JRST @UUOBKG UUOSBR: HLRZ T,(T) ;*** FSUBR CALLED LIKE FSUBR MOVEM P,UUPSV MOVNI R,1 TLOA A,400000 UUOSB2: MOVEI R,1 ;R>0 SAYS DON'T DO FRAME HACKERY UUOSB3: MOVE TT,40 ;OTHERWISE R HAS -<# OF ARGS> UUOSB5: TLO T,(PUSHJ P,) TLNE TT,(1_33) ;THE NO-PUSH, OR JRST, BIT. SEE DEFINITION OF JCALL TLCA T,(JRST#) PUSH P,UUOH UUOSB6: JUMPG R,UUOSB7 EXCH T,R JSR UUOBKG EXCH T,R UUOSB7: TLZ A,-1 TLNE TT,(20_33) ;THE NUMERIC CALL BIT. SEE DEFINITION OF NCALL AOS T ;FOR NCALL, ENTER AT ENTRY+1 SKIPN VNOUUO TLNE TT,(2_33) ;THE NO-CLOBBER BIT. SEE DEFINITION OF CALLF JRST UUOXT0 SOS TT,UUOH UUOSB4: LDB R,[331100,,(TT)] CAIN R,XCT_-33 JRST UUOXCT ;MAKE XCT OF UUO WORK MOVEM T,(TT) UUOXT0: TLNN T,(34_33) ;CAUSE EXIT TO INDIRECT THRU ACALL TLO T,(@) UUOXIT: EXCH T,UUTSV UUOXT1: MOVE TT,UUTTSV MOVE R,UURSV JRST @UUTSV UUOXCT: LDB R,[220400,,(TT)] ;GET INDEX FIELD OF XCT JUMPE R,.+2 HRRZ R,@UUOACS-1(R) ;IF NON-ZERO, GET CONTENTS OF THAT AC ADD R,(TT) ;ADD IN ADDRESS FIELD HLL R,(TT) MOVEI TT,(R) TLNE R,(@) JRST UUOXCT ;MAKE INDIRECTION WIN JRST UUOSB4 ;MAKE XCT OF XCT ... OF XCT OF UUO WIN ;;; TABLE OF WHERE TO FIND THE ACS AS THEY WERE ON UUO ENTRY UUOACS: IRPS X,,[A B C AR1 AR2A UUTSV UUTTSV D UURSV F FREEAC UUPSV FLP FXP SP] X TERMIN UUOARR: HLRZ R,(T) ;*** ARRAY CALLED LIKE SUBR MOVSI TT,(@) JRST UUOS03 UUOS0: SETZ TT, ;*** SUBR CALLED LIKE SUBR HRRZ R,UUOFN UUOS03: MOVEM P,UUPSV ;THIS IS TO HELP UUOXCT HLR TT,(T) PUSH P,TT LDB T,[270400,,40] MOVNS T PUSH FXP,T PUSHJ P,ARGCHK ;SKIPS IF OK JRST UUOS0E POP FXP,R ;R NOW HAS -<# OF ARGS> POP P,T TLNN T,(@) ;FURTHER WORK NEEDED FOR CALLING AN ARRAY JRST UUOSB3 MOVSI TT,TTS HLL A,40 ;UUOSB7 WILL CLEAR LEFT HALF OF A TLNN A,2000 ;DO NOT SET THE COMPILED-CODE- IORM TT,TTSAR(T) ; NEEDS-ME BIT FOR A CALLF! MOVE TT,40 TLZN TT,(20_33) JRST UUOSB3 TLNN TT,(2_33) JRST UUOAR2 ;NCALL'ING AN ARRAY MEANS CLOBBER, PUSH P,[UUONVL] ; IF ANY, SHOULD BE TO ACALL JRST UUOSB5 UUOAR2: TLNN TT,1000 TLOA T,(ACALL) ;NCALL, BUT NOT NCALLF => ACALL TLOA T,(AJCALL) ;NJCALL, BUT NOT NJCALF => AJCALL PUSH P,UUOH TLZ TT,777000 TLZ T,(@) JRST UUOSB6 UUONVL: SKOTT A,FX+FL JRST UUONVE FIX7: MOVE TT,(A) ;OF COURSE, THE ROUTINE HAD BETTER COME UP POPJ P, ;WITH SOME LISP NUMBER AS VALUE UUOS1E: PUSH FXP,D MOVEI D,1 JRST UUOE3 UUOS2E: MOVEM D,(FXP) ;TAKE THE SPOT ALREADY PUSHED ON FXP MOVEI D,3 UUOE3: PUSHJ P,SAVX3 ;ARGS WERE ALREADY ON PDL, HENCE MUST BE POPPED OFF MOVEM B,QF1SB ;SO WE MIGHT AS WELL LIST THEM UP WHILE WE'RE AT IT PUSH FXP,T PUSHJ FXP,LISTX POP FXP,T MOVE B,QF1SB JRST UUOE2 UUOS0E: SUB P,R70+1 UUOS0F: PUSH FXP,D PUSHJ P,SAVX3 MOVEI D,0 UUOE2: TLNE D,2 ;D 1.2 => EXIT ADDRESS ALREADY BEEN HACKED JRST .+4 MOVE R,40 TLNN R,1000 PUSH P,UUOH PUSHJ FXP,SAV5M1 PUSH P,[UUOSE1] MOVE TT,40 HRLS TT PUSH P,TT ;NAME OF FUNCTION IN LH TRNN D,1 ;1.1 => LISTING HAS ALREADY BEEN DONE JSP TT,ARGP0 ;ARGS TO FUNCTION NOW ON PDL MOVEM D,-1(FXP) PUSHJ P,RSTX3 ;RECUPERATE - IF POSSIBLE, DO NEW EVALUATION JRST WNAERR ;OR ELSE CRAP OUT ON WRONG NUMBER ARGS UUOSE1: PUSHJ FXP,RST5M1 POP FXP,D POPJ P, UUOS1: HRRZ TT,(T) ;*** SUBR CALLED LIKE LSUBR HLRZ T,(T) EXCH T,UUTSV JSP R,PDLARG HRRZ R,UUOFN PUSHJ P,ARGCK0 ;FORCE CHECKING OF NUMBER OF ARGS JRST UUOS0F MOVE TT,40 TLNE TT,(20_33) ;THE NCALL BIT AOS UUTSV TLNN TT,(1_33) ;THE NO-PUSH, OR JRST, BIT. SEE DEFINITION OF JCALL PUSH P,UUOH JSR UUOBKG JRST UUOXT1 UUOX4B: SKIPN UUOH ;=0 MEANS ENTRY FROM MAP SERIES JRST (R) PUSHJ FXP,SAV5M1 PUSH P,CR5M1PJ JRST (R) UUOLSB: MOVEM P,UUPSV ;*** LSUBR CALLED LIKE LSUBR MOVEI A,NIL HLRZ T,(T) SKIPN V.RSET JRST UUOSB2 PUSH FXP,T ;SAVE T (ADDRESS OF LSUBR) MOVE T,UUTSV PUSH FXP,T ;SAVE -<# OF ARGS> FOR UUOFUL HRRZ R,UUOFN ;FOR ARGCK0 PUSHJ P,ARGCK0 JRST UUOS1E MOVE R,T ;WATCH THIS SHUFFLING OF R, T, AND UUTSV! JSP T,NPUSH-6 ;SIX SLOTS FOR "APPLY FRAME", ETC. MOVE T,UUTSV MOVEM R,UUTSV MOVEI T,(P) UUOLB3: AOJG R,UUOLB4 ;SO SLIDE STUFF SIX SLOTS UP THE PDL MOVE TT,-6(T) ;AT END, T POINTS TO LAST OF THE FIVE MOVEM TT,(T) ; FRAME SLOTS FOR UUOFUL SOJA T,UUOLB3 UUOLB4: MOVE TT,40 ;FIGURE OUT IF CALL OR CALLF TYPE MOVEI R,CPOPJ ; (MAY BE CALL TYPE IF 0 ARGS) TLO R,(PUSHJ P,) ;FIGURE IT OUT TLNE TT,1000 ;IT MAY LOOK LIKE WE'RE CONSTRUCTING A PUSHJ TLCA R,(JRST#) ; TO THE WRONG PLACE, BUT READ THIS CAREFULLY! HRR R,UUOH ;RETURN ADDRESS MUST GO UNDER HRRZM R,-5(T) ; THE FRAME, NOT OVER!!! HLLM R,-1(FXP) ;SAVE INSTRUCTION TO CLOBBER WITH MOVEI TT,(T) PUSHJ P,UUOFUL ;SO STICK AN APPLY FRAME UNDER ARGS, IF ANY ;REMEMBER, UUOFUL EXPECTS TWO FROBS ; ON FXP, AND POPS ONE OF THEM POP FXP,T ;RESTORE T (ADDRESS OF LSUBR) MOVE TT,40 JRST UUOSB7 UUOFUL: MOVS R,40 ;PUT FRAME UNDER LSUBR CALL HRRI R,CPOPJ ;TT POINTS TO LAST OF 5 PDL SLOTS MOVEM R,(TT) ;USES T,TT,R MOVEI R,-2(FXP) ;FXP HAS -<# OF ARGS> AND ONE HRRM R,-3(TT) ; OTHER SLOT AS WELL HRLM FLP,-3(TT) HRLM SP,-2(TT) HRRZ R,40 HRRM R,-2(TT) POP FXP,T MOVEI R,(T) HRLI R,-1(T) ADDI R,(P) SKIPN T SETZ R, MOVEM R,-4(TT) MOVE R,[$APPLYFRAME] MOVEM R,-1(TT) POPJ P, UUOS9: SKIPA TT,CILIST ;*** LSUBR CALLED LIKE FSUBR UUOS7: MOVEI TT,ARGPDL ;*** LSUBR CALLED LIKE SUBR MOVE R,40 TLNN R,1000 PUSH P,UUOH HLRZ T,(T) TLNE R,(20_33) ;THE NCALL BIT ADDI T,1 PUSH FXP,T PUSH FXP,XC-1 SKIPN V.RSET JRST UUOS7A MOVEI T,1 PUSHJ P,UUOBAK REPEAT 2, SOS -3(P) ;ALLOW FOR TWO FROBS ON FXP HRRZM P,(FXP) UUOS7A: JSP TT,(TT) ;ARGPDL OR ILIST POP FXP,R JUMPL R,UUOS7K SKIPN TT,T JRST UUOS7H HRLI TT,-1(TT) ADDI TT,1(P) UUOS7H: MOVEM TT,-4(R) MOVE TT,[$APPLYFRAME] MOVEM TT,-1(R) ;APPLYFRAME DONE UUOS7K: MOVEM T,UUTSV HRRZ R,UUOFN PUSHJ P,ARGLCK JRST UUOS2E POP FXP,T MOVEI A,0 JRST UUOXIT UUOS2A: HLRZ TT,(T) ;*** ARRAY CALLED LIKE FSUBR MOVEM TT,LISAR MOVEI R,(TT) MOVEI TT,IAPAR1 JRST UUOS2Q UUOS2: HLRZ TT,(T) ;*** SUBR CALLED LIKE FSUBR HRRZ R,UUOFN UUOS2Q: MOVE T,40 TLNN T,1000 PUSH P,UUOH TLNE T,(NCALL) PUSH P,[UUONVL] CAIN T,IAPAR1 PUSH P,LISAR PUSH FXP,TT ;SUBR ADDR CILIST: JSP TT,ILIST ;ILIST FORTUNATELY SAVES R PUSHJ P,ARGCHK JRST UUOS2E JSP R,PDLARG POP FXP,TT ;PRESERVE T FOR UUOBKG CAIN TT,IAPAR1 POP P,LISAR JSR UUOBKG MOVEI T,(TT) ;BEWARE! LOOSE SUBR POINTER JRST UUOXIT UUOS1A: HLRZ TT,(T) ;*** ARRAY CALLED LIKE LSUBR MOVEM TT,LISAR MOVEI T,IAPAR1 ;HAIR SO INTERRUPTS WON'T SCREW US EXCH T,UUTSV JSP R,PDLARG ;SAVES TT JSR UUOBKG ;ALSO SAVES TT, AND WANTS NOTHING ON PDLS LDB R,[TTSDIM,,TTSAR(TT)] MOVE TT,40 TLNN TT,1000 PUSH P,UUOH TLNE TT,(NCALL) PUSH P,[UUONVL] MOVNI R,(R) CAMN R,T JRST UUOXT1 PUSH FXP,D PUSHJ P,SAVX3 MOVEI D,2 JRST UUOE2 ;;; PUTCODE [EXPR _ FSUBR]40 UUOS4: POP P,A ;*** FEXPR CALLED LIKE LSUBR MOVN TT,UUTSV JRST UUOS4A UUF2N: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE FSUBR UUOS6: HLRZ TT,(T) ;*** EXPR CALLED LIKE FSUBR MOVE R,40 TLZN TT,-1 ;UUF2N LEAVES LH OF T ^= 0 HRL TT,R ;OTHERWISE GET SUBR EXPR NAME IN LH TLNN R,1000 PUSH P,UUOH TLNE R,(20_33) ;THE NCALL BIT PUSH P,[UUONVL] JSP R,UUOX4B SKIPN V.RSET JRST UUOS6Q PUSH P,FXP ;IF IN *RSET MODE, MAKE HRLM FLP,(P) ; UP AN EVAL FRAME (SEE EVAL MOVEI C,(A) ; FOR FORMAT THEREOF) HRRZ B,40 PUSHJ P,XCONS ;MUST CONS UP FAKE ARG TO EVAL PUSH P,A HRLM SP,(P) PUSH P,[$EVALFRAME] MOVEI A,(C) UUOS6Q: PUSH P,TT ;PUSH OF FUNCTION MOVEI TT,IAPPLY JRST ILIST UUOS11: MOVEM T,UUOFN ;*** FSUBR CALLED LIKE LSUBR MOVE T,UUTSV JRST UUS10A ;;; ENDCODE [EXPR _ FSUBR] UUOS3: LDB TT,[270400,,40] ;*** FEXPR CALLED LIKE SUBR UUOS4A: SOJN TT,UUOFER UUOEX2: MOVEI TT,1 ;*** FEXPR CALLED LIKE FSUBR DPB TT,[270400,,40] TLOA A,400000 UUOS: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE SUBR UUOEXP: HLRZ TT,(T) ;*** EXPR CALLED LIKE SUBR LDB T,[270400,,40] UUOEX4: MOVE R,40 ;ALL OF T,TT,R WILL BE LOST! TLZN TT,-1 ;INSERT EXPR NAME IF WAS EXPR HRL TT,R TLNN R,1000 PUSH P,UUOH MOVN T,T SKIPE V.RSET PUSHJ P,UUOBNC TLNE R,(NCALL) PUSH P,[UUONVL] JSP R,UUOX4B PUSH P,TT ;PUSH FUNCTION JUMPE T,IAPPLY MOVEM T,UUTSV HRLZ R,UUTSV MOVE A,1(R) JSP T,PDLNMK PUSH P,A ;PUSH ARGUMENT AOBJN R,.-3 MOVE T,UUTSV JRST IAPPLY ;APPLY FUN TO ARGS UUOS10: MOVEM T,UUOFN ;*** FSUBR CALLED LIKE SUBR JSP TT,ARGPDL UUS10A: AOJN T,UUOFER POP P,A MOVSI T,2000 IORM T,40 MOVE T,UUOFN JRST UUOSBR UUL2N: SKIPA TT,40 ;*** NONATOMICFUN CALLED LIKE LSUBR UUOS5: HLRZ TT,(T) ;*** EXPR CALLED LIKE LSUBR MOVE T,UUTSV CAMGE T,XC-NACS JRST UUOS5A JSP R,PDLARG MOVNS T JRST UUOEX4 UUOS5A: PUSH FXP,T ;DAMN CASE WHERE WE MUST PUSH FXP,V.RSET ; SLIDE STUFF UP THE PDL, MOVEI R,(P) ; DOING PDLNMK'S AS WE GO JSP T,NPUSH-3-NACS+1 ;ROOM FOR ALL ACS BUT A, PLUS 3 SKIPE (FXP) JSP T,NPUSH-5 ;EXTRA SLOTS FOR *RSET MOVEI D,(P) MOVE F,-1(FXP) UUOS5B: MOVE A,(R) ;SO DO ALL THE PDLNMK'S JSP T,PDLNMK MOVEM A,(D) SUBI R,1 SUBI D,1 AOJL F,UUOS5B HRL TT,40 ;TT HAS BEEN SAVED - HAS FN MOVEM TT,(D) ;SAVE FUNCTION BELOW ARGS FOR IAPPLY SKIPE (FXP) ;D SHOULD POINT TO WHERE ACS ARE SAVED SUBI D,5 ;FOR *RSET, MUST SAVE THE ACS UNDER THE FRAME! REPEAT NACS-1, MOVEM B+.RPCNT,.RPCNT-NACS(D) ;SAVE ALL MARKED ACS BUT A MOVEI TT,R5M1PJ ;PROVIDE FOR RESTORING THEM MOVEM TT,-1(D) ;ACS WERE SAVED UNDER, NOT OVER, THE MOVE TT,40 ; FRAME IN CASE OF AN FRETURN MOVE F,UUOH ;MAYBE NEED RETURN ADDRESS UNDER TLNE TT,1000 ; THE ARGS (IF NOT, USE A CPOPJ) MOVEI F,CPOPJ MOVEM F,-NACS-1(D) POP FXP,F JUMPE F,UUOS5C ;MAYBE MORE *RSET HAIR? PUSH FXP,(FXP) ;DUPLICATE NUMBER OF ARGS ON FXP MOVEI TT,4(D) ;TT POINTS TO THE FIVE *RSET SLOTS MOVEM TT,-1(FXP) ;PLOP POINTER INTO PDL SLOT PUSHJ P,UUOFUL ;SET UP APPLYFRAME (POPS FXP) POP FXP,TT HRRZS (TT) ;FLUSH CPOPJ - IAPPLY WILL CREATE ONE JRST IAPPLY UUOS5C: POP FXP,T ;NOW FOR THE IAPPLY JRST IAPPLY ;UUOFUL WANTS TWO THINGS ON FXP, WILL POP ONE ARGCHK: CAMGE T,XC-NACS ;CHECK NUMBER OF ARGS SUPPLIED JRST PAERR ;R HAS ATOM PROPERTY LIST POINTER ARGLCK: SKIPE V.RSET JRST ARGCK2 ARGCK1: POP P,TT ;FOR SPEED, DO THIS RATHER THAN JRST 1(TT) ;AOS (P) POPJ P, ARGCK2: SKOTT R,SY ;R HAS SYMBOL OR SAR JRST ARGCK5 ;MUST BE A SAR ARGCK0: HLRZ R,(R) HLRZ R,1(R) JUMPE R,ARGCK1 LDB TT,[111100,,R] JUMPN TT,ARGCK3 ARGCK4: LDB TT,[001100,,R] MOVNI TT,-1(TT) CAMN T,TT AOS (P) POPJ P, ARGCK3: MOVNI TT,-1(TT) CAMLE T,TT POPJ P, LDB TT,[001100,,R] CAIN TT,777 ;777 IS EFFECTIVELY INFINITY JRST POPJ1 MOVNI TT,-1(TT) CAML T,TT AOS (P) POPJ P, ARGCK5: LDB R,[TTSDIM,,TTSAR(R)] AOJA R,ARGCK4 ARGPDL: LDB T,[270400,,40] ;ARGS => PDL -CNT=> T MOVNS T ARGP0: HRLZ R,T ARGP1: JUMPE R,(TT) PUSH P,A(R) AOBJN R,.-1 JRST (TT) PDLARG: CAMGE T,XC-NACS PAERR: LERR EMS16 ;MORE THAN 5 ARGS JRST .+1+NACS(T) REPEAT NACS,[CONC RSTR,\,: POP P,A-1+NACS-.RPCNT ] PDLA2: JRST (R) MOVEI D,QSUBRCALL ;COME HERE IF SUBRCALL (Q.V.) GOT 0 ARGS SOJA T,WNALOSE STRTOUT: SUBI T,STRT_-33 ;FLAG NON-ZERO IF STRT7 CALL EXCH T,UUTSV PUSH P,UUOH ;PUSH RETURN ADDR FOR FINAL EXIT PUSH P,A PUSHJ P,SAVX5 PUSH FXP,UUTSV PUSH FXP,40 PUSH P,AR1 PUSH P,AR2A LDB D,[270400,,(FXP)] ;AC=17 MEANS USE MSGFILES. CAIN D,17 JRST ERP0D SKIPN AR1,(D) ;NIL MEANS USE DEFAULT ^R AND ^W JRST ERP0C CAIN AR1,QUNBOUND ;GIVEN UNBOUND VARIABLE? LERR [SIXBIT \UNBOUND VARIABLE IN PRINC FROM COMPILED CODE --GSB!\] ERP0E: TLO AR1,200000 ERP0F: MOVEI A,(AR1) LSH A,-SEGLOG SKIPL ST(A) ;MAYBE SHOULD ERRR-CHECK BETTER? TLO AR1,400000 ;NOTE WHETHER LIST OR NOT ERP0A: JSP T,GTRDTB .5LOCKI ERBPLOC==-1 ;LOCATION OF BYTE PTR ON FXPDL ER7PLOC==-2 ;LOCATION OF STRT7-P ON FXPDL SKIPE ER7PLOC(FXP) ;STRT7-P? JRST ERP7A MOVSI D,440600 HLLM D,ERBPLOC(FXP) ERP1: ILDB TT,ERBPLOC(FXP) ;STRING BYTE POINTER IS STORED ON FXP CAIN TT,'# ;THE .5LOCKI SAVED INHIBIT ON TOP OF FXP JRST ERP3 CAIN TT,'! JRST ERP6 CAIN TT,'^ JRST ERP4 ERP5: ADDI TT,40 ERP5A: PUSHJ P,STRTYO JRST ERP1 ERP7A: MOVSI D,440700 HLLM D,ERBPLOC(FXP) ERP7: ILDB TT,ERBPLOC(FXP) ;STRING BYTE POINTER IS STORED ON FXP JUMPE TT,ERP6 PUSHJ P,STRTYO JRST ERP7 ERP0D: SKIPN AR1,VMSGFILES JRST ERP6A JRST ERP0E ERP0C: SKIPE AR1,TAPWRT HRRZ AR1,VOUTFILES JUMPN AR1,ERP0F SKIPE TTYOFF JRST ERP6A JRST ERP0A ERP3: ILDB TT,ERBPLOC(FXP) ;QUOTE A CHAR JRST ERP5 ERP4: ILDB TT,ERBPLOC(FXP) ;CONTROLLIFY A CHAR ADDI TT,40 TRC TT,100 CAIE TT,^M JRST ERP5A PUSHJ P,STRTYO MOVEI TT,^J JRST ERP5A ERP6: UNLOCKI ;DONE! ERP6A: POP P,AR2A POP P,AR1 SUB FXP,R70+2 ;FLUSH BYTE PTR AND STRT7P SWITCH POP P,A ;RESTORE A JRST RSTX5 ;RESTORE NUMACS AND POPJ ENDFUN==.-1 .SEE SSYSTEM ;NO MORE FUNCTIONS BEYOND HERE SUBTTL INITIAL STARTUP CODE ;;; NORMAL G STARTUP CODE. ON FIRST RUN, THE ALLOC PHASE COMES HERE; ;;; THEREAFTER, LISPGO COMES HERE DIRECTLY. ;;; WE DO NOT HAVE THE USE OF THE PDLS UNTIL THE CALL TO ERINIX. ;;; WE DO NOT HAVE THE USE OF CONSING OF ANY SORT UNTIL THE CALL TO GCNRT. LISP: ;CLEAR AND DISABLE INTERRUPT SYSTEM IFN ITS,[ PION .SUSET [.SPIRQC,,R70] .SUSET [.SIFPIR,,R70] .SUSET [.ROPTION,,TT] TLO TT,OPTINT+OPTOPC ;NEW-STYLE INTERRUPTS AND NO PC SCREWAGE .SUSET [.SOPTION,,TT] TLNN TT,OPTBRK ;IF OUR SUPERIOR CLAIMS TO HANDLE BREAKS, JRST LISP17 ; AND IF IT CLAIMS TO HAVE LISP'S SYMBOL TABLE .BREAK 12,[..RSTP,,TT] ; VALRET A STRING TO CAUSE & TYPEOUT MODE SKIPGE TT ; TO BE S-EXP TYPEOUT (AND % TO BE SQUOZE) .VALUE [ASCIZ /:IF N :SYMTYP P% (..TAMP\ ..TPER\1Q ..TAMP\P% ):VP /] LISP17: ] ;END OF IFN ITS 20$ JSP R,TNXSET ;DECIDE WHICH OPSYS - TENEX OR TOPS20 ; AND FIX UP PAGE ACCESSIBILITYS IFN USELESS*, JSP T,SHAREP ;CONSIDER SHARING PAGES WITH OTHER JOBS PION ;ENABLE INTERRUPTS ;RESET I/O SWITCHES SETZM TAPWRT ;UWRITE FLAG (^R) SETZM TTYOFF ;TTY OUTPUT FLAG (^W) IFN JOBQIO,[ IT$ .DTTY ;SAY THIS JOB WANTS THE TTY, RATHER IT$ JFCL ; THAN LETTING AN INFERIOR HAVE IT IT% WARN [RETRIEVE TTY FROM INFERIOR?] ] ;END OF IFN JOBQIO ;RESET FREELISTS TO FORCE A CLEAN GARBAGE COLLECTION REPEAT NFF, SETZM FFS+.RPCNT ;SET FREELISTS TO NIL IFN HNKLOG+DBFLAG+CXFLAG, MOVSI A,(SETZ) IFN HNKLOG,[ REPEAT HNKLOG+1,[ SKIPN HNSGLK+.RPCNT ;HACK TO AVOID CREATING MOVEM A,FFH+.RPCNT ; UNNEEDED HUNK SEGMENTS ] ;END OF REPEAT HNKLOG+1 ] ;END OF IFN HNKLOG DB$ SKIPN DBSGLK ;DITTO FOR WEIRD NUMERIC TYPES DB$ MOVEM A,FFD ;THE SETZ BIT IN THE FREELIST CX$ SKIPN CXSGLK ; POINTER MEANS IT IS OKAY TO CX$ MOVEM A,FFC ; HAVE NO FREE CELLS AS LONG AS DX$ SKIPN DXSGLK ; NO ONE TRIES TO CONS ONE DX$ MOVEM A,FFZ SETZM GCTIM ;RESET GC TIME (SINCE RUNTIME PROBABLY GOT RESET?) SETZM ALGCF ;RESET ALLOC FLAG - OKAY TO GC NOW JSP T,TLVRSS ;RESET VARIOUS "TOP LEVEL VARIABLES" JSP A,ERINIX ;SET UP PDLS, RESTORE MUNGED DATA, ENABLE INTERRUPTS ;INITIALIZE DEFAULT DIRECTORY NAMES JSP T,PPNUSNSET ;TRY TO OPEN THE TERMINAL AS AN I/O DEVICE PUSHJ P,OPNTTY JFCL ;PERFORM INITIAL GARBAGE COLLECTION (BUT DON'T BOTHER TO COMPACT ARRAYS) MOVSI T,111111 PUSHJ P,GCNRT PUSHJ P,UDIRSET ;INITIALIZE CURRENT UNIT ;INITIALIZE VARIOUS BIZARRE TOP-LEVEL VARIABLES MOVEI T,INR70 MOVEM T,VTTSR MOVEI A,Q. ;INITIAL VALUE OF * IS * MOVEM A,V. MOVE A,VERRLIST ;SET UP FOR EVAL'ING ERRLIST MOVEM A,VIQUOTIENT SKIPGE AFILRD JRST LSPRET LIHAC: SETOM AFILRD ;HAIRY HAC TO READ, THE FIRST TIME MOVEI A,TRUTH ; AROUND, FROM THE .LISP. (INIT) FILE MOVEM A,TAPRED ;(SETQ ^Q T) JRST HACENT IFN ITS,[ LISP43: SETZ SIXBIT \SSTATU\ REPEAT 5, 2000,,TT ;IGNORE USELESS GARBAGE 402000,,TT ;MACHINE NAME ] ;END OF IFN ITS 10$ WAKTTY: JRST (T) SUBTTL PPNUSNSET UDIRSET TNXSET D10SET PPNUSNSET: IFN D10,[ SA% GETPPN TT, ;FOR TOPS10/CMU, USE GETPPN SA% JFCL ; (GETS PPN OF CURRENT JOB) SA$ SETZ TT, ;FOR SAIL, WE PREFER DSKPPN SA$ DSKPPN TT, ; (AS SET BY THE ALIAS COMMAND) MOVEM TT,USN MOVEM TT,TTYIF2+F.PPN MOVEM TT,TTYOF2+F.PPN ] ;END OF IFN D10 IFN ITS,[ MOVE TT,IUSN MOVEM TT,TTYIF2+F.SNM MOVEM TT,TTYOF2+F.SNM ] ;END OF IFN ITS JRST (T) ;INITIALIZE THE NAME OF THE MACHINE IN THE FEATURES LIST ;INITIALIZE (STATUS UDIR) UDIRSET: IFN ITS,[ .CALL LISP43 ;GETS NAME OF ITS (AI, MC, ML, DM) IN TT .VALUE SETZ A, ;CONVERT TO ATOMIC SYMBOL HLRZS TT IRP X,,[AI,ML,MC,DM] CAIN TT,(SIXBIT \X\) MOVEI A,Q!X TERMIN SKIPN A .VALUE HRLM A,SITEFT ;SET UP (STATUS FEATURES) FOR SITE NAME ] ;END OF IFN ITS MOVE TT,BPSH ;IF BPEND SOMEHOW CAMGE TT,@VBPEND ; IS LARGER THAN BPSH, PUSHJ P,BPNDST ; SET IT EQUAL TO BPSH 10$ PUSHJ P,SIXJBN ;INITIALIZE TEMP FILE NAME D10NAM IFN D10,[ IFE SAIL,[ MOVNI T,1 ;FOR NON-SAIL, TRY TO GET SETZB TT,D ; DEFAULT SNAME BY USING PATH. MOVEI R,0 MOVE F,[4,,T] PATH. F, ] ;END OF IFE SAIL MOVE D,USN ;ON FAILURE, JUST USE USN MOVE TT,D ;PPNATM EXPECTS PPN TO BE IN AC TT PUSHJ P,PPNATM ] ;END OF IFN D10 IFN ITS,[ MOVEI A,0 ;;; Following will be done by (STATUS UDIR) ;;; MOVE TT,IUSN ;TAKE INITIAL SNAME ;;; PUSHJ P,SIXATM ;CONVERT TO ATOMIC SYMBOL ] ;END OF IFN ITS 20% MOVEM A,SUDIR POPJ P, IFN D20,[ TNXSET: MOVE A,[112,,11] ;MUST BE CALLED WHEN INTERRUPTS ARE OFF GETTAB A, JRST TNXST9 ;LOSE IF WE CANT DECIDE! LDB A,[141400,,A] ;3 FOR TENEX, 4 FOR TOPS-10 SUBI A,2 CAIE A,1 MOVEI A,NIL MOVEM A,TENEXP MOVEI D,2 ;CCOC2 BITS FOR ^_ MOVEI B,QTOPS20 JUMPE A,.+3 MOVEI D,1 MOVEI B,QTENEX DPB D,[100200,,CCOCW2] HRLM B,OPSYFT ;MAYBE SOMEDAY WE COULD FIGURE OUT THE ARPA HOST NAME HERE??? HRLM B,SITEFT MOVEI TT,1_17.-SEGSIZE+1 TNXST0: MOVEI D,(TT) LSH D,-SEGLOG ;GET SEGMENT NUMBER HLL D,ST(D) TLNE D,ST.$NX JRST TNXST1 MOVSI A,.FHSLF HRRI A,(D) ;GET PAGE NUMBER JSP T,IPURE$ ;MAKE SURE PAGE EXISTS AND B,[PA%RD+PA%WR+PA%EX+PA%CPY] TLO B,(PA%RD) ;LET IT BE READABLE TLNE D,ST.LS+ST.FX+ST.FL+ST.BGN TLZA B,(PA%EX) ;DONT EXECUTE FROM DATA AREAS TLO B,(PA%EX) TLNE D,ST.PUR JRST TNXST2 TLNE B,(PA%CPY) ;WHY WOULD BOTH PA%CPY AND PA%WR TLZA B,(PA%WR) ; BOTH BE ON??? TLNN B,(PA%WR) ;IF ALREADY WRITEABLE, DONT MAKE TLO B,(PA%CPY) ; COPYABLE JRST TNXST4 TNXST2: TLZ B,(PA%CPY+PA%WR) ;NOT WRITEABLE, IF A "PURE" PAGE SKIPN PSYSP ; PSYSP is override TLO B,(PA%CPY) TNXST4: SPACS TNXST1: SUBI TT,SEGSIZE JUMPG TT,TNXST0 JRST (R) ] ;END OF IFN D20 IFN D10*<1-SAIL>,[ D10SET: MOVE TT,[%CCTYP] ;KA 10 VS KL/KI 10 ? GETTAB TT, JRST .+4 ;DO RUNTIME TEST IF ENTRY NOT THERE CAIE TT,.CCKAX MOVEI TT,0 JRST .+3 MOVNI TT,1 ;AOBJN ON -1 LEAVES [1,,0] ON A KA10 AOBJN TT,.+1 ; BUT [0] ON A KL OR KI MOVEM TT,KA10P SETZM MONL6P SETZM CMUP MOVEI A,QTOPS10 HRLM A,OPSYFT ;MAYBE SOMEDAY WE COULD FIGURE OUT THE ARPA HOST NAME HERE??? HRLM A,SITEFT MOVE A,[%CNMNT] ;GET MONITOR TYPE WORD GETTAB A, MOVEI A,010000 ;ASSUME TOPS-10 IF GETTAB ENTRY NOT THERE LDB A,[.BP CN%MNT,A] ;1 = TOPS-10, 2 = ITS, 3 = TENEX, 6 = TOPS-20 SOJE A,.+3 ;REAL TOPS-10 SYSTEM, RATHER THAN SIMULATOR? SETZB A,SGANAM ; ON VARIOUS SIMULATIONS, DONT KILL HISEG JRST (T) MOVE A,[%CNVER] GETTAB A, ;GET MONITOR LEVEL NUMBER MOVSI A,5 LDB A,[140600,,A] CAIN A,6 SETOM MONL6P MOVE A,[%CNFG0] GETTAB A, MOVE A,[ASCIZ \CMU10\] CAME A,[ASCIZ \CMU10\] JRST (T) SETOM CMUP MOVEI A,QCMU HRLM A,OPSYFT ;MAYBE SOMEDAY WE COULD FIGURE OUT THE ARPA HOST NAME HERE??? HRLM A,SITEFT JRST (T) ] ;END OF D10*<1-SAIL> SUBTTL JCL INITIALIZATION ROUTINE 20$ WARN [D20 JCL?] IFN D10,[ JCLSET: SETZ D, MOVE R,[440700,,SJCLBUF+1] SA% RESCAN SA$ RESCAN A SA% CAIA SA$ SKIPN A JRST JCST3 JCST4: INCHRS B JRST JCST3 CAIE B,^M ;IF OR OCCURS ON COMMAND CAIN B,33 JRST JCST3 ;BEFORE A ";", THEN NO JCL CAIE B,"; CAIN B,"( CAIA JRST JCST4 ;LOOP UNTIL WE FIND A ; OR ( MOVNI D,BYTSWD*LSJCLBUF JCST2: INCHRS A JRST JCST1 CAIN B,"( ;IF JCL STARTED WITH A (, CAIE A,") ; ONLY UP TO THE ) IS JCL, CAIA ; BUT WE MUST GOBBLE THE WHOLE LINE SETO B, JUMPL B,JCST5 AOSG D IDPB A,R JCST5: CAIN A,^M ; OR TERMINATES JRST JCST1 ;THE COMMAND LINE CAIE A,33 JRST JCST2 JCST1: SKIPLE D TDZA D,D ;TOO MUCH JCL => NONE AT ALL ADDI D,BYTSWD*LSJCLBUF JCST3: INCHRS A ;MAKE SURE NO SUPERFLUOUS CHAR JFCL MOVEM D,SJCLBUF SETZ A, IDPB A,R ;INSURE AT LEAST ONE NULL BYTE FOLLOWING THE LINE JRST (F) ] ;END OF IFN D10 SUBTTL INTERNAL PCLSR'ING ROUTINES SFXTBL: ;TABLE OF LOCATIONS FOR SFX HACK MACROLOOP NSFC,ZZM,* SFXTBI: ;TABLE OF INSTRUCTIONS NORMALLY IN THOSE LOCATIONS MACROLOOP NSFC,ZZN,* PROTB: ;TABLE OF INTERRUPT PROTECTION INTERVALS MACROLOOP NPRO,PRO,* ;;; TABLE MUST BE AN EXACT POWER OF TWO IN LENGTH SO WE CAN ;;; USE SUPER-WINNING BINARY SEARCH METHOD. HAOLNG LOG2NPRO,<.-PROTB-1> REPEAT <1_LOG2NPRO>-NPRO,[ INTOK,,777777 ] ;END OF REPEAT <1_LOG2NPRO>-NPRO ;;; IT IS OBVIOUSLY USELESS TO USE PROTECT MACROS BEYOND THIS POINT. ;;; EXPUNGING NPRO WILL CAUSE AN ERROR IF THE PROTECT MACROS ARE USED EXPUNGE NPRO ;;; PUSHJ FXP,$IWAIT ;;; CALLED FROM WITHIN A NORMAL INTERRUPT HANDLER TO DECIDE ;;; WHETHER IT IS SAFE TO ISSUE A USER INTERRUPT. ;;; ON FAILURE, STACKS UP THE INTERRUPT AND SKIPS. ;;; AS FOR UINT0, D CONTAINS THE INTERRUPT DESCRIPTOR WORD. ;;; INTERRUPTS MUST BE DEFERRED; PDL OVERFLOW MUST BE ;;; ENABLED. THE CONTENTS OF INTPDL POINTS TO THE INTPDL ENTRY ;;; FOR THE CURRENT INTERRUPT, WHICH CONTAINS THE SAVED ;;; CONTENTS OF D AND R. FXP MUST BE IN A USABLE STATE. $IWAIT: HLRZ R,NOQUIT ;IF IN GC, WE ARE IN A BAD STATE JUMPN R,IWSTAK ; AND SO MUST STACK THE INTERRUPT HRRZ R,INTPDL CAIE R,INTPDL+LIPSAV ;FOR NESTED PI LEVEL (E.G. PDL OVERFLOW), JRST IWSTAK .SEE INTXIT ; ALSO STACK THE INTERRUPT MOVEI R,(SP) ;IF THE SPECPDL IS IN SOME MOVE F,(SP) ; KIND OF STRANGE STATE (E.G. CAME R,ZSC2 ; INTERRUPTED OUT OF SPECBIND) CAMN F,SPSV ; THEN MUST DO THE INTSFX HACK JRST IWLOOK INTSFX: MOVE F,[PUSHJ FXP,SPWIN] MOVSI R,-NSFC .SEE SFX MOVEM F,@SFXTBL(R) ;CLOBBER LOCATIONS MARKED BY SFX SO AOBJN R,.-1 ; SFXPRO'ED ROUTINE WILL RETURN TO SPWIN HRRZ F,INTPDL ;RESTORE AC'S, AND SAVE EXCH D,IPSD(F) ; INTERRUPT DESCRIPTOR MOVE R,IPSR(F) PUSH FXP,IPSPC(F) ;GET PC AND FLAGS MOVEI F,IPSF(F) PUSH FXP,F MOVE F,(F) JRST 2,@-1(FXP) ;CONTINUE WHATEVER WE WERE DOING ;;; RETURN FROM SFX HACK. ROUTINE HAS DONE PUSHJ FXP,SPWIN. SPWIN: MOVEM F,@-1(FXP) ;PRESERVE F HRRZ F,INTPDL POP FXP,IPSPC(F) ;PUT PC BACK INTO INTPDL FRAME, SOS IPSPC(F) ; BACKED UP TO THE CLOBBERED INSTRUCTION SUB FXP,R70+2 MOVEM R,IPSR(F) ;SAVE ACS D AND R EXCH D,IPSD(F) MOVSI R,-NSFC SPWIN1: MOVE F,SFXTBI(R) ;RESTORE THE LOCATIONS THAT WE MOVEM F,@SFXTBL(R) ; CLOBBERED WITH PUSHJ FXP,SPWIN AOBJN R,SPWIN1 JRST IWWIN ;WE HAVE WON IWLOOK: HRRZ F,INTPDL ;FAST BINARY SEARCH OF PROTECT HRRZ R,IPSPC(F) ; TABLE ON PC INTERRUPTED FROM PUSH FXP,D MOVEI D,0 REPEAT LOG2NPRO,[ MOVE F,PROTB+<1_>(D) CAIL R,(F) ADDI D,1_ ] ;END OF REPEAT LOG2NPRO MOVS R,PROTB(D) POP FXP,D HRRZ F,INTPDL ;A USEFUL VALUE FOR F JRST (R) ;GO TO PLACE WHICH HANDLES THIS INTERVAL ;;; COME HERE TO MOVE THE PC FORWARD OUT OF A PROTECTED INTERVAL ;;; BY EXECUTING INTERVENING INSTRUCTIONS. THE ACS ARE CORRECTLY ;;; AVAILABLE DURING THIS EXECUTION, EXCEPT FXP. THE PC FLAGS ARE ;;; NOT PRESERVED. THUS, CODE IN SUCH A PROTECTED INTERVAL SHOULD ;;; NOT USE FXP OR THE PC FLAGS. NO JUMP INSTRUCTIONS MAY BE USED; ;;; HOWEVER, SKIPS ARE HANDLED CORRECTLY. .SEE XCTPRO INTXCT: PUSH FXP,IPSPC(F) EXCH D,IPSD(F) ;RESTORE ACS D, R, AND F MOVE R,IPSR(F) ;FLAGS ARE *NOT* RESTORED MOVEI F,IPSF(F) ;ALSO, FXP IS OUT OF WHACK (BEWARE!) PUSH FXP,F MOVE F,(F) XCT @-1(FXP) ;EXECUTE AN INSTRUCTION CAIA AOS -1(FXP) ;HANDLE SKIPS CORRECTLY AOS -1(FXP) MOVEM F,@(FXP) SUB FXP,R70+1 HRRZ F,INTPDL MOVEM R,IPSR(F) EXCH D,IPSD(F) POP FXP,IPSPC(F) JRST IWLOOK ;MAY NEED TO XCT SOME MORE INTSYP: SOS NPFFY2 .SEE SYCONS INTSYQ: SOS NPFFY2 INTSYX: MOVEI R,PSYCONS JRST INTBK1 INTROT: HLRZ R,R ;PROTECT CODE OF THE FORM SUBI R,1 ; ROT A,-SEGLOG ROT A,SEGLOG ; ... MUNCH ... JRST INTBK1 ; ROT A,SEGLOG INTPPC: HLRZ R,R ;PROTECT PURE CONSER SUBI R,1 ;BACK UP TO THE AOSL OR WHATEVER HRRM R,IPSPC(F) SOS @(R) ;RESTORE THE COUNTER JRST INTOK INTC2X: HLRM B,A ;MUST PROTECT LEFT HALF OF B FOR CONS MOVEI R,CONS1 ;HAIRY KIND OF BACKUP FOR CONS JRST INTBK1 INTC2Y: HLRM B,A ;MUST PROTECT LEFT HALF OF B FOR CONS MOVEI R,%CONS1 ;HAIRY KIND OF BACKUP FOR CONS JRST INTBK1 INTACT: HRRZ R,UUTSV .SEE UUOACL JRST IWLOOK INTTYX: HLRZ R,R ;ARRANGE TO GO TO INTTYR, WHICH WILL PUSH P,R ; GET THE TTSAR BACK INTO T, THEN POPJ MOVEI R,INTTYR .SEE TYOXCT TYIXCT TYICAL HRRZS INHIBIT .SEE .5LKTOPOPJ JRST INTBK1 INTACX: MOVSS A .SEE ACONS ;(RESTORES A FOR BACKUP) MOVEI R,ACONS ;MAKE THIS THE NEW PC JRST INTBK1 20$ INTSLP: ;FOR INTERRUPT FROM D20 SLEEP, MUST FLUSH "A" INTZAX: SETZ A, ;CONSERS WHICH DON'T PROTECT THEIR FREELIST! INTBAK: HLRZ R,R ;BACK UP PC TO BEGINNING INTBK1: HRRM R,IPSPC(F) ; OF INTERVAL INTOK: TLZ R,-1 HS$ 10$ CAIL R,HSGORG ;NO ARRAYS IN HIGH SEGMENT! HS$ 10$ JRST IWWIN CAML R,@VBPEND JRST INTSFX IWWIN: HRRZ F,INTPDL ;WE HAVE WON! POPJ FXP, ;;; NEED WE PIOF AROUND THIS JSR UISTAK ?? E.G. WHAT ABOUT MEMERR? IWSTAK: JSR UISTAK ;WE ARE IN A BAD STATE -- AOS (FXP) ; STACK UP THE INTERRUPT JRST IWWIN PGTOP INT,[INTERRUPT AND UUO HANDLERS] SUBTTL PATCH AREA, STRUCT INSERT, BIT TABLES, AND SPACE CALCULATIONS PATCH: PAT: XPATCH: BLOCK PTCSIZ PAGEUP EPATCH==.-1 INFORM [LENGTH OF PATCH AREA = ]\EPATCH-PATCH PG% BSYSSG==HILOC-STDHI ;CROCK - BEWARE RELOCATION! SPCTOP SYS,,[SYSTEM] PG% EXPUNGE BSYSSG NPURPG==<.-BPURPG>/PAGSIZ 10$ $LOSEG INUM==. ;;@ STRUCT 522 INITIAL LIST STRUCTURE ;;; ***** MACLISP ****** INITIAL LIST STRUCTURE ****************** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** SUBTTL MACROS FOR CREATING INITIAL LIST STRUCTURE PFXEST==3200 ;ESTIMATED SPACE NEEDED FOR PURE FIXNUMS SYMEST==1100 ;ESTIMATED INITIAL NUMBER OF LISP SYMBOLS LSYALC==20 GSNSYSG==/SEGSIZ ;GUESS AT THE NUMBER OF SYM SEGS NEEDED GSNSY2==<+SEGSIZ-1>/SEGSIZ ;GUESS AT THE NUMBER OF SY2 SEGS NEEDED GSNPFXSG==/SEGSIZ ;GUESS AT THE NUMBER OF PFX SEGS NEEDED MAYBE NXVCSG==PAGING*2000/SEGSIZ .NSTGWD ;NO STORAGE WORDS OVER MACRO DEFINITIONS KNOB==0 ;NUMBER OF OBJECTS FOR OBARRAY .XCREF KNOB DEFINE PUTOB A REL$ ADDOB \A-.RL1,\KNOB REL% ADDOB \A,\KNOB TERMIN DEFINE ADDOB A,N DEFINE OB!N REL$ .RL1+A REL% A TERMIN KNOB==KNOB+1 TERMIN ;;; STANDARD FUNCTION MAKERS ;;; MKAT ,,, ;;; MKAT1 ,,,, DEFINE MKAT A,B,C,D Q!B % A,,NIL RMTAH1 [C]A,PNL-2,[A]D,SUNBOUND,100 TERMIN DEFINE MKAT1 A,B,C,D,E Q!B % D,,NIL RMTAH1 [C]D,PNL-2,[A]E,SUNBOUND,100 TERMIN ;;; MKAT2 USED TO CREATE AUTOLOAD ATOMS ;;; MKAT2 ,, DEFINE MKAT2 A,D,C QAUTOLOAD % QFL.!D,,NIL IFSN [C], RMTAH1 [ ]C,PNL-2,[A],SUNBOUND,100 IFSE [C], RMTAH1 [ ]A,PNL-2,[A],SUNBOUND,100 TERMIN ;;; MAKE AN ATOM WITH AUTOLOAD PROPERTY FROM A SHARED PROPERTY LIST ;;; ,<2-CHAR-PLIST-ID>,, DEFINE MKAL A,D,C,E IFSN [C], RMTAH1 [ ]C,D!$AL,[A]E,SUNBOUND,100 IFSE [C], RMTAH1 ,,D!$AL,[A]E,SUNBOUND,100 TERMIN ;;; SAME AS MKAL, BUT WITH A VALUE CELL. ;;; "BRIEF" INTERNAL NAME MAY NOT BE OMITTED DEFINE MKALV A,D,C,E,VAL RMTAH1 [ ]C,D!$AL,[A]E,V!C,100 RMTVC V!C,VAL TERMIN ;;; MAKES AN ATOM WITH A VALUE CELL, BUT NO OTHER PROPERTIES ;;; MKAV ,,, DEFINE MKAV PN,VCL,C,D IFSN [D], RMTAH1 [ ]D,,[PN],C.,100 IFSE [D], RMTAH1 ,,,[PN],C.,100 C..==. LOC C. IFSN [VCL], VCL: .ELSE, V!PN: IFSN [C], C .ELSE, NIL C.==. LOC C.. TERMIN ;;; MAKES A FUNCTION WITH A VALUE CELL ;;; MKFV ,,,, DEFINE MKFV PN,B,C,D,E Q!C % B,,NIL RMTAH1 [ ]B,PNL-2,[PN]E,V!B,100 RMTVC V!B,D TERMIN ;;; STRINGS TOGETHER THE WORDS OF A PNAME INTO A LIST DEFINE APN,PN (F.)!REPEAT <<.LENGTH ~PN~>+4>/5-1,[% (F.+.RPCNT+1)] PNL==. LOC F. ASCII ~PN~ F.==. LOC PNL TERMIN ;;; MAKES A "SYSTEM" ATOM. USUSALLY HAS NO PROPERTIES. ;;; MSA , DEFINE MSA LN,PN RMTAH1 [ ]LN,,[PN],SUNBOUND,100 TERMIN ;;; Makes a "Simple" atom. No properties or labels. ;;; MSAT DEFINE MSAT PN RMTAH1 ,,,[PN],SUNBOUND,100 TERMIN ;;; MAKE A "RANDOM ATOM" (OR ATOMS) DEFINE MRA PNS IRP PN,,[PNS] MSA PN,PN TERMIN TERMIN ;;; C = MEANS THAT WE SHOULD HAVE A LABEL FOR THE HEADER ;;; D IS THE LABEL, MORE OR LESS, IF C IS A ;;; PL IS FLAG FOR PROPERTY LIST. IF NULL, THEN NIL [= 0] GETS ;;; ASSEMBLED. FOR MKAT CASE, IT MUST BE "PNL-2", SINCE THE PROPERTY ;;; LIST WILL ALWAYS HAVE 2 CELLS JUST PRECEEDING THE PNAME-LIST ;;; PN IS THE PNAME STRING, ;;; AR THE ARGS PROPERTY, ;;; V THE LABEL OF THE VALUE CELL ;;; UC IS FOR THE "COMPILED-CODE-NEEDS-ME" BITS - 100 SAYS USED AS FUNCTION ;;; 40 SAYS USED IN STRUCTURES DEFINE RMTAH1 C,D,PL,PN,AR,V,UC PNL==. LOC S. PUTOB . IFSE [C] , Q!D: B.,,PL S.==. LOC B. UC\777200,,V NN!AR,,PNL B.==. LOC PNL APN [PN] TERMIN ;;; REMOTE VALUE CELL MAKER DEFINE RMTVC A,C ZZ==. LOC C. A: IFSN [C], C .ELSE, NIL C.==. LOC ZZ TERMIN ;;; ARGS TO IRP IN GROUPS OF 4 FOR EASY COUNTING IRP Q,,[0,,1,2 3,4,5,01 12,23,16,36 08,1777,2777,02 13,34,35,45 03,27,37,04 3777,17]R,,[1,0,2,3 4,5,6,1002 2003,3004,2007,4007 1011,2777,3777,1003 2004,4005,4006,5006 1004,3010,4010,1005 4777,2010] NN!Q==R TERMIN ;FOR BIBOP ARGS PROPERTIES SUBTTL STARTS FOR SAR, VC, IS2, AND SYM [SYMBOL-HEADER] SPACES ;;; STATE OF THE WORLD HERE HAD BETTER BE ;;; 1) LOSEG IF IN D10 ;;; 2) BEGINNING ON A SEGMENT BOUNDARY .XCREF RMTAH1 MKAT MKAT1 MKAT2 MKAV MKFV RMTVC MSA .XCREF MKAL MKALV .YSTGWD ;STORAGE WORDS ARE OKAY NOW PGBOT ATM BLSTIM==.MRUNT ;;; FORMAT OF SYMBOL HEADER FOR BIBOP: ;;; THE MAIN HEADER OF A SYMBOL IS A SINGLE WORD IN SYMBOL SPACE. ;;; THE RIGHT HALF CONTAINS THE PROPERTY LIST, AND THE LEFT HALF ;;; POINTS TO THE REST OF THE HEADER, WHICH IS IN THE IS2 OR SY2 AREA. ;;; SINCE THE REST OF THE HEADER (ALSO CALLED A "SYMBOL BLOCK") MUST ;;; LIE ON AN EVEN WORD BOUNDARY, THE LOW BIT OF THE LEFT HALF OF ;;; THE MAIN HEADER IS NORMALLY ZERO. THIS BIT IS USED BY THE ;;; GARBAGE COLLECTOR FOR MARKING PURPOSES, AND THEN RESET TO ZERO. ;;; THE SYMBOL BLOCK IS 2 WORDS LONG: ;;; ,, ;;; ,, ;;; THE "VARIOUS BITS" ARE: ;;; 4.9-3.9 ONES (FOR NO PARTICULARLY GOOD REASON) ;;; 3.9 ZERO (RESERVED FOR SPECIAL VALUE CELL/LAP HACK) ;;; 3.8 1 => SYMBOL BLOCK MAY BE PURE (SEE GCMARK) ;;; 3.7 ONE IFF COMPILED CODE NEEDS THE SYMBOL ;;; 3.6 ONE IFF COMPILED CODE REFERENCES BY OTHER THAN CALL UUO ;;; (IMPLIES 3.7 WHICH *MUST* ALSO BE ON) ;;; 3.5-3.1 ZERO (SO CAN INDIRECT THROUGH THE WORD TO GET VALUE) ;;; THE ARGS PROPERTY IS IN THE SAME FORMAT FASLOAD USES, ;;; TWO NINE-BIT BYTES DECODED AS FOLLOWS: ;;; 0 => NIL ;;; 777 => 777 (EFFECTIVELY INFINITY) ;;; N => N-1, N NOT 0 OR 777 ;;; THUS 000006 = (NIL . 5), 004005 = (3 . 4), AND 002777 = (1 . 777) SPCBOT SAR DEDSAR: 0,,ADEAD ;DEAD SAR (PROTECTED BY GC) TTDEAD DBM: 0,,ADEAD ;DEAD BLOCK MARKER TTDEAD BSYSAR==. ;BEGINNING OF "SYSTEM" ARRAY PROPS (SEE SYSP) OBARRAY: AS,,IOBAR1 ;OBARRAY TTS<1D+CN>,,IOBAR2(TT) READTABLE: AS,,RSXTB1 ;READTABLE TTS<1D+CN>,,RCT(TT) PRDTBL: AS,,RSXTB2 ;PURE READTABLE TTS<1D+CN>,,RCT0(TT) TTYIFA: AS,,TTYIF1 ;TTY INPUT FILE ARRAY TTS<1D+CL+CN+TY>,,TTYIF2(TT) TTYOFA: AS,,TTYOF1 ;TTY OUTPUT FILE ARRAY TTS<1D+CL+CN+TY+IO>,,TTYOF2(TT) INIIFA: AS,,INIIF1 ;INIT FILE ARRAY TTS<1D+CL>,,INIIF2(TT) ESYSAR==. SPCTOP SAR,ILS,[SAR] ;;; BEGINS ON A SEGMENT BOUNDARY, BECAUSE OF THE "SPCTOP SAR" SPCBOT VC C.==. ;LOCATION COUNTER FOR VALUE CELL SPACE ;;; NOTE THAT VALUE CELLS FOR T, NIL, UNBOUND, AND UBAR ;;; ARE IN PURE FREE STORAGE BLOCK 400 SEGUP . BXVCSG==. IFN NXVCSG,[ PAGEUP BXVCSG==. LOC .+NXVCSG*SEGSIZ-1 PAGEUP ] EVCSG==. SPCBOT IS2 SY2ALC: LOC .+2*LSYALC SPCTOP IS2,ILS,[IMPURE SYMBOL BLOCK] SPCBOT SYM TRUTH: $$$TRUTH,,NIL ;ATOM HEADER FOR T PUTOB TRUTH REL$ ADDOB -.RL1+NIL,\KNOB REL% ADDOB NIL,\KNOB ;;; CROCK TO PUTOB NIL CORRECTLY QUNBOUND: $$$UNBOUND,,NIL ;INTERNAL UNBOUND MARKER SYALC: BLOCK LSYALC ;FOR ALLOC S.==. ;LOCATION COUNTER FOR SYMBOL SPACE SEGUP BSYMSG+GSNSYSG*SEGSIZ-1 ;END OF SYMBOL GUESS ESYMGS==. PAGEUP SUBTTL STARTS FOR SY2, PFX, AND PFS [PURE LIST] SPACES 10$ $HISEG SPCBOT SY2 $$$TRUTH: 777300,,VTRUTH 0,,$$TRUTH $$$UNBOUND: 777300,,SUNBOUND 0,,$$UNBOUND B.==. ;LOCATION COUNTER FOR SYMBOL BLOCK SPACE SEGUP BSY2SG+GSNSY2*SEGSIZ-1 SPCBOT PFX INR70: R70 IFN D10*<1-SAIL>,[ IPPN1: . ;INITIAL PPN FOR LISP'S "SYS" DEVICE IPPN2: . ] ;END OF IFN D10*<1-SAIL> F.==. ;LOCATION COUNTER FOR PURE FIXNUMS - USED FOR PNAMES AND INUMS SEGUP BPFXSG+GSNPFXSG*SEGSIZ-1 EPFXGS==. SPCBOT PFS BPURFS==. ;BEGINNING OF PURE FS (FOR INSERT FILE PAGE) ;;; FREE STORAGE STUFF THAT IS NEVER GC'ED, NOR DARE MARKED FROM (NON-BIBOP) PWIOINT: NIL ;WITHOUT INTERRUPTS SPECIAL PURE LOCATION $$UNBOUND: APN UNBOUND $$NIL: ;PNAME FOR NIL APN NIL VNIL: NIL ;NIL'S VALUE CELL IS IN PFS - THAT WAY YOU CAN'T SETQ IT $$TRUTH: ;PNAME OF T APN T VT: VTRUTH: TRUTH ;LIKEWISE CAN'T SETQ T ;;; STANDARD UNBOUND VALUE CELL - POINTED TO BY ALL SYMBOLS WHICH ;;; DON'T HAVE THEIR OWN VALUE CELL. NOTE: ALL SUCH SYMBOLS ARE ;;; HELIOCENTRIC. MUST HAVE SUNBOUND ABOVE END OF VALUE CELL AREA ;;; - SEE GYSP5A AND SSYSTEM. SUNBOUND: QUNBOUND SUBTTL INITIAL PURE LIST STRUCTURE SSSBRL: QARRAY % ASBRL: QAUTOLOAD % SYSBRL: QARRAY,,SBRL SBRL: QSUBR % QFSUBR % QLSUBR,,NIL QGRTL: Q$GREAT,,NIL ;(>) FOR UGREAT IGSBV: OBARRAY,,READTABLE ;FOR "ERROR-BREAK-ENVIRONMENT" QLSTF.X: QSTF.X,,NIL IFN NEWRD,[ ;;;INITIAL ASSQ LIST OF MACRO-FUNCTIONS PRMCLS: .+1,,.+2 47,,QRDQTE .+1,,NIL 73,,QRDSEMI ] ;END OF IFN NEWRD BSYSAP==. ;BEGINNING OF SYSTEM AUTOLOAD PROPERTIES ;;; NOTE THAT DUE TO THE 6-CHAR LOSS, GRINDEF HAD TO BECOME GFN IN THE LABEL ;;; HERE ARE THE NAMELISTS WHICH WILL BECOME AUTOLOAD PROPERTIES ;;; [EREAD,HELP,ALLFI,DUMPA,LEDIT,LISPT,HUMBLE],,[ER,HE,FL,DY,LE,LT,HM] IRP A,,[GRIND,GFN,LAP,GETMIDASOP,SORT,LET,BACKQ,FORMAT,CGOL,DEFMACRO,$DFMX DEFVST,LODBY,MACAI,MLMAC,SETF,$EDIT,TRACE,SHARPM]B,,[GI,GE LA,GT,SO,LM,BQ,FT,CG,DE,DX,DV,LB,MA,MM,SF,ED,TR,SH] QFL.!B: IRACOM % Q!A,,IRATBL B!$AL: QAUTOLOAD % QFL.!B,,NIL TERMIN IFN SAIL,[ QFL.ER: IRACOM % QEREAD,,IRATBL ER$AL: QAUTOLOAD % QFL.ER,,NIL QFL.HE: IRACOM % QHELP,,IRATBL HE$AL: QAUTOLOAD % QFL.HE,,NIL ] IFN ITS,[ QFL.AL: IRACOM % QALLFILES,,IRATBL AL$AL: QAUTOLOAD % QFL.AL,,NIL ] ;END OF IFN ITS IFN USELESS,[ QFL.DY: IRACOM % QDUMPARRAYS,,IRATBL DY$AL: QAUTOLOAD % QFL.DY,,NIL ] ;END OF IFN USELESS IFN JOBQIO\D20,[ QFL.LE: IRACOM % QLEDIT,,IRATBL LE$AL: QAUTOLOAD % QFL.LE,,NIL ] IFN JOBQIO,[ QFL.HM: IRACOM % QHUMBLE,,IRATBL HM$AL: QAUTOLOAD % ;for HUMBLE QFL.HM,,NIL QFL.LT: IRACOM % ;for LISPT QLISPT,,IRATBL LT$AL: QAUTOLOAD % QFL.LT,,NIL ] ;END OF IFN JOBQIO ESYSAP==. ;END OF SYSTEM AUTOLOAD PROPERTIES QA%DDD: IRACOM,,NIL ;AUTOLOAD DEFAULT DEVICE/DIRECTORY LIST IRATBL: QFASL,,NIL IRACOM: QLISP,,NIL ;STANDARD DEVICE/DIRECTORY FOR AUTOLOAD FILES IFN BIGNUM,[ BNM23A: IN0 % IN1,,NIL BNM23B: IN0 % IN2,,NIL BN.1A: IN0+1,,NIL BNV2A: BNV1,,NIL ] ;END OF IFN BIGNUM QTLIST: TRUTH,,NIL IFN ITS,[ QLSPOUT: Q.LISP. % ;FOR ITS, (/.LISP/. OUTPUT) QOUTPUT,,NIL ] ;END OF IFN ITS IFN D20,[ QLSPOUT: QMACLISP % ;FOR D20, (MACLISP OUTPUT) QOUTPUT,,NIL ] ;END OF IFN D20 ;QLSPOUT CONSTRUCTED AT RUN TIME FOR D10 QUWL: QUWRITE,,NIL QURL: QUREAD,,NIL LGOR: QGO % QRETURN,,NIL QNILSETQ: QSETQ % ;FOR NIHIL ERROR MESSAGE .+1,,NIL NIL,,NIL QTSETQ: QSETQ % ;FOR VERITAS ERROR MESSAGE .+1,,NIL TRUTH,,NIL QXSETQ: QSETQ % ;FOR PURITAS ERROR MESSAGE QXSET1,,NIL ARQLS: QARRAY % ;(ARRAY ?) $QMLST: QM,,NIL ;LIST OF A QUESTION MARK: (?) QSJCL: QSTATUS % ;(STATUS JCL) QJCL,,NIL SPCNAMES: ;(STATUS SPCNAMES) QSYMBOL % QARRAY % PURSPCNAMES: ;(STATUS PURSPCNAMES) QLIST % IFN HNKLOG,[ RADIX 10. REPEAT HNKLOG+1, CONC QHUNK,\.RPCNT,,,.+1 RADIX 8 ] ;END OF IFN HNKLOG BG$ QBIGNUM % DX$ QDUPLEX % CX$ QCOMPLEX % DB$ QDOUBLE % QFLONUM % QFIXNUM ,,NIL PDLNAMES: IRPS XX,Y,[REG FL FX SPEC] Q!XX!PDL,,IFSE [Y][ ][.+1] TERMIN SUBTTL RANDOM SYSTEMIC ATOMS ;; +INTERNAL-/'-MACRO *MUST* be first in this table, for (STATUS SYSTEM ...) ;; QRDQTE is first symbol except for TRUTH and QUNBOUND --RWK RDQTEB=RDQTE ;THE OTHERS WIN BECAUSE THEY ARE 6 CHARS IRP X,,[RDQTEB,RDSEMI,RDVBAR,RDDBLQ]Y,,[['],[;],[|],["]] MKAT1 [+INTERNAL-Y-MACRO]SUBR,[ ]X,0 TERMIN MKAT1 +INTERNAL-TTYSCAN-SUBR,SUBR,[ ]TTYBUF,3 MKAT1 +INTERNAL-^Q-MACRO,SUBR,[ ]CTRLQ,0 MKAT1 +INTERNAL-^S-MACRO,SUBR,[ ]CTRLS,0 MKAT1 +INTERNAL-^B-BREAK,SUBR,[ ]CN.BB,2 MKAT1 +INTERNAL-IOL-BREAK,SUBR,[ ]IOLB,1 MKAT1 +INTERNAL-UREAD-EOFFN,SUBR,[ ]UREOF,2 MKAT1 +INTERNAL-INCLUDE-EOFFN,SUBR,[ ]INCEOF,2 MKAT1 +INTERNAL-TTY-ENDPAGEFN,SUBR,[ ]TTYMOR,1 MKAT1 +INTERNAL-*RSET-BREAK,SUBR,[ ]CB,1 IRP X,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC] MKAT1 +INTERNAL-X-BREAK,SUBR,[ ]X!B,1 TERMIN MKAT1 +INTERNAL-PDL-BREAK,SUBR,[ ]PDLB,1 MKAT1 +INTERNAL-GCO-BREAK,SUBR,[ ]GCOB,1 MKAT1 +INTERNAL-AUTOLOAD,SUBR,[ ]IALB ;;; NOTE WELL! the symbol headers for ;;; LIST, FIXNUM, FLONUM, DOUBLE, COMPLEX, DUPLEX, BIGNUM, ;;; SYMBOL, , RANDOM, ARRAY ;;; must be allocated sequentially, in that order. [Note also that this ;;; constraint overlaps the next constraint too.] This is so that ;;; certain routines, notably EVAL, may quickly dispatch thru a table ;;; of routines, indexed by the sequence number of TYPEP of a form. COMMENT # QLIST: QFIXNUM: QFLONUM: QDOUBLE: QCOMPLEX: QDUPLEX: QBIGNUM: QSYMBOL: QHUNK0: ... QHUNKn: QRANDOM: QARRAY: # MKAT LIST,LSUBR,[ ] MRA FIXNUM MRA FLONUM DB$ MRA DOUBLE CX$ MRA COMPLEX DX$ MRA DUPLEX BG$ MRA BIGNUM MRA SYMBOL IFN HNKLOG,[ IRP X,,[0,1,2,3,4,5,6,7,8,9]SZ,,[2,4,8,16,32,64,128,256,512,1024] MSA HUNK!X,HUNK!SZ IFE .IRPCNT-HNKLOG, .ISTOP TERMIN ] ;END OF IFN HNKLOG MKAT RANDOM,LSUBR,[ ]01 ;;; NOTE WELL! the symbol headers for ;;; ARRAY, SUBR, FSUBR, LSUBR, EXPR, FEXPR, MACRO, AUTOLOAD ;;; must be allocated sequentially, in that order. [Note also that this ;;; constraint overlaps the preceeding, as well as the next constraint too.] ;;; This is so that certain routines, notably EVAL and APPLY and UUO-handler, ;;; may quickly determine whether a given property is a functional property. MKAT ARRAY,FSUBR,[ ] MKAT SUBR,SUBR,[ ]1 IRP A,,[FSUBR,LSUBR,EXPR,FEXPR] MRA A TERMIN MKAL MACRO,DE,MACRO ;;; NOTE WELL! the symbol headers for ;;; AUTOLOAD, ERRSET, *RSET-TRAP, ;;; GC-DAEMON, GC-OVERFLOW, PDL-OVERFLOW ;;; must be allocated sequentially, in that order. [Note also that this ;;; constraint overlaps the preceeding constraint too.] This is so that ;;; the interrupt handler may have an easier time(?) MKAV AUTOLOAD,VAUTFN,QIALB,AUTOLOAD MKFV ERRSET,ERRSET,FSUBR MKAV *RSET-TRAP,V.TRAP,QCB,.R.TP MKAV GC-DAEMON,VGCDAEMON MKAV GC-OVERFLOW,VGCO,QGCOB,GCO MKAV PDL-OVERFLOW,VPDL,QPDLB,PDL MRA [VALUE,LAMBDA,DSK,SYM,SPLICING,SINGLE,EVALARG,BPS] MKAV [TTYSCAN-STRINGERS|]VTSCSR,ITSCSR,TSCSR ITSCSR: .+1,,.+2 IN0+73,,IN0+15 ;(#/; . #\CR) .+1,,.+2 IN0+174,,IN0+174 ;(#/| . #/|) .+1,,NIL IN0+42,,IN0+42 ;(#/" . #/") ;;; PROPERTY LIST FOR "LISP" WITH ITS INITIAL "PPN" PROPERTY FOR LISP SYSTEM ;;; FILE DIRECTORY SPECIFICAITON IT$ PLLISP==:NIL IFE ITS,[ PLLISP: QPPN % .+1,,NIL IFN D20,[ 10X QDSK % 20$ QPS % QMACLISP,,NIL ] ;END OF IFN D20 IFN D10,[ QDSK % .+1,,NIL SA% IPPN1 % SA% IPPN2,,NIL SA$ QMAC % SA$ QLSP,,NIL ] ;END OF IFN D10 ] ;END OF IFE ITS RMTAH1 [ ]LISP,PLLISP,LISP,,SUNBOUND,100 MRA [BIBOP,FASL,JCL,DDT] MSA %GLOBALSYM,GLOBALSYM MRA [LABEL,FUNARG] SA$ MRA [MAC] 10$ MRA [LSP] ;Don't change order from here to &RESTV, must be consecutive with &OPTIONAL ;first and &RESTV last for DEFUN to work. IRP PN,,[OPTIONAL,REST,AUX,WHOLE] MSA %!PN,&!PN TERMIN MSA %RSTL,&RESTL MSA %RSTV,&RESTV ;;; NOTE WELL! the symbol headers for ;;; REGPDL, FLPDL, FXPDL, SPECPDL ;;; must be allocated sequentially, in that order. This is so that ;;; status routines, and pdl-overflow routines may "index" off the kind ;;; of pdl being talked about. MRA [REGPDL,FLPDL,FXPDL,SPECPDL] ;;; NEED COPIES OF DOUBLE, COMPLEX, DUPLEX, BIGNUM EVEN IF TYPES NOT IMPLEMENTED .SEE LDATER DB% MRA DOUBLE CX% MRA COMPLEX DX% MRA DUPLEX BG% MRA BIGNUM HN% MRA HUNK PG$ MRA PAGING MRA PPN 20$ MRA PS IFN ITS,[ MRA [ITS,AI,ML,MC,DM] MRA EXPERIMENTAL MRA .LISP. ] ;END OF IFN ITS IFN D20,[ MRA DEC20 MSA TOPS20,TOPS-20 MRA TENEX ] ;END OF IFN D20 IFN D10,[ MRA DEC10 HS% MRA ONESEGMENT IFE SAIL,[ MRA CMU MSA TOPS10,TOPS-10 ] ;END OF IFE SAIL ] ;END OF IFN D10 IFN USELESS, MRA ROMAN MRA SAIL IFN JOBQIO, MRA JOB MRA [FILE,ECHO,CLA,IMAGE,BLOCK,NEWIO,OUTPUT,SCROLL] MRA MACLISP MSA RDEOF,READ-EOF MSA CN.B,[^B] MSA M,[?] MSA ..MIS,[**MISSING-ARG**] MSA LA,[_] MSA XPRHSH,EXPR-HASH MRA CALLI ;;; NOTE WELL! the symbol headers for ;;; ODDP, EVAL, DEPOSIT, EXAMINE ;;; must be allocated sequentially, in that order. This is so that ;;; the machine-error interrupt handler may "index" off the kind ;;; of interrupt being talked about. .SEE UINT32 MKAT ODDP,SUBR,[ ]1 MKFV EVAL,OEVAL,LSUBR,NIL,12 MKAT DEPOSIT,SUBR,[ ]2 MKAT EXAMINE,SUBR,[ ]1 SUBTTL ATOMS FOR SUBRS ;DUMMY ATOM SO THAT BAKTRACE PRINTS SOMETHING REASONABLE IN CERTAIN SCREW CASES MKAT1 QMARK,SUBR,,QMARK,0 MKAT GC,SUBR,,0 MKAT1 ^G,SUBR,,CTRLG,0 ;;; NOTE WELL! the symbol headers for ;;; ;;; must be allocated sequentially, in the order shown below; "CAR" must be ;;; the firs, and "CDDDDR" the last, with labels for at least each of these ;;; two. This is so that the +INTERNAL-CARCDRP function may determine ;;; whether something is a carcdr operation by address comparison. MKFV CAR,CAR,SUBR,,1 MKFV CDR,CDR,SUBR,,1 IRP A,,[CAAR,CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR,CDAADR,CDADAR CDADDR,CDDAAR,CDDADR,CDDDAR] MKAT A,SUBR,,1 TERMIN MKAT CDDDDR,SUBR,[ ]1 MKAT1 +INTERNAL-CARCDRP,SUBR,,ICADRP,1 IRPS A,C,[FIXP FLOATP RETURN EVALFRAME ERRFRAME,BIGP,BOUNDP,LISTIFY NOT ATOM TYPEP,EXPLODE MINUSP,PLUSP,NUMBERP ZEROP,INTERN,LAST REVERSE,NREVERSE,READLIST,MAKNAM,LENGTH,ABS,MINUS,ADD1,SUB1,FIX,FLOAT FLATSIZE FLATC ARG COS,SQRT,LOG,EXP,SXHASH NOINTERRUPT,REMOB,SYSP MAKUNBOUND,IMPLODE,MUNKAM,MAKNUM,PURCOPY PLIST SYMEVAL] MKAT A,SUBR,[C]1 TERMIN ;;; NOTE WELL! the symbol headers for ;;; RUNTIME, TIME ;;; must be allocated sequentially, in that order. This is so that ;;; the alarmclock function may "index" off the kind of alarm required. MKAT1 RUNTIME,SUBR,[ ]$RUNTIME,0 MKAT1 TIME,SUBR,[ ]$TIME,0 IRPS A,C,[IFIX,EXPLODEC NULL,ASCII ALLOC,NCONS,SLEEP,SIN] MKAT1 A,SUBR,[C]$!A,1 TERMIN IRPS A,C,[XCONS,GETCHARN,GET PNGET] MKAT1 A,SUBR,[C]$!A,2 TERMIN MKAT1 PURIFY,SUBR,,$PURIFY,3 IFN USELESS, MKAT HAULONG,SUBR,,1 MKAT1 SYMBOLP,SUBR,,%SYMBOLP,1 MKAT1 EXPLODEN,SUBR,[ ]$$EXPLODEN,1 MKAT1 ARRAYDIMS,SUBR,,ADIMS,1 MKAT1 [VALUE-CELL-LOCATION]SUBR,,VALLOC,1 IRPS A,C,[SUBLIS REMPROP SET,RPLACA,RPLACD,NTH,NTHCDR,DISPLACE, EQ,FRETURN,FRETRY,EXPT,MEMQ,SETARG MEMBER,EQUAL GETL,ASSOC,ASSQ, REMAINDER,ATAN,SAMEPNAMEP,ALPHALESSP GETCHAR,COPYSYMBOL,PNPUT, FILLARRAY NRECONC,SETPLIST] MKAT A,SUBR,[C]2 TERMIN MKAT1 *BREAK,SUBR,,$BREAK,2 MKAT1 *THROW,SUBR,,.THROW,2 IFN HNKLOG,[ MKAT CXR,SUBR,[ ]2 MKFV MAKHUNK,MAKHUNK,SUBR,TRUTH,1 MKFV HUNKP,HUNKP,SUBR,TRUTH,1 MKAT HUNKSIZE,SUBR,,1 MKAT HUNK,LSUBR,[ ] MKAT RPLACX,SUBR,,3 ] ;END OF IFN HNKLOG IFN USELESS,[ MKAT1 [\\]SUBR,,.GCD,2 IRPS A,C,[RECLAIM,HAIPART,GCD] MKAT A,SUBR,[C]2 TERMIN ] IRPS A,,[LSH,ROT,FSC] MKAT1 A,SUBR,,$!A,2 TERMIN MKAT1 ^,SUBR,,XPTII,2 MKAT1 ^$,SUBR,,XPTI$,2 MKAT1 FIXNUM-IDENTITY,SUBR,,FXIDEN,1 MKAT1 FLONUM-IDENTITY,SUBR,,FLIDEN,1 IRPS A,,[DIF,QUO] MKAT1 [*A]SUBR,,.!A,2 TERMIN IRP A,,[1+,1-]B,,[ADD1,SUB1] IRP C,,[$,]D,,[$,I] MKAT1 [A!!C]SUBR,,[D!!B]1 TERMIN TERMIN IRP A,,[>,<]B,,[GREAT,LESS] MKAT1 A,SUBR,[ ]$!B,2 TERMIN MKAT1 =,SUBR,,$EQUAL,2 MKAT1 [\]SUBR,,REMAINDER,2 IRPS A,C,[SASSOC,SASSQ,SUBST SETSYNTAX] MKAT A,SUBR,[C]3 TERMIN MKFV PUTPROP,PUTPROP,SUBR,SBRL,3 PG$ MKAT1 LH|,SUBR,,LHVBAR,2 SUBTTL ATOMS FOR FSUBRS AND LSUBRS IRPS A,C,[COND PROG QUOTE DO DECLARE PROGV, DEFPROP CATCH THROW BREAK GO , SETQ ERR SIGNP STORE STATUS SSTATUS FUNCTION CASEQ] MKAT A,FSUBR,[C] TERMIN MKAT1 SETF,FSUBR,[ ]SETF MKAT1 PUSH,FSUBR,[ ]$PUSH MKAT1 POP,FSUBR,[ ]$POP MKFV DEFUN,DEFUN,FSUBR,NIL MKAT1 COMMENT,FSUBR,[ ]$COMMENT MKAT1 UNWIND-PROTECT,FSUBR,[ ]UNWINP MKAT1 *CATCH,FSUBR,[ ].CATCH MKAT1 CATCHALL,FSUBR,,CATCHALL MKAT1 CATCH-BARRIER,FSUBR,,CATCHB MKAT1 AND,FSUBR,,$AND MKAT1 OR,FSUBR,,$OR MKAT1 EVAL-WHEN,FSUBR,[ ]EWHEN MKAT1 *FUNCTION,FSUBR,[ ]%%FUNCTION ;;; MUST HAVE (MAPLIST,MAPCAR,MAP,MAPC,MAPCON,MAPCAN) IN THAT ORDER MKAT MAPLIST,LSUBR,[ ]2777 MKAT MAPCAR,LSUBR,[ ]2777 MKAT1 MAP,LSUBR,[ ]$MAP,2777 MKAT MAPC,LSUBR,[ ]2777 MKAT MAPCON,LSUBR,[ ]2777 MKAT1 MAPCAN,LSUBR,[ ]$MAPCAN,2777 MKAT PROG1,LSUBR,[ ]1777 MKAT PROG2,LSUBR,[ ]2777 MKAT PROGN,LSUBR,[ ] MKAT BOOLE,LSUBR,,2777 IRPS A,C,[DELQ DELETE APPLY ] MKAT A,LSUBR,[C]23 TERMIN IT$ MKAT SYSCALL,LSUBR,[ ]2777 MKAT1 LIST*,LSUBR,[ ]LIST.,1777 MKAT1 CONS,SUBR,,$C2NS,2 MKAT FUNCALL,LSUBR,[ ]1777 MKAT1 ARRAYCALL,FSUBR,[ ]%ARRAYCALL MKAT SUBRCALL,FSUBR,[ ] MKAT1 LSUBRCALL,FSUBR,[ ]%LSUBRCALL IRPS A,C,[VALRET BAKTRACE BAKLIST GENSYM ] MKAT A,LSUBR,[C]01 TERMIN MKAT SUSPEND,LSUBR,[ ]02 IFN USELESS, MKAT CURSORPOS,LSUBR,[ ]03 MKAT QUIT,LSUBR,[ ]01 MKAT1 ERROR,LSUBR,[ ]$ERROR,03 MKAT GETSP,LSUBR,[ ]12 MKAT MAPATOMS,LSUBR,[ ]12 IRPS A,C,[NCONC PLUS,TIMES,DIFFERENCE,QUOTIENT,APPEND ] MKAT A,LSUBR,[C] TERMIN ;;; MUST HAVE (MAX,GREATERP,MIN,LESSP) IN THAT ORDER MKAT MAX,LSUBR,[ ]1777 MKAT GREATERP,LSUBR,[ ]2777 MKAT MIN,LSUBR,[ ]1777 MKAT LESSP,LSUBR,[ ]2777 ;;; IN THE FOLLOWING, NOTE THAT +, -, *, AND / GET VALUE CELLS IRP A,,[+,-,*,/]B,,[PLUS,DIFFERENCE,TIMES,QUOTIENT] MKFV [A]I!B,LSUBR,QI!B TERMIN IRP A,,[+,-,*,/]B,,[PLUS,DIFFERENCE,TIMES,QUOTIENT] MKAT1 [A!$]LSUBR,,[$!B] TERMIN MKAT1 *REARRAY,LSUBR,[ ].REARRAY,17 MKAT1 *ARRAY,LSUBR,[ ]%%ARRAY,27 MKAT LISTARRAY,LSUBR,[ ]12 SUBTTL ATOMS FOR LAP, FASLAP, AND FASLOAD USAGE ;;; SUBROUTINES USED BY COMPILER OUTPUT - ERGO, NEEDED BY LAP ;;; AND FASLOAD. ALSO OTHER GOODIES FOR LAP AND FASLAP. IRP A,,[DELQ,DELETE,APPEND,TIMES,GREAT,LESS,PLUS,NCONC,APPLY] MKAT1 *A,SUBR,[ ].!A,2 TERMIN IRP A,,[PRINT,PRIN1,PRINC,TERPRI,TYO]B,,[PRT,PR1,PRC,TRP,TYO]C,,[1,1,1,0,1] MKAT1 *!A,SUBR,[ ]B!$,C TERMIN IRP A,,[READ,READCH,TYI]B,,[READ,RDCH,TYI]C,,[0,0,0] MKAT1 *!A,SUBR,[ ]B!$,C TERMIN MKAT1 *EVAL,SUBR,,EVAL,1 MKAV PURE,VPURE,IN1*PAGING ;INIT TO NIL OR 1 (IF PAGING SYS) MKAV *PURE,V.PURE MKAV PURCLOBRL MKAT1 FASLAPSETUP|,SUBR,,FSLSTP,1 MKFV LAPSETUP|,LAPSETUP,SUBR,,2 MKAT PAGEBPORG,SUBR,[ ]0 MKFV TTSR|,TTSR,SUBR MKAT1 SQOZ|,SUBR,,5BTWD,1 MKAT GETDDTSYM,SUBR,[ ]1 MKAT PUTDDTSYM,SUBR,,2 MKFV GCPROTECT,GCPRO,SUBR,,2 MKAV SYMBOLS,V$SYMBOLS,,$SYMBOLS MKFV FASLOAD,FASLOAD,FSUBR,SBRL SUBTTL ATOMS FOR AUTOLOAD FEATURES MRA [SHARPM] MKAL DEFSHARP,SH MKAL [+INTERNAL-#-MACRO]SH,,0 MKAL SETSYNTAX-SHARP-MACRO,SH,,3 MKAV [#-SYMBOLIC-CHARACTERS-TABLE]V%SCT,QUNBOUND MKAV [#-MACRO-DATALIST]V%MDL,QUNBOUND MRA [BACKQ] MKAV BACKQUOTE-EXPAND-WHEN,V%BEW,QOEVAL MKAV [`-,-level|]V%BCLV,IN0 MKAL [`-expander|]BQ MKAL [`,|]BQ MKAL [`,@|]BQ MKAL [`,.|]BQ MKAL [+INTERNAL-`-macro|]BQ,I%B%F,0 MKAL [+INTERNAL-,-macro|]BQ,I%C%F,0 IRP A,,[LET,LET*,DESETQ]B,,[LET,LET.,DESETQ] MKAL A,LM,B MKAL [A!-EXPANDER-1]LM,,1 TERMIN MSA STF.X,[SETF-X] MKAL +INTERNAL-SETF-X-1,SF,,1 MKAL +INTERNAL-SETF-X,SF,ISTFX,2 MKAL +INTERNAL-PUSH-X,SF,IPUX,2 MKAL +INTERNAL-POP-X,SF,IPOX,2 MKAL SETF-STRUCT,SF,,4 MSA $DFMX,DEFMAX MKAV MACRO-EXPANSION-USE,V%MEU,Q%MXPD MKAV GRIND-MACROEXPANDED,V%GMX MKALV MACROEXPANDED,DX,%MXPD MKAL [MACROEXPANDED MACRO]DX,,1 MKAL [forget-macromemos|]DX,,1 MKAL MACROFETCH,DX,,1 MKALV MACROMEMO,DX,%MCMO,3 MKAL MACROEXPAND,DX,%MCXP,1 MKAL MACROEXPAND-1,DX,,1 MKAL [MACROEXPAND-1*]DX,%MCX.,1 MKAV DEFMACRO-CHECK-ARGS,V%DCA,TRUTH MKAV DEFMACRO-DISPLACE-CALL,V%DDC,TRUTH MKAV DEFMACRO-FOR-COMPILING,V%DFC,TRUTH MKALV [DEFUN&]DE,%DEFUN MKAL [DEFUN& MACRO]DE,,1 MKAV [DEFUN&-CHECK-ARGS]V%DACA,TRUTH MKALV [DEFUN&-ERROR]DE,DE$ER,0 MKALV [&r-l|]DE,%R.L,3 MKAL [Certify-no-var-dependency|]DE,,1 ;;; MKAL MACRO,DE,MACRO ;;; NOTE THAT THIS MUST BE "ABOVE" MKAL [MACRO MACRO]DE,,1 MKAL DEFMACRO,DE,DEFMA MKAL [DEFMACRO MACRO]DE,,1 MKAL DEFMACRO-DISPLACE,DE MKAL [DEFMACRO-DISPLACE MACRO]DE,,1 MKAL [defmacro-1|]DE,,1 MRA [MACAID] MKAL FLATTEN-SYMS,MA,,2 MKALV [carcdrp|]MA,%%CRP,1,TRUTH MKAL [no-funp|]MA,,1 MKAL +INTERNAL-DUP-P,MA,,1 MKAL [side-effectsp|]MA,,1 MKAL [constant-p|]MA,,1 MKAL DEFSIMPLEMAC,MA MKAL DEFCOMPLRMAC,MA MKAL DEFUNFROMMAC,MA MKAL DEFBOTHMACRO,MA MRA [MLMAC] MKAL HERALD,MM MKAL SELECTQ,MM MKAL FBOUNDP,MM MKAL DEFVAR,MM MKAL SETQ-IF-UNBOUND,MM MKAL WITH-INTERRUPTS,MM MKAL WITHOUT-INTERRUPTS,MM MKAL WITHOUT-TTY-INTERRUPTS,MM MRA [LODBYT] MKAL LDB,LB MKAL LOAD-BYTE,LB MKAL DPB,LB MKAL DEPOSIT-BYTE,LB MKAL *LDB,LB,,2 MKAL *DPB,LB,,3 MKAL *LOAD-BYTE,LB,,3 MKAL *DEPOSIT-BYTE,LB,,4 MKAL DEFVST,DV,DEFVST MKAL SETVST,DV MKAL STRUCT-TYPEP,DV MKAL [defvst-typchk|]DV,,3 MKAL [defvst-construction|]DV,,2 IRP A,,[GRIND,CGOLREAD,LAP,TRACE,FORMAT,CGOL]B,,[GI,CG,LA,TR,FT,CG] MKAL A,B,A TERMIN MKAL GRIND0,GI MKALV GRINDEF,GE,GFN MKAL SPRINTER,GE,,1 MKAL SPRIN1,GE,,12 MKAL READMACROINVERSE,GE,$RMI MKAL [MACROEXPANDED-grindmacro|]GE,,0 MKAL [+INTERNAL-`-grindmacros|]GE,,0 MKAL GETMIDASOP,GT,GETMIDASOP,1 MKAL SORT,SO,SORT,2 MKAL SORTCAR,SO,,2 MKALV EDIT,ED,$EDIT MKAL [LAP-A-LIST]LA SA$ MKAT2 EREAD,ER SA$ MKAT2 HELP,HE IFN USELESS,[ MKAL DUMPARRAYS,DY,DUMPARRAYS MKAL LOADARRAYS,DY ] ;END OF IFN USELESS IFN ITS,[ MKAL ALLFILES,AL,ALLFILES IRP A,,[MAPALLFILES,DIRECTORY,MAPDIRECTORY] MKAL A,AL TERMIN ] ;END OF IFN ITS IFN JOBQIO\D20 MKAL LEDIT,LE,LEDIT IFN JOBQIO,[ MKAL LISPT,LT,LISPT MKAL [INF-EDIT]LT ] ;END OF IFN JOBQIO IT$ MKAL HUMBLE,HM,HUMBLE IT$ MKAL [CREATE-JOB]HM SUBTTL ATOMS FOR ODDBALL FUNCTIONS AND VARIABLES IFN ITS, MKFV ALARMCLOCK,ALARMCLOCK,SUBR,,2 IFE ITS, VALARM==VNIL IFN USELESS,[ ;THESE MUST BE IN THIS ORDER, FOLLOWNG ALARMCLOCK MKAV CLI-MESSAGE,VCLI,,CLI MKAV MAR-BREAK,VMAR,,MAR MKAV TTY-RETURN,VTTR,,TTR MKAV SYS-DEATH,VSYSD,,SYSD ] ;END OF IFN USELESS MKFV NOUUO,NOUUO,SUBR,,1 MKFV NORET,NORET,SUBR,,1 MKFV EVALHOOK,EVALHOOK,LSUBR,,23 MKFV READ-EVAL-*-PRINT,TLPRINT,SUBR,,1 MKFV READ-EVAL-PRINT-*,TLTERPRI,SUBR,,0 MKFV *-READ-EVAL-PRINT,$TLREAD,SUBR,,0 MKFV READ-*-EVAL-PRINT,TLEVAL,SUBR,,1 MKFV GCTWA,GCTWA,FSUBR MKFV ARGS,ARGS,LSUBR,,12 MKFV *RSET,.RSET,SUBR,TRUTH,1 MKFV *NOPOINT,.NOPOINT,SUBR,,1 MKFV OBARRAY,OBARRAY,ARRAY,OBARRAY MKFV READTABLE,READTABLE,ARRAY,READTABLE MKAV ERROR-BREAK-ENVIRONMENT,VE.B.E,IGSBV MKAV RINTERN-PACKAGE-HOOK,V%RPH,NIL SUBTTL ATOMS FOR NEWIO FUNCTIONS AND VARIABLES IRPS A,C,[NAMELIST,NAMESTRING,SHORTNAMESTRING,TRUENAME INPUSH,PROBEF,LOAD FILEP] MKAT A,SUBR,[C]1 TERMIN MKFV DEFAULTF,DEFAULTF,SUBR,,1 MRA NODEFAULT MKAT1 FORCE-OUTPUT,SUBR,[ ]FORCE,1 MKAT1 CLEAR-OUTPUT,SUBR,[ ]CLROUT,1 MKAT1 CLEAR-INPUT,SUBR,[ ]CLRIN,1 IRPS A,C,[CLOSE DELETEF IN FASLP ] MKAT1 A,SUBR,[C]$!A,1 TERMIN MKAT1 +TYO,SUBR,,PTYO,2 MKAT1 OPEN,LSUBR,[ ]$OPEN,02 SA$ MKAT1 EOPEN,LSUBR,[ ]$EOPEN,04 MKAT1 OUT,SUBR,[ ]$OUT,2 MKAT1 INCLUDEF,SUBR,,.INCLU,02 MKAT1 RENAMEF,SUBR,[ ]$RENAMEF,2 MKAT CNAMEF,SUBR,[ ]2 MKAT MERGEF,SUBR,,2 MKAT1 LENGTHF,SUBR,[ ]$LENGTHF,1 MKAT1 LISTEN,LSUBR,[ ]$LISTEN,01 IFN SFA,[ MKAT1 SFA-CREATE,SUBR,,STCREA,3 MKAT1 SFA-CALL,SUBR,,STCALL,3 MKAT1 SFAP,SUBR,,STPRED,1 MKAT1 SFA-GET,SUBR,,STGET,2 MKAT1 SFA-STORE,SUBR,,STSTOR,3 MSA WOP,WHICH-OPERATIONS MRA FILEMODE MRA UNTYI MRA SFA MRA PNAME MRA NAME MRA PROBEF MRA TTYSCAN MRA TTYCONS ] ;END IFN SFA IRPS A,C,[CRUNIT,UKILL,UFILE UCLOSE,UAPPEND,UPROBE,INCLUDE] MKAT A,FSUBR,[C] TERMIN MKFV UREAD,UREAD,FSUBR MKFV UWRITE,UWRITE,FSUBR IRPS A,,[INFILE,INSTACK,OUTFILES,ECHOFILES]C,,[TRUTH,,,] MKAV A,,C TERMIN MKAV MSGFILES,,QTLIST,MSGFILES MKFV TYI,%TYI,LSUBR,TTYIFA,02 MKAT1 READLINE,LSUBR,[ ]%READLINE,02 MKAT TYIPEEK,LSUBR,[ ]03 MKFV TYO,%TYO,LSUBR,TTYOFA,12 MKAT1 PRINT,LSUBR,[ ]%PRINT,12 MKFV PRIN1,%PR1,LSUBR,,12 MKAT1 PRINC,LSUBR,[ ]%PRC,12 MKAT1 [PRINT-OBJECT]LSUBR,[ ]%PRO,45 MKAT1 [FLATSIZE-OBJECT]LSUBR,[ ]%FLO,45 MKFV TERPRI,%TERPRI,LSUBR,TRUTH,01 MKFV READ,OREAD,LSUBR,,02 MKAT1 READCH,LSUBR,[ ]$READCH,02 IRPS A,C,[ENDPAGEFN EOFFN PAGEL CHARPOS LINENUM PAGENUM LINEL RUBOUT FILEPOS ERRPRINT ] MKAT A,LSUBR,[C]12 TERMIN SUBTTL ATOMS FOR VARIABLES AND USER INTERRUPT BREAKS ;;; TTYOPN WILL INIT VLINEL TO THE RIGHT THINGS. ;;; FOR NON-BIBOP, NOTE THAT LINEL AND CHRCT POINT INTO THE ;;; (UNRELOCATED!) INUM AREA DURING ALLOC. THEY WILL THUS ;;; HAVE THE RIGHT VALUES BUT THE WRONG TYPE (I.E. TYPEP ;;; OF THEM WOULD LOSE.) THUS PRINT ETC. SHOULD NOT CHECK ;;; TYPEP OF THESE THINGS. ALLOC REHACKS THEIR VALUES AFTERWARDS. ;;; CHRCT IS INITIALLY 777 SO ALLOC WON'T GENERATE CR'S. COMMENT | VBPORG: VBPEND: VERRLIST: VTTY: VZUNDERFLOW: VZFUZZ: VCHRCT: VLINEL: | IRP A,,[BPEND,BPORG,ERRLIST,TTY,ZUNDERFLOW]C,,[VBPE1,VBP1,,,] MKAV A,,C,A TERMIN BG$ MKAV ZFUZZ,,,ZFUZZ COMMENT | VIBASE: VBASE: V%LEVEL: V%LENGTH: TAPRED: TTYOFF: TAPWRT: SIGNAL: | ;;; FOR NON-BIBOP, ALLOC REHACKS VBASE AND VIBASE AFTERWARDS. MKAV IBASE,,IN10,IBASE MKAV BASE,,IN10,BASE IFN USELESS,[ MKAV PRINLEVEL,V%LEVEL,,%LEVEL MKAV PRINLENGTH,V%LENGTH,,%LENGTH ] ;END OF IFN USELESS IRP A,,[^Q,^W,^R,^A]B,,[TAPRED,TTYOFF,TAPWRT,SIGNAL] MKAV A,B TERMIN RMTAH1 ,,,+INTERNAL-WITHOUT-INTERRUPTS,,PWIOINT,100 SA% MKAV [P]VDOLLRP,QDOLLRP,DOLLRP SA$ MKAV [}P]VDOLLRP,QDOLLRP,DOLLRP DOLLRP==QDOLLRP MKAV ^D,GCGAGV,,CN.D ;;; (UNDF-FNCTN, UNBND-VRBL, WRNG-TYPE-ARG, ;;; UNSEEN-GO-TAG, WRNG-NO-ARGS, GC-LOSSAGE, FAIL-ACT, ;;; IO-LOSSAGE) MUST BE IN THAT ORDER IRP A,,[UDF,UBV,WTA,UGT,WNA,GCL,FAC]PN,,[UNDF-FNCTN,UNBND-VRBL WRNG-TYPE-ARG,UNSEEN-GO-TAG,WRNG-NO-ARGS,GC-LOSSAGE,FAIL-ACT] MKAV PN,V!A,Q!A!B,A TERMIN MKAV IO-LOSSAGE,VIOL,QIOLB,IOL MKAV COMPILER-STATE,VCOMST MKAV MACHINE-ERROR,VMERR,,MERR PGTOP ATM,[SYSTEM ATOMS AND STUFF] ;;; ************* END OF PURE LISP (NON-BIBOP) ************* PFSLAST==. ;GUARANTEED SAFE OVER SPCTOP 10$ $LOSEG LOC C. ESYSVC==. EXPUNGE C. SUBTTL RANDOM BINDABLE CELLS ;;; HERE ARE THINGS WHICH ARE LIKE VALUE CELLS, IN THAT SPECPDL ;;; UNBINDING MUST WORK ON THEM; BUT THEY ARE NOT NECESSARILY ;;; MARKED FROM. LISAR: NIL ;LAST INTERPRETIVELY-SEEN ARRAY - ASAR TYIMAN: $DEVICE ;WHERE TO GET CHARACTERS FROM UNTYIMAN: UNTYI ;WHERE TO PUT BACK CHARACTERS TO UNREADMAN: .+1 .VALUE READPMAN: .+1 .VALUE FASLP: NIL ;FASLOADING-P? TIRPATE: 0 ;PSEUDO VALUE CELL, USED TO EXTIRPATE THE CONSEQUENT UNBINDING ;FOLLOWING A SETQ DONE ON NIL OR T ;;; #### MOOOBY IMPORTANT! MUST HAVE
=
+ 1 ARGLOC: 0 ;FOR LEXPRS - LOCATION OF ARG VECTOR ON PDL ARGNUM: 0 ;HOLDS FIXNUM WHICH IS # OF ARGS FOR LEXPR IN ARGLOC SUBTTL BIBOP STORAGE PARAMETER CALCULATIONS BFVCS: INFVCS==BXVCSG-BFVCS IFL INFVCS, WARN \-INFVCS,[=TOO MANY VALUE CELLS] SPCTOP VC,ILS,[VALUE CELL] LOC S. EXPUNGE S. B. IFL ESYMGS-1-., WARN \.-ESYMGS,[=TOO MANY SYMBOLS (SYMEST=]\SYMEST,[)] SYMSYL==:. ;ADR OF LAST SYSTEM SYM SPCTOP SYM,ILS,[SYMBOL HEADER] IFE PAGING,[ NXXASG==0 NXXZSG==0 $HISEG ] ;END OF IFE PAGING IFN PAGING,[ BXXASG==. NXXASG==<<&PAGMSK>-BXXASG>/SEGSIZ BXXZSG==BXXASG+NXXASG*SEGSIZ ;TAKE UP SLACK PAGES BEFORE SY2 NXXZSG==/SEGSIZ ] ;END OF IFN PAGING NSY2SG==/SEGSIZ SEGUP BSY2SG+NSY2SG*SEGSIZ-1 SPCTOP SY2,ILS,[PURE SYMBOL BLOCK] LOC F. EXPUNGE F. IFL EPFXGS-1-HINUM-LONUM-., WARN \.+HINUM+LONUM-EPFXGS,[=TOO MANY PURE FIXNUMS (PFXEST=]\PFXEST,[)] ZZ==EPFXGS-. ZZZ==/2 ; THEN TO THE NEXT PAGE BOUNDARY XHINUM==HINUM+ZZZ ;DISTRIBUTE ANY SUCH EXTRA SPACE EVENLY IFL XHINUM-777,XHINUM==777 ;MANY LOSERS DEPEND ON HINUM BEING AT LEAST THIS BIG XLONUM==ZZ-XHINUM ; BETWEEN POSITIVE AND NEGATIVE INUMS IFL XLONUM-10,[ WARN [XLONUM=]\XLONUM,[, YOU WILL CERTAINLY LOSE] .ERR INUM LOSSAGE ] REPEAT XLONUM, .RPCNT-XLONUM IN0: ;HAIRY PAGE (APPROXIMATELY) OF SMALL FIXNUMS REPEAT XHINUM, .RPCNT IRP X,,[1,2,3,4,5,6,7,10,777] IN!X=IN0+X TERMIN INFORM [HIGHEST NLISP INUM=]\XHINUM INFORM [LOWEST NLISP INUM=-]\XLONUM SPCTOP PFX,ILS,[PURE FIXNUM] LOC PFSLAST SPCTOP PFS,ILS,[PURE LIST] SPCBOT PFL ;;; INITIAL ASSEMBLED PURE FLONUMS GO HERE (HA HA!) SPCTOP PFL,ILS,[PURE FLONUM] 10$ $LOSEG SUBTTL INITIAL RANDOM IMPURE FREE STORAGE IFN PAGING,[ BXXPSG==. ;POSSIBLE SLACK PURE SEGMENT PAGEUP NXXPSG==<.-BXXPSG>/SEGSIZ SPCBOT IFS NPURFS==<.-BPURFS>/PAGSIZ ] ;END OF IFN PAGING .ELSE, SPCBOT IFS FIRSTW: QXSET1: .,,NIL ;FOR XSETQ NUNMRK==.-FIRSTW .SEE GCP6 IFG NUNMRK-40, WARN \NUNMRK,[=TOO MANY UNMARKABLE FS LOCATIONS] IT$ FEATEX: QEXPERIMENTAL % FEATLS: ;INITIAL LIST FOR (STATUS FEATURES) QBIBOP % IFN BIGNUM, QBIGNUM % QFASLOAD % IFN HNKLOG, QHUNK % QFUNARG % IFN USELESS, QROMAN % QNEWIO % IFN SFA, QSFA % 10$ HS% QONESEGMENT % PG$ QPAGING % QMACLISP % ;OPERATING SYSTEM TYPE (FORMERLY, "MACHINE" NAME) OPSYFT: IT$ QITS % 10$ SA$ QSAIL % 10$ SA% QTOPS10 % 20$ QTOPS20 % ;Startup puts ; "TOPS-20" or "TENEX" for DEC20 style systems ; "TOPS-10" or "CMU" for non-SAIL DEC10 style systems ;"SITE", BUT MAY BE SPLICED OUT BY STARTUP CODE. SITEFT: SA$ QSAIL % SA% NIL % ;Startup puts "AI", "ML", or "MC" here on ITS systems, ; "TOPS-20" or "TENEX" for DEC20 style systems ; "TOPS-10" or "CMU" for non-SAIL DEC10 style systems ;FILE SYSTEM TYPE COMES LAST FILEFT: IT$ QITS,,NIL 10$ QDEC10,,NIL 20$ QDEC20,,NIL ;;; FROM BPROTECT, FOR DISTANCE LPROTECT, IS PROTECTED BY THE GARBAGE COLLECTOR. .SEE GCP6Q2 BPROTECT: BG$ BNV1,,ARGNUM ;TO PROTECT CONTENTS OF THESE CELLS BG% NIL,,ARGNUM TLF: NIL ;TOP LEVEL FORM - NIL FOR STANDARD BLF: NIL ;ANALOGOUSLY, THE BREAK LEVEL FORM QF1SB: NIL ;SAVE B DURING QF1 PA3: 0 ;RH = PROG BODY (I.E. CDDR OF PROG FORM) ;LH = NEXT PROG STATEMENT GCPSAR: 0 ;POINTS TO SAR FOR HASH ARRAY FOR GC-PROTECTION LISTS RDLARG: NIL ;LIST OF CHARS FOR READLIST, MAKNAM, IMPLODE SUDIR: NIL ;INITIAL SNAME (ITS) OR PPN (DEC-10) FEATURES: FEATLS LDFNAM: NIL ;FASLOAD FILE NAME LDEVPRO: NIL ;LIST OF EVALED-FROBS-IN-ATOMTABLE TO BE PROTECTED NILPROPS: NIL ;PROPERTY LIST FOR NIL DEOFFN: NIL ;DEFAULT EOF FUNCTION DENDPAGEFN: NIL ;DEFAULT END OF PAGE FUNCTION UUSRHNK: NIL ;USER-HUNK checking routine USENDI: NIL ;User SEND interpreter UCALLI: NIL ;User CALL interpreter LPROTECT==:.-BPROTECT Q.=:QITIMES ;ALIASES FOR THE SYMBOL * V.=:VITIMES .HKILL QITIMES VITIMES IGCMKL: DEDSAR % ;DEAD AREA AT TOP OF BPS IGCFX1 % INIIFA % ;INIT FILE ARRAY IGCFX2,,NIL OBTFS: BLOCK KNOB+10 ;FREE STORAGE FOR OBARRAY CONSAGE LFSALC==100 FSALC: BLOCK LFSALC ;FOR ALLOC SPCTOP IFS,ILS,[IMPURE LIST] SPCBOT IFX BG$ BNV1: . ;TEMPORARILY RPLACED BY BNCVTM VBP1: BBPSSG ;INITIAL ALLOCATED VALUE FOR BPORG VBPE1: INIIF1-2 ;INITIAL ALLOCATED VALUE FOR BPEND IGCFX1: PG$ <&PAGMSK>-EINIFA ;SIZE OF DEAD BLOCK PG% 0 ;WILL BE CALCULATED BY ALLOC IGCFX2: LINIFA ;SIZE OF INIT FILE ARRAY LFWSALC==40 FWSALC: BLOCK LFWSALC ;FOR ALLOC NIFWAL==0 SPCTOP IFX,ILS,[IMPURE FIXNUM] SPCBOT IFL 1.0 ;NEED AT LEAST ONE IMPURE FLONUM SEGMENT SPCTOP IFL,ILS,[IMPURE FLONUM] IFN BIGNUM,[ SPCBOT BN BBIGPRO: .SEE GCP6Q3 ;PROTECTED BIGNUMS BN235: 0,,BNM23A BNM235: -1,,BNM23A BNM236: -1,,BNM23B BNV2: 0,,BNV2A BN.1: 0,,BN.1A LBIGPRO==.-BBIGPRO SPCTOP BN,ILS,[BIGNUM] ] ;END OF IFN BIGNUM IFE BIGNUM,[ BBNSG==. NBNSG==0 ] ;END OF IFE BIGNUM IFN PAGING,[ BXXBSG==. ;TAKE UP SLACK UNTIL FIRST PAGE OF BPS PAGEUP NXXBSG==<.-BXXBSG>/SEGSIZ ] ;END OF IFN PAGING IF2 GEXPUN BLSTIM==.MRUNT-BLSTIM INFORM [TIME TO MAKE INITIAL STRUCT, PASS ]\.PASS,[ = ]\BLSTIM/1000.,[ SECS] ;;@ END OF STRUCT 522 ;;; 10$ NOW IN ** LOW SEGMENT ** NBITB==NIFSSG+NIFXSG+NIFLSG+NBNSG ZZ==<*BTBSIZ+SEGSIZ-1>/SEGSIZ IFN ZZ-BTSGGS,[ WARN [NEEDED NUMBER OF INITIAL BIT TABLE SEGMENTS (]\ZZ,[) DOESN'T MATCH GUESS. (BTSGGS=]\BTSGGS,[) ] ] ;END OF IFN ZZ-BTSGGS .ALSO .ERR IFN LOBITSG, BFBTBS=BTBLKS+NBITB*BTBSIZ .ELSE,[ ;;; NOTE WELL! FIRST FS SEGMENT GETS FIRST ;;; BIT BLOCK! (SEE NUNMRK, GCP6) SPCBOT BIT BTBLKS: -1 ;THIS WILL BE RESET BY GCINBT BLOCK NBITB*BTBSIZ-1 BFBTBS: ;BEGINNING OF FREE BIT BLOCKS PAGEUP SPCTOP BIT,ST,[BIT BLOCK] ] ;END OF .ELSE NBPSSG==1*SGS%PG ;INIT WILL MUNG ST AND PURTBL ANYWAY TO PRESERVE ALLOC NFXPSG==1*SGS%PG ;PDL AREAS FOR INIT AND ALLOC NFLPSG==1*SGS%PG NPSG==1*SGS%PG NSPSG==1*SGS%PG ;ALLOC ALTERS ALL PDL PARAMETERS!!! IFN PAGING,[ NXFXPSG==1*SGS%PG NXFLPSG==1*SGS%PG NXPSG==2*SGS%PG NXSPSG==2*SGS%PG IFE SFA,[ IFN ML, NSCRSG==2*SGS%PG .ELSE NSCRSG==3*SGS%PG ;ALLOW FOR PDP6 PAGE (P6) ] ;END IFE SFA IFN SFA,[ IFN ML, NSCRSG==1*SGS%PG .ELSE NSCRSG==2*SGS%PG ;ALLOW FOR PDP6 PAGE (P6) ] ;END IFN SFA ;;; NUMBER OF NON-EXISTENT MEMORY SEGMENTS ;;; (TAKE ALL OF CORE AND SUBTRACT OUT EVERYTHING USEFUL!!!) NNXMSG==NSEGS IRP SPC,,[ZER,ST,SYS,SAR,VC,XVC,IS2,SYM,XXA,XXZ,SY2,PFX,PFS,PFL,XXP IFS,IFX,IFL,BN,XXB,BIT,BPS,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR] NNXMSG==NNXMSG-N!SPC!SG TERMIN ;;; DETERMINE ORIGINS FOR ALL SPACES ABOVE THIS POINT ZZX==. IRP SPC,,[BPS,NXM,FXP,XFXP,FLP,XFLP,P,XP,SP,XSP,SCR] B!SPC!SG==ZZX ZZX==ZZX+N!SPC!SG*SEGSIZ TERMIN SPDLORG==MEMORY-*SEGSIZ PDLORG==SPDLORG-*SEGSIZ FLPORG==PDLORG-*SEGSIZ FXPORG==FLPORG-*SEGSIZ ] ;END OF IFN PAGING IFE PAGING,[ ZZX==. IRP SPC,,[FXP,FLP,P,SP,BPS] B!SPC!SG==ZZX ZZX==ZZX+N!SPC!SG*SEGSIZ TERMIN SPDLORG==BSPSG PDLORG==BPSG FLPORG==BFLPSG FXPORG==BFXPSG ] ;END OF IFE PAGING SUBTTL APOCALYPSE (END OF THE WORLD) ;FOR REL ASSEMBLIES, INIT AND ALLOC CODE OVERLAP INITIAL BPS 10$ LOC BBPSSG ;;@ ALLOC 250 INITIALIZATION AND ALLOCATION ROUTINES ;;; ***** MACLISP ****** INITIALIZATION AND ALLOCATION ROUTINES ** ;;; ************************************************************** ;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** ;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* ;;; ************************************************************** CONSTANTS ;LITERALS USED PREVIOUSLY MUST BE OUT OF BPS SUBTTL INITIALIZATION CODE ;;; THIS CODE IS IN BINARY PROGRAM SPACE .CRFOFF OBTL: REPEAT KNOB, CONC OB,\.RPCNT .CRFON INITIALIZE: IFN D10*HISEGMENT,[ SETZ FREEAC, SETUWP FREEAC, ;FREEAC HAS OLD STATE OF HISEG-PURE BIT .VALUE ] ;END OF IFN D10 IFN D10*PAGING,[ MOVEI FREEAC,MEMORY-1 HRRM FREEAC,.JBFF CORE FREEAC, .VALUE IFN SAIL,[ HRRZ FREEAC,.JBSA ;SET DDT STARTING ADDRESS SO SAVE COMMAND WINS SKIPN .JBDDT SETDDT FREEAC, ] ;END IFN SAIL ] ;END IFN D10*PAGING IFN ITS,[ MOVE TT,[4400,,400000+<_11>] .CBLK TT, .VALUE MOVE TT,[4400,,400000+<_11>] .CBLK TT, .VALUE MOVE TT,[4400,,400000+<_11>] .CBLK TT, .VALUE ] ;END OF IFN ITS MOVE P,[-LFAKP-1,,FAKP-1] MOVE FXP,[-LFAKFXP-1,,FAKFXP-1] ;;; FALLS THROUGH SUBTTL DUMP OUT TOPS20 SYMBOL TABLE IFN D20,[ MOVE C,[LVRNO] SETZ A, INIT2A: SETZ B, LSHC B,6 JUMPE B,INIT2B IMULI A,10. ADDI A,-'0(B) JRST INIT2A INIT2B: LSH A,30 MOVEM A,ENTVEC+2 ;VERSION NUMBER STORED IN LOC 137 AS 0XXX00,, SKIPN <.JBSYM==:116> ;CHECK FOR SYMBOL TABLE JRST INIT2X ; LDB D,[3014_30 ENTVEC+2] MOVEI 1,(D) HRLI 1,(GJ%SHT+GJ%OLD) MOVE B,INIT2P GTJFN JRST INIT2F HRLI 1,(DF%EXP) DELF JRST INIT2E INIT2F: MOVEI 1,(D) HRLI 1,(GJ%SHT+GJ%NEW) MOVE B,INIT2P GTJFN JRST INIT2E MOVE TT,1 ;REMEMBER THE FILE HANDLE FOR LATER USE MOVE 2,[<44_36>+OF%WR] ;36 BIT BYTES, WRITE ACCESS OPENF JRST INIT2E HRRZ 1,TT ;RESTORE JFN MOVE 2,.JBSYM ;OUTPUT THE SYMBOL TABLE POINTER BOUT ;OUTPUT THE AOBJN POINTER FIRST HRRZ 1,TT ;RESTORE JFN HRRZ 2,.JBSYM ;SYMBOL TABLE ADDRESS MINUS ONE HRLI 2,444400 ;36 BIT BYTES HLRE 3,.JBSYM ;GET NEGATIVE LENGTH OF SYMBOL TABLE SOUT ;OUTPUT THE SYMBOL TABLE TO THE FILE CLOSF JRST INIT2E HRROI 1,[ASCIZ \;Symbol table dumped out in PS:LISP.SYMBOLS.\] PSOUT SETZ T, JUMPE D,.+5 IDIVI D,10. ADDI D+1,"0 PUSH FXP,D+1 AOJA T,.-4 POP FXP,1 PBOUT SOJN T,.-2 HRROI 1,[ASCIZ \ \] PSOUT JRST INIT2X INIT2P: 440700,,[ASCIZ \PS:LISP.SYMBOLS\] INIT2E: HRROI 1,[ASCIZ \I/O Loses badly while trying to dump symbol table \] PSOUT HALTF ] ;END OF IFN D20 INIT2X: ;;; FALLS IN INIBS: MOVEI F,0 ;BUBBLE-SORT THE LAPFIV TABLE, WHILE MOVEI C,LLSYMS-1 ;SORTING THE BSP TABLE AS SUBSIDIARY RECORDS INIBS1: MOVE D,LAPFIV(C) CAML D,LAPFIV-1(C) JRST INIBS2 MOVEI F,1 ;FLAG TO NOTE THAT A BUBBLING OCCURED THIS PASS EXCH D,LAPFIV-1(C) MOVEM D,LAPFIV(C) ;INTERCHANGE KEYS MOVE D,INIBSP(C) EXCH D,INIBSP-1(C) ;INTERCHANGE RECORDS MOVEM D,INIBSP(C) INIBS2: SOJG C,INIBS1 JUMPN F,INIBS MOVNI C,LLSYMS-1 MOVE AR2A,[441100,,LAP5P] MOVE TT,INIBSP+LLSYMS-1(C) IDPB TT,AR2A AOJLE C,.-2 ;;; INITIALIZE THE SEGMENT-LINK COUNTERS FOR ITS & D20 IFN PAGING,[ IRP A,,[FS,FX,FL,SY,SA,S2]B,,[IFS,IFX,IFL,SYM,SAR,IS2] MOVEI T,L!B!SG MOVEM T,A!SGLK TERMIN BG$ MOVEI T,LBNSG BG$ MOVEM T,BNSGLK IRPC Q,,[AB] IFN NXX!Q!SG,[ MOVE T,IMSGLK MOVE TT,[-NXX!Q!SG,,BXX!Q!SG_-SEGLOG] DPB T,[SEGBYT,,GCST(TT)] MOVEI T,(TT) AOBJN TT,.-2 MOVEM T,IMSGLK ] ;END OF IFN NXX!Q!SG TERMIN MOVEI T,<<&PAGMSK>-BBPSSG>_-PAGLOG MOVEI D,BBPSSG_-PAGLOG ROT D,-4 ADDI D,(D) ROT D,-1 TLC D,770000 ADD D,[450200,,PURTBL] MOVEI TT,3 INIT5: TLNN D,730000 TLZ D,770000 IDPB TT,D SOJG T,INIT5 MOVE T,[-<<<&PAGMSK>-BBPSSG>_-SEGLOG>,,ST+] MOVE TT,[$XM,,QRANDOM] MOVEM TT,(T) AOBJN T,.-1 ] ;END OF IFN PAGING IFE PAGING,[ ;;; INITIALIZE THE SEGMENT TABLES, AND LINK COUNTERS FOR DEC-10 BZERSG==FIRSTLOC ;CROCK - BEWARE RELOCATION! BSYSSG==HILOC IN10ST: SETZ A, ;INIBD SETS NON-ZERO ON ERROR MOVEI T,FIRSTLOC MOVEI TT,FIRSTLOC ;DO NOT ATTEMPT TO PERFORM SUBI TT,STDLO ; THIS ARITHMETIC AT ASSEMBLY JSP F,INIBD ; TIME! WOULD USE WRONG ASCIZ \LOW\ ; RELOCATION QUANTITIES IFN HISEGMENT,[ MOVEI T,HILOC MOVEI TT,HILOC SUBI TT,STDHI MOVEM TT,MAXNXM SOS MAXNXM JSP F,INIBD ASCIZ \HIGH\ SKIPE A EXIT ;LOSE LOSE ] ;END IFN HISEGMENT HS% MOVEI TT,-1 HS% MOVEM TT,MAXNXM ;AS MUCH CORE AS IT WANTS TO USE! MOVE T,[$NXM,,QRANDOM] ;INITIALIZE SEGMENT TABLES MOVEM T,ST MOVE T,[ST,,ST+1] BLT T,ST+NSEGS-1 SETZM GCST MOVE T,[GCST,,GCST+1] BLT T,GCST+NSEGS-1 MOVEI AR1,BTBLKS ;AR1 ACTS AS BTB. [BIT-BLOCK COUNTER] LSH AR1,5-SEGLOG 10ST ZER 10ST ST 10ST SAR,[SA,,QARRAY][GCBMRK+GCBSAR]SASGLK 10ST VC,[LS+VC,,QLIST][GCBMRK+GCBVC] 10ST IS2,,,S2SGLK 10ST SYM,[SY,,QSYMBOL][GCBMRK+GCBSYM]SYSGLK 10ST IFS,[LS+$FS,,QLIST][GCBMRK+GCBCDR+GCBCAR]FSSGLK,BITS 10ST IFX,[FX,,QFIXNUM][GCBMRK]FXSGLK,BITS 10ST IFL,[FL,,QFLONUM][GCBMRK]FLSGLK,BITS BG$ 10ST BN,[BN,,QBIGNUM][GCBMRK+GCBCDR]BNSGLK,BITS 10ST BIT 10ST FXP,[FX+$PDLNM,,QFIXNUM] 10ST FLP,[FL+$PDLNM,,QFLONUM] 10ST P 10ST SP 10ST BPS 10ST SYS,[$XM+PUR,,QRANDOM] 10ST SY2 10ST PFS,[LS+$FS+PUR,,QLIST] 10ST PFX,[FX+PUR,,QFIXNUM] 10ST PFL,[FL+PUR,,QFLONUM] IN10S5: HRRM AR1,BTBAOB LSH AR1,SEGLOG-5 CAIN AR1,BFBTBS JRST IN10S8 OUTSTR [ASCIZ \LOST WHILE INITIALIZING BIT BLOCKS \] EXIT 1, IN10S8: EXPUNGE BZERSG BSYSSG ] ;END OF IFE PAGING ININTR: MOVE A,[-KNOB+1-10,,OBTFS+1] ;SET UP OBLIST-LINKING CONSING AREAS HRRZM A,-1(A) AOBJN A,.-1 MOVEI F,OBTFS MOVEM F,FFS MOVE F,[-KNOB,,OBTL] HRRZ A,(F) PUSHJ P,INTERN AOBJN F,.-2 INIRND: JSP F,IRAND ;INITIALIZE RANDOM NUMBER GENERATOR ;INITIALIZE INTERRUPT MASKS IN MEMORY 10$ MOVE T,[STDMSK] 10% MOVE T,[DBGMSK] MOVEM T,IMASK IFN ITS,[ MOVE T,[DBGMS2] MOVEM T,IMASK2 MOVE A,[SETO AR1,] MOVEM A,PURIFY .BREAK 12,[..SSTA,,[LISPGO]] ;SET START ADDRESS .CORE _-PAGLOG ;FLUSH PDL PAGES .VALUE .VALUE [ASCIZ \:INITIALIZED \] MOVE A,[JRST BINIT9] ;CLOBBER INIT, SINCE ONLY MOVEM A,INITIALIZE ; NEED DO ONCE BINIT9: .VALUE [ASCIZ \:ALREADY INITIALIZED \] JRST BINIT9 ] ;END OF IFN ITS IFN D20,[ MOVEI 1,.FHSLF MOVE 2,[3,,ENTVEC] SEVEC SKIPN PSYSP JRST .+3 PUSHJ P,PURIFY ;If we Purify the SYStem Pages SETZM .JBSYM ; then that flushs the symtab MOVE A,[JRST BINIT9] ;CLOBBER INIT, SINCE ONLY MOVEM A,INITIALIZE ; NEED DO ONCE HRROI 1,[ASCIZ \;Initialization Done \] SKIPA BINIT9: HRROI 1,[ASCIZ \;Already initialized \] PSOUT HALTF ;RETURN TO SUPERIOR JRST BINIT9 ] ;END IFN D20 IFN D10,[ MACROLOOP N2DIF,ZZD,* IFE SAIL,[ OPEN TMPC,INITO1 ;CHECK TO SEE IF THERE IS A JRST INIT1Z ; "LISP:" DEVICE WHICH LOOKUP TMPC,INIT1Q ; SHOULD HAVE "DEFMAX.FAS" ON IT JRST INIT1Z MOVEI T,QLISP ;"LISP" IS THUS THE LISP SYSTEM DEVICE MOVEI TT,NIL ; AND NEEDS NO PPN PROPERTY JRST INIT1W INIT1Z: OPEN TMPC,INITO2 ;CHECK FOR A "LSP:" DEVICE JRST INIT1A LOOKUP TMPC,INIT1Q JRST INIT1A MOVEI T,QLSP MOVEI TT,QLSP INIT1W: CLOSE TMPC, HRLM T,IRACOM ;PUT THE RIGHT "DEVICE" IN THE AUTOLOAD THING MOVEI A,QLISP HRRZ A,(A) ;FIX UP THE "PPN" PROPERTY OF "LISP" HLRZ B,(A) HRRZ A,(A) CAIE B,QPPN JRST .-4 HRLM TT,(A) ;BY RPLACD'ING IN THE NEW PPN PROPERTY JRST INIT1X INIT1E: JFCL OUTSTR [ASCIZ \ Error in scanning PPN, or PPN is not the LISP sys area - try again. \] INIT1A: JSP T,D10SET OUTSTR [ASCIZ \What is the PPN of the area with the autoload files? \] SETZM PNBUF MOVE T,[PNBUF,,PNBUF+1] BLT T,PNBUF+LPNBUF-1 MOVE R,[440700,,PNBUF] SETZB TT,D ;NUMBER WORDS - BASE 8 AND BASE 10. SETZB F,T ;FLAGS WORD ; 1 PROJ NUM FOUND ; 2 PROG NUM FOUND ; 4 CMU STYLE ; 10 "[" ENCOUNTERED ; 20 "]" ENCOUNTERED ; 40 "." ENCOUNTERED DURING NUMBER ; 400000,, ANY DIGITS/CMU-STRING FOUND INIT1B: INCHWL A CAIE A,^C CAIN A,^M JRST INIT1C ;^C OR TERMINATES PROGRAMMER NUMBER TRNE F,20 JSP T,INIT1E ;NO MORE CHARS PERMITTED AFTER RB CAIE A,91. ;LB FOUND JRST INIT1M TLNE F,400000 JSP T,INIT1E TROE F,10 TLO F,400000 ;PERMIT BRACKETS, BUT NOT REQUIRED JRST INIT1B INIT1M: CAIE A,93. ;RB FOUND JRST .+3 TRO F,20 JRST INIT1B SKIPE CMUP TRNN F,4 JRST INIT1K INIT1J: CAIL A,"a CAILE A,"z JRST .+2 SUBI A,"a-"A TLO F,400000 IDPB A,R ;ACCUMULATING CMU STYLE INTO PNBUF JRST INIT1B INIT1K: CAIE A,". JRST INIT1F TLNE F,400000 ;"." TROE F,40 JSP T,INIT1E JRST INIT1B INIT1F: CAIL A,"0 CAILE A,"9 JRST INIT1G TLO F,400000 IMULI TT,8 ;ACCUMULATE NUMBER BASE 8 IMULI D,10. ; AND BASE 10. ADDI TT,-"0(A) ADDI D,-"0(A) JRST INIT1B INIT1G: CAIE A,", JRST INIT1H TLZE F,400000 ;BETTER BE SOME DIGITS TROE F,1 ;CANT HAVE TWO COMMAS JSP T,INIT1E TRZE F,40 ;PROJ NUMBER FOUND MOVE TT,D ;BASE 10.? MOVEM TT,IPPN1 SETZB TT,D JRST INIT1B INIT1H: SKIPN CMUP ;NEITHER DIGITS NOR SYNTAX CHARS JSP T,INIT1E CAIL A,"a CAILE A,"z JRST .+2 SUBI A,"a-"A CAIL A,"A CAILE A,"Z JSP T,INIT1E TRO F,4 JRST INIT1J INIT1D: MOVEI T,PNBUF SKIPE CMUP ;0,,ADDRESS OF CMU PPN STRING CMUDEC T, ;CMUDEC WILL CONVERT A STRING TO A PPN WORD JSP T,INIT1E ;FAIL IF NOT A VALID CMU PPN HLRZM T,IPPN1 HRRZM T,IPPN2 JRST INIT1V INIT1C: TLNN F,400000 ;BETTER BE SOME DIGITS JSP T,INIT1E TRNE F,4 JRST INIT1D TRZE F,40 ;PROGRAMMER NUMBER FOUND? MOVE TT,D ;BASE 10.? MOVEM TT,IPPN2 INIT1V: MOVE T,IPPN1 HRLM T,INIT1S+3 ;CHECK TO SEE IF THAT PPN EXISTS MOVE T,IPPN2 HRRM T,INIT1S+3 RELEASE TMPC, OPEN TMPC,INITO3 JSP T,INIT1E INIT1X: RELEASE TMPC, ] ;END OF IFE SAIL MOVE C,[LVRNO] SETZ A, INIT2A: SETZ B, LSHC B,6 JUMPE B,INIT2B IMULI A,10. ADDI A,-'0(B) JRST INIT2A INIT2B: LSH A,30 ;VERSION NUMBER STORED IN LOC 137 AS MOVEM A,137 ;0XXX00,,0 MOVEI A,LISPGO HRRM A,.JBSA" MOVEM A,INIT ;SA$ MOVEI FREEAC,1 ;SAIL SETUWP DOES NOT RETURN OLD VALUE IN AC AS DEC10 HS$ SA% SETUWP FREEAC, ;RESTORE WRITE PROTECT STATUS HS$ SA% .VALUE IFE SAIL,[ OUTSTR [ASCIZ \:$INITIALIZED$ \] EXIT 1, ] ;END OF IFE SAIL IFN SAIL,[ IFN HISEGMENT,[ SETZ T, GETNAM T, MOVEM T, SGANAM ; JRST INIT7B PUSHJ P,SAVHGH ;SAVE HIGH SEGMENT AS SYS:MACLSP.SHR JRST INIT7A OUTSTR [ASCIZ \:$INITIALIZED; HIGH SEGMENT SAVED$ \] SETZ T, ;RECALL THAT A CRUFTY CODE 15 MAKES PTLOAD HAPPY MOVE TT,[440700,,[ASCIZ \SAVE SYS:MACLSP \]] PTLOAD T ;STICK SAVE COMMAND IN LINE EDITOR MOVEI T,INIT99 HRRM T,RETHGH JRST KILHGH ;FLUSH HIGH SEGMENT INIT7A: OUTSTR [ASCIZ \:$FAILED TO SAVE HIGH SEGMENT$ \] INIT7B: OUTSTR [ASCIZ \:$INITIALIZED$ \] SETZ T, ;RECALL THAT A CRUFTY CODE 15 MAKES PTLOAD HAPPY MOVE TT,[440700,,[ASCIZ \SSAVE SYS:MACLSP \]] PTLOAD T ;STICK SAVE COMMAND IN LINE EDITOR EXIT 1, ] ;END IFN HISEGMENT IFE HISEGMENT,[ OUTSTR [ASCIZ \:$INITIALIZED$ \] EXIT 1, JRST @.JBSA ] ;END IFE HISEGMENT ] ;END OF IFN SAIL ] ;END OF IFN D10 INIT99: JRST LISPGO IFN D10,[ INITO1: .IOBIN SIXBIT \LISP\ 0 INITO2: .IOBIN SIXBIT \LSP\ 0 INITO3: .IOBIN SIXBIT \DSK\ 0 INIT1Q: SIXBIT \DEFMAX\ SIXBIT \FAS\ 0 0 INIT1S: SIXBIT \DEFMAX\ SIXBIT \FAS\ 0 0 ;FILLED IN WITH ippn1,,ippn2 ] ;END OF IFN D10 ;;; NOTE THAT THE SECOND $ IN THE MESSAGE HERE IS A REAL DOLLAR SIGN, ;;; WHILE THE OTHER TWO ARE ALTMODES; THUS DDT WON'T GET SCREWED! NOTINIT: IFN ITS,[ .VALUE [ASCIZ \:LISP NOT INITIALIZED (USE INIT$G) \] ] ;END OF IFN ITS IFN D20,[ HRROI 1,[ASCIZ \;Not INITIALIZED (use INIT$G) \] PSOUT HALTF ] ;END OF IFN D20 INIBSP: REPEAT LLSYMS, .RPCNT IFN D10,[ ;;; ROUTINE TO CHECK SEGMENT BOUNDARIES, AND IF LOSING, ;;; TELL LOSER HOW TO WIN WITH LINK-10. INIBD: TRNN TT,SEGKSM JRST 1(F) ;WIN SETO A, OUTSTR (F) OUTSTR [ASCIZ \ SEGMENT ON BAD BOUNDARY. TELL LINK "/SET:.\] OUTSTR (F) OUTSTR [ASCIZ \.:\] ANDI TT,SEGKSM ADDI T,SEGSIZ SUBI T,(TT) HRLZ TT,T MOVEI D,6 INIBD1: SETZ T, LSHC T,3 ADDI T,"0 OUTCHR T SOJG D,INIBD1 OUTSTR [ASCIZ \" \] JRST 1(F) ] ;END OF IFN D10 IFN ITS,[ IFE SEGLOG-11,[ ;VARIOUS PARAMETERS BUILT INTO UCODE IFLE HNKLOG-5,[ ;;; KL-10 INIT ROUTINE KLINIT: MOVE T,[-NSEGS,,GCST] KLINI1: MOVE TT,(T) IFN HNKLOG, TLNN TT,GCBFOO+GCBHNK .ELSE TLNN TT,GCBFOO JRST KLINI2 SETO D, TLNE TT,GCBSYM MOVEI D,0 TLNE TT,GCBVC MOVEI D,1 TLNE TT,GCBSAR MOVEI D,2 IFN HNKLOG,[ HRRZ R,ST(T) TLNE TT,GCBHNK 2DIF [MOVEI D,(R)]3,QHUNK1 ] ;END OF IFN HNKLOG SKIPGE D .VALUE IFN HNKLOG, TLZ TT,GCBFOO+GCBHNK .ELSE TLZ TT,GCBFOO TLO TT,200000 DPB D,[330300,,TT] MOVEM TT,(T) KLINI2: AOBJN T,KLINI1 MOVE T,[JRST KLGCM1] MOVEM T,GCMRK0 MOVE T,[JRST KLGCSW] MOVEM T,GCSWP .VALUE [ASCIZ \:INITIALIZED FOR KL-10 \] ] ;END OF IFLE HNKLOG-5 ] ;END OF IFE SEGLOG-11 ] ;END OF IFN ITS IFN D10,[ LOPDL==200 LOFXPDL==100 LOSPDL==40 LOFLPDL==10 ALBPS==7000 SA$ ALBPS==ALBPS+4000 ] ;END OF IFN D10 SUBTTL HAIRY ALLHACK MACRO DEFINE AMASC A,B ASCIZ \ A!B \ TERMIN DEFINE ALLHACK XLABEL,TP,NAME,STDALC,MINALC,EXTRA,WHERE,NWHERE SKIPE ALLF JRST XLABEL PUSHJ P,ALLTYO AMASC [TP! !NAME = ]\STDALC MOVE AR1,[ASCII \NAME\] PUSHJ P,ALLNUM SKIPGE A XLABEL: MOVEI A,STDALC CAIGE A,MINALC MOVEI A,MINALC IFSN EXTRA,, ADDI A,EXTRA HRRM A,WHERE IFSN NWHERE,,[ MOVN B,A HRRM B,NWHERE ] PUSHJ P,ALLECO TERMIN SUBTTL ALLOC I/O ROUTINES 10% ALLJCL: BLOCK 80. ;BUFFER UP JOB COMMAND LINE IF THERE WAS ONE. 10% ALJCLP: -1 ;ALLOW ONLY ONE TRY FOR JCL (JOB COMMAND LINE) FAKJCL: 0 ;NON-ZERO MEANS LOOKING FOR INIT FILE, 0 MEANS JCL FILE ALLF: 0 ;NON-ZERO FOR STANDARD ALLOCATION AINFIL: 0 ;NON-NIL MEANS LOAD .LISP. (INIT) FILE AFTER ALLOCING ATYF: 0 ;TTYOFF FOR ALLOC LICACR: 0 ;LAST INPUTED CHAR TO ALLOC WAS A CR -1 ==> YES ALERR: STRT [SIXBIT \GC CALLED FROM ALLOC - LOSE, LISP IS DEAD!\] .VALUE ;;; PUSHJ P,ALLTYO ;PRINT ASCIZ STRING FOR ALLOC ;;; ASCIZ \TEXT...\ ;NOTE: ASCIZ IS NOT IN [ ... ] ! ALLTYO: HRLI A,440700 HLLM A,(P) ATYOI: ILDB A,(P) JUMPE A,POPJ1 SKIPN ATYF PUSHJ P,ALLTYC JRST ATYOI ALLECO: SKIPL AFILRD SKIPE ATYF POPJ P, PUSH P,A MOVE TT,A HRROI R,TYO PUSHJ P,PRINL4 POP P,A POPJ P, IFN SAIL,[ SAILP4: CAIN C,32 ;A TILDE? JRST SAIP1 CAIN C,176 ;A ~ JRST SAIP2 CAIE C,175 ;AN ALTMODE JRST SAIP3 MOVEI C,33 JRST SAIP3 SAIP1: MOVEI C,176 JRST SAIP3 SAIP2: MOVEI C,175 SAIP3: TRZE C,600 ;CTRL/META/BOTH? TRZ C,140 CAIN C,121 MOVEI C,21 CAIN C,161 MOVEI C,21 CAIN C,127 MOVEI C,27 CAIN C,167 MOVEI C,27 POPJ P, ] ;END OF IFN SAIL ALLTYI: IFN ITS,[ .IOT 0,C ;CHANNEL NUMBER FILLED IN ] ;END OF IFN ITS IFN D10,[ INCHRW C SA$ PUSHJ P,SAILP4 AOSG LICACR JRST ATI1 ATI2: CAIN C,^M SETOM LICACR ] ;END OF IFN D10 IFN D20,[ PUSH P,1 PBIN MOVEI C,(1) POP P,1 ] ;END IFN D20 CAIN C,^G JRST ALLOC1 POPJ P, IFN D10,[ ATI1: CAIN C,^J ;FLUSH A SYSTEM-SUPPLIED LINE-FEED INCHRW C ;FOLLOWING A CR SA$ PUSHJ P,SAILP4 JRST ATI2 ] ;END OF IFN D10 ALLTYC: IFN ITS,[ CAIE A,^J ALOIOT: .IOT 0,A ;WILL CLOBBER CHANNEL HERE ] ;END OF IFN ITS 10$ OUTCHR A 20$ PBOUT ;OUTPUT TO PRIMARY OUTPUT JFN POPJ P, ALLRUB: PUSHJ P,ALLTYO ASCIZ \XX \ ALLNUM: SKIPGE C,AFILRD ;GETS A NUMBER FOR SOME STORAGE AREA SIZE JRST ALNM1 ALNM2: JUMPN C,ALNM27 SETO A, POPJ P, ALNM27: HLRZ A,(C) ;SEARCH THE READ IN LIST TO SEE HRRZ C,(C) ;WHETHER LOSER HAS TRIED TO SPECIFY JUMPE C,ALLNER ;ALLOCATION FOR THIS QUANTITY SKOTT A,SY JRST ALSYER HLRZ A,(A) HRRZ A,1(A) HLRZ AR2A,(A) HLRZ A,(C) CAMN AR1,(AR2A) JRST ALNM3 HRRZ C,(C) JRST ALNM2 ALNM3: MOVE TT,(A) ;GET NUMBER INTO TT SKOTT A,FL ;IF FLOATING CONVERT TO FIXNUM SKIPA PUSHJ P,FIX2 SKOTT A,FX ;IS IT FIXNUM? JRST ALNMER ALNMOK: MOVE A,(A) POPJ P, ALSYER: MOVEI D,[SIXBIT \NON-SYMBOL ALLOCATION AREA!\] JRST ALCLZ1 ALNMER: MOVEI D,[SIXBIT \NON-FIXNUM/FLONUM ALLOCATION QUANTITY!\] JRST ALCLZ1 ALLNER: MOVEI D,[SIXBIT \ODD LENGTH ALLOCATION COMMENT!\] JRST ALCLZ1 ALNM1: MOVSI B,400000 MOVSI A,400000 ;GET VALUE FROM TTY ALNM1A: PUSHJ P,ALLTYI CAIE C,12 CAIN C,15 POPJ P, CAIE C,33 ;ALT MODE SAYS "DONE ALLOCING" JRST .+3 SETOM ALLF POPJ P, CAIN C,". MOVE A,B MOVE D,RCT0(C) TLNE D,170000 POPJ P, CAIL C,"0 CAILE C,"9 JRST ALLRUB TLZ A,400000 TLZ B,400000 IMULI A,10 ADDI A,-"0(C) IMULI B,10. ADDI B,-"0(C) JRST ALNM1A IFN D10,[ DECDIG: SKIPE ATYF POPJ P, JUMPN T,DDIG1 OUTCHR [ASCII \0\] DDIG1: JUMPE T,CPOPJ IDIVI T,10 PUSH P,TT PUSHJ P,DECDIG POP P,TT ADDI TT,"0 OUTCHR TT POPJ P, ] ;END OF IFN D10 SUBTTL ALLOC (INIT) FILE ROUTINES ALOFIL: IFN ITS,[ MOVSI C,(SIXBIT \DSK\) .SUSET [.RXUNAME,,A] MOVE B,[SIXBIT \LISP\] .SUSET [.RHSNAME,,F] ALOINI: .CALL ALOFL6 ;DOES INIT FILE EXIST? JRST ALOFL2 JRST ALOIN1 ;ELSE PROCEED NORMALLY ALOFL2: CAMN A,[SIXBIT /*/] ;ALREADY TRIED **? JRST ALFLER ;YUP, GIVE UP MOVE A,@ALOFL2 ;ELSE TRY ** JRST ALOINI ALOJCL: .CALL ALOFL6 ;DOES JCL FILE EXIST? JRST ALFLER ;NOPE, ERROR ALOIN1: MOVEM C,INIIF2+F.DEV ;YES, SAVE FILE NAMES MOVEM F,INIIF2+F.SNM MOVEM A,INIIF2+F.FN1 MOVEM B,INIIF2+F.FN2 ALOFL4: .CLOSE TMPC, ] ;END IFN ITS IFN D10,[ HRLZI C+1,(SIXBIT/DSK/) MOVE A,[SIXBIT/LISP/] HRLZI B,(SIXBIT/INI/) ALOFL1: SETZB C,C+2 OPEN TMPC,C JRST ALFLER ;NO DISK? MOVEM C+1,INIIF2+F.DEV SETZI C, MOVE C+1,R ;GET SPECIFIED PPN MOVEM C+1,INIIF2+F.PPN LOOKUP TMPC,A JRST ALFLER MOVEM A,INIIF2+F.FN1 HLLZM B,INIIF2+F.FN2 CLOSE TMPC, ];END IFN D10 IFN D20,[ SKIPE TENEXP SKIPA C,[ASCIZ \DSK\] MOVE C,[ASCIZ \PS\] ;LOSE LOSE - ASSUME CONNECTED TO "PS:" MOVEM C,INIIF2+F.DEV ;YES, SAVE FILE NAMES ] ;end of IFN D20 PUSH P,[ALOFL5] PUSH P,[INIIFA] PUSH P,[QNODEFAULT] ;DON'T MEREGE WITH DEFAULT FILENAMES MOVNI T,2 JRST $EOPEN ;OPEN INIT FILE ARRAY ALOFL5: MOVEM A,VINFILE MOVEI A,TRUTH MOVEM A,TAPRED SETOM AFILRD POPJ P, IFN ITS,[ ALOFL6: SETZ SIXBIT \OPEN\ ;OPEN FILE 5000,,2 ;MODE (ASCII BLOCK INPUT) 1000,,TMPC ;CHANNEL # ,,C ;DEVICE ,,A ;FILE NAME 1 ,,B ;FILE NAME 2 400000,,F ;SNAME ];END IFN ITS ;SETUP DEAFULT JCL IFN D10,[ ALFDEF: SETOM FAKJCL ;JCL IS REALLY FAKE MOVE TT,[ASCII \LISP \] ;DEFAULT JCL: LISP MOVEM TT,SJCLBUF+1 MOVE TT,[ASCII \ \] MOVEM TT,SJCLBUF+2 POPJ P, ] ;END IFN D10 ALLFIL: PUSHJ P,ALOFIL ;OPEN INIT FILE ALLFL1: SETZM BFPRDP PUSHJ P,READ ;READ IN ALLOCATIONS "COMMENT" SETZM ALGCF HLRZ B,(A) CAIE B,Q$COMMENT JRST ALCLUZ ALLFL2: HRRZ A,(A) MOVEM A,AFILRD ;SAVE IT (ACTUALLY, ITS CDR) JRST ALLOCC ALCLUZ: MOVEI D,[SIXBIT \ALLOC COMMENT MISSING IN INIT FILE!\] ALCLZ1: HRRZ A,VINFILE SETZM VINFILE PUSH FXP,D PUSHJ P,$CLOSE POP FXP,D 20% MOVE A,INIIF2+F.FN1 20% MOVE B,INIIF2+F.FN2 IT$ MOVE F,INIIF2+F.SNM 10$ MOVE F,INIIF2+F.PPN 20$ WARN [WHAT TO DO FOR FILE NOT FOUND ERROR FOR D20 ALLOC] SETZM FAKJCL ;FORCE ERROR MESSAGE THROUGH EVEN IF FAKING JCL JRST ALCERR IFN ITS,[ ALLTTS: SETZ ;TTYSET FOR ALLOC - NO INTERRUPT CHARS! SIXBIT \TTYSET\ ;SET TTY VARIABLES ,,TTYIF2+F.CHAN ;CHANNEL # ,,[STTYA1] ;TTYST1 400000,,[STTYA2] ] ;END OF IFN ITS ALHELP: PUSHJ P,ALLTYO ASCIZ \ N = DON'T ALLOCATE (I.E. USE DEFAULTS) Y = ALLOC FROM TTY ^A = READ INIT FILE AND ALLOC FROM IT ^B = ALLOC FROM TTY, THEN READ INIT FILE ^W = SAME AS ^A, BUT NO ECHO ON TTY ALTMODE, TYPED AT ANY TIME, TERMINATES ALLOCATION PHASE, TAKING REMAINING PARAMETERS AS DEFAULTS. ^G RESTARTS ALLOC. LINES PROMPTED BY A "#" CANNOT BE RE-ALLOCATED AFTER RUNNING. OTHERS CAN BE RE-ALLOCATED AT ANY TIME WITH THE LISP FUNCTION "ALLOC". TERMINATE EACH NUMERIC ENTRY WITH CR OR SPACE. A CR OR SPACE TYPED WITHOUT A PRECEDING NUMBER ASSUMES THE DEFAULT FOR THAT ENTRY. RUBOUT RESTARTS THE CURRENT ENTRY. NUMBERS ARE TYPED IN BASE EIGHT, UNLESS SUFFIXED BY ".", IN WHICH CASE BASE TEN IS USED. ALL ENTRIES ARE IN UNITS OF PDP-10 WORDS. \ JRST ALLOC1 ALFLER: MOVEI D,[SIXBIT \ INIT FILE NOT FOUND!\] ALCERR: SETZM TAPRED SETZM TTYOFF SETZM TAPWRT AOSN FAKJCL ;DID WE FAKE JCL? JRST POPJ1 ;YUP, THEN SKIP RETURN SO CAN DO ALLOC STRT [SIXBIT \ !\] IFN ITS,[ MOVE AR1,F MOVEI T,"; PUSHJ P,ALFL6 ] ;END OF IFN ITS MOVE AR1,A 10% MOVEI T,40 10$ MOVEI T,". PUSHJ P,ALFL6 MOVE AR1,B MOVEI T,40 PUSHJ P,ALFL6 STRT (D) SA$ CLRBFI ;CLEAR INPUT BUFFER FOR SAIL MOVNI T,0 ;SETUP FOR NO ARG LSUBR CALL JRST QUIT ; (VANILLA-FLAVORED QUIT) ALFL6: EXCH A,R SETZ AR2A, MOVE TT,[440600,,AR1] ALFL6A: ILDB A,TT JUMPE A,ALFL6B ADDI A,40 IT$ ALFL6C: .IOT 0,A ;CHANNEL # FILLED IN 10$ OUTCHR A 20$ PBOUT JRST ALFL6A ALFL6B: MOVE A,T IT$ .IOT 0,A ;CHANNEL # FILLED IN 10$ OUTCHR A 20$ PBOUT EXCH A,R POPJ P, SUBTTL MAIN ALLOC INTERACTION CODE %ALLOC: IFN D10,[ SETZM LICACR ;LAST INPUT CHAR TO ALLOC WAS? CR - NO! IFE SAIL,[ MOVEM 0,SGANAM ;SAVE MAGIC STUFF FOR GETHGH MOVEM 11,SGADEV MOVEM 7,SGAPPN JSP T,D10SET ] ;END OF IFE SAIL MOVEI A,ENDLISP+PAGSIZ-1;MUST DO CRUFTY CALCULATION BY HAND AS INVOLVES ANDI A,PAGMSK ;BOOLEAN OPS AND RELOCATABLE SYMBOLS (BARF!!) SUBI A,EINIFA MOVEM A,IGCFX1 ] ;END OF IFN D10 20$ JSP R,TNXSET ;DECIDE BETWEEN TENEX AND TOPS20 ; AND SET PAGE ACCESSIBILITY MOVE A,[RCT0,,RCT] BLT A,RCT+LRCT-1 IFN ITS,[ MOVE TT,[4400,,400000+<_11>] .CBLK TT, .VALUE MOVE TT,[4400,,400000+<_11>] .CBLK TT, .VALUE MOVE TT,[4400,,400000+<_11>] .CBLK TT, .VALUE MOVE TT,[4400,,400000+<_11>] .CBLK TT, .VALUE ] ;END OF IFN ITS MOVE P,C2 MOVE SP,SC2 MOVE FXP,FXC2 MOVE FLP,FLC2 MOVE A,[-LFSALC+1,,FSALC+1] ;SET UP ALLOC CONSING AREAS HRRZM A,-1(A) AOBJN A,.-1 MOVE A,[-LFWSALC+1+NIFWAL,,FWSALC+1+NIFWAL] HRRZM A,-1(A) AOBJN A,.-1 MOVE A,[-LSYALC+1,,SYALC+1] HRRZM A,-1(A) AOBJN A,.-1 MOVE A,[-NIS2SG*SEGSIZ/2+1,,SY2ALC+2] HRRZM A,-2(A) ADDI A,1 AOBJN A,.-2 MOVE A,[-INFVCS+1,,BFVCS+1] HRRZM A,-1(A) AOBJN A,.-1 MOVEI A,FSALC ;SET UP PHONY FREELISTS MOVEM A,FFS MOVEI A,FWSALC+NIFWAL MOVEM A,FFX MOVEI A,SYALC MOVEM A,FFY SETOM ALGCF ;ERROR OUT ON GC (UNTIL FURTHER NOTICE) SETZB NIL,ATYF SETOM AFILRD IFN ITS,[ .SUSET [.RSNAM,,T] MOVEM T,TTYIF2+F.SNM MOVEM T,TTYOF2+F.SNM ] ;END OF IFN ITS IFN D10,[ SA$ SETZ T, SA$ DSKPPN T, ;AS SET BY ALIAS COMMAND SA% GETPPN T, MOVEM T,TTYIF2+F.PPN MOVEM T,TTYOF2+F.PPN SA% SETZ T, ] ;END OF IFN D10 IFE D20,[ PUSH FXP,[SIXBIT \DSK\] PUSH FXP,T PUSH FXP, [SIXBIT \*\] IT$ PUSH FXP,[SIXBIT \>\] 10$ SA% PUSH FXP,[SIXBIT \LSP\] SA$ PUSH FXP, [SIXBIT \___\] ] ;END IFE D20 IFN D20,[ SKIPE TENEXP SKIPA T,[ASCIZ \DSK\] MOVE T,[ASCIZ \PS\] ;LOSE LOSE - ASSUME CONNECTED TO "PS:" PUSH FXP,T PUSHN FXP,L.6DEV-1 PUSH FXP,[ASCIZ \*\] PUSHN FXP,L.6DIR-1 PUSH FXP,[ASCIZ \*\] PUSHN FXP,L.6FNM-1 PUSH FXP,[ASCIZ\LSP\] PUSHN FXP,L.6EXT-1 PUSH FXP,[ASCIZ \*\] PUSHN FXP,L.6VRS-1 ] ;END IFN D20 PUSHJ P,6BTNML MOVEM A,VDEFAULTF PUSHJ P,OPNTTY ;OPEN TTY INPUT AND OUTPUT .VALUE ;MUST HAVE TTY TO DO ALLOC IFN ITS,[ MOVE T,TTYOF2+F.CHAN ;INITIALIZE CHANNEL NUMBER FOR DPB T,[270400,,ALOIOT] ; ALLOC'S OUTPUT .IOT TO TTY DPB T,[270400,,ALFL6B] DPB T,[270400,,ALFL6C] MOVE T,TTYIF2+F.CHAN ;NOW DO THE SAME FOR DPB T,[270400,,ALLTYI] ; THE INPUT .IOT ] ;END IFN ITS IFN ITS,[ AOSE ALJCLP JRST ALJ3 .SUSET [.ROPTION,,TT] SETZM FAKJCL ;NOT FAKE JCL TLNE TT,20000 ;NOT DDT ABOVE LISP TLZN TT,40000 ;IF THERE IS JCL, TURN IT OFF AFTER READING SOSA FAKJCL ;NO JOB COMMAND LINE, FLAG AS FAKE JCL .BREAK 12,[..RJCL,,ALLJCL] ALFDE1: SETZB A,C SETZB D,F SETZ B, MOVE AR1,[440700,,ALLJCL] ALJ1: MOVE AR2A,[440600,,T] SETZ T, ALJ1A: ILDB TT,AR1 JUMPE TT,ALJ2 CAIGE TT,"! JRST ALJ1B CAIE TT,": JRST ALJ1A1 MOVE C,T AOJA D,ALJ1 ALJ1A1: CAIE TT,"; JRST ALJ1A2 MOVE F,T AOJA D,ALJ1 ALJ1A2: CAIL TT,"a ;LOWER-CASE CAILE TT,"z ADDI TT,40 ANDI TT,77 TLNE AR2A,770000 IDPB TT,AR2A JRST ALJ1A ALJ1B: JUMPE T,ALJ1B2 JUMPE A,ALJ1B1 MOVEM T,B JRST ALJ1B2 ALJ1B1: MOVEM T,A ALJ1B2: CAIN TT,33 ;ALTMODE MEANS INIT FILE CAN GET JCL JRST ALJ2Q CAIE TT,^M JRST ALJ1 ALJ2: .SUSET [.ROPTION,,TT] TLZ TT,OPTCMD ;TURN OFF JCL .SUSET [.SOPTION,,TT] ALJ2Q: SKIPN C MOVSI C,(SIXBIT \DSK\) JUMPN A,ALJ2A SKIPN FAKJCL ;IF JCL FAKED, ALWAYS READ INIT JUMPE D,ALJ3 ;IF WAS REALLY NULL THEN DON'T TRY TO READ INIT MOVE B,[SIXBIT \LISP\] ;ASSUME FN2 OF LISP SKIPN F ;SNAME SPECIFIED? .SUSET [.RHSNAME,,F] ;NOPE, USE THE HSNAME .SUSET [.RXUNAME,,A] ;XUNAME IS FIRST TRY AT FN1 SETOM ATYF ;TURN OF TTY OUTPUT PUSHJ P,ALOINI ;TRY TO FIND FILE, USE INIT FILE ALGORITHM JRST ALLFL1 ;FILE FOUND JRST ALJ2A1 ALJ2A: SKIPN F ;DEFAULT SNAME? .SUSET [.RSNAM,,F] SKIPN B ;DEFAULT FN2? MOVSI B,(SIXBIT />/) SETOM ATYF PUSHJ P,ALOJCL JRST ALLFL1 ALJ2A1: SETZM ATYF ;TURN ON TTY I/O ALJ3: .CALL ALLTTS .VALUE ] ;END OF IFN ITS IFN D10,[ SETZM FAKJCL ;NOT FAKE JCL YET JSP F,JCLSET SKIPN SJCLBUF+1 ;ANY JCL? PUSHJ P,ALFDEF ;SETUP DEFAULT JCL SETZB D,R ;D IS FLAG FOR . SEEN, R IS PPN SETZB A,C 10$ MOVSI B,(SIXBIT \INI\) 20$ MOVE B,[ASCII \INI\] MOVE AR1,[440700,,SJCLBUF+1] ALJ1: MOVE AR2A,[440600,,T] SETZ T, ALJ1A: ILDB TT,AR1 JUMPE TT,ALJ2 CAIGE TT,"! JRST ALJ1B CAIE TT,": JRST ALJ1A1 MOVE C,T JRST ALJ1 ALJ1A1: CAIE TT,". JRST ALJ1A2 MOVE A,T SETZ B, AOJA D,ALJ1 ALJ1A2: CAIE TT,91. ;START OF PPN SPEC? JRST ALJ1A3 SA% GETPPN R, ;HOLD PPN IN R SA% JFCL ;IGNORE FUNNY SKIP RETURNS SA$ SETZ R, SA$ DSKPPN R, ;ON SAIL USE ALIAS PUSHJ P,HAFPPN ;READ 1/2 PPN, SKIP IF ZERO HRL R,T CAIE TT,", ;IF TERMINATOR NOT COMMA THEN GIVE UP ON PPN JRST ALPPN1 PUSHJ P,HAFPPN ;READ THE OTHER HALF OF THE PPN HRR R,T ;REPLACE IN GENERATED PPN CAIE TT,95. ;TERMINATING CLOSE BRACKET? ALPPN1: MOVE TT,C+2 ;NOPE, RESTORE OLD BYTE POINTER JRST ALJ1 ALJ1A3: CAIL TT,"a ;LOWER CASE CAILE TT,"z ADDI TT,40 ANDI TT,77 TLNE AR2A,770000 IDPB TT,AR2A JRST ALJ1A ALJ1B: JUMPE T,ALJ1B2 SKIPN D SKIPA A,T HLLZ B,T ALJ1B2: CAIN TT,33 ;ALT-MODE SAYS DONT FLUSH JCL JRST ALJ2Q CAIN TT,^M JRST ALJ1 ALJ2: SETZM SJCLBUF ALJ2Q: SKIPN C+1,C MOVSI C+1,(SIXBIT \DSK\) SETOM ATYF PUSHJ P,ALOFL1 ;SKIP RETURN MEANS INIT FILE NOT FOUND JRST ALLFL1 SETZM ATYF ;TURN ON TTY I/O JRST ALJ3 HAFPPN: SETZ T, ;START OFF WITH 0 MOVE C+2,AR1 ;SAVE CURRENT BYTE POINTER ILDB TT,AR1 CAIL TT,"0 ;MUST BE NUMERIC CAILE TT,"9 JRST HAFPP1 LSH T,3 ;ADD DIGIT INTO PPN ADDI T,-"0(TT) JRST HAFPPN HAFPP1: SKIPN T ;SKIP RETURN IF T NIL AOS (P) POPJ P, ALJ3: ] ;END OF IFN D10 PUSHJ P,ALLTYO ASCIZ \ LISP \ MOVE B,[LVRNO] ALLOCB: SETZ A, LSHC A,6 JUMPE A,ALLOCA ADDI A,40 PUSHJ P,ALLTYC JRST ALLOCB ALLOCA: ALLOC1: PUSHJ P,ALLTYO ASCIZ \ Alloc? \ PUSHJ P,ALLTYI SETZM ALLF CAIN C,^W SETOM ATYF CAIE C,^W CAIN C,^A JRST ALLFIL CAIE C,33 ;ALTMODE CAIN C,40 ;SPACE SETOM ALLF CAIE C,^B JRST .+3 SETOM AINFIL JRST ALLOCC CAIE C,"n ;LOWER CASE CAIN C,"N SETOM ALLF SKIPE ALLF JRST ALLOCC CAIE C,"Y CAIN C,"y ;LOWER CASE JRST ALLOCC CAIN C,"? JRST ALHELP CAIE C,"H CAIN C,"h ;LOWER CASE JRST ALHELP SA$ BEEP=047000,,400111 SA$ SETOM A SA$ BEEP A, SA% MOVEI A,^G ;RANDOM ILLEGAL CHARACTER TO ALLOC SA% PUSHJ P,ALLTYC IT$ HRRZ TT,TTYIF2+F.CHAN IT$ .CALL CKI2I IT$ .VALUE 20$ MOVEI 1,.PRIIN 20$ CFIBF JRST ALLOC1 IFN PAGING,[ ALCORX==>/PAGSIZ ALCORE==ALCORX+/PAGSIZ ] ;END IFN PAGING .ELSE [ ALCORX==>/PAGSIZ ALCORE==ALCORX+4 ] ALLOCC: PG% ALLHACK ASBPS,#,BPS,ALBPS,ENDLISP-BBPSSG,,BPSH ALLHACK ASRPDL,#,REGPDL,ALPDL,200,100,OC2 ALLHACK ASSPDL,#,SPECPDL,ALSPDL,200,100,OSC2 ALLHACK ASFXP,#,FXPDL,ALFXP,200,LSWS+12,OFXC2 ALLHACK ASFLP,#,FLPDL,ALFLP,10,10,OFLC2 10$ ALLHACK ASDDT,#,DDTSYMS,100,20,,SYMLO ALLHACK ASLIST,,LIST,MAXFFS,200,,XFFS ALLHACK ASSYM,,SYMBOL,MAXFFY,200,,XFFY ALLHACK ASFIX,,FIXNUM,MAXFFX,200,,XFFX ALLHACK ASFLO,,FLONUM,MAXFFL,200,,XFFL IFN BIGNUM, ALLHACK ASBIG,,BIGNUM,MAXFFB,100,,XFFB ALLHACK ASARY,,ARRAY,MAXFFA,100,,XFFA PUSHJ P,ALLTYO ASCIZ \ \ SUBTTL RUNTIME STORAGE ALLOCATION MOVEI TT,ALCORX*PAGSIZ IRP Q,,[S,X,L,B,Y,A]Z,,[FS,FX,FL,BN,SY,SA]N,,[NIFSSG+2,NIFXSG+2 NIFLSG+1,NBNSG,NSYMSG+1,NSARSG]FLG,,[1,1,1,BIGNUM,1,1] IFN FLG,[ MOVEI T,*SEGSIZ CAML T,XFF!Q MOVEM T,XFF!Q MOVE T,XFF!Q CAMGE T,G!Z!SIZ MOVEM T,G!Z!SIZ ADD TT,T LSH T,-4 ;HACK CAIGE T,SEGSIZ MOVEI T,SEGSIZ CAILE T,4000 MOVEI T,4000 CAML T,G!Z!SIZ SUBM T,G!Z!SIZ ] ;END OF IFN FLG TERMIN MOVEI D,ALCORE SUB D,TT JUMPLE D,ALLCZX IRP Q,,[S,X,L,Y]%%%,,[70.,15.,3.,12.] MOVEI T,(D) IMULI T,%%% IDIVI T,100. ADDM T,XFF!Q TERMIN ALLCZX==. ;FALLS THROUGH ;FALLS IN IFN PAGING,[ ALLCPD: SETZ F, MOVEI R,MEMORY-NSCRSG*SEGSIZ IRP Q,,[SC2,C2,FLC2,FXC2]Y,,[1,0,0,0]W,,[SPDL,PDL,FLP,FXP] MOVEI T,(R) SUBI T,MIN!W EXCH T,O!Q CAIGE T,MIN!W MOVEI T,MIN!W MOVEM T,X!W ADDI T,PAGSIZ-1+MIN!W ANDI T,PAGMSK MOVEI TT,(T) LSH TT,-PAGLOG SUBI F,(TT) SUBI R,(T) MOVEI D,PAGSIZ-20 CAML D,X!W MOVE D,X!W MOVNS D HRLS D HRRI D,(R) IFN , ADD D,R70+Y MOVEM D,Q MOVEI D,(R) ADD D,X!W ANDI D,777760 ;KEEP AWAY FROM PAGE BOUNDARIES! TRNN D,PAGKSM SUBI D,20 MOVEM D,X!W MOVEM D,Z!W TERMIN HRLM F,PDLFL1 IMULI F,SGS%PG HRLM F,PDLFL2 MOVEI F,(R) LSH F,-PAGLOG HRRM F,PDLFL1 MOVEI F,(R) LSH F,-SEGLOG HRRM F,PDLFL2 SUBI R,1 MOVEM R,HINXM HRRZ A,SC2 MOVEM A,ZSC2 HRRZ A,C2 ADDI A,1 MOVEM A,NPDLH HRRZ A,FXC2 ADDI A,1 MOVEM A,NPDLL IT% SETZM SYMLO JRST ALLDONE ] ;END OF IFN PAGING ;FALLS IN IFE PAGING,[ ALLCPD: MOVEI A,BFXPSG MOVEM A,NPDLL MOVEI B,LOFXPDL ;SET UP FXP ADD B,OFXC2 ADDI B,SEGSIZ-1 ANDI B,SEGMSK MOVNI C,-LOFXPDL(B) MOVSI C,(C) HRRI C,-1(A) MOVEM C,FXC2 ADDI C,-LOFXPDL(B) HRLI C,-LOFXPDL MOVEM C,OFXC2 MOVE C,[FX+$PDLNM,,QFIXNUM] JSP T,ALSGHK MOVEI B,LOFLPDL ;SET UP FLP ADD B,OFLC2 ADDI B,SEGSIZ-1 ANDI B,SEGMSK MOVNI C,-LOFLPDL(B) MOVSI C,(C) HRRI C,-1(A) MOVEM C,FLC2 ADDI C,-LOFLPDL(B) HRLI C,-LOFLPDL MOVEM C,OFLC2 MOVE C,[FL+$PDLNM,,QFLONUM] JSP T,ALSGHK MOVEM A,NPDLH MOVEI B,LOPDL+LOSPDL+1 ;SET UP P AND SP ADD B,OC2 ADD B,OSC2 MOVEI AR1,SEGSIZ-1(B) ANDI AR1,SEGMSK MOVEI AR2A,(AR1) MOVEI F,(A) SUBI AR1,(B) LSH AR1,-1 ;SPLIT SEGMENT REMAINDER MOVE B,OC2 ADDI B,LOPDL(AR1) MOVNI C,-LOPDL(B) MOVSI C,(C) HRRI C,-1(A) MOVEM C,C2 ADDI C,-LOPDL(B) HRLI C,-LOPDL MOVEM C,OC2 ADDI A,(B) MOVE B,OSC2 ADDI B,LOSPDL+1(AR1) MOVNI C,-LOSPDL-1(B) MOVSI C,(C) HRRI C,(A) .SEE UBD ;SP NEEDS FUNNY SLOT MOVEM C,SC2 HRRZM C,ZSC2 ADDI C,-LOSPDL-1(B) HRLI C,-LOSPDL MOVEM C,OSC2 MOVEI A,(F) MOVEI B,(AR2A) MOVE C,[$XM,,QRANDOM] JSP T,ALSGHK MOVEM A,BPSL MOVEM A,VBP1 MOVE C,A ADDB C,BPSH ;FIRST ESTIMATE OF BPSH HRRE B,.JBSYM JUMPLE B,ALCPD1 ;ONLY HACK SYMBOLS IF IN LOW SEGMENT SUB B,SYMLO CAIG C,(B) MOVE C,B MOVEM C,BPSH ;SECOND ESTIMATE OF BPSH ADD C,SYMLO HLRE B,.JBSYM" HRRO D,.JBSYM SUB D,B SUBI D,1 ;TO BE A PDL PTR IN THE SYMMOV SUB C,B ALCPD1: IORI C,SEGKSM ;HIGHEST ADDR FOR AUGMENTED SYMTAB MOVEI B,1(C) CAMG C,.JBFF JRST .+3 CORE C, JRST ALQX2 HRRM B,.JBFF" MOVEI F,-1(B) SUB B,BPSL ;TOTAL NUMBER WDS OCCUPIED BY RANDOM BPS AND SYMTAB SUBI F,(D) ;TOTAL DISTANCE THAT SYMTAB MOVES HRRE R,.JBSYM JUMPLE R,ALQX1 ;ONLY HACK SYMBOLS IF THERE OR IN LOW SEGMENT HLRE R,.JBSYM JUMPE F,ALQX1 MOVE TT,[SYMMOV,,SYMMV1] BLT TT,LPROGS HRRI SYMMV1,(F) JRST SYMMV1 SYMMV6: ADDI SYMMV1,1(D) HRRM SYMMV1,.JBSYM" SUB SYMMV1,SYMLO SUBI SYMMV1,1 HRRZM SYMMV1,BPSH ;IF THERE WAS A SYMTAB, NOW WE KNOW WHERE BPSH IS IFE SAIL,[ MOVE F,[112,,11] GETTAB F, SETZ F, LDB F,[061400,,A] CAIN F,3 HRRM SYMMV1,@770001 ;TENEX SIMULATOR FOR TOPS-10 ] ;END OF IFE SAIL ALQX1: MOVE C,SYMLO ASH C,-1 MOVEM SYMLO ;CONVERT FROM # OF WORDS TO # OF ENTRIES HRRZ C,BPSH SUB C,IGCFX1 ;IF NEWIO, MUST ALLOW FOR INITIAL ARRAY SUB C,IGCFX2 ;AND INIT FILE ARRAY MOVEM C,VBPE1 ;INITIAL SETTING OF BPEND MOVE C,[$XM,,QRANDOM] JSP T,ALSGHK MOVEI C,-1(A) MOVEM C,HIXM MOVEI B,HILOC ANDI B,SEGMSK SUBI B,(A) MOVE C,[$NXM,,QRANDOM] JSP T,ALSGHK JRST ALLDONE ALSGHK: MOVEI TT,(A) MOVNI D,(B) LSH TT,-SEGLOG ASH D,-SEGLOG HRLI TT,(D) MOVEM C,ST(TT) AOBJN TT,.-1 ADDI A,(B) JRST (T) ALQX2: PUSHJ P,ALLTYO ASCIZ \ CAN'T GET ENOUGH CORE!\ JRST ALLOC1 ] ;END OF IFE PAGING ALLDONE: IFE PAGING,[ IFE SAIL,[ MOVE P,C2 ;SET UP PDL POINTERS MOVE FXP,FXC2 MOVE FLP,FLC2 MOVE SP,SC2 ] ;END OF IFE SAIL ] ;END OF IFE PAGING MOVEI A,LISP HRRM A,LISPSW SETZM ALGCF ;GC IS OKAY NOW IFN D10,[ MOVEI A,GOINIT HRRM A,.JBSA" PUSHJ P,GRELAR ] ;END OF IFN D10 JRST LISP CONSTANTS ;ALLOC'S LITERALS GET EXPANDED HERE IFE PAGING,[ SYMMOV: ;MOVE MOBY JOB SYMBOL TABLE UPWARDS OFFSET C-. SYMMV1: POP D,.(D) ;C AOJL R,SYMMV1 ;AR1 JRST SYMMV6 ;AR2A LPROGS==.-1 OFFSET 0 .HKILL SYMMV1 ] ;END OF IFE PAGING ;;; INITIAL ARRAYS IN SYSTEM GO HERE. .SEE GCMKL .SEE IGCMKL .SEE VBPE1 SUBTTL INITIAL INIT FILE ARRAY FOR .LISP. (INIT) FILE -F.GC,,INIIF2 ;GC AOBJN POINTER INIIF1: JSP TT,1DIMS INIIFA ;POINTER TO SAR 0 ;CAN'T ACCESS INIIF2: OFFSET -. FI.EOF:: NIL ;EOF FUNCTION FI.BBC:: 0,,NIL ;BUFFERED BACK CHARS FI.BBF:: NIL ;BUFFERED BACK FORMS BLOCK 5 F.MODE:: 0 ;MODE (BLOCK ASCII DSK INPUT) F.CHAN:: -1 ;CHANNEL # (INITIALLY ILLEGAL) 20$ F.JFN:: -1 ;JOB-FILE NUMBER 20% 0 F.FLEN:: 0 ;FILE LENGTH F.FPOS:: -1 ;FILEPOS BLOCK 3 IFN ITS+D10,[ F.DEV:: SIXBIT \DSK\ ;DEVICE IT$ F.SNM:: 0 ;SNAME (FILLED IN) 10$ F.PPN:: 0 ;PPN (FILLED IN) IT$ F.FN1:: SIXBIT \.LISP.\ ;FILE NAME 1 10$ F.FN1:: SIXBIT \LISP\ IT$ F.FN2:: SIXBIT \(INIT)\ ;FILE NAME 2 10$ F.FN2:: SIXBIT \INI\ F.RDEV:: BLOCK 4 ;.RCHST'D NAMES ] ;END OF IFN ITS+D10 IFN D20,[ F.DEV:: ASCIZ \DSK\ ;DEVICE (FILLED IN AT RUN TIME) BLOCK L.6DEV-<.-F.DEV> F.DIR:: ;DIRECTORY (UNSPECIFIED) BLOCK L.6DIR-<.-F.DIR> F.FNM:: ASCIZ \LISP\ ;FILE NAME BLOCK L.6FNM-<.-F.FNM> F.EXT:: ASCIZ \INI\ ;EXTENSION BLOCK L.6EXT-<.-F.EXT> F.VRS:: ASCIZ \0\ ;VERSION BLOCK L.6VRS-<.-F.VRS> ] ;END OF IFN D20 LOC INIIF2+LOPOFA BLOCK 5 AT.CHS:: 0 ;CHARPOS AT.LNN:: 0 ;LINENUM AT.PGN:: 0 ;PAGENUM BLOCK 10 LONBFA:: FB.BYT:: 0 ;BYTE SIZE FB.BFL:: 0 ;BUFFER LENGTH FB.BVC:: 0 ;COUNT OF VALID CHARACTERS IFN ITS+D20,[ FB.IBP:: 0 ;INITIAL BYTE POINTER FB.BP:: 0 ;BYTE POINTER FB.CNT:: 0 ;CHARACTER COUNT BLOCK 2 ] ;END OF IFN ITS+D20 IFN D10,[ FB.HED:: 0 ;BUFFER HEADER FB.NBF:: 0 ;NUMBER OF BUFFERS FB.BWS:: 0 ;SIZE OF BUFFER IN WORDS SA% 0 SA$ FB.ROF:: 0 ;RECORD OFFSET BLOCK 1 ] ;END OF IFN D10 FB.BUF:: 10% BLOCK RBFSIZ 10$ BLOCK NIOBFS* 10$ IFL NIOBFS-2, BLOCK NIOBFS* OFFSET 0 LINIFA==:.-INIIF1+1 ;TOTAL NUMBER OF WORDS EINIFA:: ;END OF ARRAY -1 ;PHOOEY! FORCE THE "BLOCK" TO MAKE REAL 0'S ;;@ END OF ALLOC 250 PRINTX \ \ ;JUST TO MAKE LSPTTY LOOK NICER EXPUNGE ZZ ZY ZX ZZX ZZY ZZZ ZZW HS$ 10$ IF2, BSYSSG==HSGORG ;ANTI-RELOCATION CROCK IF2, MACROLOOP NBITMACS,BTMC,* ;FOR BIT TYPEOUT MODE ENDLISP:: ;END OF LISP, BY GEORGE! VARIABLES ;NO ONE SHOULD USE VARIABLES! IFN .-ENDLISP, WARN [OKAY, WHO'S THE WISE GUY USING VARIABLES?] IFN D10,[ $HISEG ENDHI:: ;END OF HIGH SEGMENT ] ;END OF IFN D10 IF2, ERRCNT==:.ERRCNT ;NUMBER OF ASSEMBLY ERRORS END INITIALIZE