perm filename LEAP[S,AIL]36 blob
sn#112364 filedate 1974-07-22 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00028 PAGES VERSION 17-1(53)
RECORD PAGE DESCRIPTION
00001 00001
00007 00002 HISTORY
00022 00003 Leap Generators.
00027 00004 NOW FOR THE DEFINITIONS OF ALL THE RUNTIME ROUTINES.
00033 00005 ZERODATA (LEAP VARIABLES)
00038 00006 DSCR LEPINI
00042 00007 DSCR LEAPC1, LEAPC2
00044 00008 DSCR STSET,LSTKCK,QUESET,FRESET
00049 00009
00053 00010 STCHK: PUSH P,D SAVE NUMBER OF PARAMS TO CHECK.
00064 00011 DSCR CHKSAT -
00065 00012 FOREACH STATEMENT HANDLERS.
00079 00013 ↑DERIV: DERIVED SETS.
00082 00014 DATUM HANDLERS
00089 00015 DSCR - PPSTO,EPPSTO,GETPROP execs for PROPS
00093 00016 MAKE AND ERASE
00095 00017 VARIOUS BOOLEANS.
00101 00018 DSCR DELT, SIPGO, STPRIM, ECVI, STLOP, PUTIN, LPPHI, etc.
00110 00019 DSCR PUTINL,HLDPNT,REMXD,REPLCX LISTGT
00114 00020 DSCR CVLS,LSSUB,SELIP,SELSBL
00119 00021 GETTING NEW ITEMS.
00130 00022 CASE, EXPRESSION CONDITIONALS.
00132 00023 STORE ROUTINES.
00138 00024
00142 00025 DSCR CALMP -MATCHING PROCEDURE EXECS
00148 00026 DSCR REMEMBER EXECS RMASET,RMBSET,RMSTK
00153 00027 EXECS FOR DYNAMIC BINDING OF PROC ITEMS
00156 00028 EXECS FOR APPLY
00158 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000065 ⊗;
COMMENT ⊗
VERSION 17-1(53) 6-28-74 BY JRL BUG #SR# DON'T ALLOW "PUT X IN LIST"
VERSION 17-1(52) 6-28-74 BY JRL BUG #SQ# BOOLEAN X IN LIST WAS COMPILED AS X IN SET
VERSION 17-1(51) 5-28-74 BY RHT BUG #SE#
VERSION 17-1(50) 5-22-74 BY RHT MODIFY ITMTYP TREATMENT OF RECORDS
VERSION 17-1(49) 5-20-74 BY RHT BUG #SB# REFITEM(STRING VALUE) NEEDED HELP
VERSION 17-1(48) 5-20-74 BY RHT BUG #RZ# TYPO AT SKKRFD
VERSION 17-1(47) 5-20-74
VERSION 17-1(46) 5-5-74 BY JRL FIX BUG RS AGAIN (WAS CHECKING LPITM RATHER THAN LPSET)
VERSION 17-1(45) 5-5-74 BY JRL BUG #RV# DON'T ALLOW LENGTH(ITEMEXPR)
VERSION 17-1(44) 5-1-74 BY RHT TWEAK DATUM TO ALLOW FOR RECORDS
VERSION 17-1(43) 4-12-74 BY RHT ADD RECORD INFO FOR ITMTYP & DATUM EXECS
VERSION 17-1(42) 4-12-74
VERSION 17-1(41) 4-12-74
VERSION 17-1(40) 4-7-74 BY JRL BUG #RS# GIVE ERROR MESSAGE FOR COP(ITEMEXPR)
VERSION 17-1(39) 3-22-74 BY JFR MORE REFITEM/STRING CONSTANT STUFF
VERSION 17-1(38) 3-22-74 BY JFR REFITEM STRING CONSTANT PROBLEMS
VERSION 17-1(37) 3-21-74 BY JRL BUG #RP# COLLECT TYPE BITS FOR STRING TEMP RFITEMS CORRECTLY
VERSION 17-1(36) 3-21-74
VERSION 17-1(35) 3-21-74
VERSION 17-1(34) 2-24-74 BY RHT FEAT %BH% -- ARGLIST
VERSION 17-1(33) 2-8-74 BY JRL BUG #RB# FORGOT TO INCLUDE THE GETD'S
VERSION 17-1(32) 2-6-74 BY JRL BUG #RC# MINOR FIX TO FEAT %BD% FOREACH'S WITHOUT BINDING LISTS
VERSION 17-1(31) 2-6-74 BY JRL BUG #RB# VARIOUS MISSING ACCESSES
VERSION 17-1(30) 1-22-74 BY JRL BUG #QN# DO IT RIGHT
VERSION 17-1(29) 1-22-74 BY RHT BUG #QN# MAKE BUG PX RECOVERABLE
VERSION 17-1(28) 1-7-74 BY JRL FEAT %BD% ALLOW FOREACHS WITHOUT BINDING LISTS
VERSION 17-1(27) 12-12-73 BY JRL BUG #PX# ADD MORE STACK-HEIGHT CHECKING
VERSION 17-1(26) 12-9-73 BY RHT PROVIDE GLBSET
VERSION 17-1(25) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(24) 12-1-73 BY JRL FEAT %AU% ALLOW FAIL, SUCCEED AS ITV EXPRESSIONS (NEW ROUTINE ONEITV)
VERSION 17-1(23) 11-29-73 BY JRL BUG #PH# BAD BOOLEAN CODE WITHIN FOREACH (FBOUT WAS SUPPRESSED)
VERSION 17-1(22) 11-25-73 BY JRL FEAT %AN% MOVE ITMSTRT(FEAT(%AG%) TO GEN
VERSION 17-1(21) 11-24-73 BY JRL BUG #PD# MAKE SURE LEAP STACK IN GOOD SHAPE BEFORE COND EXPR
VERSION 17-1(20) 11-15-73 BY RHT BUG #PB# NEEDED ALLSTO IN APPLY
VERSION 17-1(19) 11-4-73 BY JRL BUG #OY# DON'T ALLOW MAKE TO TAKE A SET ARGUMENT
VERSION 17-1(18) 10-23-73 BY JRL FEATURE %AG% ITEM OVERLAP STUFF
VERSION 17-1(17) 10-23-73 BY JRL FEATURE %AF% DIFFERENT SET AND LIST MEMBERSHIP BOOLEANS
VERSION 17-1(16) 10-23-73
VERSION 17-1(15) 10-19-73 BY JRL BUG #OQ# LOP DID NOT KNOW IT WAS A CONSTUCTIVE ITEM EXPR
VERSION 17-1(14) 10-14-73 BY JRL BUG #ON# AGAIN
VERSION 17-1(13) 10-14-73 BY JRL BUG #ON# ? FOREACH LOCALS BEING STACKED TOO EARLY
VERSION 17-1(11) 10-14-73 BY RHT BUG #OM# ANOTHER TYPO
VERSION 17-1(10) 10-14-73 BY RHT BUG #OK# ITEMS TREATED WRONG BY REF!ITEM
VERSION 17-1(9) 10-14-73 BY RHT BUG #OJ# SAPPL1 NEEDED A BLKGET
VERSION 17-1(8) 10-5-73 BY JRL MINOR ALLGLOBAL GLITCH FOR DATUM
VERSION 17-1(7) 8-30-73 BY JRL MOD GETITM SLIGHTLY TO MAKE MORE EFFICIENT
VERSION 17-1(6) 8-30-73 BY JRL BUG #NX# HANDLE DATUM(BINDIV,DATUM) CORRECTLY
VERSION 17-1(5) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(4) 8-13-73 BY JRL SAV SEMBLKS FOR BINDIT,ANY,MAINPI,EVTYPE
VERSION 17-1(3) 8-13-73 BY JRL BUG #NR# DRYROT REMOP STCNST IN NEW OF STC
VERSION 17-1(2) 8-5-73 BY JRL BUG #NM# RELATIONS INVOLVING BINDING ITEMVARS
VERSION 17-1(1) 7-26-73 BY RHT JUST CHECKING ON JRL
VERSION 17-1(0) 7-26-73 BY JRL **** VERSION 17 ****
VERSION 16-2(87) 7-14-73 BY RHT ADD EXECS FOR SPROUT APPLY
VERSION 16-2(86) 6-15-73 BY JRL BUG #MR# STRING ARRAY IS NOT A STRING
VERSION 16-2(85) 5-7-73 BY JRL ADD CONELM EXEC
VERSION 16-2(84) 4-2-73 BY JRL MAKE BNDTRP KNOW ABOUT GLOBAL
VERSION 16-2(83) 4-2-73 BY JRL CATCH NEW(ITEMEXPR) GIVE ERRMSG
VERSION 16-2(82) 3-19-73 BY JRL REMOVE POPSET
VERSION 16-2(81) 3-16-73 BY JRL BUG #LU# GLOBAL OPERATIONS
VERSION 16-2(80) 3-12-73 BY JRL REMOVE REFERENCES TO GAG SWITCH
VERSION 16-2(79) 3-8-73 BY JRL COMPILE LENGTH IN-LINE IF POSSIBLE
VERSION 16-2(78) 3-7-73 BY JRL STUFF FOR ALLGLOBAL
VERSION 16-2(77) 3-6-73 BY JRL ADD ALLGLOBAL FEATURE
VERSION 16-2(76) 3-6-73
VERSION 16-2(75) 2-26-73 BY JRL ANOTHER ATTEMPT TO FIX MP RETURN VALUES
VERSION 16-2(74) 2-26-73
VERSION 16-2(73) 2-26-73
VERSION 16-2(72) 2-19-73 BY JRL NOTE SUPERFLUOUS LEAP ROUTINES AS NOOPS
VERSION 16-2(71) 2-12-73 BY JRL ..RVAL NOW AN XX TYPE THING
VERSION 16-2(70) 2-12-73
VERSION 16-2(69) 2-9-73
VERSION 16-2(68) 2-7-73
VERSION 16-2(67) 2-7-73
VERSION 16-2(66) 2-7-73 BY RHT BUG #LH# ADEPTH PROBLEMS COPPIT,BINCL
VERSION 16-2(65) 2-7-73
VERSION 16-2(64) 2-7-73
VERSION 16-2(63) 2-7-73
VERSION 16-2(62) 2-7-73 BY JRL ROUTINE MPTEMP TO CREATE LOCAL VAR FOR MP
VERSION 16-2(61) 2-6-73 BY JRL ADD ERROR MESSAGE FOR BRACKETED TRIPLE,DERIVED SET IN FOREACH
VERSION 16-2(60) 2-5-73
VERSION 16-2(59) 2-5-73 BY JRL FIX MP'S FOR SPROUT
VERSION 16-2(58) 2-4-73 BY JRL BUG #LF# ITMREL ALWAYS POPPED STACK INTO AC 4
VERSION 16-2(57) 1-28-73 BY JRL BINDIT AS ALIAS OF UNBND
VERSION 16-2(56) 1-28-73 BY JRL ADD NULL!CONTEXT
VERSION 16-2(55) 1-23-73 BY JRL ANY NOW PREDECLARED "ITEM" FLUSH FROM COMPILER
VERSION 16-2(54) 1-22-73 BY JRL BUG #LE# HANDLE FOREACH ?X|X XOR X EQV FOO
VERSION 16-2(53) 1-22-73
VERSION 16-2(52) 1-9-73 BY JRL BUG #KZ# DATUM SHOULD TURN OFF OWN BIT
VERSION 16-2(51) 12-4-72 BY JRL ADD O EQV V DERIVED SET
VERSION 16-2(50) 12-1-72 BY JRL BUG #KO# CVLIST SHOULD MARK RESULT AS LIST
VERSION 16-2(49) 12-1-72
VERSION 16-2(48) 11-26-72 BY JRL ADD POTENTIAL ANY XOR ANY EQV ANY SEARCH
VERSION 16-2(47) 11-26-72 BY JRL BUG #KN# LTYPCK SHOULD RETURN IP FOR ITEM PRIMARY
VERSION 16-2(46) 11-21-72 BY JRL BUG #KJ# ECHK WITH ITEMVAR GAVE BAD TBITS
VERSION 16-2(45) 11-13-72 BY JRL COMPILE BETTER CODE FOR PROPS
VERSION 16-2(44) 11-10-72 BY JRL ADD EXEC FOR PROPS
VERSION 16-2(43) 11-8-72 BY JRL MAKE BOOLEAN CODE LIKE BOOLEAN FNS
VERSION 16-2(42) 11-8-72 BY JRL CHANGE ISIT TO PRODUCE INTEGER RATHER THAN BOOLEAN
VERSION 16-2(41) 11-7-72 BY JRL ADD BINDING ASSOCIATIVE BOOLEAN
VERSION 16-2(40) 11-6-72 BY JRL BUG #KA# MAKE SURE REMEMBER PARAMS IN CORE
VERSION 16-2(39) 11-6-72 BY JRL JUST GET CNST SEMBLK FOR CVN(DECL ITEM)
VERSION 16-2(38) 11-2-72 BY JRL REFERENCE SETS TO PUT REMOVE SHOULD BE REMOPPED
VERSION 16-2(37) 10-23-72 BY JRL COMPILE ITEM COMPARISONS INLINE
VERSION 16-2(36) 10-22-72 BY JRL MAKE JUMPE JRST TO JUMPN IN FRBOL
VERSION 16-2(35) 10-21-72 BY JRL MAKE CATLST KNOWN TO WORLD
VERSION 16-2(34) 10-20-72 BY RHT BUG #JS# ADJUST ADEPTH IN EVLLST & EVLNLL
VERSION 16-2(33) 10-8-72 BY JRL BUG ##J#O# ADD ROUTINE LTYPCK TO MAKE AE GO TO IP OR SP
VERSION 16-2(32) 10-8-72 BY JRL BUG #JN# STORE DUMMY SEMBLK FOR DERIVED SET IN PARSE STACK
VERSION 16-2(31) 10-3-72 BY JRL OPTIMIZE CVN CODE
VERSION 16-2(30) 10-3-72 BY JRL OPTIMIZE FRCHPOP(DO ONLY WHEN NECESSARY)
VERSION 16-2(29) 10-2-72 BY JRL COMPILE POPTOP ITEM(ECHK) IN-LINE
VERSION 16-2(28) 9-27-72 BY JRL IMPROVE THE STOR1 OPERATION FOR ITEMVARS
VERSION 16-2(27) 9-26-72 BY JRL ADD DATUM(IT,TYPE) FACILITY
VERSION 16-2(26) 9-21-72 BY JRL DECLARE PREDECLARED ITEMS
VERSION 16-2(25) 9-12-72 BY JRL CHANGE DATUM TO USE GDATM PROPERLY
VERSION 16-2(24) 9-11-72 BY JRL MAKE ECVI HONEST ABOUT TYPE
VERSION 16-2(23) 9-8-72 BY JRL ADD CODE TO HANDLE ? LOCALS
VERSION 16-2(22) 9-5-72 BY JRL FORCE STAKIT TO HANDLE ? PARAMETERS
VERSION 16-2(21) 9-1-72 BY KVL MAKE CHECK ON UNTYPED ITEMVARS
VERSION 16-2(20) 8-24-72 BY JRL CHANGE BNDLST TO ALLOW SETS
VERSION 16-2(19) 8-23-72 BY JRL FIX FOR LIST WITH ITEMVAR BUG
VERSION 16-2(18) 8-21-72 BY JRL STORE ITEMS BY EITHER POP OR MOVEM (NOT LEAP CALL)
VERSION 16-2(17) 8-20-72 BY JRL TURN OFF LPFREE IN STAKIT RATHER THAN STITM
VERSION 16-2(16) 8-17-72 BY JRL HANDLE DISPLAY ITEMVAR LOCALS TO FOREACH
VERSION 16-2(15) 8-14-72 BY RHT FIX JRL
VERSION 16-2(14) 8-12-72 BY RHT MODIFY LODPDA TO HANDLE EXTERNAL PROCEDURES
VERSION 16-2(13) 8-10-72 BY JRL ADD REMEMBER, FORGET EXECS
VERSION 16-2(12) 8-9-72 BY JRL CHANGE "GLOBAL" KLUDGE SEE GLBST2
VERSION 16-2(11) 7-2-72 BY JRL ADD LEAPIS AND CLEAN UP LPXISX
VERSION 16-2(10) 6-23-72 BY RHT CHANGE LPSET,LPXISX TO LPSET!LPXISX JUST BEFORE BUG #HW# ON P 16
VERSION 16-2(9) 6-22-72 BY JRL CATCH SET ITMVR←SET
VERSION 16-2(8) 6-21-72 BY RHT FIX THINGS SO PDA NOT FIXED UP AFTER PD IS OUT
VERSION 16-2(7) 6-20-72 BY JRL BUG #HR# USE FIXUP IN LOADING SATIS BLK ADDR RATHER THAN REL. ADDR
VERSION 16-2(6) 6-12-72 BY JRL ADD BNDLST EXEC
VERSION 16-2(5) 6-8-72 BY DCS INSTALL VERSION 16
VERSION 15-2(4) 2-22-72
⊗;
SUBTTL Leap Generators.
LSTON (LEAP)
NOGEN
BEGIN LEAP
DSCR -- LEAP EXECS
SEE Comment below, and later, for sketchy details
⊗
COMMENT ⊗
These are the generators to handle the LEAP constructs. Supposedly,
everything is conditionally assembled so that if LEAPSW is not
on, you will get a smaller, faster and less elegant compiler.
The SET and ITEM expression manipulators really just call run time
routines to stack things on some pseudo-stack. The various Bool-
ean and operational operators are then implemented as calls on
the runtime interpreter. At compiler time, a "copy" of that stack
is kept around. This is for purposes of type checking, checking
to see that things are bound at the right times, etc.
The first section of this code deals with this compile-time stack.
Every time a LEAP type primary is scanned, either STSET or STITM
is called to place the token on the stack and to pass the things
off to the runtime routines. Any generators designed to make use
of this stack mechanism should be careful to adjust things.
⊗
;VARIOUS MACRO DEFINITIONS FOR US.....
DEFINE STAKCHECK (X,Y) <
IFDIF <Y><>,<MOVNI D,X>
IFIDN <Y><>,<MOVEI D,X>
PUSHJ P,STCHK
>
DEFINE CONCHK <
TLNN A,CNSTR
ERR <RETRIEVAL - CONSTRUCTION FAILURE>,1
>
DEFINE RETCHK <
TLNN A,RETRV
ERR <RETRIEVAL - CONSTRUCTION FAILURE>,1
>
DEFINE SETCHK (N) <
IFDIF <N><>,<MOVEI D,N>
PUSHJ P,CHKSET ;SEE IF REQUIRED NUMBER OF SETS
>
;BITS FOR LOCAL ITEMVAR ADDRESSES in FOREACH SATISFIER BLOCK
CDISP ←← 100000 ;THIS PARM NEEDS A DISPLAY CALCULATION
MPPAR ←← 200000 ;THIS IS ? FORMAL PARAMETER
POTUNB ←← 400000 ;THIS IS A ? LOCAL
;VARIOUS BIT DEFINITIONS FOR THE LEAP RUNTIME STACK.
;SEVERAL (THOSE ***'ED) ARE PASSED ON TO THE RUNTIMES -- CAREFUL.
LPSET ←← 1 ;THIS IS A SET *********
BINDING ←← 2 ;THIS IS A LOCAL BEING BOUND ********
BOUND ←← 4 ;THIS IS A LOCAL THAT IS BOUND ********
LPXISX ←← 20 ;THIS IS A LIST, LPSET ALSO ON ****
DUMSEM ←← 40 ;THE LEAP STACK ENTRY IS A DUMMY
↑↑LPITM ←← 40000 ;AN ITEM.
RETRV ←← 20000 ;RETRIEVAL CONTEXT IS OK.
CNSTR ←← 10000 ;CONSTRUCTION CONTEXT IS OK.
LPDMY ←← 4000 ;THIS IS A BRAND NEW, MADE-
;UP LOCAL NUMBER. FOR BRACKETED
;TRIPLE OR DERIVED SET WITHIN FOREACH
STACKET ←← 2000 ;THIS THING IS REALLY STACKED ....
LPNUL ←← 1000 ; "PHI" LPSET ON ALSO
;FBIND AND QBIND NOW DEFINED IN HEAD
; FBIND ←← 100 ;BIND ITVMR AS IN BIND X XOR Y EQV Z
; QBIND ←← 200 ;? ITMVR AS IN BIND X XOR Y EQV Z
BRACKET ←← 400000 ;THIS IS A BRACKETED SEARCH ****
; **** MUST BE SIGN BIT FOR RUNTIMES
;**** (ONLY)
GLOC <
GLBSRC ←← 200000 ;THIS IS A GLOBAL SEARCH ******
>;GLOC
FOREA ←← 40000 ;THIS IS INSIDE A FOREACH LIST
; (BUT NOT USED)
SETOP ←← 20000 ;THIS IS A SET OPERATION.
ATTPOS ←← 6 ;POSITIONS OF TYPE BITS.
;IN CONTROL WORD.
OBJPOS ←← 3
VALPOS ←← 0
;NOW FOR THE DEFINITIONS OF ALL THE RUNTIME ROUTINES.
DEFINE RUNTIM ' (X,Y) <
L'X ←← MYCOUNT!GLOFLG
IFDIF <Y><>,<MYCOUNT←←MYCOUNT+Y>
IFIDN <Y><>,<MYCOUNT←←MYCOUNT+1>
GLOFLG←←0
>
DEFINE GLO <
GLOC <
GLOFLG ←← 400000
>;GLOC
>
MYCOUNT ←←0
GLOFLG ←←0
GLO RUNTIM TRIPLES ;0--ORDINARY TRIPLE SEARCHES
RUNTIM NOOP1,7 ;1-7 NO LONGER USED.
RUNTIM STSRC,2 ;THE SET SEARCHES ?
RUNTIM FRCHGO ;12--BEGINNING OF FOREACH LIST.
RUNTIM FRCHPOP ;13--POP SATISFIERS INTO CORE
RUNTIM FRLOOP ;14--LOOP BACK FOR MORE (FOREACH STATE.)
RUNTIM FRFAL ;15--BOOLEAN FALSE.
GLO RUNTIM MAKE ;16--MAKE
GLO RUNTIM BMAKE ;17--BRACKETED TRIPLE MAKE.
GLO RUNTIM ERAS ;20--ERASE ROUTINES.
RUNTIM NOOP2,7 ;21-27 NO LONGER USED
GLO RUNTIM ISTRIP ;30-BOOLEAN "IS THIS A BRACKETED TRIPLE"
GLO RUNTIM SELECT,3 ;31-33--SELECTORS.
RUNTIM CORPOP ;34 --MOVE CORE TO SATISFIER TABLE
GLO RUNTIM LDERIV,3 ;35-37--DERIVED SETS DURING FOREACH LISTS.
GLO RUNTIM DERIV,3 ;40-42--DERIVED SETS, NOT DURING FOREACH.
GLO RUNTIM DELETE ;43 -DELETE THIS ITEM.
GLO RUNTIM NEWITM ;44--MAKE A NEW ONE.
GLO RUNTIM NEWARITH ;45--MAKE A NEW ARITHMETIC TIEM.
GLO RUNTIM NEWRY ;46--MAKE A NEW ARRAY ITEM.
RUNTIM FRELS ;47--RELEASE THE FOREACH BLOCK
RUNTIM STPUT ;50--PUT
RUNTIM STREM ;51--REMOVE
RUNTIM SIP ;52--SET MAKERS( SETO SETC )
;; %AF% ! (1 OF 3) DIFFERENT ROUTINES FOR MEMBERSHIP BOOLEANS
RUNTIM LSTIN ;53--BOOLEAN A IN LIST?
RUNTIM SETCUNT ;54--LENGTH OF A SET OR LIST
RUNTIM STUNT ;55--COP OF A SET
RUNTIM STUNI ;56--SET UNION
RUNTIM STINT ;57--SET INTERSECTION
RUNTIM STMIN ;60--SET SUBTRACTION.
RUNTIM STORE ;61--STORE A SET OR ITEM
RUNTIM STORBUTDONTREMOVE ;62--EXPRESSION STORE(LEAVE ON STACK)
;; %AF% ! (2 OF 3) DIFFERENT ROUTINES FOR MEMBERSHIP BOOLEANS
RUNTIM STIN ;63--BOOLEAN A IN SET?
RUNTIM NOOPA ;64--NO-OP USED TO BE POP OFF SET
RUNTIM SETREL,6 ;65-72 SET RELATIONS.
GLO RUNTIM ISIT ;73--A XOR O EQV V ?
RUNTIM NOOP4,7 ;74-102 NO LONGER IN USE
GLO RUNTIM BRTRIP ;103-[A XOR O EQV V] AND LEAVE ON STACK.
RUNTIM NOOP5,7 ;104-112 NO LONGER IN USE
GLO RUNTIM ITMRY ;113--THE TWO GUYS FOR MARKING ARRAYS.
RUNTIM ITMYR ;114
RUNTIM STLOP ;115--LOP OFF AN ITEM FROM A SET.
GLO RUNTIM BNDTRP ;116--BIND X XOR BIND Y EQV BIND Z (BOOLEAN)
RUNTIM SETCOP ;117--COPY A FORMAL SET (ADDRESS IN TAC1)
RUNTIM SETRCL ;120--RECLAIM A FORMAL SET ( "" )
RUNTIM CATLST ;121--CONCATENATE TWO LISTS
RUNTIM PUTAFT ;122--PUT AFTER ITEM
RUNTIM PUTBEF ;123--PUT BEFORE ITEM
RUNTIM SELFET ;124--SELECT LIST ELEMENT
RUNTIM TSBLST ;125--TO SUBLIST
RUNTIM FSBLST ;126--FOR SUBLIST
RUNTIM SETLST ;127--TRANSFORM LIST TO SET CVSET
RUNTIM RPLAC ;130--REPLACE ELEMENT OF LIST
RUNTIM REMX ;131--REMOVE INDEXED
RUNTIM REMALL ;132--REMOVE ALL
RUNTIM PUTXA ;133--PUT AFTER INDEXED
RUNTIM PUTXB ;134--PUT BEFORE INDEXED
RUNTIM LSTMAK ;135--ADD TO TEMPORARY LIST (LISTO LISTC)
RUNTIM MATCAL ;136--CALL A MATCHING PROCEDURE
RUNTIM STK4VL ;137--STACK A ? LOCAL
RUNTIM STKQPR ;140--STACK A ? LOCAL AS AN MP ARGUMENT
;;FOLLOWING FOR LPCALLS FROM OTHER SOURCE FILES
↑LCATLS ←← LCATLS ;RETURN MUST COPY RESULT
↑LSTKQP ←← LSTKQP ;CALARG-STACKS QUES PARAMS
↑LFRLOO ←← LFRLOO ;LOOP CODE MUST BE ABLE TO LOOP BACK
↑LFRELS ←← LFRELS ;DONE ETC, MUST BE ABLE TO EXIT FOREACH
↑LITMRY ←← LITMRY ;ARRAY DECLARATION
↑LITMYR ←← LITMYR ;ARRAY DECLARATION
↑LSETCO ←← LSETCO ;COPY SET FORMALS
↑LSETRC ←← LSETRC ;RECLAIM SET FORMALS
ZERODATA (LEAP VARIABLES)
;MPSTAK A QSTACK OF ALL MATCHING PROCEDURES WHOSE ENDS HAVE NOT
;BEEN SEEN
↑↑MPSTAK:0
;MPVSTK A QSTACK OF XWD ?TABLE ADDR,STATIC LEVEL OF MATCH PROC
↑↑MPVSTK:0
;MPQSTK: A QSTACK FOR ? ITEMVAR PARAMS TO MATCHING PROCEDURE
↑↑MPQSTK: 0
;LEAPIS -- ZERO IF NO LEAP CONSTRUCTS, -1 IF LEAP USED BY COMPILED PROG.
↑↑LEAPIS: 0
;SATADR -- CONTAINS ADDR FIXUP FOR SATISFIER BLOCK FOR FRCHGO
?SATADR: 0
;BBWORD,INDEX4 used in STCHK to give type bits to ? FOREACH locals
?BBWORD: 0
?INDEX4: 0
;BYTES -- a parameter to LPCALL, specifies type bits, etc.
↑↑BYTES: 0
?FFSAVE: 0 ;SAVE FF SOMETIMES
;; #PX# (1 OF 13)
;LEADUM -- ZERO WORD BEFORE LEABEG FOR STACK UNDERFLOW CHECKING
?LEADUM: 0
;; #PX
;LEABEG -- LEAP "push-down stack" -- used to model the runtime stack,
; keep track of things
?LEABEG: BLOCK 40
;LEAPSK -- LEABEG "PDP" -- points to last LEABEG entry
↑↑LEAPSK: 0
;DATBITS + HOLDS TYPE BITS FOR DATUM CONSTRUCT
DATBITS: 0
;HLDCNT - COUNT OF ?FOREACH LOCALS IN SEARCH
;HLD- SEMBLK POINTERS FOR ABOVE, TO HANDLE MISERABLE
; FOREACH ?X | X XOR X EQV FOO DO
?HLDCNT: 0
?HLD: BLOCK 3
;LEPGLB -- counter set when LEAP operation preceded by GLOBAL
;When the operation is scanned (NEW,⊗,DELETE,DATUM,etc) this value is pushed
;onto the GLBSTK qstack. This is so that constructs such as
; GLOBAL NEW( DATUM (x)) is handled correctly.
↑↑LEPGLB: 0
;GLBSTK A QSTACK TO HANDLE GLOBAL CONSTRUCTS.
↑↑GLBSTK: 0
;ALLGLO -- indicates all leap operations are to be considered global
↑↑ALLGLO: 0
;LOCALCOUNT -- number of bound locals in a FOREACH call
?LOCALCOUNT: 0
;LOCBEG -- QTAK descriptor into LOCST's QSTACK for FRCHGO call --
; first collects local names, then puts them out after call
; see FTRPRM for similar mechanism
?LOCBEG: 0
;LOCST -- the QPUSH/POP descriptor for the stack described above
; in LOCBEG
?LOCST: 0
?MADEUPLOCALS: 0 ;TEMP IN BRACKETED TRIPLES CODE
;MKFLAG -- tells bracketed triple stuff it's inside a MAKE
?MKFLAG: 0
;PARBEG -- a temporary pointer into LEABEG stack sometimes
?PARBEG: 0
;PNBEG, PNLST, PNMSW -- temps for PNAMES stuff in compiler
↑↑PNBEG: 0 ;QTAK pointer for PNLST
↑↑PNLST: 0 ;qstack for printnames
↑↑PNMSW: 0 ;non-zero if pnames required
;ITMSTK - Q-STACK FOR ITEM#'S,TYPES,ITMBEG,ITMCNT ALSO ASSOC.
↑↑ITMSTK: 0 ;QSTACK containing item-type,,item
↑↑ITMBEG: 0 ;QTAK pointer for ITMSTK
↑↑ITMCNT: 0 ;count of all items including GLOBALS
;HOLDPT - CROCK FOR REFERENCE LIST PARAMS. TO LEAP
;LORSET - QSTACK, TOP ELEM.INDICATES IF MAKING LIST OR SET see sip
;REMASET: FLAG ON IF REMOVE ALL CONSTRUCT
↑↑HOLDPT: 0
↑↑LORSET: 0
↑↑REMASET: 0
PHIBLK: 0 ;DUMMY SEMANTIC BLOCK FOR SETS ON STACK
NILBLK: 0 ;DUMMY SEMANTIC BLOCK FOR LISTS ON STACK
NULLCN: 0 ;DUMMY SEMANTIC BLOCK FOR NULL!CONTEXT
↑↑REMCEL: 0 ;SAVE ROUTINE NAME REMEMBER,FORGET RESTORE
;NEDPOP - FLAG -1 IF SOME SEARCH (WITHIN FOREACH) HAS POSSIBLY VOIDED THE CURREN
;SATISFIERS IN CORE
NEDPOP: 0
;BNDFLG -FLAG ON IF STCHK HAS SEEN A BIND
BNDFLG: 0
ENDDATA
DSCR LEPINI
CAL PUSHJ FROM GENINI
DES SETS UP ALL LEAP-SPECIFIC VARIABLES BEFORE EACH COMPILATION
⊗
DEFINE NAMEIT(NAME,TYPE,ITNO,SBNAME) <
HRROI TEMP,NAME+1
POP TEMP,PNAME+1
POP TEMP,PNAME
MOVEWI (BITS,TYPE)
MOVE LPSA,SYMTAB
PUSHJ P,SHASH
PUSHJ P,ENTERS
MOVE PNT,NEWSYM
IFDIF <ITNO><>,<
PUSH P,PNT
MOVEI A,ITNO
PUSHJ P,CREINT
POP P,LPSA
HRRZM PNT,$VAL2(LPSA)
>
IFDIF <SBNAME><>,<
MOVEM LPSA,SBNAME
>
>
;PREDECLARED ITEM NAMES
UBNAME: XWD 0,7
POINT 7,.+1
ASCII /UNBOUND/
MINAME: XWD 0,6
POINT 7,.+1
ASCII /MAINPI/
NINAME: XWD 0,3
POINT 7,.+1
ASCII /NIC/
EVNAME: XWD 0,6
POINT 7,.+1
ASCII /EVTYPI/
EV2NAM: XWD 0,12
POINT 7,.+1
ASCII /EVENT_TYPE/
ANYNAM: XWD 0,3
POINT 7,.+1
ASCII /ANY/
BINNAM: XWD 0,6
POINT 7,.+1
ASCII /BINDIT/
ZERODATA(LEAP ITEM SEMBLK PTRS)
↑UBSBLK: 0; BINDIT
↑EVSBLK: 0; EVTYPI
↑ANSBLK: 0; ANY
↑MPSBLK: 0; MAINPI
ENDDATA
↑↑LEPINI:
QPUSH (LOCST)
QPOP (LOCST)
MOVE A,LOCST
MOVEM A,LOCBEG
MOVEI A,LEABEG-1
MOVEM A,LEAPSK
;; %AG% ITEM!START STUFF
MOVE A,[XWD 11,10] ;DEFAULT ITEM!START IS 11
MOVEM A,ITEMNO ;LEAVE SOME FOR LEAP TO PLAY WITH.
GLOC <
MOVEI A,7777 ;MAXIMUM GLOBAL ITEM
MOVEM A,GITEMNO ;AND RECORD IT.
>;GLOC
QPUSH (MPSTAK,[0])
QPUSH (ITMSTK)
QPOP (ITMSTK)
MOVE A,ITMSTK
MOVEM A,ITMBEG ;SAVE FOR USING QTAKE
QPUSH (MPQSTK,[0]) ;FLAG TO MARK END OF MPQSTK
GETBLK (PHIBLK)
MOVEI A,SET
MOVEM A,$TBITS(LPSA) ;DUMMY SEMANTIC BLOCK FOR PHI(NULL SET)
GETBLK (NILBLK)
MOVEI A,SET!LSTBIT
MOVEM A,$TBITS(LPSA)
GETBLK (NULLCN) ;DUMMY SEMBLK FOR NULL!CONTEXT
MOVEI A,FLOTNG!SET ;CONTEXT
MOVEM A,$TBITS(LPSA)
POPJ P,
↑↑LPNAME:NAMEIT (UBNAME,ITEM,UNBND,UBSBLK) ;DECLARE PREDECLARED IDENTIFIERS
NAMEIT (MINAME,ITEM,MAINPI,MPSBLK)
NAMEIT (NINAME,ITEM,NIC)
NAMEIT (EVNAME,ITEM,EVTYPI,EVSBLK)
NAMEIT (EV2NAM,ITEM,EVTYPI)
NAMEIT (ANYNAM,ITEM,0,ANSBLK)
NAMEIT (BINNAM,ITEM,UNBND) ;AN ALIAS FOR UNBOUND
MOVEI TEMP,RESYM ;SO DONES WILL WORK CORRECTLY
MOVEM TEMP,VARB
POPJ P,
DSCR LEAPC1, LEAPC2
PRO LEAPC1 LEAPC2
These routines are called by the LPCALL macro to generate the
call to LEAP. Both use left half of BYTES to form control
bits for flag word. LEAPC2 also adds right half of BYTES
to routine dispatch number.
PAR A contains the dispatch number of routine to be called.
⊗
↑LEAPC2: ;LEAP CALL OF FIRST VARIETY.
ADD A,BYTES ;USES INDICES COMPUTED BY STCHK
SKIPA
↑LEAPC1:
HLL A,BYTES ;JUST THE TYPES COMPUTED BY STCHK.
SETOM LEAPIS ;SOMEONE USED LEAP.
PUSH P,LPSA ;
PUSH P,TBITS ;SO CAN RESTORE LATER
PUSH P,SBITS
PUSH P,PNT
PUSH P,D
PUSH P,A
PUSHJ P,ALLSTO ;SO LEAP DOESN'T HAVE TO SAVE ACS
POP P,A ;GET FLAG WORD BACK AGAIN
GLOC <
TRZN A,400000 ;LEGAL GLOBAL OPERATION
JRST NGLBOP ;NO.
PUSH P,A ;SAVE OVER QSTAK STUFF.
QPOP (GLBSTK)
MOVE B,A
POP P,A
SKIPN ALLGLO ;EVERYTHING GLOBAL??
CAIE B,0 ;PREFACED BY GLOBAL?
TLO A,GLBSRC ;YES.
NGLBOP:
>;GLOC
PUSHJ P,CREINT ;AN INTEGER CONSTANT
EMIT <MOVE 5,NOUSAC> ;LOAD FLAG WITH CONTROL BITS, ROUTINE NAME
SETZM BYTES ;FOR NEXT TIME
XCALL (LEAP)
POP P,D
POP P,PNT ;RESTORE
POP P,SBITS
POP P,TBITS
POP P,LPSA
POPJ P, ;EXIT
DSCR STSET,LSTKCK,QUESET,FRESET
PRO STSET
STSET, STITM exec routines called whenever a set or item is scanned.
Stacks entry onto LEAPSK and generates actual stack for previous top
of LEAPSK if any unless within foreach statement.
⊗
↑STSET: ↑STITM: ;CALLED EACH TIME A SET OR ITEM IS SCANNED
GETSEM (1) ;SEMANTICS OF ITEM OR SET
TLNE FF,LPPROG ;A FOREACH IN PROGRESS?
JRST JUSTAK ;YES -- DO NOT STACK ON RUNTIME STACK
PUSH P,PNT
MOVE D,LEAPSK
CAIL D,LEABEG
PUSHJ P,STAKIT ;STACK THE PREVIOUS THING.
POP P,PNT
PUSHJ P,GETAD
TLNE SBITS,LPFREE ;NOT FREE NOW, IS IT?
ERR <FREE ITEMVAR IN BAD SPOT>,1 ; WE MUST BE INSIDE A BOOLEAN SINCE
;LPPROG IS OFF, THEREFORE CAN'T USE
;UNBOUND LOCALS.
JUSTAK: HRRZI A,(PNT)
TLO A,RETRV!CNSTR ;TURN ALL THESE ON INITIALLY.
TLNE SBITS,LPFRCH!FREEBD ;A LOCAL IN THIS FOREACH?
TLO A,BOUND ;SAY BOUND
TLNE SBITS,LPFREE ;A FREE LOCAL?
TLC A,BOUND!BINDING ;SAY BINDING and ¬BOUND
;FOLLOWING INSTRUCTION REMOVED SO THAT MATCHING PROCEDURES MAY KNOW IF
;THERE PARAMS ARE UNBOUND (LPFREE ON);
;THE CODE IN STCHK HAS BEEN ALTERED ACCORDINGLY
; MOVEM SBITS,$SBITS(PNT) ;IN CASE IT WAS CHANGED.
TLNE SBITS,FREEBD ;A ? LOCAL
TLZ A,BINDING ;A FREE ? LOCAL IS NEITHER BOUND NOR BINDING
TRNE TBITS,ITEM!ITMVAR ;WHICH LEAP TYPE?
JRST [TLO A,LPITM ;AN ITEM
JRST TYPKWN]
TLO A,LPSET ;A SET.
TRNE TBITS,LSTBIT
TLO A,LPXISX ;A LIST
TYPKWN: AOS B,LEAPSK ;INCREMENT STACK POINTER.
CAIL B,LEABEG+MAXLOC ;GONE TOO FAR?
ERR <LEAP PUSH-DOWN OVERFLOW>,1
MOVEM A,(B) ;STORE THE ENTRY.
; THE FOLLOWING HACK IS TO ALLOW COMPLICATED SET OR LIST EXPRESSIONS TO
; BE ARGUMENTS TO NEW. SINCE NEW GETS TYPE OF EXPRESSION FROM PARSE STACK
TLNE SBITS,INUSE ;IF NOT A TEMP DON'T BOTHER
TRNE TBITS,ITEM!ITMVAR ;IF ITEM DON'T BOTHER
POPJ P,
MOVE A,PHIBLK ;ASSUME SET
TRNE TBITS,LSTBIT
MOVE A,NILBLK ;DUMMY LIST SEMBLK
MOVEM A,GENRIG+1 ;NEW PARSE STACK ENTRY
POPJ P,
↑QUESET:SKIPA A,[QBIND,,0] ;A ? TYPE OF ASSOCIATIVE BOOLEAN
↑FRESET: ;AN ASSOCIATIVE BOOLEAN OF BIND FORM
HRLZI A,FBIND ;THE BIT
TLNE FF,LPPROG ;INSIDE FOREACH
ERR <BIND OR ? NOT VALID WITHIN FOREACH>,1
ORM A,@LEAPSK
POPJ P,
;; #PX# (2 OF 13) ADD SOME STACK HEIGHT ERROR CHECKING
↑LSTKCK:
HRRZ TEMP,LEAPSK
CAIE TEMP,LEABEG-1 ;NON-EMPTY STACK OR UNDERFLOW?
;;#QN# ! 1 OF 3
ERR <DRYROT:LEAPSK>,1,.LSKFX
.TSTAD:
SKIPN ADEPTH ;ALSO CHECK ADEPTH, SDEPTH
SKIPE SDEPTH
;;#QN# ! 2 OF 3
ERR <DRYROT:ADEPTH,SDEPTH>,1,.DPTFX
.DPTOK:
GLOC <
SKIPE LEPGLB ;COUNT OF NUMBER OF GLOBALS SEEN
ERR <GLOBAL SAID TOO MANY TIMES>,1
SETZM LEPGLB
>;GLOC
POPJ P,
;; #PX#
;;#QN# 3 OF 3 MAKE THESE ERRORS A BIT MORE RECOVERABLE
.LSKFX: MOVEI TEMP,LEABEG-1 ;FIX STACK
MOVEM TEMP,LEAPSK
JRST .TSTAD
.DPTFX: SETZM ADEPTH
SETZM SDEPTH
JRST .DPTOK
;;#QN#
COMMENT @
HERE ARE THE PEOPLE WHO LOOK AT THE COMPILE TIME STACK.
LASCHK -- MAKES SURE THAT TOP OF COMPILE STACK IS REALLY
STACKED -- THIS IS FOR CASE STATEMENTS,EXPR. CONDITIONALS. ETC.
STCHK -- GUARANTEES THAT N (PASSED IN D) ARGUMENTS ARE IN THE RIGHT
ORDER ON THE RUNTIME STACK. THIS IS ONLY COMPLICATED WHEN
PARSING A FOREACH LIST, SINCE THIS IS THE ONLY CIRCUMSTANCE
IN WHICH REAL STACKING IS DEFERED.
THE REASON REAL STACKING IS DEFERRED DURING FOREACH LISTS IS
THE FOLLOWING:
FOREACH X,Y,Z | A XOR X EQV [B XOR Y EQV Z] DO .....
GETS CHANGED INTO --
FOREACH X,Y,Z | [B XOR Y EQV Z]=Q AND A XOR X EQV Q DO .....
WITH THE PARTICULAR FORM OF INTERPRETER DESIGNED FOR THESE THINGS,
THERE CAN BE NOTHING REMEMBERED IN THE STACK OVER
A SEARCH OPERATION (E.G. OVER THE "AND" IN THE REARRANGED EXAMPLE ABOVE.
@
↑↑OKSTACK: MOVE D,LEAPSK ;CHECK TO SEE IF TOP OF STACK
;; #ON# (1 OF 2) DON'T PREMATURELY STACK ? FOREACH LOCALS
MOVE PNT,(D)
CAIL D,LEABEG ;IS REALLY STACKED.
TLNE PNT,STACKED
POPJ P, ;ALREADY STACKED
MOVE TEMP,$SBITS(PNT)
TLNE TEMP,LPFREE
TLNN TEMP,FREEBD
JRST STAKIT
POPJ P,
;; #ON#
;; #JO# BY JRL 10-8-72 ROUTINE TO TAKE AE TO EITHER IP OR SP
↑LTYPCK: ;MAKE AE GO TO EITHER SP OR IP
;; #PX# (3 OF 13) SOME REDUNDANT LEAPSK CHECKING
SKIPN A,@LEAPSK ;TOP OF STACK ENTRY
ERR <DRYROT:LEAPSK UNDERFLOW>,1
;; #PX#
MOVE B,%NIP ;ASSUME ITEM
;; #KN# 11-26-72 FOLLOWING INSTR WAS ERRONEOUSLY TLNN
TLNE A,LPSET!LPXISX ;LIST OR SET?
MOVE B,%NSP ;YES
MOVEM B,PARRIG+1 ;INTO PARSE STACK
POPJ P,
;; #JO#
↑BNDITM:
PUSHJ P,OKSTACK ;MAKE SURE ITS STACKED
SOS B,LEAPSK ;TOP OF STACK
CAIE B,LEABEG-1 ;MAKE SURE WAS ONLY 1 ITEM
ERR <MUST BE ITEM EXPRESSION>
MOVE A,1(B) ;OLD TOP OF STACK
TLNN A,LPITM ;TEST IF REALLY ITEM
ERR <BNDITM- ASSOC EXPR MUST BE ITEM>,1
POPJ P,
↑BNDLST:
PUSHJ P,OKSTACK
SOS B,LEAPSK ;TOP OF STACK
CAIE B,LEABEG-1 ;MAKE SURE ONLY SINGLE LIST
ERR <MUST BE LIST EXPRESSION>,1
MOVE A,1(B) ;OLD TOP OF STACK
TLNN A,LPSET
ERR <LIST EXPRESSION REQUIRED>,1
POPJ P,
LASCHK: MOVE D,LEAPSK ;CURRENT TOP OF STACK.
PUSHJ P,STAKIT ;MAKE SURE THAT IT IS STACKED.
PUSH P,[1] ;ONE PARAMETER.
MOVE A,LEAPSK
MOVEM A,PARBEG ;ONE PARAMETER.
JRST POP0 ;GO DO THE STUFF ON
;THE COMPILE-TIME STACK.
STCHK: PUSH P,D ;SAVE NUMBER OF PARAMS TO CHECK.
MOVMS D
;; ##PX# (4 OF 13)
HRRZ TEMP,LEAPSK
SUBI TEMP,(D)
CAIGE TEMP,LEABEG-1
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
MOVNI D,-1(D) ;NUMBER OF PARAMETERS -1
ADD D,LEAPSK ;TO GET BEGINNING.
MOVEM D,PARBEG ;THE FIRST PARAMETER.
TLNE FF,LPPROG ;MAKES A BIG DIFFERENCE.
JRST LPCHK ;ALAS, YES.
MOVE D,LEAPSK
PUSH P,PNT ;STAKIT WILL DESTROY
PUSHJ P,STAKIT ;STACK THE LAST THING.
POP P,PNT ;RESTORE IT
POP0: MOVE D,PARBEG ;THE FIRST PARAMETER
MOVE SBITS2,LEAPSK ;THE LAST PARAMETER.
SETOM B ;ALL BITS ON (RETRV,LPITM, ETC)
SETZM TBITS2 ;THE BITS FOR THE CONTROL WORD.
MOVE PNT2,[POINT 3,TBITS2,8] ;TO GET ATTPOS ON AN IDPB....
SETZM BNDFLG ;NO FBIND YET
POP1: CAILE D,(SBITS2) ;DONE?
JRST POP1B ;YES
MOVE A,(D) ;TOP OF STACK.
TLNN A,FBIND!QBIND
JRST PP1A
SETOM BNDFLG ;HAVE SEEN A BIND.
TLO A,BINDING ;THIS IS BEING BOUND
PP1A: HLRZ C,A ;GET LEFT HALF BITS.
IDPB C,PNT2 ;STORE THE THREE BITS AWAY IN "BYTES"
ANDB A,B ;AND CREATE THE HAVOC EVERYONE WANTS.
;ACTUALLY THIS KEEPS TRACK
;OF CNSTR,RETRV, ETC.
TRZ A,-1 ;NOTHING THERE.
SOS ADEPTH ;SINCE THIS IS A PARAMETER,
; IT WILL DISAPPEAR
SOS LEAPSK ;DECREMENT STACK POINTER.
TLNN A,RETRV!CNSTR ;HAD BETTER BE ONE OR THE OTHER.
ERR <RETRIEVAL - CONSTRUCTION FAILURE>,1
;SIGNAL RETRIEVAL-CONSTR. FAILURE
AOJA D,POP1 ;LOOP UNTIL ALL PARAMETERS DONE.
POP1B: TLNE TBITS2,BINDING⊗ATTPOS
TRO TBITS2,1 ;START TO MAKE UP AN INCREMENT.
TLNE TBITS2,BINDING⊗OBJPOS
TRO TBITS2,2
TLNE TBITS2,BINDING⊗VALPOS
TRO TBITS2,4
TLNN FF,LPPROG ;ONLY RECORD LEFT HALF IF FOREACH.
TLZ TBITS2,444 ;THIS IS THE "BOUND" BITS EVERYWHERE.
MOVEM TBITS2,BYTES ;AND THE RESULTS.
POP P,D
SKIPE BNDFLG ;ANY BIND OPS?
TLO A,FBIND ;YES
JUMPGE D,CPOPJ
AOS LEAPSK
MOVEM A,@LEAPSK
AOS ADEPTH ;THIS IS NOT A PARAM YET....
POPJ P,
LPCHK: CAIN D,LEABEG ;THE END OF THE LEAP STACK?
JRST GOODY ;YES -- EVERYTHING IS MUCH SIMPLER.
MOVEI D,LEABEG ;PREPARE TO RAMBLE THROUGH.
POP3: CAMN D,PARBEG ;ARE WE UP TO THE PARAMETERS YET
JRST GOODY ;YES -- WITHOUT A HITCH.
MOVE A,(D) ;PICK UP STACK ELEMENT.
TLNN A,STACKET ;IS IT REALLY STACKED ?
AOJA D,POP3 ;LOOP -- NO
MOVE D,LEAPSK ;TROUBLE -- GET TOP OF STACK.
;SOMETHING BEFORE THE PARAMETERS
;IS STACKED. WE MUST POP OFF EVERYTHING
;SINCE WITHIN FOREACH NOTHING CAN BE
;REMEMBERED ON THE STACK OVER CALL TO LEAP
POP4: CAIL D,LEABEG ;LOOP UNTIL ALL ARE POPPED.
JRST POP8 ;ALL DONE -- NOW STACK BACK ON.!!
PUSH P,POPEND ;IN LINE CALL.
POPIT: MOVE A,(D) ;STACK ELEMENT
TLZN A,STACKET ;ON STACK ?
POPJ P, ;NO
PUSH P,A
PUSHJ P,GETCRTMP ;GET A TEMP.
MOVEI PNT,(LPSA) ;SINCE GETCRTMP RETURNS ANSWER IN LPSA.
EMIT (<POP RP,NOUSAC>)
SOS ADEPTH ;WE HAVE POPPED.
POP P,A
HRRI A,(PNT) ;POINTER TO TEMP.
MOVEM A,(D) ;SAVE BACK ON STACK.
POPEND: POPJ P,.+1
SOJA D,POP4 ;LOOP UNTIL DONE.
GOODY: MOVE D,PARBEG ;HERE WHEN STACK BEHIND
;PARBEG IS IN GOOD
ADDI D,1 ;SHAPE....
G2: CAMLE D,LEAPSK ;ALL DONE?
JRST POP8 ;YES ...
MOVE C,@PARBEG ;THE FIRST PARAMETER.
XOR C,(D) ;XOR WITH THE CURRENT PARAMETER.
TLNN C,STACKET ;ARE THEY STACKED DIFFERENTLY?
AOJA D,G2 ;NO -- LOOP
MOVE D,LEAPSK ;TROUBLE -- GO THROUGH AND POP.
G1: CAMGE D,PARBEG
JRST POP8 ;ALL DONE
PUSHJ P,POPIT ;DO THE POPS
SOJA D,G1
POP8: MOVE D,PARBEG ;WHERE IT ALL BEGINS.
HRRI C,(BINDING!BOUND)⊗ATTPOS
MOVEM C,BBWORD ;INITIAL BINDING BITS WILL RIGHT SHIFT
;EACH TIME THROUGH LOOP
MOVEI C,1 ;INITIAL DISPATCH INCREMENT
MOVEM C,INDEX4
JRST POP9
POP90: MOVE C,BBWORD
LSH C,-3
MOVEM C,BBWORD
MOVE C,INDEX4
LSH C,1
MOVEM C,INDEX4
POP9: CAMG D,LEAPSK ;ALL DONE?
JRST POP9A ;NO.
;; #LE# DON'T TURN OFF LPFREE TOO EARLY
SKIPN B,HLDCNT ;ANY ?LOCALS?
JRST POP0 ;NO -- ALL DONE
SETZM HLDCNT ;FOR NEXT TIME
MOVE SBITS,[LPFREE,,0]
MOVE PNT,HLD-1(B) ;THE LAST ONE.
ANDCAM SBITS,$SBITS(PNT) ;TURN OFF LPFREE BIT
SOJG B,.-2
JRST POP0 ;ALL DONE WITH THIS KLUDGE
POP9A: PUSH P,POPRET ;IN LINE CALL.
STAKIT: MOVE PNT,(D) ;GET STACK ELEMENT.
;; #PX# (5 OF 13) SOME REDUNDANT? STACK HEIGHT CHECKING
HRRZ TEMP,D
CAIGE TEMP,LEABEG ;VALID STACK ENTRY?
ERR <NON LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
TLOE PNT,STACKET ;ALREADY STACKED?
POPRET: POPJ P,POP11 ;DONE.
;; #ON# (2 OF 2) DON'T STACK ? FOREACH LOCALS UNLESS REALLY INSIDE FOREACH
TLNN FF,LPPROG
JRST [MOVE TEMP,$SBITS(PNT)
TLNN TEMP,LPFREE
JRST .+1
POPJ P,]
;; #ON#
MOVEM PNT,(D)
PUSH P,POPAA ;IN LINE CALL.
PREPAR: PUSHJ P,GETAD ;GET GOOD BITS.
TLNE PNT,FBIND!QBIND ;BIND ITMVR?
JRST BINDQF
TLZ SBITS,LPFREE ;A FREE LOCAL?
TLNN SBITS,FREEBD ;DON'T SAVE YET IF FREEBD
;BECAUSE OF CONSTRUCT X XOR X EQV Y
MOVEM SBITS,$SBITS(PNT) ;NO LONGER FREE
TRNE TBITS,ITEM
TLNE TBITS,FORMAL!SBSCRP
JRST [TRNE TBITS,ITMVAR
TLNN SBITS,LPFRCH!FREEBD
JRST NONEW
TLNE FF,LPPROG ;ONLY GET LOCAL NUMBER IF FOREACH
JRST NEWSS ;IN PROGRESS
JRST NONEW]
NEWSS:
HRR PNT,$VAL2(PNT) ;THE POINTER TO ITEM NUMBER
;OR LOCAL NUMBER......
PUSHJ P,GETAD
NONEW:
SETZM A
TLNE PNT,LPDMY
HRRZ A,(D) ; A MADE UP NUMBER.
TLNE PNT,LPDMY!LPNUL
PUSHJ P,CREINT
POP10: GENMOV (ACCESS,0) ;STACK THE THINGS.
POPAA: POPJ P,.+1
GENMOV (STACK,0) ;WILL CAUSE REMOP TOO.
POPJ P,
POP11: MOVE PNT,(D) ;GET ITEMVAR SEMBLK BACK
MOVE SBITS,$SBITS(PNT) ;GET SBITS BACK
TLNN SBITS,LPFREE ;IF STILL FREE MUST BE FREEBD
AOJA D,POP90 ;LOOP BACK
TLNN SBITS,FREEBD ;ERROR CHECK
ERR <DRYROT - POP11>
AOS A,HLDCNT
MOVEM PNT,HLD-1(A) ;-1 SINCE INDEX STARTS AT ZERO
HRL A,BBWORD
HRR A,INDEX4
PUSHJ P,CREINT
GENMOV (STACK,0) ;STACK BINDING BITS,DISPATCH INCREMENT
SOS ADEPTH ;THIS WILL GO AWAY IMMEDIATELY
PUSH P,BYTES ;PROTEXT BYTES OVER LPCALL
LPCALL (STK4VL) ;STACK VAL OR LOCAL NUMBER
POP P,BYTES ;RESTORE BYTES
AOJA D,POP90 ;LOOP BACK
BINDQF: PUSH P,PNT ;SAVE LEFT HALF BITS
GENMOV (INCOR) ;MAKE SURE IN CORE
HLL PNT,(P) ;IN CASE INCOR CHANGED PNT.
TLNE PNT,QBIND
JRST [SETOM MPFLAG
HRLI PNT,POTUNB
PUSHJ P,FTRADR ;WANT POTUNB IN LEFT HALF
SETZM MPFLAG
JRST BINDQ1]
HRRZS PNT ;SINCE ADRINS WILL USE BITS LH
PUSHJ P,ADRINS ;WILL STACK THE ADDRESS
BINDQ1: HLL PNT,(P) ;GET LEFT HALF BITS BACK
SUB P,X11 ;POP OFF OLD PNT
POPJ P,
CHKSET: ;CHECK IF PARAMETERS SETS
MOVE C,LEAPSK ;TOP ELEM. OF STACK
HRLZI A,LPXISX ;BIT WE'RE LOOKING FOR
CHKSLP: TDNE A,(C) ;A LIST?
ERR <ERROR - ILLEGAL LIST OPERATION>,1
SUBI C,1
SOJG D,CHKSLP
POPJ P, ;RETURN ALL O.K.
DSCR CHKSAT -
check to see if we have to pop satisfiers into core within
associative context of FOREACH
⊗
↑↑CHKSAT: ;
SKIPN NEDPOP ;DO WE NEED IT;
POPJ P,
SETZM NEDPOP ;DON'T NEED IT NOW
LPCALL (FRCHPOP)
POPJ P,
;FOREACH STATEMENT HANDLERS.
DSCR FRCHGO, ENTITV, BOPREP, FRBOL, STSRC, BTRIP, DERIV, etc.
PRO FRCHGO ENTITV BOPREP FRBOL STSRC FID1 FRCH1 FRCH2 BTRIP DERIV
⊗
COMMENT ⊗
THE FIRST THING WE DO IS CAUSE THE ADDRESS OF THE SCB POINTER
VARIABLE TO BE STACKED. WE THEN CAUSE THE LOADING OF TAC1 WITH
THE ADDRESS OF THE SATISFIER BLOCK CONTAINING:
1. A JRST TO THE END (OUTSIDE) OF THE LOOP.
2. THE NUMBER OF LOCAL ITEMVARS SPECIFIED IN THE SEARCH.
3. THE ADDRESSES (1 BY 1) OF ALL THE LOCAL ITEMVARS.
THUS, IF A LOCAL IS REFERED TO BY NUMBER (SAY 3)
ITS CORE STORAGE ADDRESS CAN BE FOUND BY LOOKING
IN THE THIRD ENTRY IN THIS LIST
We then emit the call to start leap up, followed by a jump
around the satisfier block followed by the satisfier block
itself (see above);
⊗
SCBNAM: XWD 0,6 ;every scb variable has the same name
POINT 7,.+1
ASCII /SCB.../
↑EACH4: ;DECLARE SCB VARIABLE
NAMEIT (SCBNAM,<INTEGR!FLOTNG>)
PUSHJ P,GETAD
EMIT <MOVEI TAC1,NOUSAC>
HRLZI C,14 ;ADDR IS 14
EMIT <PUSH P,NOUSAC!USADDR!NORLC!NOADDR>
POPJ P,
↑FRCHGO:
SETZM NEDPOP ;DON'T NEED POP YET
PUSHJ P,FRCHT ;IN FOR LOOP DOMAIN --
;MAKE A BLOCK. ETC.
MOVEI B,$DATA(LPSA) ;PLACE TO PUT FIXUP FOR JUMP OUT.
TLO FF,LPPROG ;LEAP IN PROGRESS.
MOVE C,PCNT ;CALC. ADDR OF SATISFIER BLOCK
; ##HR## JRL 6-20-72 USE FIXUP RATHER THAT RELATIVE ADDR. SO NEEDNEXT OK
MOVEM C,SATADR ;FOR FIXUP LATER
EMIT <MOVEI TAC1,NORLC!NOADDR!NOUSAC> ;LOAD ADDRESS OF SATIS BLOCK
; ##HR##
LPCALL (FRCHGO) ;CALL TO SET UP FOREACH SEARCH.
MOVE C,PCNT ;CALC. ADDRESS FOR JUMP OVER SATIS BLOCK
ADD C,LOCALCOUNT ;ONE WORD PER LOCAL
ADDI C,3 ;FOR JRST AND COUNT OF LOCALS
MOVSI C,(C) ;PREPARE FOR EMIT
EMIT <JRST , USADDR!NOUSAC> ;JRST AROUND SATIS BLOCK
;NOW GENERATE SATISFIER BLOCK
HRLZ PNT2,PCNT
MOVEM PNT2,(B) ;FIXUP FOR JUMP OUT.
;; #HR# USE FIXUP
HRR PNT2,SATADR ;PLACE TO FIXUP
MOVS B,PNT2
PUSHJ P,FBOUT ;FIXUP MOVEI 14,
;; #HR#
EMIT (<JRST NOUSAC!NOADDR>) ;WHERE TO GO WHEN DONE.
HRL C,LOCALCOUNT
EMIT (<NOUSAC!NORLC!USADDR>) ;COUNT OF LOCALS.
MOVE B,LOCBEG ;THE POINTER FOR QTAK
ANO: QTAKE (LOCST) ;GET FIRST LOCAL.
POPJ P, ;ALL DONE.
MOVE PNT,A
PUSHJ P,GETAD ;GET SEMANTICS
MOVEI A,0 ;COLLECT BITS FOR LEFT HALF
TLNE TBITS,MPBIND ; A ? PARAMETER
TRO A,MPPAR ;YES
TLNE SBITS,FREEBD ;POTENTIALLY UNBOUND?
TRO A,POTUNB ;YES
TRNN SBITS,DLFLDM ;A DISPLAY TYPE THING?
JRST SIMITM ;NO.
TLNE TBITS,REFRNC ;A REFERENCE PARAMETER?
TRO A,20 ;PUT ON INDIRECT BIT
LDB TEMP,[LEVPOINT <SBITS>]
CAMN TEMP,CDLEV ;SAME DISPLAY LEVEL?
JRST SIMITM ;YES, SIMPLE CASE AGAIN
TRO A,CDISP ;THIS IS A DISPLAY TYPE THING
SUB TEMP,CDLEV ;CALCULATE DISPLAY DIFFERENCE
MOVMS TEMP
IORI A,(TEMP) ;PUT INTO INDEX FIELD
HRLI A,JSFIX!NOUSAC ;BITS FOR EMITER
TLNN TBITS,REFRNC!VALUE ;A FORMAL PARAMETER?
JRST SIMIT2 ;NO.
HRRZ TEMP,$ADR(PNT) ;STACK DISPLACEMENT
MOVN TEMP,TEMP ;NEGATE
SUBI TEMP,1 ;FOR RETURN ADDR
HRL C,TEMP
HRLI A,USADDR!NOUSAC!NORLC
JRST SIMIT2
SIMITM: HRLI A,NOUSAC ;STANDARD CASE
SIMIT2:
MOVSS A ;RIGHT IS LEFT AND VICE VERSA
PUSHJ P,EMITER
JRST ANO ;LOOP UNTIL DONE.
↑↑QLOCAL:
GETSEM (0) ;A ? FOREACH LOCAL
TLNE SBITS,LPFRCH!FREEBD ;ALREADY IN LIST?
ERR <SAME LOCAL ITEMVAR IN BINDING LIST>,1
TLO SBITS,FREEBD
MOVEM SBITS,$SBITS(PNT)
POPJ P,
;; %BD% (1 OF 3) ALLOW FOREACH'S WITHOUT BINDING LISTS
↑DUMITV: ;ALLOW FOREACH SUCH THAT
MOVEI TBITS,ITMVAR ;GET AN ITEMVAR CORETMP
PUSHJ P,GETCRTMP
;; #RC# ! LOAD SEMBLK INTO PNT
MOVE PNT,LPSA ;GETCRTMP RETURNS IN LPSA NOT PNT
PUSHJ P,ITVCMN
MOVE SBITS,$SBITS(PNT2)
TLZ SBITS,LPFREE ;MARK AS NOT FREE
MOVEM SBITS,$SBITS(PNT2)
POPJ P,
↑ENTITV: ;RECORD THE NAME OF A LOCAL.
GETSEM (1) ;SEMANTICS OF ITMVAR.
ITVCMN:
;; %BD%
MOVE PNT2,PNT
TLNE SBITS,LPFREE
ERR <SAME LOCAL APPEARS MORE THAN ONCE IN BINDING LIST>,1
TLO SBITS,LPFREE!LPFRCH ;TURN ON.
TLNE SBITS,FREEBD ;A ? LOCAL
TLZ SBITS,LPFRCH ;YES
MOVEM SBITS,$SBITS(PNT) ;IN MEMORY
AOS A,LOCALCOUNT
CAILE A,MAXLOC
ERR <TOO MANY LOCALS IN FOREACH LIST>,1
PUSHJ P,CREINT ;MAKE AN INTEGER.
MOVEM PNT,$VAL2(PNT2) ;SAVE FOR FUTURE GENERATIONS.
;; %BD% (2 OF 2) !
QPUSH (LOCST,PNT2) ;SAVE FOR END.
POPJ P,
↑BOPREP: ;PREPARE FOR BOOLEAN INSIDE A FOREACH SPEC.
PUSHJ P,CHKSAT ;UPDATE CORE LOCATIONS IF NECESSARY
TLZ FF,LPPROG ;TURN OFF THE "LEAP" BIT.
POPJ P,
↑FRBOL: ;BOOLEAN DONE INSIDE FOREACH LIST.
PUSH P,PCNT ; SAVE PCNT
PUSHJ P,ALLSTO ;CLEAR ALL AC'S
POP P,A
CAME A,PCNT ;SHOULD BE THE SAME
ERR <DRYROT-AT LEAP:FRBOL>,1
PUSHJ P,BONOT ;TO JUMP ON TRUE
PUSHJ P,STIF ;GO GENERATE CODE.
; LPCALL (FRTRU) ;FOREACH TRUE HANDLER.
; WE WILL NOW SIMPLY GEN JRST ; (WILL SKIP OVER THE "FALSE" CALL FOLLOWING)
LPCALL (FRFAL) ;FOREACH FALSE HANDLER.
HRR B,PCNT
HLL B,GENRIG ;FIXUP FOR FALSE PART.
;; #PH DON'T SUPPRESS FBOUT IF LH(B) MERELY NEG (REENTRANT COMPILATIONS)
HLRE TEMP,B
AOJE TEMP,.+2 ;If BE evaluates to FALSE no JRST TRUE
;; #PH#
PUSHJ P,FBOUT
SETOM GENRIG ;FOR THE FOREACH GUY TO NOTICE THAT CODE HAS GONE OUT.
TLO FF,LPPROG ;TURN IT BACK ON.
POPJ P,
↑STSRC: ;FOREACH SPEC. OF FORM " X IN SET "
;; #PX# (6 OF 13)
SKIPN A,@LEAPSK ;SEE IF DUMMY ITEM(FROM DERIVED SETS)
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
TLNE A,LPDMY
ERR <DERIVED SET WITHIN FOREACH WILL DO WRONG THING>,1
STAKCHECK (2) ;TWO ARGS.
RETCHK ;RETRIEVAL TYPES NECESSARY
MOVSI A,SETOP ;TELL FOREACH
IORM A,BYTES
LPCALL (STSRC,,BYTES) ;CALL FOR SEARCH.
SETOM NEDPOP ;NEED POP INTO CORE
SETOM GENRIG+1 ;CODE GONE OUT.
POPJ P,
↑FID1: ;TO SAY NO CODE GONE.
SETZM GENRIG+1
POPJ P,
↑FRCH1: ;GENERAL SEARCH X XOR Y EQV Z
SKIPE GENLEF+1 ;HAS CODE GONE OUT?
POPJ P, ;YES -- WAS A SET SEARCH.
STAKCHECK (3) ;THREE ARGUMENTS.
;STCHK COMPUTES THE DIRECTIVE BITS
;(IN "BYTES" TO TELL LEAP INTERPRETER
;WHICH THINGS ARE BOUND, FREE, ETC.)
RETCHK ;RETRIEVAL TYPES NECESSARY
LPCALL (TRIPLES) ;AIN'T THAT SIMPLE.
SETOM NEDPOP ;NEED TO POP
POPJ P,
↑FRCH2: ;LAST SEARCH SPEC. IN THE FOREACH LIST.
PUSHJ P,FRCH1 ;FOR THE LAST TRIPLE.
MOVE A,FRBLK ;SAVE SEMANTICS OF ASSDO
MOVEM A,GENRIG
PUSHJ P,CHKSAT ;CALL TO PUT SATISFIERS DOWN IN CORE.
MOVE SP,LOCALCOUNT ;GET READY TO PROCESS LOCALS.
LGO: QPOP (LOCST) ;GET TOP ONE
MOVE SBITS,$SBITS(A) ;
MOVE TBITS,$TBITS(A)
MOVE LPSA,A ;FOR THE ERROR HANDLER TO PRINT OUT.
TLZE SBITS,LPFRCH!FREEBD ;NO LONGER IN A FOREACH.
TLZE SBITS,LPFREE
ERR <STRANGE USE OF LOCAL: >,3 ;NEVER WAS CITED.
MOVEM SBITS,$SBITS(A)
;; %BD% (3 OF 3)
TLNE SBITS,CORTMP ;A PHONY?
JRST [PUSH P,SP ;JUST TO BE SAFE
PUSH P,B ;DITTO
PUSHJ P,REMOPL ;REMOP THE CORTMP
POP P,B
POP P,SP
JRST .+1]
;; %BD%
SOJG SP,LGO
SETZM LOCALCOUNT ;RESTART THE COUNT FOR NEXT TIME.
SETZM MADEUPLOCALS ;DITTO.
TLZ FF,LPPROG ;AT LAST DONE.
JRST ENDFOR ;IN FOR LOOP CODE -- MAY PUT OUT
;CALLS IF COROUTINES NEEDED.
↑BTRIP: ;BRACKETED TRIPLE.
STAKCHECK (3) ;3 PARAMS TO BRACKETED TRIPLE.
TLNN FF,LPPROG ;INSIDE FOREACH SEARCH
JRST NOFR ;NO
AOS A,MADEUPLOCALS ;MAKE A NEW "MADE UP" LOCAL.
ADD A,LOCALCOUNT
PUSH P,A ;"A" IS NEW LOCAL NUMBER.
PUSHJ P,CREINT ;MAKE AN INTEGER
EMIT (<PUSH RP,NOUSAC>) ;AND GIVE THE NUMBER.
MOVSI B,BRACKET
IORM B,BYTES ;TO TELL THERUNTIMES.
LPCALL (TRIPLES) ;SEARCH FOR THE BRACKETED TRIPLE.
;LEAP INTERP. WILL PUT ITEM # IN AS
;SATISFIER OF THE MADEUP LOCAL.
POP P,A
HRLI A,LPDMY!LPITM!BOUND!RETRV ;NOW RECORD THE DUMMY LOCAL NUMBER.
;NOTE DUMMY NUMBER IN RIGHT HALF;
JRST BFIN ;ALL DONE.
NOFR: SKIPE MKFLAG ;IN A MAKE STATEMENT?
JRST MKB ;YES
TLNE A,FBIND
ERR <BIND NOT VALID WITH BRACKETED TRIPLES>,1
RETCHK ;RETRIEVAL TYPES NECESSARY
LPCALL (BRTRIP) ;JUST LOOK FOR IT.
HRLZI A,LPITM!STACKET!RETRV ;RESULT IS AN ITEM.
JRST BFINA
MKB: CONCHK ;CONSTRUCTION TYPES NECESSARY
LPCALL (BMAKE) ;CALL TO MAKE THE BRACKETED TRIPLE.
HRLZI A,LPITM!STACKET!CNSTR ;AND RESULT IS ITEM.
BFINA: AOS ADEPTH ;STACK HAS A RESULT ON IT.
BFIN: AOS B,LEAPSK ;PUT THIS BACK -- STCHK SOS'ED IT.
MOVEM A,(B) ;STORE THE NEW TOP OF STACK.
POPJ P,
↑DERIV: ;DERIVED SETS.
PUSH P,B ;PARSER INDEX OF TYPE.
STAKCHECK (2) ;TWO PARAMETERS.
TLNE A,FBIND
ERR <BIND OR ? NOT VALID IN DERIVED SETS>,1
MOVE B,(P) ;GET THE PARSER INDEX.
CAIN B,2 ;IF THIS KINDS
ERR <P * Q NOT IMPLEMENTED>,1
MOVEI A,BINDING
JRST DERNDX(B) ;WHICH DERIVED SET
DERNDX: JRST DERXOR ;A ⊗ O
JRST DERQUOT ;A ' V
JRST DERXOR ;WILL TREAT A*O AS A⊗O
; O EQV V
LDB C,[POINT 9,BYTES,17-VALPOS];WILL HAVE TO SHIFT BITS STACKCHECK
;COMPUTED
LSH C,-3 ;ATT shifts to OBJ shifts to VAL
DPB C,[POINT 6,BYTES,17-VALPOS]
DPB A,[POINT 3,BYTES,17-ATTPOS]
SOS (P) ;INDEX SHOULD BE 2
JRST NOFUNQ
; A ' V
DERQUOT:LDB C,[POINT 3,BYTES,17-OBJPOS]
DPB C,[POINT 3,BYTES,17-VALPOS]
DPB A,[POINT 3,BYTES,17-OBJPOS]
JRST NOFUNQ ;SAFE.
; A ⊗ O
DERXOR: DPB A,[POINT 3,BYTES,17-VALPOS] ;NEW ITEMVAR.
NOFUNQ:
TLNN FF,LPPROG ;FOREACH GOING ?
JRST NODRV ;NO
AOS A,MADEUPLOCALS ;MAKE UP A NEW LOCAL NUMBER.
ADD A,LOCALCOUNT
PUSH P,A
PUSHJ P,CREINT ;MAKE AN INTEGER FOR IT.
EMIT (<PUSH RP,NOUSAC>) ;PUSH ON STACK .
LPCALL (LDERIV,<-1(P)>) ;CALL SEARCHER. WE HAVE ESSENTIALLY
;TURNED A XOR ( C XOR D) EQV X INTO
; C XOR D EQV Y AND A XOR Y EQV X
POP P,A
HRLI A,LPITM!LPDMY!BOUND!RETRV ;RESULT IS AN ITEM DUMMY NUMBER.
POP P,B
JRST BFIN
NODRV: LPCALL (DERIV,<(P)>) ;NOT INSIDE FOREACH -- JUST CALL IT.
MOVE A,PHIBLK ;DUMMY SET SEMBLK
;; #JN# BY JRL 10-8-72 FOLLOWING INSTR WAS TO GENRIG INSTEAD OF GENRIG+1
MOVEM A,GENRIG+1 ;ONTO PARSE STACK
HRLZI A,LPSET!STACKET!RETRV ;RESULT IS A SET.
POP P,B
JRST BFINA
;DATUM HANDLERS
DSCR DDATA, LDATA
PRO DDATA LDATA
⊗
GETITM: ;LOAD TOP OF LEAPSK INTO AC 3
;; #PX# (7 OF 13)
SKIPN PNT,@LEAPSK ;GET THE LAST THING PUT ON STACK.
ERR <NON LEAP ARG TO LEAP EXPRESSION>,1
;; # PX#
SOS LEAPSK ;DECREMENT STACK COUNTER.
TLNN PNT,LPITM ;HAD BETTER HAVE ITEM
ERR <DATUM AND PROPS ONLY VALID FOR ITEM EXPR>,1
TLNE PNT,LPDMY
ERR <PROPS WON'T FOR BRACKETED TRIPLE WITHIN FOREACH>,1
SETZM SBITS ;ZERO OUT SBITS
TRNE PNT,-1 ;IF WE HAVE A SEMBLK
PUSHJ P,GETAD ;GET SEMANTICS OF ITEM.
SKIPN TEMP,BITS ;FOR DATUM(IT,TYPE)
MOVE TEMP,TBITS
MOVEM TEMP,DATBITS
REC <
TRNE TEMP,PNTVAR
TRNE TEMP,777777-(PNTVAR!GLOBL)
JRST GTIT.0 ;NOT A RECORD
PUSH P,TEMP ;PARANOIA
TRNN PNT,-1 ;DID HE GIVE ME AN ITEM
HLRZ TEMP,$ACNO(PNT) ;BITS MAY COME FROM THERE
SKIPE QRCTYP ;BUT HE MAY HAVE SAID EXPLICITLY
HRRZ TEMP,QRCTYP ;
HRRZM TEMP,RCLASS ;FOR THE IMMINENT MARK
POP P,TEMP
GTIT.0:
>;REC
TLNE SBITS,LPFREE
ERR <DATUM OR PROPS OF UNBOUND ITEMVAR WITHIN FOREACH>,1
TLNE FF,LPPROG ;CHECK TO SEE IF FOREACH GOING.
TLNN SBITS,LPFRCH!FREEBD;AND THIS THING IS ONE OF THE ITEMVARS.
SKIPA ;NO -- OK
PUSHJ P,CHKSAT
MOVEI D,3 ;WE NEED THE ITEM IN AC 3
TLNN PNT,STACKET
JRST [
;; #NX# WASN'T DOING RIGHT THING BY DATUM(BINDIV,STRING) MAKE SURE
; GOOD TBITS ARE USED.
GENMOV (GET,SPAC!GETD);
JRST GOTEN]
HRL C,D ;AC NUMBER TO GET IT IN.
EMIT <POP RP,NOUSAC!NORLC!USADDR> ; IT WAS ON THE REAL STACK.
SOSA ADEPTH ;AND BOOKKEEP THIS.
GOTEN:
PUSHJ P,REMOP ;REMOVE THE ITEM NUMBER.
POPJ P,
↑DDATA:
↑LDATA: TLO FF,FFTEMP ; GET ADDRESS OF DATUM ENTRY.
;IF FFTEMP IS OFF, GET VALUE OF DATUM ENTRY.
PUSHJ P,GETITM
PUSHJ P,GETAN0 ;BUT GET ANOTHER AC FOR DATUM.
GLOC <
QPOP (GLBSTK) ;IF GLOBAL, THEN USE THE OTHER ONE.
SKIPN ALLGLO
SKIPE A ;USE GLOBAL DATUM?
JRST [HRLI C,7776 ;MAXIMUM ITEM.
EMIT (<CAIG 3,NOUSAC!USADDR!NORLC>)
HRLI C,6000 ;GLOBAL BREAK
EMIT (<CAIG 3,NOUSAC!USADDR!NORLC>)
XCALL (DATERR)
HRL C,PCNT ;CHAIN INSTRUCTIONS.
SKIPN NOEMIT
EXCH C,LIBTAB+RGDATM ;GLOBAL DATUM
JRST DATGO]
>;GLOC
HRL C,PCNT
SKIPN NOEMIT
EXCH C,LIBTAB+RDATM ;WORD TO INDIRECT THROUGH.
DATGO:
MOVE TBITS,DATBITS
TRZN TBITS,LPARRAY
JRST NORM ;ITEM TYPE IS NOT AN ARRAY.
;;#FN# DCS 2-6-72 (1-1) SAFE ... ARRAY ITEMVAR X -- X not treated as SAFE
TLZ TBITS,-1≠SAFE ;READY FOR NEW TEMP
TLO TBITS,SBSCRP ;NEW TEMP WILL BE ARRAY, NOT WITH OWN ON, ETC.
;;#FN# Replace HRLI TBITS,SBSCRP
TLZ FF,FFTEMP ;BUT WE GET THE DESCRIPTOR.
EMIT (SKIPN @USADDR)
XCALL (LPRYER) ;GETTING AN ARRAY THAT DON'T EXIST.
JRST FINOUT
NORM: MOVE A,[MOVE @USADDR] ;INSTR. TO PICK UP VALUE.
TLNE FF,FFTEMP
TLO A,1000 ;CHANGE IT TO A MOVEI.
TRNE TBITS,STRING ;STRING ITEM?
HRLI A,(<HRRO @>) ;HRRO INDIRECT
PUSHJ P,EMITER ;AND EMIT THE INSTRUCTION.
FINOUT: TRZ TBITS,ITEM!ITMVAR
TRNN TBITS,-1 ;UNTYPED?
ERR (<UNTYPED ITEM OR ITEMVAR OUGHT TO BE TYPED.>,1)
PUSHJ P,TYPDEC ;TYPE THE NEW THINGS.
MOVEM A,PARRIG ;PARSE TYPE FOR THE PRODUCTION INTERPRETER.
;; #KZ# TURN OFF OWN BIT DATUM(OWNARRAY[I])
TLZ TBITS,FORMAL!OWN!MPBIND;RANDOM THINGS MAY BE ON......
PUSH P,PNT ;SAVE SEMANTICS OF THING POINTED DO.
PUSH P,TBITS ;BECAUSE MARK MASKS SOME THINGS.
SETZB TBITS,SBITS ;MAKE SURE WE MAKE AN ARITHMETIC TEMP....
GENMOV (MARK,0) ;MAKE A TEMP.
NOREC < ;CAN FLUSH NOW SINCE ADDED CHECK FOR ARTEMP IN ARRAY
HRROS $ACNO(PNT) ;FOR ARRAYS $*$*$*$*$**$*$*$*$*$**$*
>;NOREC
POP P,TBITS
POP P,TEMP
TLNE TBITS,SBSCRP ;IF AN ARRAY DATUM,
NOREC <
MOVEM TEMP,$VAL(PNT) ;SEE ARRY FOR THE PLACE THIS IS USED.
;IT IS FOR MAKING A NAME FOR THE ARRAY ERROR UUO.
>;NOREC
REC <
HRLZM TEMP,$VAL2(PNT) ;PUT THIS IN A DIFFERENT SPOT. ARRAY ERR UUO NEEDS
HLRZ TEMP,$ACNO(TEMP);RECORD CLASS INFO
TRNE TBITS,PNTVAR ;ADD MARKING IF A RECORD
HRLM TEMP,$ACNO(PNT) ;REMEMBER REC TYPES IF APPLIC
>;REC
MOVEM TBITS,$TBITS(PNT) ;PUT DOWN THE REAL TYPES.
TLNE FF,FFTEMP
TLC SBITS,INAC!PTRAC!INDXED ;NORMAL CASE IS TO RETURN POINTER.
MOVEM SBITS,$SBITS(PNT) ;AND THE REAL SEMANTIC BITS.
MOVEM PNT,GENRIG ;TELL EVERYONE WHO OUGHT TO KNOW.
POPJ P,
DSCR - PPSTO,EPPSTO,GETPROP execs for PROPS
⊗
↑PPROP: SOS B,LEAPSK ;GET ITEM
;; #PX# (8 OF 13)
SKIPN PNT,1(B) ;TOP ELEM OF LEAP STACK
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
TLNN PNT,LPITM ;BETTER BE ITEM
ERR <PROPS REQUIRES ITEM EXPR ARGUMENT>,1
TLNE PNT,STACKED ;STACKED,HOPE NOT!
JRST WSSTKD ;TOO BAD
HRRZM PNT,GENRIG ;NO JUST PUT IT DOWN
POPJ P,
WSSTKD: MOVEI D,3 ;WANT AC 3
PUSHJ P,STORZ ;MAKE SURE WE CAN HAVE IT
HRLI C,3
EMIT <POP RP,USADDR!NOUSAC!NORLC> ; POP IT OFF
SOS ADEPTH ;NO LONGER ON STACK
MOVEI TBITS,ITMVAR ;RESULT IS ITEMVAR
PUSHJ P,MARKME
HRRZM PNT,GENRIG
POPJ P,
↑EPPSTO:TLOA FF,FFTEMP ;EXPR STORE
↑PPSTO: TLZ FF,FFTEMP ;JUST STORE
MOVE PNT,GENLEF+3 ;THE ITEM
MOVEI D,3 ;WANT ITEM IN AC 3
GENMOV (GET,SPAC!GETD)
PUSHJ P,REMOP ;REMOP THE TEMP IF NEC.
HRROS ACKTAB+3 ;PROTECT AC 3
MOVE PNT,GENLEF+1 ;THE VALUE TO BE STORED
HRRI B,INTEGR ;HAD BETTER BE INTEGER
GENMOV (GET,INSIST!POSIT!GETD)
TLNN FF,FFTEMP ;EXPR STORE?
JRST STPROP ;NO.
PUSHJ P,MARKINT ;MARK AS TEMP
MOVEM PNT,GENRIG+1 ;THE RESULT
JRST .+2 ;SKIP OVER REMOP
STPROP: PUSHJ P,REMOP
HRL C,PCNT ;FOR FIXUP TO PROPS
GLOC < QPOP (GLBSTK) ;GLOBAL PROPS?
SKIPE ALLGLO
JRST [SKIPN NOEMIT
EXCH C,LIBTAB+RGPROPS
JRST PPDPB]
JUMPN A,[SKIPN NOEMIT
EXCH C,LIBTAB+RGPROPS ;FIXUP TO GPROPS
JRST PPDPB]
>;GLOC
SKIPN NOEMIT
EXCH C,LIBTAB+RPROPS ;FIXUP TO PROPS
PPDPB: EMIT <DPB ,USADDR> ;STORE VALUE
HRRZS ACKTAB+3 ;UNPROTECT AC 3
POPJ P,
↑GTPROP:
MOVE PNT,GENLEF+1 ;ITEM INTO AC 3
MOVEI D,3
GENMOV (GET,SPAC!GETD)
PUSHJ P,REMOP ;REMOP THE TEMP
HRL C,PCNT ;FOR FIXUP TO PROPS
GLOC <
QPOP (GLBSTK)
SKIPE ALLGLO
JRST PPAGLO
JUMPN A,[PPAGLO:SKIPN NOEMIT
EXCH C,LIBTAB+RGPROPS
JRST GTPR2]
>;GLOC
SKIPN NOEMIT
EXCH C,LIBTAB+RPROPS
GTPR2: PUSHJ P,GETAC ;AC FOR RESULT
EMIT <LDB ,USADDR>
PUSHJ P,MARKINT ;MARK AS INTEGER
MOVEM PNT,GENRIG+1
POPJ P,
; MAKE AND ERASE
DSCR MAKIT, ERAS, MKSET, MAK
PRO MAKIT ERAS MKSET MAK
⊗
↑MAKIT: JUMPE B,MAK
↑ERAS:
STAKCHECK (3) ;THREE ARGUMENTS.
TLNE A,FBIND ;BIND NOT VALID
ERR <BIND NOT VALID IN ERASE>,1
RETCHK ;RETRIEVAL TYPES NECESSARY
TLNN A,LPITM ;ITEMS ONLY ?
ERR <MAKE AND ERASE DO NOT ACCEPT SET ARGUMENTS>,1
LPCALL (ERAS) ;ERASE CALL.
POPJ P,
↑MKSET: ;GO INTO MAKING MODE.
SKIPN B
SETOM MKFLAG ;TO DETERMINE IF BRACKETED TRIPLE SHOULD
;BE MADE, OR RETRIEVED
POPJ P,
↑MAK: ;MAKE AN ASSOCIATION.
SETZM MKFLAG
STAKCHECK (3) ;THREE ARGUMENTS.
;; #OY# MAKE CAN'T TAKE SET ARGUMENTS
TLNN A,LPITM ;EVERYTHING HAD BETTER BE ITEMS
ERR <MAKE DOES NOT ACCEPT SET OR LIST ARGUMENTS>,1
;; #OY#
TLNE A,FBIND
ERR <BIND NOT VALID IN MAKE>,1
CONCHK ;CONSTRUCTION TYPES NECESSARY
LPCALL (MAKE) ;DOIT
POPJ P,
; VARIOUS BOOLEANS.
DSCR STIN, ISTRIP, ISIT, STREL
PRO STIN ISTRIP ISIT STREL
⊗
↑STIN: ; X IN SET ?
;; #SQ# ! (1 OF 2) SAVE WHETHER SET OR LIST HERE
PUSH P,@LEAPSK ;TOP LEAPSK ENTRY
STAKCHECK (2) ;TWO ARGUMETS.
TLNE A,FBIND
ERR <BIND NOT VALID IN SET BOOLEANS>,1
RETCHK ;RETRIEVAL TYPES NECESSARY
XPREP
;; %AF% (3 OF 3) DIFFERENT ROUTINES FOR LIST AND SET MEMBERSHIP BOOLEANS
;; #SQ# ! (2 OF 2) TEST THE CORRECT BITS
POP P,A
TLNE A,LPXISX ;A LIST WE'RE SEARCHING?
JRST [LPCALL (LSTIN)
JRST INTGO1]
;; %AF%
LPCALL (STIN)
JRST INTGO1 ;MARK AS INTEGER.
↑ISTRIP: ; IS X A BRACKETED TRIPLE ?
STAKCHECK (1)
XPREP
LPCALL (ISTRIP) ;CALL
JRST INTGO ;MARK AN INTEGER AND LET BOOP FIND IT.
↑ISIT: ;A XOR B EQV C ?
STAKCHECK (3) ;THREE ITEMS.
RETCHK ;RETRIEVAL TYPES NECESSARY
TLNE A,FBIND
JRST [XPREP
LPCALL(BNDTRP) ;CALL
JRST INTGO1]
XPREP
LPCALL (ISIT) ;CALL.
JRST INTGO1
↑ITMREL:SOS B,LEAPSK ;DEC LEAP STACK
;; #PX# (8 OF 13)
SKIPN PNT,1(B) ;OLD TOP OF LEAP STACK
ERR <NON-LEAP ARGUMENT TO LEAP EXPRESSION>,1
;; #PX#
TLNE PNT,LPDMY
ERR <BRACKETED TRIPLE WON'T WORK HERE>,1
TLNN PNT,STACKED ;STACKED?
;;#NM# ! (1 OF 2) IF A BINDING ITEMVAR MUST LOAD;
JRST BINTST ;NO, JUST STORE
HRRI FF,0 ;DON'T NEED INDX OR DBL
PUSHJ P,GETAC ;GET AN AC
;; #LF# FOLLOWING WAS A HRLI
HRL C,D ;THE AC NUMBER
EMIT <POP RP,NOUSAC!USADDR!NORLC>
SOS ADEPTH ;NO LONGER ON STACK
HRRI TBITS,ITMVAR
PUSHJ P,MARKME ;MARK AS ITEMVAR TEMP
JRST ITMRE2
;; #NM# (2 OF 2) LOAD INTO AC IF ? ITEMVAR
BINTST: ;IF A BINDING ITEMVAR MUST MAKE A TEMP;
MOVE TBITS,$TBITS(PNT);
TLNN TBITS,MPBIND ; A BINDING PARAM?
JRST ITMRE2 ; NO.
GENMOV (GET,GETD) ;LOAD INTO AC
HRRI TBITS,ITMVAR
PUSHJ P,MARKME ;MARK AS ITMVAR
;; #NM#
ITMRE2: HRRZM PNT,GENRIG+1
HRRZM PNT,GENLEF+1 ;BOTH PLACES
POPJ P,
↑STREL: ;RELATIONS ON LISTS, SETS AND ITEMS.
CAIN B,2 ;=?
JRST SRELOK ;YES
CAIN B,3 ;≠?
JRST SRELOK ;YES
HRLZI A,LPITM!LPXISX ;INVALID TYPES FOR GTR. LE.
MOVE C,LEAPSK ;ADDR. TOP OF PSEUDO STACK
TDNE A,(C) ;O.K. RELATION
JRST RELERR ;NO.
TDNN A,-1(C) ;OTHER ARGUMENT SET?
JRST SRELOK ;YES, RELATION IS VALIED
RELERR: ERR <INVALID RELATION, CHANGED TO ≠>,1
MOVEI B,3 ;≠
SRELOK: PUSH P,B ;TYPE OF RELATION.
MOVE A,@LEAPSK ;TOP OF LEAP STACK
TLNN A,LPITM ;AN ITEM?
JRST SREOK2 ;NO.
PUSHJ P,ITMREL ;GET OFF OF LEAP STACK
SKIPN PNT,GENLEF+3
ERR <DRYROT AT LEAP:SRELOK>,1
MOVE TBITS,$TBITS(PNT) ;
TRNN TBITS,ITEM!ITMVAR
ERR <INVALID ITEM COMPARISON>,1
TRNE TBITS,ITEM ;AN ITEMVAR?
TLNE TBITS,FORMAL!SBSCRP
JRST STMREL
HRRZ PNT,$VAL2(PNT) ;GET CONSTANT SEMBLK
JUMPN PNT,STMREL
ERR <DRYROT AT LEAP:STMREL>
STMREL: MOVEM PNT,GENLEF+3
MOVE PNT,GENLEF+1
MOVE TBITS,$TBITS(PNT)
TRNE TBITS,ITEM
TLNE TBITS,FORMAL!SBSCRP
JRST STMRE2
HRRZ PNT,$VAL2(PNT)
MOVEM PNT,GENLEF+1
STMRE2:
POP P,B ;RELATION TYPE
JRST IREL ;IN BOOLEAN CODE(EXPRS)
SREOK2:
STAKCHECK (2) ;TWO ARGUMENTS.
RETCHK ;RETRIEVAL TYPES NECESSARY
XPREP
TLNN A,LPITM ;ITEMS?
JRST SETSES ;NO -- SETS.
ERR <INVALID ITEM COMPARISON>,1
; LPCALL (<ITMREL-2>,<(P)>)
JRST STFIN
SETSES: TLNN A,LPSET ;IS IT REALLY A SET.
ERR <NO MIXED RELATIONS, PLEASE>,1
LPCALL (SETREL,<(P)>)
STFIN: POP P,B
GETBLK GENRIG+1 ;SIMULATE A BOOLEAN
MOVEM LPSA,GENRIG
PUSHJ P,GOSTO
EMIT (<JUMPE NOADDR>)
MOVE A,[XWD 1,$VAL]
JRST BODON ;FINISH OUT WITH BOOLEANS
DSCR DELT, SIPGO, STPRIM, ECVI, STLOP, PUTIN, LPPHI, etc.
PRO DELT, SIPGO, STPRIM SIP1 STCNT STUNT ECVI ECVN STLOP
PRO STMIN STINT STUNI PUTIN LPPHI
⊗
↑DELT: ;DELETE THE ITEM.
STAKCHECK (1)
RETCHK ;RETRIEVAL TYPES NECESSARY
LPCALL (DELETE)
POPJ P,
; START A LIST IN THE MAKING.
↑LIPGO: SKIPA A,[-1] ;TO STORE IN LORSET
; START A SET IN THE MAKING. I.E. A← SETO ONE,TWO,THREE SETC
↑SIPGO:
SETZ A, ;TO STORE IN LORSET
QPUSH (LORSET)
PUSHJ P,OKSTACK
MOVEM FF,FFSAVE ;SAVE THE FLAG WORD.
TLZ FF,LPPROG
MOVEI A,0
PUSHJ P,CREINT
EMIT (<PUSH RP,NOUSAC>)
AOS ADEPTH
POPJ P,
↑STPRIM: ;ALL DONE -- JUST MARK "STACK"
MOVSI A,LPPROG
TDNE A,FFSAVE
TLO FF,LPPROG
MOVE C,PHIBLK ;DUMMY SET SEMBLK
HRLZI B,LPSET!STACKET!RETRV ;THESE ARE THE NEW BITS.
HLRZ A,LORSET ;ADDRESS TOP ENTRY
SKIPE (A) ;SKIP IF SET
JRST [TLO B,LPXISX ;REALLY A LIST
MOVE C,NILBLK ;DUMMY LIST SEMBLK
JRST .+1]
MOVEM C,GENRIG ;FAKE UP PARSE STACK
QPOP (LORSET)
HLLZ A,B
JRST BFIN
↑SIP1: ;CALLED FOR EACH ELEMENT OF SET LIST.
STAKCHECK (1)
HLRZ A,LORSET
SKIPE A,(A)
JRST [LPCALL (LSTMAK)
POPJ P,]
LPCALL (SIP)
POPJ P,
↑STCNT: ;LENGTH OF SET (# OF ELEMENTS)
;; #PX# (9 OF 13)
SKIPN PNT,@LEAPSK
ERR <NON-LEAP ARGUMENT TO LEAP EXPRESSION>,1
;; #PX#
MOVE SBITS,$SBITS(PNT)
TLNN PNT,STACKED ;ALREADY STACKED?
TLNE SBITS,ARTEMP ;OR A TEMP?
JRST LPCNT ;CALL LEAP DO DO IT
;; #RB# (1 OF 4) JRL DO ACCESS BEFORE EMIT
GENMOV (ACCESS,GETD)
;; #RV# (1 OF 2) DON'T ALLOW LENGTH(ITEM)
TRNE TBITS,ITEM!ITMVAR
ERR <LENGTH OF ITEM EXPRESSION>,1
;; #RV#
PUSHJ P,GETAC ;GET AN AC TO PLAY WITH
EMIT <HLRE ,> ;FETCH THE LENGTH
SOS LEAPSK ;SO LONGER ON LEAP STACK
JRST INTGO ;MAKE INTO INTEGER
LPCNT: ;WILL HAVE TO CALL LEAP
STAKCHECK (1)
;; #RV# (2 OF 2)
TLNE A,LPITM
ERR <LENGTH OF ITEM EXPRESSION>,1
;; #RV#
INFENT: XPREP
LPCALL (SETCUNT) ;ENTER HERE FROM PROCESSING INF.
INTGO: PUSHJ P,MARKINT ;MARK AN INTEGER.
HRRI TBITS,INTEGR
MOVEM TBITS,$TBITS(PNT) ;IN CASE WAS A TEMP ITMVAR OR SOMETHING
;SINCE MARK DOESN'T CHANGE TBITS OF TEMP
MOVEM PNT,GENRIG
POPJ P,
INTGO1: PUSHJ P,MARKINT ;MARK AS INTEGER
HRRI TBITS,INTEGR
MOVEM TBITS,$TBITS(PNT)
MOVEM PNT,GENRIG+1
POPJ P,
↑STUNT: ;COP OF SET (GET ONE ELEMENT)
STAKCHECK (1)
;; #RS# GIVE ERROR MESSAGE FOR COP(ITEMVAR)
TLNN A,LPSET!LPXISX
ERR <COP REQUIRES LIST OR SET EXPRESSION ARGUMENT>,1
;; #RS#
LPCALL (STUNT)
HRLZI A,LPITM!STACKET!RETRV!CNSTR ;A NEW ITEM.
JRST BFINA
↑ECVI:
MOVE PNT,GENLEF+1 ;CONVERT TO ITEM.
GENMOV (GET,GETD!INSIST,INTEGR)
PUSH P,D ;THE AC ITS IN
PUSHJ P,REMOP ;REMOP THE INTEGER TEMP
POP P,D
MOVEI TBITS,ITMVAR
PUSHJ P,MARKME ;THIS IS REALLY AN ITEMVAR
MOVE A,PNT
HRLI A,LPITM!RETRV!CNSTR
JRST LPREC ;PUT BACK ON STACK.
↑ECVN: SKIPN PNT,@LEAPSK ;TOP OF LEAP STACK
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
TLNE PNT,LPSET!LPXISX ;BETTER NOT BE SET;
ERR <CVN ONLY VALID FOR ITEMS>,1
TLNE PNT,LPDMY
ERR <BRACKETED TRIPLE INVALID HERE>,1
TLNN PNT,STACKET ;ALREADY STACKED?
JRST GTITM
STAKCHECK (1) ;ALREADY ON RUNTIME STACK
PUSHJ P,GETAC ;GET A RESULT NUMBER.
HRL C,D
EMIT <POP RP,NOUSAC!NORLC!USADDR>
JRST INTGO ;GO MAKE AN INTEGER
; (SEE "LLEN" IN STRING.)
GTITM:
MOVE TBITS,$TBITS(PNT) ;TYPE BITS OF QUANTITY
TRNE TBITS,ITEM ;DECLARED ITEM?
JRST [TRNE TBITS,FORMAL!SBSCRP
JRST .+1
HRRZ TEMP,$VAL2(PNT) ;THE CONSTANT SEMBLK
JUMPE TEMP,.+1 ;NOT THERE
MOVEM TEMP,GENRIG ;THE CONSTANT SEMBLK
SOS LEAPSK ;NO LONGER ON LEAP STACK
POPJ P,]
GENMOV (GET,GETD) ;NOT STACKED
SOS LEAPSK ;NO LONGER ON LEAP STACK
JRST INTGO ;MAKE INTO INTEGER
FIRREF: SOS PNT,LEAPSK ;THERE SHOULD BE SOMETHING THERE.
SKIPN PNT,1(PNT)
ERR <NON-LEAP ARGUMENT TO LEAP EXPRESSION>,1
TRNE PNT,-1
TLNE PNT,STACKET ;NOT STACKED, I HOPE
ERR <NEEDS REFERENCE ARG>,1,CPOPJ
PUSHJ P,GETAD
TLNE SBITS,INDXED!FIXARR ;OK IF CALC. SBSCRP.
JRST FIROK
TLNE SBITS,ARTEMP!STTEMP ;NOT THESE
ERR <NEEDS REFERENCE ARG>,1
FIROK: GENMOV (ACCESS,0)
EMIT <MOVEI TAC1,NOUSAC>
PUSHJ P,REMOP
POPJ P,
↑STLOP: PUSHJ P,FIRREF ;FIRST ARG BY REF....
LPCALL (STLOP)
;; #OQ# ! DID NOT INCLUDE CNSTR BIT
HRLZI A,LPITM!STACKET!RETRV!CNSTR
JRST BFINA
FOR II IN (STMIN,STINT,STUNI),<
↑II: SETCHK (2) ;NEEDS TWO SET ARGUMENTS
STAKCHECK (2,LEAVE)
LPCALL (II)
POPJ P, >
↑REMAST: SETOM REMASET ;INDICATES REMOVE ALL
POPJ P,
↑PUTIN: ;PUT AND REMOVE.
PUSH P,B ;PARSER INDEX
;; #SR# ! TYPE CHECK TO CATCH PUT X IN LIST.
PUSH P,@LEAPSK
PUSHJ P,FIRREF ;GO GET IT.
STAKCHECK (1) ;FOR THE ITEM.
POP P,A ;THE TYPE BITS
POP P,D
SKIPN D
JRST [
;; #SR# TYPE CHECK
TLNE A,LPXISX ;BETTER NOT BE A LIST VARIABLE
ERR <INVALID LIST PUT STATEMENT>,1
;; #SR#
LPCALL (STPUT)
POPJ P,]
SKIPE REMASET
JRST [SETZM REMASET
LPCALL (REMALL)
POPJ P,]
LPCALL (STREM)
POPJ P,
; THINGS TO MAKE NIL AND PHI WORK. THEY JUST MARK THE COMPILE STACK.
↑STKNIL: SKIPA C,NILBLK ;SEMANTIC BLOCK NIL LIST
↑LPPHI: MOVE C,PHIBLK ;GET SEMANTIC BLOCK
MOVEM C,GENRIG
MOVE A,[XWD LPSET!LPNUL!RETRV,0]
CAME C,PHIBLK
TLO A,LPXISX
LPREC: ;ENTER HERE FROM ECVI
PUSHJ P,BFIN
TLNE FF,LPPROG
POPJ P, ;FOREACH GOING ON.
MOVEI D,-1(B) ;THING BEFORE THE "NIL"
CAIL D,LEABEG ;ANYTHINGTO STACK ?
JRST STAKIT ;STACK IT.
POPJ P,
LSTON (LEAP)
DSCR PUTINL,HLDPNT,REMXD,REPLCX LISTGT
PRO PUTINL,HLDPNT,REMXD,REPLCX,LISTGT
⊗
COMMENT ⊗
PUTINL is exec routine which is called to generate PUT AFTER
REMXD is exec routine which generates REMOVE indx FROM list
HLDPNT simply takes argument off of LEAPSK and saves it in
location HOLDPNT.
LISTGT causes TEMP to be loaded from list variable whose semantics
are in HOLDPNT
⊗
↑PUTINL: ;PUT INTO LIST (AFTER,BEFORE)
PUSH P,B ;PARSER INDEX
GETSEM (1) ;SEMANTICS OF AE
TRNN TBITS,ITEM!ITMVAR!SET ;SET TO TAKE CARE OF COP,LOP ; ITEM OR ARITHMETIC?
JRST PUTXAB ;ARITHMETIC
PUSHJ P,LISTGT ;CROCK TO GET LIST ARGUMENT
STAKCHECK (2) ;TWO ITEM ARGUMENTS
;HERE WE SHOULD PROBABLY CHECK TO MAKE SURE BOTH ITEMS NOT SETS.
TLNN A,LPITM ;BOTH ITEMS?
ERR <SET OR LIST WHERE ITEM EXPECTED>,1
POP P,B ;POP INDEX
LPCALL (PUTAFT,<B>) ;CALL LEAP
POPJ P, ;RETURN TO PARSE
PUTXAB: STAKCHECK (1) ;ITEM ARGUMENT
TLNN A,LPITM ;REALLY AN ITEM?
ERR <SET OR LIST WHERE ITEM EXPECTED>,1
AOS ADEPTH ;SINCE STAKCHECK DECREMENTED.
GETSEM (1) ;INDEX AMOUNT
GENMOV (STACK,INSIST,INTEGR) ;STACK AND COERCE TO INTEGER
PUSHJ P,LISTGT
MOVNI B,2
ADDM B,ADEPTH ;PARAMETERS WILL DISAPEAR
POP P,B ;PARSER INDEX
LPCALL (PUTXA,<B>)
POPJ P,
LISTGT: MOVE A,HOLDPT ;PNTR FOR LIST SEMBLK
AOS B,LEAPSK ;WILL STACK IT TO USE FIRREF
MOVEM A,(B) ;STACK IT
MOVE A,$TBITS(A)
TRNN A,LSTBIT
ERR <LIST DESTINATION REQUIRED>,1
PUSHJ P,FIRREF ;LIST ARGUMENT
POPJ P,
↑HLDPNT:SOS B,LEAPSK ;TAKE OFF OF LEAP STACK
;; #PX# (10 OF 13)
SKIPN A,1(B)
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
MOVEM A,HOLDPT ;SAVE LIST SEMBLK POINTER
POPJ P,
↑REMXD: ;REMOVE INDEXED
GETSEM (3) ;INDEX
GENMOV (STACK,INSIST,INTEGR) ;COERCE AND STACK
PUSHJ P,FIRREF ;FOR LIST PARAMETER
SOS ADEPTH ;PARAMETER WILL GO AWAY
LPCALL (REMX) ;FOR CALL TO LEAP
POPJ P, ;RETURN TO PARSE
↑REPLCX: STAKCHECK (1) ;ITEM
AOS ADEPTH ;SINCE STACKCHEK DECREMENTED.
GETSEM (3) ;INDEX
GENMOV (STACK,INSIST,INTEGR) ;COERCE AND STACK
GETSEM (4) ;LIST ARGUMENT
TRNN TBITS,LSTBIT
ERR <REPLACE REQUIRES LIST PARAMETER>,1
GENMOVE (ACCESS,0) ;LIST PARAMETER
EMIT <MOVEI TAC1,NOUSAC>
MOVNI A,2
ADDM A,ADEPTH ;TWO PARAMS WILL GO AWAY.
LPCALL (RPLAC)
POPJ P, ;RETURN TO PARSE
DSCR CVLS,LSSUB,SELIP,SELSBL
⊗
COMMENT ⊗ CVLS GENERATES THE CODE TO CONVERT A LIST EXPRESSION INTO
A SET EXPRESSION AND VICE-VERSA.
REFINF - puts semantics of list variable on LENSTR q-stack for
appropriate handling of INF
⊗
↑CVLS: ;CONVERT LIST TO SET(VICE-VERSA)
; B 1 IF CVLIST, 0 IF CVSET
MOVE A,GENLEF+1
MOVEM A,GENRIG ;TWIDDLE PARSE STACK
SKIPN A,@LEAPSK
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
TLNN A,LPSET
ERR <CVLIST CVSET REQUIRE SET, LIST ARGUMENTS>,1
JUMPE B,[STAKCHECK (1);LIST
LPCALL (SETLST)
HRLZI A,LPSET!STACKET!RETRV!CNSTR
JRST BFINA]
;; #KO# BY JRL CVLIST SHOULD MARK RESULT AS LIST
HRLZI A,LPSET!LPXISX!RETRV!CNSTR
IORM A,@LEAPSK
POPJ P,
↑↑REFINF: ;REFERENCE FORM FOR INF
GETSEM (1) ;THE LIST
MOVE A,PNT
HRLI A,777000
JRST REFENT
↑↑LSSUB: ;SET UP TO HANDLE INF.
PUSHJ P,OKSTACK
HRRO A,ADEPTH
REFENT: QPUSH (LENSTR) ;SAME AS SUBSTRING USES
AOS LENCNT
POPJ P,
↑ELSSUB: ;DISABLE INF.
QPOP (LENSTR)
SOS LENCNT
POPJ P,
↑↑LINF: ;HANDLE INF. WITHIN LIST SELECTION OR REPLACE
TLNN A,777 ;REFERENCE FORM
JRST [HRRZ PNT,A
JRST REFLNG] ;PERM. SET, WE CAN FIND THE LENGTH DIRECTLY
MOVN C,ADEPTH ;CURRENT ADEPTH
ADDI C,(A) ;RELATIVE STACK POSITION
LSH C,=18 ;PREPARE FOR EMIT
PUSH P,C ;SAVE IN CASE DESTROYED BY ROUTINES
PUSHJ P,GETAC ;GET AN ACCUM. TO PLAY WITH
PUSHJ P,MARKINT ;LENGTH IS AN INTEGER
MOVEM PNT,GENRIG ;PARSER EXPECTS A SEMBLK
POP P,C ;IN CASE GETAC OR MARKINT DESTROYED
HRLI D,P ;PREPARE FOR EMIT
EMIT <HLRE ,USADDR!NORLC!USX>
HRL C,D ;PREPARE FOR MOVMS
EMIT <MOVM ,USADDR!NORLC>
POPJ P,
REFLNG: ;TO DETERMINE LENGTH OF PERMANENT SET
;; #RB# ! (2 OF 4) DO ACCESS BEFORE EMIT
GENMOV (ACCESS,GETD)
PUSH P,PNT ;REFERENCE TO SET,
PUSHJ P,GETAC ;ACCUM TO PLAY WITH
PUSHJ P,MARKINT ;LENGTH RETURNED IS INTEGER
MOVEM PNT,GENRIG ;PRODUCTIONS EXPECT IT HERE
POP P,PNT
MOVE SBITS,$SBITS(PNT);GET SBITS
EMIT <HLRE >
POPJ P,
↑SELIP: ;SELECT ITEM INDEXED FROM LIST
STAKCHECK (1) ;FOR LIST ARGUMENT
AOS ADEPTH ;SINCE STACKCHEK DECREMENTED.
GETSEM (1) ;INDEX
GENMOV (STACK,INSIST,INTEGR)
LPCALL (SELFETCH)
SOS ADEPTH ;PARAM WILL GO AWAY.
HRLZI A,LPITM!STACKET!RETRV!CNSTR
JRST BFIN
↑SELSBL: ;FOR TAKING A SUBLIST
SUBI B,4 ;PARSER INDEX 0 IF TO ,1 IF FOR
SKIPGE B ;CHECK TO MAKE SURE TO OR FOR
ERR <ERROR- SUBLIST SYNTAX, FOR ASSUMED>,1
PUSH P,B ;SAVE FOR LATER USE
STAKCHECK (1) ;FOR LIST
AOS ADEPTH ;SINCE DECREMENTED.
GETSEM (3) ;FOR FIRST ARG.
GENMOV (STACK,INSIST,INTEGR) ;FOR FIRST INDEX
GETSEM (1) ;FOR SECOND INDEX
GENMOV (STACK,INSIST,INTEGR)
MOVNI A,3 ;STACK WILL BE THREE LESS
ADDM A,ADEPTH
POP P,B ;RESTORE INDEX
CAIE B,0 ;TO?
JRST [LPCALL (FSBLST)
HRLZI A,LPSET!LPXISX!STACKET!RETRV!CNSTR
JRST BFINA]
LPCALL (TSBLST)
HRLZI A,LPSET!LPXISX!STACKET!RETRV!CNSTR
JRST BFINA
↑LSTCAT: ;CONCATENATE TWO LISTS
STAKCHECK (2,LEAVE)
LPCALL (CATLST)
HRLZI A,LPXISX!LPSET ;RESULT IS LIST
ORM A,@LEAPSK
POPJ P,
;GETTING NEW ITEMS.
DSCR NEWNOT, NEWART, GLBSET, SELET,RFIMAK
PRO NEWNOT NEWART, GLBSET, SELET
⊗
DSCR ITMTYP returns type code in A corresponding to bits in A. Normally
A will have been loaded with TBITS entry for type
TYPE CODES NOW CONTAINED IN HEAD.
STTYPE←← 3
FLTYPE←← 4
INTYPE←← 5 ;INTEGER ITEM
SETYPE←← 6 ;SET ITEM
LSTYPE←← SETYPE+1 ;LIST ITEM,TYPE CODE SHOULD BE 1 GTR SETYPE
CTXTYP←← 13
ARRTYP←← 15 ;ADDED TO MAKE ARRAY
⊗
↑ITMTYP: PUSH P,B ;SAVE B
MOVEI B,0 ;INITIALLY NO TYPE
TLNE A,SBSCRP ;AN ARRAY?
ADDI B,ARRTYP
TRNE A,LPARRAY ;DECLARED ARRAY ITEM?
ADDI B,ARRTYP ;YES
TRNN A,SET ;A SET OR LIST?
JRST NTSET
TRNE A,FLOTNG ;A CONTEXT?
ADDI B,1 ;MAKE UP FOR CONTEXT =13 BUT SET+REAL=12
ADDI B,SETYPE ;YES
TRNE A,LSTBIT ;A LIST?
ADDI B,1 ;LIST TYPE 1 GTR THAN SET
NTSET: TRNE A,FLOTNG ;REAL?
ADDI B,FLTYPE
TRNE A,STRING
ADDI B,STTYPE
TRNE A,INTEGR
ADDI B,INTYPE
REC <
TRNE A,PNTVAR
ADDI B,RECTYP ;A RECORD
>;REC
SKIPN A,B
MOVEI A,1 ;UNTYPED ITEM TYPE IS 1
POP P,B ;RESTORE B
POPJ P,
↑NEWNOT: PUSHJ P,OKSTACK ;REGULAR NEW.
MOVEI A,1
HRLM A,BYTES ;TYPE CODE FOR UNTYPED ITEM
LPCALL (NEWITM)
MOVEI TBITS,0
TLZ FF,FFTEMP
JRST ONCON
↑NEWART: ;NEW (ARITHMETIC ARGUMENT)
PUSHJ P,OKSTACK
GETSEM (1)
TRNE TBITS,ITEM!ITMVAR
ERR <NEW OF ITEM EXPRESSION ILLEGAL>,1
TRNN TBITS,SET ;IF SET, ALREADY STACKED
JRST NTSTKD
TDNE TBITS,[XWD SBSCRP,FLOTNG] ;UNLESS ARRAY OR CONTEXT
JRST NTSTKD
SOS A,LEAPSK
HLRZ B,1(A); GET TYPE BITS
MOVEI A,SETYPE; FIRST ASSUME SET
TRNE B,LPXISX; A LIST
ADDI A,1 ; REALLY A LIST
JRST ISSTACK ;DON'T RESTACK IT
NTSTKD: MOVE A,TBITS ;PREPARE FOR CALL TO ITMTYP
PUSHJ P,ITMTYP ;GET TYPE
PUSH P,A ;SAVE FOR LATER
CAIN A,CTXTYP ;CONTEXT?
JRST [CAME PNT,NULLCN ;HAD BETTER BE NULL!CONTEXT
ERR <ONLY NULL!CONTEXT MAY BE ARGUMENT TO NEW>,1
MOVEI A,0 ;WILL STACK 0
PUSHJ P,CREINT
JRST .+1]
GENMOV (STACK,GETD) ;STACK THE ARITHMETIC.
POP P,A ;GET TYPE BACK
ISSTACK:
;; #MR# A STRING ARRAY IS NOT A STRING
TLNN TBITS,SBSCRP
TRNN TBITS,STRING
JRST NWA ;NOT A STRING
MOVNI B,2
ADDM B,SDEPTH
CAIA
NWA: SOS ADEPTH ;IT IS A PARAMETER.
HRLM A,BYTES ;TYPE TO LEAP PARAM
TLNE TBITS,SBSCRP
JRST [LPCALL (NEWRY)
JRST DCON]
LPCALL (NEWARITH)
DCON:
;; #NR# ! AVOID DRYROT REMOP STCNST
;;; PUSHJ P,REMOP ;STACK HAS ALREADY DONE REMOP
ONCON: MOVSI A,LPITM!CNSTR!STACKET ;RECORD THAT NEW ENTRY IS ITEM.
JRST BFINA
NOGLOC <
↑GLBSET: ERR <THIS COMPILER WON'T DO GLOBAL MODEL TYPE THINGS>,1
↑GLBST2: POPJ P,
>;NOGLOC
GLOC <
↑GLBSET: AOS LEPGLB
POPJ P, ;$$$*** $$$*** $$$***
↑GLBST2: QPUSH (GLBSTK,LEPGLB) ;SAVE STATE, REALLY ZERO,NON-ZERO.
SKIPE LEPGLB ;IF NON-ZERO
SOS LEPGLB ;DECREMENT
POPJ P,
>;GLOC
↑SELET: ;FIRST, SECOND, THIRD.
PUSH P,B ;SELECTOR INDEX.
GLOC <
PUSHJ P,GLBST2 ;HANDLE "GLOBAL"
>;GLOC
STAKCHECK (1) ;ONE ARGUMENTS.
RETCHK ;RETRIEVAL TYPES NECESSARY
LPCALL (SELECT,<(P)>)
POP P,B
MOVSI A,LPITM!RETRV!STACKET ;RESULT IS AN ITEM.
JRST BFINA
;;%BH% -- ADD EXEC RFTEMP & REORGANIZE RFIMAK SO MAIN PART IS RFDPSH
ZERODATA(REFERENCE VAR FLAG)
NOSKIT: 0 ;IF NOT 0, THEN RFDPSH DOESN'T STACK THE DESCRIPTOR
;AND RETURNS ITS SEMANTICS IN PNT
ENDDATA
↑RFNCDO:
SETOM NOSKIT
GETSEM (1) ;GET SEMANTICS OF EXPRN
HLRZ PNT2,GENLEF+2 ;GET EXTRA FLAG BITS
TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR]
TRNN TBITS,STRING
JRST RFDT.1 ;BETTER NOT ALLOW STRING VALUES ON STACK
TLNN SBITS,STTEMP ;IF A STRING TEMP OR CONSTANT
TLNE TBITS,CNST ;
ERR <UNFORTUNATELY, REFERENCE WONT WORK FOR STRING EXPRESSIONS>,1
RFDT.1: PUSHJ P,RFDPSH ;GET REFERENCE COMPUTED
SETZM NOSKIT ;RESET THE FLAG
HRRZM PNT,GENRIG ;RESULT SEMANTICS
POPJ P,
↑RFIMAK:
PUSHJ P,RFDPSH ;GO PUSH REFITEM DATUM
MOVEI A,RFITYP ;THE ACTUAL TYPE
JRST NWA ;GO PUT IT AWAY
↑RFDPSH:
GETSEM (1) ;THE EXPRN
;;#RQ# -- TO MAKE STRING CONSTANTS WORK, ESPECIALLY FOR WRITEON
TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR]
TRNN TBITS,STRING
JRST RFDP1 ;JUMP IF ARRAY OR ITEM OR NOT STRING
;;#SB# ALL VALUE STRINGS MUST PUSH SP,...
TLNN TBITS,CNST
TRNE PNT2,1⊗5 ;
TLNE SBITS,STTEMP ;DON'T STACK AGAIN IF STRING
JRST RFDP1 ;JUMP IF NOT CONSTANT ∧ ¬VALUE
;;#SB#
GENMOV (STACK,0) ;WE NOW HAVE A STRING CONSTANT
MOVEI TBITS,STRING ; MAKE A STRING TEMP FROM IT
SETZM SBITS
GENMOV (MARK,0)
MOVEM PNT,GENLEF+1 ;THIS THING IS NOW A STRING TEMP
RFDP1:
;;#RQ#
;;#OK# -- TO MAKE ITEMS WORK
TRNE TBITS,ITEM ;ITEMS NEED TO HAVE VALUES
JRST [ HRRZ PNT,$VAL2(PNT); GET NUMBER, BUT KEEP THESE SEMANTICS
MOVEI B,0 ;LIKE A CONSTANT
TRZ PNT2,1⊗5;RESET THIS IMPORTANT FLAG
JRST RFDAT] ;GO DO REST
;;#SE#
;;#OK#
MOVEI B,REFB ;USUALLY A REAL LIVE REF
TLNN TBITS,CNST ;CONSTANTS GO RIGHT AWAY
TLNE SBITS,ARTEMP!INUSE
TRZ B,REFB ;THIS IS A TEMP
TLNE SBITS,INDXED!PTRAC
TRO B,REFB ;REFERENCE !
;;%BH% -- USE THE FLAG A BIT DIFFERENT NOW
TRZE PNT2,1⊗5 ;WAS IT A VALUE
TRZ B,REFB ;YES
TMPTST: TRNE A,-1 ;A ZERO RH MEANS NOT TEMP
TRO B,TMPB
RFDAT: MOVE A,TBITS ;THIS IS A REFERENCE
TRNN TBITS,ITMVAR!ITEM ;AN ITEMVAR?
JRST NTITRF ;NO
ISIREF: TRO B,ITEMB ;YES
TLCE A,SBSCRP ;ARY2 THING
TROA B,ARY2B ;
TLC A,SBSCRP ;
NTITRF: PUSHJ P,ITMTYP ;
LSH A,5 ;GET IT OVER
TLNE PNT,FBIND ;BIND?
TRO A,BINDB ;YES
TLNE PNT,QBIND ;? ?
TRO A,QUESB
TRO A,(B) ;THE ARY2 BIT & OTHERS
GENMOV (INCOR,0) ;BE SURE THE THING IS INCORE
TLNE SBITS,STTEMP ;STRING TEMP?
JRST ISSTTT ;YES
HRL PNT,A ;FOR DATUM
;;% %
TLO PNT,(PNT2) ;A FEW EXTRA BITS, PERHAPS
SETOM MPFLAG
PUSHJ P,FTRADR ;STACK THE TYPE,,POINTER
SETZM MPFLAG
;;#RZ# ! used to skipn
SKKRFD: SKIPE NOSKIT ;WANT A STACKING??
JRST SKKR.1
GENMOV (STACK,0) ;DOES THE ACTUAL STACKING (& REMOPS IT)
SKKR.1: MOVE LPSA,GENLEF+1 ;THE TEMP FROM THE EXPRN
PUSHJ P,REMOPL ;REMOP THE EXPRN
POPJ P,
ISSTTT:
;; #RP# ! TYPE BITS GO IN LEFT HALF
HRLZ A,A ;WE WERE COLLECTING BITS IN RIGHT HALF
TLZ A,REFB ;REFB NOT
TLO A,SP ;IS TOP OF STRING STACK
PUSHJ P,CREINT ;TYPES 0(SP)
MOVNI A,2 ;ADJUST SDEPTH
ADDM A,SDEPTH ;
JRST SKKRFD ;GO STACK THE RFI DATUM
;;%BH% FIX THESE GUYS TO SET THE BITS IN THE RIGHT HALF
↑RFTEMP: MOVSI A,TMPB
ORM A,GENLEF+2 ;SET FLAG TO INDICATE A TMPB ON
POPJ P,
↑RFVAL: ;SAY IS A VALUE
HRLZI A,1⊗5 ;THE BIT
HLLM A,GENRIG ;REMEMBER IT IN GENERATOR STACK
POPJ P,
↑RFZERO:
HRRZS GENRIG+1 ;ZERO OUT THE ENTRY
POPJ P,
↑RFBKLG: SKIPA A,[XWD BINDB,0]
↑RFQKLG: HRLZI A,QUESB ;REMEMBER ? BIT
ORM A,GENRIG+2
POPJ P,
; CASE, EXPRESSION CONDITIONALS.
DSCR LPCS2, LPCS3, LPEXF1, LPEXF2,CHKLEP
PRO LPCS2 LPCS3 LPEXF1 LPEXF2
⊗
↑CHKLEP: ;TO MAKE SURE EVERYTHING IS STACKED
;BEFORE PROCESSING CASE OR CONDITIONAL
;LEAP EXPRESSION
HRRZ TEMP,LEAPSK ;ANY THING ON LEAP STACK?
CAIG TEMP,LEABEG-1
POPJ P, ;NOPE
TLNE FF,LPPROG ;FOREACH IN PROGRESS?
ERR <WARNING: CONDITIONALS INSIDE FOREACH MAY NOT WORK CORRECTLY>,1
PUSHJ P,OKSTACK ;MAKE SURE THIS THING IS STACKED
POPJ P,
↑LPCS2:
MOVE SP,GENLEF+2
PUSHJ P,LASCHK
SKIPN TBITS,$TBITS(SP)
MOVE TBITS,A
MOVEM A,$TBITS(SP)
TLNN A,LPITM
JRST CASEMT ;NOT AN ITEM, SO OK.
XOR TBITS,A
TDNE TBITS,[XWD -1 ≠(CNSTR!RETRV!LPNUL),-1]
ERR <CASE STATEMENT MISMATCH>,1
JRST CASEMT
↑LPCS3:
MOVE SP,GENLEF+2
MOVE A,$TBITS(SP)
LPGO: PUSHJ P,BFINA
JRST CASEND
↑LPEXF1:
PUSHJ P,LASCHK
MOVEM A,GENRIG+1
JRST IFLS1
↑LPEXF2:
PUSHJ P,LASCHK
PUSH P,A
XOR A,GENLEF+3
TDNE A,[XWD -1 ≠(LPNUL!CNSTR!RETRV),-1]
ERR <EXPRESSION CONDITIONALS DON'T MATCH>,1
POP P,A ;TYPES ---
PUSHJ P,BFINA ;PUT BACK ON STACK.
JRST IFLS2
; STORE ROUTINES.
DSCR LPSTOR, LPFRSTO, LEAVE, PNAM
PRO LPSTOR LPFRSTO LEAVE PNAM
⊗
↑LPSTOR:
TDZA SP,SP ;NOT A FOR STATEMENT.
↑LPFRSTO: SETOM SP
MOVE PNT,GENLEF+2 ;SEMANTICS OF DESTINATION
GENMOV (ACCESS,GETD) ;GET ACCESS IF INDEXED
JUMPL SP,NOSQ ;IF A FOR LOOP, DO IT THE HARD WAY.
;; #PX# (11 OF 13)
SKIPN PNT2,@LEAPSK ;GET TOP OF STACK.
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
TLNE PNT2,LPDMY
ERR <THIS CONSTRUCT WON'T WORK WITHIN FOREACH>,1
TLNN PNT2,LPITM ;IF A SET, THEN DO IT HARD WAY.
JRST NOSQ ;CALL LEAP ANYWAY.
TRNN TBITS,ITEM!ITMVAR ;CHECK TYPE
ERR <STORING ITEM INTO WROND ID>,1
TRNE PNT2,-1 ;IF A TEMP
TLNE PNT2,STACKE ;OR STACKED
JRST ITMPOP ;WILL HAVE TO POP OFF STACK
TLNE TBITS,MPBIND
JRST ITMPOP
MOVEM PNT2,GENLEF+1 ;EXPRESSION SEMANTICS.
TLNN FF,FFTEMP ;DO NOT BACK UP IF EXPRESSION STORE.
SOS LEAPSK
JRST STORG ;BACK UP IN STORE FROM WHICH WE WER CALLED.
ITMPOP: ;WILL ATTEMPT TO GENERATE POP
PUSHJ P,OKSTACK ;MAKE SURE TOP REALLY STACKED
GETSEM (2) ;GET SEMANTICS OF DEST AGAIN
TLNE TBITS,MPBIND ;A ? PARAMETER?
JRST [MOVEM FF,FFSAVE
GENMOV (GET,ADDR!INDX) ;GET THE ADDRESS OF THE PARAM
MOVSS D ;PREPARE FOR POP
EMIT <POP RP,NOUSAC!NOADDR!USX!NORLC>
MOVE FF,FFSAVE
JRST DECSTK ;DECREMENT STACK IF NECESSARY
]
EMIT <POP RP,NOUSAC>
TLNE SBITS,INDXED!INUSE ;REMOP?
PUSHJ P,REMOP
DECSTK: SOS B,LEAPSK
SOS ADEPTH
TLNN FF,FFTEMP ;EXPRESSION STORE?
POPJ P,
MODSTK: MOVE A,[XWD 1,1]
PUSH P,PNT
PUSHJ P,CREINT
EMIT <ADD RP,NOUSAC>
POP P,PNT
HLL TBITS2,1(B) ;OLD TYPE BITS
JRST STE
NOSQ: TLNE TBITS,MPBIND ;A ? PARAMETER?
JRST [HRRI D,TAC1 ;WANT ADDR IN TAC1
PUSH P,TBITS
GENMOV (GET,ADDR!SPAC)
JRST NOSQ2]
MOVE A,[HRROI TAC1,NOUSAC]
TRNE TBITS,ITEM!ITMVAR
HRLI A,(<MOVEI TAC1,0>)
PUSHJ P,EMITER
PUSH P,TBITS ;PRESERVE DESTINATION TYPE.
NOSQ2: JUMPN SP,.+3 ;ONLY IF NOT OUR MAN FOR.
TLNE SBITS,INDXED!INUSE
PUSHJ P,REMOP ;REMOP HERE SINCE LPCALL CALLS
;ALLSTO.
STAKCHECK (1) ;AFTER THE MOVEI BECAUSE THIS WILL
;CHANGE ADEPTH, ETC....
POP P,TBITS
XPREP
TLNE A,LPITM
JRST [TRNN TBITS,ITMVAR
ERR <STORING ITEM INTO WROND ID>,1
JRST TYPOK]
TLNN A,LPSET!LPXISX
ERR <NEITHER SET, LIST, NOR ITEM EXPRESSION>,1,TYPOK
;; #HW# BY JRL 6-22-72 A SET ITEMVAR IS NOT A SET (LHS ASSIGNMENT)
TRNE TBITS,ITEM!ITMVAR ;BETTER NOT BE ITEM
ERR <STORING LIST OR SET INTO ITEM OR ITEMVAR>,1
;; #HW#
TRNN TBITS,SET
ERR <STORING LIST INTO WRONG ID>,1
TLNE A,LPXISX ;A LIST TO BE STORED?
TRNE TBITS,LSTBIT ;A LIST DESTINATION
CAIA
ERR <STORING LIST EXPRESSION INTO SET>,1
TYPOK: JUMPN SP,STD ;IF WITHIN FOR CAN'T BE EXPRESSION
MOVE TBITS2,A
TLNN FF,FFTEMP ;EXPRESSION STORE??
JRST STD ;NO
LPCALL (STORBUTDONTREMOVE)
JRST STE
STD: LPCALL (STORE)
STE: JUMPN SP,LFOR
TLNN FF,FFTEMP
POPJ P,
TLNN SBITS,INDXED!FIXARR
JRST STE1
GETBLK (PNT) ;GET A DUMMY SEMBLK.
TLO TBITS2,DUMSEM ;MARK THIS AS A DUMMY
MOVEM TBITS,$TBITS(PNT)
STE1: HRRI A,(PNT)
MOVEM PNT,GENRIG+1 ;SAVE FOR OTHERS.
HLL A,TBITS2
JRST BFINA ;MARK THE LEAP STACK.
↑LEAVE: ;ENTERED FROM ECHK, OTHERS?
;; #PX# (12 OF 13)
SKIPN A,@LEAPSK ;IS IT STACKED??
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
TRNE A,-1 ;SEE IF HAS SEMBLK POINTER
TLNE A,STACKET ;
JRST NOWW ;NO CLEVER.
TLNE A,LPDMY ;A CRAZY DERIVED SET OR BTRIP
JRST [ERR <DERIVED SET OR BRACKETED TRIPLE DOESN'T WORK HERE>,1
MOVE A,GENLEF+1 ;MAYBE THIS WILL SAVE REST OF COMPILING
JRST .+1]
MOVE TBITS,$TBITS(A)
TRNN TBITS,ITEM!ITMVAR!SET!LSTBIT
JRST NOWW
HRRZM A,GENLEF+1
TLNE A,FBIND!QBIND
HLLM A,GENLEF+1 ;LEAVE FBIND,QBIND BITS FOR CALARG TO FIND
SOS LEAPSK
POPJ P,
NOWW:
TLNE A,LPITM
JRST [PUSHJ P,GETAC ;AN AC TO STORE IT IN
HRLI C,(D) ;THE AC NUMBER
EMIT <POP RP,NOUSAC!USADDR!NORLC>
SOS LEAPSK
SOS ADEPTH
;; #KJ BY JRL (11-21-72) FOLLOWING INSTR WAS HRRI, GOT GARBAGE LH BITS
MOVEI TBITS,ITMVAR
SETZM SBITS
PUSH P,TBITS
JRST MARW]
STAKCHECK (1) ;MAKE SURE THIS IS THE VERY TOP.
SETZB SBITS,TBITS
TLNE A,LPSET
TRO TBITS,SET
TLNE A,LPXISX
TRO TBITS,LSTBIT
PUSH P,TBITS
XPREP
HRLI C,1 ;POP INTO AC 1
EMIT <POP RP,NORLC!USADDR!NOUSAC>
MARW: GENMOV (MARK,0)
MOVEM PNT,GENLEF+1
POP P,$TBITS(PNT) ;SINCE MARK IS INCREDIBLY STUPID.
POPJ P,
↑MAKEST: ;PERFORM CONVERSION TO SET FOR INSIST(GENMOVE)
GENMOV (STACK,GETD) ;STACK LIST
LPCALL (SETLST) ;CONVERT TO SETLST
POPMRK: XPREP
SOS ADEPTH ;REMOVEING FROM STACK
HRLI C,1
EMIT <POP RP,USADDR!NORLC!NOUSAC>
GENMOV (MARK,0) ;MARK RESULT
MOVEI A,SET
MOVEM A,$TBITS(PNT)
POPJ P,
↑MAKLST: ;PERFORM CONVERSION TO LIST FOR INSIST(GENMOV)
POPJ P, ;NO DUPLICATION NOW.
↑PNAM:
SKIPE PNMSW
ERR <SAY PNAMES ONLY ONCE>,1
AOS PNMSW ;WILL COUNT PNAMES.
MOVE A,SCNVAL ;FROM REQUIRE
MOVEM A,PNAMNO ;FOR ALLOCATION STUFF.
QPUSH (PNLST)
QPOP (PNLST)
MOVE A,PNLST
MOVEM A,PNBEG ;SAVE FOR TAKING THINGS OUT.
POPJ P,
↑ALLGLB: SETOM ALLGLO ;EVERY OPERATION IS TO BE CONSIDERED GLOBAL
POPJ P,
DSCR CALMP -MATCHING PROCEDURE EXECS
⊗
↑↑CALMP:
MOVE PNT2,GENLEF+1 ;PROCEDURE SEMANTICS
HRRZ PNT,$VAL(PNT2) ;
HRRI D,TEMP ;WE WANT IT LOADED INTO TEMP
PUSHJ P,LODPDA ;ADDR OF PDA ONTO STACK
HRLI C,TEMP ;PREPARE FOR PUSH
EMIT <PUSH RP,NOUSAC!NORLC!USADDR> ;PUSH PDA ONTO STACK
LPCALL (MATCAL) ;CALL MATCHING PROCEDURE
SOS ADEPTH ;FOR ITEM PARAM TO SPROUT
SETZM NEDPOP ;THE MP HAS DONE THE POP FOR US
; ADEPTH,SDEPTH HAVE ALREADY BEEN DECREMENTED BY ISUCAL FOR PARAMS
LPMPAR: QPOP (MPQSTK) ;POP OFF
JUMPE A,NOMORE ;ALL DONE?
HRLZI SBITS,LPFREE
ANDCAM SBITS,$SBITS(A) ;THE ? PARMS ARE NO LONGER FREEE
JRST LPMPAR
NOMORE: QPUSH (MPQSTK,A) ;PUT MARKER BACK ON
POPJ P,
↑↑SUCCEX:
PUSHJ P,ALLSTO ;NOTHING IS SAVED OVER CALL
QPOP (MPSTAK)
JUMPE A,SUCCER
SUCCON: QPUSH (MPSTAK,A) ;PUT IT BACK ON
PUSH P,A
PUSH P,B ;SAVE INDEX
HRRZ PNT,$VAL(A) ;PDA SEMBLK
MOVS C,$ADR(PNT) ;
MOVE A,[HRRZI TEMP,NOUSAC!JSFIX]
TRNE C,-1 ;ALREADY PUT OUT
HRRI A,NOUSAC!USADDR ;NO.
PUSHJ P,EMITER
QLOOK (MPVSTK) ;XWD ?TABLE,,LEVEL
MOVE C,(A)
EMIT <HRLI TEMP,NOUSAC!USADDR>
HRLI C,TEMP
EMIT <PUSH RP,NOUSAC!USADDR!NORLC>
MOVE A,(P) ;SUCC OR FAIL
ADDI A,R.SUCCE+LIBTAB ;LIBTAB INDEX
PUSHJ P,XCALLQ ;CALL SUCCEED OR FAIL
;; THE SKIP RETURN FROM .SUCC SHOULD BE INVERTED IN THE RUNTIMES
;; UNTIL THAT TIME WE WILL DO IT HERE
EMIT <SKIPA ,NOUSAC!NOADDR>
;; END OF TEMPORARY HACK
HRL C,PCNT
ADD C,[XWD 6,0]
EMIT <JRST , NOUSAC!USADDR>
MOVE PNT,-1(P) ;THE PROC SEMBLK
HRR PNT,$VAL(PNT) ;THE PDA SEMBLK
MOVS C,$ADR(PNT) ;
MOVE A,[HRRZI LPSA,NOUSAC!JSFIX]
TRNE C,-1 ;ALREADY PUT OUT
HRRI A,NOUSAC!USADDR ;NO.
PUSHJ P,EMITER
QLOOK (MPQSTK)
HRLZ C,(A) ;THE LEXICAL LEVEL
EMIT <HRLI LPSA,USADDR!NORLC!NOUSAC>
XCALL <STKUWD>
POP P,C ;SUCCEED OR FAIL
MOVE A,[SETZ A,NOUSAC!NOADDR] ;ASSUME FALSE
SKIPN C
HRLI A,(<SETO A,>)
PUSHJ P,EMITER ;THE TRUTH VALUE TO BE RETURNED
POP P,PNT ;PROC SEMBLK
HRLZ C,$ACNO(PNT) ;FIXUP FOR EXIT
HRRZ D,PCNT ;CURRENT PC
HRRM D,$ACNO(PNT)
EMIT <JRST NOUSAC!USADDR>
POPJ P,
SUCCER: ERR <SUCCEED OR FAIL MUST BE WITHIN MATCH. PROC>,1
JRST SUCCON
↑ONEITV: ;FOR WHEN FAIL, SUCCEED CALLED WITHIN
;EXPRESSION.
MOVEI D,1 ;SUCCEX HAS ALREADY DONE EVERYTHING ELSE
;WE KNOW RESULT IS RETURNED IN AC 1
MOVEI TBITS,ITMVAR
SETZ SBITS,
PUSHJ P,MARKME
MOVEM PNT,GENRIG ;FOR RESULTANT ITV EXPRESSION
POPJ P,
↑SAMEV:
MOVE PNT,GENLEF+4 ;FIRST ITEMVAR
MOVE PNT2,GENLEF+2
MOVE TBITS,$TBITS(PNT) ;SEE IF REALLY A MP PARM.
TLNN TBITS,MPBIND
JRST FALCON ;NO ALWAYS FALSE.
MOVE TBITS,$TBITS(PNT2)
TLNN TBITS,MPBIND
JRST FALCON
;;#RB# (3 OF 4) DO AN ACCESS
GENMOV (ACCESS,GETD)
PUSHJ P,GETAC ;GET AN AC TO PLAY WITH
EMIT <MOVE ,> ;LOAD WITH FIRST ITEMVAR
MOVE PNT,PNT2 ;SECOND ITEMVAR SEMBLK
;; #RB# (4 OF 4) ACCESS AGAIN
HRROS ACKTAB(D) ;PROTECT AC OVER ACCESS
GENMOV (ACCESS,GETD)
HRRZS ACKTAB(D)
;; #RB#
EMIT <CAMN ,> ;COMPARE FIRST WITH SECOND
HRLI C,20 ;INDIRECT BIT FOR NEXT INSTR
EMIT <TLNN ,NORLC!USADDR>
HRLI C,(D) ;THE AC ITEMVAR IN.
EMIT <TDZA ,NORLC!USADDR> ;FALSE
HRLI C,1
EMIT <MOVNI ,NORLC!USADDR>;TRUE
PUSHJ P,MARKINT
MOVEM PNT,GENRIG+1
POPJ P,
FALCON: MOVNI A,1
PUSHJ P,CREINT
MOVEM PNT,GENRIG+1
POPJ P,
DSCR REMEMBER EXECS RMASET,RMBSET,RMSTK
⊗
;TYPE BITS TO BE PASSED TO RUNTIMES
DESC ←← 400000
ISARR ←← 200000
ISSTR ←← 100000
ISSET ←← 40000
↑RMASET: ;REMEMBER ALL
HRLZM B,REMCEL ;SAVE WHICH KIND OF OPERATION,# PARAMS
POPJ P,
↑RMBSET: ;REM,FOR,RES NAMED ENTRIES
ADDI B,3
HRLI B,1
MOVSM B,REMCEL ;SAVE WHICH KIND
MOVEI A,0 ;CREATE ZERO CONSTANT
PUSHJ P,CREINT
GENMOV (STACK,GETD)
POPJ P,
↑RMSTK:
AOS REMCEL
GETSEM (1) ;SEMANTICS OF VARIABLE TO BE SAVED ETC
TRNE TBITS,ITEM ;DON'T ALLOW ITEM TO BE SAVED ETC
ERR <AN ITEM IS NOT A VARIABLE CAN'T BE REMEMBERED>,1
TLNN TBITS,SBSCRP ;ARRAYS ARE NEVER ON LEAPSK
TRNN TBITS,SET!ITMVAR ;LEAPISH THING?
JRST HVPNT ;NO.
SOS B,LEAPSK ;GET SEMAN FROM LEAP STACK
;; #PX# (13 OF 13)
SKIPN PNT,1(B) ;SEMBLK
ERR <NON-LEAP ARG TO LEAP EXPRESSION>,1
;; #PX#
TLNE PNT,STACKET ;ALREADY STACKED?
ERR <EXPRESSIONS CANNOT BE REMEMBERED>,1
HVPNT:
HRRZS PNT ;PREPARE TO CALCULATE TYPE BITS
TLNE TBITS,SBSCRP ;AN ARRAY?
TLO PNT,ISARR ;TELL THE WORLD
TRNE TBITS,STRING
TLO PNT,ISSTR
TRNN TBITS,SET
JRST RMEXPR
TRNE TBITS,FLOTNG!INTEGR
ERR <KILL!SETS AND CONTEXTS MAY NOT BE REMEMBERED>,1
TLO PNT,ISSET
RMEXPR: TLNE SBITS,ARTEMP!STTEMP ;AN EXPRESSION?
TLNE TBITS,SBSCRP ;OK IF ARRAY
JRST RMSTK2 ;NO
TLNN SBITS,FIXARR!INDXED ;
ERR <EXPRESSION CANNOT BE REMEMBERED>,1
RMSTK2:
TLNN SBITS,FIXARR!INDXED ;IF NOT ARRAY ELEM
PUSHJ P,INCOR ;MAKE SURE INCORE
SETOM MPFLAG ;WANT BITS IN LEFT HALF
PUSHJ P,FTRADR ;MAKE LIKE A FORTRAN CALL
GENMOV (STACK,GETD)
SETZM MPFLAG
POPJ P,
↑CNTXTS: ;STACK CONTEXT VARIABLE AND CALL ROUTINE
GETSEM (1)
PUSHJ P,ADRINS ;GET ADDRESS OF CONTEXT VARIABLE
GENMOV (STACK,0) ;STACK IT
PUSHJ P,ALLSTO ;MAKE SURE NOTHING IN AC
HRLI A,LIBTAB+RALLRM ;
ADD A,REMCEL
HLRZ A,A
PUSHJ P,XCALLQ
HRRZ A,REMCEL
ADDI A,1
MOVNS A
ADDM A,ADEPTH
POPJ P,
↑INCNTX: GETSEM (1)
GENMOV (STACK,0) ;STACK VAL
XPREP
XCALL (.INCON)
PUSHJ P,MARKINT
MOVEM PNT,GENRIG
POPJ P,
↑NLCNXT: ;NULL!CONTEXT
MOVE PNT,NULLCN ;DUMMY SEMBLK FOR NULL!CONTEXT
MOVEM PNT,GENRIG ;STORE IT AWAY
POPJ P,
↑CONELM: ;CNTX:VAR CONSTRUCT
GETSEM (3) ;THE CONTEXT
GENMOV (STACK,0) ;STACK IT
GETSEM (1) ;THE VARIABLE NAME
PUSH P,TBITS ;SINCE HVPNT WILL DESTROY
PUSHJ P,HVPNT ;STACK IT
POP P,TBITS ;HVPNT DESTROYED
XPREP ;CONELM WILL RETURN RESULT IN 1
XCALL (CONELM)
MOVNI TEMP,2 ;UPDATE P-STACK
ADDM TEMP,ADEPTH
PUSHJ P,TYPDEC ;TYPE THE THING
MOVEM A,PARRIG+1
TLZ TBITS,OWN!FORMAL!MPBIND ;IF ARRAY NO LONGER OWN
PUSH P,PNT
PUSH P,TBITS ;SAVE OVER CALL TO MARK
SETZB TBITS,SBITS
GENMOV (MARK,0) ;GET A TEMP
MOVEM PNT,GENRIG+1
HRROS $ACNO(PNT) ;FOR ARRAYS
POP P,TBITS
POP P,TEMP
TLNE TBITS,SBSCRP ;AN ARRAY?
MOVEM TEMP,$VAL(PNT) ;NAME FOR ARRERR UUO
MOVEM TBITS,$TBITS(PNT) ;STORE REAL TBITS
TLC SBITS,INAC!PTRAC!INDXED
MOVEM SBITS,$SBITS(PNT) ;STORE REAL SBITS
POPJ P,
BEND LEAP
COMMENT ⊗ EXECS FOR DYNAMIC BINDING OF PROC ITEMS⊗
DSCR PDASTK
DES EMITS CODE TO PUSH ONTO THE P-STACK PDA OF NAMED PROC
⊗
↑PDASTK:
MOVE PNT2,GENLEF+1 ;GET SEMBLK FOR PROC ID
HRRZ PNT,$VAL(PNT2) ;POINT AT PD SEMBLK
PUSHJ P,GETAC ;GETS AN AC
PUSHJ P,LODPDA
HRL C,D
EMIT <PUSH P,NOUSAC!USADDR!NORLC> ;PUSH P,AC
AOS ADEPTH ;HIT THEE BOOKS
POPJ P,
↑LODPDA: ;LOADS PDA NAMED BY PNT INTO AN AC NAMED
;IN RH OF D (MANGLES C)
;ASSUMES PROC SEMBLK IS IN PNT2
SKIPL C,$ADR(PNT) ;IS THE ADDRESS TRUE YET ?
JRST EMJSF ;NO, DO A FIXUP
HRLZ C,C ;PICK UP THE ADDRESS OF THE PDA
EMIT <MOVEI USADDR> ;GO PUT IT OUT
POPJ P, ;RETURN
EMJSF: MOVE A,[MOVEI JSFIX] ;MOVEI A,PDA
MOVE C,$TBITS(PNT2) ;
TLNE C,EXTRNL
MOVE A,[MOVE JSFIX]
PUSHJ P,EMITER
POPJ P,
DSCR COPPIT
DES EMITS CODE TO CALL PITCOP TO COPY ONE FHQ PROC ITEM DATUM INTO ANOTHER ITEM
DATUM. DOES A STORZ ON B&C TO FREE THEM UP -- WARNING: THIS MAY
CONFLICT WITH THE PROTECT!ACS FEATURE.
⊗
↑COPPIT:
MOVEI D,B
PUSHJ P,STORZ ;FREE UP B
MOVEI D,C
PUSHJ P,STORZ ;FREE UP C
XCALL (PITCOP)
;;#LH# 1 OF 2 RHT 2-6-73 ADJUST ADEPTH
MOVNI D,2
ADDM D,ADEPTH
;;#LH#
POPJ P,
DSCR BINCL
DES EMITS CODE TO CALL PITBND -- ALSO FREES UP B&C
⊗
↑BINCL:
MOVEI D,B
PUSHJ P,STORZ ;FREE UP B
MOVEI D,C
PUSHJ P,STORZ ;FREE UP C
XCALL (PITBND)
;;#LH# 2 OF 2 RHT 2-6-73 ADJUST ADEPTH
MOVNI D,2
ADDM D,ADEPTH
;;#LH#
POPJ P,
COMMENT ⊗EXECS FOR APPLY⊗
DSCR EVLLST,EVLNLL,PITSTK
DES USED TO SET UP INTERP CALL
⊗
↑EVLLST:
PUSHJ P,BNDLST ;GET LIST STACKED
JRST XCLEVL ;GO CALL THE CALLER
↑EVLNLL:
MOVEI A,0
PUSHJ P,CREINT ;GET A ZERO
GENMOVE (STACK) ;STACK IT
XCLEVL:
;;#PB# ! RHT 15 NOV 73 NEEDED AN ALLSTO
PUSHJ P,ALLSTO
XCALL (APPLY) ;CALL APPLY
;;#JS# ADJUST ADEPTH RHT 10-20-72
MOVNI A,2 ;
ADDM A,ADEPTH ;
;;#JS#
POPJ P,
↑PITSTK:
MOVEI D,B ;FREE UP B & C
PUSHJ P,STORZ
MOVEI D,C
PUSHJ P,STORZ
XCALL (PITDTM) ;
POPJ P,
;; EXECS FOR SPROUT APPLY
;;#OJ# -- Revised this code to do a getblk. RHT
↑SAPPL1: GETBLK GENRIG+1
HLLOS $VAL2(LPSA) ;MARK SPROUT SEMBLK AS SPROUT APPLY
POPJ P,
;;#OJ#
↑SAPPL: PUSHJ P,BNDLST ;GET ARG LIST ON STACK
JRST SAPPP
↑SAPPN: MOVEI A,0
PUSHJ P,CREINT ;A NULL
GENMOVE (STACK,0) ;STACK IT
SAPPP:
HRL C,PCNT
;;#OM# ! LEFT OUT LIBTAB
EXCH C,LIBTAB+RAPPL$Y ;FIXUP ON APPL$Y
EMIT <MOVEI TEMP,NOUSAC!USADDR>
HRLI C,TEMP
EMIT <PUSH RP,NOUSAC!USADDR!NORLC>
AOS ADEPTH
POPJ P,