diff --git a/Makefile b/Makefile index 33187583..94db30bf 100644 --- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ SRC = syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ macsym lmcons dmcg hack hibou agb gt40 rug maeda ms kle aap common \ fonts zork 11logo kmp info aplogo bkph bbn pdp11 chsncp sca music1 \ moon teach ken lmio1 llogo a2deh chsgtv clib sys3 lmio turnip \ - mits_s rab stan_k bs cstacy kp dcp2 -pics- victor imlac rjl mb + mits_s rab stan_k bs cstacy kp dcp2 -pics- victor imlac rjl mb lispm1 DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ diff --git a/src/lispm1/lmi.845 b/src/lispm1/lmi.845 new file mode 100644 index 00000000..5da77d19 --- /dev/null +++ b/src/lispm1/lmi.845 @@ -0,0 +1,10621 @@ +;**WARNING** THE PARAMETER ASSIGNMENTS IN THIS FILE HAVE BEEN UPDATED +; TO KNOW ABOUT 24 BIT POINTERS, BUT THE CODE HASNT!!**** + + .SYMTAB 5000. + +FNASW==1 ;PHASEOVER SWITCH FOR FUNARG (CLOSURE) HACKING + +TITLE LMI + +.MLLIT==1 + +;REGISTER ASSIGNMENTS + +ZR=0 +A=1 +B=2 +C=3 +D=4 +E=5 +T=6 +R=7 +Q=10 +I=11 +J=12 +S=13 +AP=14 ;INTERPRETED ARG PNTR +IP=15 ;INTERPRETED PDL PNTR +PC=16 ;INTERPRETED PC + ;4.9 OF PC USED TO COUNT HALVES OF WORDS +QINDAT==200000 ;4.8 IS USED FOR ATOM INDCATOR +QINDNL==100000 ;4.7 IS USED FOR NIL INDICATOR +QBBFL== 40000 ;4.6 BINDINGS PUT ON BINDING LIST THIS BLOCK +;QBALM== 20000 ;4.5 ARG LOADING MODE (0 LINEAR, 1 FRAME) +;QBNEAF== 10000 ;4.4 NON-EVAL ARG STORED FLAG (FOR CHECKING ON FAST CALLS) +; ;4.3 UNUSED + +MSIND== 20000 ;4.5 MESA-CODE INDICATOR. SET BY MESA EQ, <, >. TESTED BY + ; SOME MESA BRANCHES. ALWAYS TESTED IMMEDIATELY AFTER + ; BEING SET, SO IT IS NOT NECESSARY TO SAVE THIS FLAG + ; ACROSS CALL-RETURN BOUNDARIES, ETC. + +%PCSTS==350700 ;BYTE POINTER TO PC STATUS + +P=17 + +;CORE MANAGEMENT PARAMETERS + +NCPGS==40 ;# CORE SLOTS FOR VIRTUAL "VIRTUAL PAGES" +PAGSIZ==200 ;PAGE SIZE IN PDP-10 WORDS +NPPG==PAGSIZ/2 ;# FULL NODES/PAGE +HNPPG==PAGSIZ ;# HALF NODES/PAGE + +HALT==.VALUE ; THIS IS USED WHEREVER SOMEONE WAS TOO LAZY TO PUT IN A BARF... + +DEFINE BARF MESS,CMNDS +.VALUE [ASCIZ |: +---- ERROR ----- +MESS +.JPC/ +CMNDS +.-1 +|] +TERMIN ;NOTE TAB AT END OF LINE 2 BEFORE THIS ONE + +DEFINE CONC A,B +A!B!TERMIN + +DSKI==1 ;INPUT CHNL COLD LOAD +TYIC==2 ;%TYI CHNL +TYOC==3 ;%TYO CHNL + +SOUT==1000,, ;STRING PRINT UUO + +SPPO==20 ;OFFSET IN SCRATCH-PAD PAGE FROM BEG TO PARAMETER AREA +SPTO==20 ;FURTHER OFFSET TO TEMP AREA + +LPDL==100 ;LENGTH INTERPRETER INTERNAL PDL + +;NODE STORAGE FORMAT + +;ALL Q ADDRESSES OFFSET FROM PDP-10 ADDRESSES BY SYMBOL "MEM" + +;4.9 INTERPRETER TRAP +;4.5-1.1 SIMULATED 32 BIT Q + +;4.5-3.7 INFO BYTE +;3.6-1.1 ADDRESS OR DATA FIELD + ;ADDRESS ARE STORED AS FOLLOWS + ;"Q" ADDRESS IN 2.9-1.1 + ;BYTE ADR (IF USED) IN 3.5-3.4 + +NHIB==740000 ;"HIGH" BITS UNUSED IN Q +NCDRB==30000 ;4.5-4.4 CDR CODE BITS +%NCDRB==360200 ;BYTE POINTER TO ABOVE +NUSRCB==4000 ;4.3- USRC +%NUCB==350100 ; BYTE POINTER TO ABOVE +%NDATU==3600 ;BYTE-POINTER TO USRC+DATA-TYPE+POINTER +NDTB==3700 ;4.2-3.7 DATA TYPE BITS +%NDTB==300500 ;BYTE POINTER TO DATA TYPE BITS +%NDAT==3500 ;BYTE POINTER TO STORE DATA NOT INCLUDING CDR CODE, USRC BITS +%NPTR==3000 ;BYTE POINTER TO JUST "POINTER" DATA +RBMSK==NUSRCB+NCDRB+NHIB ;MASK TO LEAVE ONLY D.T. AND DATA +%RBMSK==350300 ;BYTE POINTER TO ABOVE +NADIP==PAGSIZ-1 ;BITS THAT CORRESPOND TO ADDRESS WITHIN PAGE +%NADIP==700 ;BYTE POINTER TO LOAD BITS THAT ADDRESS WITHIN PAGE + +NNPTR==777700 ;MASK TO CLEAR BITS EXCEPT POINTER DATA +%NNPTR==301000 ; BYTE POINTER TO ABOVE + +;CDR CODES + ;0 FULL NODE +NXTNOT==10000 ;1 TRAP (2ND HALF OF FULL NODE) +NXTNIL==20000 ;2 CDR NIL +NXTCDR==30000 ;3 CDR NEXT + + +;DATA TYPES + +QZTRAP==0 ;ILLEGAL TRAP +QZNULL==1 ;"BLANK" (USED FOR EMPTY FUNCTION AND VALUE CELLS) +QZFREE==2 ;NULL +QZSYM==3 ;SYMBOL POINTER TO HEAD OF SYMBOL ARRAY +QZFIX==4 ;FIX 23 BITS +QZXNUM==5 ;EXTENDED NUMBER NOT YET IMPLEMENTED +QZINV==6 ;INVOKE + ;"INVISIBLENESS IS A FORM OF CONDITIONAL INDIRECT ADDRESSING" +QZGCF==7 ;GC-FORWARD +QZSCF==10 ;SYMBOL-COMPONENT-FORWARD +QZQF==11 ;Q-FORWARD +QZF==12 ;FORWARD +QZMEMP==13 ;LIKE LOCATIVE, BUT POINTER VALUE HAS "MEM" ADDED INTO IT SO + ;MICRO-COMPILED CODE CAN WIN +QZXLIS==14 ;"LOCATIVE" TO LIST ;POINTS AT ITS GIVEN Q REGARDLESS OF WHETHER CAR OR CDR +QZXSTR==15 ;LOCATIVE INTO STRUCTURE ;IS TAKEN OF IT. +QZXSYM==16 ;LOCATIVE INTO SYMBOL +QZLIST==17 ;LIST +QZLSTR==20 ;LIST POINTER INTO STRUCTURE +QZLSYM==21 ;LIST POINTER INTO SYMBOL +QZUENT==22 ;MICRO-CODE ENTRY (IF CALLED AS FCTN) +QZMESA==23 ;MESA CODE ENTRY, POINTER POINTS TO MESA-FEF +QZFEFP==24 ;POINTER TO FEF +QZFEFH==25 ;FEF HEADER +QZARYP==26 ;POINTER TO ARRAY-HEADER +QZARYH==27 ;ARRAY-HEADER +QZALDR==30 ;ARRAY LEADER +QZSTKG==31 ;STACK GROUP, POINTS TO ARRAY-HEADER. HOWEVER, USER MUST + ; CHANGE TO ARRAY-POINTER TO REF AS ARRAY. NORMAL INTERPRETATION + ; IN FUNCTION CONTEXT IS TO CALL-STACK-GROUP. +QZCLOS==32 ;CLOSURE. IN FUNCTION CONTEXT, HACK VALUE CELLS THEN CALL. + +NQZUSD==40-32-1 ;# DATA TYPES UNUSED +QZ==0,,-1 ;FOR DDT BIT TYPE OUT MODE + +;AREA STORAGE PARAMETERS + +;STG AREA ALLOC +ZARN==0 +ZPGN==0 + +DEFINE DAREA NAME,PAGES +NAME==ZARN +CONC .LQ,\NAME,==ZPGN*PAGSIZ +ZARN==ZARN+1 +ZPGN==ZPGN+PAGES +CONC .LN,\NAME,==PAGES*PAGSIZ + +CONC DEFINE AM,\NAME +.O!NAME: +CONC .OI,\NAME,: BLOCK PAGSIZ*PAGES +TERMIN +TERMIN + +NANPG==1 ;# PAGES PER (PER AREA) ARRAY +NAREAS==NANPG*HNPPG-1 ;MAX # OF AREAS + + + +;FIRST 4 CHARACTERS OF ARRAY NAME MUST BE UNIQUE +;BOTTOM +DAREA ANSYM,1 ;SYMBOL SPACE + ;(RESIDENT, TO BE USED FOR HIGHLY USED ATOMS) +DAREA ANCOM,1 ;SYSTEM COMMUNICATIONS, PROBABLY NOT USED IN LMI +DAREA ANSCR,1 ;PAGE TO BE LOADED INTO "SCRATCH PAD" MEMORY ON RESTART + ;(WAS 2 WITH 100 WD PGS) +DAREA ANMS,4 ;MICRO-CODE SYMBOL VECTOR (WAS 2 W/100 WD PGS) + ; FIRST 600 LOCNS ARE ENTRY VECTOR ARE UCODE STARTING ADRS + ; FOR MISC INSTRUCTIONS 200-777. (3 PAGES) + ; FOLLOWING THAT ARE RANDOM OTHER UCODE ENTRY ADRS + ; (MMCALL, ETC). (1 PAGE) +DAREA APAG,0 ; PAGE-TABLE-AREA +DAREA APPAN,0 ; PHYSICAL-PAGE-AREA-NUMBER + ;AA AREAS ARE ARRAYS, INDEXED BY AREA #, ONE Q PER AREA +DAREA AAORG,NANPG ;AREA ORIGINS (IN Q'S) INTIALIZED BY + ;COLD LOAD FOR INITIALLY ACTIVE AREAS +DAREA AALN,NANPG ;AREA LENGTH (IN Q'S) (INITIALIZED AT COLD LOAD FOR + ;INITIALLY ACTIVE AREAS +DAREA AAFM,NANPG ;FREE STORAGE MODE FOR ALL AREAS BOTTOM 3 BITS + ;OTHER RANDOM MODES HERE TOO SEE QCOM +DAREA AASO,NANPG ;AREA# SORTED BY ORIGIN +DAREA AANAME,NANPG ;AREA NAMES +DAREA AAFP,NANPG ;FREE STORAGE POINTERS FOR ALL AREAS + ;FOR FSLIN AREA, IS ASCENDING POINTER + ;FOR FSQLST AREA, IS LIST OF FREE 2Q NODES +DAREA AAPP,NANPG ;ADDTL INFO + ;FOR FSQLST AREA, POINTER TO CURRENTLY + ;PARTIALLY ALLOCATED PAGE +DAREA AAPL,NANPG ;FREE PAGE LIST +DAREA ANSUP,1 ;"SUPPORT ENTRY VECTOR" (CONTAINS FUNCTION POINTERS (EITHER + ; MACRO-COMPILED OR MICRO-COMPILED) TO ACCESS "SUPPORT" + ; FUNCTIONS (LIKE INTERPRETER TRAP, PRINT, ETC). ORDER IS + .SEE SVCPNT ; IMPORTANT. +DAREA ANCP,1 ;CONSTANTS PAGE. SECOND Q MUST BE POINTER TO ATOM T +DAREA ANME,5 ;MICRO-CODE ENTRY +DAREA ANMN,5 ;MICRO-CODE ENTRY NAMES +DAREA ANNA,5 ;MICRO-CODE ENTRY NUMBER ARGS +DAREA ANMP,5 ;MICRO-CODE ENTRY MAX IP USAGE. +DAREA ANMX,6 ;MICRO-CODE EXIT (AND LIST-SPACE REFERENCE) + + +IFG ZARN-NAREAS,.ERR TOO MANY AREAS +IAARAS==ZARN ;# INITIALLY ACTIVE AREAS + +IF2 QQTPG=.OANCP ;ORIGIN OF CONSTANTS PAGE +IF2 MSYM==.OANMS ;ORIGIN OF MICRO-CODE SYMBOL VECTOR +IF2 AFSORG=.OAAOR ;ORIGIN OF AREA ORIGIN ARRAY (THIS Q CORRESP TO AREA 0) +IF2 AFSLN=.OAALN ;ORIGIN OF AREA LENGTH ARRAY " +IF2 AFSPTR=.OAAFP ;ORIGIN OF AREA FREE POINTER ARRAY " +IF2 AFSMOD=.OAAFM ;ORIGIN OF AREA FREE STORAGE MODE ARRAY " +IF2 AFSPP=.OAAPP ;ORIGIN OF PARTIALLY ALLOCATED PAGE ARRAY " +IF2 AFSPL=.OAAPL ;ORIGIN OF FREE PAGE LIST ARRAY " +IF2 MEVEC=.OANME ;ORIGIN OF MICRO-CODE ENTRY VECTOR +IF2 MEVECN=.OANMN ;ORIGIN OF MICRO-CODE ENTRY NAME VECTOR +IF2 MEVECA=.OANNA ;ORIGIN OF MICRO-CODE-ENTRY NUMBER ARGS VECTOR +IF2 MXVEC=.OANMX ;ORIGIN OF MICRO-CODE EXIT VECTOR +IF2 SUPV==.OANSUP ;ORIGIN OF SUPPORT FUNCTION VECTOR +IF2 PAGT==.OAPAG ;ORIGIN OF PAGE-TABLE-AREA + +IF2 SC%FRE==.OANCOM+16 ;%SYS-COM-NEXT-FREE-LOC +IF2 SC%HGH==.OANCOM+17 ;%SYS-COM-HIGHEST-LOC + +;FREE STORAGE MODE CODES + +FSERR==0 +FSLIN==1 ;AREA HAS LINEARLY ADVANCING FREE STG POINTER +FSQLST==2 ;AREA HAS FREE STORAGE LIST OF 2Q NODES, + ; A FREE STG LIST OF PAGES + ; AND A SINGLE CURRENTLY PARTIALLY ALLOCATED PAGE +FSPLST==3 ;AREA HAS FREE STORAGE LIST OF PAGES + +FSMAX==4 ;HIGHEST MODE ASSIGNED + +;INVOKE ACTIVATE CODES (GIVEN TO INVOKED ROUTINE TO TELL IT WHAT IS TRYING TO BE DONE) +IVACAR==1 ;CAR +IVACDR==2 ;CDR +IVARCA==3 ;RPLACA +IVARCD==4 ;RPLACD +IVAAHD==5 ;EXAMINING IT AS AN ARRAY HEADER + +;"SYMBOL VECTOR" + +SYMVL==4 ;# OF Q'S IN SYMBOL VECTOR + +; PNAME POINTER (STRING) +; VALUE BINDING CELL +; FUNCTION BINDING CELL +; PROPERTY LIST + +;STRING STORAGE **OLD** +;0-177 ASCII VALUES +;200-237 MAGIC KEYS +;240-250 FONT CHANGES +; OTHER HAIR E.G. FROM THE FOLLOWING OBSOLETE STUFF: +;200 BIT ESCAPE +;200- STRING TERMINATOR +;201- CURSOR CONTROL - FOLLOWED BY CHAR OR CHARACTERS AS IN ITS ^P CODES +;210-227 FONT CHANGE TO FONT N +;230-237 HASH LINK FLAG - SYSTEM CHARACTER HASH LINK TBL N (0-7) +;240-277 N CHARACTER DELETION (240->0, SO IT IS A NULL CHARACTER) +;340-377 SPECIFIES 5 HIGH BITS FOR NEXT CHARACTER IN "EXTENDED" CHARACTER + ;SET, MAKING A TOTAL OF 12 (5+7) + + +%FRMDT==230400 ;THIS FIELD OF FIRST Q OF FRAME CONTAINS FRAME TYPE + ;-- MUST EXIST IN THING POINTED TO BY DATA TYPE QZFEFP + +FRMERR==0 ;ERROR +FRMPDL==1 ;PDL FRAME +FRMARG==2 ;ARG HOLDING FRAME +FRMFEF==3 ;FUNCTION ENTRY FRAME + + +;ARRAY STORAGE + +;POINTERS TO ARRAY HEADER IN GENERAL LIST STRUCTURE HAVE DATA TYPE QZARYP + + +;HEADER WORD OF ARRAY HAS DATA TYPE QZARYH +ARTSFT==23 ;SHIFT FOR BELOW FIELD +%ARYTP==230500 ;HAS TYPE OF ARRAY + ARTERR== 0 ;ERROR + ARTBIT== 1 ;BIT ARRAY + ART2BT== 2 ;2 BIT ARRAY + ART4BT== 3 ;4 BIT ARRAY + ART8BT== 4 ;8 BIT ARRAY + ART16B== 5 ;16 BIT ARRAY + ART32B== 6 ;32 BIT ARRAY + ARTQ== 7 ;ARRAY OF Q'S + ARTLAR==10 ;"LIST" ARRAY (LIKE Q ARRAY, BUT ALSO USED AS + ;LIST. MAY HAVE POINTERS INTO ITS MIDDLE + ARTSTR==11 ;STRING (STORAGE RETRIEVAL IDENTICAL TO 8 BIT ARRAY) + ARTSGH==12 ;STACK-GROUP HEAD (STORAGE RETRIEVAL IDENTICAL TO ARTQ) + ARTSPD==13 ;ART-SPECIAL-PDL (HOLDS LINEAR-BINDING-PDL) + ARTTV==14 ;TV BUFFER ARRAY (ON REAL MACHINE ONLY) + ARTRPD==15 ;ART-REG-PDL +ARXIB== 1_21 ;SAYS "LEADER" FOR ARRAY EXISTS +ARDSPB==1_20 ;"DISPLACED" ARRAY, DATA DOES NOT FOLLOW HEADER BUT IS BASED + ;BY POINTER IN WHAT WOULD BE FIRST DATA Q + ; NOTE: IF THIS Q HAS DATA TYPE ARRAY-POINTER, + ; IT MEANS THAT THIS ARRAY IS TO POINT TO THE SAME BLOCK OF + ; DATA AS THAT ARRAY (CALLED INDIRECT ARRAY). THUS, IF THAT + ; ARRAY IS MULTI-DIMENSIONAL + ; THE INDEXING INFO Q S MUST BE SPACED OVER. THEN ADDITIONAL + ; INDIRECTION MAY OCCUR, ETC. + ;FOLLOWING THAT IS Q GIVING Q-LENGTH OF DATA + ; THIS Q IS THE EFFECTIVE LIMIT EVEN IF INDIRECTION AS DESCRIBED + ; ABOVE HAPPENS. + ;FURTHER HAIR: + ; IF THE ARRAY IS DISPLACED AND INDIRECT AS DESCRIBED ABOVE, + ;AND THE USER CONTROL BIT IS ON IN THE INDIRECT ARRAY POINTER, + ;IT MEANS THAT THIS ARRAY HAS AN INDEX-OFFSET FROM THAT ARRAY. + ;THE INDEX OFFSET IS SPECIFIED IN ELEMENTS. WHENEVER THIS ARRAY + ;IS REFERENCED, IT IS AS IF THAT ONE WAS, BUT WITH AN INDEX + ;N HIGHER. THE INDEX OFFSET IS ALWAYS SINGLE DIMENSIONAL, AND OCCURS + ;AFTER THE REGULAR MULTIPLE DIMENSIONS HAVE BEEN MULTIPLIED OUT. + ;THE INDEX OFFSET IS STORED IN A THIRD Q. +ARYFLG==1_17 ;"FLAG" BIT. FOR STRINGS, THIS BIT, IF SET, INDICATES STRING + ; CONSISTS ENTIRELY OF "ORDINARY" PRINTING CHARACTERS. + ; THUS, ITS LENGTH CAN BE DETERMINED WITHOUT SCANNING THRU + ; BY LOOKING AT STRING LENGTH. +ARDSFT==14 ;SHIFT FOR BELOW FIELD +%ARYND==140300 ;# DIMENSIONS +ARYEXL==1_13 ;THIS BIT, IF SET, INDICATES ARRAY IS TOO LONG FOR LENGTH TO + ; FIT IN %ARYL FIELD. IN THIS CASE, THE INDEX LIMIT + ; IS STORED IN AN EXTRA Q WHICH IMMEDIATELY FOLLOWS ARRAY HEADER. +;ONE SPARE BIT... +%ARYL==1200 ;INDEX LIMIT FOR ARRAY UNLESS ARYEXL BIT IS SET. + ;FOLLOWED BY INDEX LIMIT Q IF ARYEXL BIT SET. + ;FOLLOWED BY DIM-1 Q'S INDEXING INFO, THEN DATA (UNLESS + ; DISPLACED, IN WHICH CASE THERE ARE TWO Q'S. FIRST + ; GIVES BASE OF DATA, SECOND Q-LENGTH). + +;IF ARXIB IS SET, STORAGE IMMEDIATELY BEFORE ARRAY HEADER IS +; THE "ARRAY LEADER". THE Q IMMEDIATELY BEFORE THE ARRAY HEAD +; IS A FIXNUM AND CONTAINS +%AHALD==2200 ;# OF ENTRIES IN ARRAY LEADER. THEY ARE ONE Q EACH, +; AND BEFORE THEM IS THE ARRAY-LEADER-HEADER (WITH DATA TYPE QZALDR). IT +; IS THE LOWEST Q OF THE ENTIRE (LEADER + ARRAY) COMBINATION. +;FIELDS IN ARRAY-LEADER-HEADER +%ALAHD==2200 ;DISPLACEMENT TO ARRAY HEADER + ;FOLLOWING Q'S ARE DATA OF LEADER. THE LEADER IS INDEXED + ; BACKWARDS, SO THAT THE ITEM TWO BEFORE THE + ; ARRAY HEADER HAS INDEX 0, + ; THE ONE BEFORE THAT INDEX 1, ETC. + + +;LINEAR PDL FORMATTING + +LLPFRM==4 ;LENGTH OF LINEAR PDL FRAME +;(LOAD TIME) +;--"THE ADDTIONAL INFO" (ADI)-- +; ADI MAY OPTIONALLY BE ATTACHED TO ANY CALL (I.E. ANY OF MICRO-TO-MICRO, +; MICRO-TO-MACRO, MACRO-TO-MACRO OR MACRO-TO-MICRO. +; THE INFORMATION AS DESCRIBED BELOW IS FORMATTED IDENTICALLY IN ALL THESE CASES, +; BUT THE FACT THAT IT EXISTS AT ALL IS SIGNALLED IN A MANNER UNIQUE TO THE +; TYPE OF CALL. IN ALL CASES, THE ADI IS STORED ON THE LINEAR STACK PRECEEDING +; THE ARGUMENTS, HOWEVER, ITS EXACT RELATIVE POSTION TO THE FIRST ARGUMENT +; VARIES DEPENDING ON THE TYPE OF CALL. +; FOR A MACRO-TO-MACRO CALL, THE PRSENCE OF ADI IS SIGNALLED BY THE LPADL BIT +; IN THE LPCLS Q OF THE CALL BLOCK. THE ADI IS LOCATED IMMEDIATELY +; BEFORE THE CALL BLOCK, AND IS THUS LLPFRM Q'S BEFORE THE FIRST +; ARGUMENT. +; FOR A MACRO-TO-MICRO CALL, THE LPADL BIT IS ALSO SET. ADDITIONALLY, HOWEVER, +; WHEN CONTROL IS ACTUALLY TRANSFERRED TO MICRO-CODE (AT QME1), +; THE PPBMAA BIT IN THE RETURN WORD PUSHED ON THE MICRO-CODE STACK +; IS SET. IN THIS CASE THE INFO IS LLPFRM Q'S BEFORE THE FIRST ARG. +; FOR A MICRO-TO-MACRO CALL, THE LPADL IS SET. +; THE INFO IS STORED BY CALLING A RELATED ROUTINE (MMASU, FOR EXAMPLE) +; INSTEAD OF P3ZERO IN THE NORMAL CALLING SEQUENCE. THE ADI +; IS LLPFRM Q'S BEFORE THE FIRST ARG. +; FOR A MICRO-TO-MICRO CALL, THE CALL BLOCK DOES NOT EXIST. THEREFORE, THE +; ADI STARTS IMMEDIATELY BEFORE THE FIRST ARG. THE PRESENCE OF ADI +; IS SIGNALLED BY THE PPBMIA BIT IN THE RETURN WORD ON THE MICRO-STACK. +; --NOTE-- IN THE DISCUSSION BELOW, THE OBSERVER IS CONSIDERED TO BE "STANDING" +; ON THE FIRST ARGUMENT, LOOKING BACK UP THE PDL AT THE ADI. +; THE ADI (ASSUMING IT EXISTS) CONSISTS OF 1 OR MORE PAIRS OF Q'S. +; THE FIRST Q OF EACH PAIR HAS FIELDS GIVING THE TYPE OF INFO, AND MISC FIELDS +; AS REQUIRED BY THAT TYPE. THE SECOND Q IS USUALLY A POINTER WHOSE USE IS CONTROLLED +; BY THE FIRST Q. THE "LIST" OF ADI PAIRS IS TERMINATED BY A PAIR WITH THE BUSRC OF THE +; SECOND Q OFF. THE BUSRC OF THE FIRST Q IS ALWAYS ON. (INDICATING IT IS NOT LAST.) +;ADDITIONAL NOTE: THE ADI Q'S ARE EVENTUALLY REMOVED FROM THE PDL BY A MECHANISM +; WHICH DEPENDS ON THE TYPE OF CALL. +; MACRO-TO-MACRO. DESTINATION RETURN DOES THE JOB. +; MACRO-TO-MICRO. AFTER RETURN IS MADE TO QME1, IT TRANSFERRS TO +; QMEX1 (WHICH IS PART OF DESTINATION RETURN). +; THE SAME CODE AS FOR MACRO-TO-MACRO REMOVES THE ADI. +; MICRO-TO-MACRO DESTINATION RETURN AGAIN, THIS TIME VIA QMMR1. +; MICRO-TO-MICRO THE CALL IS INVOKED BY PUSHJ P,MVCALL , WHICH +; PUSHES A RETURN TO QRAD1 ON THE MICRO-STACK +; BEFORE TRANSFERRING CONTROL TO THE CALLED FUNCTION. +; QRAD1 IS THUS REACHED WHEN THE CALLED FUNCITON RETURNS, +; AND IT FLUSHES THE INFO THEN RETURNS TO THE ORIGINAL +; CALLING FUNCTION. +; SEE DISCUSSION BELOW FOR FURTHER DETAILS. +; + +%ADITP==240300 ;GIVES TYPE INFO IF D.T. IS QZFIX + ;ERR + ADIRT==1 ;MULT RETURN INFO + .SEE %ADIRB ;FOR DOCUMENTATION ON MULTIPLE RETURN VALUE ADI + ADRPC==2 ;RESTART PC + ; RESTART PC (EITHER MACRO OR MICRO AS APPROPRIATE) TO TRANSFER TO + ; IF IT IS DECIDED TO "RETFROM" THIS CALL WHILE IT IS IN THE OPEN STATE. + ; VALUE OF THIS CALL SHOULD BE PUT ON IP BEFORE XFERRING HERE. + ;NOTE MUST ALWAYS BE USED IN CONJUNCTION WITH ADIBDL BELOW. + ADIFEX==3 ;FEXPR CALL + ;LAST ARG IS A QUOTED REST ARGUMENT, ALL OPTIONAL ARGS ARE PRESENT + ;I.E. THE ARGS COLLECTED INOT "REST" HAVE NOT BEEN SPREAD. + ;THE 2ND Q IS IGNORED. + ADILEX==4 ;LEXPR CALL + ;SIMILAR BUT DECLARES THE LAST ARG TO BE AN EVALUATED REST ARGUMENT. + ADIBDL==5 ;BINDING STACK LEVEL + ;USED IN CONJUNCTION WITH ADRPC IN IMPLEMENTING %CATCH, ETC. ALLOWS BINDS DONE + ; WITHIN THE CATCH-FRAME BUT AFTER THE CATCH-POINT TO BE UNDONE BY %THROW. + ; MUST IMMEDIATELY FOLLOW (IE BE PUSHED IMMEDIATELY BEFORE) ADRPC ADI ON STACK. + ;6 UNUSED + ADIRTU==7 ;MULT RETURN INFO, USED UP + ;MUST BE 7 FOR UCONS. + +;CALL BLOCK. THIS CALL BLOCK IS USED (WITH SOME VARIATIONS AS INDICATED BELOW) +; FOR MACRO-TO-MACRO, MACRO-TO-MICRO, AND MICRO-TO-MACRO CALLS. IT IS NOT +; PRESENT (AND IS REPLACED WITH NULL) IN A MICRO-TO-MICRO CALL. +LPCLS==-3 ;SAVED STATE TO BE RESTORED WHEN CALL RETURNS +IFN FNASW,[ + LPFNAB==20,, ;CLOSURE BINDING BLOCK PUSHED FOR THIS BLOCK +] +;IF ACTIVE FCTN IS MACRO-COMPILED (IE D.T. OF LPFEF = QZFEFP) + ;(STORED AT EXECUTION OF CALL INSTRUCTION) +; LPCPLI==10,, ;PREVIOUS LOADING MODE- LINEAR OR STACK (1) + LPADL==4,, ;ADDITIONAL INFO RELATIVE TO THIS CALL STORED IN Q(S) ABOVE +; LPCARV==2,, ;ALL ARGS STORED SO FAR EVALUATED FLAG (1) +IFN FNASW,[ + LPFNLB==2,, ;SAYS A DOWNWARD-CLOSURE STORED ON THIS CALL (THE ACTUAL FUNARG ITSELF + ; NOT THE BINDING BLOCK). + %LPFSD==200400 ;ABOVE BIT + SAVED DESTINATION. USED BY HACK TO TEST ABOVE BIT WITHOUT + ; SLOWING DOWN MAIN PATH. +] + %LPCSD==200300 ;SAVED DESTINATION)(3) + %LPCPN==101000 ;DELTA TO FEF WD OF LAST "OPENED" CALL BLOCK OR TO + ;FEF IF THIS IS FIRST ONE OF BLOCK (8) + %LPCAD==1000 ;DELTA TO CURRENT (AT TIME OF EXECUTION OF CALL INSTRUCTION) + ;ARG POINTER (8) + ;--IF THIS STACK-GROUP'S BINDINGS ARE SWAPPED OUT, %LPCAD GETS + ; MUNGED TO POINT TO FOLLOWING ACTIVE CALL BLOCK (INSTEAD OF + ; THE PREVIOUS ONE). WHEN BINDINGS ARE + ; RESWAPPED, THE %LPCAD'S GET REREVERSED. THIS IS BECAUSE + ; IT IS NECESSARY TO TRAVERSE THE PDL TOP-DOWN WHEN RESWAPPING, + ; AND WHICH WOULD BE VERY INCONVENIENT OTHERWISE.-- +;IF ACTIVE-FCTN -> MICRO-COMPILED, (D.T. LPFEF -> QZUENT) + ;(STORED BY MMCALL) + ;LPADL SAME AS ABOVE + ;%LPCPN SAME AS ABOVE + ;%LPCAD SAME AS ABOVE + + +LPEXS==-2 ;EXIT STATEWORD Q (IGNORED UNTIL STORED IN AT "LAST" ARG TIME. + ;(RETRIVED WHEN CALL RETURNS) +;IF STORED BY MACROCODE + %LPCST==200700 ;POINTER TO FIELD OF STATUS BITS BELOW + LPEPB==20,, ;BYTE BIT OF EXIT PC (ONLY IN PDP10 SIMULATOR) + L%PEPB==.BP LPEPB + LPEATI==10,, ;ATOM INDICATOR (1) + LPENLI==4,, ;NIL INDICATOR (1) + LPEBFL==2,, ;BINDS PUT ON BINDING LIST THIS BLOCK (1) + LPELMI==1,, ;LINEAR MODE INDICATOR (1) =1 + LPEALM==400000 ;ARG LOADING MODE (0 STACK, 1 FRAME) + LPEEAF==200000 ;1-> NON EVAL ARG HAS BEEN STORED + ;ABOVE BITS ARE AS THEY ARE IN IPC + %LPEPC==1700 ;EXIT PC RELATIVE TO FEF ORG (Q'S COMP) (15) + ;ON REAL MACHINE THIS IS IN 16-BIT WORDS (PC-2*FEFORG) +;IF STORED BY MICROCODE + ;PC STATUS NOT MEANINGFUL IN THIS CASE + %LPMPC==2200 ;MICRO RETURN PC + +LPENS==-1 ;ENTRY STATEWORD Q (APPLIES TO CURRENTLY RUNNING FCTN, NOT ONE BEING CALLED) + ;STORED AT ENTRY TIME AND LEFT UNCHANGED +; LPESF==20,, ;SPECIAL FLAG (1) - SPECIAL VARIABLES BOUND THIS BLOCK +; ; *OBSOLETE* NOW THAT ALL S.V. BINDINGS SAVED ON BINDING PDL. + LPEBDR==10,, ;BINDING DIRECTION THIS BLOCK (1) + LPEEPH==4,, ;ENVIRONMENT POINTER POINTS HERE (1) + %LPENA==100600 ;# ARGS ACTUALLY SUPPLIED + ;IF FCTN RUNNING THIS FRAME IS MACRO-COMPILED + %LPLBO==1000 ;ORIGIN OF LOCAL BLOCK IN Q'S FROM ARG PNTR (8) + ;(NORMALLY STORED IN QLOCO) + ;IF FCTN RUNNING THIS FRAME IS MICRO-COMPILED + %LPNWP==1000 ;# Q'S TO XFER BACK TO MICRO-STACK FROM LINEAR BIND STACK +;-> "ARG POINTER" AP POINTS HERE. +LPFEF==0 ;POINTER TO FEF TO BE CALLED (ARG POINTER POINTS HERE WHEN RUNNING) +;ARG 1 +;ARG 2 +;... +;LOCAL VARIABLES BLOCK +LPLOFF==1 ;INITIAL OFFSET OF LOCAL BLOCK FROM ARG POINTER IN LINEAR PDL MODE + ;TO THIS ADD THE NUMBER OF ARGUMENTS PUSHED +;LOCAL PDL PDL + +;ARG POINTER POINTS TO Q CONTAINING FEF POINTER OF FUNCTION NOW RUNNING +;PDL PNTR BUMPED AS NECESSARY FOR LOCAL VARS + + +;PDL FORMAT (FRAME MODE) **COMPLETELY OBSOLETE** + +QLRETA==0 ;WD0 BYTE 1 -> FRMPDL IF PDL FRAME, FRMARG IF HOLDING ARGS + ;WD1 RET ADR REL TO FE ORG +QLENT==1 ;PNTR TO FEF OF FUNCTION RUNNING HERE +QLCL==2 ;PNTR TO PREVIOUS CONTEXT - CONTROL +QLBL==3 ;PNTR TO PREVIOUS CONTEXT - BINDINGS +QLMISC==4 ;WD0 BYTE 1 RANDOM INFO AS IN LINEAR FORM BYTE 1 OF PC WORD + ;WD1 BYTE 0 MAX FRAME ADR USED (INITIALLY MAXPDLLVL+LLOCBLOCK+QLVARS) + ;EXPANDED BY BIND BLOCKS IN Q'S + ;WD1 BYTE 1 ORG OF LOCAL BLOCK (IN Q'S FROM PDL FRAME ORG) +QLEXT==5 ;PNTR TO EXTENSION PAGE OR NIL +QLPDL==6 ;LOCAL PDL PNTR +QLBNDD==7 ;POINTER TO BLOCKS CREATED WITH BIND FEATURE. EA + ;OF THEM IS OF THE FORM + ;Q0 CHAIN PNTR TO NEXT OR NIL + ;Q1 BOUND LOCN + ;Q2 PREVIOUS CONTENTS +QLVARS==10 +;FOLLOWED BY ARGS + ;IN ARGS, USRC=1 -> THIS ARG "NOT EVALUATED" +;FOLLOWED BY LOCAL BLOCK (IF REST VAR EXISTS, IT IS FIRST IN LOCAL BLOCK) +;FOLLOWED BY PDL-PDL +;FOLLOWED (POSSIBLY) BY BINDING BLOCK AREA + +;THE LINEAR-BINDING PDL +; THE LINEAR BINDING PDL IS AN AUXILLARY PDL SIMILAR TO THE SPECIAL PDL IN PDP-10 +;LISP. HOWEVER, IN ADDITION TO HOLDING PREVIOUS BINDINGS OF SPECIAL VARIABLES (WHICH +;WORK THE SAME AS IN MACLISP) IT IS USED FOR OTHER PURPOSES AS WELL. +; WHEN A MICRO-TO-MACRO CALL IS MADE, THE CONTENTS OF THE MICRO-STACK ARE +;TRANSFERRED TO THE LINEAR BINDING PDL. THIS IS NECESSARY BECAUSE OF THE +;HARDWARE LIMITED LENGTH OF THE MICRO-STACK. +;-- THE LINEAR BINDING PDL IS ALSO USED TO HOLD CERTAIN INFORMATION ACROSS +;-- MESA-TO-XXX FUNCTION CALLS. THIS IS PROBABLY A CROCK, AND MAY BE FIXED UP LATER. +; TWO DIFFERENT SORTS OF BLOCKS ARE CONNECTED WITH THE FUNARG (CLOSURE) FEATURE. +; (1) A CLOSURE BINDING BLOCK SIMILAR TO AN ORDINARY BINDING BLOCK. IN FACT, A +; COMPLETELY ORDINARY BINDING BLOCK COULD BE USED. THE MOTOVATION FOR THE DIFFERENCE +; IS MERELY TO RETAIN A POINTER TO THE CLOSURE ITSELF FOR DEBUGGING PURPOSES. +; THIS POINTER IS PUSHED AS THE FIRST Q OF THE BLOCK, AND IGNORED EXCEPT FOR DEBUGGING. +; IT IS DISTINGUISHED BY ITS DATA-TYPE OF QZCLOS. +; (2) A DOWNWARD-CLOSURE BLOCK. THE PURPOSE IS TO ALLOW CLOSURE HACKING WITHOUT CONSING. +; OF COURSE, SINCE L-B-P STORAGE IS USED INSTEAD, THIS CAN WORK ONLY IN THE +; DOWNWARD (IE > DEPTH OF RECURSION) DIRECTION. +; THE BLOCK IS A LIST THE FIRST ELEMENT OF WHICH IS THE FUNCTIONAL AND THE REST +; OF WHICH IS THE CLOSED LIST. TWO OR MORE DOWNWARD-CLOSURE BLOCKS MAY BE +; CONCATENATED IF THEY ARE BOTH TO BE PASSED AS ARGUMENTS TO THE SAME FUNCTION +; (SEE THE LPXXX BIT). THIS IS DONE SIMPLY BY CLEARING (OR NOT SETTING IN THE FIRST +; PLACE) THE BUSRC BIT IN THE SECOND BLOCK. + +;--NOTE: IN THE FOLLOWING DISCUSSION, "FIRST" IS 0(QLBNDP), "SECOND" IS -1(QLBNDP),ETC +; THE LINEAR BINDING PDL IS BLOCK ORIENTED, WITH THE BLOCKS BEING DELIMITED +;BY THE USRC BIT BEING SET IN THE LAST Q (IE THE FIRST ONE PUSHED IN EACH BLOCK.) +;THE DATA-TYPE OF THE FIRST Q OF EACH BLOCK (IE THE LAST ONE PUSHED) +;INDICATES WHAT TYPE OF BLOCK IT IS. THUS, NORMALLY THE DATA TYPE OF 0(QLBNDP) +;INDICATES WHAT TYPE OF BLOCK IS AT THE HEAD OF THE STACK. MEANINGFUL TYPES ARE: +; LOCATIVE, ON REAL MACHINE MAY BE ANY OF QZXLIS QZXSTR QZXSYM. +; IN LMI, ITS ALWAYS QZXSYM. +; NORMAL VARIABLE BINDING BLOCK, PNTR POINTS TO BOUND LOCN +; NEXT Q GIVES PREV CONTENTS. +; THIS PAIRING MAY BE REPEATED ANY NUMBER OF TIMES. +;-- IN THE EVEN POSITION, (WHERE LOCATIVE NORMALLY IS) MAY ALSO APPEAR A CLOSURE POINTER +;-- (QZCLOS). THIS FUNARG POINTER IS RETAINED FOR DEBUGGING PURPOSES AND SHOULD +;-- NORMALLY BE SKIPPED OVER. SUCH A Q SHOULD ALWAYS TERMINATE THE BLOCK +;-- (IE HAVE ITS BUSRC SET). +; QZFIX TRANSFERRED P STACK (DUE TO MICRO-MACRO CALL) +; ENTIRE BLOCK SHOULD BE QZFIX ES TO BE XFERRED. +; PDL-FUNARG-BLOCK +;-- QZMESA MESA-LEAVE BLOCK, PNTR POINTS TO MESA-FEF LEFT +;-- BLOCK 2 Q S LONG +;-- SECOND Q HAS SAVED MESA-PC + +; QZFIX AND QZMESA BLOCKS ARE PUT ON IN A SINGLE OPERATION. THUS, NORMALLY THERE +;IS NO POSSIBILITY OF A PARTIALLY PUT ON BLOCK. VARIABLE BINDING BLOCKS, ON THE OTHER HAND, +;ARE PUT ON A PAIR AT A TIME. THUS, AT ANY TIME, A BLOCK MAY BE "OPEN" (IE HAVING AT +;LEAST ONE PAIR ALREADY), OR NOT. WHEN MACRO-COMPILED FUNCTIONS ARE RUNNING, +;THE QBBFL BIT IN THE PC STATUS, IF SET, INDICATES +;A BINDING BLOCK IS CURRENTLY OPEN. WHEN MICRO-COMPILED FUNCTIONS CALL EACH OTHER, +;PROVISION MUST BE MADE FOR EACH TO OPEN ITS OWN BINDING BLOCK. THIS IS DONE +;VIA THE PPBSPC BIT ON THE MICRO-STACK. IF THIS BIT IS SET IN AN USTACK ENTRY, +;THE FUNCTION WHICH WILL RETURN BY POPJ ING THRU THAT ENTRY HAS AN OPEN BINDING BLOCK. +;FOR MICRO-COMPILED FUNCTIONS, THE QBBFL BIT IS USED ONLY FOR LOCAL COMMUNICATION +;TO THE LOW LEVEL BINDING PUSHING ROUTINES AND HAS NO "GLOBAL" SIGNIFICANCE. + +; THE VARIABLE QLBNDP IS THE PDL POINTER TO THE LINEAR-BINDING PDL. IT FOLLOWS THE +;NORMAL CONVENTION AND POINTS AT THE LAST Q WHICH IS CURRENTLY PART OF THE PDL. + +; TRAVERSING THE PDL. +;IN ORDER TO IMPLEMENT THE VARIABLE SWAPPING FEATURE ON STACK-GROUP ENTRY/EXIT, +;IT IS NECCESARY TO BE ABLE TO TRAVERSE THE L-B-P IN EITHER DIRECTION AND IDENTIFY +;WHICH ARE THE VARIABLE BINDING BLOCKS, ETC. WHEN SCANNING UP THE PDL (TOWARD LESS RECENTLY +;PUSHED ITEMS) THERE IS NO PROBLEM. HOWEVER, WHEN SCANNING DOWN, IT WOULD REQUIRE +;TWO PASSES TO FIRST LOCATE THE END OF THE BLOCK, THEN IF IT WAS LOCATIVE, SWAP +;THE BINDINGS. ALTHOUGH THIS WOULD NOT BE EXTREMELY PROHIBITIVE, IT SOMEWHAT OF +;A DRAG. ACCORDINGLY, IT IS DECLARED TO BE SUFFICIENT THAT ONE MERELY CHECK +;THE 2ND WORD OF THE BLOCK TO VERIFY THAT A) ITS BUSRC IS NOT ON AND 2) ITS +;DATA TYPE IS DTP-LOCATIVE (ANY OF THE THREE). + +; --THE DISCUSSION BELOW IS MOSTLY OBSOLETE-- GRUBBLING OVER THE PDL. .. +; A PARTICULAR PROBLEM IS TRAVERSING THE L-B-P IN THE REVERSE DIRECTION AS WHEN +;UNDOING A VARIABLE SWAP. WHEN SEVERAL MICRO-COMPILED FUNCTIONS WHICH HAVE +;CALLED EACH OTHER WITH MICRO-MICRO CALLS HAVE OPEN BINDING BLOCKS, THE PICTURE +;AS SEEN FROM THE BOTTOM OF THE PDL IS BINDING BLOCKS FOLLOWED BY AN TRANSFERRED +;MICRO-STACK WITH PPBSPC BITS SET. THE PROBLEM IS, WE DONT KNOW BEFOREHAND. +;WE DO KNOW, HOWEVER, THAT MUST BE ZERO IF THE %LPNWP FIELD OF THE IP-STACK +;FRAME IS 0. BEYOND THIS, EVERY ROUTINE WHICH SPACES PAST SUCH A BLOCK +;SHOULD MAKE AN ERROR CHECK TO MAKE SURE THINGS COME OUT RIGHT. + +; BLOCKS ON THE LINEAR PDL MATCH UP WITH MAIN PDL BLOCKS. BASICALLY, ONE CRAWLS +;UP THE MAIN STACK, CHECKING EACH FRAME FOR INDICATIONS THAT A BINDING PDL FRAME +;"CORRESPONDS" TO THE MAIN PDL FRAME. THE TOP FRAME "CURRENTLY RUNNING" IS SOMEWHAT +; OF A SPECIAL CASE. + +;STACK-GROUPS -- INTRODUCTION AND OVERVIEW +; A STACK-GROUP IS THE LOGICAL UNIT OF INFORMATION WHICH CORRESPONDS TO "PROCESS" +;IN LISP-MACHINE LISP. INTERRUPT CONTEXT SWITCHING, CO-ROUTINES AND GENERATORS +;AMONG OTHER THINGS ARE FACILITATED BY USE OF STACK-GROUPS. AT ALL TIMES, +;EXACTLY ONE STACK-GROUP IS ACTIVE. THIS CORRESPONDS TO THE PROCESS CURRENTLY +;BEING RUN IN A TIME-SHARING SYSTEM. +; PHYSICALLY, A STACK-GROUP IS REPRESENTED BY A POINTER OF TYPE STACK-GROUP. +;THE STACK-GROUP POINTER POINTS AT AN ARRAY-HEADER AND RELATED STRUCTURE +;EXACTLY AS WOULD AN ARRAY-POINTER. IN FACT, WHEN IT IS DESIRED TO "LOOK INSIDE" +;THE STACK-GROUP, ONE MUST SWITCH THE DATA-TYPE TO ARRAY-POINTER. (THE PURPOSE +;IN HAVING A DIFFERENT DATA-TYPE NORMALLY IS TO ALLOW A DIFFERENT INTERPRETATION +;IN FUNCTIONAL CONTEXT. THIS IS DISCUSSED BELOW.) +;THIS ARRAY ALSO HAS A SPECIAL TYPE CODE, ART-STACK-GROUP. (THE PURPOSE HERE IS +;TO GIVE "DATA-INTEGRITY" TO THE STRUCTURE. THAT IS, IT ASSURES ANY ROUTINE WILL +;ALWAYS BE ABLE TO DISTINGUISH A STACK-GROUP FROM A RANDOM ARRAY). +;THE DATA SECTION OF THIS ARRAY CONTAINS THE LINEAR-PDL OF THE STACK-GROUP, +;WHILE THE ARRAY-LEADER (SOMETIMES CALLED THE PDL-HEAD) CONTAINS OTHER +;INFORMATION INCLUDING A POINTER TO +;ANOTHER ARRAY WHICH HOLDS THE LINEAR-BINDING-PDL FOR THE STACK-GROUP. +;(THIS ARRAY IS OF TYPE ART-SPECIAL-PDL). +; OTHER INFORMATION STORED IN THE PDL-HEAD INCLUDES THE PDL-POINTER S +;FOR BOTH PDL S (THESE STORED BACK HERE WHEN THE STACK-GROUP IS INACTIVE). +; STILL OTHER INFORMATION STORED IN THE PDL-HEAD IS SEMI-REDUNDANT, +;BUT IMPROVES THE EFFICIENCY OF THE STACK-GROUP SWITCHING. (VARIOUS LIMITS ETC) +; ALSO STORED IN THE PDL-HEAD ARE CERTAIN MICRO-CODE VARIABLES WHICH MUST +;BE PRESERVED OVER MACRO-INSTRUCTION BOUNDARIES (AND THUS OVER "CLEAN" TRAPS). + +; THE MOTOVATION IN ASSIGNING A SPECIAL ARRAY-TYPE CODE, ART-STACK-GROUP +;INSTEAD OF USING AN EXISTING ON SUCH AS ART-Q IS CLEANLINESS, NOT ABSOLUTE +;NECESSITY. FOR EXAMPLE, THIS WAY THE GARBAGE COLLECTOR CAN CONVIENTLY KNOW +;TO MARK ONLY THE ACTIVE SECTION OF THE PDL, NOT THE ENTIRE ARRAY, ETC. +;FOR ALL "LOW LEVEL" PURPOSES, AN ART-STACK-GROUP ARRAY IS IDENTICAL TO AN +;ART-Q ARRAY (THIS IS SOMEWHAT SIMILAR TO THE POINT IN DISTINGUISHING AN +;ART-STRING ARRAY FROM AN ART-8-BIT ARRAY). +; IF AN ART-STACK-GROUP ARRAY IS MOVED, THE GC +;MUST BE AWARE OF THE POSSIBILTY OF THE EXISTANCE OF POINTERS DIRECTLY +;INTO THE ARRAY. + +;STACK-HEADER (THE STACK HEADER IS THE ARRAY-LEADER OF AN ART-STACK-GROUP ARRAY). +; (Q 'S BELOW ARE LISTED IN ORDER OF ARRAY-LEADER INDEX) VALUES ARE +; SUCH AS TO REFERENCE THE GIVEN Q GIVEN THE STACK-GROUP POINTER (IE THE +; ARRAY POINTER TO THE ART-STACK-GROUP ARRAY). + +;NOTE THAT DEFAULT-CONS-AREA, ETC CAN BE CHANGED AS A FUNCTION OF STACK-GROUP +;BY USING SPECIAL-VARIABLES BOUND IN THE STACK-GROUP. ERROR AND INVOKE +;HANDLERS CAN BE CHANGED IN THIS WAY TOO. + +SGNAME==-2 ;SG-NAME ;THE "NAME" OF THE STACK-GROUP. NOT USED BY + ; SYSTEM ITSELF, BUT HELPS USER FIGURE OUT + ; WHICH FROB IS RUNNING FOR DEBUGGING, ETC. +SGRA== -3 ;SG-REG-PDL-ARRAY ;POINTS TO DATA ARRAY FOR MAIN PDL +SGBA== -4 ;SG-LINEAR-BINDING-ARRAY ;POINTS TO DATA ARRAY FOR LINEAR BINDING PDL +SGIFCT==-5 ;SG-INITIAL-FCTN-INDEX ;POSITION IN SGBA OF TOPMOST FUNCTION POINTER + ; CELL. THIS IS NORMALLY 3, BUT MAY DIFFER IF + ; INITIAL CALL HAS ADI. +SGUCOD==-6 ;SG-UCODE ;USED IN AN UNSPECIFIED AT THIS TIME MANNER + ; TO INDICATE WHICH UCODE PACKAGES MUST BE + ; LOADED, ETC FOR THIS STACK-GROUP TO WIN. +;THE FOLLOWING Q S "HOLD STATE" ACROSS MACRO-INSTRUCTION BOUNDARIES + +;THE FOLLOWING Q S HAVE TO DO WITH CALL-STACK-GROUP, ETC. SEE DISCUSSION BELOW. + +SGSTAT==-7 ;SG-STATE + %SGSST==000600 ;1.1-1.6 STATE + SGNERR== 0 ; ERROR + SGNACT== 1 ; ACTIVE, + SGNINT== 2 ; INTERRUPTED, + SGNIND== 3 ; INTERRUPTED-DIRTY, + SGNINC== 4 ; INTERRUPTED-CLEANSED, (SAME AS INTERRUPTED, BUT GOT HERE + ; BY MUNGE FROM DIRTY STATE) + SGNAER== 5 ; AWAITING-ERROR-RECOVERY, + SGNAED== 6 ; AWAITING-ERROR-RECOVERY-DIRTY, + SGNAEC== 7 ; AWAITING-ERROR-RECOVERY-CLEANSED, + SGNART==10 ; AWAITING-RETURN, + SGNACL==11 ; AWAITING-CALL, + SGNAIC==12 ; AWAITING-INITIAL-CALL, (SAYS STACK CONTAINS BARE CALL BLOCK + ; AND ARGS). THESE ARE ACTIVATED WHEN STACK-GROUP IS CALLED. + SGNAGC==13 ; AWAITING-GC. + SGNEXH==14 ; EXHAUSTED. HAPPENS IF STACK-GROUP "RETURNS OFF THE TOP", + ; NORMAL RETURN OCCURS, BUT ITS AN ERROR TO CALL AGAIN. + %SGSPS==060600 ;1.7-2.3 PREVIOUS STATE (FOR DEBUGGING, WHAT + ; STATE WAS BEFORE IT WAS CHANGED TO WHAT IS IS NOW. + ;REST FLAGS + SGSHLT==20,, ;HALT IF ATTEMPT TO ERR OUT OF THIS STACK-GROUP + SGSSVD==10,, ;IF 1, S.V. S THIS STACK-GROUP SWAPPED-OUT (NON-RUNNABLE STATE) + SGSSWI==04,, ;IF 1, A S.V. SWAP IS IN PROGRESS. THIS SHOULD NEVER BE THE + ; CASE UNLESS IN THE MIDDLE OF THE SWAPPER!! IF SOME ERROR + ; OCCURS AND THE SWAP IS NOT COMPLETED, THIS BIT WILL BE LEFT + ; ON. IN THAT CASE, THE STACK-GROUP IS SCREWWED BEYOND ANY + ; POSSIBILITY OF RECOVERY. + SGSNSP==02,, ;THIS STACK-GROUP BINDS NO SPECIALS AT ALL (ERR IF IT TRIES). + ; (IF THIS ON, DONT HAVE TO THINK ABOUT SWAPPING S.V. S EVER) + SGSSTO==01,, ;IF 1, SWAP S.V. ON TRAP-OUT + SGSSCO==00,,400000 ;IF 1, SWAP S.V. ON CALL-OUT + SGSSCI==00,,200000 ;IF 1, SWAP S.V. S OF S.G. THAT IS PREV TO ME + ; WHEN ABOUT TO ENTER ME + +SGPREV==-10 ;SG-PREVIOUS-STACK-GROUP ;POINTER TO SG WHICH CALLED ME OR + ; WAS INTERRUPTED "FOR" ME + ;THE BELOW TWO POINTERS MAKE IT FAIRLY EASY FOR A STACK-GROUP TO ACCESS + ;ITS ARGUMENTS, IE, ARGUMENTS TO THE DTP-STACK-GROUP INVOCATION THAT + ;ACTIVATED THIS STACK-GROUP. +SGARGP==-11 ;SG-CALLING-ARGS-POINTER ;POINTER TO ARG-BLOCK WHICH LAST CALLED ME +SGARGN==-12 ;SG-CALLING-ARGS-NUMBER ;NUMBER OF ARGS IN ABOVE BLOCK. + +SGFOLL==-13 ;SG-FOLLOWING-STACK-GROUP ;POINTER TO SG I CALLED OR WAS INTERRUPTED TO + ; RUN. +;"DYNAMIC" STATE STARTS HERE +SGPDLP==-14 ;SG-PDL-PDL-POINTER ;PDL POINTER TO LINEAR-PDL + ;STORED AS FIXNUM INDEX INTO STORAGE-ARRAY +SGBP== -15 ;SG-LB-PDL-POINTER ;PDL POINTER TO LINEAR-BINDING-PDL + ;STORED AS FIXNUM OFFSET FROM SG-LINEAR-BINDING-ARRAY +SGAP== -16 ;SG-AP ;POINTS TO CURRENTLY RUNNING FRAME + ;STORED AS FIXNUM INDEX INTO STORAGE-ARRAY +SGIPM== -17 ;SG-IPMARK ;POINTS TO CURRENTLY OPEN FRAME + ;STORED AS FIXNUM INDEX INTO STORAGE-ARRAY +SGUSTK==-20 ;SG-U-STACK-QS ;# OF QS TRANSFERRED TO U-STACK ON SWITCHOUT. +SGARYH==-21 ;SG-SAVED-QLARYH ;SAVED QLARYH, (LAST ARY POINTER REF'ED) +SGARYL==-22 ;SG-SAVED-QLARYL ;SAVED QLARYL, (LAST ARY ELEMENT REF'ED) +SGINDS==-23 ;SG-SAVED-INDICATORS ;PC FLAGS, CONDITION CODE, ETC + +SGAAK== -24 ;M-K ON REAL MACHINE +SGAAS== -25 ;THE FOLLOWING ARE SAVED AC'S (AC NAME IS PREFIXED BY SGAA) +SGAAJ== -26 ;THESE REGISTERS ALL ARE ASSUMED TO HAVE WELL FORMED CONTENTS +SGAAI== -27 ;COMPLETE WITH DATA-TYPES, ETC WITH THE EXECPTION THAT IT IS +SGAAQ== -30 ;OK TO HAVE A DATA-TYPE OF 0 (NORMALLY DTP-TRAP). +SGAAR== -31 +SGAAT== -32 +SGAAE== -33 +SGAAD== -34 +SGAAC== -35 +SGAAB== -36 +SGAAA== -37 +SGAAZR==-40 +SGSVMA==-41 ;SAVED VMA ON REAL MACHINE. READ-MEMORY DATA REG IS CONSIDERED + ;RETREVABLE BY DOING A READ CYCLE. WRITE-MEMORY-DATA REG IS CONSIDERED + ;TO BE WRITE-ONLY +SGSPHS==-42 ;SAVED PDL-BUFFER PHASE ON REAL MACHINE. THIS IS OCTAL VALUE OF PP AT + ; TIME OF SWITCHOUT. IF ANYBODY SIMULATES PUSHES OR POPS ON THIS STACK + ; GROUP, THIS VARIABLE SHOULD BE AOS ED OR SOS ED APPROPRIATELY. + + +;----NOTE--- THE FOLLOWING STUFF IS NOT IN ------ +;CLEAN TRAPS VERSUS DIRTY TRAPS ... + +; THE OPERATION OF "RUNNING" A PROCESS CONSISTS OF ADVANCING IT +;BY INDIVISIBLE DESCRETE AMOUNTS (CALLED TICKS IN THIS DISCUSSION). ON THE +;REAL MACHINE TICKS ARE MICRO-INSTRUCTION EXECUTION CYCLES, IN THE LMI THEY +;ARE PDP-10 INSTRUCTIONS. AT EACH TICK, ONE CAN THINK OF "THE STATE INFORMATION" +;(HEREIN CALLED THE INFO) WHICH CONSISTS OF THE SET OF ALL THOSE BITS THE STATE +;OF WHICH WILL "AFFECT" THE FUTURE COURSE OF THE PROCESS. OF COURSE IN PRINCIPLE +;IT IS IMPOSSIBLE TO EVER "SAVE" THE INFO OR EVEN DEFINE IT EXACTLY SINCE IT +;MAY INCLUDE THE CURRENT TIME, CHARACTERS THAT HAVENT BEEN TYPED YET, ETC ETC. +;NONETHELESS, BY MEANS OF SUITABLE RESTRICTIONS AND ASSUMPTIONS AND AN APPROPRIATE +;DEFINITION OF "AFFECT", WE CONCEPTUALIZE (IF NOT DEFINE) THE INFO CONCEPT AND +;SPEAK MEANINGFULLY OF "SAVING" IT. WE ARE NOT, HOWEVER, ENTIRELY DOGMATIC +;ON THIS POINT IN AN AUTOMATA THEORY SORT OF WAY. IN OTHER WORDS, WE RECOGNIZE +;SOMETHING CALLED "ACCEPTABLE PROGRAMMING PRACTICE" AND THE POSSIBILITY THAT PROGRAMS +;NOT CODED IN ACCORDANCE WITH IT MAY DEPEND ON INFLUENCES EXTERNAL TO THE INFO. +;THE FREQUENTLY HEARD "THAT DESERVES TO LOSE" COMMENT IS A STATEMENT THAT ACCEPTABLE +;PROGRAMMING PRACTICE HAS BEEN VIOLATED, AND WE REFUSE TO CONCERN OURSELVES WITH +;THE CONSEQUENCES (OR FREQUENTLY, THE DETAILED CONSEQUENCES BEYOND CERTAIN IMPORTANT +;ONES. "YOU CAN'T CRASH THE SYSTEM BY DOING THAT" OR "THE DISK DOESNT GET GARBAGED", +;ETC). +; IN ADDITION TO THE CONCEPT OF INFO FOR THE SYSTEM AS A WHOLE, WE ALSO +;FREQUENTLY CONCEPTUALIZE THE INFO AS IT RELATES TO ONE OF THE PARTS OF THE SYSTEM. +;(A SUBROUTINE, PROCESS, OR PIECE OF HARDWARE FOR EXAMPLE). +; HERE WE USUALLY HAVE IN MIND A LOOSELY STRUCTURED HIERARCHY OF TICKS AND +;MACRO-TICKS. WE CONCEPTUALIZE THAT IF THE INFO IS SAVED AT ANY TICK AND LATER RESTORED, +;THE EFFECT IS "INVISIBLE" AT THE MACRO-TICK LEVEL. HOWEVER, IN APPLYING THIS +;CONCEPT TO PARTS OF A SYSTEM, WE HAVE INTRODUCED SEVERAL PROBLEMS, NOTABLY +;INFO-FORK S AND TIMING-ERROR S. +; AN INFO-FORK COULD OCCUR WHEN THERE IS A PARTIAL OVERLAP +;IN THE MAKEUP OF THE INFO FOR TWO SUBPARTS OF THE SYSTEM. WE MIGHT FIND WE HAD +;SUCCESSFULLY SAVED THE INFO FOR EACH OF THE PARTS, BUT THEY WERE "INCOMPATIBLE" +;IN SOME SENSE. THE POSSIBILITY OF THIS HAPPENING DEPENDS CRITICALLY ON THE +;CONVENTION USED IN CONCEPTUALIZING THE INFO. FOR EXAMPLE, CONSIDER A FREE STORAGE +;POINTER. IF THE INFO INCLUDES ALL IS LIKELY TO +;BE WELL, BUT IF IT INCLUDES , WE WILL BE UNABLE TO DO ANYTHING WITHOUT +;MAKING AN INFO-FORK. IN PRACTICE, INFO-FORK S ARE USUALLY FATAL TO THE +;"PROPER" OPERATION OF THE SYSTEM WHEN ONLY MACHINES ARE INVOLVED, AND ARE VERY PAINFUL +;TO STRAIGHTEN OUT WHEN HUMANS [OR PERHAPS INTELLIGENT BEINGS] ARE INVOLVED. +; WE DEFER FOR THE MOMENT THE QUESTION OF WHAT PRIMITIVES ARE NECESSARY +;TO DESCRIBE A WORKABLE CONVENTION OF INFO, BUT PROCEED ON THE ASSUMPTION THAT SUCH +;EXISTS. GIVEN SUCH A CONVENTION, WE CERTAINLY HAVE NO ASSURANCE THAT THE INFO +;AT EACH TICK WILL IN FACT BE EXPRESSIBLE IN TERMS OF THE CONVENTION (UNLESS THE +;CONVENTION IS THE SAVE-ALL-BITS ONE, BUT THAT ONE IS COMPETELY UNACCEPTABLY +;SUBJECT TO INFO-FORK S). +; IN THE LISP MACHINE, INFO SAVING AND RESTORING OCCURS IN CONNECTION WITH +;STACK-GROUP SWITCHES. WHEN SWITCHING AWAY FROM A STACK-GROUP, THE FIRST STEP +;IS TO SAVE THE INFO FOR THE OLD STACK-GROUP. THERE ARE TWO BASIC CASES HERE, +;EITHER THE INFO WILL FIT IN THE PDL-HEAD, OR IT WONT AND USE OF THE DIRTY-TRAP +;PAGE IS NECESSARY. IF THE DIRTY-TRAP PAGE IS USED, THE SAVED STATE MUST BE +;SANITIZED IF IT IS EVER TO BE RESUMED. FURTHERMORE, CERTAIN SYSTEM-WIDE OPERATIONS +;(NOTABLY STORAGE-REORGANIZATION) COMPLETELY INVALIDATE THE INFO HELD BY ANY +;UNSANITIZED PDL-HEAD S IN EXISTANCE AT THE TIME THEY ARE PERFORMED. EVEN A REGULAR +;NON-RELOCATING GC CAN LEAD TO GROSS LOSSAGE IF IT IS PERFORMED WHEN THE ONLY +;POINTER TO AN ACTIVE DATA STRUCTURE IS IN AN UNSANITIZED PDL-HEAD. +;AS A RESULT, IT IS NORMALLY CONSIDERED GOOD PRACTICE TO SANITIZE IMMEDIATELY +;AFTER USING THE DIRTY-PAGE, OMMITING THIS ONLY IN THE CASE OF INTERRUPT HANDLERS +;WHICH ARE BOTH VERY SIMPLE AND VERY FREQUENTLY USED. IN THE LATTER CASE, +;CARE MUST BE USED TO ASSURE THAT NO GC'S, ETC CAN POSSIBLY OCCUR WITH A PDL-HEAD +;IN AN UNSANITIZED CONDITION. + +; IN PRACTICE, WE ABANDON THE GOAL OF BEING ABLE TO SAVE THE INFO AT ANY TICK, +;CONCENTRATING INSTEAD ON +; 1) BEING ABLE TO DETERMINE WHETHER THE INFO CAN IN FACT BE SAVED ON ANY +; PARTICULAR TICK. IDENTIFY THOSE ON WHICH IT CAN AS CLEAN-TICK S. +; 2) ATTEMPTING TO ASSURE THAT CLEAN-TICK S OCCUR WITH ACCEPTABLE FREQUENCY. +; 3) PROVIDING A MECHANISM WHEREBY IF AN ATTEMPT IS MADE TO SAVE THE INFO +; ON A DIRTY-TICK, WE CAN EITHER PROCEED TO THE NEXT CLEAN-TICK, OR +; REVERT TO THE PREVIOUS CLEAN-TICK AS APPROPRIATE. + +; IN DEFINING THE INFO, WE ALSO FACE THE PRACTICAL PROBLEM THAT THE SIZE +;(IN BITS) OF THE INFO IS BY NO MEANS CONSTANT FROM ONE TICK TO ANOTHER. +;INSOFAR AS POSSIBLE, WE WISH TO DEFINE THE INFO SO THAT AS FEW BITS AS POSSIBLE +;ARE SAVED, AND MAY BE WILLING TO TOLERATE A SOMEWHAT LESS FREQUENT OCCURANCE +;OF CLEAN-TICK S AS A RESULT. + +; IN THE SYSTEM AS A WHOLE SEVERAL KINDS OF TICKS EXIST, SOME OF WHICH WE LIST BELOW: +; T1) MICRO-INSTRUCTIONS +; T1A) REFERENCES TO READ-MEMORY-DATA +; T2) INITIATIONS OF MEMORY-CYCLES VMA-START-READ, ETC +; T3) EXECUTIONS OF MACRO-INSTRUCTIONS +; T4) MANIPULATIONS OF SYSTEM DATA BASES (FREE STORAGE LISTS, ETC) +; T5) MANIPULATIONS OF USER DATA BASES (NECESSARILY, BY USER DEFINED FUNCTIONS). +; T6) MACRO-CODE CALL-RETURN BOUNDARIES + +; THESE KINDS OF TICKS FORM AN IMPERFECT HIERARCHY. FOR EXAMPLE, ALL OTHER +;TICKS MUST SIMULTANEOUSLY BE T1 S, BUT T4 S AND T5 S CAN OCCUR IN AN INTERSPERCED +;MANNER. +; WE CHOOSE AS OUR "BASIC" INFO CONVENTION EXECUTION OF MACRO-INSTRUCTION, T3. +;THIS IS TO SAY, OUR BASIC INFO SAVING DATASTRUCTURE, THE STACK-HEAD, PROVIDES +;STORAGE SLOTS DIRECTLY TO STORE THOSE QUANTITIES WHICH CARRY OVER BETWEEN +;MACRO INSTRUCTIONS. + +;THE PROBLEM AS ENCOUNTERED IN PRACTICE. +; SUPPOSE STACK-GROUP G1 IS CURRENTLY ACTIVE, AND A "REQUEST" IS +;RECEIVED TO RUN G2. WE WISH TO DETERMINE IF THE CURRENT TICK +;IS SUFFICENTLY CLEAN TO EFFECT THE SWITCH, AND IF NOT, DETERMINE WHICH +;OF OUR VARIOUS TRICKS WE NEED TO USE TO "OBTAIN" A CLEAN-ENUF TICK. + +;---END OF RANDOM BULL ABOUT STUFF NOT IN------- + +;INTERNAL V.S. EXTERNAL VALUE-CELLS. (DAVE MOON SUGGESTED THESE NAMES). +; THE VALUE CELL WHICH IS PART OF THE 4-Q ATOM BLOCK IS CALLED THE +; INTERNAL VALUE CELL. IN THE CASE OF A LOCAL VARIABLE, ITS SLOT ON THE +; PDL SERVES AS ITS INTERNAL VALUE CELL. EACH LOGICAL VARIABLE ALWAYS HAS +; EXACTLY ONE INTERNAL VALUE CELL (THIS IS WHAT DISTINGUISHES THE SCHEME AS +; "SHALLOW BINDING". IN THE CASE OF A SPECIAL VARIABLE, THE ONE INTERNAL +; VALUE CELL, CAN, AT DIFFERENT TIMES, HOLD MANY DIFFERENT LOGICAL INSTANCES +; OF THE VARIABLE (THE OTHERS BEING SAVED ON THE BINDING STACK, ETC). +; A VARIABLE CAN HAVE, ON THE OTHER HAND, NONE, ONE OR MANY EXTERNAL VALUE +; CELLS. EACH OF THEM PERMANENTLY HOLDS THE VALUE ASSOCIATED WITH A SINGLE +; LOGICAL INSTANCE OF THE VARIABLE. IT IS NOT PUSHED OR POPPED, THE VALUE JUST +; STAYS THERE PERIOD. AS A CONSEQUENCE, STORAGE FOR EXTERNAL VALUE CELLS MUST BE +; OBTAINED VIA CONS, ETC. +; IN NORMAL COMPUTATION, THE INTERNAL VALUE CELL CONTAINS THE VALUE, +; EXTERNAL VALUE CELLS ARISE ONLY WHEN CLOSURE S ARE COMPUTED. IF THE ACTIVE +; VALUE AT A GIVEN MOMENT RESIDES IN AN EXTERNAL VALUE CELL, THEN THE INTERNAL +; VALUE CELL CONTAINS A SYMBOL-COMPONENT-FORWARDING POINTER TO THE EXTERNAL VALUE +; CELL. THUS, IT REMAINS TRUE THAT ONE CAN ALWAYS OBTAIN THE CURRENT VALUE +; FOR THE VARIABLE "FROM" THE INTERNAL VALUE CELL. SINCE THIS FORWARDING POINTER +; IS AUTOMATICALLY TAKEN INTO ACCOUNT BY THE STANDARD EFFECTIVE ADDRESS COMPUTATION +; MECHANISM, THE INDIRECTION (IF ANY) OPERATES TRANSPARENTLY TO THE MACRO-INSTRUCTION +; STREAM. NOTE THAT IF THE VALUE IS CURRENTLY RETAINED IN THE INTERNAL VALUE CELL, +; ONE CAN AT ANY TIME PERFORM A CONS, MOVE THE VALUE TO A NEWLY CREATED EXTERNAL +; VALUE CELL, AND STORE AN APPROPRIATE POINTER TO THE NEW EXTERNAL VALUE CELL IN +; THE INTERNAL VALUE CELL. + +;CLOSURES +; (MAKE-CLOSURE
) IS AN ORDINARY USER FUNCTION +; (IE NOT PART OF THE NUCLEAR SYSTEM, CAN BE INTERPRETED OR ANYTHING, ETC. +; THE GENERAL OPERATION PERFORMED BY MAKE-CLOSURE HAS IN THE PAST BEEN DENOTED +; BY *FUNCTION OR SOME SUCH, IT IS HOPED THE NEW NAME IS AN IMPROVEMENT.) +; (HOWEVER, A SIMILAR FUNCTION, MAKE-DOWNWARD-CLOSURE, DOES NEED TO BE HAND +; CODED FOR REASONABLE OPERATION, SINCE IT MONKEYS WITH SYSTEM STACKS, ETC. +; AS A RESULT, MAKE-CLOSURE WINDS UP HANDCODED TOO.) +; MAKE-CLOSURE RETURNS A POINTER WITH DATA-TYPE DTP-CLOSURE. FROM A +; STORAGE-CONVENTION POINT OF VIEW, THE PROPERTIES OF DATA-TYPE CLOSURE ARE +; IDENTICAL WITH THOSE OF DTP-LIST. THE FIRST ELEMENT OF THE CLOSURE, THEN, +; IS AS GIVEN TO MAKE-CLOSURE. MAKE-CLOSURE DOES NOT EXAMINE OR +; PROCESS IN ANY WAY. THE REMAINDER OF THE CLOSURE IS (LOGICALLY) +; AN A-LIST. (IN ORDER TO WIN MORE WITH CDR-CODING, ETC, IT IS ACTUALLY STORED IN +; "PROPERTY-LIST" FORM). +; THE CLOSURE-SPEC SHARES SOME PROPERTIES WITH A LAMBDA-LIST. IN FACT, +; ONE CAN THINK OF THE WHOLE OPERATION AS ONE IN WHICH THE LAMBDA-BINDING "HAPPENS" +; IMMEDIATELY, BUT THE EXECUTION UNDER THIS BINDING IS DELAYED UNTIL THE CLOSURE IS CALLED. +; HOWEVER, THERE ARE ALSO PITFALLS IN THE ABOVE LINE OF THINKING. +; + +;AS FAR AS THE "NUCLEAR" SYSTEM IS CONCERNED, THERE EXISTS TWO KINDS OF CODE, +;MICRO-CODE AND MACRO-CODE. MICRO-CODE IS COMPILED PDP-10 INSTRUCTIONS, +;PRODUCED EITHER BY HAND OR BY THE MICRO-COMPILER. MACRO-CODE ARE THE 16 BIT +;INSTRUCTIONS DESCRIBED IN COMMENT HEADED "INTERPRETED ORDER CODE" BELOW. + +;SINCE EITHER TYPE OF CODE CAN CALL THE OTHER TYPE OR ITS OWN TYPE, THERE ARE +;FOUR POSSIBILITIES. + ;MICRO-TO-MICRO + ;PUSHJ P,SUBR, WITH ARGS ON IP. IF PARTICULAR SUBR TAKES A VARIABLE + ;NUMBER OF ARGS, THE NUMBER OF ARGS IS IN J. + ;VALUE RETURNS IN AC T, ARGS HAVE BEEN POPPED OFF STACK + ;MICRO-TO-MACRO + ;PUSHJ P,P3ZERO ;PUSH 3 ZEROS ON IP WHICH WILL + ;EVENTUALLY BE HEAD OF MACRO-CODE RUNNING FRAME + ;PUSH IP,@ ;MXVEC IS THE MICRO-CODE-EXIT VECTOR, AND + ;MXVEC+N SHOULD BE A QZMEMP POINTER TO THE + ;FUNCTION CELL OF FCTN TO CALL + ; ... COMPUTE ARGS, PUSHING THEM ONTO IP ... + ;JSR <# OF ARGS>,MMCALL ;ACTUALLY DO CALL + ; VALUE RETURNS IN T + ;MACRO-TO-MICRO AND MACRO-TO-MACRO + ;CALL ;ALLOCATE LLPFRM WD PDL BLOCK AND + ;STORE FEF PNTR OF FUNCTION TO EVENTUALLY CALL + ; ... COMPUTE N-1 ARGS, STORING THEM IN DESTINATION "NEXT". + ; ... COMPUTE LAST ARG, STORING IT IN DESTINATION "LAST". + ;STORING IN "LAST" SAVES CURRENT MACHINE STATE (PC ETC) + ;THEN REFERENCES DATA-TYPE OF DATA PREVIOUSLY STORED BY CALL INSTRUCTION + ;VALID POSSIBILITIES ARE + ;FRAME + ;DATA HAD BETTER POINT TO A FEF (OR ERROR), + ;AND MACRO-TO-MACRO CALL OCCURS + ;ARRAY-POINTER + ;DATA HAD BETTER POINT TO AN ARRAY-HEADER, + ;AND ARRAY IS REFERENCED + ;MICRO-CODE-ENTRY + ;DATA IS MICRO-CODE ENTRY NUMBER. IT IS IMMEDIATELY + ;CALLED AS IN MICRO-TO-MICRO CALL. WHEN VALUE RETURNS + ;IN T, IT IS STORED IN APPROPRIATE DESTINATION + ;ANY OTHER DATA-TYPE RESULTS IN AN "INTERPRETER TRAP" + + +;NOTE: +;NO NEW FRAME IS CREATED ON A MICRO-TO-MICRO CALL. + +;OPERATION OF THE ROUTINE MMCALL +; MMCALL MUST PERFORM THE FOLLOWING JOBS: +; 1)DETERMINE NUMBER OF ARGS BEING PASSED (FROM AC FIELD OF JSR INST). +; 2)LOCATE BLOCK PREVIOUSLY RESERVED BY MICRO-CODE BY INDEXING BACK ON +; IP THAT MANY +; 3)IF NECESSARY, TRANSFER P STACK TO LINEAR-PDL-BINDING STACK +; 4)STORE LPCLS AND LPEXS IN PREVIOUSLY LOCATED BLOCK APPROPRIATELY +; 5)ACCESS FUNCTION TO CALL IN THAT BLOCK +; ;NOTE THAT PDP-10 MACHINE FLAGS AND ALL OTHER +; ;STATUS NOT EXPLICITLY SAVED IS LOST ACROSS +; ;A MICRO-TO-MACRO CALL + +;ALSO NOTE: +;DURING STEP 3, DATA ORIGINALLY ON P STACK WILL HAVE DATA TYPE OF QZFIX ADDED. +; THUS A) ONLY LOW 24 BITS WILL BE EVENTUALLY RESTORED AND B) P STACK SHOULD BE +; USED ONLY TO HOLD NON-POINTER DATA SUCH AS NUMBERS AND MICRO-PROGRAM RETURN +; ADDRESSES. IT WILL NOT GET MARKED OR RELOCATED DURING A GARBAGE COLLECTION. + +;RETURNING MULTIPLE VALUES: (OUTLINE) +; BOTH THE CALLING FCTN AND THE CALLED FCTN MUST COOPERATE IN A SPECIAL MANNER TO +; EFFECT THE RETURN OF MORE THAN ONE VALUE FROM THE CALLED FUNCTION. THUS, NORMAL +; CALLS (PRODUCED IN MACRO-CODE BY CALL AND CALL0, FOR EXAMPLE, ONLY CAN RECEIVE +; ONE VALUE AND STORING IN DESTINATION "RETURN" CAN ONLY RETURN ONE VALUE. + +;MACRO-CODE +; 1) AN "ADDITIONAL INFO" TYPE OF CALL BLOCK MUST BE PRODUCED. +; 2) THIS INFO SPECIFIES BOTH THE NUMBER VALUES EXPECTED AND THE DESIRED +; STORING OPTION. +; IN SOME CASES, SPACE IS LEFT ON THE PDL ABOVE THIS CALL BLOCK TO HOLD +; THE RETURNED VALUES. +; 3) CONTROL THEN PASSES TO CALLED FUNCTION AS NORMAL. THERE ARE THEN TWO +; POSSIBILITIES (AS FAR AS RETURNING VALUES IS CONCERNED). +; 3A) CONTROL REACHES A "NORMAL" OLD-TYPE STORE IN DESTINATION RETURN +; THE VALUE IS RETURNED IN THE CONVENTIONAL MANNER. +; 3B) CONTROL REACHES A CALL TO "RETURN-NEXT-VALUE" (OR OTHER FUNCTION WHICH +; IS A SIMPLE LINEAR-COMBINATION THEREOF). +; THE CALL BLOCK IS EXAMINED TO SEE IF THIS IS THE LAST VALUE IT IS EXPECTING. +; IF IT IS A "NORMAL" CALL BLOCK, IT IS ALWAYS EXPECTING ONLY ONE VALUE +; SO THAT THIS IS THE LAST ONE. THE VALUE SUPPLIED TO "RETURN-NEXT-VALUE" +; IS SUPPLIED AS IF IT HAD BEEN STORED IN DESTINATION RETURN, AND A + +; RETURN OF CONTROL IS EFFECTED. +; IF IT IS A "ADDITIONAL INFO" CALL BLOCK, THE VALUE SUPPLIED TO +; "RETURN-NEXT-VALUE" IS STORED, AS SPECIFIED. IF THAT WAS THE LAST +; ONE EXPECTED, CONTROL RETURNS. OTHERWISE, THE "RETURN-NEXT-VALUE" +; RETURNS AND EXECUTION OF THE ORIGINALLY CALLED FUNCTION CONTINUES +; IN ORDER TO COMPUTE THE ADDITIONAL DESIRED VALUES. +; 4) WHEN ALL DESIRED VALUES ARE COMPUTED AND CONTROL IS FINALLY RETURNED TO THE +; ORIGINALLY CALLING FUNCTION, IT MAY WISH TO EXECUTE CODE IN ORDER TO +; STORE THE RETURNED VALUES IN "OTHER" PLACES. IF THIS IS THE CASE, +; THEY NORMALLY WOULD HAVE BEEN "RECEIVED" ON THE STACK, SO THAT THEY CAN +; BE CONVIENTLY POPPED OFF INTO THE DESIRED LOCATION(S). +; THE "ADDITIONAL-INFO" BLOCK IS REMOVED FROM THE PDL +; AS PART OF THE RETURN PROCESS. + +;MICRO-CODE +; 1) "ADDITIONAL INFO" MUST ALSO BE PROVIDED. IN THE CASE OF +; MICRO-TO-MACRO THIS INFO TAKES EXACTLY THE FORM ABOVE. +; IN THE CASE OF MICRO-TO-MICRO, +; THE "EXTRA-INFO" BLOCK STARTS IMMEDIATELY BEFORE THE FIRST ARG. +; 2) THE "ADDITIONAL INFO" SPECIFIES THE SAME DATA AS IN 2 ABOVE. +; 3) CONTROL PASSES TO CALLED FUNCTION. THE FACT THAT "EXTRA VALUE +; HACKERY" IS TAKING PLACE IS INDICATED BY NON-ZERONESS IN BITS +; 3.1-3.2 OF THE RETURN WORD ON THE P PDL. THESE BITS ARE ALWAYS +; STORED 0 BY THE PDP-10 PUSHJ INSTRUCTION (INDICATING NO MULTIPLE +; VALUE HACKERY). THERE ARE TWO NON-ZERO POSSIBILITIES. 1 +; INDICATES THIS IS A MICRO-TO-MICRO CALL AND THE INFO IS +; IMMEDIATELY BEFORE THE FIRST ARG. 2 INDICATES THIS IS A +; MACRO-TO-MICRO (OR MICRO-TO- +; CALL, AND THE INFO IS LLPFRM Q'S FURTHER UP (EXACTLY AS FOR +; MACRO-TO-MACRO). +; 3A) IF CONTROL REACHES A "NORMAL" OLD STYLE RETURN, THE VALUE IS +; PLACED IN AC T AND A POPJ P, EXECUTED. (EXACTLY AS WOULD BE +; THE CASE FOR A SINGLE RETURNED VALUE. THE SAME AMOUNT OF +; STACK ADJUSTMENT IS DONE, NAMELY, THE ARGS (AND ANY TEMPS) +; ARE REMOVED, BUT ANY "EXTRA-INFO" IS NOT REMOVED. +; 3B) IF CONTROL REACHES A "RETURN-NEXT-VALUE", THE P PDL IS +; EXAMINED TO SEE IF THE CALLING FUNCTION IS EXPECTING +; MULTIPLE VALUES. IF NOT, THE VALUE IS RETURNED IN T. +; (RETURN-NEXT-VALUE MUST ALSO BE SUPPLIED A ARGUMENT +; (CONSTANT FOR ANY PARTICULIAR CALL TO IT) AS TO HOW MANY +; IP POPS MUST BE DONE IF A POPJ IS DONE. IF THE CALLING +; FUNCTION IS EXPECTING MULTIPLE VALUES, THE INFO IS LOCATED +; (IN ONE OF TWO SLIGHTLY DIFFERENT PLACES, AS SPEC'D BY (P)). +; IF THE INFO INDICATES THAT THIS IS THE LAST VALUE EXPECTED, +; A POPJ OCCURS WITH THE VALUE IN T. NOTE THAT THE LAST +; VALUE IS NOT "STORED" IN THE "INDICATED PLACE". THIS WILL +; BE DONE, PRESUMABLY, BY THE FIX-UP ROUTINE BELOW. IF THIS +; IS NOT THE LAST VALUE, IT IS STORED +; IN THE "INDICATED" PLACE AND RETURN-NEXT-VALUE +; RETURNS. ON A POPJ, THE SAME STACK ADJUSTMENT AS IN 3A IS MADE. +; 4) WHEN A POPJ DOES OCCUR, CONTROL WILL BE TRANSFERRED TO QME1 +; IN THE CASE IT WAS A MACRO-TO-MICRO OR +; MICRO-TO-MACRO-WHICH-TURNED-OUT-TO-BE-MICRO CALL. +; IN THIS CASE THE MECHANISM DESCRIBED IN 4 ABOVE IS AVAILABLE. +; IF THE ORIGINAL CALL WAS MICRO-TO-MICRO, CONTROL RETURNS DIRECTLY +; TO THE CALLING FUNCTION, WHICH WILL USUALLY WANT TO CALL A RUN +; TIME ROUTINE TO TRY AND FIGURE OUT HOW MANY VALUES WERE RETURNED +; AND WHAT TO DO NEXT. + +;THE "ADDITIONAL INFO" REFERRED TO ABOVE HAS TWO BASIC COMPONENTS. +; ONE IS THE COUNT OF VALUES EXPECTED. THIS LOGICALLY COUNTS DOWN +; TO ZERO AS THEY ARE SUPPLIED, SO THAT THE CONDITION THAT ALL EXPECTED +; HAVE BEEN GENERATED CAN BE DETECTED. ALSO, THIS ENABLES THE CALLING FUNCTION +; TO DETERMINE THAT NOT ALL REQUESTED ARGS HAVE BEEN SUPPLIED. +; ANOTHER MODE IS TO RECEIVE ALL GENERATED VALUES, LISTIFING THEM. +; THE SECOND IS INDICATING WHERE THE VALUES ARE TO BE STORED. +; TWO BASIC POSSIBILITIES ARE STORING THE RETURNED VALUES IN A BLOCK +; (FREQUENTLY ON THE PDL) AND STORING THEM IN A LIST A LA DESTINATION +; NEXT-LIST. IN LIST MODE, COMPONENT INVISIBLE POINTERS ARE INTERPRETED, +; SO THE LIST CAN CONSIST OF A LIST OF POINTERS, OR IT CAN BE +; ACTUALLY STORED INTO AND BECOME A "LIST OF VALUES". A SPECIAL FLAG IS +; NEEDED IF ONE IS STORING INTO A SPECIAL VARIABLE WITH A LIST OF POINTERS SINCE +; AN ENVIRONMENT SWITCH IS NOT NORMALLY PERFORMED AT "STORE-NEXT-VALUE". +; IN ADDITION, SEVERAL "MINOR" FUNCTIONS ARE CONTROLLED BY BITS IN THE +; ADDITIONAL INFO. +; CAUSE UN-SWAPPING AND RE-SWAPPING OF SPECIAL VARIABLES OF RUNNING FRAME +; WHEN VALUES ARE STORED BY STORE-NEXT-VALUE IN PRECEEDING FRAME. + + +; IMPLEMENTATION + +;MULTI-VALUE-RETURN ADI +; CONTROL Q (THIS ONE PUSHED LAST) SO IT IS IN HIGHER MEM ADR) +;BUSRC=1 SINCE THIS IS NOT LAST ADDTL Q LOOKING UP +;DATA-TYPE =QZFIX +.SEE ADIRT ;VALUE FOR %ADITP (USES 3 BITS) +%ADIRB==210300 ;VALUE STORING OPTION + ;ERROR + ADISB==1 ;STORE IN BLOCK + ADISL==2 ;STORE IN LIST + ADISC==3 ;DO CONS AND MAKE LIST + ADIP==4 ;INDIRECT POINTER. POINTER POINTS AT OTHER ADI INFO BLOCK + ;WHICH IS TO BE USED FOR ALL DATA (HAVING TO DO WITH M.V.) + ;PNTR POINTS TO "FIRST" WORD, HIGH IS HIGHEST IN MEM ADDR +ADISSV==200000 ;SWAP S. V. IN RUNNING BLOCK WHEN STORING HERE. +%ADINV==600 ;REMAINING VALUES TO BE SUPPLIED + +;RESTART PC ADI +;CONTROL Q +;DATA TYPE =QZFIX +.SEE ADRPC ;DATA Q IS RESTART PC (MACRO OR MICRO AS APPROPRIATE) AS FIXNUM +%ARMSL==600 ;MICRO-STACK LEVEL TO RESTORE TO + +;BINDING LEVEL ADI +;DATA Q - DATA TYPE FIX, BIND PDL POINTER (RELATIVE TO ORIGIN OF BIND-STORAGE ARRAY). + +;USAGE OF 5 BITS IN INDIRECT AND INDEX FIELDS OF PC WORD ON P PDL. THESE ARE +;ALWAYS STORED ZERO BY PUSHJ INSTRUCTION. +PPBINF==3 ;IF THESE NON-ZERO, THEY SIGNAL PRESENCE OF ADDTL INFO + PPBMIA==1 ;MICRO-TO-MICRO CALL + PPBMAA==2 ;MICRO-TO-MACRO OR MACRO-TO-MICRO CALL (LOOK LLPFRM Q'S BACK FOR INFO) + ;IF BOTH PPBMIA AND PPBMAA SET, IT MEANS THAT Q BEFORE ARGS IS A + ;"STACK-BLIP". THE STACK-BLIP CONTAINS THE "REAL" PPBMIA AND PPBMAA + ;BITS, AND ALSO A COUNT OF Q'S TO FLUSH WHEN POPING THIS BLIP. + ;STACK-BLIP'S CAN ARISE DURING THE ENTRY SEQUENCE OF A + ;MICRO-COMPILED FUNCTION WHICH HAS A &REST ARG. +PPBSPC==4 ;DO BBLKP (POPPING A BLOCK OFF LINEAR BINDING PDL) ON EXIT FROM + ;THIS FCTN. FCTN MUST EXIT TO CBBLKP OR MRN<><> TO CAUSE THIS + ;BIT TO GET LOOKED AT. + + + +;PREASSIGNED MICRO-CODE-ENTRY #S +UCATCH==0 ;U CODE ENTRY # OF %CATCH +UERRS==1 ;U CODE ENTRY # OF %ERRSET + +;OPERATION OF %CATCH. (%CATCH ) APPEARS TO THE USER SIMILIAR TO CATCH +; IN MACLISP. THE DIFFERENCES ARE THAT THE ORDER OF THE ARGUMENTS IS REVERSED AND +; THAT IS EVALUATED, NOT AUTOMATICALLY QUOTED. MUST ALWAYS BE PRESENT, +; BUT MAY, OF COURSE, BE NIL (OR ANYTHING ELSE). %CATCH IS IMPLEMENTED AS A +; MICRO-CODE-ENTRY, AND MUST BE ASSIGNED A PREDETERMINED ENTRY # KNOWN AT +; MICRO-ASSEMBLE TIME. +; THE GENERAL OPERATION IS AS FOLLOWS: +; AN OPEN CALL BLOCK IS CREATED FOR THE CALL TO %CATCH, AS IT WOULD BE +; IN ANY CASE. THE FIRST ARGUMENT IS EVALUATED AND STORED, ALSO COMPLETELY +; AS NORMAL. EVALUATION OF THE SECOND ARGUMENT THEN BEGINS, STILL IN A +; COMPLETELY NORMAL FASHON. IF NO %THROW S ARE ENCOUNTERED, EVALUATION +; OF THE SECOND ARGUMENT WILL COMPLETE AND %CATCH ITSELF WILL BE CALLED. +; %CATCH SIMPLY IGNORES ITS FIRST ARGUMENT AND RETURNS TWO VALUES, +; ITS SECOND ARGUMENT AND T. THIS COMPLETES HANDLING OF THE CASE WHERE +; NO THROW S ARE ENCOUNTERED. IF %THROW IS REACHED, IT SIMPLY UNWINDS +; BACK UP THE PDL UNTIL IT FINDS AN OPEN CALL BLOCK TO %CATCH WTIH THE APPROPRIATE +; FIRST ARGUMENT IN PLACE. THIS CALL BLOCK IS REMOVED AND THE ARGUMENT +; TO THROW SUBSTITUTED AS IT VALUE. THE REMAINING PROBLEM IS TO SET THE +; PC TO THE POINT IT WOULD ORDINARILY BE AFTER THE ACTIVIATION OF THE +; CALL BLOCK. THIS PROBLEM IS SOLVED BY REQUIRING THAT EITHER THE ORIGINAL +; CALL TO %CATCH BE AN ADI CALL, WITH AN ADI BLOCK OF TYPE ADRPC OR THAT +; IT SPECIFY DESTINATION RETURN. THE DATA ASSOCIATED WITH THE ADI-BLOCK, +; IF PRESENT, IS THE RESTART PC. + +;%ERRSET WORKS VERY SIMILIARLY. (%ERRSET ) + +;MISC FCTNS FOR CONVENIENTLY GETTING THE ABOVE STUFF ON THE PDL +;MACRO-CODE + ;OPERATE IN A SIMILAR MANNER TO %CALL-MULT-VALUE. + ;%CATCH-OPEN -- OPENS A CALL BLOCK TO %CATCH WITH ONE ADI BLOCK + ;OF TYPE RESTART PC AND DATA ADR. + ;%CATCH-OPEN-MV -- AS ABOVE, BUT WITH TWO ADI BLOCKS AND PROVISION + ;FOR RECEIVING N VALUES + ;%ERRSET-OPEN , %ERRSET-OPEN-MV + + +;NUMERIC ARGUMENT DESCRIPTION FORMAT: +; THIS FORMAT IS USED WHENEVER A NUMBER IS USED TO DESCRIBE THE NUMBER AND +;TYPE OF ARGUMENTS A FUNCTION TAKES. THESE PLACES INCLUDE THE FAST-OPTION +;Q IN THE FEF OF A MACRO-COMPILED FUNCTION, THE ARG-DESC Q IN A MESE-FEF, +;THE ENTRY IN THE MICRO-CODE-ENTRY-NUMBER-ARGS AREA FOR A MICRO-CODE ENTRY, +;AND THE VALUE RETURNNED BY THE %ARGS-INFO MISC-INSTRUCTION. + +AGIRQT== 10,,000000 ; REST ARG QUOTED +AGIREV== 4,,000000 ; REST ARG EVALUATED +AGINFO== 2,,000000 ; FEF W/O FAST OPTION, CHECK ADL FOR QUOTAGE +AGIINT== 1,,000000 ; TRAP TO INTERPRETER, VAL ALWAYS=1000077 +%AGIMN== 060600 ; FIELD CONTAINS MIN NUMBER REG+OPT ARGS +%AGIMX== 000600 ; FIELD CONTAINS MAX NUMBER REG+OPT ARGS + ; NOTE THERE MAY A REST ARG AS WELL. + +;SUPPORT VECTOR ASSIGNMENTS +; THESE LOADED INTO SUPPORT VECTOR (STARTING AT SUPV) DURING +; COLD LOAD, AND REPRESENT THE INDICATED QUANTITIES AS OF THE END OF COLD +; LOAD GENERATION. IN THE CASE OF FUNCTION CELLS, NOTE THAT THESE ARE THE +; ACTUAL FUNCTION CELL CONTENTS, NOT A POINTER TO THEM. THUS, IF THE INDICATED +; FUNCTION IS TRACED, ETC, THE ENTRY SUPPORT VECTOR WILL NOT BE AFFECTED. +; THIS IS CLAIMED TO BE A FEATURE. + +SVCPNT==0 ;FCTN CELL CONTENTS OF PRINT +SVCFEX==1 ;HEAD OF SYMBOL FEXPR +SVCLEX==2 ;HEAD OF SYMBOL LEXPR +SVCAPL==3 ;FCTN CELL OF APPLY-LAMBDA +SVCEQU==4 ;FCTN CELL OF EQUAL + +;MICRO-COMPILING FCTNS WITH &REST ARGS. +; PROBLEMS: +; 1) WITH A VARIABLE # OF ARGS, INDEXING (FROM IP) TO GIVEN ARG IS NOT CONSTANT. +; (MACRO-CODE DOESNT HAVE THIS PROBLEM BECAUSE OF THE ARG-POINTER). +; 2) MUST PROVIDE A MEANS TO REMEMBER HOW MANY ARGS TO FLUSH ON RETURN. +; SOLUTION: CALL RSTSUP (REST-ARG-SETUP) WHEN FIRST ENTERING FCTN. THIS ROUTINE +; IS SUPPLIED AN ARG SAYING HOW MANY SPREAD ARGS FCTN TAKES. (AS USUAL ON +; MICRO-CODE-ENTRY WITH VARIABLE # OF ARGS, J HAS NUMBER OF ARGS CALLED WITH, +; OR MORE ACCURATELY IN THIS CASE, # OF PDL SLOTS CALLED WITH). +; RSTSUP A) PUSHES THE NUMBER PDL SLOTS CALLED WITH ON IP AS FIXNUM. THIS IS +; SO KNOW HOW MANY TO FLUSH ON RETURN. ALSO, THE ORIGINAL ADI +; INFO BITS ARE COPIED INTO THIS WORD. +; B) COMPUTES POINTER TO FIRST ARG SLOT. +; C) IF ANY SPREAD ARGS, "COPY THEM OVER" TO THE TOP OF THE STACK (DOING NEW +; PUSHES). THIS IS TO SOLVE PROBLEM 1 ABOVE. +; D) CHECK ADI. IF LISTIFIED CALL (FEXPR-CALL OR LEXPR-CALL), COPY OVER +; &REST ARG AS WELL. OTHERWISE, PUSH LIST POINTER TO ARG-LIST AND +; ASSURE ITS CDR-CODES ARE KOSHER. +; E) STORE ADI FOR THIS FCTN WITH BOTH PPBMIA AND PPBMAA SET. THIS +; COMBINATION SAYS Q BEFORE SPREAD ARGS CONTAINS THE REAL A-D-I +; BITS AND AMT TO FLUSH FROM PDL ON EXIT. + +; ON RETURN, COMPILED FUNCTION FLUSHES THE SPREAD ARG SLOTS AND EXITS +; TO NORMAL FLAVOR "HAIRY" EXIT AS APPROPRIATE (SPECSTR, M-V RETURN, ETC) +; THIS DISPATCHES ON ADI BITS ON RETURN. SEEING BOTH PPBMIA AND PPBMAA SET, +; IT KNOWS TO DO THE RIGHT THING (IE FLUSH FROM PDL ALL SUPPLIED AS ARG Q'S). + + +;FUNCTION ENTRY FRAME FORMAT + +QFEIPC==0 ;FRMFEF IN %FRMDT + QNADL==1,, ;NO ADL STORED FOR THIS FCTN (FAST OPTS USED INSTEAD) + QFASAB==400000 ;FAST ARG OPTION ACTIVE BIT (1) + QFSVOP==200000 ;SPECIAL VARS BOUND FLAG + ;0- NO SPECIAL ARGS PRESENT (1) + ;1- SPECIAL ARGS PRESENT. INVISIBLE POINTERS TO THEIR VALUE + ; CELLS ARE AT THE HEAD OF QFSVVP. + + %QFEPC==2000 ;INITIAL PC (RELATIVE TO FEF ORG) +QFEFN==1 ;FCTN NAME + +QFRFSO==2 ;NUMERIC DESCRIPTION OF NUMBER AND TYPES OF ARGS, AS COMPLETE AS + ; POSSIBLE (IF QFASAB IS SET, THEN IT IS IN FACT COMPLETE). + .SEE AGIRQT +QFSVMP==3 ;BIT MAP OF SPECIAL BINDING SLOTS IN (ARGLIST+LOCBLOCK) (22) + QFSBMA=20,, ;ACTIVE (1) + +QFEMSC==4 ;PDL FRAME DESC + %QFAGL==171000 ;# ENTRIES IN BIND DESC LIST + ; (# OF VARIABLES DESCRIBED) + %QFAGS==71000 ;FEF ADR START OF ARG-DESC-LIST + %QFLBL== 700 ; Q'S IN LOCAL BLOCK + +QFEMS1==5 ;MORE RANDOMS + %QFMXP==171000 ;MAX LENGTH (LOCAL BLOCK + LOCAL PDL) +; %QFETI==100700 ;FEF ADR OF HIGHEST VARIABLE NEEDING +; ;ENTRY TIME INITIALIZATION + +QFFL==6 ;TOTAL LENGTH OF THE STG OCCUPIED IN Q'S + +QFVA==7 ;START OF VARIABLE LENGTH LIST AREA + + +;SPECIAL VARIABLE VALUE CELL POINTERS LIST (QFSVVP) +; FIRST BINDING POINTERS +; THEN REFERENCE POINTERS (WITH BUSRC SET) +;ARG LIST + ;DESCRIBING BITS + ALNP==20,, ;NAME PRESENT (IN FOLLOWING Q OF LIST) + ALBOP==10,, ;BINDING OPTION WD1 BYTE 0 QTR 1 HIGH BIT (1) + ;LOCAL - DO NOTHING SPECIAL (HA HA) + ;SPECIAL SAVE PREV VALUE OF BINDING CELL AND STORE NEW + ;ONE THERE OBTAIN POINTER TO VALUE CELL FROM + ;NEXT FROM IN QFSVVP LIST + + %ALDDT==110400 ;ARG DESIRED DATA TYPE WD0 BYTE 1 QTR 0 (4) + ;DONT CARE + ;NUMBER + ;FIXED NUMBER + ;SYMBOL + ;ATOM + ;LIST + ;FRAME + %ALDQT==70200 ;ARG DESIRED EVAL/QUOTAGE WD0 BYTE 1 QTR 1 (2) + ;DONT CARE + ;DESIRED EVAL'ED + ;DESIRED QUOTED + %ALAGS==40300 ;ARG SYNTAX WD1 BYTE 0 QTR 0 (3) + ALARG==0 ;REQUIRED ARG + ALOPT==1 ;OPT ARG + ALRST==2 ;"REST" ARG + ALAUX==3 ;"AUX" + ALFREE==4 ;FREE - IGNORED BY ENTRY OPERATION + ;TAKES NO LOCBLOCK SLOT + ALINT==5 ;INTERNAL - IF SPECIAL, IGNORED BY ENTRY OP + ;IF LOCAL, TAKES LOCBLOCK SLOT + ALINTA==6 ;INTERNAL - AUX + ;IF LOCAL, TAKES LOCBLOCK SLOT + MXAGS==7 ;IF THIS OR GREATER, LOSE + %ALIOP==400 ;INITIALIZING OPTION (4) + ;NONE IE ARG OR FREE + ;NIL + ;INITIALIZE TO PNTR + ;INITIALIZE TO CONTENTS OF PNTR + ;OPTIONAL SA - SA HERE IF ARG SUPPLIED + ;INITIALIZED BY COMPILED CODE + ;INITIALIZE TO FOLLOWING Q LOW 9 BITS CONSIDERED AS + ;EFFECTIVE ADR + ;INITIALIZE TO SELF (SAME ACTION AS NONE, BUT INDICATES + ;ORIGINAL LAMBDA LIST OF FORM (A A) ETC + ;ALSO, ENTIRE LOCBLOCK IS INITED TO NIL + +;ARG NAME (IF PRESENT) + + +;INTERPRETED ORDER CODE + +;MAIN OP CODE (4 BITS 170000) + +;OPS WHICH TAKE BOTH ADDRESS AND "DESTINATION" MODIFIER +;0 CALL +;1 CALL0 ;CALL FCTN OF NO ARGS - DO BUILD THEN CALL +;2 MOVE +;3 CAR +;4 CDR +;5 CADR +;6 CDDR +;7 CDAR +;10 CAAR + +;OPS WHICH TAKE ONLY ADDRESS (FURTHER DECODED BY "DESTINATION" FIELD) +;ND1 11 + ;MOVEM (TOP ITEM OF STACK STORED IN E, STACK PNTR NOT CHANGED) + ;+ (ADD TOP ITEM OF STACK TO C(E), RESULT TO STACK + ;- + ;* + ;/ + ;LOGAND + ;LOGXOR + ;LOGIOR +;ND2 12 + ;EQ THESE COMPARE C(E) TO TOP OF STACK AND SET INDICATORS + ;> THE STACK IS POPPED + ;< + ;POP + ;SCDR - SETS EFFECTIVE ADR TO ITS CDR + ;SCDDR - SETS EFFECTIVE ADR TO ITS CDDR + ;+1 - SETS EFFECTIVE ADR TO ITS CONTENTS +1 + ;-1 - " " " " " " -1 + +;ND3 13 + ;BIND - CREATE BIND DESC BLOCK BINDING E TO ITS CURRENT CONTENTS + ;BINDNIL - DO ABOVE, THEN SET E TO NIL + ;BINDPOP - DO BIND, THEN SET E TO CONTENTS OF TOP OF STACK. POP STACK + ;SETNIL - SET E TO NIL + ;SETZERO - SET E TO 0 + ;PUSH-E - PUSHES LOCATIVE PNTR TO EFF ADR + +;BRANCH 14 + ;3 BIT BRANCH CODE + ;BRANCH ALWAYS + ;BRANCH ON "NILIND" + ;BRANCH ON NOT "NILIND" + ;BRANCH ON "NILIND", POP ON NO TRANSFER + ;BRANCH ON NOT "NILIND", POP ON NO TRANSFER + ;BRANCH ON ATOMIND + ;BRANCH ON NO ATOMIND + ;DATA XFER INSTRUCTIONS SET ATOMIND TO T + ;IFF DATA = ATOM, NIL OTHERWISE + ;SET NILIND TO T IF DATA = NIL + ;PREDICATES SET "NILIND" AS PER THEIR VALUE + + ;9 BIT SIGNED DELTA FOR PC, 0 => GOBBLE FOLLOWING + ;WD FOR 16 BIT SIGNED DELTA + +;MISC 15 + ;HAS DESTINATION CODE (3 BITS) + ;9 BIT FCTN SELECTOR + ;"LIST GROUP" (USING DEFAULT CONSING AREA) +;-- FOLLOWING INITIAL ; BELOW INDICATES NOT IN REAL MACHINE MICRO-CODE. +; (THIS CAN BE DUE EITHER ITS BEING NOT APPLICABLE OR "DECOMMITTED") +;0-77 ;LIST 0-77 (NO ARGS) + ;LIST RESERVES BLOCK OF "N" Q'S + ;PUSHES A PNTR TO THE BLOCK, + ;THE DESTINATION AS A INTEGER, + ;AND A SECOND POINTER TO THE BLOCK + ;DEST "NEXT LIST" IS USED TO STORE IN VALUES +;100-177 ;"LIST GROUP" (SPECIFING CONSING AREA) + ;JUST LIKE 0-77 BUT TAKES EXTRA ARG SPECIFING AREA + +;200-217 ;UNBIND 1 - 16. (UNDO 1-16. BINDING BLOCKS) +;220-237 ;POPPDL 1-16. FLUSH TOP N ENTRIES FROM STACK +;240 ;FREE +;241 ;FREE +;242 ;CDR (THESE UP TO CAAR AVAILABLE AS MISC INSTRUCTIONS ONLY SO +;243 ;CAR MICROCOMPILED FCTNS CAN ACCESS THEM CONVIENTLY +;244-247 ;CXXR -- 4 (COUNT IN ORDER D=0) +;250-257 ;CXXXR -- 8 +;260-277 ;CXXXXR -- 16 + ; # ARGS +;--*OBSOLETE* %GCB ;300 1 ;RETURNS NIL IF GC BIT OF ARG CLEAR, T IF SET +;--*OBSOLETE* %USRCB ;301 1 ;RETURNS NIL IF USRC " " " " +;--*OBSOLETE* %CDRC ;302 1 ;RETURNS CDR CODE OF ARG AS FIXNUM 0-3 +;%DATTP ;303 1 ;RETURNS DATA TYPE OF ARG AS FIXNUM 0-37 +;%DAT ;304 1 ;RETURNS POINTER DATA OF ARG AS FIXNUM 0-37,,777777 +;--*OBSOLETE* %SGCB ;305 2 ;RETURNS ARG1 WITH ARG2 SUBSTITUTED AS GC BIT +;--*OBSOLETE* %SUSRCB ;306 2 ; " " " AS USRC BIT +;--*OBSOLETE* %SCDRC ;307 2 ; " " " AS CDR CODE (WATCH OUT!!) +;%SDATTP;310 2 ; " " " AS DATA TYPE +;%SDAT ;311 2 ; " " " FOR POINTER DATA +;%STORE ;312 2 ;STORES ARG2 IN LOCN SPECIFIED BY ARG1 (CLOBBER) + ;DOES NOT AFFECT CDR CODE +;--*OBSOLETE* %STALL ;313 2 ;AS ABOVE BUT INCLUDES CDR CODE +;--*OBSOLETE* %COMBIN ;314 2 ;RETURNS (WD1 OF ARG1, WD1 OR ARG2) AS WD0,WD1 +;%LDB ;315 2 ; SUPPLIES FIXNUM D.T. IF BYTE DOES + ; NOT INCLUDE D.T. FIELD. +;%DPB ;316 3 ; + ;RETURNS ARG3 WITH ARG1 SUBSITIUTED IN BYTE INDICATED BY ARG2 +;%COMBINE-STORE + ;317 3 ;STORE IN ADR OF ARG1 DATA CONSISTING OF ARG2 IN DATA-TYPE, ETC + ;ARG3 IN POINTER. (IE 9 BITS FROM ARG2, 23 FROM ARG3). + ; SEE %SP-Q FOR 16, 16 FLAVOR CLOBBER STORE. + +;320 ;GET +;321 ;GETL +;322 ;ASSQ +;323 ;LAST +;324 ;LENGTH +;325 ;1+ +;326 ;1- +;327 ;RPLACA +;330 ;RPLACD +;331 ;ZEROP +;332 ;SET +;333 +;334 ;FREE +;335 ;COMPUTEGO TARGET TAG ON TOP OF STACK +;336 ;FREE +;337 ;XSTORE +;340 ;FALSE (ALWAYS NIL) +;341 ;TRUE (ALWAYS T) +;342 ;NOT +;343 ;ATOM +;344 ;%TYI +;345 ;%TYO +;346 ;%HALT +;347 ;GET-PNAME +;350 ;LSH +;351 ;ROT +;352 ;%BOOLE (3 ARGS) +;353 ;NUMBERP +;354 ;PLUSP +;355 ;MINSUP +;356 ;\ (REMAINDER) +;357 ;MINUS +;360 ;PRINT-NAME-CELL-LOCATION (OF SYMBOL) (GIVES LIST PNTR TO ..) +;361 ;VALUE-CELL-LOCATION " " +;362 ;FUNCTION-CELL-LOCATION " " +;363 ;PROPERTY-CELL-LOCATION " " +;364 ;NCONS +;365 ;NCONSA +;366 ;CONS +;367 ;CONSA +;370 ;XCONS +;371 ;XCONSA +;--372 ;ARRAY-DIMENSION-N +;373 ;SYMEVAL +;374 ;AREA-RELATIVE-CONTENTS +;375 ;ALLOCATE-BLOCK +;376 ;%CALL-MULT-VALUE (XCMV) +;377 ;%CALL0-MULT-VALUE (XC0MV) +;400 ;%RETURN-2 VALUES +;401 ;%RETURN-3 VALUES +;402 ;%RETURN-N VALUES +;403 ;RETURN-NEXT-VALUE +;404 ;GET-ARRAY-TYPE +;--405 ;APPLY --FLUSHED-- THINGS SHOULD GET TO M-APPLY +;406 ;BIND +;--407 ;GET-MACRO-ARG-DESC-POINTER + +;410 ;MEMQ +;411 ;M-< (< FOR VALUE) +;412 ;M-> " +;413 ;M-= " +;--414 ;%OPEN +;--415 ;%UTYI +;--416 ;%WORDREAD (READS OCTAL # FROM UTYI SOURCE AND RETURNS IT.) + ;HAS HACKS TO READ NUMBERS AS PRINTED BY PDP-10 LISP. +;--417 ;%UNUTYI UNTYI CH OR LAST CH IF ARG NIL +;420 ;%SCRATCHPAD-STORE +;421 ;M-+ +;422 ;M-- +;423 ;M-* +;424 ;M-// +;425 ;M-LOGAND +;426 ;M-LOGXOR +;427 ;M-LOGIOR +;430 ;ARRAY-LEADER ARRAY-POINTER, INDEX +;431 ;STORE-ARRAY-LEADER ARRAY-POINTER, INDEX, DATA +;432 ;GET-LIST-POINTER-INTO-ARRAY +;433 ;FILL-ARRAY ,DATA (XFARY) +;434 ;M-APPLY (XMAPLY) + ; NOTE: THIS MISC INSTRUCTION SHOULD NEVER BE EXECUTED. IT APPEARS HERE + .SEE XMAPLY ;AS A CONVIENENCE FOR THE COLD LOAD GENERATOR IN SETTING UP THE + ;FUNCTION CELL OF APPLY, AND SHOULD BE MOVED TO THE MISC-ENTRIES TABLE. + ;ALL CALLS REACHING M-APPLY SHOULD BE VIA MACRO-TO-MICRO, ETC CALLS + ;WHICH CREATE A FRESH FRAME FOR M-APPLY TO RUN IN. +;435 ;%SCRATCHPAD-READ +;--436 ;%LOAD-MISC-BITS (RETURNS CDR-CODE,USRCB AS FIXNUM) +;--437 ;%STORE-MISC-BITS STORES ABOVE +;--440 ;%STORE-PDP10-INSTRUCTION +;441 *OBSOLETE* ;%P-GCB (RETURNS GCB OF CONTENTS OF POINTER) +;442 ;%P-USRCB USRCB +;443 ;%P-CDRC CDR-CODE +;444 ;%P-DATTP DATA-TYPE +;445 ;%P-DAT DATA +;446 *OBSOLETE* ;%SP-GCB STORES DATA IN GCB OF LOCN POINTED TO BY PNTR +;447 ;%SP-USRCB LIKEWISE USRCB +;450 ;%SP-CDRC CDR-CODE +;451 ;%SP-DATTP DATA-TYPE +;452 ;%SP-DAT DATA +;--453 ;%GET-MISC-FCTN-ENTRY +;--454 ;%RELOC-PDP10-INST + ;POINTER SHOULD BE A FIXNUM, AND IS RELOCATED BY MEM + ;INDIRECT BIT IS SET IF INDIRECTP IS NON-NIL + ;AMOUNT IS ADDED TO RG +;455 ;%GET-MEM-POINTER MEM-POINTER IS CONVERTED TO A + ;MEM-POINTER. THIS MEANS ADDING MEM UNLESS IT IS + ;ALREADY OF TYPE MEM-POINTER. +;456 ;%CATCH-OPEN SEE DISCUSSION ON OPERATION OF %CATCH, ETC +;457 ;%CATCH-OPEN-MV +;460 ;%ERRSET-OPEN +;461 ;%ERRSET-OPEN-MV +;462 ;%FEXPR-CALL +;463 ;%FEXPR-CALL-MV +;464 ;%LEXPR-CALL +;465 ;%LEXPR-CALL-MV +;466 ;%CATCH IGNORES TAG, RETURNS EXP, T HERE FOR LINKAGE + ;AND DEBUGGING CONVENIENCE ONLY, MUST BE CALLED WITH FRAME + ; TYPE CALL FOR PROPER OPERATION. (IN CASE THERE IS A THROW.) +;467 ;%ERRSET LIKEWISE, SEE ABOVE +;470 ;%THROW THROWS TO %CATCH +;471 ;%ERR "THROWS" TO %ERRSET +;472 ;%P-LDB +;473 ;%P-DPB +;474 ;%MASK-FIELD + ;MASK FIELD IS LIKE LDB EXCEPT DATA IS RETURNNED IN ITS + ;ORIGINAL POSITION IN Q INSTEAD OF RIGHT ADJUSTED. + ;ERROR IF FIELD IS NOT CONTAINED IN POINTER PART OF Q +;475 ;%P-MASK-FIELD +;476 ;%DEPOSIT-FIELD + ;%DEPOSIT-FIELD IS LIKE %DPB BUT DATA TO BE DEPOSITED IS + ;TAKEN FROM CORRESPONDING PART OF INSTEAD OF + ;RIGHT ADJUSTED. ERROR IF FIELD IS NOT CONTAINED IN + ;POINTER PART OF Q + ;RETURNS DEPOSITED INTO DATA +;477 ;%P-DEPOSIT-FIELD + ;LIKEWISE. ALSO ERROR IF FIELD IS NOT CONTAINED IN POINTER PART + ;OF Q. DEPOSITS INTO CONTENTS OF POINTER, AND RETURNS + ;DATA DEPOSITED (ARG 1). +;500 ;%COPY-ARRAY-CONTENTS .. DATA IN ARRAY TRANSFERRED + ;TO ARRAY. IF ARRAY SMALLER, REST OF + ;ARRAY'S ENTRIES ARE CLEARED. IF ARRAY SMALLER, + ;ADDITIONAL ENTRIES IN ARRAY IGNORED. TRANSFER + ;OCCURS ON A Q FOR Q BASIS TREATING EACH AS A SINGLE + ;DIMENSIONAL Q ARRAY. +;501 ;%COPY-ARRAY-CONTENTS-AND-LEADER LIKEWISE, BUT LEADER + ;ALSO COPIED. +;--502 ;%ITS-CALL TAKES LIST AS ARG AND MAKES NEW SYSTEM CALL + .SEE XITSC ;SEE COMMENT +;503 ;ARRAY-HAS-LEADER-P RETURNS T IF ARRAY HAS + ;ASSOCIATED LEADER +;504 ;%ITS-STRING-OUT + ;DO NEW SYSTEM CALL IOT ON CHNL, OF STRING STARTING AFTER + ;NTH CHARACTER. IS SUPPLIED AS CONTROL BITS. + ;CHNL MUST BE OPEN IN BLOCK MODE + ;NOTE!! THIS CALL ITS SPECIFIC AND ITS USE SHOULD BE + ;WELL "DELIMITED" +;505 ;FIND-POSITION-IN-LIST . LOOKS FOR DATA IN LIST BY + ;MEANS OF EQ. RETURNS ELEMENT # IN LIST IF FOUND + ;(STARTING WITH 0 IF FIRST), NIL IF NOT. +;--506 ;FIND-POSITION-IN-LIST-EQUAL . SIMILAR BUT USES EQUAL + ;WHICH IT ACCESSES VIA A MICRO-TO-MACRO CALL +;507 ;G-L-P . ARRAY MUST BE ART-Q-LIST. + ;RETURNS LIST POINTER TO FIRST ELEMENT EXCEPT RETURNS NIL + ;IF ARRAY HAS 0 FILL POINTER +;510 ;FIND-POSITION-IN-VECTOR . SIMILIAR TO + ;FIND-POSITION-IN-LIST, BUT FASTER. +;--511 ;FIND-POSITION-IN-VECTOR-EQUAL . LIKEWISE + ;FIND-POSITION-IN-LIST-EQUAL +;512 ;AR-1 REFERENCE ARRAY OF ONE DIM. FASTER THAN FUNCALL. +;513 ;AR-2 LIKEWISE, WITH TWO DIMENSIONS. +;514 ;AR-3 LIKEWISE, THREE DIMS +;515 ;AS-1 STORE DATA ONE DIM ARRAYP +;516 ;AS-2 LIKEWISE, TWO DIMS. +;517 ;AS-3 LIKEWISE, THREE DIMS +;--520 ;TVINI INITIALIZE VIDEO BUFFER +;--521 ;TVSET SET TV POINT +;--522 ;TVREAD RETURN T OR NIL DEPENDING ON CURRENT STATE OF POINT + ;X,Y +;--523 ;DRAWMODE PUT THIS IN ALU-OP OF UNIBUS-SUPERBUS CONVERTER +;--524 ;HLINE DRAW HORIZ LINE +;--525 ;VLINE DRAW VERT LINE +;526 ;%SP-Q CLOBBER C(POINTER) WITH + ;Q FORMED BY HIGH 16 BITS FROM LEFT-DATA, LOW FROM RIGHT-DATA +;527 ;%OFFSET-MEM-REF RETURNS THE DATA TYPE AND POINTER + ;OF THE MEMORY WORD DISPLACED FROM . + ; MUST BE A FIXNUM, BUT ADDR CAN BE ANY DATA TYPE. + ;(IN THIS SIMULATOR, MEM IS ADDED IF DATA-TYPE IS NOT + ; MEM-POINTER). +;530 ;%OFFSET-MEM-REF-HIGH-HALF SIMILAR TO ABOVE, BUT + ;RETURNS HIGH 16 BITS AS A FIXNUM. +;531 ;%OFFSET-MEM-REF-LOW-HALF SIMILAR, BUT LOW 16 BITS + ;AS A FIXNUM. +;532 ;%ARGS-INFO FUNCTION CAN BE ANYTHING MEANINGFUL IN + .SEE AGIRQT ;FUNCTION CONTEXT. RETURNS FIXNUM TYPE ARGS INFO. +;533 ;%OPEN-CALL-BLOCK + ;USED TO "DYNAMICALLY" CONSTRUCT CALL BLOCKS. + ; SAYS N PAIRS OF QS ON STACK ARE ADI FOR + ;THIS CALL. IS CODE A LA DEST FIELD OF + ;MACROINSTRUCTION. IF THIS IS D-RETURN, AND CURRENT + ;RUNNING FRAME WAS CALLED WITH MULTIPLE VALUE ADI, AN + ;INDIRECT ADI POINTER TO THAT ADI IS PUSHED FOR THIS BLOCK. + ;RETURNS NUMBER OF WDS PUSHED. +;534 ;%PUSH DIRECTLY PUSHES IT ON LINEAR PDL. +;535 ;%ACTIVATE-OPEN-CALL-BLOCK +;536 ;%ASSURE-PDL-ROOM ASSURES THAT MORE + ;%PUSH S CAN BE DONE WITHOUT OVERFLOWING THE PDL BUFFER +;537 ;%STACK-GROUP-RETURN , WHEN RESUMED, NIL IS RETURNED. +;540 ;%STACK-GROUP-RETURN-MULTI N N. +;541 ;%TV-DRAW-CHAR +;542 ;%TV-ERASE + ;USUALLY USED FOR ERASING, BUT CAN HACK XOR ETC. +;543 ;%CALL-MULT-VALUE-LIST +;544 ;%CALL0-MULT-VALUE-LIST +;545 ;%STACK-GROUP-PRESET + ;SIMILAR TO %ACTIVATE-OPEN-CALL-BLOCK, BUT THE OPEN CALL BLOCK + ;IS TRANSFERRED TO THE TARGET STACK-GROUP TO BE ACTIVATED + ;WHEN THAT STACK-GROUP IS CALLED. APROPRIATE VARIABLES, + ;PDL-POINTERS, ETC OF THE STACK-GROUP ARE INITIALIZED. + ;ADI PRESENT IN THE OPEN CALL BLOCK IS COPIED OVER TOO, + ;EXCEPT FOR MULTIPLE-VALUE STUFF WHICH IS DISCARDED. + ;UNFORTUNATELY, DUE TO ITS SIMILARITY WITH %ACTIVATE-O-C-B.. + ;%STACK-GROUP-PRESET CAN ONLY BE USED MY MACRO-COMPILED FCTNS, + ;ALTHOUGH MOST OF THE WORK IS DONE BY AN INTERNAL ROUTINE + ;WHICH IT MAY BE POSSIBLE TO MAKE AVAILABLE TO OTHER EXECUTION + ;MODES. +;546 ;%OFFSET-MEM-STORE STORES THE DATA TYPE AND POINTER + ;OF THE MEMORY WORD DISPLACED FROM . + ; MUST BE A FIXNUM, BUT ADDR CAN BE ANY DATA TYPE. + ;(IN THIS SIMULATOR, MEM IS ADDED IF DATA-TYPE IS NOT + ; MEM-POINTER). +;547 ;%OFFSET-MEM-STORE-HIGH-HALF SIMILAR TO ABOVE, BUT + ;STORES 16 BITS OF AS HIGH 16 BITS. +;550 ;%OFFSET-MEM-STORE-LOW-HALF SIMILAR, BUT LOW 16 BITS. +;551 ;%ARRAY-INDEX-LENGTH RETURNS INDEX LENGTH OF ARG AS FIXNUM. + ;"KNOWS" ABOUT SMALL ARRAYS AND DISPLACED ARRAYS, BUT DOES NOT + ;FOLLOW INDIRECT ARRAY POINTERS. +;552 ;%ARRAY-ACTIVE-INDEX-LENGTH . SIMILAR TO ABOVE, BUT KNOWS ABOUT + ;FILL-POINTERS. IE RETURNS LEADER(0) IF IT EXISTS. +;553 ;%COMPUTE-PAGE-HASH . RETURNS FIXNUM. ON REAL MACHINE ONLY. +;554 ;GET-LOCATIVE-POINTER-INTO-ARRAY ) SIMILAR TO GET-LIST-POINTER-INTO-ARRAY + ;EXCEPT ARRAY NEED ONLY BE Q ORIENTED (INSTEAD OF ART-Q-LIT) + ;AND LOCATIVE DATA-TYPE RETURNNED. +;555 ;%UNIBUS-READ ADR +;556 ;%UNIBUS-WRITE ADR DATA +;557 ;%DISK-OPERATE + ;CAUSES DISK TRANSFER ON REAL MACHINE +;560 ;%DISK-WAIT NO ARGS. DELAYS UNTIL DISK OP COMPLETED, THEN RETURNS + ;COMPLETION STATUS. NIL MEANS NO ERROR OCCURRED. +;561 ;%AREA-NUMBER . EFFICIENTLY RETURNS AREA NUMBER TO WHICH POINTER + ;(DISREGARDING DATA TYPE) POINTS. WORKS VIA LOG SEARCH ON + ;AREA-SORTED-BY-ORIGIN. ONLY ON REAL MACHINE FOR NOW. +;562 ;%MAX N1 N2 - RETURNS MAXIMUM OF TWO NUMBERS +;563 ;%MIN N1 N2 - MINIMUM +;564 ;%SET-#-AREAS N - TEMPORARY ON REAL MACHINE TO SET A-MEM COPY OF #-AREAS +; ;ABOVE HAS BEEN FLUSHED. 5/31/77. +;565 ;CLOSURE +;566 ;DOWNWARD-CLOSURE +;567 ;LISTP +;570 ;NLISTP +;571 ;SYMBOLP +;572 ;NSYMBOLP +;573 ;ARRAYP +;574 ;FUNCTIONP +;575 ;STRINGP +;576 ;BOUNDP +;577 ;\\ ;GCD. +;600 ;FUNCTION-EVAL COUNTERPOINT TO SYMEVAL. +;601 ;AP-1 ;RETURN LOCATIVE POINTER INTO ARRAY +;602 ;AP-2 +;603 ;AP-3 +;604 ;AP-LEADER ;RETURN LOCATIVE POINTER INTO ARRAY-LEADER +;605 ;%P-LDB-OFFSET +;606 ;%P-DPB-OFFSET +;607 ;%P-MASK-FIELD-OFFSET +;610 ;%P-DEPOSIT-FIELD-OFFSET +;611 ;%MULTIPLY-FRACTIONS YIELDS BITS [23:45] OF PRODUCT +;612 ;%DIVIDE-DOUBLE YIELDS QUOTIENT +;613 ;%REMAINDER-DOUBLE YIELDS REMNDR +;614 ;HAULONG AS IN MACLISP. +;615 ;%ALLOCATE-AND-INITIALIZE + ;
+;616 ;%ALLOCATE-AND-INITIALIZE-ARRAY
+ ; +;617 ;%MAKE-OFFSET-POINTER +;620 ;^ EXPONENTIATION AS IN MACLISP +;621 ;%CHANGE-PAGE-STATUS VIRTUAL ADDRESS, SWAP STATUS, ACCESS STATUS AND META BITS +;622 ;%CREATE-PHYSICAL-PAGE PHYSICAL ADDRESS +;623 ;%DELETE-PHYSICAL-PAGE PHYSICAL ADDRESS + +IFN FNASW,[ +; CLOSURE MAKE A CLOSURE CALLING AND CLOSING +; AS REQUESTED. CONS STORAGE. +; CLOSED-DESC-LIST IS A LIST OF LOCATIVES TO +; SYMBOL COMPONENTS TO BE CLOSED, OPTIONALLY FOLLOWED BY A LIST OF NUMBERS. +; THESE NUMBERS INDICATE SLOTS WITHIN THE CURRENT FRAME, WHICH ARE TO BE +; COMMUNICATED TO THE CLOSED FUNCTION (THEY ARE PROBABLY IN THE FORM OF +; STANDARD MACRO-CODE EFFECTIVE-ADRS.) +; DOWNWARD-CLOSURE SIMILAR BUT TAKE STORAGE FROM L-B-P +; INSTEAD OF CONSING IT. TO CAUSE THIS STORAGE TO GET POPPED EVENTUALLY, +; DOWNWARD-CLOSURE SETS THE LPFNLB BIT IN THE CURRENTLY OPEN CALL BLOCK. +; THIS BIT IS TESTED BY LOCATING IT CONTIGOUS WITH THE MACRO-SAVED-DESTINATION, +; AND DISPATCHING ON THE COMBINED FIELD. IF THE LPFNLB BIT IS ALREADY SET, IT +; MEANS THAT THIS FUNCTION IS BEING CALLED WITH MORE THAN ONE DOWNWARD-CLOSED FUNCTIONAL +; ARGUMENT. IT THAT CASE, THE L-B-P BLOCK OF THIS ONE IS COMBINED WITH THAT ONE. +; (BY FAILING TO SET BUSRC IN THE FIRST Q PUSHED.) +] + + +;DESTINATION CODE (3 BITS) 7000 + + ;DISCARD + ;TO STACK + ;TO "NEXT", QUOTED BIT => 0 + ;TO "LAST", QUOTED BIT =>0 + ;TO "RETURN" + ;TO "NEXT", QUOTED BIT => 1 + ;TO "LAST", QUOTED BIT => 1 + ;TO "NEXT LIST" + ;STORE DATA IN CAR OF ITEM PNTED TO BY TOP OF STACK + ;THEN REPLACE TOP OF STACK ITEM BY ITS CDR + ;IF IT IS THEN ATOMIC, POP IF OFF STACK + ;USE THE NEXT ITEM ON STACK AS A DESTINATION + ;FOR STORING THE THIRD ITEM ON STACK + ;(IE PNTR TO HEAD OF LIST) +;ADDRESS (9 BITS 777) + + ;REGISTER (3 BITS 700) + ;FEF + ;FEF +100 + ;FEF +200 + ;FEF +300 + ;SHARED QUOTED CONSTANTS PAGE + ;LOCAL BLOCK + ;ARGS + ;PDL + ;IV-EFF-AD PNTRS USED IN FEF FOR FUNCTION CELLS AND VALUE CELLS + + ;DISPLACEMENT (6 BITS 77) + ; IN Q'S + ;ADDS EXCEPT SUBTRACTS FROM PDL + + ;ADR PDL 77 REALLY MEANS TOP OF STACK, WHICH IS POPPED WHEN EFFECTIVE ADR COMPUTED + + + +ZZ==. +LOC 41 + JSR UUOH + +LOC ZZ + +QMLP: +QMLPR: SKIPGE A,MEM(PC) ;FETCH PC + PUSHJ P,ITRAP ;INTERPRETER TRAP + JUMPL PC,QMLP1B + TLO PC,400000 ;INCREMENT PC + ANDI A,177777 +QMLP1A: MOVEM A,INST ;SAVE INSTRUCTION +IN: MOVE B,A ;GOOD PLACE TO BREAKPOINT + ANDI B,777 ;ADDR OR MISC FUNCT # + LDB E,[60300,,A] ;"INDEX" FIELD IF ADDR + LDB C,[110300,,A] ;DESTINATION CODE + LDB D,[140400,,A] ;OP CODE + PUSHJ P,@OPDTBA(D) + JRST QMLP + +QMLP1B: ADD PC,[400000,,1] ;INCREMENT PC +QMLP1E: LSH A,-16. + JRST QMLP1A + +ILLOP: BARF ILLOP! + ;ERROR HANDLER (A LA UCODE) +IVAACT: BARF INVOKE POINTER? + ;ACTIVATE INVOKE POINTER + +QIERR1: BARF UNDEFINED OP CODE, + + +QAFE: ADD B,LPFEF(AP) ;POINTER TO FEF OF FCTN RUNNING +QADR1: SKIPGE T,MEM(B) ;FETCH C(E) + PUSHJ P,ITRAP +QADR2: LDB Q,[%NDTB,,T] ;GET DATA TYPE + JRST @QADDTB(Q) + +QADDR: JRST @OPDTB(D) + +QADIVG: SKIPGE J,MEM(T) ;DATA TYPE OF C(E) GC INVZ, LEAVE E THE SAME + PUSHJ P,ITRAP ;BUT CLOBBER C(E) TO C(C(E)) + DPB J,[%NDAT,,MEM(B)] + JRST QADR1 + +QADIVE: MOVE B,T ;INVISIBLE ON EFFECTIVE ADR COMP + JRST QADR1 + +QAQT: MOVEI B,QQTPG-400-MEM(B) + JRST QADR1 + +QADLOC: ADD B,QLOCO ;OFFSET OF LOCAL BLOCK FROM ARG PNTR + ADDI B,-500-MEM(AP) ;LPLOFF ALREADY ACCOUNTED FOR IN QLOCO + JRST QADR1 + +QADARG: ADDI B,-600-MEM+LPLOFF(AP) + JRST QADR1 + + +QADPDL: CAIN B,777 + JRST QMAD1 ;SPECIAL REF TO TOP OF STACK AND POP + MOVNI B,-700(B) + ADDI B,-MEM(IP) + JRST QADR1 + +QMAD1: MOVEI B,-MEM(IP) + SOJA IP,QADR1 + +QIERR2: BARF BAD OP CODE ON OPDTB DISPATCH + +QADTRP: BARF ILLEGAL DATA TYPE IN CONTENTS OF EFF ADDR. + +QICDDR: PUSHJ P,QCDR +QICDR: PUSHJ P,QCDR ;(REPLACE T WITH (CDR T) +QIMOVE: TLZ PC,QINDAT+QINDNL ;STORE C(T) IN DESTINATION IN C + LDB J,[%NDTB,,T] + JRST @QNDDT1(J) ;DISP ON DATA TYPE + +QIMOV1: TDNN T,[37,,-1] + TLO PC,QINDNL +QIMOV7: TLO PC,QINDAT + JRST @QMDTBD(C) ;DISP ON DESTINATION + + +QICADR: PUSHJ P,QCDR +QICAR: PUSHJ P,QCAR + JRST QIMOVE + +QICAAR: PUSHJ P,QCAR + JRST QICAR + +QICDAR: PUSHJ P,QCAR + JRST QICDR + + +QMA: ;ENTRY AS MISC INSTRUCTION +QCAR: LDB J,[%NDTB,,T] ;TAKE (CAR T), RESULT TO T + XCT CAPRDT(J) ;CAR-PRE-DISPATCH + +QCARSY: LDB I,[%CSYMM,,QCARM] ;TAKING CAR OF SYM, SEE WHAT TO DO + CAIGE I,NCARSM + JRST @CASYMD(I) +QCASYE: BARF CAR OF A SYMBOL,T/& + +QCASE1: TDNN T,[37,,-1] + JRST QCDNIL + JRST QCASYE + +QCARNM: LDB I,[%CNUMM,,QCARM] ;TAKING CAR OF NUMBER, SEE WHAT TO DO + CAIGE I,NCARNM + JRST @CANUMD(I) +QCANME: BARF CAR OF A NUMBER,T/& + +CAGCIV: +CAEIV: JRST QCAR3 ;GOT IV POINTER ON FIRST TRY, TRY AGAIN + +QCARMP: SUBI T,MEM ;MEMORY POINTER +QCAR3: LDB T,[%NDAT,,MEM(T)] ;NORMAL RETURN FOR "TAKE THE CAR" (LIST, ETC) + LDB I,[%NDTB,,T] + XCT CAPODT(I) ;CAR POST DISPATCH + BARF CAR POST DISPATCH LOST,T/& + +QCAR5: LDB T,[%NDAT,,MEM(T)] ;INVISIBLE + JRST QCAR + + +QMD: ;ENTRY AS MISC INST +QCDR: LDB J,[%NDTB,,T] + XCT CDPRDT(J) ;CDR-PRE-DISPATCH + BARF CDR OF ILLEGAL DATATYPE + +QCDRSY: LDB I,[%CSYMM,,QCDRM] ;TAKING CDR OF ATOM + CAIGE I,NCDRSM + JRST @CDSYMD(I) +QCDSYE: BARF CDR OF A SYMBOL,T/& + +QCDSE1: TDNN T,[37,,-1] + JRST QCDNIL + JRST QCDSYE + +QCDRNM: LDB I,[%CNUMM,,QCDRM] ;TAKING CDR OF NUMBER + CAIGE I,NCDRNM + JRST @CDNUMD(I) +QCDNME: BARF CDR OF A NUMBER,T/& + +QCDPRP: ADDI T,3 ;RETURN PROP CELL + TLZ T,777740 ;TURN IT INTO A LOCATIVE + TLO T,QZXSYM_5 + JRST QCDR + +CDGCIV: +CDEIV: +CDCCIV: LDB T,[%NDAT,,MEM(T)] ;CAR POSITION HAD IV POINTER +QCDR3: ;TAKE CAR FIRST + LDB I,[%NDTB,,MEM(T)] + XCT CDCADT(I) ;CDR-CAR-DISPATCH + LDB I,[%NCDRB,,MEM(T)] + XCT CDCDDT(I) ;CDR-CDR-DISPATCH + +QCDFN: LDB T,[%NDAT,,MEM+1(T)] ;FULL NODE + LDB I,[%NDTB,,T] + XCT CAPODT(I) ;CAR-POST-DISPATCH + BARF CAR POST DISPATCH LOSES,I/ + +QCDNIL: MOVSI T,QZSYM_5 ;CDR NIL + POPJ P, + +QCDNXT: TLZ T,777740 ;CDR NEXT + TLO T,QZLIST_5 + AOJA T,CPOPJ + +POPJ1: AOS (P) +CPOPJ: POPJ P, + +QCDR5: LDB T,[%NDAT,,MEM(T)] ;Q-FORWARD D.T. ON INPUT + JRST QCDR + + +XRPLCA: POP IP,T ;RPLACA + POP IP,S +QRAR1: LDB J,[%NDTB,,S] + JRST @QRACDT(J) + +QRATR1: BARF RPLACAING BAD DATA TYPE +QRATR2: BARF RPLACAING INVOKE PNTR +QRATR3: BARF RPLACAING FREE DATA TYPE + +QRASYM: LDB I,[%CSYMM,,QCARM] ;RPLACA ING SYM, SEE WHAT TO DO + TDNN S,[37,,-1] + JRST QRASYE ;RPLACA ING NIL ALWAYS ERROR + CAIGE I,NCARSM + JRST @RASYMD(I) +QRASYE: BARF RPLACAING SYMBOL + +QRANUM: LDB I,[%CNUMM,,QCARM] ;RPLACA ING NUMBER + CAIGE I,NCARNM + JRST @RANUMD(I) +QRANME: BARF RPLACAING NUMBER + +QRARMP: SUBI S,MEM ;MEMORY POINTER + TLZ S,NDTB ;CHANGE IT TO A LOCATIVE + TLO S,QZXSYM_5 + JRST QRAR3 + +QRAR3A: MOVE S,I +QRAR3: SKIPGE I,MEM(S) ;NORMAL RETURN FOR "DO THE RPLACA" + PUSHJ P,ITRAP + DPB T,[%NDAT,,MEM(S)] + MOVE T,S + POPJ P, + +QRAR5: SKIPGE I,MEM(S) ;INVISIBLE + PUSHJ P,ITRAP + MOVE S,I + JRST QRAR1 + + +XRPLCD: POP IP,T ;RPLACD + POP IP,S +QRDR1: LDB J,[%NDTB,,S] + JRST @QRDCDT(J) + +QRDTR1: HALT ;RPLACD ING BAD DATA TYPE +QRDTR2: HALT ;RPLACD ING INVOKE DATA TYPE +QRDTR3: HALT ;RPLACD ING FREE DATA TYPE + +QRDRSY: LDB I,[%CSYMM,,QCDRM] ;RPLACD ING SYMBOL + CAIGE I,NCDRSM + JRST @RDSYMD(I) +QRDSYE: HALT + +QRDRNM: LDB I,[%CNUMM,,QCDRM] ;RPLACD ING NUMBER + CAIGE I,NCDRNM + JRST @RDNUMD(I) +QRDNME: HALT + +QRDPRP: ADDI S,3 ;RPLACD ING SYMBOL, STORE INTO PROP CELL + TLZ S,777740 + TLO S,QZXSYM_5 ;TURN IT INTO A LOCATIVE + JRST QRDR1 + +QRDR3: SKIPGE I,MEM(S) ;TAKE CAR FIRST + PUSHJ P,ITRAP + LDB I,[%NCDRB,,I] + JRST @QRDRCD(I) ;RPLACD-CDR-DISPATCH + +QRDRCD: QRDFN ;FULL NODE + QRDRE ;ERROR + QRDRNL ;CDR NIL + QRDRNX ;CDR NEXT + +QRDRE: HALT + +QRDFN: SKIPGE I,MEM+1(S) ;RPLACD FULL NODE + PUSHJ P,ITRAP + DPB T,[%NDAT,,MEM+1(S)] + MOVE T,S + POPJ P, + +QRDRNL: TLZ T,RBMSK + CAMN T,[QZSYM_5,,] + POPJ P, ;ITS ALREADY NIL + JRST QRDRN1 + +QRDRNX: TLZ T,RBMSK + CAMN T,[QZSYM_5,,] + JRST QRDRN2 ;JUST CHANGE CDR CODE TO NIL +QRDRN1: PUSH IP,S ;DO CONS.. + PUSH IP,T + MOVE S,CNSADF ;DEFAULT AREA TO DO CONSES IN + PUSHJ P,IALL2Q ;GOBBLE TWO Q'S + MOVE B,T + POP IP,T + POP IP,S + TLO B,NXTNIL+ ;ZONK IN INVIZ DATA TYPE. NXTNIL DATA TYPE IS JUST + SKIPGE A,MEM(S) ;FOR ADDITIONAL SAFETY + PUSHJ P,ITRAP + MOVEM B,MEM(S) + TLZ A,NXTCDR ;NOW FULL NODE + MOVEM A,MEM(B) + TLO T,NXTNOT + MOVEM T,MEM+1(B) ;STORE IN NEW CDR + HRRZ T,B + TLO T,QZLIST_5 ;RETURN POINTER TO NEW FULL NODE + POPJ P, + +QRDRN2: MOVEI I,NXTNIL_-12. ;CHANGE CDR CODE TO NXTNIL + DPB I,[%NCDRB,,MEM(S)] + MOVE T,S + POPJ P, + +QRDR5: SKIPGE I,MEM(S) ;ANY INVZ + PUSHJ P,ITRAP + MOVE S,I + JRST QRDR1 + +QMDDNQ: +; TLO PC,QBNEAF ;HAVE STORED "QUOTED" ARG + TLOA T,NUSRCB +QMDDN: TLZ T,NUSRCB ;TO NEXT ARG +QMDDS: TLO T,NXTCDR + PUSH IP,T + POPJ P, + + + +QMDDLQ: +; TLO PC,QBNEAF ;HAVE STORED "QUOTED" ARG + TLOA T,NUSRCB +QMDDL: TLZ T,NUSRCB ;TO LAST ARG + TLO T,NXTNIL + PUSH IP,T +QMRCL: MOVE S,IPMARK ;GET POINTER TO FEF TO CALL (PREVIOUSLY STORED) + HRRZ ZR,IP + SUBI ZR,(S) + MOVEM ZR,NARGS + SKIPGE A,LPFEF(S) + PUSHJ P,ITRAP + LDB B,[%NDTB,,A] + SKIPL DQMRC1(B) + PUSHJ P,QLLV + XCT DQMRCL(B) ;CAN UNSKIP TWICE IF SYM OR INVZ + +INTP1: MOVE E,NARGS + MOVE AP,IP + SUBI AP,(E) + HRRZM AP,IPMARK + TLZ PC,QBBFL+QINDAT+QINDNL ;+QBNEAF + JUMPE E, [MOVSI T, ;GET POINTER TO LIST OF ARGS + JRST INTP3] + MOVEI J,NXTCDR_-12. + MOVEI I,1(S) + MOVEI T,-MEM(I) + TLO T,QZLIST_5 +INTP4: DPB J,[%NCDRB,,(I)] + AOS I + SOJG E,INTP4 + MOVEI J,NXTNIL_-12. + DPB J,[%NCDRB,,-1(I)] +INTP3: MOVE ZR,LPCLS(S);"INTERPRETER TRAP" + TLNE ZR,(LPADL) + PUSHJ P,INTP5 ;DUMMY UP RIGHT ADDITIONAL INFO + PUSHJ P,P3ZERO + PUSH IP,SUPV+SVCAPL ;FUNCTION CELL TO APPLY-LAMBDA + PUSH IP,LPFEF(S) ;FUNCTION TO BE INTERPRETED + PUSH IP,T ;LIST OF ARGS + JSR 2,MMCALL ;APPLY THE GUY +INTRET: PUSH P,T + JRST QMEX1 + +INTP5: MOVEI R,-LLPFRM(S) +INTP6: LDB J,[%ADITP,,(R)] + JRST .+1(J) + HALT ;0 ERR + JRST INTP10 ;1 MULTIPLE VALUE RETURN + JRST INTP7 ;2 RESTART PC + JRST INTP20 ;3 FEXPR CALL + JRST INTP20 ;4 FEXPR CALL + JRST INTP7 ;5 BINDING PDL LEVEL + HALT ;6 ERR + HALT ;7 USED UP MV RETURN INFO + +INTP7: MOVSI J,NUSRCB + TDNN J,-1(R) + JRST INTP9 + SUBI R,2 + JRST INTP6 + +INTP20: MOVE J,NARGS ;PSEUDO SPREAD REST ARG + CAIG J,1 + SKIPA T,MEM(T) + CAIA + JRST INTP7 + MOVEI J,0 ;CDR NORMAL + DPB J,[%NCDRB,,-2(I)] + MOVEI J,NXTNOT + DPB J,[%NCDRB,,-1(I)] + JRST INTP7 + +INTP10: HRLI R,QZMEMP_5 ;MULT VAL RETURN, MAKE INDIRECT POINTER + PUSH IP,R + PUSH IP,[NUSRCB+QZFIX_5,,0] + MOVEI ZR,ADIP + DPB ZR,[%ADIRB,,(IP)] + MOVEI ZR,ADIRT + DPB ZR,[%ADITP,,(IP)] + JRST INTP7 + +INTP9: TLNN R,QZMEMP_5 + POPJ P, + PUSHJ P,P3ZERO + MOVSI R,(LPADL) + IORM R,LPCLS+1(IP) + JRST POPJ1 + +QMRCL1: TDNN A,[37,,-1] + BARF ATTEMPT TO CALL NIL AS A FUNCTION + MOVE A,MEM+2(A) ;GET FUNCTION CELL +QMRCL4: LDB B,[%NDTB,,A] + XCT ILLOBF(B) + MOVEM A,LPFEF(S) + POP P,D + JRST -3(D) ;UNSKIP ON RETURN SO AS TO TEST DQMRC1 AGAIN + +QMRCL3: MOVE A,MEM(A) ;CALLING INVZ AS FCTN + JRST QMRCL4 + +IFN FNASW,[ +;DISPATCH ENTRY THAT GETS HERE HAS DOES DO QLLV, ETC +QCLS: ;1) PUSH CLOSURE POINTER ON BINDING STACK WITH USRC BIT SET + ; (SO ITS AVAILABLE FOR DEBUGGING) --NOT DOING THIS INITIALLY-- + ;2) SMASH LPFEF WITH (CAR FNARG) + ;3) GET LIST-TO-BIND AT (CDR FNARG) + ;4) FOR EACH FROB, + ; IF (%DATTP CLOSED-LOC) IS XXX, IT POINTS TO SYMBOL-COMPONENT. + ; BIND TO NEWVAL. + ; IF (%DATTP CLOSED-LOC) IS XXX, REST OF LIST IS + ; LOCATIVES TO DESIRED LOCAL VALUE CELLS, STOP INTERPRETING + ; LIST FOR NOW AND PUT ASIDE POINTER IN SIDE EFFECT + ; REGISTER TO BE DUG OUT BY QLENTR AT THE APPROPRIATE TIME. + ; REDISPATCH ON NEW FUNCTION TYPE, W/O DOING QLLV, ETC. + MOVE T,A + PUSHJ P,QCAR ;COULD REAL MACHINE AFFORD TO INTERRUPT HERE? + MOVEM T,LPFEF(S) ;REPLACE CLOSURE BY CLOSED FCTN. + EXCH T,A + PUSHJ P,QCDR ;GET BINDING LIST. + TLZ PC,QBBFL ;THIS WILL BE A NEW BLOCK +QCLS1: CAMN T,[QZSYM_5,,] ;BINDING LIST IS AN A-LIST STORED IN P-LIST FORM. + JRST QCLS2 + MOVE D,T + PUSHJ P,QCAR + MOVE B,T ;LOCN TO BIND + MOVE T,D + PUSHJ P,QCDR + MOVE D,T + PUSHJ P,QCAR ;GET NEW BINDING + PUSHJ P,QBND1 ;SAVE PREVIOUS BINDING + DPB T,[%NDAT,,MEM(B)] ;STORE NEW BINDING + MOVE T,D + PUSHJ P,QCDR + JRST QCLS1 + +QCLS2: LDB ZR,[.BP PC] ;IF ANY BINDINGS PUSHED, + DPB ZR,[<.BP LPFNAB> LPCLS(S)] ;SET LPFNAB BIT TO POP THEM EVENTUALLY. + LDB B,[%NDTB,,A] + JFCL ;IN CASE IT UNSKIPS + JFCL + XCT DQMRCL(B) +] + +QMDDNL: MOVE S,(IP) ;POINTER TO NEXT PLACE IN LIST TO STORE + SKIPGE MEM(S) + PUSHJ P,ITRAP + DPB T,[%NDAT,,MEM(S)] ;STORE CRUFT + MOVE T,S + PUSHJ P,QCDR + MOVEM T,(IP) ;STORE BACK POINTER + TDNE T,[37,,777777] + POPJ P, ;NOT THRU WITH LIST + POP IP,T + POP IP,C ;SAVED DESTINATION + POP IP,T ;POINTER TO HEAD OF LIST + LDB S,[%NDTB,,C] + TDNN C,[37,,777770] ;THIS SHOULD BE DESTINATION SIZE + CAIE S,QZFIX + JRST QMDDE1 + JRST QIMOVE ;STORE IN DESTINATION + +QMDDE1: HALT + + +QARYR: PUSHJ P,GAHD1 ;GET ARRAY HEADER + CAME D,NARGS ; IN NEW SCHEME, RETURNS ARRAY LENGTH IN ELEMENTS IN S + HALT + MOVEI Q,0 + MOVEI E,1(A) ;COMPUTE INDEX + TRNE B,ARYEXL + AOS E ;SPACE PAST EXTENDED LENGTH Q +QARYR2: SOJLE D,QARYR1 + POP IP,R ;MULTI-DIMENSION ARRAY + LDB ZR,[%NDTB,,R] + CAIE ZR,QZFIX + HALT + SKIPGE I,MEM(E) + PUSHJ P,ITRAP + ADDI Q,(R) + IMULI Q,(I) + AOJA E,QARYR2 + +GAHD4: CAIN ZR,QZSTKG + JRST GAHD1 ;STACK GROUP OK + BARF ARRAY REFERENCE NOT TO AN ARRAY,A/& + +GAHDRA: POP IP,A +GAHDR: LDB ZR,[%NDTB,,A] ;IN NEW SCHEME OF THINGS, RETURNS INDEX LIMIT OF + CAIE ZR,QZARYP ;ARRAY ITSELF IN S (INCLUDES DISPLACED, BUT NOT INDEX + ;OFFSET OR INDIRECT HACKAGE). + JRST GAHD4 +GAHD1: SKIPGE B,MEM(A) ;GET ARRAY HEADER + PUSHJ P,ITRAP + LDB ZR,[%NDTB,,B] + CAIE ZR,QZARYH + JRST QARYR3 ;ARRAY PNTER DOESNT POINT TO ARRAY HEADER + LDB D,[%ARYND,,B] + MOVEI E,(A) ;ADR OF FIRST DATA ELEMENT OR DISPLACED POINTER IF + ADD E,D ;DISPLACED + TRNE B,ARYEXL + JRST GAHD2 + LDB S,[%ARYL,,B] +GAHD3: TRNN B,ARDSPB ;SMALL ARRAY + POPJ P, + LDB ZR,[%NDTB,,MEM+1(E)] ;DISPLACED ARRAY, LIMIT IS WHERE SECOND DATA WD WOULD BE + CAIE ZR,QZFIX + HALT + LDB S,[%NPTR,,MEM+1(E)] + POPJ P, + +GAHD2: LDB ZR,[%NDTB,,MEM+1(A)] ;EXTENDED ARRAY + CAIE ZR,QZFIX + HALT + LDB S,[%NPTR,,MEM+1(A)] + AOJA E,GAHD3 + +QARYR3:; CAIE ZR,QZIVGC +; CAIN ZR,QZIVCE +; JRST QARYR4 +; CAIN ZR,QZIVCC +; JRST QARYR4 + BARF ARRAY POINTER DID NOT POINT TO ARRAY HEADER,A/&B/& + +QARYR4: SKIPGE A,MEM(A) + PUSHJ P,ITRAP + JRST GAHD1 + +XAIXL: PUSHJ P,GAHDRA ;(%ARRAY-INDEX-LENGTH ) +XAIXL1: HRRZ T,S + TLO T,QZFIX_5 + POPJ P, + +XAAIXL: PUSHJ P,GAHDRA ;(%ARRAY-ACTIVE-INDEX-LENGTH ) + TDNN B,[ARXIB] + JRST XAIXL1 + MOVE T,MEM-2(A) ;HAS LEADER, RETURN FILL POINTER + POPJ P, + + +QARYR1: POP IP,R ;POP OFF LAST GUY + LDB ZR,[%NDTB,,R] + CAIE ZR,QZFIX + BARF ARRAY-REF OF A NON-FIXNUM,R/& + ADDI Q,(R) + LDB R,[%ARYTP,,B] + MOVEM A,QLARYH ;PNTR TO HEADER OF LAST ARRAY + MOVEM Q,QLARYL ;LAST ELEMENT NUMBER REF ED + TRNN B,ARDSPB + JRST QARYR5 + LDB ZR,[%NDTB,,MEM(E)] + CAIN ZR,QZARYP ;ELEMENT NUMBER IN Q + PUSHJ P,QDACMP ;THIS ARRAY POINTS AT THAT ARRAY'S DATA. + ;COMPUTE EFFECTIVE BASE DATA ADDRESS OF ARRAY-HEADER + ;POINTED TO BY MEM(E) AND SKIP!!! + MOVE E,MEM(E) ;ARRAY DISPLACED +QARYR5: ;WITH NEW SCHEME, LIMIT IS IN ENTRIES, NOT Q'S + CAML Q,S + BARF ARRAY OUT OF BOUNDS,Q/&S/& + PUSHJ P,@QARYDT(R) ;DISPATCH ON TYPE OF ARRAY + MOVE B,LPCLS(IP) +IFN FNASW,[ + TLNE B,(LPFNAB) ;POP FUNARG (CLOSURE) BLOCK IF ANY PUSHED (THIS IS PRETTY + PUSHJ P,BBLKP ; RANDOM, IT COULD BE DEFINED TO BE AN ERROR). +] + LDB J,[%LPCPN,,B] ;DELTA TO IP MARK + HRRZ ZR,IP + SUB ZR,J + MOVEM ZR,IPMARK + SUBI IP,LLPFRM + TLNE B,(LPADL) + PUSHJ P,QRAD1 ;MULT-VAL CALL STORE LAST VALUE IN RIGHT PLACE, ETC + LDB C,[%NDTB,,LPFEF(AP)] + JRST @QMXRT1(C) ;DISPATCH ON FLAVOR OF CODE RETURNNING TO + +QBARY1: LDB C,[%LPCSD,,B] ;RETREIVE SAVED DESTINATION IN A GOOD PLACE +; TLZ PC,QBNEAF +; TLNE B,(LPCPLI) +; TLO PC,QBALM +; TLNE B,(LPCARV) +; TLO PC,QBNEAF + JRST QIMOVE ;STORE IT IN DESIRED PLACE + +QBARY2: LDB E,[%LPMPC,,LPEXS(AP)] + JSP (E) ;RETURN (SAVE RET ADR HERE FOR DEBUGGING HA HA) + +QBAERR: HALT + + +QBARY: LDB J,[200,,Q] ;BYTE ADDRESS + LSH Q,-2 + ADD E,Q + LDB T,QBBYP(J) + HRLI T,QZFIX_5 + POPJ P, + +QBBYP: 1000,,MEM(E) + 101000,,MEM(E) + 201000,,MEM(E) + 301000,,MEM(E) + +QB1RY: LDB J,[500,,Q] ;BIT ARRAY + LSH Q,-5 + ADD E,Q + LDB T,Q1BYP(J) + HRLI T,QZFIX_5 + POPJ P, + + +Q1BYP: REPEAT 32.,<<.RPCNT>_12.+100>,,MEM(E) + +QB2RY: LDB J,[400,,Q] ;2 BIT ARRAY + LSH Q,-4 + ADD E,Q + LDB T,Q2BYP(J) + HRLI T,QZFIX_5 + POPJ P, + + +Q2BYP: REPEAT 16.,<<2*.RPCNT>_12.+200>,,MEM(E) + +QB4RY: LDB J,[300,,Q] ;4 BIT ARRAY + LSH Q,-3 + ADD E,Q + LDB T,Q4BYP(J) + HRLI T,QZFIX_5 + POPJ P, + + +Q4BYP: REPEAT 8,<<4*.RPCNT>_12.+400>,,MEM(E) + +QB16RY: LDB J,[100,,Q] ;16 BIT ARRAY + LSH Q,-1 + ADD E,Q + LDB T,Q16BYP(J) + HRLI T,QZFIX_5 + POPJ P, + +Q16BYP: 2000,,MEM(E) + 202000,,MEM(E) + + +QQARY: ADD E,Q ;COMPUTER Q ADR + SKIPGE T,MEM(E) + PUSHJ P,ITRAP ;GET DESIRED ARRAY ELEMENT + POPJ P, + +XAP3: PUSHJ P,XAR3 + JRST XAP1A + +XAP2: PUSHJ P,XAR2 + JRST XAP1A + +XAP1: PUSHJ P,XAR1 ;RETURN LOCATIVE POINTER TO ARRAY ELEMENT +XAP1A: CAIN R,ARTLAR ;R SET UP FROM ARRAY REF + JRST XAP1B + CAIE R,ARTSGH + JRST ILLOP +XAP1B: LDB T,[%NPTR,,E] ;ALSO SET UP FROM ARRAY REF + TLO T,QZXSTR_5 + POPJ P, + +XAS1: TDZA C,C +XAR1: MOVEI C,1 + POP IP,Q ;REF SINGLE DIMENSION ARRAY + PUSHJ P,GAHDRA + CAIE D,1 + BARF AR-1 ARRAY NOT ONE DIMENSION,A/& +XAR1A: LDB ZR,[%NDTB,,Q] + CAIE ZR,QZFIX + BARF AR-1 ELEMENT NUMBER NOT A NUMBER,Q/& + HRRZS Q + TRNE B,ARDSPB + JRST [ LDB ZR,[%NDTB,,MEM(E)] + CAIN ZR,QZARYP ;ELEMENT NUMBER IN Q + PUSHJ P,QDACMP ;THIS ARRAY POINTS AT THAT ARRAY'S DATA. COMPUTE + ;ITS EFFECTIVE BASE ADDRESS, RETURN IT IN E AND SKIP!! + MOVE E,MEM(E) + JRST .+1] + LDB R,[%ARYTP,,B] + CAML Q,S + BARF ARRAY REFERENCE OUT OF BOUNDS - QTH ELEMENT OF S LONG ARRAY,Q/=S/= + XCT XADTB(C) + POPJ P, + +XADTB: JRST XSACOM + PUSHJ P,@QARYDT(R) + +XSACOM: POP IP,T ;ON STORE + JRST @QSADT(R) + +XAS2: TDZA C,C +XAR2: MOVEI C,1 + POP IP,J ;REF TWO DIMENSION ARRAY + POP IP,Q + PUSHJ P,GAHDRA + CAIE D,2 + HALT +XAR2A: LDB ZR,[%NDTB,,J] + CAIE ZR,QZFIX + HALT + IMUL J,MEM-1(E) + ADDI Q,(J) + JRST XAR1A + +XAS3: TDZA C,C +XAR3: MOVEI C,1 + POP IP,I + POP IP,J + POP IP,Q + PUSHJ P,GAHDRA + CAIE D,3 + HALT + LDB ZR,[%NDTB,,I] + CAIE ZR,QZFIX + HALT + IMUL I,MEM-2(E) + ADDI J,(I) + JRST XAR2A + +XGLOPR: POP IP,ZR ;GET-LOCATIVE-POINTER-INTO-ARRAY. SIMILAR TO + MOVE A,QLARYH ;GET-LIST-POINTER-INTO-ARRAY BUT WINS IF ARRAY IS STORED + PUSHJ P,GAHD1 ;Q-WISE AND RETURNS LOCATIVE DATA-TYPE. + LDB R,[%ARYTP,,B] + MOVE ZR,ENTPQ(R) + CAIE ZR,1 + HALT + MOVSI T,QZXSYM_5 ;WOULD BE QZXSTR ON REAL MACHINE + JRST XGLOP1 + +XGLPA: POP IP,ZR ;FUNCTION OF ONE ARG. IT IGNORES THE ARG + ;BUT REFERENCES "SIDE EFFECT" REGS A LA STORE + ;RETURNS LIST POINTER TO ELEMENT REF'ED + MOVE A,QLARYH ;CAR OF VALUE WILL BE ELEMENT REF'ED + PUSHJ P,GAHD1 + LDB R,[%ARYTP,,B] + CAIE R,ARTLAR + HALT + MOVSI T,QZLIST_5 +XGLOP1: MOVE Q,QLARYL + TRNE B,ARDSPB + JRST [ LDB ZR,[%NDTB,,MEM(E)] + CAIN ZR,QZARYP ;ELEMENT NUMBER IN Q + PUSHJ P,QDACMP ;THIS ARRAY POINTS AT THAT ARRAY'S DATA. COMPUTE ADR + ;AND SKIP!! + MOVE E,MEM(E) + JRST .+1] + CAML Q,S + HALT + ADD E,Q + HRR T,E ;DESIRED DATA-TYPE ALREADY IN T + POPJ P, + +XGLPAR: POP IP,A ;G-L-P + PUSHJ P,GAHDR + LDB ZR,[%ARYTP,,B] + CAIE ZR,ARTLAR + HALT ;NOT ART-Q-LIST ARRAY + TDNE B,[ARXIB] + JRST XGPAR1 ;ARRAY-LEADER EXISTS, IS FILL POINTER 0? +XGPAR2: MOVEI Q,0 ;WANT TO REF "ELEMENT 0" + TRNE B,ARDSPB + JRST [ LDB ZR,[%NDTB,,MEM(E)] ;DISPLACED + CAIN ZR,QZARYP ;ELEMENT NUMBER IN Q + PUSHJ P,QDACMP ;THIS ARRAY POINTS AT THAT ARRAY'S DATA. SKIP ON RETURN + MOVE E,MEM(E) + JRST .+1] + ADD E,Q ;COULD BE NON-ZERO IF INDEX-DISPLACED + HRRZ T,E + TLO T,QZLIST_5 + POPJ P, + +XGPAR1: MOVE ZR,MEM-2(A) + TLZ ZR,RBMSK + CAMN ZR,[QZFIX_5,,] + JRST XFALSE ;FILL POINTER 0, RETURN NIL + JRST XGPAR2 + +XXSTOR: POP IP,ZR ;STORE IN LAST ARRAY ELEMENT REFERENCED. + ;TAKES TWO ARGUMENTS, WHICH ARE EXCHANGED FROM THE + MOVE A,QLARYH ;WAY STORE IS NORMALLY WRITTEN IN LISP. HOWEVER, + MOVE Q,QLARYL ;XSTORE IS A SUBR AND DOES NOT EVALUATE ITS ARGUMENTS + POP IP,T ;IN REVERSE ORDER, AS STORE DOES IN PDP10 LISP. + PUSHJ P,GAHD1 + LDB R,[%ARYTP,,B] + TRNE B,ARDSPB + JRST XXST1 + CAML Q,S + HALT + JRST @QSADT(R) + +XXST1: LDB ZR,[%NDTB,,MEM(E)] + CAIN ZR,QZARYP + PUSHJ P,QDACMP + MOVE E,MEM(E) + CAML Q,S + HALT + JRST @QSADT(R) + +QSAERR: HALT + + +QSBARY: LDB J,[200,,Q] + LSH Q,-2 + ADD E,Q + DPB T,QBBYP(J) + POPJ P, + +QS1RY: LDB J,[500,,Q] + LSH Q,-5 + ADD E,Q + DPB T,Q1BYP(J) + POPJ P, + +QS2RY: LDB J,[400,,Q] + LSH Q,-4 + ADD E,Q + DPB T,Q2BYP(J) + POPJ P, + +QS4RY: LDB J,[300,,Q] + LSH Q,-3 + ADD E,Q + DPB T,Q4BYP(J) + POPJ P, + +QS16RY: LDB J,[100,,Q] + LSH Q,-1 + ADD E,Q + DPB T,Q16BYP(J) + POPJ P, + +QS32RY: ADD E,Q + MOVEM T,MEM(E) + POPJ P, + +QSQARY: ADD E,Q + DPB T,[%NDAT,,MEM(E)] + POPJ P, + + +XSALDR: POP IP,T ;STORE INTO ARRAY LEADER + MOVE C,[MOVEM T,MEM(A)] + JRST XFALD1 + +XAPLD: MOVE C,[MOVEI T,(A)] ;AP-LEADER -- MAKE LOCATIVE INTO ARRAY-LEADER + PUSHJ P,XFALD1 + TLO T,QZXSTR_5 + POPJ P, + +XFALDR: MOVE C,[MOVE T,MEM(A)] ;FETCH FROM ARRAY LEADER +XFALD1: POP IP,J + POP IP,A + LDB I,[%NDTB,,J] + CAIE I,QZFIX + BARF ARRAY-LEADER INDEXED BY NON-FIXNUM,J/& + PUSHJ P,GAHDR + TDNN B,[ARXIB] + BARF ATTEMPT TO REFERENCE NON-EXISTENT ARRAY-LEADER,A/& + HRRZ I,MEM-1(A) ;LENGTH OF ARRAY LEADER + CAIG I,(J) + BARF ARRAY-LEADER REFERENCED THE LEADER OUT OF BOUNDS,I/=J/= + SUBI A,2(J) + XCT C + POPJ P, + +XFARY: POP IP,T ;FILL-ARRAY + POP IP,A + PUSHJ P,GAHDR + TDNN B,[ARXIB] + BARF FILL-ARRAY AN ARRAY WITH NO LEADER,A/& + LDB ZR,[%NDTB,,MEM-2(A)] + CAIE ZR,QZFIX + BARF FILL-ARRAY ON ARRAY WITHOUT FIXNUM FILL POINTER,A/& + HRRZ C,MEM-2(A) ;FILL POINTER + LDB R,[%ARYTP,,B] ;GET ARRAY TYPE + CAML C,S + JRST XFALSE ;LOSE, WONT FIT + AOS MEM-2(A) ;WILL WIN, INCR FILL POINTER FOR NEXT TIME + MOVE Q,C ;GET ELEMENT NUMBER IN Q + TRNE B,ARDSPB + JRST [ LDB ZR,[%NDTB,,MEM(E)] + CAIN ZR,QZARYP ;ELEMENT NUMBER IN Q + PUSHJ P,QDACMP ;THIS ARRAY POINTS AT THAT ONE'S DATA SKIP ON RETURN!! + MOVE E,MEM(E) + JRST .+1] + PUSHJ P,@XFADT1(R) ;DO APPROPRIATE STORE FOR TYPE OF ARRAY + MOVE T,C + TLO T,QZFIX_5 ;RETURN AS VALUE INDEX STORED IN + POPJ P, + +XFALAR: ADD E,Q + TLZ T,NHIB+NCDRB + TLO T,NXTNIL + MOVEM T,MEM(E) ;LIST ARRAY, STORE NXTNIL CDR CODE + MOVSI ZR,NXTCDR ;CHANGE CDR CODE OF LAST GUY TO NXTCDR + SKIPE C ;UNLESS THIS FIRST ONE + IORM ZR,MEM-1(E) + POPJ P, + +XFAERR: HALT ;BAD ARRAY TYPE + +XCARCL: POP IP,T ;COPY BOTH ARRAY AND LEADER CONTENTS + POP IP,C + MOVEI I,0 ;COPY LEADERS FIRST + MOVE A,C + PUSHJ P,GALPTR + MOVE R,B + MOVE Q,S + MOVE J,E + MOVE A,T + PUSHJ P,GALPTR +XCALD1: CAML I,S + JRST XCARC0 ;NOW COPY DATA + CAML I,Q + JRST [ MOVSI ZR,QZSYM_5 ;FILL EXTRA TO LEADER POSITIONS WITH NIL + JRST XCALD2] + MOVE A,J + SUB A,I + MOVE ZR,MEM(A) +XCALD2: MOVE A,E + SUB A,I + MOVEM ZR,MEM(A) + AOJA I,XCALD1 + +XCARC: POP IP,T ; COPY ARRAY CONTENTS + POP IP,C ; +XCARC0: MOVEI I,0 ;Q # OF ARRAYS XFERRING + MOVE A,C + PUSHJ P,GADPTR ;GET DATA ON FROM ARRAY + JUMPN Q,XCARCE ;MUST DO ELEMENT WISE COPY + MOVE R,B + LDB B,[%ARYTP,,B] ;ARRAY TYPE OF FROM ARRAY + ADD S,ENTPQ(B) + SUBI S,1 + PUSH P,S+1 + IDIV S,ENTPQ(B) + POP P,S+1 + PUSH P,S ;CROCK + MOVE J,E + MOVE A,T ;GET DATA ON TO ARRAY + PUSHJ P,GADPTR + JUMPN Q,[ POP P,Q + JRST XCARCE] + LDB Q,[%ARYTP,,B] ;ARRAY TYPE OF TO ARRAY + ADD S,ENTPQ(Q) + SUBI S,1 + PUSH P,S+1 + IDIV S,ENTPQ(Q) + POP P,S+1 + POP P,Q +XCARC1: CAML I,S + POPJ P, ;THRU (HAVE XFERRED AS MANY WDS AS IN TO ARRAY) + CAML I,Q + JRST [ LDB A,[%ARYTP,,B] ;PAST END OF FROM ARRAY + MOVE ZR,XCFILL(A) ;GENERATE APPRO FILL CODE FOR ARRAY TYPE + JRST XCARC2] + MOVE A,I + ADD A,J + MOVE ZR,MEM(A) ;REF DATA Q OF FROM ARRAY +XCARC2: MOVE A,I + ADD A,E + MOVEM ZR,MEM(A) ;STORE IN TO ARRAY + AOJA I,XCARC1 + +XCARCE: BARF MUST DO ELEMENT WISE COPY. YOU LOSE. - COPY-ARRAY-CONTENTS + +GADPTR: PUSHJ P,GAHDR ;GET POINTER TO ARRAY DATA OF ARRAY IN A + MOVEI Q,0 ; THAT MANY ELEMENTS FURTHER DOWN. THIS CAN ONLY + TRNN B,ARDSPB ; HAPPEN WITH A INDEXED OFFSET ARRAY WITH NON-FULL-Q + POPJ P, ; ELEMENTS + LDB ZR,[%NDTB,,MEM(E)] + CAIN ZR,QZARYP ;"ELEMENT" IE 0, IN Q + PUSHJ P,QDACMP ;THIS ARRAY POINTS AT THAT ONE'S DATA. SKIP ON RETURN. + MOVE E,MEM(E) + JUMPE Q,CPOPJ ;OK NO FUNNYNESS + LDB ZR,[%ARYTP,,B] ;IS IT A Q ARRAY? + ADDI ZR,ENTPQ + MOVE ZR,@ZR + SOJN ZR,CPOPJ ;NOT A FULL-Q-ARRAY, CANT WIN + ADD E,Q ;MOVE UP FIRST DATA LOCN + MOVEI Q,0 + POPJ P, + +GALPTR: PUSHJ P,GAHDR ;GET POINTER TO LEADER DATA OF ARRAY IN A + MOVEI E,-2(A) ;B GETS ARRAY HEADER + TDNN B,[ARXIB] ;E GETS FIRST DATA LOCN (HIGHEST IN MEM) + TDZA S,S ;S GETS LEADER DATA LENGTH (0 IF NONE) + HRRZ S,MEM-1(A) + POPJ P, + +XAHLP: POP IP,A ;RETURN T IF ARG ARRAY HAS LEADER + PUSHJ P,GAHDR + TDNN B,[ARXIB] + JRST XFALSE + JRST XTRUE + +;ON CALL HERE, Q HAS ELEMENT NUMBER BEING REF'ED. IF THIS ARRAY HAS AN ELEMENT OFFSET, +; IT WILL BE ADDED TO Q. S HAS ELEMENT LIMIT SO FAR. IF ARRAY INDIRECT, ITS LIMIT WILL +; BE MIN'ED WITH S (FIRST ADDING TO S THE AMOUNT OF ANY INDEX OFFSET). +QDACMP: PUSH IP,A ;COME HERE IF DISPLACED DATA POINTER OF DISPLACED ARRAY + PUSH IP,B ;HAS DATA TYPE ARRAY-POINTER. THIS MEANS THAT THE + PUSH P,D ;DISPLACED ARRAY IS TO HAVE THE SAME DATA BASE AS +QDACM2: MOVE A,MEM(E) ;THE POINTED TO ARRAY. COMPUTE ITS DATA BASE (SPACING + TLNE A,NUSRCB + JRST QDACM4 ;HAS INDEX OFFSET +QDACM5: PUSH IP,S + PUSHJ P,GAHD1 ;OVER INDEXING INFO IF NECESSARY), AND LEAVE IT IN E. + CAMLE S,(IP) + MOVE S,(IP) + SUB IP,[1,,1] + TRNN B,ARDSPB ;SKIP ON RETURN (TO SKIP OVER MOVE E,MEM(E) WHICH + JRST QDACM1 ;INVARIABLY FOLLOWS CALL TO DO THE RIGHT THING FOR + LDB ZR,[%NDTB,,MEM(E)] ;REGULAR DISPLACED ARRAYS. + CAIN ZR,QZARYP + JRST QDACM2 ;THAT ARRAY IS DISPLACED SAME WAY! + MOVE E,MEM(E) ;ITS JUST AN ORDINARY DISPLACED ARRAY +QDACM1: POP P,D + POP IP,B + POP IP,A + AOS (P) ;SKIP ON RETURN + POPJ P, + +QDACM4: LDB ZR,[%NDTB,,MEM+2(E)] ;ACCESS INDEX OFFSET Q, 2 BEYOND INDIRECT PTR + CAIE ZR,QZFIX + HALT + HRRZ ZR,MEM+2(E) + ADD Q,ZR ;CAUSE ELEMENT WISE OFFSET + ADD S,ZR ;ALSO OFFSET INDEX LIMIT SO FAR + JRST QDACM5 + +QMMPOP: LDB J,[%LPNWP,,LPENS(AP)] ;CALL WITH JSP S, +QMMPO1: JUMPE J,(S) ;FINISHED XFERRING WDS BACK (ENTER HERE FROM S-G STUFF) + HRRZ C,QLBNDP ;RETURNS 0 IN J +QMMPO2: MOVE E,(C) + LDB ZR,[%NDTB,,E] + CAIE ZR,QZFIX + HALT + SOJE J,QMMPO3 ;THIS GOING TO BE LAST ONE + TLNE E,NUSRCB + HALT ;NOT FIRST WD OF BLOCK, SHOULD NOT HAVE HAD THAT ON + PUSH P,E ;RESTORE STUFF TO P STACK + SOJA C,QMMPO2 + +QMMPO3: PUSH P,E + SOS C + TLNN E,NUSRCB + HALT ;THAT WAS LAST WD OF BLOCK, SHOULD HAVE BEEN ON. + HRRZM C,QLBNDP + JRST (S) + +QME1: HRRZ D,A ;MICRO-CODE ENTRY (GET ENTRY #) + HRRZ ZR,AMCENT + CAML D,ZR ;# ACTIVE MICRO-CODE ENTRIES + BARF MICRO-CODE-ENTRY NUMBER TOO BIG,D/ + MOVE J,NARGS ;IN CASE THIS ONE TAKES A VAR # OF ARGS + LDB ZR,[060600,,MEVECA(D)] + CAMGE J,ZR + BARF TOO FEW ARGUMENTS TO MICRO-CODE-ENTRY,D/ Q+MVECA/= + LDB ZR,[000600,,MEVECA(D)] + CAMLE J,ZR + BARF TOO MANY ARGUMENTS TO MICRO-CODE-ENTRY,D/ Q+MVECA/= + MOVE AP,IP + SUBI AP,(J) + HRRZM AP,IPMARK + TLZ PC,QBBFL+QINDAT+QINDNL ;REST OF PC IS IRRELAVENT, BUT + ;LEAVE IT THERE FOR DEBUGGING PURPOSES +QBNEAF + MOVE B,LPCLS(AP) + TLNE B,(LPADL) + JRST QME2 ;THIS AN ADDTL INFO CALL + PUSHJ P,@MEVEC(D) ;DISPATCH TO ENTRY, J NUMBER OF ARGS ON IP +QMER: PUSH P,T ;RETURN WITH VALUE IN T, ARGS HAVING BEEN POPPED OFF + JRST QMEX1 + +QME2: PUSH P,[PPBMAA,,QMER] ;SIGNAL MACRO-TO-MICRO ADTL CALL + JRST @MEVEC(D) + + +QMDDR: PUSH P,T ;DESTINATION RETURN, SAVE Q TO BE RETURNED + TLZE PC,QBBFL + PUSHJ P,BBLKP ;POP BIND BLOCK (IF STORED ONE) +; MOVE S,LPENS(AP) +; TLNE S,(LPESF) +; PUSHJ P,FRMSWP ;RESTORE BINDINGS IF SPECIAL VARS BOUND +QMEX1: SKIPGE VTRACE ;VALUE BEING RETURNED HAD BETTER BE BOTH IN T AND (P) + PUSHJ P,PT ;PRINT VALUES BEING RETURNNED + MOVE B,LPCLS(AP) +IFN FNASW,[ + TLNE B,(LPFNAB) + PUSHJ P,BBLKP ;POP FUNARG (CLOSURE) BINDING BLOCK IF ANY +] + HRRI IP,-LLPFRM(AP) ;RESTORE PDL + TLNE B,(LPADL) + PUSHJ P,QRAD1 ;ADTL INFO CALL FLUSH INFO FROM PDL + LDB ZR,[%LPCAD,,B] ;COMPUTE NEW ARG POINTER + JUMPE ZR,QMXSG ;XFER ON REACHED TOP OF STACK-GROUP, SEE WHAT TO DO.. + MOVE D,AP + SUB D,ZR + LDB J,[%LPCPN,,B] ;DELTA TO PREV IPMARK + HRRZ ZR,AP ;RESTORE THAT + SUB ZR,J + MOVEM ZR,IPMARK + LDB J,[%NDTB,,LPFEF(D)] + MOVE A,LPEXS(D) ;GET EXIT STATE + JRST @QMXRT(J) ;FLAVOR OF FCTN RETURNING TO. + +QMEXF: LDB PC,[%LPEPC,,A] ;SAVED PC (Q'S COMP, RELATIVE TO FEF) + LDB E,[%NDAT,,LPFEF(D)] ;FEF REENTERING + ADD PC,E ;UNRELATIVIZE IT + LDB J,[%LPCST,,A] ;SAVED PC STATUS BITS AND BYTE BIT + DPB J,[%PCSTS,,PC] ;RESTORE THEM + LDB C,[%LPCSD,,B] ;PUT SAVED DESTINATION IN A GOOD PLACE +; TLNE B,(LPCPLI) +; TLO PC,QBALM ;RESTORE ARG LOADING MODE +; TLNE B,(LPCARV) +; TLO PC,QBNEAF ;RESTORE NON-EVAL ARG STORED FLAG + MOVE AP,D ;RESTORE ARG POINTER + LDB J,[%LPLBO,,LPENS(AP)] + MOVEM J,QLOCO ;RESTORE QLOCO FOR THIS FRAME + POP P,T ;RETURNED VALUE + JRST QIMOVE ;STORE IT IN RIGHT PLACE + + +;NOTE THAT J HAD BETTER NOT BE STACK-GROUP BECAUSE ANY STACK-GROUP IN FUNCTION CONTEXT +; MUST ALWAYS BE IN LAST FRAME OF A STACK-GROUP, BUT WE HAVE JUST FLUSHED A FRAME. +; ANOTHER WAY TO SEE THIS IS TO REALIZE THAT INVOKING A STACK-GROUP ALWAYS RESULTS +; IN LEAVING THE CURRENT STACK-GROUP. IF WE WERE TO FIND A STACK-GROUP HERE, +; IT WOULD MEAN THAT INVOKING A STACK-GROUP HAD SOMEHOW MANAGED TO INVOKE SOMETHING +; ELSE -- WITHIN ITS OWN STACK-GROUP--. + +QMMRI: MOVE E,LPFEF(D) ;RETURNING TO INVZ, FLUSH IT AND TRY AGAIN + MOVE E,MEM(E) + MOVEM E,LPFEF(D) + LDB J,[%NDTB,,E] + JRST @QMXRT(J) + +QMMRL: LDB E,[%LPMPC,,A] + CAIE E,INTRET ;HAD BETTER BE INTERPRETER RETURN + HALT +QMMR2: POP P,T ;VALUE (GET HERE DIRECTLY ON RETURNING TO UCODE) + MOVE AP,D + JSP S,QMMPOP ;POP STUFF FROM LINEAR BIND PDL IF NECC + DPB J,[%LPNWP,,LPENS(AP)] ;0 IN J, DONT LEAVE GARBAGE IN %LPNWP FIELD + ; (CAN CONFUSE PDL GRUBBLING ROUTINES) + TLZ PC,QINDAT+QINDNL+QBBFL ;+QBNEAF + TLNE A,(LPEBFL) + TLO PC,QBBFL ;RESTORE BINDS PUT ON STACK FLAG + MOVSI ZR,QZFIX_5 + MOVEM ZR,LPEXS(AP) ;BACK IN THIS FRAME NOW. + LDB E,[%LPMPC,,A] + JSP ZR,(E) ;SAVE PC IN ZR FOR DEBUGGING PURPOSES + +QMXSG: MOVE A,QCSTKG ;GET CURRENT STACK GROUP + HRRZ B,SGIFCT+MEM(A) ;REALLY AT THE TOP + MOVE C,SGRA+MEM(A) ;GET PDL STORAGE ARRAY POINTER + MOVE E,MEM(C) ;GET ARRAY HEADER OF STACK-GROUP + ADDI B,MEM+1(C) ;UNRELATIVIZE FOR ARRAY-HEADER, MEM, AND ARRAY-ORIGIN + TRNE E,ARYEXL + AOS B ;EXTENDED ARRAY, SPACE PAST INDEX-LENGTH Q + CAIE B,(AP) + HALT ;LOSEY LOSEY + POP P,SGVTEM ;REALLY DID RETURN OUT THE TOP.. PUT VALUE THERE + MOVEI D,SGNEXH ;NOW IN EXHAUSTED STATE + JRST XSTGR1 ;RETURN THIS LAST VALUE TO HIM. + +QRAD1: ;ADDITIONAL INFO CALL, STORE LAST VALUE, FLUSH FROM PDL + ;BUT SAVE INFO AS TO HOW MANY ADDTL VALUES WERE + ;EXPECTED + ;CHANGES TYPE OF MVR BLOCK STORED INTO FROM ADIRT TO + ;ADIRTU, SO LAST VALUE ONLY STORED ONCE +QRAD3: POP IP,Q + LDB J,[%NDTB,,Q] + CAIE J,QZFIX + HALT + LDB J,[%ADITP,,Q] + CAIE J,ADIRT + JRST QRAD4 ;NOT RETURN INFO + LDB J,[%ADIRB,,Q] ;VALUE STORING OPTION + LDB I,[%ADINV,,Q] ;# VALUES EXPECTING + JRST @QRADDT(J) + +QRADDT: QRADE ;ERROR + QRADB ;BLOCK + QRADL ;STORE IN LIST + QRADC ;DO CONS AND MAKE LIST + QRAIP ;INDIRECT POINTER + QRADE + QRADE + QRADE +QRADL: +QRADE: HALT + +QRAIP: PUSH P,IP ;INDIRECT POINTER + PUSH P,Q + MOVE IP,(IP) + PUSHJ P,QRAD3 + POP P,Q + POP P,IP + JRST QRAD4 + +QRADB: MOVE J,(IP) + DPB T,[%NDAT,,MEM(J)] ;STORE LAST VALUE + SOSGE I ;ONE VALUE BEING RETURNED NOW + HALT ;LOSE. + DPB I,[%ADINV,,1(IP)] ;STORE BACK SOSED COUNT + MOVEM I,LNUSV ;LAST NUMBER UNSUPPLIED VALUES +QRAD5: MOVEI I,ADIRTU ;"USE UP" THIS MVR ADI + DPB I,[%ADITP,,1(IP)] +QRAD4: TLNN Q,NUSRCB + HALT ;PHASE OF INFO OFF + POP IP,Q + TLNN Q,NUSRCB + POPJ P, + JRST QRAD3 + +QRADC: MOVE S,CNSADF ;CONS UP LIST OF VALUES + MOVE R,T + MOVE E,B ;PROTECT B FOR QARYR5, QMEX1 + PUSHJ P,IALL2Q + MOVSI B,QZSYM_5+NXTNOT ;CDR IS NIL + MOVEM B,MEM+1(T) + TLZ R,NCDRB ;FULL NODE + MOVEM R,MEM(T) + TLO T,QZLIST_5 + MOVE S,(IP) + MOVEM T,(IP) + PUSHJ P,QRDR1 + MOVE T,R + MOVE Q,1(IP) + MOVE B,E + JRST QRAD5 + +QLLV: LDB ZR,[%NDTB,,LPFEF(AP)] + CAIE ZR,QZFEFP + HALT + HRRZ Q,PC ;GET CURRENT PC, (Q'S COMP) + LDB ZR,[%NPTR,,LPFEF(AP)] ;GET ORG OF CURRENTLY RUNNING FEF + SUB Q,ZR ;MAKE IT RELATIVE TO FEF ORG + TDNE Q,[-1,,770000] + HALT ;THERE SHOULDNT BE ANY BITS THERE! + LDB ZR,[%PCSTS,,PC] ;WORD BIT OF PC,QINDAT,QINDNL,QBBFL (ETC) + DPB ZR,[%LPCST,,Q] + TLO Q,QZFIX_5 + MOVEM Q,LPEXS(AP) ;STORE EXIT STATEWORD + POPJ P, + +;GET HERE WHEN RESUMING STACK-GROUP. DONT RESTORE PC-STATUS, SINCE THAT +; RESTORED BY STACK-GROUP RESUME MECHANISM. +QLLENT: LDB PC,[%LPEPC,,LPEXS(AP)] ;SAVED PC (Q'S COMP, RELATIVE TO FEF) + LDB J,[%NPTR,,LPFEF(AP)] ;FEF REENTERING + ADD PC,J ;UNRELATIVIZE IT + LDB J,[%LPLBO,,LPENS(AP)] + MOVEM J,QLOCO ;RESTORE QLOCO FOR THIS FRAME + POPJ P, + +XRETN: SUB P,[2,,2] + POP IP,B ;RETURN N VALUES (LAST ARG IS N) + LDB ZR,[%NDTB,,B] + CAIE ZR,QZFIX + HALT + TLZ B,777740 + SKIPN B + HALT + SOJE B,XRETN2 +XRETN1: MOVN I,B + ADDI I,(IP) + MOVE T,(I) + PUSHJ P,XRNVR + JRST QMDDR + SOJG B,XRETN1 + JRST XRETN2 + +XRET2: SUB P,[2,,2] + JRST XRET2A + +XRET3: SUB P,[2,,2] + MOVE T,-2(IP) + PUSHJ P,XRNVR ;RETURN 3 VALUES + JRST QMDDR +XRET2A: MOVE T,-1(IP) + PUSHJ P,XRNVR ;RETURN 2 + JRST QMDDR +XRETN2: MOVE T,(IP) + JRST QMDDR ;REALLY RETURN THAT ONE + +XRNV: SUB P,[2,,2] + POP IP,T + PUSHJ P,XRNVR ;RETURN NEXT VALUE AND CONTINUE IF MORE DESIRED + JRST QMDDR + JRST QIMOVE ;STORE IN DESTINATION + + +XRNVR: ;RETURN NEXT VALUE (FROM MACRO-CODE) + ;RETURN BY POPJ P, IF NO MORE VALUES DESIRED + ;BY SKIPPING IF MORE VALUES DESIRED + MOVE ZR,LPCLS(AP) ;ANY EXTRA INFO? + TLNN ZR,(LPADL) + POPJ P, ;NO, DO ORDINARY RETURN + MOVEI S,LPCLS-1(AP) ;EXAMINE THE INFO +XRNV2: MOVE Q,(S) ;ENTER HERE FROM MR2V1 + LDB J,[%NDTB,,Q] + CAIE J,QZFIX + HALT + LDB J,[%ADITP,,Q] + CAIE J,ADIRT + JRST XRNV1 ;NOT RETURN TYPE + LDB J,[%ADIRB,,Q] ;GET VALUE STORING OPTION + LDB I,[%ADINV,,Q] ;NUMBER MORE VALUES EXPECTING + JRST @XRNVDT(J) + +XRNV1: TLNN Q,NUSRCB + HALT ;INFO OUT OF PHASE + SOS S + MOVE Q,(S) ;SKIP OF PAIRED Q + TLNN Q,NUSRCB + POPJ P, + SOJA S,XRNV2 + +XRNVDT: XRNVE ;ERROR + XRNVB ;STORE IN BLOCK + XRNVL ;STORE IN LIST + XRNVC ;DO CONS AND MAKE LIST + XRNIP ;INDIRECT POINTER + +XRNVL: +XRNVE: HALT + +XRNIP: MOVE S,-1(S) ;INDIRECT POINTER + JRST XRNV2 + +XRNVB: SKIPN I + HALT ;SHOULD NOT HAVE STORED LAST VALUE THIS WAY + SOJE I,CPOPJ ;THIS THE LAST ONE, HANDLE IT NORMAL WAY + DPB I,[%ADINV,,(S)] ;NOW EXPECTING ONE LESS + AOS I,-1(S) ;GET POINTER (AND INCR) + DPB T,[%NDAT,,MEM-1(I)] ;STORE VALUE + AOS (P) ;COMPUTE STILL MORE WINNING VALUES!! + POPJ P, + +XRNVC: PUSH IP,B ;PROTECT B + PUSH IP,A ;PROTECT R, E, A FOR MR2V1 + PUSH IP,E + PUSH IP,R + PUSH IP,S ;PROTECT Q FOR XRNV2 + PUSH IP,C ;PROTECT C FOR QIMOVE FROM XRNV + MOVE E,S ;-> ADI + MOVE S,CNSADF ;CONS UP LIST OF VALUES + MOVE R,T + PUSHJ P,IALL2Q + MOVSI B,QZSYM_5+NXTNOT ;CDR IS NIL + MOVEM B,MEM+1(T) + TLZ R,NCDRB ;FULL NODE + MOVEM R,MEM(T) + TLO T,QZLIST_5 + MOVE S,-1(E) + MOVEM T,-1(E) + PUSHJ P,QRDR1 + MOVE T,R + POP IP,C + POP IP,S + POP IP,R + POP IP,E + POP IP,A + POP IP,B + AOS (P) + POPJ P, + +QLENTR: ;S HAS EVENTUAL NEW ARG POINTER + ;A HAS PNTR TO FEF TO CALL (SUPPOSEDLY) + ;B HAS DATA TYPE OF A + SKIPGE D,MEM(A) + PUSHJ P,ITRAP + LDB B,[%FRMDT,,D] ;MAKE SURE ITS A FEF TYPE OF FRAME + CAIE B,FRMFEF + JRST QETRAP + CLEARM QBTRP ;IF WANT TO TAKE TRAP + LDB ZR,[%QFMXP,,QFEMS1+MEM(A)] ;MAX LENGTH (LOCAL BLOCK + LOCAL PDL) + ADDI ZR,100(IP) ;ALLOW BUGGER BECAUSE MICRO-COMPILED DONT CHECK NOW + CAML ZR,QLPDLH ; AMONG OTHER THINGS +PCE: BARF PUSH-DOWN LIST OVERFLOW + LDB ZR,[%QFEPC,,D] + MOVEM ZR,QTEMPC ;OK TO ENTER FCTN (BUT THIS MAY GET CHANGED DUE TO + ;OPTIONAL ARGS + MOVEI PC,0 ;CLEAR OUT FLAGS + CLEARM QLCTYP ;CALL TYPE, 0 NORMAL + MOVE ZR,LPCLS(S) + TLNE ZR,(LPADL) + JRST QLEAI1 ;THIS AN ADI CALL, IS IT AN FEXPR OR LEXPR TYPE? +QLEAI2: TRNN D,QFASAB + JRST QRENT ;FAST OPTION NOT ON +; MOVEI C,QBEQTA ;ERRONEOUS QUOTED ARG +; TLNE PC,QBNEAF +; IORM C,QBTRP ;ALL ARGS NOT EVALUATED, LOSE. + MOVE B,MEM+QFRFSO(A) ;PICK UP FAST OPTION WORD + LDB ZR,[%NDTB,,B] + CAIE ZR,QZFIX + HALT + MOVEI E,QBTFA + LDB C,[%AGIMN,,B] ;MIN # ARGS + CAMLE C,NARGS + IORM E,QBTRP ;NOT ENUF ARGS + LDB E,[%AGIMX,,B] ;MAX # ARGS (FINAL # INCLUDING OPTIONALS) + TLNE B,(AGIRQT+AGIREV) + JRST QLFOA1 ;REST ARG PRESENT + MOVEI C,LPLOFF(E) ;OFFSET OF LOCAL BLOCK (FROM ARG POINTER) (INITIAL) + MOVEM C,QLOCO ;STORE IT +; TRNE D,QFSVOP ;(ANY SPECIALS HERE?) +; TLO C,(LPESF) ;INDICATE SPECIALS IN BLOCK + MOVE Q,NARGS + DPB Q,[%LPENA,,C] ;NUMBER SUPPLIED ARGS + TLO C,QZFIX_5 + MOVEM C,LPENS(S) ;STORE ENTRY STATE WORD + MOVEI Q,QBTMA + CAMGE E,NARGS + IORM Q,QBTRP ;TOO MANY ARGS +QFL2: CAMG E,NARGS + JRST QFL1 ;EXACTLY RIGHT # + PUSH IP,[QZSYM_5,,] ;SUPPLY NIL FOR REST OF THEM + SOJA E,QFL2 + + +QFL1: ;# ARGS OK, + MOVE AP,S ;SET ARG POINTER + SKIPGE Q,MEM+QFEMSC(A) + PUSHJ P,ITRAP + LDB T,[%QFLBL,,Q] ;GET LENGTH OF LOCAL BLOCK +QFL1C: JUMPE T,QFL1A ;NOT LOCAL BLOCK +QFL1B: PUSH IP,[NXTCDR+,,] ;INIT LOCAL BLOCK TO NIL + SOJG T,QFL1B +QFL1A: MOVE D,QFEIPC+MEM(A) + TRNE D,QFSVOP ;NEED TO SWAP S.V.? +; PUSHJ P,FRMSW1 ;SWAP BINDINGS AND VALUE CELLS OF SPECIAL VARS + PUSHJ P,FRMBN1 +QLENX: HRRZM AP,IPMARK ;NO OPEN CALL BLOCKS THIS BLOCK YET + MOVE B,QTEMPC + ANDI B,177777 + ROT B,-1 ;CONVERT TO Q'S AND PUT "WORD" BIT INTO SIGN + ADDI B,(A) + IOR PC,B ;DONT AFFECT PDL MODE FLAGS IN PC + SKIPN QBTRP + POPJ P, + +; ;MEANING OF BITS IN QBTRP +; +; QBTFA==1 ;TOO FEW ARGS +; QBTMA==2 ;TOO MANY ARGS +; QBEQTA==4 ;ERRONEOUS QUOTED ARG +; QBEEVA==10 ;ERRONEOUS EVALUATED ARG +; QBBDT==20 ;BAD DATA TYPE +; QBBQTS==40 ;BAD QUOTE STATUS + + SOUT [ASCIZ /TOO BAD, YOU LOSE, QBTRP REIGNS SUPREME!/] + PUSH P,A ; SAVE A, YOU NEVER KNOW WHEN YOU MIGHT NEED IT... + MOVE A,QBTRP + ; NOW, A SMALL MACRO FOR PRINTING ERROR MESSAGES IF THE BIT IS SET +DEFINE FOO BIT,MSG + TRNE A,BIT + SOUT [ASCIZ /MSG +/] +TERMIN + + FOO QBTFA,TOO FEW ARGS + FOO QBTMA,TOO MANY ARGS + FOO QBEQTA,ERRONEOUS QUOTED ARG + FOO QBEEVA,ERRONEOUS EVALED ARG + FOO QBBDT,BAD DATA TYPE + FOO QBBQTS,BAD QUOTE STATUS + +EXPUNGE FOO + POP P,A ;RESTORE A +QETRA1: HALT +QETRA2: HALT +QETRAP: HALT ;CALLING NON-FEF + +;REST ARG PRESENT E HAS MAX # REST+OPT ARGS. +QLFOA1: MOVE J,NARGS + MOVEI I,LPLOFF(S) ;GET POINTER TO FIRST ARG ON STACK + JUMPN E,QLFOA2 ;SOME BEING HANDLED BOTH WAYS.. + SKIPN QLCTYP ;SKIP ON FEXPR OR LEXPR CALL + JRST QLFOA3 ;ARGS SPREAD, LIST THEM UP, ETC. + MOVEI C,LPLOFF ;SINCE REST ARG IS FIRST OF LOCAL BLOCK +QLFOA5: MOVEM C,QLOCO ;"ARG" BLOCK IS NULL +; TRNE D,QFSVOP +; TLO C,(LPESF) + TLO C,QZFIX_5 + MOVEM C,LPENS(S) + MOVE AP,S + LDB T,[%QFLBL,,MEM+QFEMSC(A)] + SOSGE T + HALT ;LOCAL PART OF LOCAL BLOCK IS ONE LESS + JRST QFL1C + +QLFOA3: JUMPE J,QLFOA6 ;IF NO ARGS, REST POINTER WANTS TO BE NIL + MOVEI ZR,NXTCDR_-12. + MOVEI E,-MEM(I) ;POINTER TO FIRST ARG +QLFOA4: DPB ZR,[%NCDRB,,(I)] + AOS I + SOJG J,QLFOA4 + MOVEI ZR,NXTNIL_-12. + DPB ZR,[%NCDRB,,-1(I)] + CAIE I,1(IP) + HALT + TLO E,QZLIST_5 + PUSH IP,E ;STORE PNTR TO LIST OF ARGS +QLFOA7: MOVE C,NARGS ;LOCATE LOCAL BLOCK BEYOND ARGS + ADDI C,LPLOFF + JRST QLFOA5 ;REST ARG ALREADY PUSH'ED, SO LOCAL BLOCK ONE LESS + ; IS RIGHT +QLFOA6: PUSH IP,[NXTCDR+,,] + JRST QLFOA7 + +;GET HERE IF BOTH REG AND REST ARGS +QLFOA2: TLNE D,(QNADL) + HALT ;NOT CODED YET + JRST QRENT ;DO SLOW STUFF + +QLEAI1: MOVEI R,LPCLS-1(S) ;SEE IF LEXPR OR FEXPR CALL +QLEAI3: MOVE Q,(R) + LDB J,[%NDTB,,Q] + CAIE J,QZFIX + HALT + LDB J,[%ADITP,,Q] + CAIE J,ADIFEX + CAIN J,ADILEX + JRST [ MOVEM J,QLCTYP ;STORE WEIRD CALL TYPE + JRST QLEAI2] + TLNN Q,NUSRCB + HALT + SOS R + MOVE Q,(R) + TLNN Q,NUSRCB + JRST QLEAI2 ;SOME OTHER KIND OF ADI + SOJA R,QLEAI3 + + +QRENT: SKIPGE E,MEM+QFEMSC(A) ;ENTER WITH FAST OPTION OFF + PUSHJ P,ITRAP + LDB I,[%QFAGS,,E] ;START OF ARG LIST + LDB R,[%QFAGL,,E] ;LENGTH OF ARG LIST + ADDI I,(A) ;ADD IN START OF FEF + MOVEI D,LPLOFF(S) ;S HAS EVENTUAL NEW ARG POINTER + ;D GETS POINTER TO FIRST ARG + MOVEI T,QFVA(A) ;POINTER TO SPECIAL VAR VALUE CELL LIST + MOVE ZR,NARGS ;# ARGS + SETOM QLOCO ;SIGNAL LOCAL BLOCK NOT LOCATED!! +; CLEARM QRSPCF ;SPECIALS IN BLOCK FLAG + SKIPE QLCTYP + JRST QREW1A ;FEXPR OR LEXPR CALL +QBINDL: JUMPLE ZR,QBD1 ;OUT OF ARGS + SOJL R,QBTMA1 ;END OF ARG DESC LIST (TOO MANY ARGS) + SKIPGE Q,MEM(I) ;ACCESS WORD OF BINDING OPTIONS + PUSHJ P,ITRAP + TLNE Q,(ALNP) ;SKIP OVER NAME IF PRESENT + AOS I + LDB E,[%ALAGS,,Q] ;ARG SYNTAX + CAIL E,MXAGS + HALT + JRST @QREDT1(E) ;DISPATCH ON TYPE OF ARG + +QREDT1: QBRQA ;REQUIRED ARG + QBROP1 ;OPTIONAL ARG (ITS PRESENT) + QBRA ;REST ARG + QBTMA2 ;AUX VAR, (HAVE REACHED END OF ARG SECT, WITH MORE ARGS) + QBTMA2 ;FREE, " + QBTMA2 ;INTERNAL, " + QBTMA2 ;INTERNAL-AUX, " + +QREW1A: CAIE ZR,1 + JRST QBINDL ;THERE ARE REGULAR SPREAD ARGS BEFORE NON-SPREAD LIST +QREW1: LDB B,[%NDAT,,(D)] ;ARG LIST + CAMN B,[QZSYM_5,,] + JRST QBD1 ;ALL ARGS HAVE BEEN PROCESSED + JUMPE ZR,[HALT] ;BEING CALLED WITH FEXPR OR LEXPR CALL + SOJL R,QBTMA1 ;OUT OF B-D-L + MOVE Q,MEM(I) + TLNE Q,(ALNP) + AOS I + LDB E,[%ALAGS,,Q] + JRST @QRSDT1(E) + +QRSDT1: QRSQA ;REQUIRED ARG + QRSOP1 ;OPTIONAL ARG + QREW2 ;REST ARG + QBTMA2 ;AUX VAR, (NO ARGS, ARG LIST HAD BETTER BE NIL) + QBTMA2 ;FREE, " + QBTMA2 ;INTERNAL, " + QBTMA2 ;INTERNAL-AUX " + +QRSOP1: PUSHJ P,QBOSP ;OPT ARG PRESENT, SPACE PAST INIT, ETC +QRSQA: PUSH P,T ;ARG DESIRED IN SPREAD FORM + PUSH P,J + PUSH P,I + MOVE T,(D) ;GET ARG LIST + PUSHJ P,QCAR ;GET FIRST ARG + EXCH T,(D) ;STORE SPREAD FIRST ARG, GET BACK ARG LIST + PUSHJ P,QCDR ;FLUSH FIRST ARG + MOVEM T,1(D) ;STORE IT BACK IN NEXT PDL SLOT + POP P,I + POP P,J + POP P,T + TLNE Q,(ALBOP) + PUSHJ P,QBSPCL +;COULD DO DATA TYPE CHECK, ETC, IF FELT LIKE IT + AOS D + AOS I + JRST QREW1 + + +QBOSP: LDB E,[%ALIOP,,Q] + JRST @QBOPNP(E) ;OPT ARG PRESENT, SPACE PAST INIT INFO IF ANY + +QBOPNP: CPOPJ ;NONE + CPOPJ ;NIL + QBOSP1 ;INIT TO PNTR (SPACE PAST) + QBOSP1 ;INIT TO C (POINTER) (LIKEWISE) + QBOASA ;ALT STARTING ADR, START THERE TO AVOID CLOBBERING IT + CPOPJ ;INIT BY COMPILED CODE + QBOSP1 ;INIT TO C(EFF ADR) + CPOPJ ;INIT TO SELF (NO EXTRA Q TO SPACE PAST) + +QBOSP1: AOJA I,CPOPJ + +QBOASA: AOS I + SKIPGE E,MEM(I) + PUSHJ P,ITRAP + MOVEM E,QTEMPC ;START LATER TO AVOID CLOBBERING + POPJ P, + +QBROP1: PUSHJ P,QBOSP ;SPACE PAST ANY INIT INFO, ETC +QBRQA: TLNE Q,(ALBOP) + PUSHJ P,QBSPCL ;SPECIAL, SO SWAP BINDING CELL AND VALUE CELLS +QBDL1: ;ENTER HERE WHEN ARG HAS BEEN BOUND. THESE CHECKS + ;ONLY CAUSE EXCEPTIONS + LDB E,[%ALDDT,,Q] + LDB C,[%NDTB,,(D)] ;DATA TYPE OF ARG + JUMPN E,@QBDDT-1(E) ;CHECK DATA TYPE +QBDDT1: +; LDB E,[%ALDQT,,Q] ;QUOTE STATUS DOESNT WIN NOW FOR MICRO-COMPILED FROBS +; LDB C,[%NUCB,,(D)] ;USER CONTROL BIT (INDICATES EVAL/QUOTAGE +; JUMPN E,@QBEQC-1(E) ;CHECK QUOTE STATUS +QBEQC1: AOS D ;NEXT ARG SLOT + AOS I ;NEXT ARG LIST ENTRY + CAIE ZR,2 ;SKIP ON THERE WILL BE ONE MORE ARG LEFT AFTER THIS + SOJA ZR,QBINDL ;PROCEED TO NEXT ARG + SKIPN QLCTYP + SOJA ZR,QBINDL ;LAST ARG IS REGULAR ANYWAY + SOJA ZR,QREW1 ;LAST ARG IS REALLY NON-SPREAD LIST + +QBRA: MOVEI E,-MEM(D) ;REST ARG, LOCATE LOCAL BLOCK PAST LAST ARG +; ADD D,ZR ;AND STORE IN A POINTER TO THE HEAD OF IT + MOVEI J,NXTCDR_-12. ;STORE CDR CODES SINCE THEY ARENT STORED BY +QBRAA2: DPB J,[%NCDRB,,(D)] ;MICRO-COMPILED FCTNS + AOS D + SOJG ZR,QBRAA2 + MOVEI J,NXTNIL_-12. + DPB J,[%NCDRB,,-1(D)] + TLO E,QZLIST_5 + MOVEM E,(D) ;STORE POINTER TO LIST OF ARGS +QREW2: TLNE Q,(ALBOP) ;ENTER HERE IF CALLED WITH FEXPR OR LEXPR CALL + PUSHJ P,QBSPCL + PUSHJ P,QLLOCB + AOS D + AOS I +QBD1: SOJL R,QBD2 ;USE THIS LOOP AFTER ALL PRESENT ARGS ARE USED UP + ;XFER ON THRU + SKIPGE Q,MEM(I) + PUSHJ P,ITRAP + TLNE Q,(ALNP) + AOS I +QBD2A: LDB E,[%ALAGS,,Q] + CAIL E,MXAGS + .VALUE + JRST @QBDT2(E) + +QLLOCB: SKIPL QLOCO + POPJ P, + MOVE E,D ;LOCATE LOCAL BLOCK + SUBI E,(S) ;COMPUTE LOCAL BLOCK OFFSET + MOVEM E,QLOCO ;STORE LOCAL BLOCK OFFSET + POPJ P, + +;DISPATCH ON TYPE ON NEXT B-D-L ENTRY AFTER ALL PRESENT ARGS HAVE BEEN PROCESSED + +QBDT2: QBTFA1 ;THIS WAS A REQUIRED ARG, BARF!! + QBOPT1 ;THIS WAS AN OPT ARG, NOT PRESENT + QBRA1 ;THIS WAS REST ARG, SET TO NIL + QBDAUX ;AUX VAR, REALLY END OF ARG PART OF B-D-L + QBDFRE ;FREE, " + QBDINT ;INTERNAL, " + QBDINT ;INTERNAL-AUX " + + +QBTFA1: SKIPL QLOCO + JSP ZR,QBFTE1 ;CONTRADICTORY FEF + MOVEI E,QBTFA ;TOO FEW ARGS + IORM E,QBTRP + +QBRA1: PUSHJ P,QLLOCB ;REST ARG NOT SUPPLIED, MAKE 1ST LOCAL NIL +QBOPT2: MOVSI E,+NXTCDR ;STORE ARG AS NIL +QBD1B: MOVEM E,(D) +QBD1A: TLNE Q,(ALBOP) + PUSHJ P,QBSPCL + AOS D + AOJA I,QBD1 + +QBFTE1: HALT + +QBDINT: TLNE Q,(ALBOP) ;INTERNAL + AOJA T,QBDIN1 ;SPECIAL, NO LOCAL BLOCK SLOT, TAKES S-V SLOT + SKIPGE QLOCO + PUSHJ P,QLLOCB + MOVSI E,+NXTCDR ;LOCAL, IGNORE AT BIND TIME BUT LEAVE SLOT + MOVEM E,(D) + AOS D +QBDIN1: AOJA I,QBD1 + +QBDFRE: TLNE Q,(ALBOP) ;SHOULD NEVER SKIP + AOS T ;TAKES S-V SLOT + AOJA I,QBD1 ;TAKES NO LOCBLOCK SLOT + +QBDAUX: SKIPGE QLOCO ;AUX VAR + PUSHJ P,QLLOCB ;LOCATE LOCAL BLOCK + JRST QBOPT4 + +QBOPT1: SKIPL QLOCO ;OPT ARG NOT PRESENT + JSP ZR,QBFTE1 ;LOCAL BLOCK SHOULD NOT HAVE BEEN LOCATED IF THERE + ;ARE ARGS REMAINING TO BE PROCESSED +QBOPT4: LDB E,[%ALIOP,,Q] ;INITIALIZING OPTION + JRST @QBOPTT(E) ;DISP HERE FOR OPT ARG NOT PRESENT OR AUX + +QBOPTT: QBOPT3 ;NONE + QBOPT2 ;NIL + QBOPNR ;INIT TO POINTER + QBOCPT ;INIT TO C(POINTER) + QBOPT3 ;OPT ARG, ALT SA + ;ARG NOT PRESENT, SO LEAVE STARTING ADR ALONE + ;AND LET CODE INIT IT + QBOPT3 ;INIT BY COMPILED CODE + QBOEFF ;INIT TO CONTENTS OF "EFFECTIVE ADDRESS" + QBOPT3 ;INIT TO SELF (SAME ACTION AS NONE) + + + +QBOPT3: TLNN Q,(ALBOP) + JRST QBOPT2 ;LOCAL, INIT TO NIL + SKIPGE J,MEM(T) ;"INIT" TO CURRENT CONTENTS, GET POINTER TO S.V. CELL + PUSHJ P,ITRAP + SKIPGE E,MEM(J) ;GET CURRENT CONTENTS + PUSHJ P,ITRAP + MOVEM E,(D) ;(THING GETTING INITED IS REALLY SAVED BINDING) + AOS D + AOS I + AOJA T,QBD1 + +QBOPNR: AOS I ;INIT TO PNTR + SKIPGE E,MEM(I) + PUSHJ P,ITRAP + JRST QBD1B + +QBOCPT: AOS I ;INIT TO C(PNTR) + SKIPGE J,MEM(I) + PUSHJ P,ITRAP + SKIPGE E,MEM(J) + PUSHJ P,ITRAP + JRST QBD1B + +QBOEFF: AOS I ;INIT TO CONTENTS OF "EFFECTIVE ADR" + PUSH P,A + PUSH P,B + SKIPGE A,MEM(I) + PUSHJ P,ITRAP + LDB E,[60300,,A] ;INDEX FIELD + MOVE B,A + ANDI B,777 + JRST @QBOFDT(E) + +QBFE: ADD B,LPFEF(S) ;POINTER TO FEF OF FCTN ENTERING +QBDR1: SKIPGE E,MEM(B) + PUSHJ P,ITRAP + POP P,B + POP P,A + JRST QBD1B + + +QBQT: MOVEI B,QQTPG-400-MEM(B) + JRST QBDR1 + +QBDLOC: SKIPGE QLOCO + JSP ZR,QBFTE1 + ADD B,QLOCO + ADDI B,-500-MEM(S) ;LPLOFF ACCOUNTED FOR IN QLOCO + JRST QBDR1 + +QBDARG: ADDI B,-600-MEM+LPLOFF(S) + JRST QBDR1 + +QBDPDL: HALT ;PDL NOT LEGAL FOR THIS SORT OF EF ADR + +QBTMA2: MOVEI E,QBTMA ;ALSO TOO MANY ARGS + IORM E,QBTRP + ADD D,ZR + JRST QBD2A ;FINISH REST OF ARG DESC LIST + +QBTMA1: MOVEI E,QBTMA ;TOO MANY ARGS AND ARG DESC LIST ALL USED UP + IORM E,QBTRP + ADD D,ZR ;SPACE PAST THEM SO LOCAL BLOCK WILL BE BEYOND THEM +QBD2: SKIPGE QLOCO + PUSHJ P,QLLOCB + MOVE AP,S ;STORE NEW ARG POINTER + MOVEI IP,-1(D) ;POINT TO LAST WORD OF LOCAL BLOCK (OR WHATEVER) + MOVE J,QLOCO + MOVE B,NARGS ;NUMBER ACTUAL ARGS SUPPLIED + DPB B,[%LPENA,,J] +; SKIPE QRSPCF ;ANY SPECIALS THIS BLOCK? +; TLO J,(LPESF) ;YES + TLO J,QZFIX_5 + MOVEM J,LPENS(AP) ;STORE ENTRY STATE WORD + JRST QLENX + + +QBSPCL: PUSH P,Q + PUSH P,B + MOVE B,MEM(T) ;NEXT CELL IN S.V. POINTER LIST + PUSHJ P,QBND1 ;SAVE CURRENT BINDING + MOVE Q,(D) ;ARG/LOCAL BLOCK CONTENTS + DPB Q,[%NDAT,,MEM(B)] ;STORE IN NEW BINDING + POP P,B + POP P,Q + AOJA T,CPOPJ + +; SETOM QRSPCF ;SPECIALS IN BLOCK +; PUSH P,A +; PUSH P,B +; SKIPGE J,MEM(T) ;NEXT CELL IN S.V. POINTER LIST +; PUSHJ P,ITRAP +; SKIPGE B,MEM(J) ;CURRENT VALUE CELL CONTENTS +; PUSHJ P,ITRAP +; SKIPGE A,(D) ;ARG/LOCAL BLOCK CONTENTS +; PUSHJ P,ITRAP +; DPB A,[%NDAT,,MEM(J)] ;EXCH THEM +; DPB B,[%NDAT,,(D)] +; POP P,B +; POP P,A +; AOJA T,CPOPJ ;INCR POINTER TO S.V. LIST + + + +QDTN: +QDTAT1: CAIN C,QZFIX + JRST QBDDT1 ;OK + CAIN C,QZXNUM + JRST QBDDT1 +QBDDT3: MOVEI E,QBBDT ;BAD DATA TYPE +QBDDT2: IORM E,QBTRP + JRST QBDDT1 + +QDTFXN: CAIN C,QZFIX + JRST QBDDT1 + JRST QBDDT3 + +QDTSYM: CAIN C,QZSYM + JRST QBDDT1 + JRST QBDDT3 + +QDTATM: CAIN C,QZSYM + JRST QBDDT1 + JRST QDTAT1 + +QDTLST: CAIN C,QZLIST + JRST QBDDT1 + CAIE C,QZLSTR + CAIN C,QZLSYM + JRST QBDDT1 + CAIE C,QZSYM + JRST QBDDT3 ;LOSE + MOVE E,(D) + TDNN E,[37,,-1] + JRST QBDDT1 ;NIL OK + JRST QBDDT3 + +QDTFRM: CAIN C,QZFEFP + JRST QBDDT1 + JRST QBDDT3 + +QDTERR: HALT + +QBEQE: JUMPE C,QBEQC1 +QBEQQ1: MOVEI E,QBBQTS + IORM E,QBTRP + JRST QBEQC1 + +QBEQQ: JUMPN C,QBEQC1 + JRST QBEQQ1 + +;FRMSWP: SKIPGE A,LPFEF(AP) ;SWAP BINDINGS AND VALUE CELLS OF SPECIAL VARS IN FRAME +; PUSHJ P,ITRAP ;POINTED TO BY ARG POINTER. MUST NOT CLOBBER T +; LDB B,[%NDTB,,A] +; CAIE B,QZFEFP +; JRST FRMST1 +; SKIPGE D,MEM(A) +; PUSHJ P,ITRAP +; LDB B,[%FRMDT,,D] +; CAIE B,FRMFEF +; JRST FRMST1 +;FRMSW1: SKIPGE C,QFSVMP+MEM(A) +; PUSHJ P,ITRAP +; MOVEI B,QFVA(A) ;POINTER TO SPECIAL VAR VALUE CELL LIST +; TLNN C,(QFSBMA) ;SPECIAL FRAME MAP A WINNER? +; JRST FRMS1 ;NO, SCAN ARG LIST (PAIN) +; TLZ C,777760 ;FLUSH EXTRA BITS +;FRMSF2: JFFO C,FRMSF1 +; POPJ P, + +FRMBN1: MOVE C,QFSVMP+MEM(A) ;BIND S.V. S FROM FRAME FAST ENTERED USING S.V. MAP. + MOVEI T,QFVA(A) ;POINTER TO SPECIAL VAR VALUE CELL LIST. + TLNN C,(QFSBMA) ;SPECIAL FRAME MAP A WINNER? + HALT ;FOO, FAST OPTION SHOULDNT HAVE BEEN TURNNED ON. + ; (IT ISNT WORTH IT TO HAVE ALL THE HAIRY MICROCODE JUST + ; TO SPEED THIS RANDOM CASE UP A TAD.) + TLZ C,777760 ;FLUSH EXTRA BITS +FRMBN2: JFFO C,FRMBF1 + POPJ P, + + +FRMBF1: ANDCM C,FRMJT(D) ;FLUSH BIT + ADDI D,1-14.(AP) ;GET NTH SLOT FROM ARG POINTER (-14 FOR HIGH ORDER BITS) + MOVE B,MEM(T) ;LOCN TO BE BOUND + TLNE B,NUSRCB + HALT ;RAN OUT OF S.V. VALUE CELL LIST TOO SOON + PUSHJ P,QBND1 ;SAVE PREV VALUE + MOVE J,(D) ;NEW CONTENTS + DPB J,[%NDAT,,MEM(B)] ;STORE INTO VALUE CELL + AOJA T,FRMBN2 + +FRMJT: REPEAT 36.,SETZ_-.RPCNT + +;FRMSF1: ANDCM C,FRMJT(D) ;FLUSH BIT +; ADDI D,1-14.(AP) ;GET NTH SLOT FROM ARG POINTER (-14 FOR HIGH ORDER BITS) +; SKIPGE Q,MEM(B) ;AND LOCN OF S.V. VALUE CELL +; PUSHJ P,ITRAP +; TLNE Q,NUSRCB +; JRST FRMST2 ;RAN OUT OF S.V. VALUE CELL LIST TOO SOON +; SKIPGE J,MEM(Q) +; PUSHJ P,ITRAP +; SKIPGE S,(D) +; PUSHJ P,ITRAP +; DPB J,[%NDAT,,(D)] +; DPB S,[%NDAT,,MEM(Q)] +; AOJA B,FRMSF2 +; +;FRMS1: SKIPGE E,MEM+QFEMSC(A) ;GET ARG LIST DATA +; PUSHJ P,ITRAP +; LDB I,[%QFAGS,,E] ;START OF ARG LIST +; LDB R,[%QFAGL,,E] ;LENGTH OF ARG LIST +; ADDI I,(A) ;ADD IN START OF FEF +; MOVEI D,LPLOFF(AP) ;POINTER TO SLOT IN ARG/LOCAL BLOCK +; ;START WITH ARG LIST +;FRMS2: SOJL R,CPOPJ ;END OF ARG LIST +; SKIPGE Q,MEM(I) ;ACCESS WORD OF BINDING OPTIONS +; PUSHJ P,ITRAP +; TLNE Q,(ALNP) +; AOS I ;SKIP OVER NAME IF PRESENT +; LDB E,[%ALAGS,,Q] ;ARG SYNTAX +; CAILE E,ALOPT +; JUMPGE D,[ LDB D,[%LPLBO,,LPENS(AP)] ;START WITH LOCAL BLOCK +; ADDI D,(AP) +; TLO D,400000 ;INDICATE ALREADY IN LOCAL BLOCK +; JRST .+1] +; TLNN Q,(ALBOP) +; AOJA I,[AOJA D,FRMS2] ;NOT SPECIAL BUT TAKES LOCAL SLOT +; CAILE E,ALAUX +; AOJA I,[AOJA B,FRMS2] ;INTERNAL OR FREE (DOES NOT TAKE LOCAL SLOT) +; ;DOES TAKE S-V-LIST SLOT +; SKIPGE Q,MEM(B) ;NEXT IN S.V. VALUE CELL POINTER LIST +; PUSHJ P,ITRAP +; TLNE Q,NUSRCB +; JRST FRMST2 ;CONTRADICTORY FEF +; SKIPGE J,MEM(Q) ;Q HAS POINTER TO VALUE CELL +; PUSHJ P,ITRAP +; SKIPGE S,(D) ;EXCH WITH FEF CONTENTS +; PUSHJ P,ITRAP +; DPB J,[%NDAT,,(D)] ;(LEAVE CDR CODE) +; DPB S,[%NDAT,,MEM(Q)] +; AOS B ;NEXT S.V. VALUE CELL ENTRY +; AOS D ;NEXT LOCAL SLOT +; AOJA I,FRMS2 ;NEXT ARG DESC ENTRY + +;FRMST1: HALT ;ATTEMPTED TO SWAP A NON-FEF +;FRMST2: HALT ;INCONSISTANT FEF (S.V. LIST TOO SHORT FOR FAST S.V. MAP) + + +; MUST NOT CLOBBER B J I S R +BBLKP: TLOA ZR,-1 ;SIGNAL BLOCK MODE +QUNBND: TLZ ZR,-1 ;POP OFF SINGLE ENTRY + MOVE A,QLBNDP ;POP BLOCK OFF BIND LIST +BBLKP1: SKIPGE Q,(A) ;GET BOUND LOCN + PUSHJ P,ITRAP + LDB C,[%NDTB,,Q] + CAIE C,QZXSYM + HALT + SKIPGE C,-1(A) ;GET PREV CONTENTS + PUSHJ P,ITRAP + SKIPGE MEM(Q) ;MAYBE TAKE TRAP + PUSHJ P,ITRAP + DPB C,[%NDAT,,MEM(Q)] ;RESTORE + TLNE C,NUSRCB + TLZ PC,QBBFL ;POPPING LAST GUY OF BLOCK, SO NO MORE FOR THIS BLOCK + SUBI A,2 + TLNN C,NUSRCB + JUMPL ZR,BBLKP1 ;NOT START OF ENTRY FOR THIS BLOCK (XFER IN POP BLOCK MODE) + HRRZM A,QLBNDP ;STORE BACK BIND LIST POINTER + POPJ P, + +XCATCH: JRST XCAT1 ;%CATCH, ONLY GET HERE WHEN NO THROW +XERRS: JFCL ;%ERRSET, ONLY GET HERE WHEN NO ERROR OR ERR +XCAT1: POP IP,T + POP IP,ZR + PUSH IP,T + PUSHJ P,XTRUE + PUSH IP,T + JSR 0,MR2V ;RETURN TWO VALUES + +XERO: SKIPA T,[QZUENT_5,,UERRS] +XCTO: MOVE T,[QZUENT_5,,UCATCH] + SUB P,[2,,2] + POP IP,S ;OPEN CATCH BLOCK, POP RESTART PC + MOVEI R,-PDL+1(P) ;MICRO-STACK LEVEL + PUSHJ P,SADRPC ;STORE RESTART PC ADI BLOCK + JRST XCTO1 + + +XERR: SKIPA T,[QZUENT_5,,UERRS] ;ERR +XTHROW: MOVE T,[QZUENT_5,,UCATCH] ;THROW + MOVEM T,CATCHM ;MARK + POP IP,CATCHV ;VALUE + POP IP,CATCHT ;TAG +XTHRW7: HRRZ I,IPMARK ;LAST OPEN CALL BLOCK +XTHRW4: CAIGE I,(AP) ;LOOK FOR OPEN CALL BLOCK TO APPROPRIATE FCTN + HALT ;LOSE + CAIN I,(AP) + JRST [ JSR XTHRW1 ;THAT BLOCK REALLY ACTIVE, POP IT + JRST XTHRW7] + MOVE ZR,CATCHM ;CATCH MARK + XOR ZR,(I) + TDNE ZR,[1777,,-1] + JRST XTHRW2 ;THAT ONE ISNT IT + MOVE ZR,LPFEF+1(I) ;IS TAG (OTHERWISE KNOWN AS EVENTUAL FIRST ARG TO FCTN) + XOR ZR,CATCHT ;RIGHT? + TDNE ZR,[1777,,-1] + JRST XTHRW2 ;NO + MOVE B,LPCLS(I) + TLNN B,(LPADL) + JRST XTHRW9 ;NO ADI, DEST OF FRAME HAD BETTER BE RETURN + MOVEI S,LPCLS-1(I) +XTHRW3: MOVE Q,(S) + LDB J,[%NDTB,,Q] + CAIE J,QZFIX + HALT + LDB J,[%ADITP,,Q] + CAIE J,ADRPC + JRST XTHRW8 ;NOT RESTART PC + LDB J,[%ARMSL,,Q] ;DESIRED MICRO-STACK LEVEL + ADDI J,PDL-1 + CAIL J,PDL ;MICRO STACK MUST ALWAYS HAVE RETURN TO MAIN LOOP + CAILE J,(P) ;DONT SKIP ON MICRO STACK NOT AS DEEP AS %ARMSL + HALT ;LOSEY LOSEY + MOVE R,I + LDB ZR,[%LPCAD,,LPCLS(I)] + SUB R,ZR ;INDEX TO PREVIOUS FRAME + CAIE R,(AP) + HALT + MOVE E,-1(S) ;RESTART PC + LDB A,[%NDTB,,LPFEF(R)] + JRST @THRWD1(A) + +XTHWU1: DPB E,[%LPMPC,,LPEXS(R)] +; MOVEI ZR,0 +; DPB ZR,[%LPNWP,,LPENS(R)] ;IN CASE ANY GARBAGE IS THERE FROM PREVIOUS + ;ENTRY-EXIT OF FRAME +XTHRW5: CAIN J,(P) + JRST XTHRW6 + POP P,ZR + TLNE ZR,PPBSPC + PUSHJ P,BBLKP + JRST XTHRW5 + +XTHWM1: DPB E,[L%PEPB LPEXS(R)] ;FRAME IS MACROCOMPILED, SMASH RESTART PC + LSH E,-1 + DPB E,[%LPEPC,,LPEXS(R)] + JRST XTHRW5 + +XTHWI1: MOVE B,LPFEF(R) ;FRAME FEF DT INVZ + MOVE B,MEM(B) + MOVEM B,LPFEF(R) + LDB A,[%NDTB,,B] + JRST @THRWD1(A) + + +XTHRW6: +XTHBL1: JUMPL S,XTHBL2 ;XFER ON NO RESTART-PC FOUND. + HRRZ E,-3(S) ;GET DESIRED BINDING PDL LEVEL. (THIS HAD BETTER BE THE DATA + MOVE A,QLBNDP ; Q OF THE ADIBDL ADI BLOCK.) + SUB A,QLBNDO + CAILE E,(A) + HALT ;BINDING STACK ALREADY OVERPOPPED? + CAIE E,(A) + JRST [ PUSHJ P,QUNBND ;POP ONE AND TRY AGAIN + JRST XTHBL1] +XTHBL2: MOVE AP,I + PUSH P,CATCHV ;VALUE TO BE RETURNED + MOVE T,CATCHV ;QMEX1 REQUIRES VALUE BOTH PLACES + JRST QMEX1 + +XTHRW8: TLNN Q,NUSRCB + HALT + SOS S + MOVE Q,(S) + TLNN Q,NUSRCB + JRST XTHRW9 ;NO RIGHT FLAVOR ADI + SOJA S,XTHRW3 + +XTHRW9: LDB C,[%LPCSD,,LPCLS(I)] ;NOT AN ADI CALL + CAIE C,4 ;D-RETURN + HALT ;LOSE. DONT KNOW WHERE TO RESTART + LDB S,[%LPCAD,,LPCLS(I)] ;DELTA TO ACTIVE FRAME -- THIS + SUB I,S ; IS THE ONE WE WANT TO RETURN FROM + MOVNI S,1 ;FLAG NO RESTART-PC ADI, SO WILL NOT TRY TO + ; HACK BIND STACK LEVEL + MOVEI J,PDL ;FLUSH MICRO-STACK ALL THE WAY + JRST XTHRW5 + +XTHRW2: LDB ZR,[%LPCPN,,LPCLS(I)] ;INDEX BACK TO NEXT OPEN CALL BLOCK + SUB I,ZR + JRST XTHRW4 + +XTHRW1: 0 ;CALL WITH JSR !! + JSP S,UNWP ;POP FRAME POINTED TO BY IP + MOVE B,LPCLS(AP) + LDB A,[%NDTB,,LPFEF(AP)] ;PERFORM "EXIT OPERATION" ASSOCIATED + JRST @THRWD2(A) ; WITH LEAVING CURRENT FRAME + +XTHWI2: MOVE S,LPFEF(AP) + MOVE S,MEM(S) + MOVEM S,LPFEF(AP) + LDB A,[%NDTB,,S] + JRST @THRWD2(A) + +XTHWM2: TLZE PC,QBBFL ;EXIT MACRO-CODE FRAME + PUSHJ P,BBLKP +; MOVE S,LPENS(AP) +; TLNE S,(LPESF) +; PUSHJ P,FRMSWP +XTHWL2: +XTHWU2: MOVE B,LPCLS(AP) ;BBLKP CLOBBERS AC S +IFN FNASW,[ + TLNE B,(LPFNAB) + PUSHJ P,BBLKP ;POP FUNARG (CLOSURE) BINDING BLOCK, IF ANY +] + HRRI IP,-LLPFRM(AP) + LDB J,[%LPCPN,,B] + HRRZ ZR,AP + SUB ZR,J + MOVEM ZR,IPMARK + LDB ZR,[%LPCAD,,B] + SUB AP,ZR + MOVE A,LPEXS(AP) + LDB J,[%NDTB,,LPFEF(AP)] + JRST @THRWD3(J) ;DO ENTRY OPERATION ASSOC WITH FRAME + ;ENTERING +XTHWI3: MOVE S,LPFEF(AP) + MOVE S,MEM(S) + MOVEM S,LPFEF(AP) + LDB J,[%NDTB,,LPFEF(AP)] + JRST @THRWD3(J) + +XTHWM3: LDB PC,[%LPEPC,,A] ;ENTERING MACROCODE FRAME + LDB E,[%NDAT,,LPFEF(AP)] + ADD PC,E + LDB J,[%LPCST,,A] + DPB J,[%PCSTS,,PC] + LDB C,[%LPCSD,,B] ;DONT CARE ABOUT SAVED DEST, REALLY +; TLNE B,(LPCARV) +; TLO PC,QBNEAF +; LDB J,[%LPLBO,,LPENS(AP)] ;GOING THRU QMEX1 ANYWAY, SO THIS WILL GET +; MOVEM J,QLOCO ; SET UP EVENTUALLY. + JRST @XTHRW1 + + +;XTHR1B: CAIN J,QZMESA +; JRST XTHR1C +; CAIN J,QZLIST +; JRST [ LDB E,[%LPMPC,,A] +; CAIE E,INTRET ;HAD BETTER BE INTERPRETER RETURN +; HALT +; JRST XTHR1C] +; CAIE J,QZIVGC ;REALLY SHOULD NOT BE INVZ ON PDL BUT PDP-10 +; CAIN J,QZIVCE ;LOSES. +; JRST XTHR1C +; CAIE J,QZUENT ;RETURNING TO MICRO-CODE +; HALT ;PDL SCREWWED + +XTHWL3: LDB E,[%LPMPC,,LPEXS(AP)] + CAIE E,INTRET + HALT +XTHWU3: JSP S,QMMPOP ;POP STUFF FROM LINEAR BIND PDL IF NECC + DPB J,[%LPNWP,,LPENS(AP)] ;FLUSH GARBAGE, ZERO OUT + TLZ PC,QINDAT+QINDNL+QBBFL ;+QBNEAF +;IF THIS FRAME IS TO BE RUN AGAIN, LPEXS WILL GET SET FROM RESTART PC. +; TLNE A,(LPEBFL) +; TLO PC,QBBFL ;RESTORE BINDS PUT ON STACK FLAG +; MOVSI ZR,QZFIX_5 +; MOVEM ZR,LPEXS(AP) ;BACK IN THIS FRAME NOW. +; LDB E,[%LPMPC,,A] + JRST @XTHRW1 + +UNWP: HRRZ R,P ;UNWIND P STACK, CALL WITH JSP S, +UNWP1: CAIG R,PDL + JRST [MOVE P,[-LPDL+1,,PDL] + JRST (S)] + MOVE ZR,(R) + TLNE ZR,PPBSPC + PUSHJ P,BBLKP + SOJA R,UNWP1 + +SADRPC: LDB ZR,[%NDTB,,S] ;STORE RESTART PC ADI BLOCK (ADR IN S) + CAIE ZR,QZFIX ;MICRO-STACK RESTORE LEVEL IN R + HALT + TLZ S,RBMSK +USADRPC: MOVE ZR,QLBNDP ;PUSH BINDING LIST ADI + SUB ZR,QLBNDO + TLZ ZR,777740 + TLO ZR,QZFIX_5 + PUSH IP,ZR + PUSH IP,[_18.+ADIBDL_24] + TLO S,NUSRCB + PUSH IP,S ;STORE RESTART PC ADI BLOCK + PUSH IP,[_18.+ADRPC_24] + DPB R,[%ARMSL,,(IP)] ;SAVE MICRO-STACK RESTORE LEVEL + POPJ P, + +XEROM: SKIPA T,[QZUENT_5,,UERRS] +XCTOM: MOVE T,[QZUENT_5,,UCATCH] + SUB P,[2,,2] + POP IP,D + POP IP,S + PUSHJ P,LMVRB ;LEAVE ROOM FOR VALUES TO BE RCVED + MOVEI R,-PDL+1(P) + PUSHJ P,SADRPC ;STORE RESTART PC ADI BLOCK + TLO I,NUSRCB ;THIS ONE DOESNT TERMINATE ADI + JRST XCTOM1 + + +XLEC: SKIPA S,[_18.+ADILEX_24] +XFEC: MOVE S,[_18.+ADIFEX_24] + SUB P,[2,,2] + POP IP,T ;MAKE FEXPR ADI ENTRY + PUSHJ P,SADFEX + JRST XCTO1 + +XLECM: SKIPA S,[_18.+ADILEX_24] +XFECM: MOVE S,[_18.+ADIFEX_24] + SUB P,[2,,2] + POP IP,D ;MAKE BOTH FEXPR AND MV ADI ENTRIES + POP IP,T + PUSHJ P,LMVRB + PUSHJ P,SADFEX + TLO I,NUSRCB ;THIS ONE DOESNT TERMINATE ADI + JRST XCTOM1 + +SADFEX: PUSH IP,[QZFIX_5,,] ;NOT USED FOR FEX ADI + PUSH IP,S + POPJ P, + +XC0MVL: SUB P,[2,,2] ;%CALL0-MULT-VALUE-LIST + PUSHJ P,XCMVL0 + JRST QMRCL + +XCMVL: SUB P,[2,,2] ;%CALL-MULT-VALUE-LIST +XCMVL0: POP IP,T ;FCN TO CALL + PUSH IP,[QZSYM_5,,] ;NIL (ON RETN WILL BE LIST) + MOVEI D,(IP) + HRLI D,QZMEMP_5 + PUSH IP,D ;LOW ADI WD -> THAT NIL + PUSH IP,[_18.+ADIRT_24+ADISC_21] + JRST XCTO1 + +XC0MV: SUB P,[2,,2] + PUSHJ P,XCMV0 ;LIKE BELOW, BUT CALL FCTN OF 0 ARGS + JRST QMRCL + +XCMV: SUB P,[2,,2] ;ON MISC INSTRUCTION, DONT STORE IN DEST +XCMV0: POP IP,D ;MAKE ADDITIONAL INFO TYPE CALL BLOCK FOR MULT +XCMV1: POP IP,T ;ARG RETURN CALL THIS AS MISC FCTN OF 2 ARGS + PUSHJ P,LMVRB ;LEAVE ROOM FOR VALUES TO BE RECIEVED +XCTOM1: PUSH IP,I + IOR D,[_18.+ADIRT_24+ADISB_21] + PUSH IP,D ;STORE ADTL INFO +XCTO1: PUSHJ P,CBM ;STORE CALL BLOCK (DEST IN C) + MOVSI D,(LPADL) + IORM D,LPCLS(IP) ;SET ADTL INFO BIT + POPJ P, + +LMVRB: LDB ZR,[%NDTB,,D] ;LEAVE ROOM ON IP FOR # VALUES IN D TO BE RECIEVED. + CAIE ZR,QZFIX ;RETURN LOCATIVE POINTER TO HEAD OF BLOCK IN ZR + HALT + TLZ D,777740 + CAIG D,100 +ULMVRB: SKIPN E,D + HALT ;UNREASONABLE VALUE + MOVEI I,-MEM+1(IP) ;SAVE POINTER TO HEAD OF BLOCK + PUSH IP,[QZSYM_5,,] ;LEAVE SPACE TO RECEIVE VALUES + SOJG E,.-1 + TLO I,QZXSYM_5 ;WOULD BE QZXSTR ON REAL MACHINE + POPJ P, + + +QICAL0: PUSHJ P,CBM ;CALL FCTN OF NO ARGS + JRST QMRCL + +;************************ HAS TO CHECK PDL LIMIT ******* +XOCB: POP IP,C ;%OPEN-CALL-BLOCK + POP IP,A ; + POP IP,T ; + HRRZS C + CAIE C,4 ;DEST RETURN? + JRST XOCB0 + MOVE D,LPCLS(AP) ;DOES CURRENT RUNNING FRAME HAVE ADI? + TLNN D,(LPADL) + JRST XOCB0 ;NOPE. + MOVEI D,-LLPFRM(AP) ;YES, LINK UP MV WITH INDIRECT POINTER + TLO D,QZMEMP_5 + PUSH IP,D + PUSH IP,[QZFIX_23.] + MOVEI D,ADIP + DPB D,[%ADIRB,,(IP)] + MOVEI D,ADIRT + DPB D,[%ADITP,,(IP)] + AOS A +XOCB0: HRRZS A + JUMPE A,XOCB2 ;NO ADI + HRRZ B,IP ;SCAN BACK UP IP, MAKING SURE BUSRC BITS ARE SET RIGHT + MOVSI D,NUSRCB +XOCB1: IORM D,-1(B) ;SET ALL + IORM D,0(B) + SUBI B,2 + SOJG A,XOCB1 + ANDCAM D,+2-1(B);EXCEPT CLEAR LAST ONE + PUSHJ P,CBM + MOVSI D,(LPADL) + IORM D,LPCLS(IP) + POPJ P, + +XOCB2: PUSHJ P,CBM ;DO PUSHJ FOR DEBUGGING SO WE MIGHT HAVE A CHANCE .. + POPJ P, + +XPUSH: MOVE T,(IP) ;%PUSH TAKES ONE ARG ON IP AND LEAVES IT THERE! + POPJ P, ;RETURNS ITS ARGUMENT, IN LIEUE OF ANYTHING ELSE + +XACTOB: SUB P,[2,,2] ;FLUSH RETURN TO QIMSC AND DEST AND QIMSC PUSHED. + JRST QMRCL ;GIVE IT A TRY AND SEE WHAT HAPPENS + ;THIS IS OK BUT ON REAL MACHINE MAY NEED TO FIX CDR CODES + +XAPDLR: POP IP,A ;%ASSURE-PDL-ROOM + ADD A,IP + HRRZ B,QLPDLH + CAIG B,(A) + HALT ;NOT ENUF + JRST XTRUE +.SEE %QFMXP ;FOR WHAT THIS FUNCTION HAS TO HACK *********************** + +XPSG: SUB P,[2,,2] ;DONT STORE IN DESTINATION + POP IP,A ;%STACK-GROUP-PRESET + HRRZ J,IPMARK ;POINTER TO OPEN CALL BLOCK + CAIG J,(AP) + HALT ;HAD BETTER BE AN OPEN BLOCK + HRRZ C,IP ;END OF CALL BLOCK TO XFER + PUSHJ P,PSG1 +FLSOCB: HRRZ J,IPMARK ;FLUSH OPEN CALL BLOCK FROM IP STACK + CAIG J,(AP) + HALT + MOVE B,LPCLS(J) + LDB Q,[%LPCPN,,B] + MOVE ZR,J + SUB ZR,Q + HRRZM ZR,IPMARK + MOVEI R,LPCLS-1(J) + TLNN B,(LPADL) + JRST FLSOC1 ;NO ADI, THATS IT +FLSOC2: MOVE Q,(R) ;CALL HAD ADI, FIGURE OUT HOW MUCH + TLNN Q,NUSRCB + HALT + SOS R + MOVE Q,(R) + TLNE Q,NUSRCB + SOJA R,FLSOC2 +FLSOC1: HRRZ ZR,IP + SUB ZR,R + HRLS ZR + SUB IP,ZR ;FLUSH STUFF + POPJ P, + +PSG1: LDB ZR,[%NDTB,,A] + CAIE ZR,QZSTKG + HALT + LDB ZR,[%NDTB,,MEM(A)] + CAIE ZR,QZARYH + HALT + LDB ZR,[%ARYTP,,MEM(A)] + CAIE ZR,ARTSGH + HALT + LDB ZR,[%SGSST,,SGSTAT+MEM(A)] ;PRESET STACK-GROUP IN A TO CALL BLOCK + CAIN ZR,SGNACT ;POINTED TO BY J AND TERMINATED BY C + HALT ;CANT PRESET ACTIVE S-G + MOVE S,MEM(A) + MOVE B,LPCLS(J) + MOVEI D,MEM+1(A) ;COMPUTE INITIAL IP POINTER + TRNE S,ARYEXL ; +1 TO MOVE PAST ARRAY HEADER + AOS D ;EXTENDED ARRAY, SPACE PAST INDEX-LENGTH Q + MOVEI R,LPCLS-1(J) ;GET POINTER TO BEGINNING OF BLOCK +; TLNN B,(LPADL) +; JRST PSG1A +;PSG1B: MOVE Q,(R) ;SPACE TO BEG OF ADI +; TLNN Q,NUSRCB +; HALT +; SOS R +; MOVE Q,(R) +; TLNE Q,NUSRCB +; SOJA R,PSG1B +; MOVEI E,0 ;FLAG .NE. 0 IF ADI MOVED +;PSG1B1: LDB ZR,[%ADITP,,1(R)] ;COPY OVER ADI EXCEPT ADIRT STUFF +; CAIN ZR,ADIRT +; JRST PSG1B2 +; MOVE Q,(R) ;COPY ADI PAIR OVER +; SKIPN E +; TLZA Q,NUSRCB ;THIS FIRST ONE PUSHED +; TLO Q,NUSRCB +; MOVEM Q,(D) +; MOVE Q,1(R) +; MOVEM Q,1(D) +; AOS E +; ADDI D,2 +;PSG1B2: ADDI R,2 +; CAIGE R,LPCLS-1-1(J) +; JRST PSG1B1 ;LOOP TO COPY MORE ADI +; SKIPN E + TLZ B,(LPADL) ;ONLY ADI WAS ADIRT +PSG1A: ADDI D,LLPFRM + TRZ B,<.BM %LPCAD>+<.BM %LPCPN> ;DELTA S 0 SINCE THIS AT HEAD OF GROUP + MOVEM B,LPCLS(D) + MOVE B,LPEXS(J) + MOVEM B,LPEXS(D) + MOVE B,LPENS(J) + MOVEM B,LPENS(D) + MOVE B,LPFEF(J) + MOVEM B,LPFEF(D) + HRRZ ZR,D + SUBI ZR,MEM+1(A) ;RECONVERT TO PDL ARRAY INDEX + TRNE S,ARYEXL + SOS ZR + TLO ZR,QZFIX_5 + MOVEM ZR,SGIFCT+MEM(A) ;ADR OF INITIAL FCTN POINTER + MOVEM ZR,SGAP+MEM(A) ;INITIAL AP + MOVEM ZR,SGIPM+MEM(A) ;INITIAL IP-MARK + MOVEI E,1(J) ;GET PNTR TO FIRST ARG + AOS D ;MAKE D POINT BEYOND FEF POINTER +PSG2: CAMLE E,C ;COPY ARGS OVER + JRST PSG2A + MOVE B,(E) + MOVEM B,(D) + AOS E + AOJA D,PSG2 + +PSG2A: +; SUBI E,1(J) +; HRLI E,QZFIX_5 +; MOVEM E,SGNARG+MEM(A) ;SAVED-NARGS + SUBI D,MEM+1+1(A) ;+1 FOR ARRAY HEADER, +1 BECAUSE LAST LOCN STORED IN + TRNE S,ARYEXL + SOS D ;EXTENDED ARRAY, +1 FOR INDEX-LENGTH Q + HRLI D,QZFIX_5 ; -1(D) + MOVEM D,SGPDLP+MEM(A) ;STORE INITIAL PDL POINTER + MOVSI D,QZFIX_5 + MOVEM D,SGBP+MEM(A) ;INITIAL L-B-P POINTER + MOVEM D,SGUSTK+MEM(A) ;# XFERRED USTACK Q'S + MOVEI D,SGNAIC ;AWAITING INITIAL CALL + DPB D,[%SGSST,,SGSTAT+MEM(A)] + POPJ P, + +;XAPLYN: POP IP,D ;APPLY, ASK FOR N VALUES +; POP IP,R ;LIST OF ARGS +; PUSHJ P,XCMV1 +; JRST XAPLY1 + +;XAPLY: POP IP,R ;LIST OF ARGS +; POP IP,T ;FNCTN +; PUSHJ P,CBM +;XAPLY1: LDB ZR,[%NDTB,,R] +; CAIE ZR,QZLIST +; JRST QMRCL ;CALL THAT GUY AND SEE WHAT HAPPENS! +; MOVE T,R +; PUSHJ P,QCAR +; PUSH IP,T +; MOVE T,R +; PUSHJ P,QCDR +; MOVE R,T +; JRST XAPLY1 + + +QICALL: ;POINTER TO FEF (IF THATS WHAT IT IS) IN T +CBM: ADDI IP,LLPFRM ;LENGTH OF BLOCK GOING TO MAKE + MOVE ZR,IP + SUB ZR,IPMARK ;DELTA TO PREV IP MARK + MOVEM IP,IPMARK ;SAVE IP AT OPEN CALL + MOVSI S,QZFIX_5 + MOVEM S,LPENS(IP) ;CLEAR OUT UNUSED (FOR NOW) WDS + MOVEM S,LPEXS(IP) + MOVEI S,(IP) + SUBI S,(AP) ;COMPUTER ARG POINTER OFFSET + DPB C,[%LPCSD,,S] ;SAVED DESTINATION + DPB ZR,[%LPCPN,,S] ;DELTA TO PREV IP MARK +; TLZE PC,QBALM ;CURRENT ARG LOADING MODE +; TLO S,(LPCPLI) +; TLZE PC,QBNEAF ;NON-EVAL ARG STORED FLAG +; TLO S,(LPCARV) + TLO S,QZFIX_5 + MOVEM S,LPCLS(IP) + MOVEM T,LPFEF(IP) + POPJ P, + +QIND1: MOVE S,(IP) ;E IN B, C(E) IN T, (IP) IN S + JRST @QINDT1(C) ;DISPATCH ON DESTINATION + +QIPOP: SOS IP +QIMVM: DPB S,[%NDAT,,MEM(B)] ;STORE S IN LOCN OF B +SETIN1: TLZ PC,QINDAT+QINDNL ;SET INDICATORS + LDB J,[%NDTB,,S] + JRST @QNDDT2(J) ;DISPATCH ON D.T. OF THING STORING WITH MOVEM, ETC + +QIMVM1: TDNN S,[37,,-1] + TLO PC,QINDNL +QIMVM7: TLO PC,QINDAT + POPJ P, + +XCADD: POP IP,T +XTCADD: POP IP,S + LDB ZR,[%NDTB,,T] + ADD T,S +XTXIT: LDB A,[%NDTB,,S] + CAIN ZR,QZFIX + CAIE A,QZFIX + BARF ARITH ARGS NOT BOTH FIXNUMS,T/&S/& + JRST BOXT + +XCSUB: POP IP,T +XTCSUB: POP IP,S + LDB ZR,[%NDTB,,T] + SUBM S,T + JRST XTXIT + +XCMUL: POP IP,T +XTCMUL: POP IP,S + LDB ZR,[%NDTB,,T] + IMUL T,S + JRST XTXIT + +XCDIV: POP IP,T +XTCDIV: POP IP,S + LDB ZR,[%NDTB,,T] + LDB A,[%NDTB,,S] + CAIN ZR,QZFIX + CAIE A,QZFIX + HALT + JRST XCDIV1 + +XCAND: POP IP,T +XTCAND: POP IP,S + LDB ZR,[%NDTB,,T] + AND T,S + JRST XTXIT + +XCIOR: POP IP,T +XTCIOR: POP IP,S + LDB ZR,[%NDTB,,T] + IOR T,S + JRST XTXIT + +XCXOR: POP IP,T +XTCXOR: POP IP,S + LDB ZR,[%NDTB,,T] + XOR T,S + JRST XTXIT + +XMADD: POP IP,T ;M-+ (MISC-INST FLAVOR ADD) +XTADD: POP IP,S + ADD T,S +BOXT: TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +BOXPSH: TLZ T,777740 + TLO T,QZFIX_5 + PUSH IP,T + POPJ P, + +XMSUB: POP IP,T ;M-- (MISC-INST FLAVOR SUB) +XTSUB: POP IP,S + SUBM S,T ;NON COMMUTATIVE, AND LAST ARG IN T + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +XMAND: POP IP,T ;M-LOGAND +XTAND: POP IP,S + AND T,S + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +XMXOR: POP IP,T ;M-LOGXOR +XTXOR: POP IP,S + XOR T,S + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +XMIOR: POP IP,T ;M-LOGIOR +XTIOR: POP IP,S + IOR T,S + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +XMMUL: POP IP,T ;M-* +XTMUL: POP IP,S + IMUL T,S + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +XMDIV: POP IP,T ;M-// +XTDIV: POP IP,S +XCDIV1: PUSHJ P,QOADV + LDB T,[%NPTR,,S] + TLO T,QZFIX_5 + POPJ P, + +XMAX: POP IP,T + POP IP,S + TLZ T,777740 + TLZ S,777740 + TLNE T,20 + TLO T,777740 + TLNE S,20 + TLO S,777740 + CAMGE T,S + MOVE T,S + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +XMIN: POP IP,T + POP IP,S + TLZ T,777740 + TLZ S,777740 + TLNE T,20 + TLO T,777740 + TLNE S,20 + TLO S,777740 + CAMLE T,S + MOVE T,S + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +;SINCE REAL MACHINE HAS %AREA-NUMBER, LMI SHOULD TOO. THIS VERSION DOESN'T TRY TO BE FAST. +XARN: POP IP,S + TLZ S,777740 + MOVEI T,NAREAS-1 +XARN0: HRRZ Q,.OAAOR(T) + CAMGE S,Q +XARN1: SOJGE T,XARN0 + JUMPL T,XFALSE + SUBM S,Q + HRRZ R,.OAALN(T) + JUMPE R,XARN1 + CAML Q,R + SOJGE T,XARN0 + JUMPL T,XFALSE + HRLI T,QZFIX_5 + POPJ P, + +XSNA: POP IP,T ;%SET-#-AREAS DOES NOTHING EXCEPT ON REAL MACHINE + JRST XFALSE + +;XMADD: SKIPA C,[1] +;XMSUB: MOVEI C,2 +;XMOP1: POP IP,T ;ARGS IN -1(IP), 0(IP). RESULT TO T. +; MOVE S,(IP) ;FLUSH ARGS FROM STACK +; PUSHJ P,QIADD +; POP IP,T +; POPJ P, + +;XMMUL: SKIPA C,[3] +;XMDIV: MOVEI C,4 +; JRST XMOP1 + +;XMAND: SKIPA C,[5] +;XMXOR: MOVEI C,6 +; JRST XMOP1 + +;XMIOR: MOVEI C,7 +; JRST XMOP1 + + +QIADD: +QISUB: +QIMUL: +QIDIV: +QIAND: +QIXOR: +QIIOR: LDB J,[%NDTB,,S] + LDB R,[%NDTB,,T] + CAME J,R + JRST QOPDD ;DATA TYPES DIFFER + CAIN J,QZFIX + JRST QOAFX + JRST QOPILL + +QOPDD: BARF DATA TYPES DIFFER,S/&T/& +QOPILL: BARF DATA TYPE ILLEGAL,S/&T/& +QIERR: BARF UNUSED OP CODE EXECUTED + +QOAFX:; TLZ T,777740 ;ARGS IN S AND T, RESULT TO (IP) +; LDB I,[%NPTR,,S] +; TLNE I,20 +; TLO I,777740 + XCT (C)-1+[ ADD S,T ;TBL OF INST TO DO ARITH WORK + SUB S,T + IMUL S,T + PUSHJ P,QOADV ;IDIV S,T + AND S,T + XOR S,T + IOR S,T] + DPB S,[%NPTR,,(IP)] +QOAFX2: TLZ PC,QINDNL + TLO PC,QINDAT ;NUMBERS ARE NUMBERS, NOT NIL + POPJ P, + +QOADV: TLZ T,777740 ;ARGS IN S AND T, RESULT TO S + TLNE T,20 + TLO T,777740 + TLZ S,777740 + TLNE S,20 + TLO S,777740 + PUSH P,S+1 ;AP RANDOMLY + IDIV S,T + POP P,S+1 + POPJ P, + +QIND2: MOVE S,(IP) + JRST @QINDT2(C) + +XMEQ: POP IP,T + MOVE S,(IP) + PUSHJ P,QIEQ +XMGR1: TLNE PC,QINDNL + JRST XFALSE + JRST XTRUE + +QIEQ: MOVE ZR,S + XOR ZR,T + TDNE ZR,[1777,,-1] ;DATA TYPE + DATA +QIFLSE: TLOA PC,QINDNL +QITRUE: TLZ PC,QINDNL + TLO PC,QINDAT + SOJA IP,CPOPJ ;POP STACK + +XMLESS: SKIPA C,[2] +XMGRTH: MOVEI C,1 + POP IP,T + MOVE S,(IP) + PUSHJ P,QIGRP + JRST XMGR1 + +QIGRP: +QILSP: LDB J,[%NDTB,,S] + LDB R,[%NDTB,,T] + LDB I,[%NPTR,,S] + LDB D,[%NPTR,,T] + TLNE I,20 + TLO I,777740 + TLNE D,20 + TLO D,777740 + CAME J,R + JRST QOPDD + CAIN J,QZFIX + JRST QIGRFX + JRST QOPILL + +QIGRFX: XCT (C)-1+[ CAMG I,D + CAML I,D] + JRST QIFLSE + JRST QITRUE + + +QISCDR: TLZ B,777740 + TLO B,QZXSYM_5 + PUSH IP,B +QSCD1: PUSHJ P,QCDR + POP IP,B + MOVE S,T + JRST QIMVM + +QSCDDR: TLZ B,777740 + TLO B,QZXSYM_5 + PUSH IP,B + PUSHJ P,QCDR + JRST QSCD1 + +QISP1: +QISM1: LDB R,[%NDTB,,T] + CAIN R,QZFIX + JRST QISPFX + JRST QOPILL + +QISPFX: XCT (C)-6+[ AOS T + SOS T] + DPB T,[%NPTR,,MEM(B)] + JRST QOAFX2 + +QIND3: JRST @QINDT3(C) ;DISPATCH ON GROUP 3 + + +QIBNDN: PUSHJ P,QBND1 ;SAVE CURRENT CONTENTS, SET TO NIL + MOVE T,[QZSYM_5,,] +QIBDN1: DPB T,[%NDAT,,MEM(B)] + POPJ P, + +QIBNDP: PUSHJ P,QBND1 ;SAVE CURRENT CONTENTS, SET TO C(IP) + POP IP,T + JRST QIBDN1 + +XBIND: POP IP,T + POP IP,B ;USER CALLABLE BINDING FCTN (FROM MACRO-CODE) + LDB ZR,[%NDTB,,B] + CAIN ZR,QZXSYM + JRST XBIND1 + CAIE ZR,QZMEMP + BARF BIND NOT TO A MEM POINTER,B/& + SUBI B,MEM +XBIND1: PUSHJ P,QBND1 + JRST QIBDN1 + +QIBND: ;SAVE CURRENT CONTENTS, DONT ALTHER CURRENT CONTENTS +QBND1: ;POINTER TO LOCN TO BIND IN B + TLZ B,777740 + TLO B,QZXSYM_5 + LDB E,[%NDAT,,MEM(B)] ;FETCH CURRENT CONTENTS + TLON PC,QBBFL + TLO E,NUSRCB ;THIS FIRST BINDING IN BLOCK + AOS Q,QLBNDP + MOVEM E,(Q) + AOS Q,QLBNDP + MOVEM B,(Q) + POPJ P, + + +QISETZ: TLZ PC,QINDNL + TLOA PC,QINDAT +QISETN: TLOA PC,QINDNL+QINDAT + SKIPA T,[QZFIX_5,,] + MOVE T,[QZSYM_5,,] + DPB T,[%NDAT,,MEM(B)] + POPJ P, + +QIPSHE: TLZ B,777740 ;PUSH LOCATIVE PNTR TO EFF ADDR + TLO B,QZXSYM_5 + PUSH IP,B + TLZ PC,QINDNL+QINDAT + POPJ P, + +;QIBRN: JRST @BRDTAB(C) ;BRANCH + +;BRANCH ALWAYS +QBRALW: TRNE B,400 ;EXTEND SIGN + ORCMI B,377 + CAMN B,[-1] + JRST QBRALZ ;DOUBLE WORD BRANCH +QBRLZ2: ROT PC,1 ;GET BYTE BIT BACK IN LOW PART + ADD PC,B + ROT PC,-1 ;PUT IT BACK + POPJ P, + +QBRALZ: SKIPGE B,MEM(PC) + PUSHJ P,ITRAP + JUMPL PC,[ ADD PC,[400000,,1] + LSH B,-16. + JRST QBRLZ1] + TLO PC,400000 + ANDI B,177777 +QBRLZ1: TRNE B,100000 + ORCMI B,77777 + JRST QBRLZ2 + +QBRNTP: SOS IP ;DONT BRANCH BUT POP +QBRNOT: CAIE B,777 ;DONT BRANCH + POPJ P, + JUMPL PC, [ADD PC,[SETZ 1] ;SKIP OVER NXT WORD DELTA + POPJ P,] + TLO PC,400000 + POPJ P, + +QBRNL: TLNN PC,QINDNL ;BRANCH ON NIL + JRST QBRNOT + JRST QBRALW + +QBRNNL: TLNE PC,QINDNL ;BRANCH ON NOT NIL + JRST QBRNOT + JRST QBRALW + +QBRAT: TLNN PC,QINDAT ;BRANCH ON ATOM + JRST QBRNOT + JRST QBRALW + +QBRNAT: TLNE PC,QINDAT ;BRANCH ON NOT ATOM + JRST QBRNOT + JRST QBRALW + +QBRNLP: TLNN PC,QINDNL ;BR NIL, POP IF NOT + JRST QBRNTP + JRST QBRALW + +QBRNNP: TLNN PC,QINDNL ;BR N NIL, POP IF + JRST QBRALW + JRST QBRNTP + + +QIMSC: CAIGE B,200 + JRST QMSCO1 ;LIST GROUPS + CAIL B,MSFCTL+200 + JRST QIMSCR + PUSH P,C ;STORE IN DESTINATION + PUSHJ P,@MSFCT-200(B) ;SOME GUYS SUB P,[2,,2] IF DONT WANT TO STORE IN DEST + POP P,C ;DESTINATION + JRST QIMOVE + +QMSCO1: PUSH P,C + HRRZ S,CNSADF ;DEFAULT AREA + TRZE B,100 ;LIST GROUP SKIP ON USE DEFAULT AREA + POP IP,S ;WITH AREA ARG + PUSHJ P,IALLB ;ALLOCATE Q'S IN B IN AREA IN S + PUSH IP,T ;RETURN POINTER TO BLOCK IN T + POP P,C + TLO C,QZFIX_5 ;PUSH DESTINATION + PUSH IP,C + PUSH IP,T ;ANOTHER POINTER TO ALLOCATED BLOCK + POPJ P, + + +XXCONS: SKIPA S,CNSADF ;XCONS +XXCONA: POP IP,S ;XCONS WITH AREA AS THIRD ARG + POP IP,A + EXCH A,(IP) + PUSH IP,A + JRST QCONS + +XNCONS: SKIPA S,CNSADF ;NCONS +XNCONA: POP IP,S ;NCONS WITH AREA AS 2ND ARG + PUSH IP,[QZSYM_5,,] + JRST QCONS + +;XGMFE: POP IP,B +; LDB ZR,[%NDTB,,B] +; CAIE ZR,QZFIX +; HALT +; ANDI B,777 +; CAIL B,200 +; CAIL B,MSFCTL+200 +; HALT +; MOVE T,MSFCT-200(B) +;; TLNE T,XNOUC +;; HALT +; HRLI T,QZFIX_5 +; POPJ P, + + +XCONS: SKIPA S,CNSADF ;CONS +XCONSA: POP IP,S ;CONS WITH AREA AS THIRD ARG +QCONS: HRRZS S + PUSHJ P,IALL2Q ;ALLOCATE 2 Q'S, RETURN POINTER TO THEM IN T + POP IP,B + POP IP,A + TLZ B,NCDRB + TLO B,NXTNOT + MOVEM B,MEM+1(T) + TLZ A,NCDRB ;FULL NODE + MOVEM A,MEM(T) + TLO T,QZLIST_5 + POPJ P, + +IALL2Q: HRRZS S + CAIL S,NAREAS + HALT + LDB A,[000300,,AFSMOD(S)] ;GET FREE STORAGE MODE OF DESIRED AREA + CAIGE A,FSMAX + JRST @IA2QDT(A) +IA2QE: HALT + +IA2QDT: IA2QE ;ERROR + IA2QL ;LINEARLY ADVANCING + IA2QQ ;Q ALLOCATED + IA2QE ;PAGE ALLOCATED + +IA2QL: MOVE T,AFSPTR(S) ;PICKUP UP FREE POINTER (WITHIN AREA) + MOVE B,T + ADDI B,2 + HRRZ C,AFSLN(S) ;LENGTH IN Q'S + CAIGE C,(B) + JRST IALLGC ;GC NEEDED + MOVEM B,AFSPTR(S) + ADD T,AFSORG(S) ;ADD IN ORIG OF AREA + TLZ T,777740 + POPJ P, + +IA2QQ: LDB T,[%NPTR,,AFSPTR(B)] ;SEE IF SPACE AVAIL ON FREE NODE LIST + CAMN T,[37,,-1] + JRST IA2Q1 ;NO ROOM THERE, ANY ON PARTIALLY ALLOC PAGE? + HRRZ C,AFSLN(B) + CAIG C,T + .VALUE ;FS LIST OUT OF AREA + ADD T,AFSORG(S) + SKIPGE C,MEM(T) + PUSHJ P,ITRAP + MOVEM C,AFSPTR(S) + TLZ T,777740 + POPJ P, + + +IA2Q1: LDB T,[%NPTR,,AFSPP(S)] ;PARITALLY ALLOCATED PAGE THIS AREA + TDNE T,[-37,,-1] + JRST IA2Q2 ;0 MEANS NONE + ; TRY TO GET ONE OFF FREE PAGE LIST + LDB C,[%NADIP,,T] + CAILE C,PAGSIZ-2 + JRST IA2Q2A ;NOT ENUF ROOM THERE + MOVE C,T + ADDI C,2 + DPB C,[%NPTR,,AFSPP(S)] + TLZ T,777740 + POPJ P, + +IA2Q2A: TRNN T,NADIP ;CLEAR OUT UNUSED STORAGE TO TRAP + JRST IA2Q2B + CLEARM MEM(T) + AOJA T,IA2Q2A + +IA2Q2B: MOVEI T,0 + DPB T,[%NPTR,,AFSPP(S)] ;INDICATE NO PARTIALLY ALLOC PAGE +IA2Q2: MOVE T,AFSPL(S) ;FREE PAGE LIST + TDNN T,[37,,-1] + JRST IALLGC ;GC NEEDED + DPB T,[%NPTR,,AFSPP(S)] + SKIPGE C,MEM(T) + PUSHJ P,ITRAP + DPB C,[%NPTR,,AFSPL(S)] + JRST IA2Q1 + +IALLGC: BARF [AREA OVERFLOW, YOU LOSE! THE LUCKY WINNER IS:]S/ + +IALLB: HRRZS S + CAIL S,NAREAS + BARF AREA NUMBER TOO HIGH,S/ + LDB A,[000300,,AFSMOD(S)] ;ALLOCATE BLOCK # Q'S IN B, AREA IN S + CAIGE A,FSMAX + JRST @IABDT(A) +IABE: BARF ILLEGAL ALLOCATION MODE FOR IALLB,A/S/ + + +IABDT: IABE ;ERROR + IABL ;LINEARLY ADVANCING + IABQ ;Q ALLOCATED + IABE ;PAGE ALLOCATED + +IABL: MOVE T,AFSPTR(S) + MOVE E,T + ADD E,B + HRRZ C,AFSLN(S) + CAIGE C,(E) + JRST IALLGC + MOVEM E,AFSPTR(S) + ADD T,AFSORG(S) + TLZ T,777740 + TLO T,QZLIST_5 +IABLS: MOVSI C,NXTCDR+QZSYM_5 + MOVE E,T + SOJG B, [MOVEM C,MEM(E) + AOJA E,.] + MOVSI C,NXTNIL+QZSYM_5 + MOVEM C,MEM(E) + POPJ P, + +IABQ: HALT + +QIMSCR: BARF BAD MISC INSTRUCTION + + + +REPEAT 16.,[ +CONC XUB,\16.-.RPCNT,: + TLNN PC,QBBFL + JRST QMUB2 ;TRYING TO OVERPOP FRAME + PUSHJ P,QUNBND +] + POPJ P, + +QMUB2: BARF ATTEMPT TO OVER UNBIND + +XPOPIP: SUBI B,220 ;POP PDL 1-16. NOTE THIS CAN NOT BE CALLED BY + SUB IP,B ;COMPILED MICROCODE SINCE B WONT BE SET UP + POPJ P, + + +IRPS S1,,[QMA QMD QMAA QMAD QMDA QMDD QMAAA QMAAD QMADA QMADD QMDAA QMDAD QMDDA QMDDD +QMAAAA QMAAAD QMAADA QMAADD QMADAA QMADAD QMADDA QMADDD QMDAAA QMDAAD QMDADA QMDADD +QMDDAA QMDDAD QMDDDA QMDDDD]S2,,[QTA QTD QTAA QTAD QTDA QTDD QTAAA QTAAD QTADA QTADD +QTDAA QTDAD QTDDA QTDDD QTAAAA QTAAAD QTAADA QTAADD QTADAA QTADAD QTADDA QTADDD +QTDAAA QTDAAD QTDADA QTDADD QTDDAA QTDDAD QTDDDA QTDDDD] +S2: POP IP,T + JRST S1 +TERMIN + +QMAAAA: PUSHJ P,QCAR +QMAAA: PUSHJ P,QCAR +QMAA: PUSHJ P,QCAR + JRST QCAR + +QMDDDD: PUSHJ P,QCDR +QMDDD: PUSHJ P,QCDR +QMDD: PUSHJ P,QCDR + JRST QCDR + +QMAAAD: PUSHJ P,QCDR + JRST QMAAA + +QMDDDA: PUSHJ P,QCAR + JRST QMDDD + +QMAADD: PUSHJ P,QCDR +QMAAD: PUSHJ P,QCDR + JRST QMAA + +QMAADA: PUSHJ P,QCAR + JRST QMAAD + +QMDDAA: PUSHJ P,QCAR +QMDDA: PUSHJ P,QCAR + JRST QMDD + +QMDDAD: PUSHJ P,QCDR + JRST QMDDA + +QMADAA: PUSHJ P,QCAR +QMADA: PUSHJ P,QCAR + JRST QMAD + +QMADAD: PUSHJ P,QCDR + JRST QMADA + + +QMADDD: PUSHJ P,QCDR +QMADD: PUSHJ P,QCDR +QMAD: PUSHJ P,QCDR + JRST QCAR + +QMADDA: PUSHJ P,QCAR + JRST QMADD + +QMDADA: PUSHJ P,QCAR +QMDAD: PUSHJ P,QCDR + JRST QMDA + +QMDADD: PUSHJ P,QCDR + JRST QMDAD + +QMDAAA: PUSHJ P,QCAR +QMDAA: PUSHJ P,QCAR +QMDA: PUSHJ P,QCAR + JRST QCDR + +QMDAAD: PUSHJ P,QCDR + JRST QMDAA + +;SUPPORT SUBRS + + +XFALSE: MOVSI T,QZSYM_5 + POPJ P, + +XTRUE: LDB T,[%NDAT,,QQTPG+1] ;SECOND Q OF QUOTED CONSTANTS PAGE MUST BE T + POPJ P, + +XNOT: POP IP,S + LDB J,[%NDTB,,S] + CAIE J,QZSYM + JRST XFALSE + TDNN S,[37,,-1] + JRST XTRUE + JRST XFALSE + +XATOM: POP IP,T +XTATOM: LDB J,[%NDTB,,T] + CAIE J,QZSYM + CAIN J,QZFIX + JRST XTRUE + CAIE J,QZXNUM + JRST XFALSE + JRST XTRUE + +XZEROP: POP IP,T +XTZERO: LDB J,[%NDTB,,T] + CAIN J,QZFIX + JRST XZERFX + JRST XFALSE + +XBZERO: ;GET HERE DIRECTLY FOR UNBOXED-NUM +XZERFX: TDNN T,[37,,-1] + JRST XTRUE + JRST XFALSE + +XTYI: POP IP,S + .IOT TYIC,T + HRLI T,QZFIX_5 + POPJ P, + +XTYO: POP IP,T + ANDI T,377 + CAIGE T,200 ;TYPE OUT ANY SMALL CHARACTERS + JRST XTYO1 + CAIGE T,207 ;IGNORE 200-206 + POPJ P, + CAILE T,215 + POPJ P, ;IGNORE >215 + SUBI T,200 +XTYO1: .IOT TYOC,T + HRLI T,QZFIX_5 + POPJ P, + +XHALT: BARF [SOMEBODY DID A %HALT.] + POPJ P, + +XGPN: POP IP,S ;RETURN POINTER TO P-NAME ARRAY + LDB B,[%NDTB,,S] + CAIE B,QZSYM + JRST XFALSE + SKIPGE T,MEM(S) + PUSHJ P,ITRAP + POPJ P, + + +XLSH: PUSHJ P,2FIXA + LSH T,(S) + TLZ T,777740 +XROT1: TLO T,QZFIX_5 + POPJ P, + +XROT: PUSHJ P,2FIXA +XROT3: JUMPE S,XROT1 + JUMPG S,XROT2 + ROT T,-1 + TLZE T,400000 + TLO T,20 + AOJA S,XROT3 + +XROT2: ROT T,1 + TLZE T,40 + TRO T,1 + SOJA S,XROT3 + + +XBOOLE: PUSHJ P,3FIXA + MOVE ZR,[SETZB S,R] + DPB T,[350400,,ZR] + XCT ZR + MOVE T,R + TLO T,QZFIX_5 + POPJ P, + +XNUMBP: POP IP,T +XTNUMB: LDB A,[%NDTB,,T] + CAIE A,QZFIX + CAIN A,QZXNUM + JRST XTRUE + JRST XFALSE + + +XPLUSP: POP IP,T +XTPLUP: LDB A,[%NDTB,,T] + CAIN A,QZFIX + JRST XPLUFX + BARF PLUSP NOT ON A NUMBER,T/& + +XBPLUP: ;GET HERE DIRECTLY FOR UNBOXED NUM +XPLUFX: TDNE T,[37,,-1] ;T IF ARG STRICTLY > 0. + TLNE T,20 + JRST XFALSE + JRST XTRUE + +XMNUSP: POP IP,T +XTMNSP: LDB A,[%NDTB,,T] + CAIN A,QZFIX + JRST XMNUFX + BARF MINUSP NOT ON A NUMBER,T/& + +XBMNSP: ;GET HERE DIRECTLY FOR UNBOXED NUM +XMNUFX: TLNN T,20 + JRST XFALSE + JRST XTRUE + +3FIXA: POP IP,R + LDB A,[%NDTB,,R] + CAIE A,QZFIX + HALT + TLZ R,777740 +2FIXA: POP IP,S ;SECOND ARG + POP IP,T ;FIRST ARG + LDB A,[%NDTB,,S] + LDB B,[%NDTB,,T] + CAIN A,QZFIX + CAIE B,QZFIX + HALT + TLZ T,777740 + TLZ S,777740 + POPJ P, + +XREM: PUSHJ P,2FIXA + MOVE I,T + TLNE I,20 + TLO I,777740 + IDIV I,S + MOVE T,J ;I+1 + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + + +XMINUS: POP IP,T +XTMNS: LDB J,[%NDTB,,T] + CAIN J,QZFIX + JRST XMNFX + BARF MINUS NOT ON A NUMBER,T/& + +XPNPCL: +XCL1: POP IP,T ;GIVEN PNTR TO SYM, RETURN LIST PNTR TO ITS P-N CELL + LDB J,[%NDTB,,T] + CAIE J,QZSYM + BARF MUMBLE CELL LOCATION FO A NON-SYMBOL,T/&P/ + TLZ T,777740 + TLO T,QZXSYM_5 + POPJ P, + +XVCL: PUSHJ P,XCL1 ;" " TO ITS VALUE CELL + AOJA T,CPOPJ + +XFCL: PUSHJ P,XCL1 ;" " TO ITS FUNCTION CELL + ADDI T,2 + POPJ P, + +XPRPCL: PUSHJ P,XCL1 ;" " TO ITS PROPERTY CELL + ADDI T,3 + POPJ P, + +XBMNS: ;GET HERE DIRECTLY FOR UNBOXED NUM +XMNFX: MOVNS T +X1PLF1: TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +X1PLS: POP IP,T +XT1PLS: LDB J,[%NDTB,,T] + CAIN J,QZFIX + JRST X1PLFX + BARF 1+ ON A NON-FIXNUM,T/& + +XB1PLS: ;GET HERE DIRECTLY FOR UNBOXED NUM +X1PLFX: AOJA T,X1PLF1 + + +X1MNS: POP IP,T +XT1MNS: LDB J,[%NDTB,,T] + CAIN J,QZFIX + JRST X1MNFX + BARF 1- ON A NON-FIXNUM,T/& + +XB1MNS: ;GET HERE DIRECLTY FOR UNBOXED NUM +X1MNFX: SOJA T,X1PLF1 + + +XGATP: POP IP,S ;GET ARRAY TYPE + LDB ZR,[%NDTB,,S] + CAIE ZR,QZARYP + HALT + MOVE T,MEM(S) + AND T,[.BM %ARYTP] + TLO T,QZFIX_5 + POPJ P, + +;XADN: POP IP,T ;ARRAY DIMENSION N +; POP IP,S ;(DESIRED DIMENSION #) +; LDB ZR,[%NDTB,,S] ;DIMENSION 0 IS NET LENGTH +; LDB Q,[%NDTB,,T] +; CAIN Q,QZARYP +; CAIE ZR,QZFIX +; JRST XFALSE +; LDB Q,[%ARYND,,MEM(T)] +; CAIGE Q,(S) +; JRST XFALSE +; CAIN Q,(S) +; JRST XADN1 ;WANT LAST DIM -- FIGURE IT OUT +; ADD S,T +; LDB T,[%ARYL,,MEM(S)] +;XADN4: TLO T,QZFIX_5 +; POPJ P, +; +;XADN1: LDB B,[%ARYL,,MEM(T)] ;TOTAL Q LENGTH +; SUBI B,-1(Q) ;Q OF DIMENSIONING INFO +; LDB C,[%ARYTP,,MEM(T)] +; IMUL B,ENTPQ(C) ;GET INDEX LENGTH +; MOVEI A,1 +;XADN2: CAIGE Q,2 +; JRST XADN3 ;COMPUTE PRODUCT OF DIMS EXCEPT LAST +; HRRZ ZR,MEM+1(T) ;DIM-N +; IMUL A,ZR +; AOS T +; SOJA Q,XADN2 +; +;XADN3: IDIV B,A +; HRRZ T,B +; JRST XADN4 + + +XFCTEV: POP IP,T + MOVEI A,2 + JRST XFCTE1 + +XSYMEV: POP IP,T +XTSYME: MOVEI A,1 +XFCTE1: LDB ZR,[%NDTB,,T] + CAIE ZR,QZSYM + BARF SYMEVAL OF A NON-SYMBOL,T/& + ADD T,A +XSYME1: LDB ZR,[%NDTB,,MEM(T)] + LDB T,[%NDAT,,MEM(T)] + CAIN ZR,QZSCF ;SKIP ON POINTER TO EXTERNAL VALUE CELL + JRST XSYME1 + POPJ P, + +XARC: POP IP,R ;FETCH AREA-RELATIVE ARG2 REL ADR + POP IP,S ;ARG1 + LDB ZR,[%NDTB,,R] + CAIN ZR,QZUENT + JRST XARC1 + CAIE ZR,QZFIX + HALT +XARC1: LDB ZR,[%NDTB,,S] + CAIE ZR,QZFIX + HALT + MOVE B,AFSORG(S) + ADDI B,(R) + MOVE T,MEM(B) + POPJ P, + +XALLB: POP IP,B ;ALLOCATE BLOCK OF STORAGE + POP IP,S + LDB ZR,[%NDTB,,S] + CAIN ZR,QZSYM + JRST [ MOVE S,MEM+1(S) ;ACCESS VALUE CELL + LDB ZR,[%NDTB,,S] + JRST .+1] + CAIE ZR,QZFIX + HALT + LDB ZR,[%NDTB,,B] + CAIE ZR,QZFIX + HALT + HRRZS B + PUSHJ P,IALLB + POPJ P, + +XSET: POP IP,T + POP IP,S + LDB ZR,[%NDTB,,S] + CAIE ZR,QZSYM + HALT + LDB ZR,[%NDTB,,MEM+1(S)] + CAIN ZR,QZSCF + JRST XSET1 + DPB T,[%NDAT,,MEM+1(S)] + POPJ P, + +XSET1: LDB S,[%NPTR,,MEM+1(S)] ;EXTERNAL VALUE CELL +XSET2: LDB ZR,[%NDTB,,S] + CAIN ZR,QZSCF + JRST [ LDB S,[%NPTR,,MEM(S)] + JRST XSET2] + DPB T,[%NDAT,,MEM(S)] + POPJ P, + +XASSQ: MOVE T,(IP) +XASSQ1: TDNN T,[37,,-1] + JRST XASSQX + PUSHJ P,QCAR + PUSH IP,T + PUSHJ P,QCAR + XOR T,-2(IP) + TDNN T,[1777,,-1] ;DT + DATA + JRST XASSQF ;FOUND IT + SUB IP,[1,,1] + MOVE T,(IP) + PUSHJ P,QCDR + MOVEM T,(IP) + JRST XASSQ1 + +XASSQX: SUB IP,[2,,2] + JRST XFALSE + +XASSQF: POP IP,T + SUB IP,[2,,2] + POPJ P, + +XMEMQ: MOVE T,(IP) +XMEMQ1: TDNN T,[37,,-1] + JRST XMEMQX + PUSHJ P,QCAR + XOR T,-1(IP) + TDNN T,[1777,,-1] + JRST XMEMQF + MOVE T,(IP) + PUSHJ P,QCDR + MOVEM T,(IP) + JRST XMEMQ1 + +XMEMQX: SUB IP,[2,,2] + JRST XFALSE + +XMEMQF: POP IP,T ;RETURN LIST, CAR OF WHICH IS FOUND ITEM + SUB IP,[1,,1] + POPJ P, + +XFPIL: PUSH IP,[QZFIX_5,,] ;FIND-POSITION-IN-LIST + MOVE T,-1(IP) +XFPIL1: TDNN T,[37,,-1] + JRST XFPLX + PUSHJ P,QCAR + XOR T,-2(IP) + TDNN T,[37,,-1] + JRST XFPLF + MOVE T,-1(IP) + PUSHJ P,QCDR + MOVEM T,-1(IP) + AOS (IP) + JRST XFPIL1 + +XFPLX: SUB IP,[3,,3] + JRST XFALSE + +XFPLF: POP IP,T + SUB IP,[2,,2] + POPJ P, + +XFPILE: PUSH IP,[QZFIX_5,,] ;FIND-POSITION-IN-LIST-EQUAL + MOVE T,-1(IP) +XFPEL1: TDNN T,[37,,-1] + JRST XFPLX + PUSHJ P,QCAR + LDB ZR,[%NDTB,,T] + LDB Q,[%NDTB,,-2(IP)] + CAME ZR,Q + JRST XFPEL2 ;DATA TYPES NOT EQUAL SO THEY RE NOT. + CAIE Q,QZSYM + CAIN Q,QZFIX + JRST [ XOR T,-2(IP) ;THESE DATA-TYPES MUST BE EQ TO BE EQUAL + TDNN T,[37,,-1] + JRST XFPLF + JRST XFPEL2] + PUSHJ P,P3ZERO + PUSH IP,SUPV+SVCEQU ;EQUAL + PUSH IP,-2-4(IP) + JSR 2,MMCALT + TDNE T,[37,,-1] + JRST XFPLF +XFPEL2: MOVE T,-1(IP) + PUSHJ P,QCDR + MOVEM T,-1(IP) + AOS (IP) + JRST XFPEL1 + +XFPIVS: POP IP,A ;FIND POSITION IN VECTOR SETUP + PUSHJ P,GADPTR ;ERROR ANYWAY IF NOT FULL-Q ARRAY, SO NO NEED + TDNE B,[ARXIB] ; TO WORRY ABOUT INDEX OFFSET + HRRZ S,MEM-2(A) ;GET ACTIVE LENGTH FROM LEADER + LDB R,[%ARYTP,,B] + CAIE R,ARTLAR ;MUST BE Q ARRAY OR LIST ARRAY + CAIN R,ARTQ + JRST XFPIV1 + HALT +XFPIV1: POP IP,Q ;DATA TO LOOK FOR + MOVE I,E ;SAVE INITIAL MEM ADR + POPJ P, + +XFPIV: PUSHJ P,XFPIVS ;FIND POSITION IN VECTOR + JUMPE S,XFALSE +XFPIV2: MOVE T,Q + XOR T,MEM(E) + TDNN T,[37,,-1] + JRST XFPIVF + AOS E + SOJG S,XFPIV2 + JRST XFALSE + +XFPIVF: HRRZ T,E + SUBI T,(I) + TLO T,QZFIX_5 + POPJ P, + +XFPIVE: PUSHJ P,XFPIVS ;FIND POSITION IN VECTOR EQUAL + JUMPE S,XFALSE +XFPVE2: LDB ZR,[%NDTB,,Q] + LDB J,[%NDTB,,MEM(E)] + CAME ZR,J + JRST XFPVE3 ;DATA TYPES NOT = + MOVE T,MEM(E) + CAIE J,QZSYM + CAIN J,QZFIX + JRST [ XOR T,Q + TDNN T,[37,,-1] + JRST XFPIVF + JRST XFPVE3] + HRLI S,QZFIX_5 + PUSH IP,S + HRLI I,QZFIX_5 + PUSH IP,I + HRLI E,QZFIX_5 + PUSH IP,E + PUSH IP,Q + PUSHJ P,P3ZERO + PUSH IP,SUPV+SVCEQU + PUSH IP,0-4(IP) + JSR 2,MMCALT ;THIS ONLY WINS IF FCTN CALLING XFPIVE IS + POP IP,Q ; MICRO-COMPILED! -LOSEY LOSEY + POP IP,E + POP IP,I + POP IP,S + HRRZS S + TDNE T,[37,,-1] + JRST XFPIVF +XFPVE3: AOS E + SOJG S,XFPVE2 + JRST XFALSE + + +XGETL: MOVE T,-1(IP) ;SYM TO GET FROM + LDB ZR,[%NDTB,,T] + CAIE ZR,QZSYM + HALT + PUSH IP,MEM+3(T) ;ITS PROP CELL + MOVE T,(IP) +XGETL1: TDNN T,[37,,-1] + JRST XGETLX + PUSHJ P,QCAR + PUSH IP,T ;NEXT INDICATOR + PUSH IP,-2(IP) ;LIST OF THINGS TO GET + MOVE T,(IP) +XGETL2: TDNN T,[37,,-1] + JRST XGETL3 ;THIS ONE ISNT ANY OF THOSE + PUSHJ P,QCAR + XOR T,-1(IP) + TDNN T,[1777,,-1] + JRST XGETL4 ;YEP, THATS IT + MOVE T,(IP) + PUSHJ P,QCDR + MOVEM T,(IP) + JRST XGETL2 + +XGETL3: SUB IP,[2,,2] + MOVE T,(IP) + PUSHJ P,QCDR + PUSHJ P,QCDR + MOVEM T,(IP) + JRST XGETL1 + +XGETLX: SUB IP,[3,,3] + JRST XFALSE + +XGETL4: MOVE T,-2(IP) + SUB IP,[5,,5] + POPJ P, + + +XGET: POP IP,S ;PROP TO GET + POP IP,T ;SYM TO GET IT FROM + LDB ZR,[%NDTB,,T] + CAIE ZR,QZSYM + HALT + PUSH IP,MEM+3(T) ;GET PROP CELL + MOVE T,(IP) +XGET1: TDNN T,[37,,-1] + JRST XGETX + PUSHJ P,QCAR + XOR T,S + TDNN T,[1777,,-1] + JRST XGETF + MOVE T,(IP) + PUSHJ P,QCDR + PUSHJ P,QCDR + MOVEM T,(IP) + JRST XGET1 + +XGETX: SUB IP,[1,,1] + JRST XFALSE + +XGETF: POP IP,T + PUSHJ P,QCDR + PUSHJ P,QCAR + POPJ P, + +XLAST: MOVE T,(IP) + LDB R,[%NDTB,,T] + SKIPN SKPLST(R) + JRST XLEN2 +XLAST1: PUSHJ P,QCDR + LDB R,[%NDTB,,T] + SKIPN SKPLST(R) + JRST XLEN2 + MOVEM T,(IP) + JRST XLAST1 + +XLENGT: POP IP,T +XTLENG: PUSH IP,[QZFIX_5,,] +XLEN1: LDB R,[%NDTB,,T] + SKIPN SKPLST(R) + JRST XLEN2 + PUSHJ P,QCDR + AOS (IP) + JRST XLEN1 + +XLEN2: POP IP,T + POPJ P, + + + +XGMADP: POP IP,T + LDB ZR,[%NDTB,,T] + CAIE ZR,QZFEFP + HALT + MOVE S,MEM+QFEIPC(T) + TLNE S,(QNADL) + JRST [MOVE T,QFRFSO+MEM(T) ;NO ADL, RETURN FAST OPT. + POPJ P,] + LDB A,[%QFAGS,,MEM+QFEMSC(T)] + JUMPE A,XFALSE + ADD T,A + TLZ T,777740 + TLO T,QZLIST_5 + POPJ P, + +XCLOS: LDB T,[%NDAT,,-1(IP)] ;CLOSURE + MOVEI B,1 +XCLOS1: CAMN T,[QZSYM_5,,] ;FIGURE OUT HOW MUCH SPACE REQD. + JRST XCLOS2 + MOVE C,T + PUSHJ P,QCAR +;CHECK FOR & MUMBLES .. + MOVE T,C + PUSHJ P,QCDR + ADDI B,2 ;2 Q S FOR EACH BINDING + JRST XCLOS1 + +XCLOS2: HRRZ S,CNSADF ;DEFAULT AREA FOR NOW + PUSHJ P,IALLB ;ALLOCATE BLOCK OF STG + POP IP,S ;FCTN + PUSH IP,T ;SAVE POINTER TO BLOCK + DPB S,[%NDAT,,MEM(T)] ;STORE FCTN IN CLOSURE + PUSHJ P,QCDR + PUSH IP,T ;SAVE POINTER TO PLACE WHERE FILLING BLOCK +;0(IP) -> FILL POINTER, -1(IP) -> CLOSURE-BLOCK, -2(IP) CLOSURE-LIST + LDB T,[%NDAT,,-2(IP)] ;CLOSURE-LIST +XCLOS4: CAMN T,[QZSYM_5,,] + JRST [ SUB IP,[1,,1] ;END OF CLOSURE-LIST, DONE + POP IP,T + SUB IP,[1,,1] + TLZ T,NNPTR + TLO T,QZCLOS_5 ;RETURN POINTER WITH DATA-TYPE CLOSURE + POPJ P, ] + PUSHJ P,QCAR ;GET ELEMENT OF CLOSURE-LIST + LDB ZR,[%NDTB,,T] + CAIE ZR,QZSYM + HALT + PUSH IP,T ;STORE PNTR TO LOCATION BOUND IN CLOSURE BLOCK + PUSH IP,0-1(IP) ;FILL POINTER (ARG TO RPLACA) + MOVEI T,1(T) ;MAKE LOCATIVE POINTER TO VALUE CELL + TLO T,QZXSYM_5 + PUSH IP,T + PUSHJ P,XRPLCA + PUSHJ P,QCDR + MOVEM T,0-1(IP) ;UPDATE FILL POINTER + POP IP,T ;GET BACK SYMBOL POINTER + LDB ZR,[%NDTB,,MEM+1(T)] + CAIN ZR,QZSCF + JRST [ LDB T,[%NDAT,,MEM+1(T)] + JRST XCLOS3] ;EXTERNAL VALUE CELL ALREADY EXISTS + PUSH IP,T + HRRZ S,CNSADF + MOVEI B,1 + PUSHJ P,IALLB + POP IP,S + LDB ZR,[%NDAT,,MEM+1(S)] + DPB ZR,[%NDAT,,MEM(T)] ;MOVE VALUE TO EXTERNAL VALUE CELL + TLZ T,NNPTR + TLO T,QZSCF_5 + DPB T,[%NDAT,,MEM+1(S)] ;STORE POINTER TO EXTERNAL VALUE CELL IN INTERNAL ONE +XCLOS3: PUSH IP,0(IP) ;FILL POINTER + PUSH IP,T ;POINTER TO EXTERNAL VALUE CELL + PUSHJ P,XRPLCA + PUSHJ P,QCDR + MOVEM T,0(IP) ;UPDATE FILL POINTER + MOVE T,-2(IP) ;(SETQ CLOSURE-LIST (CDR CLOSURE-LIST)) + PUSHJ P,QCDR + MOVEM T,-2(IP) + JRST XCLOS4 + +XDCLOS: HALT ;DOWNWARD-CLOSURE + +XLISTP: POP IP,S ;LISTP + LDB R,[%NDTB,,S] + SKIPN SKPLST(R) + JRST XFALSE + JRST XTRUE + +XNLSTP: POP IP,S ;NLISTP + LDB R,[%NDTB,,S] + SKIPE SKPLST(R) + JRST XFALSE + JRST XTRUE + +XSYMP: POP IP,S ;SYMBOLP + LDB R,[%NDTB,,S] + CAIE R,QZSYM + JRST XFALSE + JRST XTRUE + +XNSYMP: POP IP,S ;NSYMBOLP + LDB R,[%NDTB,,S] + CAIN R,QZSYM + JRST XFALSE + JRST XTRUE + +XARRYP: POP IP,S ;ARRAYP + LDB R,[%NDTB,,S] + CAIE R,QZARYP + JRST XFALSE + JRST XTRUE + +XSTRNP: POP IP,S ;STRINGP + LDB R,[%NDTB,,S] + CAIE R,QZARYP + JRST XFALSE + LDB R,[%ARYTP,,MEM(S)] + CAIE R,ARTSTR + JRST XFALSE + JRST XTRUE + +XFCTNP: SKIPA A,[2] ;FUNCTIONP +XBOUNP: MOVEI A,1 + POP IP,S ;BOUNDP + LDB R,[%NDTB,,S] + CAIE R,QZSYM + JRST XFALSE + ADD S,A +XBOUN1: LDB R,[%NDTB,,MEM(S)] + CAIN R,QZNULL + JRST XFALSE + CAIE R,QZSCF + JRST XTRUE + LDB S,[%NDAT,,MEM(S)] + JRST XBOUN1 + + +XUSRCB: POP IP,T + TLNN T,NUSRCB + JRST XFALSE + JRST XTRUE + +XCDRC: POP IP,T + LDB T,[%NUCB,,T] +XCDRC1: TLO T,QZFIX_5 + POPJ P, + +XDATTP: POP IP,T + LDB T,[%NDTB,,T] + JRST XCDRC1 + +XDAT: POP IP,T + TLZ T,777740 + JRST XCDRC1 + +XSUSCB: MOVE Q,[%NUCB,,J] +XSCOM: POP IP,T + POP IP,J + DPB T,Q + MOVE T,J + POPJ P, + +XSCDRC: SKIPA Q,[%NCDRB,,J] +XSDATP: MOVE Q,[%NDTB,,J] + JRST XSCOM + +XSPTR: MOVE Q,[%NPTR,,J] + JRST XSCOM + +XSTND: POP IP,T + POP IP,J ;STORE ARG2 IN ADR OF ARG1, DONT AFFECT CDR CODE + SKIPGE MEM(J) + PUSHJ P,ITRAP + DPB T,[%NDAT,,MEM(J)] + POPJ P, + + +XSTALL: POP IP,T + POP IP,J + SKIPGE MEM(J) + PUSHJ P,ITRAP + DPB T,[4000,,MEM(J)] + POPJ P, + +XCOMB: POP IP,T + POP IP,J ;RETURN 32 BIT COMBINATION OF LOW 16 BITS + DPB J,[202000,,T] ;OR ARG1 AND ARG2 + POPJ P, + +XPUSRC: MOVE A,[%NUCB,,J] +XPFT1: POP IP,B + PUSHJ P,GLOCA + MOVE J,MEM(B) + LDB T,A + TLO T,QZFIX_5 + POPJ P, + +XPCDRC: SKIPA A,[%NCDRB,,J] +XPDATP: MOVE A,[%NDTB,,J] + JRST XPFT1 + +XPDAT: MOVE A,[%NPTR,,J] + JRST XPFT1 + +XSPUSR: MOVE A,[%NUCB,,MEM(B)] +XSPTR1: POP IP,T + POP IP,B + PUSHJ P,GLOCA + DPB T,A + POPJ P, + +XSPCDR: SKIPA A,[%NCDRB,,MEM(B)] +XSPDTP: MOVE A,[%NDTB,,MEM(B)] + JRST XSPTR1 + +XSPDAT: MOVE A,[%NPTR,,MEM(B)] + JRST XSPTR1 + + +XCMBS: PUSHJ P,2FIXA ;GET LAST ARG INTO S, 2ND INTO T + POP IP,B ;ADDRESS TO STORE IN + DPB T,[%NNPTR,,S] ;STORE DATA TYPE,ETC + MOVEM S,MEM(B) ;CLOBBER + MOVE T,B + POPJ P, + +XSPQ: PUSHJ P,2FIXA ;GET LAST ARG INTO S, 2ND INTO T + POP IP,B + DPB T,[202000,,S] + MOVEM S,MEM(B) + MOVE T,B + POPJ P, + +XOMR: POP IP,B ;%OFFSET-MEM-REF + POP IP,S + LDB ZR,[%NDTB,,B] + CAIN ZR,QZMEMP + SUBI B,MEM + ADDI B,(S) + LDB T,[%NDAT,,MEM(B)] + POPJ P, + +XOMS: MOVE J,[%NDAT,,MEM(B)] ;%OFFSET-MEM-STORE +XOMS1: POP IP,B + POP IP,S + LDB ZR,[%NDTB,,B] + CAIN ZR,QZMEMP + SUBI B,MEM + ADDI B,(S) + POP IP,T + DPB T,J + POPJ P, + +XOMRH: POP IP,B ;%OFFSET-MEM-REF-HIGH-HALF + POP IP,S + LDB ZR,[%NDTB,,B] + CAIN ZR,QZMEMP + SUBI B,MEM + ADDI B,(S) + LDB T,[202000,,MEM(B)] + TLO T,QZFIX_5 + POPJ P, + +XOMSH: SKIPA J,[202000,,MEM(B)];%OFFSET-MEM-STORE-HIGH-HALF +XOMSL: MOVE J,[002000,,MEM(B)];%OFFSET-MEM-STORE-LOW-HALF + JRST XOMS1 + +XOMRL: POP IP,B ;%OFFSET-MEM-REF-LOW-HALF + POP IP,S + LDB ZR,[%NDTB,,B] + CAIN ZR,QZMEMP + SUBI B,MEM + ADDI B,(S) + LDB T,[002000,,MEM(B)] + TLO T,QZFIX_5 + POPJ P, + +;MICRO-COMPILER RUN-TIME ROUTINES + +PTRM=[37,,-1] ;CONSTANT USED FOR ZEROP CHECKING BY U CODE + +P3ZERO: PUSH IP,[QZFIX_5,,] +MMASU1: PUSH IP,[QZFIX_5,,] + PUSH IP,[QZFIX_5,,] + MOVEI ZR,1(IP) + SUB ZR,IPMARK ;DELTA TO PREV IPMARK + DPB ZR,[%LPCPN,,LPCLS+1(IP)] ;DELTA TO PREV IP MARK + ;(+1 BECAUSE LPFEF HASNT BEEN PUSHED YET) + MOVEI ZR,1(IP) + SUBI ZR,(AP) + CAILE ZR,377 + HALT ;FRAME TOO BIG + DPB ZR,[%LPCAD,,LPCLS+1(IP)] ;DELTA TO PREV ACTIVE FRAME + MOVEI ZR,1(IP) + MOVEM ZR,IPMARK ;SET IP MARK TO POINT TO THIS FEF-BASE + POPJ P, + +MMASU: 0 ;CALL JSR N,MMASU TO SET UP MICRO-TO-MACRO BLOCK WITH + MOVE C,MMASU ;INFO REQUESTING N VALUES + PUSH P,C + LDB D,[270400,,-1(C)] + PUSHJ P,ULMVRB ;LEAVE ROOM FOR VARIABLES +UCTOM1: PUSH IP,I ;SAVE POINTER TO BLOCK + IOR D,[_18.+ADIRT_24+ADISB_21] + PUSH IP,D ;REST OF INFO +UAPLY4: PUSH IP,[QZFIX_5+(LPADL),,] + JRST MMASU1 + + +UERO: SKIPA T,[QZUENT_5,,UERRS] ;OPEN %ERRSET BLOCK (RESTART PC IN S) +UCTO: MOVE T,[QZUENT_5,,UCATCH] ;OPEN %CATCH BLOCK " + MOVEI R,-PDL+1-1(P) + TLO S,QZFIX_5 + PUSHJ P,USADRPC +UCTO1: PUSHJ P,UAPLY4 + PUSH IP,T + POPJ P, + +UCTOM: 0 ;OPEN %CATCH BLOCK, MV (# IN AC OF JSR) + MOVE C,UCTOM ;RESTART PC IN S + MOVE T,[QZUENT_5,,UCATCH] + JRST UCTCH1 + +UEROM: 0 ;OPEN %ERRSET BLOCK, MV (# IN AC OF JSR) + MOVE C,UEROM ;RESTART PC IN S + MOVE T,[QZUENT_5,,UERRS] +UCTCH1: PUSH P,C + LDB D,[270400,,-1(C)] + PUSHJ P,ULMVRB + MOVEI R,-PDL+1-1(P) + TLO S,QZFIX_5 + PUSHJ P,USADRPC + TLO I,NUSRCB + PUSHJ P,UCTOM1 + PUSH IP,T + POPJ P, + +XLDB: POP IP,Q + POP IP,S + LDB ZR,[%NDTB,,S] + CAIE ZR,QZFIX + HALT + MOVEI B,Q + JRST XLDB1 + +XOPLDB: POP IP,A ;%P-LDB-OFFSET + HRRZS A + ADDM A,(IP) +XPLDB: PUSHJ P,GPTCS2 ;GET FIELD TO GOBBLE IN S, POINTER TO DATA IN B + HRRZI B,MEM(B) +XLDB1: DPB S,[301400,,B] + LDB T,B + TLNN T,NNPTR + TLO T,QZFIX_5 ;PUT IN FIX D.T. IF LOADED BYTE DOES NOT INCLUDE + POPJ P, ; D.T. FIELD. THIS HAPPENS "NATURALLY" ON REAL MACHINE. + +XDPB: POP IP,T ;DATA TO DPB INTO + POP IP,S ;FIELD SPEC + POP IP,B ;DATA TO DPB + MOVEI Q,T + DPB S,[301400,,Q] + DPB B,Q + POPJ P, + +XOPDPB: POP IP,A ;%P-DPB-OFFSET + HRRZS A + ADDM A,(IP) +XPDPB: PUSHJ P,GPTCS2 + HRRZI B,MEM(B) + DPB S,[301400,,B] + POP IP,T + DPB T,B + POPJ P, + +XMF: PUSHJ P,GDCS2 + MOVE D,B + MOVEI B,D +XMF1: PUSHJ P,MFCKR + DPB S,[301400,,B] + LDB T,B + LSH T,(E) ;SHIFT IT BACK + TLO T,QZFIX_5 + POPJ P, + +XOPMF: POP IP,A ;%P-MASK-FIELD-OFFSET + HRRZS A + ADDM A,(IP) +XPMF: PUSHJ P,GPTCS2 ;LOAD FIELD (FROM POINTER) + HRRZI B,MEM(B) + JRST XMF1 + +XDF: PUSHJ P,GDCS2 ;DEPOSIT FIELD + PUSHJ P,MFCKR + POP IP,T + EXCH T,B + LSH S,24. + HRRI S,B + LDB ZR,S + HRRI S,T + DPB ZR,S + POPJ P, + + +XOPDF: POP IP,A ;%P-DEPOSIT-FIELD-OFFSET + HRRZS A + ADDM A,(IP) +XPDF: PUSHJ P,GPTCS2 ;DEPOSIT FIELD (INTO POINTER) + HRRZI B,MEM(B) + PUSHJ P,MFCKR + POP IP,T + LSH S,24. + HRRI S,T + LDB ZR,S + HRR S,B + DPB ZR,S + POPJ P, + +MFCKR: LDB E,[60600,,S] ;CHECK FIELD FOR LEGALITY FOR MASK FIELD OPERATION + LDB ZR,[600,,S] ;LEAVE SHIFT COUNT IN E + ADD ZR,E + CAILE ZR,23. + HALT + POPJ P, + +GDCS2: POP IP,B ;GOBBLE ARGS INTO S,B AND MAKE SURE FIRST IS A FIX + POP IP,S + LDB ZR,[%NDTB,,S] + CAIE ZR,QZFIX + HALT + POPJ P, + +GPTCS2: POP IP,B + POP IP,S +GPTCS: LDB ZR,[%NDTB,,S] ;ALSO VERIFY S IS A FIX + CAIE ZR,QZFIX + HALT +GPNTR: LDB ZR,[%NDTB,,B] + CAIN ZR,QZMEMP + SUBI B,MEM + POPJ P, + + +MMISU: 0 ;CALL JSR N,MMISU TO SET UP MICRO-TO-MICRO INFO BLOCK + MOVE C,MMISU ;REQUESTING N VALUES + PUSH P,C + LDB D,[270400,,-1(C)] + SKIPN E,D + HALT + MOVEI ZR,-MEM+1(IP) + PUSH IP,[QZSYM_5,,] + SOJG E,.-1 + TLO ZR,QZXSYM_5 ;ON REAL MACHINE WOULD BE QZXSTR + PUSH IP,ZR + IOR D,[_18.+ADIRT_24+ADISB_21] + PUSH IP,D + POPJ P, + +MVCALL: AOS C,(P) + PUSH P,[PPBMIA,,QRAD1] ;PUSHJ P,MVCALL TO ACTIVATE MICRO-TO-MICRO CALL + JRST @-1(C) ;FOLLOWED BY WD POINTING TO ENTRY TO BE CALLED + +XMAPLY: ;ALSO COME HERE FOR APPLY FROM INTERPRETER AND + ;MACRO-CODE (VIA MACRO-MICRO CALL) + ;NOTE THAT WE DO --NOT-- GET HERE VIA A MISC INSTRUCTION. THUS, A FULL + ;FRAME HAS BEEN CREATED FOR THE APPLY. THUS (AP) CONTAINS THE CONTENTS + ;OF THE FUNCTION CELL OF THE SYMBOL APPLY, (QZUENT XMAPLY) ETC. + ;BECAUSE OF THIS, WE ARE GUARANTEED THAT THE ACTIVE FRAME IS A MICRO-COMPILED + ;FUNCTION AND THAT MMCAL4 WILL WIN WHEN IT STORES INTO THE %LPNWP FIELD + ;OF LPENS(AP), ETC. +UAPLY: POP IP,R ;APPLY, EXPECT SINGLE VALUE + POP IP,T + CLEARM NWADI ;NO ADI FOR BLOCK GOING TO CREATE (YET..) + PUSHJ P,SPRDP ;DOES FCTN IN T PREFER TO HAVE ARGS SPREAD? + JRST UAPFX ;NO, LEAVE THEM LISTIFIED + POP P,C ;RETURN ADDRESS + PUSHJ P,P3LNK ;PUSH CALL BLOCK, POSSIBLY WITH ADI MV LINK + PUSH IP,T +UAPLY1: MOVEI S,0 +UAPLY5: LDB T,[%NDTB,,R] + SKIPN SKPLST(T) + JRST MMCAL4 + MOVE T,R + PUSHJ P,QCAR + PUSH IP,T + MOVE T,R + PUSHJ P,QCDR + MOVE R,T + AOJA S,UAPLY5 + +UAPFX: POP P,C ;LEAVE ARGS LISTIFIED, MAKE FEXPR CALL BLOCK + MOVE S,[_18.+ADIFEX_24] + PUSHJ P,SADFEX + AOS NWADI + AOS NWADI + PUSHJ P,P3LNK + PUSH IP,T + PUSH IP,R ;CALL IT AS FCTN OF ONE ARG + MOVEI S,1 + JRST MMCAL4 + +P3LNK: TLNN C,PPBINF ;NWADI HAS WDS OF ADI ALREADY PUSHED + JRST P3LNK1 ;NO NEED FOR EXTRA ADI + HRRZ S,IP ;GET POINTER TO HIS INFO + SUB S,NWADI ;SPACE BACK OVER ADI ALREADY PUSHED + TLNE C,PPBMAA + SUBI S,LLPFRM + MOVE J,S +UAPY3A: MOVE Q,(J) + LDB ZR,[%NDTB,,Q] + CAIE ZR,QZFIX + HALT + LDB ZR,[%ADITP,,Q] + CAIN ZR,ADIRT + JRST UAPY3B ;YEP FOUND RETURN VALUE ADI + TLNN Q,NUSRCB + HALT + SOS J + MOVE Q,(J) + TLNE Q,NUSRCB ;SKIP ON END OF ADI, IE, HE DOESNT REALLY WANT MV S + SOJA J,UAPY3A +P3LNK1: SKIPN NWADI + JRST P3ZERO + JRST P3LNK2 + +UAPY3B: SKIPE NWADI + TLO S,NUSRCB ;THIS ISNT FIRST OF ADI + TLO S,QZMEMP_5 + PUSH IP,S + AOS NWADI + PUSH IP,[_18.+ADIRT_24+ADIP_21] ;STORE INDIRECT POINTER + AOS NWADI +P3LNK2: JRST UAPLY4 + +XARGI: POP IP,S ;%ARGS-INFO +XARGI0: LDB ZR,[%NDTB,,S] ;RETURN FIXNUM DECODING ARGS INFO. + CAIE ZR,QZUENT ; 10,, -> REST ARG QUOTED + JRST XARGI1 ; 04,, -> REST ARG EVAL'ED + MOVE T,MEVECA(S) ; 02,, -> FEF W/O FAST OPTION, CHECK A-D-L FOR QUOTAGE + POPJ P, ; 01,, -> TRAP TO INTERPRETER. VAL ALWAYS 1000077 + ; + MIN*100+MAX REGULAR+OPTIONAL ARGS. NOTE THERE + ; MAY BE A REST ARG AS WELL +XARGI1: CAIN ZR,QZMESA + JRST XAGS1 + CAIN ZR,QZSYM + JRST [ MOVE S,MEM+2(S) + JRST XARGI0] + CAIN ZR,QZFEFP + JRST XAGM1 + CAIN ZR,QZARYP + JRST XAGAR1 +XAGM2: MOVE T,[QZFIX_23.+AGIINT+.BM <%AGIMX,,>];CANT FIGURE IT OUT, + POPJ P, ; MUST BE INTERPRETER TRAP + +XAGAR1: LDB T,[%ARYND,,MEM(S)] ;ARRAY POINTER + DPB T,[%AGIMN,,T] + TLO T,QZFIX_5 + POPJ P, + +XAGS1: MOVE T,MEM+MFFSO(S) ;MESA-FCTN + POPJ P, + +XAGM1: LDB T,[%FRMDT,,MEM(S)] + CAIE T,FRMFEF + JRST XAGM2 + MOVE T,MEM+QFRFSO(S) ;MACRO COMPILED, FAST OPT STORED IN ANY CASE! + POPJ P, + +SPRDP: EXCH S,T ;DONT SKIP IF IT WOULD BE A GOOD IDEA TO CALL + PUSHJ P,XARGI0 ;FCTN IN T WITH A FEXPR TYPE CALL + EXCH S,T + AND S,[AGIRQT+AGIREV+.BM <%AGIMN,,>+.BM <%AGIMX,,>] + CAME S,[AGIRQT] + CAMN S,[AGIREV] + POPJ P, ;IF HAS ONLY A REST ARG, USE UN-SPREAD CALL + JRST POPJ1 + +MR3VVS: +MR3VV: ;RETURN 3 VALUES, AMT TO POP IP IN D + MOVEI E,3-1 + JRST MR3VV1 + +MRNVS: +MRNV: 0 ;RETURN N VALUES, AMT TO POP IN JSR + MOVE C,MRNV ;NUMBER VALS IN E + SOJA E,MR3V1 ;BBLK + +MRNVVS: ;AMT TO POP IN D, NUMBER TO RET IN E +MRNVV: SOJA E,MR3VV1 + +MR3VS: +MR3V: 0 ;RETURN 3 VALUES AMT TO POP IN AC OF JSR + MOVE C,MR3V + MOVEI E,3-1 + JRST MR3V1 + + +MR2VVS: +MR2VV: ;RETURN 2 VALUES, AMT TO POP IP IN D + MOVEI E,2-1 + JRST MR3VV1 + + +MR2VS: +MR2V: 0 ;RETURN 2 VALUES, AMT TO POP IN JSR + MOVE C,MR2V + MOVEI E,2-1 ;RETURN 2 VALUES (ONE HERE AND ONE NORMAL) +MR3V1: LDB D,[270400,,-1(C)] ;GET # TO POP IP ON RETURN (IN ADDITION TO FLUSHING ARGS +MR3VV1: HRRZ A,IP + SUBI A,1(E) + SUB A,D ;ENDEVOR TO FIND THE INFO + HRRZ R,IP + SUBI R,1-1(E) ;GET POINTER TO FIRST VALUE + MOVE T,(R) ;GET FIRST VALUE + MOVE ZR,(P) ;A HAS LEVEL TO WHICH IP SHOULD EVENTUALLY BE RESTORED + TLNN ZR,PPBINF + JRST MRX ;HE DOESNT REALLY WANT MORE THAN ONE VALUE ANYWAY + HRRZ S,A ;HE DID MICRO-TO-MICRO, SO INFO PRECEEDS FIRST ARG? + TLNE ZR,PPBMAA + MOVEI S,-LLPFRM(A) ;NOPE IT WAS A XX-TO-MACRO (WHICH TURNNED OUT..) +MR2V1: PUSHJ P,XRNV2 + JRST MRX + MOVE T,1(R) ;GET NEXT VALUE + SOS E ;NUMBER OF VALUES LEFT + TRNE E,-1 ;SKIP ON THATS LAST ONE, LEAVE IT IN T + AOJA R,MR2V1 ;STORE NEXT VALUE +MRX: HRR IP,A ;RESTORE IP (HOPEFULLY BY RIGHT AMOUNT) +; JUMPGE E,CPOPJ ;DONT POP LINEAR-PDL-BINDING BLOCK, JUST RETURN +CBBLKP: MOVSI ZR,PPBSPC + TDNE ZR,(P) + PUSHJ P,BBLKP ;POP BLOCK IF ONE PUSHED + POPJ P, ;THEN RETURN + + +;MURVS: 0 +; MOVE C,MURVS +; MOVSI E,(SETZ) +; JRST MURVS1 + +;MURVVS: 0 +; MOVE C,MURVVS +; MOVSI E,(SETZ) +; JRST MURVV1 + +MURVVS: +MURVV: 0 + MOVE C,MURVV + MOVEI E,0 + JRST MURVV1 + +MURVS: +MURV: 0 ;RETURN-NEXT-VALUE, RETURN TO CALLER IF MORE DESIRED + MOVE C,MURV + MOVEI E,0 +MURVS1: LDB D,[270400,,-1(C)] +MURVV1: POP IP,T + HRRZ A,IP + SUB A,D + MOVE ZR,(P) + TLNN ZR,PPBINF + JRST MRX + HRRZ S,A + TLNE ZR,PPBMAA + MOVEI S,-LLPFRM(A) + PUSHJ P,XRNV2 + JRST MRX + JRST (C) ;COMPUTE MORE VALUES + + + +SPECBN: TLZ PC,QBBFL ;START NEW BINDING BLOCK + MOVSI ZR,PPBSPC + IORM ZR,(P) ;SIGNAL SP BINDINGS THIS BLOCK +SPECB1: MOVE I,(S) ;FOR BINDING SPECIAL ARGS + TLNE I,777000 ;CALLED WITH JSP S,SPECBN + JRST (S) ;FOLLOWWED BY N WORDS WITH 0 OP CODE + MOVE B,(I) + MOVEI B,-MEM(B) + PUSHJ P,QBND1 ;AC FIELD HAS PDL INDEX BACK FROM IP THAT HAS + LDB C,[270400,,I] ;NEW CONTENTS. ADDRESS POINTS TO MICRO-CODE-EXIT + MOVNS C ;VECTOR WHICH POINTS DIRECTLY TO Q TO BE BOUND + ADDI C,(IP) + MOVE D,(C) + DPB D,[%NDAT,,MEM(B)] + AOJA S,SPECB1 + +SPCSTR: HALT +; 0 ;CALL WITH JSR <# BINDINGS TO POP>,SPECSTR +; MOVE C,SPCSTR ;DOES A POPJ ON RETURN, SO THIS NORMALLY EXITS CALLING +; LDB R,[270400,,-1(C)] ;FCTN +;SPCST2: JUMPE R,CPOPJ +; PUSHJ P,QUNBND +; SOJA R,SPCST2 + +SPCST1: HALT + + +MMCALB: 0 ;SAME AS MMCALT, BUT BOX T AS WELL + MOVE C,MMCALB + TLZ T,777740 + TLO T,QZFIX_5 + PUSH IP,T + JRST MMCAL1 + +MMCALT: 0 ;SAME AS MMCALL BUT PUSH IP,T FIRST + PUSH IP,T + MOVE C,MMCALT + JRST MMCAL1 + +MMCALL: 0 ;INITIATE MICRO TO MACRO CALL + MOVE C,MMCALL ;# ARGS IN AC OF JSR ,MMCALL +MMCAL1: LDB S,[270400,,-1(C)] +MMCAL4: LDB T,[%NDTB,,LPFEF(AP)] + CAIN T,QZMESA + JRST MMCAL5 + SKIPE SKPLST(T) + JRST [ HRRZ J,C + CAIE J,INTRET + HALT ;HAD BETTER BE INTERPRETER CALL + JRST MMCAL5] +; CAIE T,QZIVGC +; CAIN T,QZIVCE +; JRST MMCAL5 + CAIE T,QZUENT + HALT +MMCAL5: MOVEM S,NARGS ;MESA ACTIVATE CALL BLOCK COMES IN HERE + MOVNS S + ADDI S,(IP) ;LOCATE NEW ARGS POINTER + CAME S,IPMARK + HALT ;# ARGS IN AC NECESSARY? +; TLZ C,-1 +; TLNE PC,QBBFL +; TLO C,(LPEBFL) + HRLI C,QZFIX_5 ;THE PPBSPC BIT (OR OTHER FUNNY BITS) + ; CAN NOT BE ON IN THIS PC + MOVEM C,LPEXS(AP) ;SAVE PC + SKIPGE A,LPFEF(S) + PUSHJ P,ITRAP +MMCS2: LDB B,[%NDTB,,A] ;S HAS IPMARK + SKIPL DQMRC1(B) + PUSHJ P,MLLV + XCT DQMRCL(B) + JRST INTP1 + +MLLV: POP P,MMLVX + JSR QMMPSH + DPB J,[%LPNWP,,LPENS(AP)] + TLZ PC,QBBFL+QINDAT+QINDNL ;+QBNEAF + JRST @MMLVX + +MMLVX: 0 + + +QMMPSH: 0 + MOVEI J,0 ;XFER P PDL TO LINEAR BIND STACK + HRRZ ZR,P + CAIG ZR,PDL + JRST @QMMPSH ;THRU WITH PDL XFER + AOS R,QLBNDP + POP P,Q + TLZ Q,777740 + TLO Q,+NUSRCB ;FIRST Q IN BLOCK, SET NUSRCB + MOVEM Q,(R) + AOS J +QMMPS1: HRRZ ZR,P + CAIG ZR,PDL + JRST @QMMPSH + AOS R,QLBNDP + POP P,Q + TLZ Q,777740 + TLO Q, + MOVEM Q,(R) + AOJA J,QMMPS1 + + +QMARTH: 0 ;CALL WITH ONE ARG IN T, OTHER ON (IP) + MOVE R,QMARTH ;OP IN AC OF JSR. + PUSH P,R ;RETURN + LDB C,[270400,,-1(R)] + MOVE S,(IP) + AOJA C,QIADD + +QMEQ: MOVE S,(IP) ;CALL WITH ONE ARG IN T, OTHER IN (IP) + PUSHJ P,QIEQ ;RETURNS QINDNL IN SIGN OF Q + MOVEI Q,0 + TLNE PC,QINDNL + TLO Q,400000 + POPJ P, + +QMLSP: SKIPA C,[2] +QMGRP: MOVEI C,1 + MOVE S,(IP) + PUSHJ P,QIGRP + MOVEI Q,0 + TLNE PC,QINDNL + TLO Q,400000 + POPJ P, + +SECDR: SUBI B,MEM + SKIPGE T,MEM(B) + PUSHJ P,ITRAP + JRST QISCDR + +SECDDR: SUBI B,MEM + SKIPGE T,MEM(B) + PUSHJ P,ITRAP + JRST QSCDDR + +SE1M: SKIPA C,[7] +SE1P: MOVEI C,6 + SUBI B,MEM + SKIPGE T,MEM(B) + PUSHJ P,ITRAP + JRST QISP1 + +SETIND: MOVE S,T ;SET INDICATORS ACCORDING TO THING IN T + PUSHJ P,SETIN1 ;SET QINDAT IN SIGN OF I + MOVEI I,0 + TLNE PC,QINDAT + MOVSI I,400000 + POPJ P, + + +NSKIP: TLZ T,RBMSK ;SKIP ON T NIL. + CAMN T,[QZSYM_5,,] + AOS (P) + POPJ P, + +NNSKIP: TLZ T,RBMSK + CAME T,[QZSYM_5,,] + AOS (P) + POPJ P, + +XMBIND: POP IP,T ;USER CALLABLE BIND FUNCTION FROM MICRO-CODE + POP IP,B + PUSHJ P,GLOCA + JRST XMBIN2 + +BNDNIL: MOVSI T,QZSYM_5 ;BIND TO NIL + JRST BNDNI1 + +BNDPPN: +BNDPOP: POP IP,T ;BIND VAR TO WHATS ON TOP OF IP PDL +BNDNI1: SUBI B,MEM +XMBIN2: TLZ PC,QBBFL ;START NEW BINDING BLOCK + MOVSI ZR,PPBSPC + TDNE ZR,-1(P) + TLO PC,QBBFL ;HAVE ALREADY STARTED ONE + IORM ZR,-1(P) ;RECORD ONE STARTED + PUSHJ P,QIBND ;BIND SV. POINTER TO VALUE CELL IN B, NEW CONTENTS ON IP + DPB T,[%NDAT,,MEM(B)] + POPJ P, + +UBDN: MOVSI ZR,PPBSPC ;POP NUMBER OF BINDINGS IN R + TDNN ZR,-1(P) + HALT ;NO BINDING BLOCK OPEN + TLO PC,QBBFL +UBDN1: PUSHJ P,QUNBND + TLNN PC,QBBFL + JRST UBDN2 ;THAT WAS LAST OF BLOCK + SOJG R,UBDN1 + POPJ P, + +UBDN2: CAIE R,1 + HALT ;TRYING TO POP MORE THAN THERE IS + MOVSI ZR,PPBSPC + ANDCAM ZR,-1(P) ;BINDING BLOCK NO LONGER OPEN + POPJ P, + +SNLST: MOVE S,(IP) ;STORE NEXT LIST + SKIPGE MEM(S) + PUSHJ P,ITRAP + DPB T,[%NDAT,,MEM(S)] ;STORE CRUFT + MOVE T,S + PUSHJ P,QCDR + MOVEM T,(IP) + TDNE T,[37,,777777] + POPJ P, ;NOT THRU + SUBI IP,1 ;FLUSH THAT + POP IP,T ;OTHER POINTER TO LIST (IE VALUE OF LIST) + POPJ P, + + +XLIST: HRRZ S,CNSADF + TRZE B,100 + HRRZ S,T ;LIST-IN-AREA, USE AREA SUPPLIED + PUSHJ P,IALLB ;ALLOCATE BLOCK (SIZE IN B, AREA IN S) + PUSH IP,T ;PUSH TWO POINTERS TO IT + PUSH IP,T + POPJ P, + +XSCSTR: POP IP,T ;STORE INTO SCRATCH-PAD MEM + POP IP,S + MOVEM T,SPMEM(S) + POPJ P, + +XSCRD: POP IP,S ;READ SCRATCH-PAD MEM + MOVE T,SPMEM(S) + POPJ P, + +XRMB: POP IP,B ;LOAD MISC BITS + PUSHJ P,GLOCA + LDB T,[%RBMSK,,MEM(B)] + TLO T,QZFIX_5 + POPJ P, + +XSMB: POP IP,T ;STORE MISC BITS + POP IP,B + PUSHJ P,GLOCA + DPB T,[%RBMSK,,MEM(B)] + POPJ P, + + +XSPDP: POP IP,T ;STORE PDP-10 INST + POP IP,S + DPB S,[202000,,T] + POP IP,S + DPB S,[400400,,T] + POP IP,B + PUSHJ P,G10AD + MOVEM T,(B) + JRST XFALSE + +XRPDP: POP IP,T ;RELOCATE PDP-10 INST AMOUNT + POP IP,S ;SET INDIRECT FLAG + POP IP,B ;LOCATION POINTER + PUSHJ P,G10AD + HRRZ ZR,T + ADD ZR,(B) + HLL ZR,(B) + TDNE S,[37,,-1] + TLO ZR,20 + MOVEM ZR,(B) + POPJ P, + + +XGMPNT: POP IP,T + LDB ZR,[%NDTB,,T] + CAIE ZR,QZMEMP + ADDI T,MEM + TLZ T,777740 + TLO T,QZMEMP_5 + POPJ P, + +G10AD: LDB ZR,[%NDTB,,B] ;POINTERS TO PDP10 INSTRUCTIONS MUST BE FIXNUMS + CAIE ZR,QZFIX ;TO AVOID INCONSISTANT DATA BASE PROBLEMS + HALT + ADDI B,MEM + POPJ P, + +GLOCA: LDB ZR,[%NDTB,,B] + CAIN ZR,QZFIX + BARF FIXNUM AS ADDRESS,B/& + CAIN ZR,QZMEMP + SUBI B,MEM + POPJ P, + +;ERR HANDLER + + +;STACK-GROUP STUFF + +;ENTER HERE WHEN STACK-GROUP CALLED AS FUNCTION. +; ANY (SEMI-REASONABLE-SIZE) NUMBER OF ARGUMENTS MAY BE PASSED. +; THESE ARE IGNORED BY THE SYSTEM, BUT A POINTER TO THEM IS +; STORED IN THE SGARGP OF THE CALLED STACK-GROUP, AND THEIR NUMBER +; IS STORED IN SGARGN OF THE CALLED STACK-GROUP. THUS, THEY CAN +; FAIRLY CONVENIENTLY BE REFERENCED BY THE CALLED STACK-GROUP. + +QSTKG1: MOVE B,A ;S-G GOING TO + LDB ZR,[%SGSST,,SGSTAT+MEM(B)] + CAIE ZR,SGNACL ;THIS STACK-GROUP AWAITING CALL? + JRST [ CAIN ZR,SGNAIC + JRST .+1 ;AWAITING INITIAL CALL OK TOO. + HALT] + MOVE AP,S ;"ACTIVATE" CALLED FRAME (SIMILAR TO WHAT QLENTR + ; WOULD DO.) + PUSHJ P,SGLV ;STORE MOST EVERYTHING BACK INTO CURRENT S-G, + ; LEAVES PNTR TO CURRENT S-G IN A. + MOVEM B,SGFOLL+MEM(A) + MOVEM A,SGPREV+MEM(B) + MOVEM AP,SGARGP+MEM(B) ;AP POINTS TO QZSTKG CALLED AS FCTN IN STACK OF CALLING + MOVE ZR,NARGS ; STACK GROUP. + TLO ZR,QZFIX_5 + MOVEM ZR,SGARGN+MEM(B) ;# ARGS BEING CALLED WITH THIS TIME. + MOVE D,SGSTAT+MEM(A) ;DO WE WANT TO SWAP BINDINGS OF STACK-GROUP LEAVING? + TLNE D,(SGSNSP) + JRST QSTKG2 ;IF NO SPECIALS, NO + MOVE C,SGSTAT+MEM(B) + TRNN D,SGSSCO ;IF I SAY TO DO IT ON CALL-OUT + TRNE C,SGSSCI ; OR HE SAYS TO DO IT ON CALL-IN + PUSHJ P,SGVSW ; SWAP BINDINGS OF STACK-GROUP +QSTKG2: LDB ZR,[%SGSST,,SGSTAT+MEM(A)] ;SHIFT CURRENT STATE TO PREV STATE + DPB ZR,[%SGSPS,,SGSTAT+MEM(A)] + MOVEI D,SGNART ;AWAITING-RETURN -> CURRENT STATE + DPB D,[%SGSST,,SGSTAT+MEM(A)] + + MOVE A,SGFOLL+MEM(A) + LDB E,[%SGSST,,SGSTAT+MEM(A)] ;SET CURRENT STATE TO ACTIVE + DPB E,[%SGSPS,,SGSTAT+MEM(A)] + MOVEI D,SGNACT + DPB D,[%SGSST,,SGSTAT+MEM(A)] + CAIN E,SGNAIC + JRST QSG2A ;ACTIVATE AWAITING-INITIAL-CALL GROUP + PUSHJ P,SGENT ;ENTER NEW STACK-GROUP +;ON REAL MACHINE, BELOW CODE MUST NOT CLOBBER ANY "STATE" AC S. + MOVE A,QCSTKG + MOVE D,SGSTAT+MEM(A) ;NEED TO UNSWAP BINDINGS OF STACK-GROUP ENTERING? + TLNE D,(SGSSVD) + PUSHJ P,SGVUSW ;BINDINGS ARE SWAPPED NOW, BETTER RESWAP BEFORE TRYING + ;TO RUN + MOVSI T,QZSYM_5 ;%STACK-GROUP-RETURN RETURNS NIL + POPJ P, ;START RUNNING?! + +QSG2A: PUSHJ P,SGENT ;ACTIVATE-INITIAL-CALL + MOVE S,IPMARK ;GET POINTER TO FEF TO CALL (PREVIOUSLY STORED) + HRRZ ZR,IP + SUBI ZR,(S) + MOVEM ZR,NARGS + SKIPGE A,LPFEF(S) + PUSHJ P,ITRAP + LDB B,[%NDTB,,A] + SKIPL DQMRC1(B) ;NO LEAVING OPERATION REQUIRED EVER + JFCL + XCT DQMRCL(B) ;CAN UNSKIP TWICE IF SYM OR INVZ + JRST INTP1 + + + +XSTGR: POP IP,SGVTEM ;%STACK-GROUP-RETURN + MOVEI D,SGNACL ;EVENTUALLY SWITCH GROUP TO AWAITING CALL STATE + MOVE A,QCSTKG ;STACK-GROUP LEAVING +XSTGR1: ;ENTER HERE FROM QMXSG, WITH EVENTUAL NEW S-G STATE IN D + MOVE B,SGPREV+MEM(A) ;STACK-GROUP RETURNNING TO. + LDB ZR,[%NDTB,,B] + CAIE ZR,QZSTKG + HALT ;PREVIOUS STACK-GROUP A LOSER? + LDB ZR,[%SGSST,,SGSTAT+MEM(B)] + CAIE ZR,SGNART + HALT ;OR NOT AWAITING-RETURN. + PUSHJ P,SGLV + LDB E,[%SGSST,,SGSTAT+MEM(A)] ;SWITCH STATES AFTER SGLV SO ERROR CHECK CAN WIN + DPB E,[%SGSPS,,SGSTAT+MEM(A)] + DPB D,[%SGSST,,SGSTAT+MEM(A)] ;SWITCH TO NEW STATE, AWAITING-CALL OR EXHAUSTED + CAIN D,SGNEXH + JRST XSTGR2 ;DONT TRY TO SWAP EXHAUSTED SG (AP IS OUT THE TOP) + MOVE E,SGSTAT+MEM(A) ;ANY S-V BINDINGS TO SWAP? + TLNN E,(SGSNSP) + PUSHJ P,SGVSW ;YEP, BETTER SWAP THEM OUT +XSTGR2: MOVE A,SGPREV+MEM(A) + LDB D,[%SGSST,,SGSTAT+MEM(A)] ;SET CURRENT STATE TO ACTIVE + DPB D,[%SGSPS,,SGSTAT+MEM(A)] + MOVEI D,SGNACT + DPB D,[%SGSST,,SGSTAT+MEM(A)] + PUSHJ P,SGENT + MOVE A,QCSTKG + MOVE D,SGSTAT+MEM(A) ;NEED TO DO A FRWSWP STACK-GROUP ENTERING? + TLNE D,(SGSSVD) + PUSHJ P,SGVUSW ;BINDINGS ARE SWAPPED NOW, BETTER RESWAP BEFORE TRYING + ;TO RUN + PUSH P,SGVTEM ;QMEX1 LIKES TO SEE VALUE IN (P) + MOVE T,SGVTEM ;VALUE HAD BETTER BE HERE TOO. + JRST QMEX1 ;CALL-STACK-GROUP RETURNS LIKE D-RETURN + +;CALL HERE TO ENTER STACK-GROUP, POINTER TO STACK-GROUP IN A +; ON RETURN, ALL AC'S AND THE PDL HAVE BEEN RESTORED TO THE SAVED STATE. +SGENT: HRRZ ZR,P + CAIE ZR,PDL+1 + .VALUE ;RETURN HAD BETTER HAVE BEEN ONLY THING ON U-STACK + POP P,SGERT ;GET THAT OFF TO MAKE ROOM FOR XFER'ED STUFF + LDB ZR,[%NDTB,,A] + CAIE ZR,QZSTKG + JRST SGENT1 + MOVEM A,QCSTKG + MOVE B,SGRA+MEM(A) ;GET POINTER TO L.P. STORAGE ARRAY +; MOVEM B,QLPBAS + MOVE E,MEM(B) + MOVEI C,MEM+1(B) + TRNE E,ARYEXL + AOS C + HRRZM C,QLPDLO ;LOW LIMIT + LDB ZR,[%ARYL,,MEM(B)] + TRNE E,ARYEXL + LDB ZR,[%NPTR,,MEM+1(B)] + ADDI ZR,-LPFUDG(C) ;ALLOW FOR FUDGE + HRRZM ZR,QLPDLH ;HIGH LIMIT + HRRZ ZR,SGPDLP+MEM(A) ;SET UP IP + ADD ZR,C + MOVE IP,ZR + SUB ZR,QLPDLH + HRLM ZR,IP ;SET UP L.H. OVFLW CHECK FOR RANDOMNESS + HRRZ ZR,SGAP+MEM(A) ;SET UP AP + ADD ZR,C + HRRZM ZR,AP + HRRZ ZR,SGIPM+MEM(A) ;SET UP IPMARK + ADD ZR,C + HRRZM ZR,IPMARK + MOVE B,SGBA+MEM(A) ;GET POINTER TO L.B. STORAGE ARRAY + MOVEM B,QLBBAS + MOVE E,MEM(B) + MOVEI C,MEM+1(B) + TRNE E,ARYEXL + AOS C + HRRZM C,QLBNDO + LDB ZR,[%ARYL,,MEM(B)] + TRNE E,ARYEXL + LDB ZR,[%NPTR,,MEM+1(B)] + ADD ZR,C + MOVEM ZR,QLBNDH + HRRZ ZR,SGBP+MEM(A) + ADD ZR,C + HRRZM ZR,QLBNDP + MOVE B,SGARYH+MEM(A) + MOVEM B,QLARYH + MOVE B,SGARYL+MEM(A) + MOVEM B,QLARYL +; MOVE B,SGNARG+MEM(A) +; HRRZM B,NARGS + MOVE Q,LPFEF(AP) + LDB J,[%NDTB,,Q] + XCT SGLOD(J) ;RELOAD MODE SPECIFIC INFO + MOVE B,SGINDS+MEM(A) ;RESTORE PC STATUS AFTER REST OF PC MAYBE RESTORED + DPB B,[%PCSTS,,PC] ; BY SGLOD DISPATCH +;RESTORE U-STACK + LDB J,[%NPTR,,SGUSTK+MEM(A)] ;# OF Q'S XFERRED FROM U-STACK + JSP S,QMMPO1 ;XFER THEM BACK + DPB J,[%NPTR,,SGUSTK+MEM(A)] ;DONT LEAVE GARBAGE AROUND ... (0 IN J) +;RESTORE RANDOM REGS + IRPS AC,,ZR B C D E T R Q I J S T + MOVE AC,SGAA!AC+MEM(A) +TERMIN + MOVE A,SGAAA+MEM(A) + JRST @SGERT + +SGENT1: .VALUE + JRST @SGERT + +SGERT: 0 + +;CALL HERE TO LEAVE CURRENT STACK-GROUP +; LEAVES POINTER TO CURRENT STACK-GROUP IN A +; STORES ALL AC'S SO THEY ARE RESTORABLE BY SGENT. ON THE IMMEDIATE RETURN, +; AC'S Q J R S HAVE BEEN CLOBBERED. + +SGLV: PUSH IP,A + PUSH IP,ZR + MOVE A,QCSTKG + LDB ZR,[%NDTB,,A] + CAIE ZR,QZSTKG + JRST SGLV1 ;ITS A LOSER, CANT STORE STUFF + LDB ZR,[%SGSST,,SGSTAT+MEM(A)] + CAIE ZR,SGNACT + HALT ;CURRENT STACK-GROUP NOT ACTIVE? + POP P,SGERT +;STORE REGISTERS + POP IP,SGAAZR+MEM(A) + POP IP,SGAAA+MEM(A) +IRPS AC,,B C D E T R Q I J S T + MOVEM AC,SGAA!AC+MEM(A) +TERMIN + JSR QMMPSH ;XFER U-STACK TO L-B STACK + HRLI J,QZFIX_5 + MOVEM J,SGUSTK+MEM(A) ;RECORD HOW MANY XFERRED + MOVE Q,LPFEF(AP) + LDB J,[%NDTB,,Q] + XCT SGSTR(J) ;STORE ANY LIVE INFO ASSOC WITH FLAVOR CODE LEAVING + MOVE J,QCSTKG ;COMPUTE DATA ORIGIN OF L.P. STORAGE ARRAY + MOVE J,SGRA+MEM(J) + MOVE Q,MEM(J) + MOVEI J,MEM+1(J) + TRNE Q,ARYEXL + AOS J ;LONG ARRAY, SPACE PAST INDEX-LENGTH Q + MOVE R,QLBBAS + MOVE Q,MEM(R) + MOVEI R,MEM+1(R) + TRNE Q,ARYEXL + AOS R ;LONG-ARRAY, SPACE PAST INDEX-LENGTH Q + MOVEI Q,(IP) ;STORE LINEAR PDL POINTER + SUB Q,J ;MAKE RELATIVE TO L.P. STORAGE ARRAY + HRLI Q,QZFIX_5 + MOVEM Q,SGPDLP+MEM(A) + ;SGBA LINEAR BINDING ARRAY + HRRZ Q,QLBNDP ;STORE BINDING PDL POINTER + SUB Q,R ;MAKE RELATIVE TO L.B.A. STORAGE ARRAY + HRLI Q,QZFIX_5 + MOVEM Q,SGBP+MEM(A) + MOVEI Q,(AP) ;STORE ARG POINTER + SUB Q,J ;MAKE RELATIVE TO L.P. STORAGE ARRAY + HRLI Q,QZFIX_5 + MOVEM Q,SGAP+MEM(A) + MOVE Q,IPMARK ;STORE POINTER TO OPEN CALL BLOCK + SUB Q,J + HRLI Q,QZFIX_5 + MOVEM Q,SGIPM+MEM(A) + MOVE Q,QLARYH ;STORE LAST ARRAY HEADER SIDE EFFECT REGISTER + MOVEM Q,SGARYH+MEM(A) + MOVE Q,QLARYL ;STORE LAST ARRAY ELEMENT NUMBER REF'ED + MOVEM Q,SGARYL+MEM(A) +; MOVE Q,NARGS ;SAVE NUMBER ARGS +; HRLI Q,QZFIX_5 +; MOVEM Q,SGNARG+MEM(A) + LDB Q,[%PCSTS,,PC] ;SAVE INDICATORS AND STATUS + TLO Q,QZFIX_5 + MOVEM Q,SGINDS+MEM(A) + JRST @SGERT + +SGLV1: .VALUE + POP IP,ZR + POP IP,A + POPJ P, + +SSTRIV: MOVE Q,MEM(Q) + POP P,J + JRST -2(J) + +SGVSW: MOVE T,QCSTKG + MOVE D,SGSTAT+MEM(T) + TLOE D,(SGSSVD+SGSSWI) + .VALUE ;ALREADY SWAPPED? + MOVEM D,SGSTAT+MEM(T) ;INDICATE SWAPPED AND SWAP IN PROGRESS. + HRRZ J,QLBNDP ;SWAP SPECIAL BINDINGS FOR CURRENT STACK GROUP + HRRZ B,QLBNDO +SGVS1: CAMG J,B + JRST SGVSX + LDB ZR,[%NDTB,,(J)] + CAIE ZR,QZXSYM + JRST SGVSP +SGVS2: MOVE C,(J) ;SWAP BINDINGS IN VAR BLOCK + MOVE D,-1(J) + LDB ZR,[%NDAT,,MEM(C)] + DPB D,[%NDAT,,MEM(C)] + DPB ZR,[%NDAT,,-1(J)] + SUBI J,2 + CAMG J,B + JRST SGVSX + TLNN D,NUSRCB + JRST SGVS2 + JRST SGVS1 + +SGVSP1: CAMG J,B + JRST SGVSX +SGVSP: MOVE ZR,(J) ;SPACE OVER BLOCK + TLNE ZR,NUSRCB + SOJA J,SGVS1 + SOJA J,SGVSP1 + +SGVSX: MOVSI ZR,(SGSSWI) + ANDCAM ZR,SGSTAT+MEM(T) ;NO LONGER IN PROGRESS! + POPJ P, + +SGVUSW: MOVE T,QCSTKG + MOVE D,SGSTAT+MEM(T) + TLZE D,(SGSSVD) + TLOE D,(SGSSWI) + HALT ;NOT SWAPPED OR COMPLETELY MUNGED + MOVEM D,SGSTAT+MEM(T) + HRRZ A,QLBNDO ;UNSWAP BINDINGS OF CURRENT STACK GROUP + HRRZ B,QLBNDP +SGUS1: CAIL A,-1(B) ;MUST BE AT LEAST 2WDS TO BE A POSSIBLE BINDING BLOCK + JRST SGVUSX + MOVE C,2(A) + LDB ZR,[%NDTB,,C] + TLNN C,NUSRCB ;POINTER WD CAN NOT BE FIRST OF BLOCK + CAIE ZR,QZXSYM + AOJA A,SGUSP1 ;NOT BINDING BLOCK, SPACE OVER IT + MOVE D,1(A) + LDB ZR,[%NDAT,,MEM(C)] + DPB D,[%NDAT,,MEM(C)] + DPB ZR,[%NDAT,,1(A)] + ADDI A,2 + JRST SGUS1 + +SGUSP1: CAIL A,-1(B) + JRST SGVUSX + MOVE ZR,1(A) + TLNE ZR,NUSRCB + JRST SGUS1 ;NEW BLOCK STARTING, SEE IF IT MIGHT BE BINDING BLOCK + AOJA A,SGUSP1 + +SGVUSX: MOVSI ZR,(SGSSWI) ;NO LONGER IN PROGRESS! + ANDCAM ZR,SGSTAT+MEM(T) + POPJ P, + +;--BELOW CODE AND DISCUSSION OBSOLETE-- +;SWAP S-V BINDINGS FOR STACK-GROUP IN A. CAN CLOBBER ALL AC S EXCEPT A. +; ALSO CLOBBERS QLPDLO, QLBNDP, AND QLBNDO SO CURRENT RUNNING STACK-GROUP +; HAD BETTER HAVE BEEN SAVED ALREADY, AND A STACK-GROUP ENTER DONE AFTER +; SGFRMS RETURNS. + +;A NOTE ON SAVED MICRO-STACKS: +; WHEN A MICRO-TO-MACRO CALL IS MADE, THE MICRO-STACK EXISTING AT THE TIME +; IS TRANSFERRED TO TO L-B-P. SGFRMS MUST BE AWARE OF THESE BLOCKS FOR TWO +; REASONS: 1) IT MUST SPACE OVER THEM TO KEEP THINGS IN PHASE, AND +; MORE IMPORTANT 2) IF THE PPBSPC BIT IS ON IN ONE OF THESE, IT MEANS +; THIS LEVEL HAS BOUND SPECIAL VARIABLES AND HAS A L-B-P BLOCK ASSOCIATED +; WITH IT. THIS MUST BE TAKEN INTO ACCOUNT TO KEEP THING FROM GETTING GROSSLY OUT OF +; PHASE. HOWEVER, NOTE THAT 2) IS ONLY POSSIBLE IF THE "RUNNING" FUNCTION +; (IE THE ONE IN THE LPFEF SLOT) IN THE FRAME IS MICRO-COMPILED. THIS IS BECAUSE +; THE ONLY WAY MACRO-CODE CAN TRANSFER TO MICRO-CODE WITHOUT MAKING A NEW FRAME +; IS VIA MISC-INSTRUCTIONS, AND THESE ARE NOT ALLOWED TO BIND SPECIAL VARIABLES +; (AS OPPOSED TO BIND THEM ON BEHALF OF THE MACRO-CODE, A LA BIND INSTRUCTION). +; ANOTHER POINT IS THAT THE ONLY MACRO-FRAME WHICH CAN POSSIBLY HAVE A NON-NULL +; MICRO-STACK ASSOCIATED WITH IT IS THE INTERRUPTED FRAME (IE LAST ONE ON THE PDL). +; THIS IS BECAUSE IF THE FRAME WAS CALLED-OUT-OF, AT THAT INSTANT THE MICRO-STACK +; MUST HAVE BEEN NULL (AS IT ALWAYS IS AT MACRO-INSTRUCTION BOUNDARIES). +; WHEN THE MICRO-STACK TRANSFER IS DONE, IT IS DONE IN THE MOST NATURAL WAY, +; POPPING THINGS OFF ONE STACK AND PUSHING THEM ONTO THE OTHER. AS A RESULT, +; THE DATA THAT WINDS UP ON THE L-B-P IS NREVERSE D FROM THE WAY IT WAS ON THE +; MICRO-STACK. +; OTHER PDL-GRUBBING ROUTINES IN LMI (DEBUGGING TYPE STACK PRINTERS) HAVE SOLVED +; THIS BY ACTUALLY POPPING THE DATA BACK OFF TO RE-NREVERSE IT. HOWEVER, THIS +; NECESSITATES THE USE OF A DIFFERENT TEMPORARY STACK, WHICH IS NOT AVAILABLE +; ON THE REAL MACHINE. THEREFORE, THE CODE BELOW ATTEMPTS TO DEAL WITH THINGS +; IN THE NREVERSE D STATE AT SOME ADDITIONAL COST IN COMPLEXITY. + +;SGFRMS: MOVE T,A ;T IS ONLY AC NOT CLOBBERED BY FRMSWP BELOW! +; MOVE D,SGSTAT+MEM(T) +; TLOE D,(SGSSVD+SGSSWI) +; .VALUE ;ALREADY SWAPPED? +; MOVEM D,SGSTAT+MEM(T) ;INDICATE SWAPPED AND SWAP IN PROGRESS. +;;RESTORE LOW LIMIT PDL POINTERS IN NORMAL FASHION. +; MOVE B,SGLPA+MEM(T) ;L-P STORAGE ARRAY +; MOVE E,MEM(B) +; MOVEI C,MEM+1(B) ;C GETS LOW LIMIT OF LINEAR PDL +; TRNE E,ARYEXL +; AOS C +; HRRZM C,QLPDLO +; HRRZ AP,SGAP+MEM(T) +; ADD AP,C ;AP GETS HI LIMIT (LAST ACTIVE FRAME) +; MOVE B,SGBA+MEM(T) ;L-B-P STORAGE ARRAY +; MOVE E,MEM(B) +; MOVEI C,MEM+1(B) ;C GETS LOW LIMIT OF L-B-P +; TRNE E,ARYEXL +; AOS C +; MOVEM C,QLBNDO +; HRRZ ZR,SGBP+MEM(T) +; ADD ZR,C ;ZR GETS HI LIMIT OF L-B-P +; MOVEM ZR,QLBNDP +; LDB J,[%NPTR,,SGUSTK+MEM(T)] ;# OF Q S OF TRANSFERRED MICRO-STACK +; PUSHJ P,SGBPST ;SET UP VARS TO POINT TO AREA XFERD +; MOVE Q,LPFEF(AP) +;SGS0: LDB B,[%NDTB,,Q] ;STUFF BELOW MUST NOT CLOBBER J, S, OR R. +; CAIE B,QZFEFP +; JRST SGS0A ;ON OTHER D.T. LPEBFL DOESNT NECESSARILY MEAN THAT +; MOVE ZR,LPEXS(AP) ;WAS LINEAR PDL BLOCK "OPEN" +; TLNE ZR,(LPEBFL) +; PUSHJ P,SGSBS ;SWAP L-B-A BLOCK +;SGS0A: PUSHJ P,SGBPSC ;SEE IF ANY PPBSPC BITS SET IN XFER ED MICRO-STACK +; +;;TRAVERSE PDL FROM TOP-DOWN, VISITING EACH ACTIVE FRAME. FOR EACH: +;; 1) IS THIS FRAME A MACRO-COMPILED FRAME? +;; IF SO, SWAP S.V. S BOUND. +;; 2) DOES THIS FRAME HAVE A L-B-A BINDING BLOCK ASSOCIATED? +;; IF SO, SWAP S.V. S BOUND THERE. +;; 3) DOES THE FRAME HAVE ANY OTHER KIND OF L-B-A BLOCK ASSOCIATED? +;; IF SO, SPACE OVER IT TO KEEP THE POINTERS IN PHASE +;; 4) "REVERSE" THE %LPCAD FIELD SO THE PDL CAN EASILY BE TRAVERSED +;; IN THE OPPOSITE DIRECTION WHEN RESWAPPING. +; +; HRRZ IP,AP ;HAS POINTER TO PREV FRAME +;SGS1: CAMG AP,QLPDLO +; HALT ;SHOULD NOT HAVE REACHED END WITHOUT ENCOUNTERING 0 %LPCAD +; MOVE Q,LPFEF(AP) +;SGS3: MOVE B,LPCLS(IP) +; LDB D,[%NDTB,,Q] +; XCT SGSDSP(D) +; HALT +; +;SGSIVZ: MOVE Q,MEM(Q) +; JRST SGS3 +; +;SGSFRM: CAMN IP,AP ;THIS FRAME ASSUMEDLY PUT ON FOLLOWING FRAME +; JRST SGS3B ; SO CROSS CHECK +;SGS3B: MOVE ZR,LPEXS(AP) ;ITS A MACRO-CODE FRAME +; TLNE ZR,(LPEBFL) +; PUSHJ P,SGSBS ;FCTN HAS L-B-P BLOCK +;; MOVE ZR,LPENS(AP) +;; TLNE ZR,(LPESF) +;; PUSHJ P,FRMSWP ;FRMSWP CLOBBERS ALL AC'S EXCEPT T!!! +;SGSIVK: +;SGSARP: +;SGSSYM: +;SGSSG: +;SGS4: LDB ZR,[%LPCAD,,LPCLS(AP)] ;GET DELTA TO PREV ACTIVE BLOCK +; SUB IP,AP +; DPB IP,[%LPCAD,,LPCLS(AP)] ;MUNG IT TO POINT TO FOLLOWING BLOCK +; MOVE IP,AP +; SUB AP,ZR +; JUMPN ZR,SGS1 +; MOVE B,SGLPA+MEM(T) +; MOVE E,MEM(B) +; MOVEI D,-MEM-1(AP) +; SUBI D,(B) +; TRNE E,ARYEXL +; SOS D +; HRRZ ZR,SGIFCT+MEM(T) ;INDEX OF INITAL FCTN CELL +; CAME ZR,D +; HALT ;DIDNT TERMINATE AT RIGHT PLACE? +; HRRZ ZR,QLBNDP +; CAME ZR,QLBNDO +; HALT ;DID "USE" ALL OF L-B-P ? +; JRST SGS2 ;DONE +; +;SGSLST: JRST SGS4 ;BIND FEATURE NOT ACCESSIBLE TO INTERPRETER YET. +; +;SGSMSE: HALT +; +;SGSUCE: LDB J,[%LPNWP,,LPENS(AP)] ;# WDS MICRO-STACK TO XFER +; PUSHJ P,SGBPST ;SET UP VARS TO POINT TO AREA OF L-B-P THAT WAS XFERRD +; PUSHJ P,SGBPSC ;SCAN THAT, LOOKING FOR PPBSPC BITS +; JRST SGS4 +; +;SGS2: MOVE A,T ;PUT BACK POINTER TO STACK-GROUP +; MOVSI ZR,(SGSSWI) +; ANDCAM ZR,SGSTAT+MEM(A) ;NO LONGER IN PROGRESS! +; POPJ P, +; +;SGBPST: MOVE S,QLBNDP ;SAVE CURRENT QLBNDP (THIS TERMINATES THIS BLOCK) +; MOVN R,J +; ADDB R,QLBNDP ;DECREMENT QLBNDP BACK PAST ENTIRE BLOCK +; HRRZS R +; CAMGE R,QLBNDO +; HALT +; POPJ P, ;ALSO, LEAVE POINTER TO HEAD OF BLOCK IN R +; +;SGBPSC: JUMPE J,SGS0B ;THRU, DID THINGS COME OUT RIGHT? +;SGS0C: MOVE ZR,1(R) ;0(QLBNDP) IS CURRENT TOP OF LIST, AND WE WANT FROB +; ; BEYOND THAT. +; TLNE ZR,PPBSPC +; PUSHJ P,SGSBS +; AOS R +; SOJG J,SGS0C +;SGS0B: CAME R,S +; HALT ;THAT SHOULD HAVE COME OUT... +; POPJ P, +; +;;SWAP NEXT BLOCK ON L-B-P +;SGSBS: HRRZ Q,QLBNDP +;SGSBS1: CAMG Q,QLBNDO +; HALT ;REACHED TOP OF L-B-P ? +; MOVE B,(Q) +; LDB ZR,[%NDTB,,B] +; CAIE ZR,QZXSYM +; HALT ;BAD DT IN L-B-P BLOCK +; MOVE C,MEM(B) ;SWAP BINDING +; MOVE D,-1(Q) +; DPB D,[%NDAT,,MEM(B)] +; DPB C,[%NDAT,,-1(Q)] +; SUBI Q,2 +; TLNN D,NUSRCB ;END OF BLOCK? +; JRST SGSBS1 +; HRRM Q,QLBNDP +; POPJ P, +; +; +;;THIS ROUTINE EXACTLY UNDOES THE OPERATION DONE BY SGFRMS. +;SGFRMR: MOVE T,A +; MOVE D,SGSTAT+MEM(T) +; TLZE D,(SGSSVD) +; TLOE D,(SGSSWI) +; HALT ;NOT SWAPPED OR COMPLETELY MUNGED +; MOVEM D,SGSTAT+MEM(T) +; MOVE B,SGLPA+MEM(T) ;PDL STORAGE ARRAY +; MOVE E,MEM(B) +; MOVEI C,MEM+1(B) +; TRNE E,ARYEXL +; AOS C +; HRRZ AP,SGIFCT+MEM(T) +; ADD AP,C ;INITIALIZE AP TO POINT TO FIRST FRAME OF STACK-GROUP +; HRRZ ZR,SGAP+MEM(T) ;REAL AP POINTS AT LAST FRAME TO BE SCANNED +; ADD ZR,C +; HRRZM ZR,QLPDLH +; MOVE B,SGBA+MEM(T) ;L-B-P STORAGE ARRAY +; MOVE E,MEM(B) +; MOVEI C,MEM+1(B) +; TRNE E,ARYEXL +; AOS C +; HRRZM C,QLBNDP ;INITIALIZE BINDING PDL POINTER TO BASE OF L-B-P +; HRRZ ZR,SGBP+MEM(T) ;REAL BINDING PDL POINTER IS HIGH LIMIT OF AREA TO +; ADD ZR,C ; BE SCANNED +; HRRZM ZR,QLBNDH +; HRRZ IP,AP ;NOTE IP IN THIS CODE HAS POINTER TO THE PREVIOUS +; ;FRAME, AND THIS IS NORMALLY < AP +;SGR1: CAMLE AP,QLPDLH +; HALT ;ABOVE ACTIVE PDL AREA? +; MOVE Q,LPFEF(AP) ;GET FUNCTION RUNNING IN FRAME +;SGR3: LDB D,[%NDTB,,Q] +; XCT SGRDSP(D) +; HALT +; +;SGRIVZ: MOVE Q,MEM(Q) +; JRST SGR3 +; +;SGRFRM: +;; MOVE ZR,LPENS(AP) +;; TLNE ZR,(LPESF) +;; PUSHJ P,FRMSWP ;SWAP FRAME, (CLOBBERS ALL AC'S EX T) +; MOVE ZR,LPEXS(AP) +; TLNE ZR,(LPEBFL) +; PUSHJ P,SGRBS ;FCTN HAS A LINEAR PDL BLOCK +;SGRIVK: +;SGRARP: +;SGRSYM: +;SGRSG: +;SGR4: LDB ZR,[%LPCAD,,LPCLS(AP)] ;GET DELTA TO NEXT ACTIVE BLOCK +; SUBM AP,IP +; DPB IP,[%LPCAD,,LPCLS(AP)] ;TURN BACK AROUND TO NORMAL STATE OF POINTING +; MOVE IP,AP ; AT PREVIOUS ACTIVE BLOCK +; ADD AP,ZR +; JUMPN ZR,SGR1 +; LDB J,[%NPTR,,SGUSTK+MEM(T)] ;EXAMINE USTACK XFERRED ON STACK-EXIT FOR +; JUMPE J,SGR4A ;NONE, DONT WORRY ABOUT IT +; PUSHJ P,SGRLBS +;SGR4A: MOVE B,SGLPA+MEM(T) +; MOVE E,MEM(B) +; MOVEI D,-MEM-1(AP) +; SUBI D,(B) +; TRNE E,ARYEXL +; SOS D +; HRRZ ZR,SGAP+MEM(T) +; CAME ZR,D +; HALT ;DIDNT TERMINATE IN THE RIGHT PLACE? +; MOVE B,SGBA+MEM(T) +; MOVE E,MEM(B) +; ADD B,SGBP+MEM(T) +; MOVEI B,MEM+1(B) +; TRNE E,ARYEXL +; AOS B +; CAME B,QLBNDP +; HALT ;DIDNT USE UP ALL BINDING STACK +;SGR2: MOVE A,T ;GET BACK POINTER TO STACK-GROUP +; MOVSI ZR,(SGSSWI) ;NO LONGER IN PROGRESS! +; ANDCAM ZR,SGSTAT+MEM(A) +; POPJ P, +; +;SGRMSE: HALT +; +;SGRLST: JRST SGR4 +; +;; TO DETERMINE THE TYPE OF AN L-B-P BLOCK WHEN LOOKING FROM THE BOTTOM, IT IS +;;NECESSARY TO SCAN OVER THE ENTIRE BLOCK TILL THE Q WITH THE USRC BIT SET +;;IS ENCOUNTERED. ITS DATA TYPE THEN GIVES THE INFO. +;; L-B-P HAS SOME NUMBER (POSSIBLY 0) OF BINDING BLOCKS FOLLOWED BY SOME NUMBER +;; (POSSIBLY 0) OF TRANSFERRED MICRO-STACK Q S. PROCEED UP SWAPPING BINDING BLOCKS +;; AS THEY ARE ENCOUNTERED. WHEN THE XFERRED MICRO-STACK IS ENCOUNTERED, IT +;; HAD BETTER HAVE THE SAME # OF PPBSPC BITS SET AS THE NUMBER OF BINDING BLOCKS +;; PASSED OVER. +;SGRUCE: LDB J,[%LPNWP,,LPENS(AP)] +; JUMPE J,SGR4 ;NO XFERRED MICRO-STACK AREA, HAD BETTER NOT BE +; ; ANY BINDINGS EITHER. ADVANCE TO NEXT BLOCK. +; PUSHJ P,SGRLBS ;SCAN L-B-P +; JRST SGR4 +; +;SGRLBS: MOVEI R,0 ;NUMBER OF BINDING BLOCKS ENCOUNTERED +; HRRZ Q,QLBNDP ;# OF Q'S IN XFERRED USTACK AREA IN J +;SGR3L1: CAMLE Q,QLBNDH +; HALT +;;Q POINTS TO FIRST WD (IE LAST PUSHED) OF PREVIOUS BLOCK. +;; 1(Q) IS THE LAST WD OF THIS BLOCK, AND BETTER HAVE BUSRC SET +;; THE NEXT Q WITH BUSRC SET IN THE RANGE 2(Q) ... IS THE LAST Q +;; OF THE FOLLOWING BLOCK, AND THE Q BEFORE HIM GIVES THE TYPE OF THE +;; CURRENT BLOCK!! +; MOVEI S,2(Q) ;TRY TO FIGURE OUT WHAT KIND OF A BLOCK THIS IS.. +;SGR3L5: MOVE ZR,(S) +; TLNE ZR,NUSRCB +; JRST SGR3L6 ;THIS ON THE START OF HIS BLOCK, SO PREV GIVES TYPE +; ; OF PREVIOUS BLOCK +; CAMG S,QLBNDH ;TOP WD OF STACK GIVES TYPE OF TOP BLOCK +; AOJA S,SGR3L5 +;SGR3L6: LDB ZR,[%NDTB,,-1(S)] +; CAIN ZR,QZFIX +; JRST SGR3L2 ;ENCOUNTERED TRANSFERRED MICRO-STACK AREA +; CAIE ZR,QZXSYM +; HALT +; PUSHJ P,SGRBS ;SWAP FRAME +; AOJA R,SGR3L1 ;COUNT ONE MORE FRAME SWAPPED +; +;SGR3L2: AOS Q +; MOVE B,(Q) +; TLZN B,NUSRCB +; HALT ;THAT SHOULD HAVE BEEN SET (FIRST IN BLOCK) +;SGR3L3: TLNE B,NUSRCB +; HALT ;BLOCK RAN OUT PREMATURELY +; LDB ZR,[%NDTB,,B] +; CAIE ZR,QZFIX +; HALT +; TLNE B,PPBSPC +; SOS R ;THAT ACCOUNTS FOR ONE OF THEM +; AOS Q +; MOVE B,(Q) ;GETS EITHER NEXT Q OF THIS BLOCK OR LAST Q OF NEXT ONE. +; SOJG J,SGR3L3 +; SKIPE R ;ALL ACCOUNTED FOR? +; HALT +; SOS Q ;SO IT NOW POINTS AS FIRST (IE LAST PUSHED) Q OF THIS +; ; BLOCK AGAIN +; CAMN Q,QLBNDH +; JRST SGR3L4 ;AT TOP OF STACK +; TLNN B,NUSRCB ;THIS SHOULD BE FIRST ON NEXT BLOCK +; HALT +;SGR3L4: HRRZM Q,QLBNDP +; POPJ P, +; +;SGRBS: HRRZ Q,QLBNDP +; AOS Q ;SO POINTS AT LAST Q OF CURRENT BLOCK +; MOVE B,(Q) +; TLZN B,NUSRCB +; HALT ;SOMETHING OUT OF PHASE +;SGRBS2: CAMLE Q,QLBNDH +; JRST SGRBSX +; TLNE B,NUSRCB +; JRST SGRBSX ;THIS LAST WD OF FOLLOWING BLOCK +; LDB ZR,[%NDTB,,1(Q)] +; CAIE ZR,QZXSYM +; HALT +; MOVE C,1(Q) ;GET LOCATIVE PNTR +; MOVE D,MEM(C) ;CURRENT CONTENTS +; DPB B,[%NDAT,,MEM(C)] ;B HAS SAVED CONTENTS FROM L-B-P +; DPB D,[%NDAT,,(Q)] +; ADDI Q,2 +; MOVE B,(Q) +; JRST SGRBS2 +; +;SGRBSX: SOS Q ;SO AS TO POINT TO LAST PUSHED WD OF CURRENT BLOCK +; HRRZM Q,QLBNDP +; POPJ P, + + +CONSTANTS +VARIABLES + +;INTERPRETER VARIABLES +;THE FIRST SECTION CORRESPONDS LOCN FOR Q WITH THE SCRATCH-INITIALIZATION AREA +;(ANSCR) ON COLD LOAD START-UP. +;THE SECOND SECTION OF VARIABLES ARE "COMPLETELY RANDOM" +;AND JUST INITIALIZED TO 0 ON COLD LOAD START-UP + +;ON A DIRTY TRAP, THE ENTIRE BLOCK IS STORED, ALONG WITH A THIRD SECTION +;CONSISTING OF THE INTERPRETER PDL AND AC'S. + +;--THIS WHOLE BLOCK REPRESENTS "THE OLD WAY" ... + +LPFUDG==10 ;LOAD QLPDLH WITH THIS MUCH LESS THAN IT "REALLY" SHOULD BE + ;FOR FUDGE FACTOR PURPOSES... + +SPMEM: ;BEGINNING OF "SCRATCH-PAD MEMORY" +;"RUNNING ENVIRONMENT" INFO +IFCTN: 0 ;POINTER TO INITIAL FUNCTION TO RUN +QTRPH: 0 ;POINTER TO FEF OF TRAP HANDLER, WHICH SHOULD BE A FCTN + ;OF N ARGS + ;1 ERROR CODE # + ;2 ERROR STATUS WD + ;3 ERROR SUBSTATUS +QCSTKG: 0 ;POINTER TO CURRENT STACK-GROUP +QISTKG: 0 ;INITIAL STACK GROUP. USE WHEN RESTARTING AFTER "CRASH" +QLARYH: 0 ;POINTER TO HEADER OF LAST ARRAY ELEMENT REFERENCED + +IFGE .-SPMEM-SPPO,.ERR TOO MANY SCRATCH POINTERS +LOC SPMEM+SPPO ;OFFSET TO PARAMETER STG AREA + +EINPRG: 0 ;IF -1, ERROR TRAP IS IN PROGRESS, AND ANY OTHER TRAP IS FATAL +CNSADF: 0 ;DEFAULT AREA TO DO CONSES IN +BNCNSA: 0 ;AREA TO DO CONSES FOR BIND BLOCKS IN +QLARYT: 0 ;TYPE OF ARRAY LAST ARRAY REF'ED WAS --OBSOLETE-- +QLARYL: 0 ;ELEMENT NUMBER OF LAST ARRAY REF'ED +QIVKM: 0 ;INVOKE MODE + ;NORMAL TRAPPING + ;TREAT AS IF DATA TYPE HAD BEEN LIST +QIVSM: 0 ;INVISIBLE MODE + ;NORMAL INVISIBLENESS + ;CC MODE NOT INVISIBLE + ;EFF ADD MODE ALSO NOT INVISIBLE + ;NO INVISIBLENESS + +QCARM: 0 ;CAR MODE + ;CAR OF SYMBOL GIVES + %CSYMM==300 ;ERROR + ;ERROR EXCEPT (CAR NIL) = NIL + ;NIL + ;P-STRING ARRAY POINTER + ;CAR OF NUMBER GIVES + %CNUMM==30300 ;ERROR + ;NIL + ;"WHATEVER IT IS" +QCDRM: 0 ;CDR MODE + .SEE %CSYMM ;CDR OF SYMBOL GIVES + ;ERROR + ;ERROR EXCEPT (CDR NIL) = NIL + ;NIL + ;PROPERTY LIST + ;CDR OF NUMBER GIVES + .SEE %CNUMM ;ERROR + ;NIL + ;"WHATEVER IT IS" + +AMCENT: 0 ;# ACTIVE MICRO-CODE ENTRIES (FOR ERROR CHECK AT QME1) + +IFGE .-EINPRG-SPTO,.ERR TOO MANY SCRATCH PARAMETERS +LOC EINPRG+SPTO ;OFFSET TO TEMP VAR AREA + +;RANDOM TEMPS + +INST: 0 ;LAST INSTRUCTION +QBTRP: 0 ;TRAP AFTER "ENTERING" FCTN (DUE TO ARG EXCEPTION, PROBABLY) + ;MEANING OF BITS IN QBTRP + + QBTFA==1 ;TOO FEW ARGS + QBTMA==2 ;TOO MANY ARGS + QBEQTA==4 ;ERRONEOUS QUOTED ARG + QBEEVA==10 ;ERRONEOUS EVALUATED ARG + QBBDT==20 ;BAD DATA TYPE + QBBQTS==40 ;BAD QUOTE STATUS + +QLOCO: 0 ;OFFSET BETWEEN LOCAL BLOCK AND ARG PNTR FOR CURRENT FUNCTION +NARGS: 0 ;NUMBER ARGS LOADED FOR CALL CURRENTLY ENTERING +QTEMPC: 0 ;TEM FOR PC (REL TO FEF) DURING ENTER OP +;QRSPCF: 0 ;FLAG SPECIALS IN BLOCK DURING SLOW ENTRY OP +IPMARK: 0 ;IP INDEX OF LAST "OPEN" CALL BLOCK IN CURRENT FRAME (AP IF NONE) +LNUSV: 0 ;LAST NUMBER UNSUPPLIED VALUES (REMAINING COUNT IN NUMBER EXPECTED + ;VALUES ON LAST ADDTL INFO RETURN PROCESSED +QLCTYP: 0 ;TYPE OF CALL AT QLENTR 0-> NORMAL, ADIFEX-> FEXPR, ADILEX-> LEXPR +NWADI: 0 ;# Q S ADI PUSHED WHEN MAKING CALL BLOCK (AT UAPLY, FOR EXAMPLE) +EISCR: ;END OF "INTERNAL SCRATCH PAD MEM" +;--END OF OLD BLOCK + +;--BEGINNING NEW SCRATCH BLOCK-- +;THIS IS THE WAY THINGS WILL EVENTUALLY BE.. VARIABLES SHOULD BE COMMENTED OUT +;IN THIS BLOCK IF THEY EXIST IN THE OLD BLOCK UNTIL THE SWITCHOVER IS MADE + +CATCHV: 0 ;VALUE RETURNED BY LAST CATCH +CATCHT: 0 ;TAG LAST CATCH WENT TO +CATCHM: 0 ;CATCH MARK (IE BASE OF OPEN CALL LOOKING FOR) +QLBBAS: 0 ;POINTER TO HEAD OF CURRENT BINDING PDL STORAGE ARRAY. +SGVTEM: 0 ;TEMP FOR VALUE BEING RETURNED IN STACK-GROUP HACKERY + +;--END NEW SCRATCH BLOCK-- + + +;INITIALIZED FROM STACK-GROUP +QLBNDP: 0 ;POINTER TO LINEAR MODE BIND STACK + ;-- IN LMI, THIS IS A DIRECT MEMORY POINTER -- + ;FIRST -> 0(QLBNDP), SECOND -> -1(QLBNDP), ETC + ;USRC=1 ON FIRST LAST Q IN BLOCK (IE FIRST PUSHED). + ; DATA TYPE OF FIRST Q (LAST PUSHED) + ; IN BLOCK DECODES TYPE OF BLOCK + ; LOCATIVE (QZXSYM IN LMI) NORMAL BINDING BLOCK + ; PNTR POINTS TO BOUND LOCN + ; NEXT Q GIVES PREV CONTENTS. + ; THIS PAIRING MAY BE REPEATED ANY NUMBER OF TIMES FOR + ; REST OF BLOCK + ; QZFIX TRANSFERRED P STACK (DUE TO MICRO-MACRO CALL) + ; ENTIRE BLOCK SHOULD BE QZFIX ES TO BE XFERRED. + ; QZMESA MESA-LEAVE BLOCK, PNTR POINTS TO MESA-FEF LEFT + ; BLOCK 2 Q S LONG + ; SECOND Q HAS SAVED MESA-PC +QLBNDO: 0 ;LOW LIMIT OF CURRENT L.B.A STORAGE ARRAY (= INITIAL QLBNDP) +QLBNDH: 0 ;HIGH LIMIT OF CURRENT L.B.A STORAGE ARRAY +QLPDLO: 0 ;LOW LIMIT OF CURRENT L.P. STORAGE ARRAY +QLPDLH: 0 ;HIGH LIMIT OF CURRENT L.P. STORAGE ARRAY + ;-- ALL THE ABOVE ARE DIRECT MEMORY POINTERS -- + +;DISPATCH TABLES + + +OPDTBA: @QADCM1(E) ;CALL + @QADCM1(E) ;CALL0 + @QADCM1(E) ;MOVE + @QADCM1(E) ;CAR + @QADCM1(E) ;CDR + @QADCM1(E) ;CADR + @QADCM1(E) ;CDDR + @QADCM1(E) ;CDAR + @QADCM1(E) ;CAAR + @QADCM1(E) ;ND1 + @QADCM1(E) ;ND2 + @QADCM1(E) ;ND3 + @BRDTAB(C) ;BRANCH + QIMSC ;MISC + QIERR1 + QIERR1 + +QADCM1: QAFE ;DISPATCH ON REG FOR ADR COMPUTE + QAFE + QAFE + QAFE + QAQT + QADLOC + QADARG + QADPDL + +QBOFDT: QBFE ;DISPATCH ON REG FOR ADR COMPUTE IN "INIT VAR TO CONTENTS OF EFF ADR" + QBFE + QBFE + QBFE + QBQT + QBDLOC + QBDARG + QBDPDL + +OPDTB: QICALL ;DISP WITH "E" IN B, C(E) IN T + QICAL0 + QIMOVE + QICAR + QICDR + QICADR + QICDDR + QICDAR + QICAAR + QIND1 + QIND2 + QIND3 + QIERR2 + QIERR2 + QIERR2 ;FREE + QIERR2 + +;DISP ON DATA TYPE OF C(E) +QADDTB: QADTRP ;TRAP + QADDR ;NULL + QADDR ;FREE + QADDR ;SYMBOL + QADDR ;FIX + QADDR ;EXTENDED NUMBER + QADDR ;INVOKE + QADIVG ;GC-FORWARD + QADIVE ;SYMBOL-COMPONENT-FORWARD + QADDR ;Q-FORWARD, NO SPECIAL ACTION + QADDR ;FORWARD, NO SPECIAL ACTION + QADDR ;MEM POINTER + QADDR ;LOCATIVE-TO-LIST + QADDR ;LOCATIVE-INTO-STRUCTURE + QADDR ;LOCATIVE-INTO-SYMBOL + QADDR ;LIST + QADDR ;LIST-INTO-STRUCTURE + QADDR ;LIST-INTO-SYMBOL + QADDR ;MICRO-CODE ENTRY + QADDR ;MESA-ENTRY + QADDR ;FEF + QADDR ;FEF HEADER + QADDR ;ARRAY HEADER + QADDR ;ARRAY POINTER + QADDR ;ARRAY LEADER + QADDR ;STACK-GROUP + QADDR ;CLOSURE +REPEAT NQZUSD,QADTRP + +;DISP ON DATA TYPE WHEN SETTING INDICATORS +QNDDT1: @QMDTBD(C) ;TRAP + @QMDTBD(C) ;NULL + @QMDTBD(C) ;FREE + QIMOV1 ;SYMBOL + QIMOV7 ;FIX + QIMOV7 ;EXTENDED NUMBER + @QMDTBD(C) ;INVOKE + @QMDTBD(C) ;GC-FORWARD + @QMDTBD(C) ;SYMBOL-COMPONENT-FORWARD + @QMDTBD(C) ;Q-FORWARD + @QMDTBD(C) ;FORWARD + @QMDTBD(C) ;MEM POINTER + @QMDTBD(C) ;LOCATIVE-TO-LIST + @QMDTBD(C) ;LOCATIVE-INTO-STRUCTURE + @QMDTBD(C) ;LOCATIVE-INTO-SYMBOL + @QMDTBD(C) ;LIST + @QMDTBD(C) ;LIST-INTO-STRUCTURE + @QMDTBD(C) ;LIST-INTO-SYMBOL + @QMDTBD(C) ;U CODE ENTRY + @QMDTBD(C) ;MESA ENTRY + @QMDTBD(C) ;FEF + @QMDTBD(C) ;FEF HEADER + @QMDTBD(C) ;ARRAY HEAD + @QMDTBD(C) ;ARRAY POINTER + @QMDTBD(C) ;ARRAY LEADER + @QMDTBD(C) ;STACK-GROUP + @QMDTBD(C) ;CLOSURE +REPEAT NQZUSD,@QMDTBD(C) + + +;DISP ON INPUT DATA TYPE WHEN TAKING CAR (CAR-PRE-DISPATCH) +CAPRDT: PUSHJ P,CAPRDL ;TRAP + PUSHJ P,CAPRDL ;NULL + PUSHJ P,CAPRDL ;FREE + JRST QCARSY ;SYMBOL + JRST QCARNM ;FIX + JRST QCARNM ;EXTENDED NUMBER + JSR IVACAR,IVAACT ;INVOKE + PUSHJ P,CAPRDL ;GC-FORWARD + JRST QCAR3 ;SYMBOL-COMPONENT-FORWARD + JRST QCAR5 ;Q-FORWARD + PUSHJ P,CAPRDL ;FORWARD + JRST QCARMP ;MEMORY POINTER + JRST QCAR3 ;LOCATIVE-TO-LIST + JRST QCAR3 ;LOCATIVE-INTO-STRUCTURE + JRST QCAR3 ;LOCATIVE-INTO-SYMBOL + JRST QCAR3 ;LIST + JRST QCAR3 ;LIST-INTO-STRUCTURE + JRST QCAR3 ;LIST-INTO-SYMBOL + PUSHJ P,CAPRDL ;U CODE ENTRY + PUSHJ P,CAPRDL ;MESA-ENTRY + JRST QCAR3 ;FEF + PUSHJ P,CAPRDL ;FEF HEADER + PUSHJ P,CAPRDL ;ARRAY HEADER + PUSHJ P,CAPRDL ;ARRAY POINTER + PUSHJ P,CAPRDL ;ARRAY LEADER + PUSHJ P,CAPRDL ;STACK-GROUP + JRST QCAR3 ;CLOSURE +REPEAT NQZUSD,PUSHJ P,CAPRDL + +; THIS USED TO BE ILLOP, BUT THIS IS BETTER FOR DEBUGGING +CAPRDL: BARF CAR OF BAD DATATYPE,T/& + + + +;DISPATCH ON DATA TYPE OF THING ABOUT TO RETURN AS CAR (CAR-POST-DISPATCH) +CAPODT: POPJ P, ;TRAP + POPJ P, ;NULL + POPJ P, ;FREE + POPJ P, ;SYMBOL + POPJ P, ;FIX + POPJ P, ;EXTENDED NUMBER + POPJ P, ;INVOKE + JRST CAGCIV ;GC-FORWARD + POPJ P, ;SYMBOL-COMPONENT-FORWARD + POPJ P, ;Q-FORWARD + JRST CAEIV ;FORWARD + POPJ P, ;MEMORY POINTER + POPJ P, ;LOCATIVE-TO-LIST + POPJ P, ;LOCATIVE-INTO-STRUCTURE + POPJ P, ;LOCATIVE-INTO-SYMBOL + POPJ P, ;LIST + POPJ P, ;LIST-INTO-STRUCTURE + POPJ P, ;LIST-INTO-SYMBOL + POPJ P, ;U CODE ENTRY + POPJ P, ;MESA-ENTRY + POPJ P, ;FEF + POPJ P, ;FEF HEADER + POPJ P, ;ARRAY HEADER + POPJ P, ;ARRAY POINTER + POPJ P, ;ARRAY LEADER + POPJ P, ;STACK-GROUP + POPJ P, ;CLOSURE +REPEAT NQZUSD, POPJ P, + + +;DISPATCH ON %CSYMM WHEN TAKING CAR OF SYM +CASYMD: QCASYE ;ERROR + QCASE1 ;ERROR EXCEPT (CAR NIL) = NIL + XFALSE ;RETURN NIL + QCAR3 ;P-NAME POINTER (TAKE NORMAL CAR) +NCARSM==.-CASYMD + +;DISPATCH ON %CNUMM WHEN TAKING CAR OF NUMBER +CANUMD: QCANME ;ERROR + XFALSE ;NIL + QCAR3 ;"WHATEVER IT IS" +NCARNM==.-CANUMD + +;DISPATCH ON INPUT DATA TYPE WHEN TAKING CDR (CDR-PRE-DISPATCH) +CDPRDT: PUSHJ P,CDPRDL ;TRAP + PUSHJ P,CDPRDL ;NULL + PUSHJ P,CDPRDL ;FREE + JRST QCDRSY ;SYMBOL + JRST QCDRNM ;FIX + JRST QCDRNM ;EXTENDED NUMBER + JSR IVACDR,IVAACT ;INVOKE + PUSHJ P,CDPRDL ;GC-FORWARD + JRST QCDR3 ;SYMBOL-COMPONENT-FORWARD + JRST QCDR5 ;Q-FORWARD + PUSHJ P,CDPRDL ;FORWARD + JRST QCARMP ;MEM POINTER NOTE CAR!! + JRST QCAR3 ;LOCATIVE-TO-LIST. NOTE CAR!! + JRST QCAR3 ;LOCATIVE-INTO-STRUCTURE. NOTE CAR!! + JRST QCAR3 ;LOCATIVE-INTO-SYMBOL. NOTE CAR!! + JRST QCDR3 ;LIST + JRST QCDR3 ;LIST-INTO-STRUCTURE + JRST QCDR3 ;LIST-INTO-SYMBOL + PUSHJ P,CDPRDL ;U CODE ENTRY + PUSHJ P,CDPRDL ;MESA-ENTRY + JRST QCDR3 ;FEF (REALLY??? SHOULD BE ERROR??) + PUSHJ P,CDPRDL ;FEF HEADER + PUSHJ P,CDPRDL ;ARRAY HEADER + PUSHJ P,CDPRDL ;ARRAY POINTER + PUSHJ P,CDPRDL ;ARRAY LEADER + PUSHJ P,CDPRDL ;STACK-GROUP + JRST QCDR3 ;CLOSURE +REPEAT NQZUSD,PUSHJ P,CDPRDL + +; THIS USED TO BE ILLOP, BUT THIS IS BETTER FOR DEBUGGING +CDPRDL: BARF CDR OF BAD DATATYPE,T/& + + +;DISPATCH ON TAKING CDR OF SYMBOL +CDSYMD: QCDSYE ;ERROR + QCDSE1 ;ERROR EXCEPT (CDR 'NIL) = NIL + XFALSE ;NIL + QCDPRP ;PROPERTY LIST +NCDRSM==.-CDSYMD + +;DISPATCH ON TAKING CDR OF NUMBER +CDNUMD: QCDNME ;ERROR + XFALSE ;NIL + QCAR3 ;"WHATEVER IT IS" +NCDRNM==.-CDNUMD + +;DISPATCH ON DT OF WHAT WAS IN CAR POSITION-- GOING TO TAKE CDR THO. +CDCADT: JFCL ;TRAP + JFCL ;NULL + JFCL ;FREE + JFCL ;SYMBOL + JFCL ;FIX + JFCL ;EXTENDED NUMBER + JFCL ;INVOKE + JRST CDGCIV ;GC-FORWARD + JFCL ;SYMBOL-COMPONENT-FORWARD + JFCL ;Q-FORWARD + JRST CDEIV ;FORWARD + JFCL ;MEM POINTER + JFCL ;LOCATIVE-TO-LIST + JFCL ;LOCATIVE-INTO-STRUCTURE + JFCL ;LOCATIVE-INTO-SYMBOL + JFCL ;LIST + JFCL ;LIST-INTO-STRUCTURE + JFCL ;LIST-INTO-SYMBOL + JFCL ;U CODE ENTRY + JFCL ;MESA-ENTRY + JFCL ;FEF + JFCL ;FEF HEADER + JFCL ;ARRAY HEADER + JFCL ;ARRAY POINTER + JFCL ;ARRAY LEADER + JFCL ;STACK-GROUP + JFCL ;CLOSURE +REPEAT NQZUSD,JFCL + +;DISPATCH ON CDR CODE WHEN TAKING CDR +CDCDDT: JRST QCDFN ;FULL NODE + PUSHJ P,ILLOP ;CDR NOT + JRST QCDNIL + JRST QCDNXT + + +;DISP ON DATA TYPE OF POINTER-TO-SMASH-CONTENTS-OF WHEN DOING RPLACA +QRACDT: QRATR1 ;TRAP + QRATR1 ;NULL + QRATR3 ;FREE + QRASYM ;SYMBOL + QRANUM ;FIX + QRANUM ;EXTENDED NUMBER + QRATR2 ;INVOKE + QRATR1 ;GC-FORWARD + QRAR3 ;SYMBOL-COMPONENT-FORWARD + QRAR5 ;Q-FORWARD + QRATR1 ;FORWARD + QRARMP ;MEM POINTER + QRAR3 ;LOCATIVE-TO-LIST + QRAR3 ;LOCATIVE-INTO-STRUCTURE + QRAR3 ;LOCATIVE-INTO-SYMBOL + QRAR3 ;LIST + QRAR3 ;LIST-INTO-STRUCTURE + QRAR3 ;LIST-INTO-SYMBOL + QRATR1 ;U CODE ENTRY + QRATR1 ;MESA-ENTRY + QRAR3 ;FEF + QRATR1 ;FEF HEADER + QRATR1 ;ARRAY HEADER + QRAR3 ;ARRAY POINTER + QRATR1 ;ARRAY LEADER + QRATR1 ;STACK-GROUP + QRAR3 ;CLOSURE +REPEAT NQZUSD,QRATR1 + +;DISPATCH ON DOING RPLACA OF SYMBOL +RASYMD: QRASYE ;ERROR + QRASYE ;ALSO ERROR IF (CAR NIL) = NIL + QRASYE ;OR IF (CAR SYM) = NIL + QRAR3 ;SMASH P-STRING POINTER + +;DISPATCH ON DOING RPLACA OF NUMBER +RANUMD: QRANME ;ERROR + QRANME ;ERROR + QRAR3 ;SMASH "WHATEVER IT IS" + + + +;DISPATCH ON DATA TYPE OF POINTER-TO-SMASH-CONTENTS-OF WHEN DOING RPLACD +QRDCDT: QRDTR1 ;TRAP + QRDTR1 ;NULL + QRDTR3 ;FREE + QRDRSY ;SYMBOL + QRDRNM ;FIX + QRDRNM ;EXTENDED NUMBER + QRDTR2 ;INVOKE + QRDTR1 ;GC-FORWARD + QRDR3 ;SYMBOL-COMPONENT-FORWARD + QRDR5 ;Q-FORWARD + QRDTR1 ;FORWARD + QRARMP ;MEM POINTER + QRAR3 ;LOCATIVE-TO-LIST. NOTE CAR!! + QRAR3 ;LOCATIVE-INTO-STRUCTURE. NOTE CAR!! + QRAR3 ;LOCATIVE-INTO-SYMBOL. NOTE CAR!! + QRDR3 ;LIST + QRDR3 ;LIST-INTO-STRUCTURE + QRDR3 ;LIST-INTO-SYMBOL + QRDTR1 ;U CODE ENTRY + QRDTR1 ;MESA-ENTRY + QRDR3 ;FEF + QRDTR1 ;FEF HEADER + QRDTR1 ;ARRAY HEADER + QRDTR1 ;ARRAY POINTER + QRDTR1 ;ARRAY LEADER + QRDTR1 ;STACK-GROUP + QRDR3 ;CLOSURE +REPEAT NQZUSD,QRDTR1 + +;DISPATCH ON DOING RPLACD OF SYMBOL +RDSYMD: QRDSYE ;ERROR + QRDSYE ;ALSO ERROR IF (CDR NIL) = NIL + QRDSYE ;ALSO IF (CDR SYMBOL) = NIL + QRDPRP ;SMASH PROP LIST + +;DISPATCH ON DOING RPLACD OF NUMBER +RDNUMD: QRDNME ;ERROR + QRDNME ;ALSO ERROR IF (CDR NUMBER) = NIL + QRAR3 ;SMASH "WHATEVER IT IS" + +;DESTINATION CODE DISPATCH +QMDTBD: CPOPJ ;IGNORE + QMDDS ;TO STACK + QMDDN ;TO NEXT + QMDDL ;TO LAST + QMDDR ;TO RETURN + QMDDNQ ;TO NEXT "QUOTE =1" + QMDDLQ ;TO LAST "QUOTE =1" + QMDDNL ;TO NEXT LIST + + +;DISPATCH ON DESIRED DATA TYPE FOR ARG +QBDDT: QDTN ;NUMBER + QDTFXN ;FIXED NUMBER + QDTSYM ;SYMBOL + QDTATM ;ATOM + QDTLST ;LIST + QDTFRM ;FRAME +REPEAT 15.-<.-QBDDT>, QDTERR + + +;DISPATCH ON DESIRED EVAL/QUOTE STATUS FOR ARG +QBEQC: QBEQE ;DESIRED EVALUATED + QBEQQ ;DESIRED QUOTED + QBEQQ ;DESIRED BROKEN-OFF + +;DISPATCH ON "DESTINATION" FIELD OF QIND1 GROUP + +QINDT1: QIMVM + QIADD + QISUB + QIMUL + QIDIV + QIAND + QIXOR + QIIOR + + +;DISPATCH ON DATA TYPE OF THING STORING WITH MOVEM, ETC +QNDDT2: CPOPJ ;TRAP + CPOPJ ;NULL + CPOPJ ;FREE + QIMVM1 ;SYMBOL + QIMVM7 ;FIX + QIMVM7 ;EXTENDED NUMBER + CPOPJ ;INVOKE + CPOPJ ;GC-FORWARD + CPOPJ ;SYMBOL-COMPONENT-FORWARD + CPOPJ ;Q-FORWARD + CPOPJ ;FORWARD + CPOPJ ;MEM POINTER + CPOPJ ;LOCATIVE-TO-LIST + CPOPJ ;LOCATIVE-INTO-STRUCTURE + CPOPJ ;LOCATIVE-INTO-SYMBOL + CPOPJ ;LIST + CPOPJ ;LIST-INTO-STRUCTURE + CPOPJ ;LIST-INTO-SYMBOL + CPOPJ ;U CODE ENTRY + CPOPJ ;MESA-ENTRY + CPOPJ ;FEF + CPOPJ ;FEF HEADER + CPOPJ ;ARRAY HEADER + CPOPJ ;ARRAY PNTR + CPOPJ ;ARRAY LEADER + CPOPJ ;STACK-GROUP + CPOPJ ;CLOSURE +REPEAT NQZUSD,CPOPJ + +;SETZ BIT SET IF INHIBIT-XCT-NEXT IS SET IN DQMRCL REAL MACHINE. +; THIS IS THE CASE IF NO "LEAVE" TYPE OPERATION IS NECESSARY. +DQMRC1: 0 ;TRAP + 0 ;NULL + 0 ;FREE + SETZ ;SYMBOL + 0 ;FIX + 0 ;EXTENDED NUMBER + 0 ;INVOKE + SETZ ;GC-FORWARD + SETZ ;SYMBOL-COMPONENT-FORWARD + SETZ ;Q-FORWARD + 0 ;FORWARD + 0 ;MEM POINTER + 0 ;LOCATIVE-TO-LIST + 0 ;LOCATIVE-INTO-STRUCTURE + 0 ;LOCATIVE-INTO-SYMBOL + 0 ;LIST + 0 ;LIST-INTO-STRUCTURE + 0 ;LIST-INTO-SYMBOL + 0 ;UCODE ENTRY + 0 ;MESA ENTRY + 0 ;FEF + 0 ;FEF HEADER + SETZ ;ARRAY POINTER + 0 ;ARRAY-HEADER + 0 ;ARRAY LEADER + 0 ;STACK-GROUP + 0 ;CLOSURE +REPEAT NQZUSD,0 + +DQMRCL: PUSHJ P,ILLOP ;TRAP + PUSHJ P,ILLOP ;NULL + PUSHJ P,ILLOP ;FREE + PUSHJ P,QMRCL1 ;SYMBOL + PUSHJ P,ILLOP ;FIX + PUSHJ P,ILLOP ;EXTENDED NUMBER + JRST INTP1 ;INVOKE + PUSHJ P,QMRCL3 ;GC-FORWARD + PUSHJ P,QMRCL3 ;SYMBOL-COMPONENT-FORWARD + PUSHJ P,QMRCL3 ;Q-FORWARD + JRST INTP1 ;FORWARD + JRST INTP1 ;MEM POINTER + JRST INTP1 ;LOCATIVE-TO-LIST + JRST INTP1 ;LOCATIVE-INTO-STRUCTURE + JRST INTP1 ;LOCATIVE-INTO-SYMBOL + JRST INTP1 ;LIST + JRST INTP1 ;LIST-INTO-STRUCTURE + JRST INTP1 ;LIST-INTO-SYMBOL + JRST QME1 ;UCODE ENTRY + JRST QMESA1 ;MESA ENTRY + JRST QLENTR ;FEF + JRST INTP1 ;FEF HEADER + JRST QARYR ;ARRAY-POINTER + JRST INTP1 ;ARRAY-HEADER + JRST INTP1 ;ARRAY LEADER + JRST QSTKG1 ;STACK-GROUP + JRST QCLS ;CLOSURE +REPEAT NQZUSD,JRST INTP1 + +;PUSHJ P,ILLOP IF CANNOT BE LEGAL IN FUNCTION CONTEXT +ILLOBF: PUSHJ P,ILLOP ;TRAP + PUSHJ P,ILLOP ;NULL + PUSHJ P,ILLOP ;FREE + JFCL ;SYMBOL + PUSHJ P,ILLOP ;FIX + PUSHJ P,ILLOP ;EXTENDED NUMBER + JFCL ;INVOKE + JFCL ;GC-FORWARD + JFCL ;SYMBOL-COMPONENT-FORWARD + JFCL ;Q-FORWARD + JFCL ;FORWARD + JFCL ;MEM POINTER + JFCL ;LOCATIVE-TO-LIST + JFCL ;LOCATIVE-INTO-STRUCTURE + JFCL ;LOCATIVE-INTO-SYMBOL + JFCL ;LIST + JFCL ;LIST-INTO-STRUCTURE + JFCL ;LIST-INTO-SYMBOL + JFCL ;UCODE ENTRY + JFCL ;MESA ENTRY + JFCL ;FEF + PUSHJ P,ILLOP ;FEF HEADER + JFCL ;ARRAY POINTER + PUSHJ P,ILLOP ;ARRAY-HEADER + PUSHJ P,ILLOP ;ARRAY LEADER + JFCL ;STACK-GROUP + JFCL ;CLOSURE +REPEAT NQZUSD,PUSHJ P,ILLOP + +;DISPATCH ON ACTIVE FUNCTION TYPE WHEN PREPARING TO SWAP-OUT STACK GROUP. +; ROUTINE REACHED HERE SHOULD STORE AWAY ANY SPECIAL ACTIVE STATE INFO +; ASSOCIATED WITH THAT FLAVOR CODE (MACRO-PC, ETC). +SGSTR: PUSHJ P,ILLOP ;TRAP + PUSHJ P,ILLOP ;NULL + PUSHJ P,ILLOP ;FREE + PUSHJ P,ILLOP ;SYMBOL SHOULD HAVE BEEN SUBSTITUTED FOR BY NOW + PUSHJ P,ILLOP ;FIX + PUSHJ P,ILLOP ;EXTENDED NUMBER + PUSHJ P,ILLOP ;INVOKE + PUSHJ P,SSTRIV ;GC-FORWARD + PUSHJ P,SSTRIV ;SYMBOL-COMPONENT-FORWARD + PUSHJ P,ILLOP ;Q-FORWARD + PUSHJ P,ILLOP ;FORWARD + PUSHJ P,ILLOP ;MEM POINTER + PUSHJ P,ILLOP ;LOCATIVE-TO-LIST + PUSHJ P,ILLOP ;LOCATIVE-INTO-STRUCTURE + PUSHJ P,ILLOP ;LOCATIVE-INTO-SYMBOL + JFCL ;LIST, NO SPECIAL ACTION REQD + JFCL ;LIST-INTO-STRUCTURE, NO SPECIAL ACTION REQD + JFCL ;LIST-INTO-SYMBOL, NO SPECIAL ACTION REQD + JFCL ;UCODE ENTRY, NO SPECIAL ACTION REQD + PUSHJ P,ILLOP ;MESA-ENTRY + PUSHJ P,QLLV ;FEF, SAVE MACRO-PC, ETC + PUSHJ P,ILLOP ;FEF HEADER + JFCL ;ARRAY-POINTER + PUSHJ P,ILLOP ;ARRAY-HEADER + PUSHJ P,ILLOP ;ARRAY-LEADER + JFCL ;STACK-GROUP + PUSHJ P,ILLOP ;CLOSURE (SHOULD HAVE BEEN SUBSTITUTED FOR) +REPEAT NQZUSD,PUSHJ P,ILLOP + +;DISPATCH ON ACTIVE FUNCTION TYPE WHEN ABOUT TO RESUME STACK-GROUP. +; SHOULD RELOAD MODE SPECIFC INFO SUCH AS MACRO-PC. +SGLOD: PUSHJ P,ILLOP ;TRAP + PUSHJ P,ILLOP ;NULL + PUSHJ P,ILLOP ;FREE + PUSHJ P,ILLOP ;SYMBOL SHOULD HAVE BEEN SUBSTITUTED FOR BY NOW + PUSHJ P,ILLOP ;FIX + PUSHJ P,ILLOP ;EXTENDED NUMBER + PUSHJ P,ILLOP ;INVOKE + PUSHJ P,SSTRIV ;GC-FORWARD + PUSHJ P,SSTRIV ;SYMBOL-COMPONENT-FORWARD + PUSHJ P,ILLOP ;Q-FORWARD + PUSHJ P,ILLOP ;FORWARD + PUSHJ P,ILLOP ;MEM POINTER + PUSHJ P,ILLOP ;LOCATIVE-TO-LIST + PUSHJ P,ILLOP ;LOCATIVE-INTO-STRUCTURE + PUSHJ P,ILLOP ;LOCATIVE-INTO-SYMBOL + JFCL ;LIST, NO SPECIAL ACTION REQD + JFCL ;LIST-INTO-STRUCTURE, NO SPECIAL ACTION REQD + JFCL ;LIST-INTO-SYMBOL, NO SPECIAL ACTION REQD + JFCL ;UCODE ENTRY, NO SPECIAL ACTION REQD + PUSHJ P,ILLOP ;MESA-ENTRY + PUSHJ P,QLLENT ;FEF, RESTORE MACRO-PC, ETC + PUSHJ P,ILLOP ;FEF HEADER + JFCL ;ARRAY-POINTER + PUSHJ P,ILLOP ;ARRAY-HEADER + PUSHJ P,ILLOP ;ARRAY-LEADER + JFCL ;STACK-GROUP + PUSHJ P,ILLOP ;CLOSURE +REPEAT NQZUSD,PUSHJ P,ILLOP + +;DISPATCH ON FUNCTION TYPE WHEN SWAPPING OUT STACK GROUP +;SGSDSP: PUSHJ P,ILLOP ;TRAP +; PUSHJ P,ILLOP ;NULL +; PUSHJ P,ILLOP ;FREE +; JRST SGSSYM ;SYMBOL +; PUSHJ P,ILLOP ;FIX + ;EXTENDED NUMBER? +; JRST SGSIVK ;INVOKE +; JRST SGSIVZ ;GC INVZ +; JRST SGSIVZ ;E INVZ +; JRST SGSIVZ ;CC INVZ +; JRST SGSIVZ ;COMPONENT INVZ +; JRST SGSLST ;MEM POINTER +; JRST SGSLST ;LOCATIVE +; JRST SGSLST ;LOCATIVE +; JRST SGSLST ;LOCATIVE +; JRST SGSLST ;LIST +; JRST SGSLST ;LIST +; JRST SGSLST ;LIST +; JRST SGSUCE ;UCODE ENTRY +; JRST SGSMSE ;MESA-ENTRY +; JRST SGSFRM ;FRAME + ;FEF HEADER? +; JRST SGSARP ;ARRAY-POINTER +; PUSHJ P,ILLOP ;ARRAY-HEADER +; PUSHJ P,ILLOP ;ARRAY LEADER +; JRST SGSSG ;STACK-GROUP + ;CLOSURE? +;REPEAT NQZUSD,PUSHJ P,ILLOP + +;DISPATCH ON FUNCTION TYPE WHEN SWAPPING IN STACK GROUP +;SGRDSP: PUSHJ P,ILLOP ;TRAP +; PUSHJ P,ILLOP ;NULL +; PUSHJ P,ILLOP ;FREE +; JRST SGRSYM ;SYMBOL +; PUSHJ P,ILLOP ;FIX + ;EXTENDED NUMBER? +; JRST SGRIVK ;INVOKE +; JRST SGRIVZ ;GC INVZ +; JRST SGRIVZ ;E INVZ +; JRST SGRIVZ ;CC INVZ +; JRST SGRIVZ ;COMPONENT INVZ +; JRST SGRLST ;MEM POINTER +; JRST SGRLST ;LOCATIVE +; JRST SGRLST ;LOCATIVE +; JRST SGRLST ;LOCATIVE +; JRST SGRLST ;LIST +; JRST SGRLST ;LIST +; JRST SGRLST ;LIST +; JRST SGRUCE ;UCODE ENTRY +; JRST SGRMSE ;MESA-ENTRY +; JRST SGRFRM ;FRAME + ;FEF HEADER? +; JRST SGSARP ;ARRAY POINTER +; PUSHJ P,ILLOP ;ARRAY-HEADER +; PUSHJ P,ILLOP ;ARRAY LEADER +; JRST SGRSG ;STACK-GROUP + ;CLOSURE? +;REPEAT NQZUSD,PUSHJ P,ILLOP + +;DISPATCH ON FUNCTION TYPE WHEN RETURNING FROM QMEX1 +QMXRT: ILLOP ;TRAP + ILLOP ;NULL + ILLOP ;FREE + ILLOP ;SYMBOL + ILLOP ;FIX + ILLOP ;EXTENDED NUMBER + ILLOP ;INVOKE + QMMRI ;GC-FORWARD + QMMRI ;SYMBOL-COMPONENT-FORWARD + ILLOP ;Q-FORWARD + ILLOP ;FORWARD + ILLOP ;MEM-POINTER + ILLOP ;LOCATIVE-TO-LIST + ILLOP ;LOCATIVE-INTO-STRUCTURE + ILLOP ;LOCATIVE-INTO-SYMBOL + QMMRL ;LIST + QMMRL ;LIST-INTO-STRUCTURE + QMMRL ;LIST-INTO-SYMBOL + QMMR2 ;UCODE-ENTRY + ILLOP ;MESA-ENTRY + QMEXF ;FEF + ILLOP ;FEF HEADER + ILLOP ;ARRAY-POINTER + ILLOP ;ARRAY-HEADER + ILLOP ;ARRAY-LEADER + ILLOP ;STACK-GROUP + ILLOP ;CLOSURE +REPEAT NQZUSD,ILLOP + +;DISPATCH ON FUNCTION TYPE WHEN RETURNING FROM QBARY2 +QMXRT1: ILLOP ;TRAP + ILLOP ;NULL + ILLOP ;FREE + ILLOP ;SYMBOL + ILLOP ;FIX + ILLOP ;EXTENDED NUMBER + ILLOP ;INVOKE + ILLOP ;GC-FORWARD + ILLOP ;SYMBOL-COMPONENT-FORWARD + ILLOP ;Q-FORWARD + ILLOP ;FORWARD + ILLOP ;MEM POINTER + ILLOP ;LOCATIVE-TO-LIST + ILLOP ;LOCATIVE-INTO-STRUCTURE + ILLOP ;LOCATIVE-INTO-SYMBOL + ILLOP ;LIST + ILLOP ;LIST-INTO-STRUCTURE + ILLOP ;LIST-INTO-SYMBOL + QBARY2 ;UCODE-ENTRY + ILLOP ;MESA-ENTRY + QBARY1 ;FEF + ILLOP ;FEF HEADER + ILLOP ;ARRAY-POINTER + ILLOP ;ARRAY-HEADER + ILLOP ;ARRAY LEADER + ILLOP ;STACK-GROUP + ILLOP ;CLOSURE +REPEAT NQZUSD,ILLOP + +;DISPATCH ON FUNCTION TYPE WHEN MUNGING IT AT XTHROW +THRWD1: ILLOP ;TRAP + ILLOP ;NULL + ILLOP ;FREE + ILLOP ;SYMBOL + ILLOP ;FIX + ILLOP ;EXTENDED NUMBER + ILLOP ;INVOKE + XTHWI1 ;GC-FORWARD + XTHWI1 ;SYMBOL-COMPONENT-FORWARD + ILLOP ;Q-FORWARD + ILLOP ;FORWARD + ILLOP ;MEM POINTER + ILLOP ;LOCATIVE-TO-LIST + ILLOP ;LOCATIVE-INTO-STRUCTURE + ILLOP ;LOCATIVE-INTO-SYMBOL + ILLOP ;LIST + ILLOP ;LIST-INTO-STRUCTURE + ILLOP ;LIST-INTO-SYMBOL + XTHWU1 ;UCODE ENTRY + ILLOP ;MESA ENTRY + XTHWM1 ;FEF + ILLOP ;FEF HEADER + ILLOP ;ARRAY POINTER + ILLOP ;ARRAY-HEADER + ILLOP ;ARRAY-LEADER + ILLOP ;STACK-GROUP + ILLOP ;CLOSURE +REPEAT NQZUSD,ILLOP + +;DISPATCH ON FUNCTION WHEN UNWINDING IT AT XTHROW +THRWD2: ILLOP ;TRAP + ILLOP ;NULL + ILLOP ;FREE + ILLOP ;SYM + ILLOP ;FIX + ILLOP ;EXTENDED NUMBER + ILLOP ;INVOKE + XTHWI2 ;GC-FORWARD + XTHWI2 ;SYMBOL-COMPONENT-FORWARD + ILLOP ;Q-FORWARD + ILLOP ;FORWARD + ILLOP ;MEM POINTER + ILLOP ;LOCATIVE-TO-LIST + ILLOP ;LOCATIVE-INTO-STRUCTURE + ILLOP ;LOCATIVE-INTO-SYMBOL + XTHWL2 ;LIST + XTHWL2 ;LIST-INTO-STRUCTURE + XTHWL2 ;LIST-INTO-SYMBOL + XTHWU2 ;UCODE ENTRY + ILLOP ;MESA ENTRY + XTHWM2 ;FRAME + ILLOP ;FEF HEADER + ILLOP ;ARRAY POINTER + ILLOP ;ARRAY HEADER + ILLOP ;ARRAY-LEADER + ILLOP ;STACK-GROUP + ILLOP ;CLOSURE +REPEAT NQZUSD,ILLOP + +;DISPATCH ON FUNCTION TYPE WHEN RE-ENTERING FRAME AT XTHROW +THRWD3: ILLOP ;TRAP + ILLOP ;NULL + ILLOP ;FREE + ILLOP ;SYM + ILLOP ;FIX + ILLOP ;EXTENDED NUMBER + ILLOP ;INVOKE + XTHWI3 ;GC-FORWARD + XTHWI3 ;SYMBOL-COMPONENT-FORWARD + ILLOP ;Q-FORWARD + ILLOP ;FORWARD + ILLOP ;MEM POINTER + ILLOP ;LOCATIVE-TO-LIST + ILLOP ;LOCATIVE-INTO-STRUCTURE + ILLOP ;LOCATIVE-INTO-SYMBOL + XTHWL3 ;LIST + XTHWL3 ;LIST-INTO-STRUCTURE + XTHWL3 ;LIST-INTO-SYMBOL + XTHWU3 ;UCODE ENTRY + ILLOP ;MESA ENTRY + XTHWM3 ;FEF + ILLOP ;FEF HEADER + ILLOP ;ARRAY POINTER + ILLOP ;ARRAY HEADER + ILLOP ;ARRAY-LEADER + ILLOP ;STACK-GROUP + ILLOP ;CLOSURE +REPEAT NQZUSD,ILLOP + +;SKIP (IE NON-ZERO) IF LIST +SKPLST: 0 ;TRAP + 0 ;NULL + 0 ;FREE + 0 ;SYMBOL + 0 ;FIX + 0 ;EXTENDED NUMBER + 0 ;INVOKE + 0 ;GC-FORWARD + 0 ;SYMBOL-COMPONENT-FORWARD + 0 ;Q-FORWARD + 0 ;FORWARD + 0 ;MEM POINTER + 0 ;LOCATIVE-TO-LIST + 0 ;LOCATIVE-INTO-STRUCTURE + 0 ;LOCATIVE-INTO-SYMBOL + SETZ ;LIST + SETZ ;LIST-INTO-STRUCTURE + SETZ ;LIST-INTO-SYMBOL + 0 ;UCODE ENTRY + 0 ;MESA ENTRY + 0 ;FEF + 0 ;FEF HEADER + 0 ;ARRAY POINTER + 0 ;ARRAY-HEADER + 0 ;ARRAY LEADER + 0 ;STACK-GROUP + 0 ;CLOSURE +REPEAT NQZUSD,0 + +;DISPATCH ON "DESTINATION" OF QIND2 GROUP +QINDT2: QIEQ + QIGRP + QILSP + QIPOP + QISCDR + QSCDDR + QISP1 + QISM1 + + + +;DISPATCH ON "DESTINATION" OF QIND3 GROUP +QINDT3: QIBND + QIBNDN + QIBNDP + QISETN + QISETZ + QIPSHE + QIERR + QIERR + +;DISPATCH ON "DESTINATION" FIELD OF BRANCH +BRDTAB: QBRALW + QBRNL + QBRNNL + QBRNLP + QBRNNP + QBRAT + QBRNAT + QIERR + + + +QARYDT: QBAERR + QB1RY ;BIT ARRAY + QB2RY ;2 BIT ARRAY + QB4RY ;4 BIT ARRAY + QBARY ;8 BIT ARRAY + QB16RY ;16 BIT ARRAY + QQARY ;32 BIT ARRAY + QQARY ;Q ARRAY + QQARY ;LIST Q ARRAY + QBARY ;STRING ARRAY + QQARY ;STACK-GROUP HEAD + QQARY ;SPECIAL-PDL ARRAY + QBAERR ;TV BUFFER (NOT SUPPORTED) + QQARY ;REG-PDL ARRAY +REPEAT 32.-<.-QARYDT>, QBAERR + +QSADT: QSAERR + QS1RY ;BIT ARRAY + QS2RY ;2 BIT ARRAY + QS4RY ;4 BIT ARRAY + QSBARY ;8 BIT ARRAY + QS16RY ;16 BIT ARRAY + QS32RY ;32 BIT ARRAY + QS32RY ;Q ARRAY + QSQARY ;LIST Q ARRAY + QSBARY ;BYTE ARRAY + QS32RY ;STACK-GROUP HEAD + QS32RY ;SPECIAL-PDL + QSAERR ;TV BUFFER (NOT SUPPORTED) + QS32RY ;REG-PDL +REPEAT 32.-<.-QSADT>, QSAERR + +;DISPATCH ON ARRAY TYPE AT XFARY +XFADT1: XFAERR + QS1RY ;BIT ARRAY + QS2RY ;2 + QS4RY ;4 + QSBARY ;8 + QS16RY ;16 + QS32RY ;32 + QSQARY ;Q ARRAY + XFALAR ;LIST -- SPECIAL HACKERY WITH CDR CODES TO EXTEND "LIST" + QSBARY ;BYTE + QS32RY ;STACK-GROUP HEAD + QS32RY ;SPECIAL-PDL + XFAERR ;TV BUFFER (NOT SUPPORTED) + QS32RY ;REG-PDL +REPEAT 32.-<.-XFADT1>, XFAERR + +;ENTRIES PER Q (THIS DOESNT REALLY GO IN DISPATCH MEMORY) +ENTPQ: 0 + 32. ;BIT ARRAY + 16. ;2 + 8 ;4 + 4 ;8 + 2 ;16 + 1 ;32 + 1 ;Q + 1 ;LIST + 4 ;BYTE + 1 ;STACK-GROUP HEAD + 1 ;SPECIAL PDL + 16. ;TV BUFFER + 1 ;REG-PDL + +;Q TO USE TO FILL OUT TO ARRAY IF IT IS LARGER THAN FROM ARRAY ON COPY +XCFILL: 0 ;ERROR + 0 ;BIT ARRAY + 0 ;2 + 0 ;4 + 0 ;8 + 0 ;16 + 0 ;32 + QZSYM_5,, ;Q + QZSYM_5,, ;LIST + 200_24.+200_16.+200_8+200 ;BYTE (STRING) - 4 NULLS + 0 ;STACK-GROUP HEAD + 0 ;SPECIAL-PDL + 0 ;TV BUFFER + 0 ;REG-PDL + +;INTERPRETER SUPPORT + +ITRAP: BARF [HALT AT ITRAP. WHAT IS THIS, ANYWAY?] + +;PDL PRINTER + +ACSAV: 0 + MOVEM 17,PPACS+17 + MOVEI 17,PPACS + BLT 17,PPACS+16 + MOVEI P,PPPDL + JRST @ACSAV + +ACREST: 0 + MOVSI 17,PPACS + BLT 17,17 + JRST @ACREST + +P...: SQUOZE 0,. + 0 + +IF2, P.=PUSHJ P,P.. ;PRINT CONTENTS OF . + +P..: JSR ACSAV + .BREAK 12,[4,,P...] + SKIPA T,@P...+1 +PT: JSR ACSAV ;PRINT T + PUSHJ P,PQ + JSR ACREST + POPJ P, + +PP: PUSHJ P,PP0 ; FOR COMPATIBILITY WITH OLD PP$G + .VALUE + +IF2, PP.=PUSHJ P,PP0 + +PP0: JSR ACSAV + HRRZ R,QLPDLO ;INITIAL IP + LDB Q,[%LPCAD,,LPCLS(AP)] + MOVNS Q + ADDI Q,(AP) + MOVEM Q,PPFRMM ;"FRAME MARK" + HRRZ Q,IPMARK + CAIL Q,(IP) + HRRZ Q,AP + MOVEM Q,PPIFRM ;MARK TO PREV OPEN CALL +PPL1: CAIL R,(IP) + JRST PPX + HRRZ J,IP + CAIN J,(AP) + SOUT [ASCIZ / -AP- /] + CAMN J,PPIFRM + JRST [SOUT [ASCIZ / -OC- /] + LDB Q,[%LPCPN,,LPCLS(J)] + MOVNS Q + ADDI Q,(J) + MOVEM Q,PPIFRM + JRST .+1] + CAMN J,PPFRMM + JRST [SOUT [ASCIZ / -FRAME- /] + LDB Q,[%LPCAD,,LPCLS(J)] + MOVNS Q + ADDI Q,(J) + MOVEM Q,PPFRMM + JRST .+1] + POP IP,T + PUSHJ P,PQ + PUSHJ P,CRR + JRST PPL1 + + +PPX: MOVE J,PPFRMM + CAME J,PPIFRM + SOUT [ASCIZ /FRAME MARKS DIFFER!! +/] + JSR ACREST + POPJ P, + + + +PQ: LDB A,[%NDTB,,T] + SOUT @DTTAB(A) + JRST @PQDT(A) + +DTTAB: [ASCIZ /TRAP /] + [ASCIZ /NULL /] + [ASCIZ /FREE /] + [ASCIZ /SYMBOL /] + [ASCIZ /FIX /] + [ASCIZ /EXTENDED-NUMBER /] + [ASCIZ /INVOKE /] + [ASCIZ /GC-FORWARD /] + [ASCIZ /SYMBOL-COMPONENT-FORWARD /] + [ASCIZ /Q-FORWARD /] + [ASCIZ /FORWARD /] + [ASCIZ /MEM POINTER /] + [ASCIZ /LOCATIVE-TO-LIST /] + [ASCIZ /LOCATIVE-INTO-STRUCTURE /] + [ASCIZ /LOCATIVE-INTO-SYMBOL /] + [ASCIZ /( /] + [ASCIZ /LIST-INTO-STRUCTURE( /] + [ASCIZ /LIST-INTO-SYMBOL( /] + [ASCIZ /U ENTRY /] + [ASCIZ /MESA-ENTRY /] + [ASCIZ /FEF /] + [ASCIZ /FEF HEADER /] + [ASCIZ /ARRAY POINTER /] + [ASCIZ /ARRAY HEAD /] + [ASCIZ /ARRAY LEADER /] + [ASCIZ /STACK-GROUP /] + [ASCIZ /CLOSURE( /] +REPEAT NQZUSD, [.ASCII /DTP !.-DTTAB /] + +PQDT: PQFIX ;TRAP + PSYM ;NULL + PQFIX ;FREE + PSYM ;SYMBOL + PQFIX ;FIX + PQFIX ;EXTENDED NUMBER + PQFIX ;INVOKE + PINVZ ;GC-FORWARD + PINVZ ;SYMBOL-COMPONENT-FORWARD + PINVZ ;Q-FORWARD + PINVZ ;FORWARD + PMEMP ;MEMORY POINTER + PLOCA ;LOCATIVE-TO-LIST + PLOCA ;LOCATIVE-INTO-STRUCTURE + PLOCA ;LOCATIVE-INTO-SYMBOL + PQLIST ;LIST + PQLIST ;LIST-INTO-STRUCTURE + PQLIST ;LIST-INTO-SYMBOL + PUENT ;U CODE ENTRY + PQFIX ;MESA-ENTRY + PQFRM ;FRAME (FEF) + PQFIX ;FEF HEADER + PQARY ;ARRAY POINTER + PHEAD ;ARRAY HEADER + PQFIX ;ARRAY LEADER + PQFIX ;STACK-GROUP + PQLIST ;CLOSURE +REPEAT NQZUSD,PQFIX + + +PQLIS0: SOUT [ASCIZ/, /] +PQLIST: PUSH P,T + MOVE T,MEM(T) + PUSHJ P,PQ + POP P,T + PUSHJ P,QCDR + LDB A,[%NDTB,,T] + SKIPE SKPLST(A) + JRST PQLIS0 + TDNN T,[37,,-1] + JRST PQLIS1 + SOUT [ASCIZ/ . /] + PUSHJ P,PQ +PQLIS1: SOUT [ASCIZ/ )/] + POPJ P, + +PHEAD: LDB A,[%ARYTP,,T] + SOUT @PARTDT(A) + TDNE T,[ARXIB] + SOUT [ASCIZ/(HAS LEADER) /] + TDNE T,[ARDSPB] + SOUT [ASCIZ/(DISPLACED) /] + LDB I,[%ARYND,,T] + PUSHJ P,OCTP + SOUT [ASCIZ/ DIMENSIONS /] + TRNE T,ARYEXL + JRST [ SOUT [ASCIZ /ENTENDED /] + JRST PHEAD2] + LDB I,[%ARYL,,T] +PHEAD1: PUSHJ P,OCTP + SOUT [ASCIZ/ INDEX-LENGTH/] +PHEAD2: POPJ P, + +PARTDT: [ASCIZ /ART-ERROR /] + [ASCIZ /ART-1B /] + [ASCIZ /ART-2B /] + [ASCIZ /ART-4B /] + [ASCIZ /ART-8B /] + [ASCIZ /ART-16B /] + [ASCIZ /ART-32B /] + [ASCIZ /ART-Q/] + [ASCIZ /ART-Q-LIST /] + [ASCIZ /ART-STRING /] + [ASCIZ /ART-STACK-GROUP-HEAD /] + [ASCIZ /ART-SPECIAL-PDL /] + [ASCIZ /ART-TVB /] + [ASCIZ /ART-REG-PDL /] +REPEAT , [.ASCII /ART !.-PARTDT /] + +PUENT: HRRZS T + HRRZ ZR,AMCENT + CAML T,ZR + JRST PSYME + MOVE T,MEVECN(T) + JRST PSYM + +PMEMP: SUBI T,MEM +PLOCA: MOVE T,MEM(T) +PLIST: MOVEI D,3 + MOVEI E,3 + POPJ P, + + +PINVZ: SOUT [ASCIZ/ --> /] + MOVE T,MEM(T) + JRST PQ + +PQARY: LDB B,[%ARYTP,,MEM(T)] + CAIE B,ARTSTR + JRST PQFIX + SOUT [ASCIZ /"/] + MOVE B,T + PUSHJ P,PSTRNG + SOUT [ASCIZ /"/] + POPJ P, + +PQFIX: TLZ T,777740 + TLNE T,20 + TLO T,777740 + MOVE I,T +OCTP: JUMPGE I,OCTP1 + MOVNS I + SOUT [ASCIZ /-/] +OCTP1: IDIVI I,10 + HRLM J,(P) + SKIPE I + PUSHJ P,OCTP1 + HLRZ A,(P) + ADDI A,"0 +MTYO: .IOT TYOC,A + POPJ P, + +CRR: MOVEI A,15 + PUSHJ P,MTYO + MOVEI A,12 + JRST MTYO + +PSYM: MOVE B,MEM(T) + LDB ZR,[%NDTB,,B] + CAIE ZR,QZARYP + JRST PSYME +PSTRNG: MOVE ZR,MEM(B) + LDB C,[%ARYL,,ZR] + TRNE ZR,ARYEXL + LDB C,[%NPTR,,MEM+1(B)] + HRLI B,001000 + ADDI B,MEM+1 + TRNE ZR,ARYEXL + AOS B +PSYML: LDB A,B + CAIE A,200 ;DON'T PRINT NULLS + PUSHJ P,MTYO + ADD B,[100000,,] ;"INCREMENT" BYTE PNTR + TLZE B,400000 ;IF UP TO 40 BITS OVER, GO TO NEXT WORD + AOS B + SOJG C,PSYML + POPJ P, + +PSYME: SOUT [ASCIZ /BAD /] + POPJ P, + + +PQFRM: LDB A,[%FRMDT,,MEM(T)] + CAIL A,NVFTP + JRST PSYME + SOUT @FTTBL(A) + JRST @FTDSP(A) + +FTTBL: [ASCIZ /ERR /] + [ASCIZ /PDL /] + [ASCIZ /ARG /] + [ASCIZ /FEF /] + +FTDSP: CPOPJ + CPOPJ + CPOPJ + FTFEF +NVFTP==.-FTDSP + +FTFEF: MOVE T,QFEFN+MEM(T) + JRST PSYM + +PEVEC: MOVEI D,0 +PEVEC1: HRRZ ZR,AMCENT + CAML D,ZR + POPJ P, + MOVE T,MEVECN(D) + PUSHJ P,PSYM + TRNN D,3 + PUSHJ P,CRR + TRNE D,3 + SOUT [ASCIZ / /] + AOJA D,PEVEC1 + +PC...: 0 + SQUOZE 0,. + +IF2, PC.=PUSHJ P,P.. + +PC..: JSR ACSAV + .BREAK 12,[4,,PC...] + MOVE T,PC...+1 + PUSHJ P,PCP0 + JSR ACREST + POPJ P, + +PCP: MOVEM 16,SAC1+16 ;SAVE ALL AC S + MOVEI 16,SAC1 + BLT 16,SAC1+15 + PUSHJ P,PCP0 + MOVSI 16,SAC1 + BLT 16,16 + POPJ P, + +SAC1: BLOCK 17 + +PQSAC: MOVEM 16,SAC1+16 ;PQ SAVE ACS + MOVEI 16,SAC1 + BLT 16,SAC1+15 + PUSHJ P,PQ + MOVSI 16,SAC1 + BLT 16,16 + POPJ P, + + +PCP0: HRRZS T ;PRINT PC IN T + CAIGE T,MEM + JRST [MOVEI B,[ASCIZ /SIMULATOR PC /] + CAIN T,QRAD3 + MOVEI B,[ASCIZ /MULTI-VALUE-RETURN /] + CAIN T,QMER + MOVEI B,[ASCIZ /MACRO-MICRO-RETURN /] + SOUT (B) + JRST PCPX] + MOVNI B,1 + MOVEI C,0 + MOVEI D,0 +PCP1: HRRZ ZR,AMCENT + CAML D,ZR + JRST PCP2 + HRRZ ZR,MEVEC(D) + CAMG ZR,T + CAMG ZR,C + AOJA D,PCP1 + MOVE B,MEVECN(D) + MOVE C,ZR + AOJA D,PCP1 + +PCP2: JUMPL B, [SOUT [ASCIZ /LOW PC!!/] + JRST PCPX] + MOVE T,B + PUSHJ P,PSYM +PCPX: PUSHJ P,CRR + POPJ P, + + +PLBP: JSR ACSAV + HRRZ C,QLBNDP +PLBP1: CAMG C,QLBNDO + JRST STKP3 + MOVE T,(C) + TLNE T,NUSRCB + SOUT [ASCIZ /L-P-BLOCK /] + PUSHJ P,PQSAC + PUSHJ P,CRR + SOJA C,PLBP1 + +IF2, STACKP=PUSHJ P,STKP0 + +STKP0: JSR ACSAV ;PRINT OUT STACK CALLS (BOTH MICRO AND MACRO) + HRRZ J,PPACS+P + SOS J ;COMPENSATE FOR PUSHJ P,STKP0 + HRRZ S,QLBNDP + HRRZ Q,PPACS+AP + LDB ZR,[%NDTB,,(Q)] ;GET FCTN POINTER FOR CURRENTLY RUNNING FCTN + CAIE ZR,QZFEFP + JRST STKP2 + TLNE PC,QBBFL ;FOR U CODE BLOCK, THIS BIT ONLY MEANS BLOCK IS + PUSHJ P,STKLPS ;"OPEN". PPBSPC BIT WILL INDICATE EXISTANCE. +STKP2: CAIG J,PDL ;FIRST PRINT OUT THE "CURRENTLY RUNNING FRAME" + JRST STKP1 ;THRU WITH THAT, NOW FOR THE REST.. + SOUT [ASCIZ /P-STACK /] + MOVE T,(J) + TLNE T,PPBSPC + PUSHJ P,STKLPS ;SPACE OVER LINEAR PDL BLOCK PUSHED HERE + PUSHJ P,PCP + SOJA J,STKP2 + + +STKLPS: CAMG S,QLBNDO + JRST [ SOUT [ASCIZ /REACHED TOP OF BINDING STACK +/] + POPJ P,] + LDB ZR,[%NDTB,,(S)] ;SPACE OVER BINDING TYPE LINEAR PDL BLOCK + CAIE ZR,QZXSYM + SOUT [ASCIZ /BAD DT ON LINEAR PDL IN BINDING BLOCK +/] + MOVE ZR,-1(S) + SUBI S,2 + TLNN ZR,NUSRCB + JRST STKLPS + POPJ P, + + +STKP1: HRRZ J,PPACS+AP ;STATE OF WORLD "AS IF" AT QMDDR J CORRESPONDS TO AP + +STKP4: HRRZ ZR,QLPDLO + CAML ZR,J + JRST STKP3 ;THRU + SOUT [ASCIZ /IP-STACK-FRAME /] + MOVE T,LPFEF(J) + PUSHJ P,PQSAC + PUSHJ P,CRR + MOVE B,LPCLS(J) + LDB Q,[%LPCAD,,B] ;GET POINTER TO PREV IP FRAME + JUMPE Q,STKP3 + MOVNS Q + ADDI Q,(J) + MOVE A,LPFEF(Q) +STKP4A: LDB ZR,[%NDTB,,A] +; CAIE ZR,QZIVGC +; CAIN ZR,QZIVCE +; JRST [MOVE A,MEM(A) +; JRST STKP4A] + CAIN ZR,QZUENT + JRST STKPM + CAIE ZR,QZFEFP + SOUT [ASCIZ /BAD DATA TYPE FRAME FEF Q/] + JRST STKP5A + +STKPM:; CAIE ZR,QZUENT +; SOUT [ASCIZ /BAD DATA TYPE IN MICRO-CODE FRAME /] + SOUT [ASCIZ /EXIT-MICRO-PC /] + LDB T,[%LPMPC,,LPEXS(Q)] + PUSHJ P,PCP + PUSHJ P,CRR + LDB B,[%LPNWP,,LPENS(Q)] + JUMPE B,STKP5A +STKP6: MOVE E,(S) + LDB ZR,[%NDTB,,E] + CAIE ZR,QZFIX + SOUT [ASCIZ /BAD DT ON LINEAR PDL IN P XFER AREA +/] + PUSH P,E + SOS S + SOJG B,STKP6 + LDB B,[%LPNWP,,LPENS(Q)] +STKP7: POP P,T + TLNE T,PPBSPC + PUSHJ P,STKLPS + SOUT [ASCIZ /XFERRED P /] + PUSHJ P,PCP + SOJG B,STKP7 + JRST STKP5 ;FOR A U-CODE BLOCK, LPEBFL ONLY MEANS BLOCK IS "OPEN" + ;ITS EXISTANCE IS INDICATED BY A PPBSPC BIT +STKP5A: MOVE ZR,LPEXS(Q) + TLNE ZR,(LPEBFL) + PUSHJ P,STKLPS ;FCTN THAT EXITED DID LINEAR BIND, FLUSH IT +STKP5: +IFN FNASW,[ + MOVE ZR,LPCLS(Q) + TLNE ZR,(LPFNAB) + JRST [ SOUT [ASCIZ /CLOSURE BINDING L-P-BLOCK/] + PUSHJ P,STKLPS + JRST .+1] +] + MOVE J,Q + JRST STKP4 + +STKP3: JSR ACREST + POPJ P, + + +UUOH: 0 + PUSH P,A + LDB A,[331100,,40] + CAIE A,SOUT_<-9-18.> + .VALUE + HRRZ A,40 + HRLI A,440700 + MOVEM A,PPTEM +PPULP: ILDB A,PPTEM + JUMPE A,[ POP P,A + JRST 2,@UUOH] + PUSHJ P,MTYO + JRST PPULP + + +PPTEM: 0 +PPFRMM: 0 ;FRAME MARK +PPIFRM: 0 ;OPEN CALL FRAME MARK +VTRACE: 0 ;IF -1 TRACE VALUES AT QMEX1 +PPPDL: BLOCK 100 ;PDL WHILE PP HACKING + +PPACS: BLOCK 20 + + + +;MESA CODE STUFF + +;MESA-FEF +MFFN==0 ;FCTN NAME +MFFSO==1 .SEE QFRFSO ;"FAST OPTION" Q +MFMSC==2 ;MISC FIELDS + %MFPDU==171000,,; MAX DEPTH PDL USED + %MFSTU==001700,,; TOTAL STORAGE USED (FOR FEF+MESA-CODE) IN QS +MFETP==3 ;EXIT TABLE POINTER + +MFLEN==4 ;LENGTH OF MESA FEF + +;MESA ORDER CODE (APPREVIATED DESCRIPTION, SEE LISPM; MESA > FOR MORE DETAIL +%MSOP==130500,, ;5 BIT OP CODE +M%EXTP==2000 ;IF SET IN ADDRESS, MEANS THIS AN EXIT TABLE ADDRESS + M%INDR==1000 ;IF M%EXTP, INDIRECT BIT (THIS BIT IS REALLY REDUNDANT..) + %MEXD==1100,, ;IF M%EXTP, GIVES DELTA FROM EXIT VECTOR + +M%PIM==1600 ;IF NOT M%EXTP AND THESE BITS GIVE ADDRESS TYPE +%MPIM==.BP M%PIM +M%AMD==177 ;ARGUMENT/DISPLACEMENT +%MAMD==.BP M%AMD +;ADDRESS MODES (VALUES FOR M%PIM) + MATXIP==1 ;-N(IP) + MATCP==2 ;CONSTANTS PAGE + MATSPL==3 ;"SPECIAL" ADDRESSES + MSREGT==0 ; ADDRESSES T + MSTPIP==1 ; TOP-IP-AND-POP-IP + MSXT==2 ; (T) +;BRANCH FIELDS + %MSBTP==110300,, ;BRANCH TYPE (NOTE OVERLAPS LOW BIT OF OP CODE) + M%SBDS==777 ;BRANCH DELTA + %MSBDS==.BP M%SBDS + M%BDSG=400 ;SIGN BIT OF BRANCH DELTA + +;MISC GROUPS + %MSMS1==110200,, ;MISC GROUP 1 SUB OP + %MSMS2==60500,, ;MISC GROUP 2 SUB OP + %MSM2A==600,, ; BP TO MISC GROUP 2 ARG FIELD + +;MESA CALLING CONVENTIONS: +; THERE ARE TWO DISTINCT CASES: +; 1) A MESA-TO- CALL - INVOKED BY THE MESA CALL AND CALL-T +; INSTRUCTIONS +; 2) A MESA-TO-MACRO CALL - INVOKED BY A P3ZERO FOLLOWED BY AN +; ACTIVATE-CALL-BLOCK + +; CASE 1: +; A MESA-LEAVE BLOCK IS PUSHED ON THE LINEAR-BINDING-PDL +; AND A RETURN TO THE MESA INTERPRETER IS ALSO LEFT ON THE P STACK. +; THE MESA-LEAVE BLOCK CONSISTS OF TWO Q S. +; 1) THE MESA-FEF POINTER +; 2) THE MESA RESTART PC +; IF ADI IS PRESENT, THE PPBMIA BIT IN THE PDL RETURN WILL BE SET, +; THIS BEING COMPLETELY COMPATABLE WITH ADI ON A MICRO-TO-MICRO CALL. +; CASE 2: +; THE GENERAL OPERATION IS SIMILIAR TO A MICRO-TO-MACRO CALL +; FROM INSIDE THE MESA INTERPRETER. A MESA-LEAVE BLOCK IS ALSO +; PUSHED TO PERMIT THE MESA INTERPRETER TO RESUME WHEN IT GETS RETURNED TO. + + +;DURING THE EXECUTION OF MESA-CODE, R CONTAINS THE EXIT TABLE POINTER AND +; Q THE MESA-FEF POINTER. AT TIME OF MAIN DISPATCH ON INSTRUCTION, +; S HAS C(E) AND B HAS E. + +MSML: MOVE A,MEM(PC) ;MESA INTERPRETER MAIN LOOP. FETCH PC + JUMPL PC,MSML1B + TLO PC,400000 ;INCREMENT PC + ANDI A,177777 +MSML1A: MOVEM A,MSINST ;SAVE FOR DEBUGGING + LDB D,[%MSOP A] + PUSHJ P,@MSOPA(D) + JRST MSML + +MSML1B: ADD PC,[400000,,1] ;INCREMENT PC + LSH A,-16. + JRST MSML1A + +MCALCE: TRNN A,M%EXTP ;COMPUTE E OF CALL INST. (SAME AS USUAL, BUT + JRST MSCE1 ;MAY SET J + LDB B,[%MEXD A] + ADD B,R + MOVE S,MEM(B) + TRNN A,M%INDR + JRST @MSOPB(D) + MOVE J,MEM+1(B) ;# ARGS AND ADI FLAG + MOVE B,S + MOVE S,MEM(B) + JRST @MSOPB(D) + +MSCE: TRNN A,M%EXTP + JRST MSCE1 ;NOT EXIT VECTOR POINTER + LDB B,[%MEXD A] + ADD B,R ;R HAS EXIT VECTOR POINTER + MOVE S,MEM(B) + TRNN A,M%INDR ;SKIP ON INDIRECT + JRST @MSOPB(D) ;B HAS E, S HAS C(E) + MOVE B,S + MOVE S,MEM(B) + JRST @MSOPB(D) + +MSCE1: LDB E,[%MPIM A] ;ADDRESS TYPE + LDB B,[%MAMD A] ;"DISPLACEMENT/ARGUMENT" + JRST @MSADDT(E) + +MSCEIP: SUBM IP,B ;COMPUTE -X(IP) + MOVEI B,-MEM(B) + MOVE S,MEM(B) + JRST @MSOPB(D) + +MSCECP: ADDI B,QQTPG-MEM ;QUOTE PAGE + MOVE S,MEM(B) + JRST @MSOPB(D) + +MSCESP: CAIGE B,MMXSA ;SPECIAL ADDRESSES + JRST @MSSADT(B) +MEAERR: HALT ;ADDRESS ERROR + +MSCERT: MOVEI B,-MEM+T ;ADR T + MOVE S,T + JRST @MSOPB(D) + +MSCETP: POP IP,S ;ADR TOP-IP-POP-IP + MOVEI B,-MEM+1(IP) + JRST @MSOPB(D) + +MSCEXT: MOVE B,T ;ADR (T) + MOVE S,MEM(B) + JRST @MSOPB(D) + +MXPSH: PUSH IP,S + POPJ P, + +MXPOP: POP IP,MEM(B) + POPJ P, + +MXMOV: MOVE T,S + POPJ P, + +MXMVM: MOVEM T,MEM(B) + POPJ P, + +MXCAR: MOVE T,S + JRST QMA + +MXCDR: MOVE T,S + JRST QMD + +MXCAAR: MOVE T,S + JRST QMAA + +MXCADR: MOVE T,S + JRST QMAD + +MXCDAR: MOVE T,S + JRST QMDA + +MXCDDR: MOVE T,S + JRST QMDD + +MXEQ: XOR S,T + TDNE S,[1777,,-1] ;DATA TYPE + DATA + TLZA PC,MSIND + TLO PC,MSIND + POPJ P, + +MXGRT: SKIPA I,[CAMG T,S] +MXLESS: MOVE I,[CAML T,S] + MOVE ZR,S + XOR ZR,T + TLNE ZR,1740 + HALT ;DATA TYPES DIFFER + LDB ZR,[%NDTB,,T] + CAIN ZR,QZFIX + JRST MXLFX +MXOPIL: HALT + +MXLFX: LSH S,36.-23. + LSH T,36.-23. + XCT I + TLZA PC,MSIND + TLO PC,MSIND + POPJ P, + +MXSEDD: SKIPA I,[PUSHJ P,QMDD] +MXSED: MOVE I,[PUSHJ P,QMD] + TLZ B,777740 + TLO B,QZXSYM_5 + PUSH IP,B + MOVE T,S + XCT I + POP IP,B + MOVEM T,MEM(B) + POPJ P, + +MXSE1M: SKIPA I,[SOS S] +MXSE1P: MOVE I,[AOS S] + LDB ZR,[%NDTB,,MEM(B)] + CAIE ZR,QZFIX + HALT + XCT I + DPB S,[%NPTR,,MEM(B)] ;DONT ALLOW CARRIES/BORROWS TO GARBAGE DATA TYPE + POPJ P, + +MXIOR: SKIPA I,[IOR S,T] +MXXOR: MOVE I,[XOR S,T] + JRST MSAOP1 + +MXAND: SKIPA I,[AND S,T] +MXPLUS: MOVE I,[ADD S,T] ;CODE BELOW WINS FOR OPS THAT DONT REQUIRE +MSAOP1: MOVE ZR,S ;SIGN EXTENSION TO WIN + XOR ZR,T + TLNE ZR,1740 + HALT ;DATA TYPES DIFFER + LDB ZR,[%NDTB,,T] + CAIE ZR,QZFIX + JRST MXOPIL + XCT I + DPB S,[%NPTR,,T] + POPJ P, + +MXQUO: MOVE I,[IDIV B,S] + JRST MSAOP2 + +MXTIMS: SKIPA I,[IMUL B,S] +MXMINU: MOVE I,[SUB B,S] +MSAOP2: MOVE ZR,S ;THIS USED FOR ARITH OPS THAT REQUIRE SIGN ENTENSION + XOR ZR,T ;TO WIN + TLNE ZR,1740 + HALT ;DATA TYPES DIFFER + LDB ZR,[%NDTB,,T] + CAIE ZR,QZFIX + JRST MXOPIL + LDB B,[%NPTR,,T] + TLNE B,20 + TLO B,777740 + TLZ S,777740 + TLNE S,20 + TLO S,777740 + XCT I + DPB B,[%NPTR,,T] + POPJ P, + + +MXCALT: PUSH IP,T ;CALL-T +MXCAL: PUSHJ P,MSLLV ;CALL - PUSH MESA-LEAVE BLOCK ON LINEAR BINDING PDL + MOVEI ZR,MSRSUM + TRNE J,100 ;ADI CALL INDICATOR + TLO ZR,PPBMIA + ANDI J,77 ;LEAVE JUST # ARGS + PUSH P,ZR ;RETURN ADDRESS + LDB ZR,[%NDTB,,S] + CAIN ZR,QZMESA + JRST MSMENT + CAIN ZR,QZUENT + JRST MSUENT + HALT + +MSMENT: MOVE Q,S + JRST MSENTR + +MSRSUM: MOVE I,QLBNDP ;RESUME MESA CODE + MOVE PC,-1(I) + MOVE Q,(I) + MOVNI ZR,2 + ADDM ZR,QLBNDP + LDB ZR,[%NDTB,,Q] + CAIE ZR,QZMESA + HALT ;LINEAR BIND PDL SCREWWED + TLZ PC,777740 + ROT PC,-7 ;SHIFT BITS BACK + ADDI PC,(Q) ;UNRELATIVIZE IT + MOVE R,MEM+MFETP(Q) ;LOAD EXIT TABLE POINTER + POPJ P, + +MSUENT: JRST @MEVEC(S) ;CALL U ENTRY + +QMESA1: MOVE Q,A ;ENTER FROM MACRO-MESA OR MICRO-MESA CALL + MOVE J,NARGS + MOVE AP,IP + SUBI AP,(J) + HRRZM AP,IPMARK + TLZ PC,QBBFL+QINDAT+QINDNL+MSIND ;REST OF PC IRRELAVENT, BUT + ;LEAVE FOR DEBUGGING +QBNEAF + MOVE B,LPCLS(AP) + TLNE B,(LPADL) + JRST QMESA2 ;THIS AN ADI CALL + PUSHJ P,MSENTR +MSER: PUSH P,T + JRST QMEX1 + +QMESA2: PUSH P,[PPBMAA,,MSER] ;SIGNAL MACRO-MESA ADI CALL + JRST MSENTR + +MSENTR: MOVEI PC,MFLEN(Q) ;ENTER MESA-FEF IN Q. + MOVE ZR,(P) ;J HAS # ARGS, LH (P) HAS ADI INFO + TLNE ZR,PPBINF + JRST MSLEA1 ;THIS AN ADI CALL +MSLEA2: MOVE B,MEM+MFFSO(Q) ;PICK UP FAST OPTION Q + LDB C,[%AGIMN,,B] + CAMLE C,J + HALT ;NOT ENUF ARGS + LDB C,[%AGIMX,,B] + CAMLE C,J + HALT ;TOO MANY ARGS + LDB ZR,[%MFPDU MEM+MFMSC(Q)] ;MAX DEPTH PDL USED + ADDI ZR,(IP) + HRRZ C,QLPDLH + CAMG C,ZR + HALT ;IP PDL OVERFLOW + MOVE R,MEM+MFETP(Q) ;LOAD EXIT TABLE POINTER + JRST MSML + +MSLEA1: MOVE E,IP ;LOCATE ADI BLOCK + SUB E,J ;SPACE PAST ARGS + TLNE ZR,PPBMAA + SUBI E,LLPFRM ;MACRO-MESA ADI CALL +MSLEA3: MOVE B,(E) + LDB ZR,[%NDTB,,B] + CAIE ZR,QZFIX + HALT + LDB ZR,[%ADITP,,B] + CAIE J,ADIFEX + CAIN J,ADILEX + HALT ;FEXPR AND LEXPR CALLS DONT WIN NOW + TLNN B,NUSRCB + HALT + SOS E + MOVE B,(E) + TLNN B,NUSRCB + JRST MSLEA2 ;SOME OTHER KIND OF ADI + SOJA E,MSLEA3 + +MSLLV: MOVEI I,2 + ADDB I,QLBNDP ;PUSH MESA-LEAVE BLOCK + TLZ Q,NUSRCB ;NOT BEGINNING OF BLOCK + MOVEM Q,(I) ;SAVE MESA-FEF POINTER + HRRZ ZR,PC ;SAVE PC RELATIVE TO MESA-FEF + SUBI ZR,(Q) + HLL ZR,PC + ROT ZR,7 ;ROTATE IN LOW BIT OF PC AND PC STATUS + TLZ ZR,777740 + TLO ZR,QZFIX_5 ;GENERATE QZFIX DATA TYPE + TLO ZR,NUSRCB ;SIGNAL FIRST PUSHED WD OF BLOCK + MOVEM ZR,-1(I) + POPJ P, + +MXP3Z: PUSHJ P,P3ZERO ;OPEN CALL BLOCK + PUSH IP,S ;PUSH FCTN TO CALL EVENTUALLY + POPJ P, + +MXPSHE: TLZ B,777740 ;PUSH-IP-E + TLO B,QZXSYM_5 ;WOULD BE QZXSTR ON REAL MACHINE + PUSH IP,B + POPJ P, + +MXERR: HALT + + +MSBRN: LDB C,[%MSBTP A] ;BRANCH (OP 34,35) + JRST @MSBRTB(C) + +MSBALT: PUSH IP,T ;PUSH-IP T THEN BRANCH +MSBALW: LDB B,[%MSBDS A] ;BRANCH DISPLACEMENT + TRNE B,M%BDSG + ORCMI B,M%SBDS + CAMN B,[-1] + JRST MSBALZ ;DOUBLE WORD BRANCH +MSBLZ2: ROT PC,1 + ADD PC,B + ROT PC,-1 + POPJ P, + +MSBALZ: MOVE B,MEM(PC) + JUMPL PC,[ ADD PC,[400000,,1] + LSH B,-16. + JRST MSBLZ1] + TLO PC,400000 + ANDI B,177777 +MSBLZ1: TRNE B,100000 + ORCMI B,77777 + JRST MSBLZ2 + +MSBNTP: SOS IP ;DONT BRANCH, BUT POP +MSBNOT: LDB B,[%MSBDS A] ;DONT BRANCH + CAIE B,777 + POPJ P, + JUMPL PC, [ADD PC,[400000,,1] ;SKIP OVER 2ND WD DELTA + POPJ P,] + TLO PC,400000 + POPJ P, + +MSBIT: TLNN PC,MSIND ;JUMP-INDICATOR-TRUE + JRST MSBNOT + JRST MSBALW + +MSBIF: TLNE PC,MSIND ;JUMP-INDICATOR-FALSE + JRST MSBNOT + JRST MSBALW + +MSBNIL: LDB ZR,[%NDTB,,T] ;JUMP-NIL + CAIN ZR,QZSYM + TDNE T,[37,,-1] + JRST MSBNOT + JRST MSBALW + +MSBNNL: LDB ZR,[%NDTB,,T] ;JUMP-NOT-NIL + CAIN ZR,QZSYM + TDNE T,[37,,-1] + JRST MSBALW + JRST MSBNOT + +MSBNP: LDB ZR,[%NDTB,,T] ;JUMP-NIL, POP-IF-NO-JUMP + CAIN ZR,QZSYM + TDNE T,[37,,-1] + JRST MSBNTP + JRST MSBALW + +MSBTP: LDB ZR,[%NDTB,,T] ;JUMP-NOT-NIL, POP-IF-NO-JUMP + CAIN ZR,QZSYM + TDNE T,[37,,-1] + JRST MSBALW + JRST MSBNTP + +MSBAT: LDB ZR,[%NDTB,,T] ;JUMP-ATOM + CAIE ZR,QZSYM + CAIN ZR,QZFIX + JRST MSBALW + CAIE ZR,QZXNUM + JRST MSBNOT + JRST MSBALW + +MSBNAT: LDB ZR,[%NDTB,,T] ;JUMP-NOT-ATOM + CAIE ZR,QZSYM + CAIN ZR,QZFIX + JRST MSBNOT + CAIE ZR,QZXNUM + JRST MSBALW + JRST MSBNOT + +MMSC1: LDB B,[%MSMS1 A] ;MISC GROUP 1 + JRST @MMSCT1(B) + +MSMMCT: PUSH IP,T ;CALL-MISC-T +MSMMC: LDB B,[1100,,A] ;MISC INST # + CAIGE B,200 + HALT ;LIST GROUPS + CAIL B,MSFCTL+200 + HALT ;OUT OF RANGE + PUSHJ P,MSLLV + PUSH P,[MSRSUM] + JRST @MSFCT-200(B) + +MMSC2: LDB B,[%MSMS2 A] ;MISC GROUP 2 + LDB C,[%MSM2A A] ;ARGUMENT + JRST @MMSCT2(B) + +MS2ERR: HALT ;BAD MISC GROUP 2 INSTRUCTION + +MSRETI: MOVE T,(IP) ;RETURN-TOP-IP +MSRET: SUB IP,C ;RETURN-T + TLNE PC,QBBFL + PUSHJ P,BBLKP ;POP SPECIAL BLOCK IF ONE PUSHED + SUB P,[1,,1] ;FLUSH RETURN TO MESA-LOOP + POPJ P, ;RETURN TO CALLER + +MSSUBI: SUB IP,C ;SUBI-IP + POPJ P, + +MSACBT: PUSH IP,T ;ACTIVATE-CALL-BLOCK-T +MSACB: PUSHJ P,MSLLV ;ACTIVATE-CALL-BLOCK + MOVE S,IPMARK + SUBI S,(IP) ;GET # ARGS (TO FAKE OUT MMCALL, HOPEFULLY NOT NECESSARY) + MOVEI C,MSRSUM + JRST MMCAL5 + +MSLSTT: PUSH IP,T ;MAKE-LIST-T +MSLST: HRRZ S,CNSADF ;MAKE-LIST GET AREA TO LIST IN +MSLST1: HRRZ B,C ;LENGTH OF LIST TO MAKE + TLO C,QZFIX_5 + PUSH IP,C + PUSHJ P,IALLB ;GET BLOCK OF Q S + POP IP,C + HRRZ B,IP + SUBI B,(C) ;LOCATE FIRST ELEMENT OF LIST + HRRZ D,C + PUSH IP,T ;SAVE POINTER TO STORAGE BLOCK +MSLST2: JUMPE D,MSLST3 ;DONE + MOVE A,(B) ;GET LIST ELEMENT + DPB A,[%NDAT,,MEM(T)] ;STORE INTO NEXT POSITON OF LIST + PUSHJ P,QCDR ;ADVANCE TO NEXT ELEMENT OF LIST + AOS B + SOJA D,MSLST2 + +MSLST3: TDNE T,[17,,-1] + HALT ;SHOULD BE AT END OF LIST NOW + POP IP,T ;GET BACK POINTER TO HEAD OF LIST + SUBI IP,(C) ;FLUSH ARGS FROM IP + TLNE C,1 ;SKIP IF THIS NOT LIST-AREA TYPE + SOS IP ;FLUSH AREA ARG + POPJ P, + +MSLSAT: PUSH IP,T ;LIST-AREA-T +MSLSA: TLO C,1 ;LIST-AREA + HRRZ B,IP + SUBI B,(C) + MOVE S,-1(B) ;AREA ARG + JRST MSLST1 + +MSMVIJ: MOVE J,C ;MOVEI-J + POPJ P, + +MSMVJA: MOVEI J,100(C) ;MOVEI-J-ADI + POPJ P, + +MSCAG: SKIPA I,[CAMG J,C] ;CAIG-J +MSCALE: MOVE I,[CAMLE J,C] ;CAILE-J + XCT I + TLZA PC,MSIND + TLO PC,MSIND + POPJ P, + +MSPBND: MOVE R,C ;POP-BINDING-PDL +MSPBN1: JUMPE R,CPOPJ + TLNN PC,QBBFL + HALT ;LOSE + PUSHJ P,QUNBND + SOJA R,MSPBN1 + +MSMII: CAIL C,LMSIIT ;"INDIVIDUAL" INSTRUCTIONS + HALT + JRST @MSIIDT(C) + +MSSPNW: TLZ PC,QBBFL ;SPECBN-NEW-BLOCK (SHOULD SAVE PREV STATE OF QBBFL) + JRST MSSPN1 + +MSSPAB: TLNN PC,QBBFL ;SPECBN-NO-NEW-BLOCK + HALT +MSSPN1: MOVE A,MEM(PC) + JUMPL PC,[ ADD PC,[400000,,1] + LSH A,-16. + JRST MSSPN2] + TLO PC,400000 + ANDI A,177777 +MSSPN2: MOVEI D,MSOPCE ;FAKE OUT OP DISPATCH + PUSHJ P,MSCE ;COMPUTE EFFECTIVE ADDRESS (THIS IS ADR OF SPECIAL CELL) + PUSH P,Q + PUSHJ P,QBND1 ;SAVE CURRENT CONTENTS + POP P,Q + LDB C,[130400,,A] ;PDL INDEX + CAIL C,16 + JRST @MSSPDT-16(C) ;NIL OR (IP)-POP-IP + MOVNS C ;-N(IP) + ADDI C,(IP) + SKIPA D,(C) +MSSPNL: MOVSI D,QZSYM_5 +MSSPT1: DPB D,[%NDAT,,MEM(B)] + TLNN A,400000 + POPJ P, ;THRU WITH BLOCK + JRST MSSPN1 ;CONTINUE WITH BLOCK + +MSSPTP: POP IP,D + JRST MSSPT1 + +MSSPDT: MSSPTP ;TOP-IP-POP-IP + MSSPNL ;NIL + +MSPBBK: TLNN PC,QBBFL ;POP-BINDING-PDL-BLOCK + HALT + PUSHJ P,BBLKP + POPJ P, + +MSPSJ: TLZ J,777740 ;PUSH-IP-J + TLO J,QZFIX_5 + PUSH IP,J + POPJ P, + +MSPPJ: POP IP,J ;POP-IP-J + POPJ P, + + + +NMADDI==40-4 ;NUMBER ADDRESSABLE INSTRUCTIONS + +;MESA DISPATCH TABLES +MSOPA: MCALCE ;COMPUTE EFF ADR SOMEWHAT DIFFERENTLY FOR CALL + MCALCE + REPEAT NMADDI-2, MSCE ;MESA COMPUTE EFFECTIVE ADDR + MSBRN ;MESA BRANCH + MSBRN + MMSC1 ;MISC GROUP 1 JUMP, CALL-MISC, CALL-MISC-T, INDIVIDUAL + MMSC2 ;MISC GROUP 2 6 BIT ARG INST. + +MSOPB: MXCAL ;CALL + MXCALT ;CALL-T + MXPSH ;PUSH-IP + MXPOP ;POP-IP + MXMOV ;MOVE-T + MXMVM ;MOVEM-T + MXCAR ;CAR + MXCDR ;CDR + MXCADR ;CADR + MXCDDR ;CDDR + MXCDAR ;CDAR + MXCAAR ;CAAR + MXEQ ;EQ + MXLESS ;< + MXGRT ;> + MXSED ;SETE CDR + MXSEDD ;SETE CDDR + MXSE1P ;SETE 1+ + MXSE1M ;SETE 1- + MXPLUS ;+ + MXMINU ;- + MXTIMS ;* + MXQUO ;// + MXAND ;LOGAND + MXIOR ;LOGIOR + MXXOR ;LOGXOR + MXP3Z ;P3ZERO + MXPSHE ;PUSH-IP-E + MXERR ;J GROUP 1 + MXERR ;J GROUP 2 + MXERR ;MISC GROUP 1 + MXERR ;MISC GROUP 2 +MSOPCE==.-MSOPB + CPOPJ ;FAKE OUT "OP" TO COMPUTE EFFECTIVE ADR + +MSADDT: MEAERR ;MESA ADDRESS TYPE + MSCEIP ;-(IP) + MSCECP ;CONSTANTS PAGE + MSCESP ;SPECIAL ADDRESSES + MEAERR + MEAERR + MEAERR + MEAERR + +;SPECIAL ADDRESS DISPATCH +MSSADT: MSCERT ;T + MSCETP ;TOP-OP-POP-IP + MSCEXT ;(T) +MMXSA==.-MSSADT ;# SPECIAL ADDRESSES USED + +;DISPATCH ON CONDITIONAL JUMP TYPE +MSBRTB: MSBIT ;JUMP-INDICATOR-TRUE + MSBIF ;JUMP-INDICATOR-FALSE + MSBNIL ;JUMP-NIL + MSBNNL ;JUMP-NOT-NIL + MSBNP ;JUMP-NIL, POP-IF-NO-JUMP + MSBTP ;JUMP-NOT-NIL, POP-IF-NO-JUMP + MSBAT ;JUMP-ATOM + MSBNAT ;JUMP-NOT-ATOM + +;DISPATCH FOR MISC GROUP 1 +MMSCT1: MSBALW ;UNCONDITIONAL BRANCH + MSBALT ;PUSH-IP T, THEN BRANCH + MSMMC ;CALL-MISC + MSMMCT ;CALL-MISC-T + +;DISPATCH FOR MISC GROUP 2 +MMSCT2: MSRET ;RETURN-T + MSSUBI ;SUBI-IP + MSACB ;ACTIVATE-CALL-BLOCK + MSACBT ;ACTIVATE-CALL-BLOCK-T + MSLST ;MAKE-LIST + MSLSTT ;MAKE-LIST-T + MSLSA ;MAKE-LIST-IN-AREA + MSLSAT ;MAKE-LIST-IN-AREA-T + MSMVIJ ;MOVEI-J + MSMVJA ;MOVEI-J-ADI + MSCAG ;CAIG-J + MSCALE ;CAILE-J + MSPBND ;POP-BINDING-PDL + MSRETI ;RETURN-TOP-IP + REPEAT 31.-.+MMSCT2, MS2ERR + MSMII ;INDIVIDUAL INSTRUCTIONS + +;INDIVIDUAL INSTRUCTION DISPATCH +MSIIDT: MSSPNW ;SPECBN-NEW-BLOCK + MSSPAB ;SPECBN-NO-NEW-BLOCK + MSPBBK ;POP-BINDING-PDL-BLOCK + MSPSJ ;PUSH-IP-J + MSPPJ ;POP-IP-J +LMSIIT==.-MSIIDT + + +MSINST: 0 ;LAST MESA INST EXECUTED + + +;BOOTSTRAPPER + +;COLD LOAD FORMAT + +;Q'S STORED ONE PER 2 36 BIT WORDS +;WD0 +%CLOP==340400 ;OPERATION + CLOERR==0 ;ERR + CLEND==1 ;END OF FILE, REST NOT VALID + CLNXT==2 ;LOAD INTO NEXT AVAIL IN STORAGE AREA MORE EXACTLY, + ;RELOCATE BY AREA'S FSP, AND INCR THE FSP + CLCOMP==3 ;COMPARE AND PRINT ERR IF DFRS FROM CURRENT CONTENTS + CLDARA==4 ;CREATE AREA # IN %CLSTG, %CLDSP PAGES LONG + CLDSYM==5 ;ADD MICRO-CODE SYMBOL SPEC BY %CLDSP TO LAST Q LOADED (RH) + CLDMSC==6 ;ADD MISC ENTRY SPEC BY %CLDSP TO LAST Q LOADED (RH) +%CRBM==1_33 ;RELOCATE RH OF DATA Q BY MEM +%CRBPT==1_32 ;RELOCATE RH OF DATA BY LOCN DATA BEING LOADED INTO +%CLSTG==240600 ;STORAGE AREA +%CLRLA==160600 ;RELOCATION AREA (ADD ORG OF THIS AREA TO DATA +%CLDSP==1600 ;DISPLACEMENT WITHIN AREA +;WD1 32 BITS DATA + +INTGO: JSR @200000 ;START INTERPRETER +INIT: .VALUE [ASCIZ |..TAMPER/P. +P|] + JSR INITR + CLEARM 10INT ;BEING RUN BY 10 INTERP FOR 10 + TDN 17,10INT ;LEAVE INTERP MODE, STORE INTERP RESTART ADR + SKIPE 10INT + JRST INIT0 ;DONT DO CORE + HRRZ A,SC.HGH + ADDI A,MEM + LSH A,-10. + .CORE (A) + .VALUE +INIT0: SKIPGE LOADED + JRST G + .SUSET [.SSNAME,,[SIXBIT/LISPM/]] + .OPEN DSKI,INO + .VALUE + MOVSI A,QZFIX_5+NXTCDR + MOVEM A,.OAAFP + MOVE A,[.OAAFP,,.OAAFP+1] + BLT A,.OAAFP+NAREAS-1 ;INIT FREE STG POINTER TO FIXNUM 0 + MOVE A,[IAOR,,.OAAOR] + BLT A,.OAAOR+IAARAS-1 ;INIT LOW Q ADR + MOVE A,[IALN,,.OAALN] + BLT A,.OAALN+IAARAS-1 ;INIT AREA LENGTH + MOVE A,[QZFIX_5+NXTCDR,,FSLIN] + MOVEM A,.OAAFM + MOVE A,[.OAAFM,,.OAAFM+1] + BLT A,.OAAFM+NAREAS-1 ;INIT FREE STG MODES + MOVEI S,IAARAS-1 ;INIT AREA-SORTED-BY-ORIGIN + PUSHJ P,INITAA + SOJGE S,.-1 +;DROPS THRU + +;DROPS IN +INITML: PUSHJ P,INITGW ;FLAGS + MOVE A,T + LDB AP,[%CLOP,,A] + JUMPE AP,[HALT] + CAIN AP,CLEND + JRST INITGO + LDB S,[%CLSTG,,A] ;STORAGE AREA + LDB J,[%CLRLA,,A] ;RELOCATION AREA + LDB Q,[%CLDSP,,A] ;DISPLACEMENT + CAIN AP,CLDARA + JRST INITA ;ALLOCATE AREA + CAIN AP,CLDSYM + JRST INSYM1 ;ADD SYMBOL TO LAST Q + CAIN AP,CLDMSC + JRST INMSC1 ;ADD MISC FCTN ENTRY TO LAST Q + PUSHJ P,INITGW ;READ DATA Q + CAIE AP,CLNXT + HALT + ADD T,Q ;ADD TO DATA Q + MOVE Q,.OAAFP(S) ;RELOCATE BY FSP OF STORAGE AREA (WITHIN AREA) + AOS IP,.OAAFP(S) ;INCR FSP + HRRZ ZR,.OAALN(S) + HRRZS IP + CAMLE IP,ZR ;THIS AOS ED THING AND STORE IS DONE WITH UN AOS ED + .VALUE ;AREA OVERFILLED +INITM1: HRRZ C,.OAAOR(S) ;ORIG OF STG AREA IN Q'S + ADD Q,C ;RELOCATE STG ADR + HRRZ C,.OAAOR(J) + ADD T,C ;RELOCATE STORED QUANTITY + TLNE A,(%CRBM) + JRST [MOVE C,T ;RELOCATE RH BY MEM + ADDI C,MEM + HRR T,C + JRST .+1] + TLNE A,(%CRBPT) + JRST [MOVE C,T + ADDI C,MEM(Q) + HRR T,C + JRST .+1] + SKIPGE MEM(Q) + .VALUE + MOVEM T,MEM(Q) + MOVEM Q,LQADR ;ADR OF LAST Q + JRST INITML + +INSYM1: CAIL Q,NMMSYM ;RELOCATE RH OF LAST Q BY SPEC SYMBOL + .VALUE ;NOT LEGIT SYM + MOVE T,.OANMS(Q) +INMSC2: MOVE J,LQADR + ADD T,MEM(J) + HRRM T,MEM(J) + JRST INITML + + +INMSC1: HALT ;THIS FROB NOT USED ANYMORE +IFN 0,[ + CAIGE Q,MSFCTL+200 + CAIGE Q,200 + HALT ;LIST GROUP NOT ADDRESSIBLE THIS WAY + MOVE T,MSFCT-200(Q) +; TLNE T,XNOUC +; HALT ;THOSE ALSO ONLY WIN FOR MACRO-CODE + JRST INMSC2 +] + +INITA: IMULI Q,PAGSIZ + MOVE B,SC.FRE ;LOWEST ADR OF FREE AREA + MOVEM B,.OAAOR(S) ;LOWEST ADR OF NEW AREA + ADD B,Q ;LENGTH OF NEW AREA + MOVEM B,SC.FRE ;NEW START OF FREE + MOVEI B,MEM(B) ;MAKE SURE CORE EXISTS + LSH B,-10. + .CORE (B) + .VALUE + TLO Q,QZFIX_5+NXTNIL + MOVEM Q,.OAALN(S) ;LENGTH OF NEW AREA + ;FREE POINTER OF NEW AREA IS 0 (AT BEG OF IT) + ;FREE POINTER OF FREE AREA IS 0 (SINCE BEGINNING HAS + ;RELOCATED) + MOVSI ZR,NXTCDR-NXTNIL + IORM ZR,.OAAOR-1(S) ;TURN HIS CDR CODE TO NXTCDR + ANDCAM ZR,.OAAOR(S) ;AND OURS TO NXTNIL + IORM ZR,.OAALN-1(S) + ANDCAM ZR,.OAAFM(S) + IORM ZR,.OAAFM-1(S) + ANDCAM ZR,.OAAFP(S) + IORM ZR,.OAAFP-1(S) + PUSHJ P,INITAA ;SORT INTO AREA-SORTED-BY-ORIGIN + JRST INITML + +;S AREA CLOBBERS T, A, B +INITAA: MOVEI T,NAREAS-1 ;SORT INTO AREA-SORTED-BY-ORIGIN + HRRZ B,.OAAOR(S) +INITA0: SKIPN .OAASO(T) + SOJGE T,INITA0 + JUMPL T,INITA2 +INITA1: MOVE A,.OAASO(T) + MOVEM A,.OAASO+1(T) + HRRZ A,.OAAOR(A) + CAILE A,(B) + SOJGE T,INITA1 + JUMPL T,INITA2 + CAIE A,(B) + JRST INITA2 + HRRZ A,.OAALN(S) + SKIPN A + SOJGE T,INITA1 ;PUT REAL AREAS AFTER ZERO LENGTH AREAS +INITA2: TLO S,QZFIX_5 + MOVEM S,.OAASO+1(T) + HRRZS S + POPJ P, + +INITGO: MOVE ZR,.OAAFP+AANAME ;FREE STORAGE POINTER OF AREA-NAME AREA + MOVEM ZR,.OAAFP+AAORG ;EQUALIZE OTHER AREA CORRESPONDING FSP S + MOVEM ZR,.OAAFP+AALN + MOVEM ZR,.OAAFP+AAFP + MOVEM ZR,.OAAFP+AAPP + MOVEM ZR,.OAAFP+AAFM + MOVEM ZR,.OAAFP+AAPL + MOVE B,SC.FRE + MOVEM B,SC%FRE + MOVE B,SC.HGH + MOVEM B,SC%HGH + HRRZ B,SC%FRE + ADDI B,MEM+14000 ;LEAVE 5 OR 6K FOR ADDITIONAL DEFINE-AREA S + ANDI B,-2000 + MOVEI A,-MEM(B) + HRRM A,SC%HGH + MOVEM A,SC.HGH + LSH B,-10. + .CORE (B) + .VALUE + SETOM LOADED + .VALUE [ASCIZ/:LOADEDî/] +G: .CLOSE DSKI, + SKIPE 10INT + JSR @10INT + MOVE A,[.OANSCR,,SPMEM] + BLT A,EISCR-1 ;LOAD SCRATCH PAD MEM + MOVE A,QISTKG ;INITIAL STACK GROUP + MOVEM A,QCSTKG ;SET THINGS UP FOR INITIAL STACK-GROUP + MOVE B,SGRA+MEM(A) ;GET POINTER TO L.P. STORAGE ARRAY +; MOVEM B,QLPBAS + MOVE E,MEM(B) + MOVEI C,MEM+1(B) + TRNE E,ARYEXL + AOS C + HRRZM C,QLPDLO ;LOW LIMIT + LDB ZR,[%ARYL,,MEM(B)] + TRNE E,ARYEXL + LDB ZR,[%NPTR,,MEM+1(B)] + ADDI ZR,-LPFUDG(C) ;ALLOW FOR FUDGE + HRRZM ZR,QLPDLH ;HIGH LIMIT + MOVEI IP,-1(C) ;SO FIRST WD PUSHED WILL GO INTO QLPDLO WD + HRRZ ZR,IP + SUB ZR,QLPDLH + HRLM ZR,IP ;SET UP L.H. OVFLW CHECK FOR RANDOMNESS + MOVE B,SGBA+MEM(A) ;GET POINTER TO L.B. STORAGE ARRAY + MOVEM B,QLBBAS + MOVE E,MEM(B) + MOVEI C,MEM+1(B) + TRNE E,ARYEXL + AOS C + HRRZM C,QLBNDO + HRRZM C,QLBNDP + LDB ZR,[%ARYL,,MEM(B)] + TRNE E,ARYEXL + LDB ZR,[%NPTR,,MEM+1(B)] + ADD ZR,C + MOVEM ZR,QLBNDH +; HRRZ ZR,SGBP+MEM(A) +; ADD ZR,C +; HRRZM ZR,QLBNDP + + PUSH IP,[0] ;DUMMY UP LINEAR PDL ENTRY, SORT OF + PUSH IP,[0] + PUSH IP,[0] + MOVE B,IFCTN ;INITIAL FUNCTION POINTER + MOVE D,MEM(B) ;REF FCTN CELL + LDB C,[%NDTB,,D] + CAIE C,QZFEFP + .VALUE + PUSH IP,D ;PNTR TO FEF INITIALLY RUNNING + MOVE AP,IP + LDB PC,[%QFEPC,,MEM(D)] + ROT PC,-1 + ADDI PC,(D) + HRRZM IP,IPMARK + JRST QMLPR ;!! + +INITR: 0 + .OPEN TYIC,TTYI + .VALUE + .OPEN TYOC,TTYO + .VALUE + MOVE P,[-LPDL,,PDL-1] + JRST @INITR + +N11PG==4 ;# PAGES TO SET UP POINTING TO 11 +11PG==400-N11PG ;FIRST PAGE TO USE TO REF 11 +LDBUFF==37002 ;PDP11 ADR OF BUFFER FLAG WD + ; THIS MUST MAP INTO THE RH OF A PDP-10 WD +LDBUF==37004 ;PDP11 ADR OF BUFFER +LDBUFB==40 ;LENGTH OF BUFFER (IN ITEMS, 2 PDP-10 + ; OR 4 PDP-11 WDS EA) + +P11N==2 ;PDP11 TO USE + +P11BA==11PG*2000 ;10 BASE OF 11 ADR SPACE + +;CONS UCODE "BINARY" FILE FORMAT: +; +; EA CONSISTS OF REGISTER ADR AND THREE DATA WORDS, LOW ORDER WD FIRST +; -2 --SIGNALS BEGINNING OF SYMBOLS +; +; EA CONSISTS OF REGISTER ADR FOLLOWED BY SYMBOL NAME +; -1 --SIGNALS END OF FILE +;NOTE: THIS LOADER IGNORES SYMBOLS + +QLOAD: JSR INITR ;LOAD CONS OVER TEN11 INTERFACE! + .OPEN DSKI,QLIO + .VALUE + MOVE A,[600000,,1777] + MOVEI C,P11N + DPB C,[320400,,A] + MOVEI B,11PG +QLD11L: .CALL [SETZ + SIXBIT /T11MP/ + B ;PAGE TO HACK 11 WITH + SETZ A] + .VALUE + ADD A,[2000_10.] + CAIGE B,377 + AOJA B,QLD11L +QLDLP: PUSHJ P,QLDWT ;WAIT FOR BUFFER FREE + MOVE Q,[442000,,P11BA+] + MOVEI J,LDBUFB ;# FROBS THAT WILL FIT IN BUFFER +QLDL1: PUSHJ P,INITGW + JUMPL T,QLDFN + PUSHJ P,QLDSLT ;SALT ADR + PUSHJ P,INITGW + MOVE A,T + PUSHJ P,INITGW + MOVE B,T + PUSHJ P,INITGW + PUSHJ P,QLDSLT ;LOW ORDER WD FIRST + MOVE T,B + PUSHJ P,QLDSLT + MOVE T,A + PUSHJ P,QLDSLT + SOJG J,QLDL1 + PUSHJ P,QLDSB + JRST QLDLP + +QLDSLT: IDPB T,Q + LDB ZR,Q ;CHECK IT + CAME ZR,T + .VALUE + POPJ P, + +QLDFN: CLEARM (Q) ;CLEAR OUT REST OF BLOCK + CLEARM 1(Q) + ADDI Q,2 + SOJG J,QLDFN + PUSHJ P,QLDSB + PUSHJ P,QLDWT +WIN: .VALUE + +QLDWT: MOVE ZR,P11BA+ + TDNN ZR,[177776_4] + POPJ P, + MOVEI ZR,2 + .SLEEP ZR, + JRST QLDWT + +QLDSB: MOVEI ZR,105_4 + MOVEM ZR,P11BA+ + POPJ P, + +QLIO: 2,,(SIXBIT /DSK/) + SIXBIT /CONS/ + SIXBIT /LOAD/ + 0 + +;THE FOLLOWING ARE USED BY COLD LOAD INITIALIZE +;COPY OF SC%FRE AND SC%HGH WHERE THEY WON'T BE CLOBBERED BY WHAT'S LOADED IN +SC.FRE: QZFIX_23.+ZZQ-MEM +SC.HGH: QZFIX_23.+-MEM + +INITGW: MOVEI T,0 ;RETURN WORD IN T, CLOBBER R +INITG1: ILDB R,INBUFP + CAIN R,3 + PUSHJ P,NEWBF + CAIN R,"- + JRST INIMNS ;HACK HACK + CAIL R,"0 + CAILE R,"9 + JRST INITG1 +INITG2: LSH T,3 + ADDI T,-"0(R) + ILDB R,INBUFP + CAIN R,3 + PUSHJ P,NEWBF + CAIN R,"- + JRST INIMNS ;HACK HACK + CAIL R,"0 + CAILE R,"9 + JRST INITG3 + JRST INITG2 + +INITG3: CAIE R,"_ + JRST [SETOM UTUNRF + MOVEM R,UTURCH + POPJ P,] + PUSH P,T + PUSHJ P,INITGW + MOVE R,T + POP P,T + LSH T,(R) + POPJ P, + +INIMNS: PUSHJ P,INITGW ;HACK (AND I DO MEAN HACK) - + MOVNS T + POPJ P, + +NEWBF: HRRZ R,INBUFP ;UNSKIPS TWICE, CLOBBERS R + SKIPGE NEWBEF + JRST .+3 + CAIE R,INBUF+INBFSZ + .VALUE + MOVE R,[-INBFSZ,,INBUF] + .IOT DSKI,R + JUMPL R,[ CAMN R,[-INBFSZ,,INBUF] + POPJ P, ;NO DATA XFERRED, RETURN IN R - + HRLI R,3_11. + MOVEM R,(R) ;ASSURE ^C AT END OF DATA + SETOM NEWBEF + JRST .+1] + MOVE R,[440700,,INBUF] + MOVEM R,INBUFP + SOS (P) + SOS (P) + SOS (P) + POPJ P, + + +;DO ITS NEW SYSTEM CALL +; TAKES 1 ARG, A LIST, EACH ELEMENT OF WHICH CORRESPONDS TO A WORD IN NEW SYSTEM +; CALL-LIST. (EXCEPT THE SETZ WORD COMES FOR FREE.) +; IF COMPLETED CALL FAILS TO SKIP, A SINGLE VALUE OF NIL IS RETURNED. +; OTHERWISE, FIRST VALUE IS T AND OTHERS ARE CONTROLLED BY "RETURNED VALUE" +; OPS (SEE BELOW). +; IF ARG IS DTP-FIX, IT IS CONVERTED INTO A DIRECT NUMERIC ARG. +; IF ARG IS DTP-SYMBOL OR A STRING, IT IS CONVERTED INTO TO SIXBIT, STORED INTO A WORD, +; AND A NORMAL ARG WORD POINTING AT THE FIRST WORD ADDED TO CALL-LIST. +; (EXCEPT IF FIRST WORD IN LIST, IE SYSTEM CALL NAME, IT IS PUT IN DIRECTLY). +; IF ARG IS DTP-LIST, THEN (CAR ARG) MUST BE A NUMBER SPECIFING "OP-CODE" TO +; BE USED. (THESE OP-CODE S ARE THE SAME AS USED BY ITS ITSELF.) +; 0 ARG. CADR AND CADDR SHOULD BE FIXNUMS WHICH ARE THE LEFT AND RIGHT +; HALVES OF ARG WORD. +; 1 IMMEDIATE ARG. ILLEGAL HERE. JUST SUPPLY FIXNUM. +; 2 RETURNED VALUE. IF CDR NIL, VALUE IS TRUNCATED TO 23 BITS AND MADE A FIXNUM, +; OTHERWISE, TWO VALUES WILL BE GENERATED, EACH AN 18 BIT FIXNUM. +; 4 CONTROL. ILLEGAL +; 5 IMMEDIATE CONTROL. CADR IS FIXNUM VALUE. +; 6 (INTERNAL OP CODE, NOT ITS DEFINED) BOTH ARG AND VALUE. IE TAKE ARG +; LIKE CODE 0, BUT LOCATE WORD IN RETURNED VALUE AREA. IF CDDDR IS NIL +; RETURNS SINGLE VALUE, ELSE TWO (A LA CODE 2) + +XITSC: PUSH P,[ITSCOM+1] ;POINTER TO WORD TO SMASH + PUSH P,[ITSCA] ;POINTER TO AREA USED TO ASSEMBLE ARGS + PUSH P,[ITSCV] ;POINTER TO AREA USED TO RECIEVE VALUES +XITSC1: MOVE T,(IP) +XITSC2: TDNN T,PTRM + JRST XITF1 ;CONSTRUCTION OF CALL FINISHED + PUSHJ P,QCAR + LDB ZR,[%NDTB,,T] + CAIN ZR,QZFIX + JRST XITFX + CAIN ZR,QZSYM + JRST XITSM + CAIN ZR,QZARYP + JRST XITSTR + CAIE ZR,QZLIST + HALT + PUSH IP,T + PUSHJ P,QCAR + LDB ZR,[%NDTB,,T] + CAIE ZR,QZFIX + HALT ;OP CODE MUST BE FIX + HRRZ A,T + SOJL A,XITSAR ;0 ARG + SOJL A,XITER ;1 + SOJL A,XITVL ;2 VALUE + SOJL A,XITER ;3 CONTROL + SOJL A,XITER ;4 + SOJL A,XITIC ;5 IMMEDIATE CONTROL + SOJL A,XITBTH ;6 BOTH PASS ARG AND GET VALUE +XITER: HALT + +XITFX: MOVE J,-1(P) + HRRZM T,(J) ;CONVERT FIXNUM INTO DIRECT ARG + JRST XITSA1 + +XITL2: MOVE I,-2(P) + MOVEM T,(I) +XITL1: AOS -2(P) +XITL: MOVE T,(IP) + PUSHJ P,QCDR + MOVEM T,(IP) + JRST XITSC2 + +XITSM: MOVE T,MEM(T) ;GET P-NAME POINTER +XITSTR: HRRZ I,-2(P) + CAIN I,ITSCOM+1 + JRST [ MOVEI D,(I) ;FIRST SIXBIT FROB (CALL NAME) GOES DIRECTLY IN + PUSHJ P,X6BC + JRST XITL1] + HRRZ D,-1(P) + PUSHJ P,X6BC ;CONVERT STRING TO SIXBIT, STORE IN MEM LOCN POINTED +XITSA1: MOVE J,-1(P) + AOS -1(P) + MOVE I,-2(P) + HRRZM J,(I) ;TO BY D + JRST XITL1 + +XITSAR: PUSHJ P,XITSA2 + SUB IP,[1,,1] + JRST XITSA1 + +XITSA2: MOVE T,(IP) ;OFFSET REFS (P) -1 BECAUSE OF SUBR ROUTINE + PUSHJ P,QMAD + LDB ZR,[%NDTB,,T] + CAIE ZR,QZFIX + HALT + MOVE J,-1-1(P) + HRLM T,(J) + MOVE T,(IP) + PUSHJ P,QMADD + LDB ZR,[%NDTB,,T] + CAIE ZR,QZFIX + HALT + MOVE J,-1-1(P) + HRRM T,(J) + POPJ P, + +XITIC: POP IP,T + PUSHJ P,QMAD + LDB ZR,[%NDTB,,T] + CAIE ZR,QZFIX + HALT + HRLI T,5000 + JRST XITL2 + +XITBTH: PUSHJ P,XITSA2 ;READ IN ARG AND STORE IN ARG SLOT + MOVE T,(J) ;(DONT INCR ARG POINTER THO) + MOVE S,(P) + MOVEM T,(S) ;STORE AS INITIAL CONTENTS OF VALUE LOCN + POP IP,T + PUSHJ P,QMDD + MOVEI ZR,0 ;FLAG AS ARG (ALTHO PRSUMABLY IT GETS MODIFIED TOO) + JRST XITBT1 + +XITVL: POP IP,T + MOVE S,(P) + CLEARM (S) ;INITIALIZE TO AVOID RANDOMNESS IN CASE IT REALLY + ;DOESNT GET STORED INTO + MOVEI ZR,2000 ;SIGNAL VALUE TO BE RETURNED +XITBT1: MOVE I,-2(P) + HRLM ZR,(I) + PUSHJ P,QCDR + MOVE S,0(P) + CLEARM ITSCVF-ITSCV(S) ;JUST WANT 18 BIT VALUE + TDNE T,PTRM + SETOM ITSCVF-ITSCV(S) ;NO WANT FULL 36 BITS AS 2 18 BIT PIECES + MOVE I,-2(P) + HRRM S,(I) + AOS 0(P) + JRST XITL1 + +XITF1: POP P,S + POP P,J + POP P,I + POP IP,T + CAIN I,ITSCOM+1 + JRST XFALSE ;NOT GOING TO WIN + CAIN I,ITSCOM+2 + JRST [ CLEARM (I) ;NO ARGS, SUPPLY NULL ONE JUST TO TERIMINATE LIST + AOJA I,.+1] + MOVSI ZR,400000 + IORM ZR,-1(I) + SUBI S,ITSCV + MOVEM S,XITNV ;NUMBER VALUES + MOVEI S,ITSCV + MOVEM S,ITSCVP + .CALL ITSCOM + JRST XFALSE + PUSHJ P,XTRUE +XITRV: SKIPG XITNV + POPJ P, ;EXIT WITH LAST VALUE IN T + PUSH IP,T + JSR 0,MURV ;RETURN PREVIOUS VALUE + MOVE S,ITSCVP + SKIPL ITSCVF-ITSCV(S) + JRST XITRV1 ;ONLY WANT RH VALUE ON THIS ONE + MOVE S,ITSCVP + HLRZ T,(S) + TLO T,QZFIX_5 + PUSH IP,T + JSR 0,MURV ;COMPUTE AND RETURN HIGH ORDER VALUE IF DESIRED +XITRV1: MOVE S,ITSCVP + HRRZ T,(S) + TLO T,QZFIX_5 ;LEAVE LOW ORDER VALUE IN T. ITS "LAST SO FAR" + AOS ITSCVP + SOS XITNV + JRST XITRV + +ITSCVP: 0 ;POINTER TO VALUE AREA +XITNV: 0 ;NUMBER VALUES LEFT TO PROCESS + +ITSCOM: SETZ ;BUILD .CALL HERE + BLOCK 20 +ITSCME: + +ITSCA: BLOCK 8 ;SEND ARGS TO ITS FROM THIS BLOCK +ITSCV: BLOCK 8 ;RECIEVE VALUES FROM ITS IN THIS BLOCK +ITSCVF: BLOCK 8 ;FOR EACH WD IN ITSCV, -1 SAYS WANT 36 BIT VALUE AS 2 18 BIT PIECES + + +XIOPEN: POP IP,T ;NAME LIST + POP IP,B ;ITS MODE + POP IP,A ;ITS CHNL + HRRM A,OPNMD + HRLM B,OPNMD + MOVEI D,OPNFN1 +XIOP1: TDNN T,[37,,-1] + JRST XIOP2 + PUSH IP,T + PUSHJ P,QCAR +XIOP3: LDB ZR,[%NDTB,,T] + CAIN ZR,QZSYM + JRST [MOVE T,MEM(T) ;IF A SYM, GOBBLE ITS P-NAME POINTER + JRST XIOP3] + HRRZ ZR,D + CAIL ZR,OPNLST + HALT + PUSHJ P,X6BC + POP IP,T + PUSHJ P,QCDR + AOJA D,XIOP1 + +XISOUT: POP IP,T ;STRING POINTER + POP IP,S ;STARTING CHAR + POP IP,ZR + HRLI ZR,5000 + MOVEM ZR,ISICM1 ;CONTROL BITS + POP IP,R + HRLI R,1000 ;CHNL + MOVEM R,ISICM2 + MOVE ZR,MEM(T) + LDB C,[%ARYL,,ZR] ;%ITS-STRING-OUT +; IMULI C,4 + TRNE ZR,ARYEXL + LDB C,[%NPTR,,MEM+1(T)] ;EXTENDED ARRAY + TDNE ZR,[ARXIB] ;SKIP ON NO LEADER + HRRZ C,MEM-2(T) ;USE ARRAY-LEADER 0 FOR STRING LENGTH + SUBI C,(S) ;SKIPPING THIS MANY + JUMPE C,CPOPJ ;FLUSH IF NOT REALLY ANY + HRLI B,001000 + HRRI B,MEM+1(T) + TRNE ZR,ARYEXL + AOS B ;SKIP OVER EXTENDED LENGTH WD + HRRZ ZR,S ;SKIP OVER # CHARS IN S + TRNE ZR,3 + JRST [ ADD B,[100000,,] + TLZE B,400000 + AOS B + SOJA ZR,.-1] + LSH ZR,-2 + ADD B,ZR +XIST2D: MOVE D,[440700,,STRBUF] +XIST1: CAMN D,[10700,,STRBUF+77] + JRST XIST2A ;DUMP THIS BUFFER LOAD + LDB A,B + CAIE A,200 ;DON'T PRINT NULLS + IDPB A,D + ADD B,[100000,,] + TLZE B,400000 + AOS B + SOJG C,XIST1 +XIST2: MOVEI B,0 ;FLAG THRU +XIST2A: MOVEI ZR,^C +XIST2B: TLNN D,760000 ;FILL OUT LAST WORD WITH NULLS + JRST XIST2C + IDPB ZR,D + JRST XIST2B + +XIST2C: MOVNI Q,1(D) + ADDI Q,STRBUF + HRLZS Q + HRRI Q,STRBUF + .CALL ISICOM + JRST XFALSE + JUMPN B,XIST2D + POPJ P, + +ISICOM: SETZ + SIXBIT /IOT/ +ISICM1: 0 +ISICM2: 0 + SETZ Q + +STRBUF: BLOCK 100 + +X6BC: HRLI D,440600 ;SMASH WORD POINTED TO BY D + CLEARM (D) + MOVE A,T + LDB B,[%NDTB,,A] + CAIN B,QZFIX + JRST X6BC1 ;ITS A NUMBER, DECIMAL PRINT IT + CAIE B,QZARYP + BARF ARG TO CONVERT-TO-SIXBIT NOT STRING OR NUMBER,T/& + MOVE B,MEM(A) + LDB C,[%ARYL,,B] + TRNE B,ARYEXL + JRST [ LDB C,[%NPTR,,MEM+1(A)] ;EXTENDED ARRAY + AOJA A,.+1] + MOVEI B,MEM+1(A) + HRLI B,1000 ;ASSUME ITS A BYTE ARRAY +XIOP4: LDB A,B + TLNE D,770000 + CAIN A,200 + JRST XIOP5 ;SKIP NULLS + SUBI A,40 + IDPB A,D +XIOP5: ADD B,[100000,,] + TLZE B,400000 + AOS B + SOJG C,XIOP4 + POPJ P, + +X6BC1: LDB A,[%NPTR,,T] +X6BC2: IDIVI A,10. ;STRING DECIMAL PRINT A NUMBER. + HRLM B,(P) + SKIPE A + PUSHJ P,X6BC2 + HLRZ A,(P) + ADDI A,20 ;CONVERT TO SIXBIT + TLNE D,770000 + IDPB A,D + POPJ P, + + +XIOP2: .CALL OPNCOM + JRST XFALSE + MOVE ZR,[440700,,INBUF+INBFSZ] + HRRZ A,OPNMD + CAIE A,DSKI + JRST XTRUE + CLEARM NEWBEF + MOVEM ZR,INBUFP + JRST XTRUE + +OPNCOM: SETZ + SIXBIT /OPEN/ + OPNMD + OPNDEV + OPNFN1 + OPNFN2 + SETZ OPNSNM + +OPNMD: 0 +OPNFN1: 0 +OPNFN2: 0 +OPNDEV: SIXBIT /DSK/ +OPNSNM: SIXBIT /LISPM/ +OPNLST: + +XIWRDR: PUSHJ P,INITGW + TLZ T,777740 + TLO T,QZFIX_5 + POPJ P, + +XIUTYI: POP IP,T ;RETURNS ARG IF EOF + AOSN UTUNRF + JRST [MOVE R,UTURCH + JRST XIUTY1] + ILDB R,INBUFP + CAIN R,3 + PUSHJ P,NEWBF + JUMPL R,CPOPJ ;RETURN ARG IF EOF + MOVEM R,UTURCH +XIUTY1: TLO R,QZFIX_5 + MOVE T,R + POPJ P, + +XIUUTY: POP IP,T + LDB ZR,[%NDTB,,T] + SETOM UTUNRF + CAIN ZR,QZFIX + HRRZM T,UTURCH + POPJ P, + +UTUNRF: 0 +UTURCH: 0 + + + +;;; +;;; TV GRAPHICS +;;; + +IMMEDIATE==1000 ;IMMEDATE ARG IN SYSTEM CALL. +RERIAC==600000 ;READ WRITE ACCESS TO PAGES IN TV BUFFER. +TVORIGIN=700000 ;SAFE PLACE IN LMI ADDRESS SPACE FOR TV BUFFER + ;TO START. +ALUOP=TVORIGIN+455.*18.+2 ;ADDRESS OF ALU OP IN TV BUFFER. + +;;INITIALIZATION FUNCTION. SETS UP TV BUFFER. + +XTVINI: MOVEI E, TVORIGIN ;E HOLDS ADDRESS OF START OF TV BUFFER. + LSH E, -12 ;PAGE NUMBER. + HRLI E, -11 ;NUMBER OF PAGES. + SETZ D, + .CALL TVMAP ;MAP 11'S TV BUFFER MEMORY TO 10'S ADDRESS SPACE. +TVFAIL: .VALUE + JRST XTRUE + +TVMAP: SETZ + SIXBIT /CORBLK/ + IMMEDIATE,, RERIAC + IMMEDIATE,, -1 + E + IMMEDIATE,, -2 + SETZ D + + +;;READ AND WRITE A SINGLE POINT IN THE TV BUFFER. +;;COORDINATES ARE X: 0 TO 575. LEFT TO RIGHT, Y: 0 TO 453. TOP TO BOTTOM. + +TVPOINT: ;TAKES X COORDINATE IN C, Y COORDINATE IN E, + ;RETURNS ADDRESS OF WORD IN E, MASK BIT IN D + IDIVI C, 32. ;DIVIDE BY 32. WORD IN C, BIT IN D. + IMULI E, 18. ;18. WORDS PER TV LINE. + ADD E, C ;OFFSET OF TV WORD TVORIGIN + ADDI E, TVORIGIN ;ADD IN TVORIGIN. E NOW HAS ADDRESS OF TV WORD + MOVEI C, 35. ;CREATE WORD TO SET IN TV BUFFER. + SUB C, D + MOVEI D, 1 + LSH D, (C) + POPJ P, + +XTVSET: ;ARGUMENTS ARE: XCOR, YCOR + HRRZ E, (IP) ;Y COORDINATE. + HRRZ C, -1(IP) ;X COORDINATE. + PUSHJ P, TVPOINT ;CALCULATE ADDRESS & MASK. + MOVEM D, (E) ;SET IT. + SUBI IP, 2 ;POP OFF TWO ARGUMENTS. + JRST XTRUE ;RETURN T RANDOMLY. + +XTVREAD: ;ARGUMENTS ARE XCOR, YCOR, RETURNS T IF ON, NIL IF OFF. + HRRZ E, (IP) + HRRZ C, -1(IP) + PUSHJ P, TVPOINT + MOVE C, (E) ;FETCH TV WORD. + SUBI IP, 2 ;POP OFF TWO ARGUMENTS. + TDNN C, D ;IS BIT ON? + JRST XFALSE + JRST XTRUE + + +XDRAWMODE: ;SETS "DRAWMODE" -- ALU OP IN PDP11. DETERMINES BOOLEAN + POP IP,E ;FUNCTION APPLIED TO OLD & NEW CONTENTS ON WRITE. + DPB E,[341000,,ALUOP] + JRST XTRUE + +;;HORIZONTAL LINE. (HORIZONTAL-LINE ) +;;WITH FROM-X < TO-X [DRAWS LEFT TO RIGHT]. + +XHLINE: HRRZ B, -1(IP) ;Y COORDINATE. + IMULI B, 18. + ADDI B, TVORIGIN + HRRZ C, -2(IP) + IDIVI C, 32. + ADD C, B ;C HAS ADDRESS OF CURRENT WORD TO DRAW IN. + MOVN D, D + MOVNI E, 1 + LSH E, (D) + TRZ E, 15. ;E HAS MASK TO DRAW WITH. + HRRZ D, (IP) + LSH D, -5 + ADD D, B ;D HAS ADDRESS OF LAST WORD TO DRAW IN. +HCOMP: CAML C, D + JRST HLWORD +HDRAW: MOVEM E, (C) + AOS C + MOVNI E, 20 + JRST HCOMP +HLWORD: HRRZ B, 0(IP) + IDIVI B, 32. + MOVEI B, 36. + SUBM B, C + MOVNI B, 1 + LSH B, (C) + AND E, B + MOVEM E, (D) + SUBI IP, 3 + JRST XTRUE + +;;VERTICAL LINE. (VERTICAL-LINE ) +;;FROM-Y SHOULD BE GREATER THAN TO-Y [DRAWS UPWARD.] + +XVLINE: HRRZ C, -2(IP) + HRRZ E, -1(IP) + PUSHJ P, TVPOINT ;ADDRESS OF STARTING POINT WORD IN E, MASK IN D + HRRZ B, (IP) ;ENDING LINE. + IMULI B, 18. + ADDI B, TVORIGIN ;IF WORD IS LESS THAN B, STOP. +VCOMP: CAMGE E, B + JRST VLEND + MOVEM D, (E) + SUBI E, 18. + JRST VCOMP +VLEND: SUBI IP, 3 + JRST XTRUE + + +10INT: 0 ;NON ZERO IF BEING INTERPRETED BY 10 INTERPRETER FOR 10 +LQADR: 0 ;ADR OF LAST Q LOADED +LOADED: 0 ;-1 COLD LOAD DONE + +TTYI: 0,,(SIXBIT /TTY/) +TTYO: 1,,(SIXBIT /TTY/) +INO: 2,,(SIXBIT /DSK/) + SIXBIT /LMCOLD/ + SIXBIT /LOAD/ + 0 + +INBUFP: 440700,,INBUF+INBFSZ +NEWBEF: 0 ;-1 LAST IOT DID NOT XFER FULL AMT OF WDS + +INBFSZ==100 + +INBUF: BLOCK INBFSZ + 3_29. + +PDL: BLOCK LPDL + +PAT: BLOCK 100 + +PATCH: BLOCK 100 + +;INITIAL AREA FREE STG POINTERS + +;THIS ARRAY BLTED TO AAFP AS PART OF COLD LOAD + +IAOR: REPEAT IAARAS, CONC NXTCDR_18.+QZFIX_23.+.LQ,\.RPCNT, +IALN: REPEAT IAARAS, CONC NXTCDR_18.+QZFIX_23.+.LN,\.RPCNT, + +CONSTANTS +VARIABLES + + +;Q STORAGE +MEM: + REPEAT IAARAS, CONC AM,\.RPCNT, + +ICORSZ==<._-10.>+1 + +ZZQ==. +LOC .OANMS ;ASSEMBLE MICRO-CODE SYMBOL VECTOR + +MSFCT: ;MISC FCTN DISPATCH.. STARTS WITH MISC 200 +XNOUC==0 ;FUNCTION NOT ACCESSIBLE TO MICRO CODE + ; (THIS ERROR CHECK NOT REALLY WORTH IT..) + REPEAT 16.,QZFIX_5+NXTCDR,,CONC XUB,\.RPCNT+1 ;UNBIND 1-16 + REPEAT 16.,QZFIX_5+NXTCDR+XNOUC,,XPOPIP ;POP IP 1-16. + ; -- NOT CALLABLE BY MICRO-FCTNS + ;SINCE IT DEPENDS ON B TO BE SET UP + QZFIX_5+NXTCDR,,QIMSCR + QZFIX_5+NXTCDR,,QIMSCR + QZFIX_5+NXTCDR,,QTA ;CAR + QZFIX_5+NXTCDR,,QTD ;CDR + QZFIX_5+NXTCDR,,QTAA ;CXXR + QZFIX_5+NXTCDR,,QTAD + QZFIX_5+NXTCDR,,QTDA + QZFIX_5+NXTCDR,,QTDD + QZFIX_5+NXTCDR,,QTAAA ;CXXXR + QZFIX_5+NXTCDR,,QTAAD + QZFIX_5+NXTCDR,,QTADA + QZFIX_5+NXTCDR,,QTADD + QZFIX_5+NXTCDR,,QTDAA + QZFIX_5+NXTCDR,,QTDAD + QZFIX_5+NXTCDR,,QTDDA + QZFIX_5+NXTCDR,,QTDDD + QZFIX_5+NXTCDR,,QTAAAA ;CXXXXR + QZFIX_5+NXTCDR,,QTAAAD + QZFIX_5+NXTCDR,,QTAADA + QZFIX_5+NXTCDR,,QTAADD + QZFIX_5+NXTCDR,,QTADAA + QZFIX_5+NXTCDR,,QTADAD + QZFIX_5+NXTCDR,,QTADDA + QZFIX_5+NXTCDR,,QTADDD + QZFIX_5+NXTCDR,,QTDAAA + QZFIX_5+NXTCDR,,QTDAAD + QZFIX_5+NXTCDR,,QTDADA + QZFIX_5+NXTCDR,,QTDADD + QZFIX_5+NXTCDR,,QTDDAA + QZFIX_5+NXTCDR,,QTDDAD + QZFIX_5+NXTCDR,,QTDDDA + QZFIX_5+NXTCDR,,QTDDDD + +;NODE FIELDS FETCH AND STORE + QZFIX_5+NXTCDR,,[HALT] ;GCB + QZFIX_5+NXTCDR,,XUSRCB + QZFIX_5+NXTCDR,,XCDRC + QZFIX_5+NXTCDR,,XDATTP + QZFIX_5+NXTCDR,,XDAT + QZFIX_5+NXTCDR,,[HALT] ;SGCB + QZFIX_5+NXTCDR,,XSUSCB + QZFIX_5+NXTCDR,,XSCDRC + QZFIX_5+NXTCDR,,XSDATP + QZFIX_5+NXTCDR,,XSPTR + QZFIX_5+NXTCDR,,XSTND + QZFIX_5+NXTCDR,,XSTALL + + QZFIX_5+NXTCDR,,XCOMB + QZFIX_5+NXTCDR,,XLDB + QZFIX_5+NXTCDR,,XDPB + QZFIX_5+NXTCDR,,XCMBS ;317 + QZFIX_5+NXTCDR,,XGET + QZFIX_5+NXTCDR,,XGETL + QZFIX_5+NXTCDR,,XASSQ + QZFIX_5+NXTCDR,,XLAST + QZFIX_5+NXTCDR,,XLENGTH + QZFIX_5+NXTCDR,,X1PLS + QZFIX_5+NXTCDR,,X1MNS + QZFIX_5+NXTCDR,,XRPLCA + QZFIX_5+NXTCDR,,XRPLCD + QZFIX_5+NXTCDR,,XZEROP + QZFIX_5+NXTCDR,,XSET + QZFIX_5+NXTCDR,,QIMSCR ;333 + QZFIX_5+NXTCDR,,QIMSCR ;334 + QZFIX_5+NXTCDR,,XCOMPGO + QZFIX_5+NXTCDR,,QIMSCR ;336 + QZFIX_5+NXTCDR,,XXSTORE + + QZFIX_5+NXTCDR,,XFALSE + QZFIX_5+NXTCDR,,XTRUE + QZFIX_5+NXTCDR,,XNOT + QZFIX_5+NXTCDR,,XATOM + + QZFIX_5+NXTCDR,,XTYI + QZFIX_5+NXTCDR,,XTYO + QZFIX_5+NXTCDR,,XHALT + QZFIX_5+NXTCDR,,XGPN + QZFIX_5+NXTCDR,,XLSH + QZFIX_5+NXTCDR,,XROT + QZFIX_5+NXTCDR,,XBOOLE + QZFIX_5+NXTCDR,,XNUMBP + QZFIX_5+NXTCDR,,XPLUSP + QZFIX_5+NXTCDR,,XMNUSP + QZFIX_5+NXTCDR,,XREM + QZFIX_5+NXTCDR,,XMINUS + QZFIX_5+NXTCDR,,XPNPCL + QZFIX_5+NXTCDR,,XVCL + QZFIX_5+NXTCDR,,XFCL + QZFIX_5+NXTCDR,,XPRPCL + QZFIX_5+NXTCDR,,XNCONS + QZFIX_5+NXTCDR,,XNCONA + QZFIX_5+NXTCDR,,XCONS + QZFIX_5+NXTCDR,,XCONSA + QZFIX_5+NXTCDR,,XXCONS + QZFIX_5+NXTCDR,,XXCONA + QZFIX_5+NXTCDR,,ILLOP ;XADN + QZFIX_5+NXTCDR,,XSYMEV + QZFIX_5+NXTCDR,,XARC + QZFIX_5+NXTCDR,,XALLB + QZFIX_5+NXTCDR+XNOUC,,XCMV + QZFIX_5+NXTCDR+XNOUC,,XC0MV + QZFIX_5+NXTCDR+XNOUC,,XRET2 + QZFIX_5+NXTCDR+XNOUC,,XRET3 + QZFIX_5+NXTCDR+XNOUC,,XRETN + QZFIX_5+NXTCDR+XNOUC,,XRNV + QZFIX_5+NXTCDR,,XGATP +; QZFIX_5+NXTCDR+XNOUC,,XAPLY + QZFIX_5+NXTCDR,,QIMSCR + QZFIX_5+NXTCDR+XNOUC,,XBIND + QZFIX_5+NXTCDR,,XGMADP + QZFIX_5+NXTCDR,,XMEMQ + QZFIX_5+NXTCDR,,XMLESS + QZFIX_5+NXTCDR,,XMGRTH + QZFIX_5+NXTCDR,,XMEQ + QZFIX_5+NXTCDR,,XIOPEN + QZFIX_5+NXTCDR,,XIUTYI + QZFIX_5+NXTCDR,,XIWRDR + QZFIX_5+NXTCDR,,XIUUTY + QZFIX_5+NXTCDR,,XSCSTR + QZFIX_5+NXTCDR,,XCADD + QZFIX_5+NXTCDR,,XCSUB + QZFIX_5+NXTCDR,,XCMUL + QZFIX_5+NXTCDR,,XCDIV + QZFIX_5+NXTCDR,,XCAND + QZFIX_5+NXTCDR,,XCXOR + QZFIX_5+NXTCDR,,XCIOR + QZFIX_5+NXTCDR,,XFALDR + QZFIX_5+NXTCDR,,XSALDR + QZFIX_5+NXTCDR,,XGLPA + QZFIX_5+NXTCDR,,XFARY + + QZFIX_5+NXTCDR,,XMAPLY + QZFIX_5+NXTCDR,,XSCRD + QZFIX_5+NXTCDR,,XRMB + QZFIX_5+NXTCDR,,XSMB + QZFIX_5+NXTCDR,,XSPDP + QZFIX_5+NXTCDR,,[HALT] ;P-GCB + QZFIX_5+NXTCDR,,XPUSRC + QZFIX_5+NXTCDR,,XPCDRC + QZFIX_5+NXTCDR,,XPDATP + QZFIX_5+NXTCDR,,XPDAT + QZFIX_5+NXTCDR,,[HALT] ;SP-GCB + QZFIX_5+NXTCDR,,XSPUSR + QZFIX_5+NXTCDR,,XSPCDR + QZFIX_5+NXTCDR,,XSPDTP + QZFIX_5+NXTCDR,,XSPDAT + QZFIX_5+NXTCDR,,[HALT] ;%GET-MISC-FCTN-ENTRY OBSOLETE + QZFIX_5+NXTCDR,,XRPDP + QZFIX_5+NXTCDR,,XGMPNT + QZFIX_5+NXTCDR+XNOUC,,XCTO + QZFIX_5+NXTCDR+XNOUC,,XCTOM + QZFIX_5+NXTCDR+XNOUC,,XERO + QZFIX_5+NXTCDR+XNOUC,,XEROM + QZFIX_5+NXTCDR+XNOUC,,XFEC + QZFIX_5+NXTCDR+XNOUC,,XFECM + QZFIX_5+NXTCDR+XNOUC,,XLEC + QZFIX_5+NXTCDR+XNOUC,,XLECM + QZFIX_5+NXTCDR,,XCATCH + QZFIX_5+NXTCDR,,XERRS + QZFIX_5+NXTCDR,,XTHROW + QZFIX_5+NXTCDR,,XERR + QZFIX_5+NXTCDR,,XPLDB + QZFIX_5+NXTCDR,,XPDPB + QZFIX_5+NXTCDR,,XMF + QZFIX_5+NXTCDR,,XPMF + QZFIX_5+NXTCDR,,XDF + QZFIX_5+NXTCDR,,XPDF + QZFIX_5+NXTCDR,,XCARC + QZFIX_5+NXTCDR,,XCARCL + QZFIX_5+NXTCDR,,XITSC + QZFIX_5+NXTCDR,,XAHLP + QZFIX_5+NXTCDR,,XISOUT + QZFIX_5+NXTCDR,,XFPIL + QZFIX_5+NXTCDR,,XFPILE + QZFIX_5+NXTCDR,,XGLPAR + QZFIX_5+NXTCDR,,XFPIV + QZFIX_5+NXTCDR,,XFPIVE + QZFIX_5+NXTCDR,,XAR1 + QZFIX_5+NXTCDR,,XAR2 + QZFIX_5+NXTCDR,,XAR3 + QZFIX_5+NXTCDR,,XAS1 + QZFIX_5+NXTCDR,,XAS2 + QZFIX_5+NXTCDR,,XAS3 + QZFIX_5+NXTCDR,,XTVINI + QZFIX_5+NXTCDR,,XTVSET + QZFIX_5+NXTCDR,,XTVREAD + QZFIX_5+NXTCDR,,XDRAWMODE + QZFIX_5+NXTCDR,,XHLINE + QZFIX_5+NXTCDR,,XVLINE + QZFIX_5+NXTCDR,,XSPQ + QZFIX_5+NXTCDR,,XOMR + QZFIX_5+NXTCDR,,XOMRH + QZFIX_5+NXTCDR,,XOMRL + QZFIX_5+NXTCDR,,XARGI + QZFIX_5+NXTCDR,,XOCB + QZFIX_5+NXTCDR,,XPUSH + QZFIX_5+NXTCDR,,XACTOB + QZFIX_5+NXTCDR,,XAPDLR + QZFIX_5+NXTCDR,,XSTGR + QZFIX_5+NXTCDR,,XSTGRM + QZFIX_5+NXTCDR,,[HALT] ;%TV-DRAW-CHAR + QZFIX_5+NXTCDR,,[HALT] ;%TV-ERASE + QZFIX_5+NXTCDR,,XCMVL + QZFIX_5+NXTCDR,,XC0MVL + QZFIX_5+NXTCDR,,XPSG + QZFIX_5+NXTCDR,,XOMS + QZFIX_5+NXTCDR,,XOMSH + QZFIX_5+NXTCDR,,XOMSL + QZFIX_5+NXTCDR,,XAIXL + QZFIX_5+NXTCDR,,XAAIXL + QZFIX_5+NXTCDR,,[HALT] ;%COMPUTE-PAGE-HASH + QZFIX_5+NXTCDR,,XGLOPR ;GET-LOCATIVE-POINTER-INTO-ARRAY + QZFIX_5+NXTCDR,,[HALT] ;%UNIBUS-READ + QZFIX_5+NXTCDR,,[HALT] ;%UNIBUS-WRITE + QZFIX_5+NXTCDR,,[HALT] ;%DISK-OPERATE + QZFIX_5+NXTCDR,,[HALT] ;%DISK-WAIT + QZFIX_5+NXTCDR,,XARN ;%AREA-NUMBER + QZFIX_5+NXTCDR,,XMAX + QZFIX_5+NXTCDR,,XMIN + QZFIX_5+NXTCDR,,XSNA + QZFIX_5+NXTCDR,,XCLOS ;CLOSURE + QZFIX_5+NXTCDR,,XDCLOS ;DOWNWARD-CLOSURE + QZFIX_5+NXTCDR,,XLISTP + QZFIX_5+NXTCDR,,XNLSTP + QZFIX_5+NXTCDR,,XSYMP + QZFIX_5+NXTCDR,,XNSYMP + QZFIX_5+NXTCDR,,XARRYP + QZFIX_5+NXTCDR,,XFCTNP + QZFIX_5+NXTCDR,,XSTRNP + QZFIX_5+NXTCDR,,XBOUNP + QZFIX_5+NXTCDR,,[HALT] ;\\ (GCD). + QZFIX_5+NXTCDR,,XFCTEV ;FUNCTION-EVAL + QZFIX_5+NXTCDR,,XAP1 ;AP-1 + QZFIX_5+NXTCDR,,XAP2 ;AP-2 + QZFIX_5+NXTCDR,,XAP3 ;AP-3 + QZFIX_5+NXTCDR,,XAPLD ;AP-LEADER + QZFIX_5+NXTCDR,,XOPLDB ;%P-LDB-OFFSET + QZFIX_5+NXTCDR,,XOPDPB ;%P-DPB-OFFSET + QZFIX_5+NXTCDR,,XOPMF ;%P-MASK-FIELD-OFFSET + QZFIX_5+NXTCDR,,XOPDF ;%P-DEPOSIT-FIELD + QZFIX_5+NXTCDR,,[HALT] ;%MULTIPLY-FRACTIONS + QZFIX_5+NXTCDR,,[HALT] ;%DIVIDE-DOUBLE + QZFIX_5+NXTCDR,,[HALT] ;%REMAINDER-DOUBLE + QZFIX_5+NXTCDR,,[HALT] ;HAULONG + QZFIX_5+NXTCDR,,[HALT] ;%ALLOCATE-AND-INITIALIZE + QZFIX_5+NXTCDR,,[HALT] ;%ALLOCATE-AND-INITIALIZE-ARRAY + QZFIX_5+NXTCDR,,[HALT] ;%MAKE-OFFSET-POINTER + QZFIX_5+NXTCDR,,[HALT] ;^ +MSFCTL==.-MSFCT + REPEAT 600-MSFCTL, QZSYM_5+NXTNIL,, ;FINISH OUT MISC-FUNCTION ENTRY AREA + +;SLASH AT END SIGNALS LAST ITEM +IRPS A,B,[MSFCT MSFCTL SPECBN SPCSTR MMCALL MMCALT P3ZERO QMARTH QMEQ QMGRP + QMLSP SECDR SECDDR SE1P SE1M PTRM BNDPOP BNDT SETIND XMISC SPCST1 + SNLST XLIST CBBLKP BNDPPN MMASU MMISU MVCALL MR2V MR2VV MR2VS MR2VVS + MR3V MR3VV MR3VS MR3VVS MRNV MRNVV MRNVS MRNVVS MURV MURVV MURVS MURVVS + NSKIP NNSKIP UAPLY QMA QMD QMAA QMAD QMDA QMDD QMAAA QMAAD QMADA QMADD QMDAA + QMDAD QMDDA QMDDD QMAAAA QMAAAD QMAADA QMAADD QMADAA QMADAD QMADDA QMADDD + QMDAAA QMDAAD QMDADA QMDADD QMDDAA QMDDAD QMDDDA QMDDDD XMBIND + MEM UCTO UERO UCTOM UEROM XTADD XTSUB XTMUL XTDIV XTAND XTXOR XTIOR + XTATOM XTZERO XTNUMB XTPLUP XTMNSP XTMNS XT1PLS XT1MNS XTSYME XTLENG + BOXPSH BOXT MMCALB XBZERO XBPLUP XBMNSP XBMNS XB1PLS XB1MNS + XMADD XMSUB XMMUL XMDIV XMAND XMXOR XMIOR + XTCADD XTCSUB XTCMUL XTCDIV XTCAND XTCXOR XTCIOR + BNDNIL UBDN/] + QZFIX_5+IFSN B,/,[NXTCDR]+.ELSE [NXTNIL],,A +TERMIN + +NMMSYM==.-.OANMS +IFG NMMSYM-CONC .LN,\ANMS,*HNPPG,.ERR MICRO-CODE SYMBOL TABLE OVERFLOW +LOC ZZQ + +END INIT + + \ No newline at end of file