// JOB // ASM *MACLIB LMACS *OVERFLOW SECTORS 0,8,0 *PRINT SYMBOL TABLE ABS ORG /01FE LIST NIL EQU 0 NO EQU 0 YES EQU 1 *************************************************** * EQUIVALENCES FOR RESIDENT MONITOR * *************************************************** $PRET EQU /28 PRE-OPERATIVE ERROR TRAP $ULET EQU /20 TABLE OF LET DISK ADRS $IOCT EQU /32 I/O PENDING INTERRUPT COUNT $EXIT EQU /38 BRANCH ADR FOR CALL EXIT $DUMP EQU /35 BRANCH LOC FOR CORE DUMP $KCSW EQU /7C KEYBOARD (// TYP) SWITCH $FPAD EQU /95 TABLE OF WS DISK ADRS $XR3X EQU /E4 XR3 SETTING FOR LIBF VECTOR $DBSY EQU /EE DISK I/O BUSY SWITCH DISKZ EQU /F2 DISK I/O SUBROUTINE $ZEND EQU /01E0 LIST HDNG 01 SPECIAL INDEX REGISTER 3 AREA *************************************************** * SPECIAL AREA - ADDRESSABLE THROUGH XR3 * *************************************************** X EQU *+128 XR3 NORMALLY HAS THIS VALUE *************************************************** * TRANSFER VECTOR FOR SUBROUTINES * *************************************************** PUSHJ DC *-* PUSH JUMP BSC L PSHJ1 POPJ DC *-* POP JUMP BSC L POPJ1 PUSHA DC *-* PUSH ACC BSC L PSHA1 POPA DC *-* POP ACC BSC L POPA1 PUSHS DC *-* SPEC PDL PUSH BSC L PSHS1 POPS DC *-* SPEC PDL POP BSC L POPS1 POPN DC *-* SPEC PDL POP N ENTRIES BSC L POPN1 XCAR DC *-* CAR XSUBR BSC L XCAR1 XCDR DC *-* CDR XSUBR BSC L XCDR1 XATOM DC *-* ATOM XSUBR BSC L XATM1 XNULL DC *-* XNULL XSUBR BSC L XNUL1 XNMBP DC *-* NUMBERP XSUBR BSC L XNMP1 ERROR DC *-* ERROR SUBROUTINE BSC L ERR01 XCONS DC *-* CONS XSUBR BSC L XCNS1 MKFXN DC *-* MAKE FIXED NUMBER BSC L MKFX1 XNCHK DC *-* NUMBER CHECK BSC L XNCH1 XSTRP DC *-* STRINGP XSUBR BSC L XSTR1 XSCHK DC *-* STRING CHECK BSC L XSCH1 EJCT *************************************************** * COMMONLY USEFUL VARIABLES * *************************************************** @TMPA DC *-* 'WASTEBASKETS' (USED BY @TMPB DC *-* VARIOUS SUBROUTINES FOR @TMPC DC *-* TEMPORARY STORAGE) @TRUE DC #T ADR OF ATOM T @SPDL DC S@SPD SPEC PDL POINTER @TMLS DC $TMLS LIST OF GC-PROTECTED ADRS @ARG1 DC *-* * ARGUMENTS @ARG2 DC *-* ** FOR @ARG3 DC *-* *** MACHINE @ARG4 DC *-* **** LANGUAGE @ARG5 DC *-* **** FUNCTIONS @ARG6 DC *-* *** ARE @ARG7 DC *-* ** PLACED @ARG8 DC *-* * HERE @FSTL DC NIL FREE STORAGE LIST @FXSL DC NIL FIXED-POINT FREE LIST BSS E 0 @SYSO DC @OSTD STD OUTPUT(SET TO 1 IF TYP) @SYSI DC @ISTD STD INPUT (SET TO 6 IF TYP) @SYSP DC @OSTD STANDARD PRINTER @SYSR DC @ISTD STANDARD READER LIST HDNG 02 PUSHDOWN LIST SUBROUTINES *************************************************** * PUSH ACC ONTO REG PDL * *************************************************** PSHA1 MDX 1 -1 MOVE POINTER STO 3 @TMPA-X LD L 1 CHECK FOR OVERFLOW S 3 @SPDL-X BSC L PSHA2,+ LD 3 @TMPA-X STO 1 0 PUT WORD ON STACK BSC I PUSHA PSHA2 BSI 3 ERROR-X HANDLE PDL OVERFLOW PSHA3 DC 1+@MAJR (ALTERED TO 11+@FATL FOR GC *************************************************** * POP ACC FROM REG PDL * *************************************************** POPA1 LD L 1 CHECK FOR UNDERFLOW S POPA9 BSC L POPA2,- LD 1 0 GET WORD MDX 1 1 MOVE POINTER BSC I POPA POPA2 BSI 3 ERROR-X HANDLE PDL UNDERFLOW DC 2+@DUMP *************************************************** POPA9 DC S@RPD *************************************************** * PUSH JUMP * *************************************************** PSHJ1 STO 3 @TMPB-X SAVE ACC LD 3 PUSHJ-X A PSHJ9 BSI 3 PUSHA-X PUSH RETURN ADR LD I PUSHJ GET JUMP ADR STO PUSHJ+1 LD 3 @TMPB-X RESTORE ACC PSHJ2 BCS L *-* JUMP *************************************************** PSHJ9 DC /8001 BIT 0 FLAG + 1 *************************************************** * POP JUMP * *************************************************** POPJ1 STO 3 @TMPA-X SAVE ACC BSI 3 POPA-X GET RETURN ADR STO POPJ2+1 LD 3 @TMPA-X RESTORE ACC POPJ2 BSC L *-* POP JUMP *************************************************** * PUSH ONTO SPEC PDL * *************************************************** PSHS1 LD 3 @SPDL-X CHECK FOR OVERFLOW A PSHS9 S L 1 BSC L PSHS3,- LD I PUSHS GET ADR OF LOC TO SAVE OR PSHS8 SET BIT 0 MDX L @SPDL,1 STO I @SPDL PUT ON STACK STO PSHS2+1 PSHS2 LD L *-* GET CONTENTS OF LOC MDX L @SPDL,1 STO I @SPDL PUT ON STACK MDX L PUSHS,1 BSC I PUSHS PSHS3 BSI 3 ERROR-X HANDLE PDL OVERFLOW DC 3+@MAJR *************************************************** PSHS8 DC /8000 PSHS9 DC 2 *************************************************** * POP FROM SPEC PDL * *************************************************** POPS1 LD 3 @SPDL-X MOVE POINTER S PSHS9 STO 3 @SPDL-X STO POPS9 S POPS8 CHECK FOR UNDERFLOW BSC L POPS3,+Z MDX L POPS9,1 LD I POPS9 GET ADR OF LOC TO RESTORE STO POPS2+1 MDX L POPS9,1 LD I POPS9 GET CONTENTS POPS2 STO L *-* AND PUT IN LOC BSC I POPS POPS3 BSI 3 ERROR-X HANDLE PDL UNDERFLOW DC 4+@DUMP *************************************************** POPS8 DC S@SPD POPS9 DC *-* *************************************************** * POP N ENTRIES FROM SPEC PDL * *************************************************** POPN1 STO 3 @TMPA-X SAVE ACC BSI 3 POPA-X GET COUNT (NEGATIVE) BSC L POPN4,+- RETURN IF NONE TO POP STO POPN9 POPN2 BSI 3 POPS-X POP AN ENTRY MDX L POPN9,1 MDX POPN2 POPN4 LD 3 @TMPA-X RESTORE ACC BSC I POPN *************************************************** POPN9 DC *-* *************************************************** LIST HDNG 03 SHORT XSUBRS AND BASIC FUNCTIONS *************************************************** * CAR XSUBR * *************************************************** XCAR1 BSC +- USE NIL IF ZERO LD XCAR9 A XCAR8 ADD 1 STO XCAR2+1 XCAR2 LD L *-* GET CAR AND XCAR7 AND OUT BIT 0 BSC I XCAR *************************************************** XCAR7 DC /7FFF XCAR8 DC 1 XCAR9 DC #NIL ADR OF ATOM 'NIL' *************************************************** * CDR XSUBR * *************************************************** XCDR1 BSC +- USE NIL IF ZERO LD XCAR9 STO XCDR2+1 XCDR2 LD L *-* GET CDR BSC I XCDR *************************************************** * ATOM XSUBR * *************************************************** XATM1 STO XATM2+1 S XATM9 BSC L XATM3,+Z S XATM8 BSC L XATM3,- ATOM IF OUTSIDE FREE STG MDX L XATM2+1,1 NOP XATM2 LD L *-* BSC L XATM3,+Z ATOM IF BIT 0 OF CAR SET SRA 16 BSC +-Z XATM3 LD 3 @TRUE-X BSC I XATOM *************************************************** XATM8 DC E@FST-S@FST XATM9 DC S@FST *************************************************** * NULL XSUBR * *************************************************** XNUL1 BSC L XNUL2,Z LD 3 @TRUE-X RETURN 'T' IF NIL BSC +-Z XNUL2 SRA 16 RETURN 'NIL' IF TRUE BSC I XNULL *************************************************** * NUMBERP XSUBR * *************************************************** XNMP1 BSC L XNMP3,+- NOT A NUMBER IF NIL S XNMP9 BSC L XNMP5,+Z S XNMP8 BSC L XNMP5,- NUMBER IF OUTSIDE FREE STG XNMP3 SRA 16 BSC +-Z XNMP5 LD 3 @TRUE-X BSC I XNMBP *************************************************** XNMP8 DC E@FST-S@FST XNMP9 DC S@FST *************************************************** * CHECK ARGUMENT FOR NUMBER - ERROR IF NOT * *************************************************** XNCH1 STO XNCH6 BSC L XNCH4,+- NOT A NUMBER IF NIL S XNCH9 BSC L XNCH2,+Z BRANCH IF NUMBER S XNCH8 BSC L XNCH4,+Z BRANCH UNLESS NUMBER XNCH2 LD I XNCH6 GET NUMBER IN ACC MDX L XNCHK,1 BSC I XNCHK RETURN XNCH4 LD I XNCHK STO XNCH5 BSI 3 ERROR-X ERROR - NOT A NUMBER DC 38+@MAJR XNCH5 DC *-* XNCH6 DC *-* *************************************************** XNCH8 DC E@FST-S@FST XNCH9 DC S@FST *************************************************** * STRINGP XSUBR *************************************************** XSTR1 STO XSTR3+1 S XSTR9 BSC L XSTR4,+Z BRANCH IF NUMBER OR NIL S XSTR8 BSC L XSTR4,- BRANCH IF NUMBER A XSTR7 STO XSTR2+1 XSTR2 LD L *-* BSC L XSTR4,- BRANCH UNLESS ATOM XSTR3 LD L *-* EOR XSTR6 BSC L XSTR4,Z BRANCH UNLESS STRING LD 3 @TRUE-X RETURN T IF STRING BSC +-Z XSTR4 SRA 16 ELSE RETURN NIL BSC I XSTRP *************************************************** XSTR6 DC @STR XSTR7 DC 1+E@FST XSTR8 DC E@FST-S@FST XSTR9 DC S@FST *************************************************** * CHECK ARGUMENT FOR STRING - ERROR IF NOT * *************************************************** XSCH1 STO XSCH9 SAVE ARG BSI 3 XSTRP-X BSC L XSCH4,+- BRANCH IF NOT STRING LD XSCH9 BSI 3 XCAR-X ELSE RETURN CHAR LIST MDX L XSCHK,1 BSC I XSCHK XSCH4 LD I XSCHK PRINT ERROR MESSAGE STO XSCH6 BSI 3 ERROR-X DC 47+@MAJR XSCH6 DC *-* *************************************************** XSCH9 DC *-* *************************************************** * CAR FUNCTION * *************************************************** DC @LAM+1 (LAMBDA (X) ... CAR LD 3 @ARG1-X BSI 3 XCAR-X BSI 3 POPJ-X *************************************************** * QUOTE FUNCTION * *************************************************** DC @NLAM+1 (NLAMBDA 8X) ... QUOTE LD 3 @ARG1-X BSI 3 POPJ-X *************************************************** * CDR FUNCTION *************************************************** DC @LAM+1 (LAMBDA (X) ... CDR LD 3 @ARG1-X BSI 3 XCDR-X BSI 3 POPJ-X *************************************************** * NULL PREDICATE * *************************************************** DC @LAM+1 (LAMBDA (X) ... NULL LD 3 @ARG1-X BSI 3 XNULL-X BSI 3 POPJ-X *************************************************** * NOT PREDICATE * *************************************************** NOT EQU NULL *************************************************** * ATOM PREDICATE * *************************************************** DC @LAM+1 (LAMBDA (X) ... ATOM LD 3 @ARG1-X BSI 3 XATOM-X BSI 3 POPJ-X *************************************************** * NUMBERP PREDICATE * *************************************************** DC @LAM+1 (LAMBDA (X) ... NMBRP LD 3 @ARG1-X BSI 3 XNMBP-X BSI 3 POPJ-X *************************************************** * STRINGP FUNCTION * *************************************************** DC @LAM+1 STRP LD 3 @ARG1-X BSI 3 XSTRP-X BSI 3 POPJ-X LIST HDNG 04 EQ, *EQUALP, EQUAL *************************************************** * EQ PREDICATE * *************************************************** DC @LAM+2 (LAMBDA (X Y) ... EQ LD 3 @ARG1-X COMPARE TWO ARG ADRS EOR 3 @ARG2-X BSC L EQ2,Z LD 3 @TRUE-X BSI 3 POPJ-X EQ2 SRA 16 BSI 3 POPJ-X *************************************************** LIST HDNG 05 EBCDIC CHARACTER CODE TABLE ***** WARNING -- PNAME SCREWS IF ARG IS NIL *************************************************** * SYMBOLS FOR CHARACTER TABLE * *************************************************** @QT EQU /80 QUOTE ON PRIN1 OUTPUT @HNM1 EQU /20 MAY BE 1ST CHAR OF HEX NUM @DNM1 EQU /08 MAY BE 1ST CHAR OF DEC NUM @HNUM EQU /04 MAY BE HEX DIGIT @DNUM EQU /01 MAY BE DEC DIGIT *************************************************** * EBCDIC CHARACTER CODE AND FLAG TABLE * *************************************************** EBCTB EQU * @ DC 256*. +@QT BLANK @CR DC /1500 CARRIAGE RETURN @CENT DC 256*.\ CENTS SIGN @PER DC 256*..+@QT @LESS DC 256*.< LESS THAN SIGN @LPAR DC 256*.(+@QT @PLUS DC 256*.++@DNM1 @OR DC 256*.| LOGICAL OR @AMPR DC 256*.&+@QT AMPERSAND @EXCL DC 256*.! EXCLAMATION POINT @$ DC 256*.$ @STAR DC 256*.* @RPAR DC 256*.)+@QT @SCLN DC 256*.; SEMICOLON @NOT DC 256*.^ LOGICAL NOT @DASH DC 256*.-+@DNM1 @SLSH DC 256*./+@HNM1 @COMA DC 256*.,+@QT @PCNT DC 256*.% PERCENT SIGN @UNDR DC 256*._ UNDERSCORE @GRTR DC 256*.> GREATER THAN SIGN @QUES DC 256*.? QUESTION MARK ***** WARNING -- PDL OVERFLOW HANDLING ROTS @COLN DC 256*.: COLON @NMBR DC 256*.# NUMBER SIGN @AT DC 256*.@ AT SIGN @QUOT DC 256*.'+@QT QUOTE MARK @EQAL DC 256*.= EQUAL SIGN @DBQT DC 256*." DOUBLE QUOTE @A DC 256*.A+@HNUM @B DC 256*.B+@HNUM @C DC 256*.C+@HNUM @D DC 256*.D+@HNUM @E DC 256*.E+@HNUM @F DC 256*.F+@HNUM @G DC 256*.G @H DC 256*.H @I DC 256*.I @J DC 256*.J @K DC 256*.K @L DC 256*.L @M DC 256*.M @N DC 256*.N @O DC 256*.O @P DC 256*.P @Q DC 256*.Q @R DC 256*.R @S DC 256*.S @T DC 256*.T @U DC 256*.U @V DC 256*.V @W DC 256*.W @X DC 256*.X @Y DC 256*.Y @Z DC 256*.Z @0 DC 256*.0+@DNM1+@DNUM+@HNUM @1 DC 256*.1+@DNM1+@DNUM+@HNUM @2 DC 256*.2+@DNM1+@DNUM+@HNUM @3 DC 256*.3+@DNM1+@DNUM+@HNUM @4 DC 256*.4+@DNM1+@DNUM+@HNUM @5 DC 256*.5+@DNM1+@DNUM+@HNUM @6 DC 256*.6+@DNM1+@DNUM+@HNUM @7 DC 256*.7+@DNM1+@DNUM+@HNUM @8 DC 256*.8+@DNM1+@DNUM+@HNUM @9 DC 256*.9+@DNM1+@DNUM+@HNUM L@EBC EQU *-EBCTB LENGTH OF EBCDIC TABLE LIST HDNG 06 1403/CPR PRINTER CODES TABLE *************************************************** * 1403 PRINTER/CONSOLE PRINTER CODE TABLE * *************************************************** PRTTB DC /7F21 BLANK DC /7F81 CARRIAGE RETURN DC /7F02 CENTS SIGN DC /6E00 . DC /7FDE LESS THAN SIGN DC /5FFE ( DC /6DDA + DC /7FC6 LOGICAL OR DC /1544 AMPERSAND DC /7F42 EXCLAMATION POINT DC /6240 $ DC /23D6 * DC /2FF6 ) DC /7FD2 SEMICOLON DC /7FF2 LOGICAL NOT DC /6184 - DC /4CBC / DC /1680 COMMA DC /7F06 PERCENT SIGN DC /7FBE UNDERSCORE DC /7F46 GREATER THAN SIGN DC /7F86 QUESTION MARK DC /7F82 COLON DC /7FC0 NUMBER SIGN DC /7F04 AT SIGN DC /0BE6 ' DC /4AC2 = DC /7FE2 DOUBLE QUOTE DC /643C A DC /2518 B DC /261C C DC /6730 D DC /6834 E DC /2910 F DC /2A14 G DC /6B24 H DC /2C20 I DC /587C J DC /1958 K DC /1A5C L DC /5B70 M DC /1C74 N DC /5D50 O DC /5E54 P DC /1F64 Q DC /2060 R DC /0D98 S DC /0E9C T DC /4FB0 U DC /10B4 V DC /5190 W DC /5294 X DC /13A4 Y DC /54A0 Z DC /49C4 0 DC /40FC 1 DC /01D8 2 DC /02DC 3 DC /43F0 4 DC /04F4 5 DC /45D0 6 DC /46D4 7 DC /07E4 8 DC /08E0 9 AIF (L@EBC EQ *-PRTTB),.OKAY ERR** ..... LENGTHS OF EBCTB AND PRTTB DIFFERENT .OKAY ANOP LIST HDNG 07 CARD CODE CHARACTER TABLE *************************************************** * CARD CODE TABLE * *************************************************** CRDTB DC /0000 BLANK DC /0001 CR (CANNOT BE READ IN) DC /8820 CENTS SIGN DC /8420 . DC /8220 LESS THAN SIGN DC /8120 ( DC /88A0 + DC /8060 LOGICAL OR DC /8000 AMPERSAND DC /4820 EXCLAMATION POINT DC /4420 $ DC /4220 * DC /4120 ) DC /40A0 SEMICOLON DC /4060 LOGICAL NOT DC /4000 - DC /3000 / DC /2420 , DC /2220 PERCENT SIGN DC /2120 UNDERSCORE DC /20A0 GREATER THAN SIGN DC /2060 QUESTION MARK DC /0820 COLON DC /0420 NUMBER SIGN DC /0220 AT SIGN DC /0120 ' DC /00A0 = DC /0060 DOUBLE QUOTE DC /9000 A DC /8800 B DC /8400 C DC /8200 D DC /8100 E DC /8080 F DC /8040 G DC /8020 H DC /8010 I DC /5000 J DC /4800 K DC /4400 L DC /4200 M DC /4100 N DC /4080 O DC /4040 P DC /4020 Q DC /4010 R DC /2800 S DC /2400 T DC /2200 U DC /2100 V DC /2080 W DC /2040 X DC /2020 Y DC /2010 Z DC /2000 0 DC /1000 1 DC /0800 2 DC /0400 3 DC /0200 4 DC /0100 5 DC /0080 6 DC /0040 7 DC /0020 8 DC /0010 9 AIF (L@EBC EQ *-CRDTB),.OKAY ERR** ..... LENGHTS OF EBCTB AND CRDTB DIFFERENT .OKAY ANOP LIST HDNG 08 OUTPT - OUTPUT ONE CHARACTER *************************************************** * OUTPUT ONE CHARACTER * *************************************************** OUTPT DC *-* STX 1 OUT40+1 SAVE XR1 STX 2 OUT45+1 SAVE XR2 LDX I3 $XR3X SET XR3 FOR LIBFS LDX L1 @OSTD PUT DEVICE NUMBER IN XR1 OUTDV EQU *-1 DEV NUMBER MAY BE CHANGED S OUT99 ACC HAS ADR WITHIN EBCTB STO OUT30+1 S OUT98 BSC L OUT20,+- BRANCH IF CR LD L1 OUTCH OUT10 S OUT97 STO L1 OUTCH DECR CHAR COUNT BSC L OUT30,- BRANCH UNLESS END OF LINE LDX 2 @CR-EBCTB BSI I1 OUTSB OUTPUT CARRIAGE RETURN LD L1 OUTLN RESET CHAR COUNT MDX OUT10 OUT20 LD L1 OUTLN RESET CHAR COUNT STO L1 OUTCH OUT30 LDX L2 *-* PUT OFFSET BACK IN XR2 BSI I1 OUTSB OUTPUT CHAR OUT40 LDX L1 *-* RESTORE XR1 OUT45 LDX L2 *-* RESTORE XR2 LDX L3 X RESTORE XR3 BSC I OUTPT *************************************************** OUT97 DC 1 OUT98 DC @CR-EBCTB OUT99 DC EBCTB *************************************************** * SET UP OUTPT FOR PROPER OUTPUT DEVICE * *************************************************** STOUT DC *-* LD I STOUT GET NAME OF CALLING FN MDX L STOUT,1 STO STOU2 LD 3 @ARG1-X GET ARG1 BSI 3 XNCHK-X CHECK IT STOU2 DC *-* BSI 3 PUSHJ-X CHECK IF DEFINED DC ODEVP BSC L STOU5,+- ERROR IF NOT LD I @ARG1 STO L OUTDV SET DEVICE NUMBER MDX STOU7 STOU5 LD 3 @ARG1-X PRINT ERROR MESSAGE STO STOU6 BSI 3 ERROR-X NOTE - ERROR WILL SET DEV DC 10+@MINR NUMBER TO SYS PRINTER STOU6 DC *-* FAULTY DEVICE NUMBER STOU7 BSC I STOUT *************************************************** * SET UP OUTPT FOR SYSTEM OUTPUT DEVICE * *************************************************** SYSOU DC *-* SYSO2 LD L #SYSO CHECK SYSOUT STO 3 @ARG1-X BSI 3 XNMBP-X BSC L SYSO5,+- BAD IF NOT NUMBER BSI 3 PUSHJ-X DC ODEVP BSC L SYSO5,+- BRANCH IF BAD LD I #SYSO USE SYSOUT BSC +-Z SYSO5 LD 3 @SYSO-X USE STANDARD OUTPUT STO L OUTDV BSC I SYSOU *************************************************** * CHRCT FUNCTION * *************************************************** DC @LAM+1 (LAMBDA (X) ... CHRCT BSI L STOUT CHECK DEVICE NUMBER DC #CHRC LD I @ARG1 A CHRC9 STO CHRC1+1 CHRC1 LD L *-* GET CHRCT FOR GIVEN DEVICE BSI 3 MKFXN-X BSI 3 POPJ-X *************************************************** CHRC9 DC OUTCH *************************************************** * LINEL FUNCTION * *************************************************** DC @LAM+1+@LIST (LAMBDA (X . Y) ... LINEL BSI L STOUT CHECK DEVICE NUMBER DC #LINE STX 2 LINE7+1 SAVE XR2 LD I @ARG1 PUT DEVICE STO L 2 NUMBER IN XR2 LD 3 @ARG2-X BSC L LINE5,+- BRANCH IF NO SECOND ARG BSI 3 XCAR-X BSI 3 XCDR-X GET NUMBER BSC + LD LINE9 USE 72 IF NON-POSITIVE S L2 OUTMX BSC -Z SRA 16 A L2 OUTMX USE MAXIMUM IF TOO LARGE RTE 16 LD L2 OUTLN GET OLD LINEL RTE 16 STO L2 OUTLN PUT NEW LINEL RTE 16 MDX LINE6 LINE5 LD L2 OUTLN RETURN OLD LINEL LINE6 BSI 3 MKFXN-X LINE7 LDX L2 *-* BSI 3 POPJ-X *************************************************** LINE9 DC 72 *************************************************** LIST HDNG 09 TABLES AND SYMBOLS FOR I/O DEVICES *************************************************** * TABLES FOR I/O DEVICES AND SUBRS * *************************************************** * ADRS OF OUTPUT DEVICE HANDLERS * *************************************************** OUTSB DC *-* 0 - USED BY PRIN1STR, ETC. DC OCPRT 1 - TYPEWRITER DC O1442 2 - 1442 CARD READ/PUNCH DC O1132 3 - 1132 PRINTER DC O1055 4 - PAPER TAPE PUNCH DC O1403 5 - 1403 PRINTER DC 0 - - - - - - - DC O1627 7 - 1627 PLOTTER DC 0 - - - - - - - DC ODISK 9 - DISK FILE OUTPUT L@OSB EQU *-OUTSB-1 NUMBER OF OUTPUT DEVICES *************************************************** * LINE LENGHTS FOR OUTPUT DEVICES * *************************************************** OUTLN DC 32767 PRIN1STR, ETC. DC 100 TYPEWRITER DC 72 1442 CARD READ/PUNCH DC 120 1132 PRINTER DC 32767 PAPER TAPE PUNCH DC 120 1403 PRINTER DC 0 - - - - - - - DC 32767 1627 PLOTTER DC 0 - - - - - - - DC 72 DISK FILE OUTPUT *************************************************** * CURRENT CHRCT VALUES FOR OUTPUT DEVICES * *************************************************** OUTCH DC *-* PRIN1STR, ETC. DC 0 TYPEWRITER DC 0 1442 CARD READ/PUNCH DC 0 1132 PRINTER DC 0 PAPER TAPE PUNCH DC 0 1403 PRINTER DC 0 - - - - - - - DC 0 1627 PLOTTER DC 0 - - - - - - - DC 0 DISK FILE OUTPUT *************************************************** * MAXIMUM LINE LENGHTS FOR OUTPUT DEVICES * *************************************************** OUTMX DC *-* PRIN1STR, ETC. DC 100 TYPEWRITER DC 80 1442 CARD READ/PUNCH DC 120 1132 PRINTER DC 32767 PAPER TAPE PUNCH DC 120 1403 PRINTER DC 0 - - - - - - - DC 32767 1627 PLOTTER DC 0 - - - - - - - DC 72 DISK FILE OUTPUT *************************************************** * PAGESKIP SUBROUTINES FOR OUTPUT DEVICES * *************************************************** OPSKP DC 0 PRIN1STR, ETC. DC PCPRT TYPEWRITER DC P1442 1442 CARD READ/PUNCH DC P1132 1132 PRINTER DC P1055 PAPER TAPE PUNCH DC P1403 1403 PRINTER DC 0 - - - - - - - DC P1627 1627 PLOTTER DC 0 - - - - - - - DC PDISK DISK FILE OUTPUT *************************************************** * ADDRESSES OF INPUT DEVICE HANDLERS * *************************************************** INSUB DC RDS50 0 - READSTR FUNCTION DC 0 - - - - - - - DC I1442 2 - 1442 CARD READ/PUNCH DC 0 - - - - - - - DC I1134 4 - PAPER TAPE READER DC 0 - - - - - - - DC IKBRD 6 - KEYBOARD DC 0 - - - - - - - DC I2501 8 - 2501 CARD READER DC IDISK 9 - DISK FILE INPUT L@ISB EQU *-INSUB-1 NUMBER OF INPUT DEVICES *************************************************** * INPUT PEEK CHARACTERS * *************************************************** INPKC DC 0 READSTR FUNCTION DC 0 - - - - - - - DC 0 1442 CARD READ/PUNCH DC 0 - - - - - - - DC 0 PAPER TAPE READER DC 0 - - - - - - - DC 0 KEYBOARD DC 0 - - - - - - - DC 0 2581 CARD READER DC 0 DISK FILE INPUT *************************************************** * FLUSH SUBROUTINES FOR READ ERRORS * *************************************************** IFLSH DC RDS70 READSTR FUNCTION DC 0 - - - - - - - DC F1442 1442 CARD READ/PUNCH DC 0 - - - - - - - DC F1134 PAPER TAPE READER DC 0 - - - - - - - DC FKBRD KEYBOARD DC 0 - - - - - - - DC F2501 2501 CARD READER DC FDISK DISK FILE INPUT *************************************************** * EQUIVALENCES FOR DEVICE DESIGNATION * *************************************************** @CPRT EQU YES TYPEWRITER @READ EQU YES 1442 CARD READER @PNCH EQU YES 1442 CARD PUNCH @1132 EQU YES 1132 PRINTER @1134 EQU NO 1134 PAPER TAPE READER @1055 EQU NO 1055 PAPER TAPE PUNCH @1403 EQU NO 1403 PRINTER @KBRD EQU YES KEYBOARD @1627 EQU NO 1627 PLOTTER @2501 EQU NO 2501 CARD READER @IDSK EQU YES DISK FILE INPUT @ODSK EQU NO DISK FILE OUTPUT *************************************************** * STANDARD DEVICES FOR INPUT/OUTPUT * *************************************************** AIF (@CPRT EQ YES),.DONE AIF (@KBRD EQ NO),.DONE @CPRT SET YES NOTE* AGO KEYBOARD SPECIFIED WITHOUT TYPE- AGO WRITER - TYPEWRITER IS ASSUMED AGO (NECESSARY FOR KEYBOARD ECHO) ANOP .DONE ANOP AIF (@1403 EQ NO),.1132 @OSTD EQU 5 AGO .DONE .1132 AIF (@1132 EQ NO),.CPRT @OSTD EQU 3 AGO .DONE .CPRT AIF (@CPRT EQ YES),.OKAY NOTE* AGO NO PRINTER SPECIFIED - AGO TYPEWRITER ASSUMED FOR OUTPUT ANOP @CPRT SET YES .OKAY ANOP @OSTD EQU 1 .DONE ANOP AIF (@2501 EQ NO),.1442 @ISTD EQU 8 AGO .DONE .1442 AIF (@READ EQ NO),.1134 @ISTD EQU 2 AGO .DONE .1134 AIF (@1134 EQ NO),.KBRD @ISTD EQU 4 AGO .DONE .KBRD AIF (@KBRD EQ YES),.OKAY NOTE* AGO NO INPUT DEVICE SPECIFIED - AGO KEYBOARD ASSUMED FOR INPUT ANOP @KBRD SET YES .OKAY ANOP @ISTD EQU 6 .DONE ANOP @PSTD EQU 0 AIF (@PNCH EQ NO),.1055 @PSTD SET 2 AGO .DONE .1055 AIF (@1055 EQ NO),.DONE @PSTD SET 4 .DONE ANOP LIST HDNG 10 XTYO, TYO, TERPRI *************************************************** * OUTDEVP/INDEVP FUNCTIONS * *************************************************** DC @LAM+1 (LAMBDA (X) ... ODEVP LD XDVP9 SET UP FOR OUTDEVP STO XDVP7 LDD XDVP6 MDX XDVP1 *************************************************** DC @LAM+1 (LAMBDA (X) ... IDEVP LD XDVP8 SET UP FOR INDEVP STO XDVP7 LDD XDVP5 XDVP1 A I @ARG1 STO XDVP3+1 RTE 16 STO XDVP2 LD 3 @ARG1-X GET ARG 1 BSI 3 XNCHK-X CHECK IT XDVP2 DC *-* BSC L XDVP4,+ NOT DEFINED IF NON-POSITIVE S XDVP7 BSC L XDVP4,-Z NOT DEFINED IF TOO LARGE XDVP3 LD L *-* BSC L XDVP4,+- NOT DEFINED IF NO HANDLER LD 3 @TRUE-X BSI 3 POPJ-X RETURN T XDVP4 SRA 16 BSI 3 POPJ-X RETURN NIL *************************************************** BSS E 0 XDVP5 DC INSUB DC #IDVP XDVP6 DC OUTSB DC #ODVP XDVP7 DC *-* XDVP8 DC L@ISB XDVP9 DC L@OSB *************************************************** * TYO SUBROUTINE * *************************************************** XTYO DC *-* STO XTYO8 SAVE CHAR STX 2 XTYO4+1 SAVE XR2 LDX 2 -L@EBC XTYO1 LD L2 EBCTB+L@EBC SEARCH EBCDIC TABLE SRA 8 EOR XTYO8 COMPARE TO NUMERIC ARG BSC L XTYO2,+- MDX 2 1 MDX XTYO1 LD XTYO9 USE BLANK IF NOT FOUND MDX XTYO3 XTYO2 LD L 2 FORM ADR OF CHAR A XTYO1+1 XTYO3 BSI L OUTPT PRINT CHAR XTYO4 LDX L2 *-* RESTORE XR2 BSC I XTYO *************************************************** XTYO8 DC *-* XTYO9 DC EBCTB *************************************************** * TYO FUNCTION * *************************************************** DC @LAM+2 (LAMBDA (X Y) ... TYO BSI L STOUT SET OUTPUT DEVICE DC #TYO LD I @ARG2 GET EBCDIC TO OUTPUT BSI XTYO LD 3 @ARG2-X RETURN SECOND ARG BSI 3 POPJ-X *************************************************** LIST HDNG PRINT/PRIN1/PRINC FUNCTIONS *************************************************** * PRINT S-EXPRESSION * *************************************************** * ARG IS IN ACC - OUTDV AND AMPSW MUST * * ALREADY BE APPROPRIATELY SET. * *************************************************** PREXP BSI 3 PUSHA-X SAVE ARG ON STACK STX 2 PR040+1 SAVE XR2 BSC L PR040,+- BRANCH IF NIL BSI 3 XATOM-X BSC L PR600,+- BRANCH UNLESS ATOM LD 1 0 GET ARG S PR901 BSC L PR200,+Z BRANCH IF NUMBER S PR902 BSC L PR200,- BRANCH IF NUMBER LD I1 0 EOR PR903 BSC L PR100,+- BRANCH IF STRING PR010 MDX L AMPSW,0 SKIP IF AMPSW ZERO (PRIN1) MDX PR040 BRANCH IF NOT (PRINC) LDX 2 7 SET BITS IN CHAR TYPE SW STX 2 PR904 (ONLY TWO BITS NOW USED) LDX 2 3 SET XR2 TO SHIFT FIRST CHAR LD 1 0 GET PNAME OF ATOM BSI 3 XCAR-X PR020 BSC L PR030,+- BRANCH IF DONE STO PR905 BSI 3 XCAR-X BSI 3 XCDR-X GET CHAR BIT INDICATORS SRA 2 SHIFT IF FIRST CHAR AND PR904 AND INDICATORS OVER TYPE SW BSC L PR040,+- BRANCH IF NONE LEFT STO PR904 ELSE SAVE LDX 2 0 SET XR2 FOR NEXT CHARS LD I PR905 GET NEXT CHAR MDX PR020 PR030 LD PR905 CHECK LAST CHAR FOR BSI 3 XCAR-X -, +, OR / (IF SO, S PR906 IT IS ONLY CHAR) BSC Z S PR907 BSC Z S PR908 BSC L PR040,+- IF SO, BRANCH LD PR909 ATOM LOOKS LIKE A NUMBER, BSI L OUTPT PRECEDE WITH AMPERSAND PR040 LDX L2 *-* RESTORE XR2 LD 1 0 GET ARG BSI 3 XCAR-X GET PNAME OF ATOM PR050 BSC L PR230,+- BRANCH IF DONE STO PR904 SAVE PNAME LIST BSI 3 XCAR-X GET CHAR MDX L AMPSW,0 SKIP IF AMPSW ZERO (PRIN1) MDX PR070 STO PR905 SAVE CHAR LD I PR905 SLA 8 BIT 8 SET MEANS QUOTE IT BSC L PR060,- BRANCH UNLESS SET LD PR909 BSI L OUTPT PRINT AMPERSAND PR060 LD PR905 GET CHAR PR070 BSI L OUTPT OUTPUT CHAR LD I PR904 CHAIN DOWN PNAME MDX PR050 *************************************************** PR901 DC S@FST PR902 DC E@FST-S@FST PR903 DC @STR PR904 DC *-* PR905 DC *-* PR906 DC @DASH PR907 DC @PLUS-@DASH PR908 DC @SLSH-@PLUS PR909 DC @AMPR *************************************************** PR100 MDX L AMPSW,0 SKIP IF AMPSW ZERO (PRIN1) MDX PR110 LD PR920 PRINT LEADING COMMA BSI L OUTPT PR110 LD 1 0 GET ARG BSI 3 XCAR-X GET PNAME OF STRING PR120 BSC L PR140,+- BRANCH IF DONE STO PR904 BSI 3 XCAR-X GET CHAR S PR920 BSC L PR130,Z BRANCH UNLESS COMMA MDX L AMPSW,0 MDX PR130 LD PR920 BSI L OUTPT PRIN1 DOUBLES THE COMMA SRA 16 THIS GETS THE SECOND COMMA PR130 A PR920 BSI L OUTPT OUTPUT CHAR LD I PR904 CHAIN DOWN PNAME LIST MDX PR120 PR140 MDX L AMPSW,0 SKIP IF PRIN1 MDX PR230 LD PR920 BSI L OUTPT PRINT TRAILING COMMA MDX PR230 *************************************************** PR920 DC @COMA *************************************************** PR200 MDX L #HEX,0 OUTPUT NUMBER - TEST HEX MDX PR300 BRANCH FOR HEX NUMBER SRA 16 OUTPUT DECIMAL NUMBER STO PR904 CLEAR DIGIT COUNTER LD I1 0 GET NUMBER BSC L PR210,- BRANCH UNLESS NEGATIVE LD PR906 BSI L OUTPT PRINT MINUS SIGN SRA 16 S I1 0 NOW USE ABSOLUTE VALUE PR210 RTE 16 PUT NUMBER IN EXT SRA 16 CLEAR ACC D PR930 GET REMAINDER MOD 10 RTE 16 BSI 3 PUSHA-X PUSH REMAINDER MDX L PR904,1 INCR DIGIT COUNT RTE 16 BSC L PR210,Z MORE IF QUOTIENT NOT ZERO PR220 BSI 3 POPA-X POP DIGIT OFF STACK A PR931 CONVERT TO CHAT TABLE ADR BSI L OUTPT PRINT CHAR MDX L PR904,-1 COUNT DIGITS MDX PR220 PR230 BSI 3 POPA-X POP ARG OFF STACK BSI 3 POPJ-X *************************************************** PR930 DC 10 PR931 DC @0 *************************************************** PR300 LD PR940 HEX NUMBER - PRINT SLASH BSI L OUTPT LD I1 0 GET NUMBER STO PR905 SAVE IT LDX 2 4 COUNT HEX DIGITS PR310 SLT 16 CLEAR EXT LD PR905 RTE 28 GET ONE HEX DIGIT IN EXT STO PR905 SAVE REST RTE 16 S PR930 CONVERT TO CHAT TABLE ADR BSC - SKIP IF 0-9 A PR941 ELSE A-F A PR942 BSI L OUTPT PRINT HEX DIGIT MDX 2 -1 MDX PR310 LDX I2 PR040+1 RESTORE XR2 MDX PR230 *************************************************** PR940 DC @SLSH PR941 DC @A-@0-10 PR942 DC @0+10 *************************************************** PR600 LD PR980 BSI L OUTPT PRINT '(' LD 1 0 PR610 BSI 3 XCAR-X GET CAR OF ARG BSI 3 PUSHJ-X PRINT IT DC PREXP LD I1 0 GET CDR OF ARG BSC L PR650,+- BRANCH IF NIL BSI 3 XATOM-X BSC L PR640,Z BRANCH IF ATOM LD PR981 BSI L OUTPT PRINT BLANK LD I1 0 GET CDR OF ARG STO 1 0 SAVE IT MDX PR610 PR640 LD PR981 PRINT ' . ' BSI L OUTPT LD PR982 BSI L OUTPT LD PR981 BSI L OUTPT LD I1 0 PRINT ATOM BSI 3 PUSHJ-X DC PREXP PR650 LD PR983 PRINT ')' BSI L OUTPT MDX PR230 *************************************************** PR980 DC @LPAR PR981 DC @ PR982 DC @PER PR983 DC @RPAR *************************************************** * PRIN1/PRINC/PRINT FUNCTIONS * *************************************************** DC @LAM+1+@LIST PRINT BSI L STOUT SET OUTPUT DEVICE DC #PRNT LD PRI90 BSI L OUTPT PRINT CR LDS 1 SET FOR CR'S AFTER ITEMS MDX PRI10 *************************************************** DC @LAM+1+@LIST PRINC BSI L STOUT SET OUTPUT DEVICE DC #PRN1 LDS 0 PRI10 SRA 16 STO AMPSW SET FOR AMPERSANDS PRI20 STS PRI40 SAVE CR INDICATOR LD 3 @ARG2-X GET LIST OF ARGS PRI30 BSC L PRI60,+- BRANCH IF DONE STO 3 @ARG2-X SAVE LIST BSI 3 XCAR-X GET FIRST ITEM ON LIST BSI 3 PUSHJ-X PRINT IT DC PREXP PRI40 LDS *-* LD PRI90 IF PRINT, OUTPUT A CR BSI L OUTPT,O AFTER EACH ITEM LD I @ARG2 CHAIN DOWN LIST OF ARGS MDX PRI30 PRI60 LD 3 @ARG2-X BSC Z IF NO ARGS, RETURN NIL BSI 3 XCAR-X ELSE RETURN LAST ARG BSI 3 POPJ-X *************************************************** PRI90 DC @CR *************************************************** AMPSW DC *-* 0 = PREXP USES AMPERSANDS *************************************************** * TYPEWRITER HANDLER * *************************************************** AIF (@CPRT EQ YES),.YES AIF (@KBRD EQ YES),.YES OCPRT EQU 0 PCPRT EQU 0 AGO .NO .YES ANOP OCPRT DC *-* LD L2 PRTTB GET TYPEWRITER CODE CHAR SLA 8 LIBF KBCP0 PRINT IT BSC I OCPRT *************************************************** PCPRT DC *-* TYPEWRITER PAGESKIP LDX 2 5 PCPR4 LD PCPR9 OUTPUT 5 CARRIAGE RETURNS BSI L OUTPT MDX 2 -1 MDX PCPR4 BSC I PCPRT *************************************************** PCPR9 DC @CR *************************************************** .NO ANOP *************************************************** I1134 EQU 0 F1134 EQU 0 O1055 EQU 0 P1055 EQU 0 O1403 EQU 0 P1403 EQU 0 O1627 EQU 0 P1627 EQU 0 I2501 EQU 0 F2501 EQU 0 ODISK EQU 0 PDISK EQU 0 LIST HDNG 13 ERROR HANDLING SUBROUTINE *************************************************** * SYMBOLS FOR ERROR TYPES * *************************************************** @INFO EQU /0000 INFORMATIONAL MESSAGE ONLY @MINR EQU /1000 MINOR ERROR - DEFAULT USED @MAJR EQU /2000 MAJOR ERROR - RECOVERABLE @FATL EQU /3000 FATAL ERROR - CALL EXIT @DUMP EQU /4000 SYSTEM ERROR - CORE DUMP *************************************************** * ERROR SUBROUTINE * *************************************************** ERR01 STX L2 ERR50+1 SAVE XR2 BSI 3 PUSHS-X SAVE OLD VALUE OF HEX DC #HEX LD 3 @TRUE-X STO L #HEX SET FOR HEX OUTPUT BSI L SYSOU SET SYSTEM OUTPUT DEVICE LD I ERROR GET ERROR NUMBER AND TYPE STO ERR83 SAVE MDX L ERROR,1 SRT 12 STO L ERR45+1 SAVE TYPE S ERR82 BSC L ERR07,+Z BRANCH IF NOT @FATL/@DUMP SRA 16 MAKE SURE THAT THIS MESSAGE STO ERR99 GETS PRINTED ERR07 SRA 16 SLT 9 COMPUTE SECTOR ADR A ERR98+1 STO L DSKBF+1 SRA 16 STO ERR94 SET SW FOR GETTING CHARS STO ERR99 CLEAR ERRGAG SWITCH STO L AMPSW SLT 3 COMPUTE LOCATION OF MESSAGE M ERR97 WITHIN BUFFER SLT 16 A ERR96 STO ERR20+1 LD ERR93 SRT 16 BSI L DISKZ READ SECTOR OF ERROR FILE LD ERR92 PRINT CR,'***** ' BSI L OUTPT LDX 2 5 ERR10 LD ERR91 BSI L OUTPT MDX 2 -1 MDX ERR10 LD ERR90 BSI L OUTPT ERR15 MDX L $DBSY,0 WAIT FOR DISK READ MDX ERR15 LDX 2 -40 ERR20 LD L2 *-* GET TWO CHARS MDX L ERR94,0 SKIP FOR LEFT CHAR SLA 8 SRA 8 STO ERR89 SAVE CHAR S ERR88 BSC L ERR25,+- BRANCH IF CENTS SIGN S ERR87 BSC L ERR30,+- BRANCH IF NUMBER SIGN S ERR86 BSC L ERR35,+- BRANCH IF AT SIGN S ERR85 BSC L ERR43,+- BRANCH IF SEMICOLON S ERR84 BSC L ERR31,+- BRANCH IF PERCENT MDX L ERR99,0 MDX ERR40 LD ERR89 BSI L XTYO OUTPUT CHAR MDX ERR40 ERR25 MDX L ERR99,0 MDX ERR40 LD ERR92 PRINT CARRIAGE RETURN BSI L OUTPT MDX ERR40 ERR30 LD 3 @TRUE-X SET FOR HEX OUTPUT BSC +-Z ERR31 SRA 16 SET FOR DEC STO L #HEX LD L ERROR MDX L ERROR,1 BSI 3 PUSHJ-X PRINT NUMBER DC PREXP LD 3 @TRUE-X SET HEX BACK TO T STO L #HEX MDX ERR40 *************************************************** ERR82 DC @FATL ERR83 DC *-* ERR84 DC .%-.; (PERCENT)-(SEMICOLON) ERR85 DC .;-.@ (SEMICOLON)-(AT SIGN) ERR86 DC .@-.# (AT SIGN)-(NUMBER SIGN) ERR87 DC .#-.\ (NUMBER SIGN)-(CENTS SIGN) ERR88 DC .\ (CENTS SIGN) ERR89 DC *-* ERR90 DC @ ERR91 DC @STAR ERR92 DC @CR ERR93 DC DSKBF ERR94 DC *-* ERR95 DC 1 ERR96 DC DSKBF+42 ERR97 DC 40 ERR98 DSA LERRS FILE OF ERROR MESSAGES ERR99 DC *-* *************************************************** ERR35 LD I ERROR PRINT AN ARBITRARY LIST MDX L ERROR,1 MDX L ERR99,0 MDX ERR40 BSI 3 PUSHJ-X DC PREXP ERR40 LD ERR94 FLIP CHAR SWITCH EOR ERR95 STO ERR94 BSC L ERR20,Z MDX 2 1 MDX ERR20 ERR43 MDX L ERR99,0 MDX ERR45 LD ERR92 PRINT CR BSI L OUTPT BSI 3 POPS-X POP OLD VALUE FOR HEX ERR45 LDX L2 *-* BSC I2 ERR47 BRANCH ON ERROR TYPE *************************************************** ERR47 DC ERR50 NORMAL RETURN DC ERR50 NORMAL RETURN DC ERR55 RECOVER ROUTINE DC $EXIT CALL EXIT DC $DUMP+1 CORE DUMP *************************************************** ERR50 LDX L2 *-* RESTORE XR2 BSC I ERROR *************************************************** ERR55 MDX L REDSW,0 CHECK IF THIS IS READ ERROR MDX ERR58 BRANCH IF NOT STX L REDSW RESET READ SWITCH ERR56 LDS 0 WAS IT DUE TO /*/*/ BSC L ERR58,O BRANCH IF SO LDX I1 INDEV BSI I1 IFLSH FLUSH INPUT DEVICE ERR58 LDS 0 RESET SWITCH STS ERR56 MDX L ERP99,0 SKIP IF NO OUTSIDE ERRSET MDX ERR60 LD XERR9 RESTORE SPEC PDL S 3 @SPDL-X SRT 1 BSI 3 PUSHA-X BSI 3 POPN-X BSC L LSPER BRANCH TO TOP LEVEL ERR60 BSI ERPOP POP GARBAGE OFF PDL'S LD ERR83 GET ERROR NUMBER SLA 8 LOSE TOP EIGHT BITS SRA 8 BSI 3 MKFXN-X RETURN ERROR NUMBER BSI 3 POPJ-X FOR ERRSET *************************************************** * ERR FUNCTION * *************************************************** DC @LAM+@LIST XERR LD 3 @ARG1-X GET ARG LIST BSC Z SKIP IF NONE (NIL) BSI 3 XCAR-X ELSE GET IT STO XERR1 SAVE MDX L ERP99,0 SKIP IF NO OUTSIDE ERRSET MDX XERR3 LD XERR9 RESTORE SPEC PDL S 3 @SPDL-X SRT 1 BSI 3 PUSHA-X BSI 3 POPN-X BSI 3 ERROR-X PRINT MESSAGE DC 41+@INFO XERR1 DC *-* XERR3 BSI ERPOP POP GARBAGE OFF PDL'S BSC L LSPER BRANCH TO TOP LEVEL LD XERR1 RETURN GIVEN RESULT BSI 3 POPJ-X *************************************************** XERR9 DC S@SPD *************************************************** * POP UNWANTED JUNK OFF STACKS ON ERROR * *************************************************** ERPOP DC *-* LD ERP99 CHECK SPEC PDL S 3 @SPDL-X BSC L ERP10,+ BRANCH UNLESS OVERPOPPED BSI 3 ERROR-X DC 40+@DUMP ERP10 STX 1 ERP98 SAVE REG PDL POINTER SRT 1 POP GARBAGE OFF SPEC PDL BSC L ERP30,- STO ERP97 ERP20 BSI 3 POPS-X MDX L ERP97,1 MDX ERP20 ERP30 LD L 1 CHECK REG PDL S ERP98 BSC I ERPOP,- RETURN UNLESS OVERPOPPED BSI 3 ERROR-X DC 39+@DUMP *************************************************** ERP97 DC *-* ERP98 DC *-* ERP99 DC 0 *************************************************** * ERRSET FUNCTION * *************************************************** DC @NLAM+1+@LIST ERSET LD 3 @SPDL-X SAVE CURRENT SPEC PDL LEVEL STO ERP98 BSI 3 PUSHS-X PUSH LAST LEVEL DC ERP99 LD ERP98 PUT THIS LEVEL IN SWITCH STO ERP99 BSI 3 PUSHS-X PUSH ERR GAG SWITCH DC ERR99 BSI 3 PUSHS-X PUSH REG PDL LEVEL DC 1 (XR1 IS REG PDL POINTER) LD 3 @ARG2-X USE ARG 2, IF ANY, TO BSC Z SET ERR GAG SWITCH - BSI 3 XCAR-X NIL = PRINT ERRORS STO L ERR99 NON-NIL = GAG BSI 3 PUSHJ-X EVAL FIRST ARGUMENT DC EVAL RTE 16 SAVE IN EXT BSI 3 POPS-X RESTORE REG PDL BSI 3 POPS-X RESTORE GAG SW BSI 3 POPS-X RESTORE SPEC PDL LEVEL SRA 16 BSI 3 XCONS-X RETURN LIST OF EVALED ARG BSI 3 POPJ-X *************************************************** BSS E 0 DSKBF DC 320 WORD COUNT DC *-* SECTOR ADDRESS BSS 320 ERROR MESSAGE DISK BUFFER *************************************************** LIST HDNG 14 GARBAGE COLLECTOR (RECLAIMER) *************************************************** * GARBAGE COLLECTOR * *************************************************** * COLLECTION PROCEEDS IN 7 STEPS - * * 1. CLEAR BIT TABLES * * 2. MARK OBLIST STRUCTURE * * 3. MARK ATOMS ON OBLIST (NON-TWA) * * 4. MARK TEMLIST AND ITEMS THEREON * * 5. MARK FROM BOTH PDL'S * * 6. REMOVE TRULY WORTHLESS ATOMS * * 7. CONSTRUCT FREE LISTS * *************************************************** DC @NLAM GC STX 2 GC903 SAVE XR2 LDX 2 0 INDICATE TYPE MDX GC010 *************************************************** GCFST DC *-* STX 2 GC903 SAVE XR2 LDX 2 1 INDICATE TYPE MDX L #GCGA,0 IS GCGAG NIL MDX GC010 BSI 3 ERROR-X IF SO, PRINT MESSAGE DC 8+@INFO MDX GC010 *************************************************** GCFXS DC *-* STX 2 GC903 SAVE XR2 LDX 2 2 INDICATE TYPE MDX L #GCGA,0 IS GCGAG NIL MDX GC010 BSI 3 ERROR-X IF SO, PRINT MESSAGE DC 9+@INFO *************************************************** GC010 STX L2 GC720+1 SAVE TYPE INDICATOR LD GC909 ALTER ERROR NUMBER IN STO L PSHA3 CASE OF PDL OVERFLOW ************* 1. CLEAR BIT TABLES ***************** SRA 16 LDX L2 L@FXB CLEAR FXS BIT TABLE GC020 STO L2 S@FXB-1 MDX 2 -1 MDX GC020 ************* 2. MARK OBLIST STRUCTURE ************ LD L #OBLS GET ADR OF OBLIST STO GC085 SAVE IN CASE OF ERROR GC050 AND GC902 BSC L GC100,+- BRANCH IF NIL STO GC906 LD I GC906 MARK NODE OR GC907 STO I GC906 LD GC906 MARK ATOM TEMPORARILY BSI 3 XCAR-X STO GC065+1 GC065 LD L *-* S GC901 BSC Z DON'T MARK IF POTENTIAL TWA OR GC907 A GC901 STO I GC065+1 MDX L GC065+1,1 NOP LD I GC065+1 BSC L GC080,- ERROR IF NOT AN ATOM LD I GC906 (COR GC906) MDX GC050 GC080 LDX L2 L@FST CLEAR ALL MARK BITS GC082 LD L2 S@FST-2 IN FREE STORAGE AND GC902 STO L2 S@FST-2 MDX 2 -2 MDX GC082 BSI 3 ERROR-X PRINT ERROR MESSAGE DC 16+@FATL GC085 DC *-* ************* 3. MARK ATOMS ON OBLIST (NON-TWA) *** GC100 LD L #OBLS GET ADR OF OBLIST GC110 AND GC902 BSC L GC200,+- BRANCH IF NIL STO GC906 BSI 3 XCAR-X GET ADR OF AN ATOM STO GC905 LD I GC905 BSC L GC130,- BRANCH IF POTENTIAL TWA AND GC902 STO I GC905 UNDO TEMP MARK LD GC905 BSI 3 PUSHJ-X MARK THE ATOM DC GCMRK GC130 LD I GC906 (CDR GC906) MDX GC110 ************* 4. MARK TEMLIST AND ITEMS THEREON *** GC200 LD 3 @TMLS-X GET ADR OF TEMLIST GC210 AND GC902 BSC L GC300,+- BRANCH IF NIL STO GC908 LD I GC908 MARK NODE OF TEMLIST OR GC907 STO I GC908 LD GC908 BSI 3 XCAR-X TAKE CAR STO GC220+1 GET CONTENTS OF LOC GC220 LD L *-* POINTED TO BY CAR BSI 2 PUSHJ-X MARK IT DC GCMRK LD I GC908 (CDR GC908) MDX GC210 *************************************************** GC901 DC @UNDF GC902 DC /7FFF GC903 DC *-* XR2 SAVED HERE GC905 DC *-* GC906 DC *-* GC907 DC /8000 GC908 DC *-* GC909 DC 11+@FATL ERR NO. FOR GC PDL OVERFLOW *************************************************** ************* 5. MARK FROM BOTH PDL'S ************* GC300 LD L 1 MARK FROM REG PDL... GC310 STO GC908 S L GC919 BSC L GC350,- BRANCH IF DONE LD I GC908 GET WORD FROM PDL BSC L GC320,+ BRANCH IF BIT 0 SET BSI 3 PUSHJ-X MARK FROM ADR FROM PDL DC GCMRK GC320 LD GC908 MOVE DOWN PDL A GC918 MDX GC310 GC350 LD 3 @SPDL-X MARK SPEC PDL... GC360 STO GC908 S GC917 BSC L GC400,+ BRANCH IF DONE LD I GC908 BSC L GC370,+ BRANCH IF BIT 0 SET BSI 3 PUSHJ-X MARK FROM ADR FROM PDL DC GCMRK GC370 LD GC908 MOVE DOWN PDL S GC918 MDX GC360 ************* 6. REMOVE TRULY WORTHLESS ATOMS ***** GC400 LD GC403+1 STO GC906 GC403 LD L #OBLS GET ADR OF OBLIST GC420 AND GC916 BSC L GC500,+- BRANCH IF NIL STO GC905 BSI 3 XCAR-X BSI 3 XCDR-X BSC L GC430,+Z BRANCH IF MARKED LD I GC905 REMOVE ATOM FROM OBLIST STO I GC906 AND GC916 UNMARK OBLIST NODE WHICH STO I GC905 WAS DISCONNECTED MDX GC420 GC430 LD GC905 STO GC906 LD I GC905 (CDR GC905) MDX GC420 *************************************************** GC912 DC 1+@MAJR NORMAL PDL OVERFLOW ERR NO. GC913 SLA 0 USED TO CONSTRUCT SHIFT GC914 DC L@FXS GC915 DC E@FXS-1 GC916 DC /7FFF GC917 DC S@SPD GC918 DC 1 GC919 DC S@RPD *************************************************** ************* 7. CONSTRUCT FREE LISTS ************* GC500 SLT 32 CLEAR ACC AND EXT STO 3 @FSTL-X CLEAR FREE LIST ADRS STO 3 @FXSL-X STO GC710 CLEAR LIST COUNTERS STO GC711 LDX L2 L@FST COLLECT FREE STORAGE... GC510 LD L2 S@FST-2 GET A NODE BSC L GC520,+Z BRANCH IF MARKED LD 3 @FSTL-X ELSE ADD TO FREE LIST STO L2 S@FST-2 NOTE - EXT IS STILL ZERO LD L 2 A GC510+1 STO 3 @FSTL-X MDX L GC710,2 INCR COUNTER MDX GC530 GC520 AND GC916 CLEAR BIT 0 IF MARKED STO L2 S@FST-2 GC530 MDX 2 -2 MDX GC510 LD GC915 COLLECT FIXED-POINT LIST STO GC908 LD GC914 STO GC906 GC540 LD GC906 GET COUNTER S GC918 RTE 20 SRA 12 A GC913 CONSTRUCT SHIFT TO GET BIT STO GC550 RTE 12 SRA 4 STO L 2 LD L2 S@FXB GET WORD OF BIT TABLE GC550 SLA *-* GET BIT BSC L GC560,+Z BRANCH IF MARKED LD 3 @FXSL-X ADD TO FREE LIST STO I GC908 LD GC908 STO 3 @FXSL-X MDX L GC711,1 INCR COUNTER GC560 MDX L GC908,-1 MDX L GC906,-1 MDX GC540 ************* END OF GARBAGE COLLECTION *********** GC700 LD GC912 RESTORE NORMAL PDL STO L PSHA3 OVERFLOW ERROR CODE GC705 MDX L #GCGA,0 SKIP IF GCGAG NIL MDX GC720 BSI 3 ERROR-X PRINT MESSAGE DC 7+@INFO GC710 DC *-* GC711 DC *-* GC720 LDX L2 *-* PUT TYPE CODE IN XR2 BSC I2 * BRANCH ON TYPE DC GC725 0 - INVOKED BY USER (GC) DC GC730 1 - INVOKED BY CONS DC GC750 2 - INVOKED BY MKFXN *************************************************** GC725 LDX I2 GC903 RESTORE XR2 SRA 16 RETURN NIL AS VALUE BSI 3 POPJ-X RETURN TO USER *************************************************** GC730 LD 3 @FSTL-X WAS ANY FST AREA COLLECTED BSC L GC740,Z BRANCH IF SO BSI 3 ERROR-X ELSE FATAL ERROR DC 5+@FATL GC740 LDX I2 GC903 RESTORE XR2 BSC I GCFST *************************************************** GC750 LD 3 @FXSL-X WAS ANY FXS AREA COLLECTED BSC L GC760,Z BRANCH IF SO BSI 3 ERROR-X ELSE FATAL ERROR DC 6+@FATL GC760 LSX I2 GC903 RESTORE XR2 BSC I GCFXS *************************************************** LIST HDNG 15 MARK TREE FOR GARBAGE COLLECTOR *************************************************** * GCMRK - MARK TREE FOR GARBAGE COLLECTOR * *************************************************** GCMRK AND GCM92 CLEAR BIT 0 OF ARG STO GCM99 AND SAVE IT S GCM98 BSC L GCM10,+Z S GCM97 BSC L GCM30,+Z BRANCH IF IN FST GCM10 LD GCM99 S GCM96 BSC L GCM20,+Z S GCM95 BSC L GCM60,+Z BRANCH IF IN FXS GCM20 BSI 3 POPJ-X RETURN GCM30 LD I GCM99 GET FIRST WORD OF NODE BSC +Z BSI 3 POPJ-X RETURN IF ALREADY MARKED OR GCM94 ELSE MARK IT STO I GCM99 LD GCM99 IS IT AN ATOM (BIT 0 A GCM93 OF CAR SET) STO GCM35+1 GCM35 LD L *-* BSC L GCM50,- BRANCH IF NOT AND GCM92 BSC L GCM40,Z BRANCH UNLESS PNAME NULL LD I GCM99 IS IT A (NULL) STRING S GCM89 (IT IS NOW MARKED) BSC +- NO, SKIP FOR ERROR BSI 3 POPJ-X YES, RETURN BSI 3 ERROR-X DC 15+@DUMP GCM40 STO GCM45+1 MARK PNAME GCM45 LD L *-* OR GCM94 STO I GCM45+1 AND GCM92 BSC L GCM40,Z LD I GCM99 GO MARK PROPERTY LIST MDX GCMRK GCM50 LD GCM99 SAVE ARG ON PDL BSI 3 PUSHA-X BSI 3 XCAR-X MARK CAR OF NODE BSI 3 PUSHJ-X DC GCMRK BSI 3 POPA-X POP ARG STO GCM55+1 TAKE CDR (THIS IS A GCM55 LD L *-* FAST WAY) MDX GCMRK GO MARK CDR GCM60 LD GCM99 MARK WORD IN FXS S GCM96 RTE 20 SRA 12 OR GCM91 CONSTRUCT SHIFT STO GCM63 RTE 12 SRA 4 A GCM90 CONSTRUCT ADDRESS WITHIN STO GCM65+1 BIT TABLE LD GCM94 GCM63 SRA *-* PUT BIT IN PROPER POSITION GCM65 OR L *-* OR INTO BIT TABLE STO I GCM65+1 MDX GCM20 *************************************************** GCM89 DC @STR+@ATOM GCM90 DC S@FXB GCM91 SRA 0 USED TO CONSTRUCT SHIFT GCM92 DC /7FFF GCM93 DC 1 GCM94 DC /8000 GCM95 DC E@FXS-S@FXS GCM96 DC S@FXS GCM97 DC E@FST-S@FST GCM98 DC S@FST GCM99 DC *-* *************************************************** LIST HDNG 16 XCONS, CONS, MKFXN *************************************************** * CONS XSUBR * *************************************************** XCNS1 STO XCNS9 CDR IN ACC, CAR IN EXT LD 3 @FSTL-X BSI L GCFST,+- GC IF NO FST LEFT LD 3 @FSTL-X GET ADR OF FREE CELL STO XCNS2+1 LD I @FSTL (SETQ @FSTL (CDR @FSTL)) STO 3 @FSTL-X LDD XCNS9 PUT GOODIES IN FREE CELL XCNS2 STO L *-* STL 32 STO XCNS9 LD XCNS2+1 RETURN ADR OF CELL BSC I XCONS *************************************************** BSS E 0 XCNS9 DC NIL PROTECTED BY TEMLIST DC NIL *************************************************** * CONS FUNCTION * *************************************************** DC @LAM+2 (LAMBDA (X Y) ... CONS LD 3 @ARG1-X PUT FIRST ARG IN EXT RTE 16 LD 3 @ARG2-X SECOND IN ACC BSI 3 XCONS-X BSI 3 POPJ-X *************************************************** * MKFXN SUBROUTINE * *************************************************** MKFX1 STO MKFX9 SAVE NUMBER LD 3 @FXSL-X BSI L GCFXS,+- GC IF NO FXS LEFT LD 3 @FXSL-X STO MKFX2+1 LD I @FXSL STO 3 @FXSL-X LD MKFX9 MKFX2 STO L *-* LD MKFX2+1 RETURN ADR OF NUMBER BSC I MKFXN *************************************************** MKFX9 DC *-* *************************************************** LIST HDNG 17 INPUT, TYI, READCH *************************************************** * SET UP INPUT FOR PROPER INPUT DEVICE * *************************************************** SETIN DC *-* LD I SETIN SET NAME OF CALLING FN MDX L SETIN,1 STO SETI2 LD 3 @ARG1-X GET ARG 1 SETI2 DC *-* BSI 3 XNCHK-X CHECK IT BSI 3 PUSHJ-X CHECK IF DEFINED DC IDEVP BSC L SETI5,+- ERROR IF NOT LD I @ARG1 STO L INDEV SET DEVICE NUMBER BSC I SETIN SETI5 LD 3 @ARG1-X PRINT ERROR MESSAGE STO SETI6 BSI 3 ERROR-X DC 13+@MAJR SETI6 DC *-* FAULTY DEVICE NUMBER *************************************************** * SET UP INPUT FOR SYSTEM INPUT DEVICE * *************************************************** SYSIN DC *-* STO 3 @ARG1-X SYSI2 LD L #SYSI CHECK SYSIN BSI 3 XNMBP-X BSC L SYSI5,+- BAD IF NOT A NUMBER LD I #SYSI USE SYSIN BSC L SYSI5,+- BRANCH IF BAD DC IDEVP BSI 3 PUSHJ-X BSC I SYSIN STO L INDEV SYSI5 LD 3 @SYSI-X USE STANDARD INPUT BSC +-Z *************************************************** * PEEK - PEEK AT AN INPUT CHARACTER * *************************************************** PEEK DC *-* STX 1 INPT5+1 SAVE XR1 STX 2 PEEK6+1 SAVE XR2 LDX I3 $XR3X SET XR3 FOR LIBFS LDX I1 INDEV PUT DEVICE NUMBER IN XR1 LD L1 INPKC IS NEXT CHAR IN SAVE AREA BSI I1 INSUB,+- IF NOT, GET ONE STO L1 INPKC SAVE IT LDX I1 INPT5+1 RESTORE XR1 PEEK6 LDX L2 *-* RESTORE XR2 LDX L3 X RESTORE XR3 BSC I PEEK *************************************************** * INPUT - INPUT A CHARACTER * *************************************************** INPUT DC *-* STX 1 INPT5+1 SAVE XR1 STX 2 INPT6+1 SAVE XR2 LDX I3 $XR3X SET XR3 FOR LIBFS LDX L1 *-* PUT DEVICE NUMBER IN XR1 INDEV EQU *-1 DEV NUMBER MAY BE CHANGED LD L1 INPKC IS NEXT CHAR IN SAVE AREA BSI I1 INSUB,+- IF NOT, GET ONE RTE 16 SRA 16 STO L1 INPKC CLEAR SAVE BUFFER RTE 16 INPT5 LDX L1 *-* RESTORE XR1 INPT6 LDX L2 *-* RESTORE XR2 LDX L3 X RESTORE XR3 BSC I INPUT *************************************************** * READ EOF ERROR HANDLER * *************************************************** RDEOF LD INDEV GET DEVICE NUMBER STO RDEO7 LDX I1 INPT5+1 RESTORE XR1 FOR PDL LDX L3 X RESTORE XR3 LDS 1 STS L ERR56 SET SWITCH FOR NO FLUSH BSI 3 ERROR-X SIGNAL ERROR DC 37+@MAJR *************************************************** RDEO7 DC *-* *************************************************** * READCH, READC, PEEKCH, PEEKC * *************************************************** DC @LAM+1 (LAMBDA (X) ... REDCH BSI L SETIN DC #RDCH LDS 0 MDX RDCH1 *************************************************** DC @LAM+1 (LAMBDA (X) ... READC BSI L SETIN DC #REDC LDS 1 MDX RDCH1 *************************************************** DC @LAM+1 (LAMBDA (X) ... PEKCH BSI L SETIN DC #PKCH LDS 2 MDX RDCH1 *************************************************** DC @LAM+1 (LAMBDA (X) ... PEEKC BSI L SETIN DC #PEKC LDS 3 RDCH1 STS RDCH2 SAVE INDICATOR LD RDCH2 STO RDCH5 RDCH2 LDS *-* BSC L RDCH3,C RDCHX BSI L INPUT INPUT CHAR BSC L RDCHX,+Z TRY AGAIN IF KEYBOARD KILL MDX RDCH4 RDCH3 BSI L PEEK PEEK AT CHAR BSC L RDCH4,- BRANCH UNLESS KEYBOARD KILL BSI L INPUT INPUT CHAR MDX RDCH3 GO PEEK AGAIN RDCH4 SRT 16 BSI 3 XCONS-X MAKE CHAR LIST OR RDCH9 SET ATOM MARK RTE 16 LD RDCH8 SET STRING VALUE MARKER BSI 3 XCONS-X RDCH5 LDS *-* BSC L RDCH6,O STO 3 @ARG1-X INTERN STRING IF BSI 3 PUSHJ-X READCH OR PEEKCH DC INTRN RDCH6 BSI 3 POPJ-X *************************************************** RDCH8 DC @STR RDCH9 DC @ATOM *************************************************** * TYI FUNCTION * *************************************************** DC @LAM+1 (LAMBDA (X) ... TYI BSI L SETIN SET INPUT DEVICE DC #TYI BSI L INPUT READ A CHAR STO TYI1+1 TYI1 LD L *-* GET EBCDIC SRA 8 BSI 3 MKFXN-X MAKE IT A NUMBER BSI 3 POPJ-X *************************************************** * INTERN FUNCTION * *************************************************** DC @LAM+1 (LAMBDA (X) ... INTRN LD 3 @ARG1-X CHECK FOR VALID ARGUMENT BSC +- BSI 3 POPJ-X OF IF NIL (RETURN) S INT99 BSC L INT10,+Z S INT98 BSC L INT10,- BAD IF OUTSIDE FREE STG A INT97 STO INT05+1 INT05 LD L *-* GET CHAR BSC L INT15,+Z BAD IF NOT ATOM INT10 LD 3 @ARG1-X STO INT12 BSI 3 ERROR-X DC 17+@MAJR INT12 DC *-* INT15 STO INT96 SAVE ADR OF PNAME STRING SLA 1 BSC L INT20,Z ERROR IF PNAME NULL BSI 3 ERROR-X DC 18+@MAJR INT20 LD INT95 GET ADR OF ATOM OBLIST INT25 STO INT94 LD INT96 STO INT90 SAVE ADR OF PNAME OF ARG LD I INT94 BSC L INT45,+- BRANCH IF END OF OBLIST BSI 3 XCAR-X STO INT93 SAVE ADR OF ATOM BSI 3 XCAR-X BSC L INT30,Z ERROR IF NULL BSI 3 ERROR-X DC 12+@DUMP INT30 STO INT92 BSC L INT35,Z BRANCH IF MORE LETTERS MDX L INT90,0 SKIP IF NONE LEFT IN ARG MDX INT40 TEST NEXT ATOM LD INT93 CHECK IF NIL S INT87 BSC Z RETURN CLEAR ACC IF SO LD INT93 RETURN EQUIVALENT ATOM BSI 3 POPJ-X INT35 LD INT92 GET CHAR OF ATOM BSI 3 XCAR-X STO INT91 LD INT90 GET CHAR OF ARG BSC L INT45,+- BSI 3 XCAR-X S INT91 BSC L INT45,+Z BRANCH TO INSERT BSC L INT40,Z BRANCH TO TEST NEXT ATOM LD I INT90 TEST NEXT CHAR STO INT90 LD I INT92 MDX INT30 INT40 LD I INT94 TEST NEXT ATOM ON OBLIST MDX INT25 *************************************************** INT82 DC #C@R INT83 DC @R INT84 DC @D-@A INT85 DC @A INT86 DC @C INT87 DC #NIL INT88 DC NIL PROTECTED BY TEMLIST INT89 DC @UNDF INT90 DC *-* INT91 DC *-* INT92 DC *-* INT93 DC *-* INT94 DC *-* INT95 DC #OBLS INT96 DC *-* INT97 DC 1+E@FST INT98 DC E@FST-S@FST INT99 DC S@FST *************************************************** INT45 LDD I @ARG1 CREATE NEW ATOM WITH LD INT89 UNDEFINED VALUE, AND BSI 3 XCONS-X PROTECT IT FROM STO INT88 GARBAGE COLLECTION BSI 3 XCAR-X GET PRINT NAME STO INT90 SAVE, CHECK FOR C-R ATOM BSI 3 XCAR-X EOR INT86 IS FIRST CHAR C BSC L INT60,Z BRANCH IF NOT INT50 LD I INT90 GET REST OF CHARS STO INT90 BSC L INT60,+- BRANCH IF NONE LEFT LD I INT90 BSC L INT55,+- BRANCH IF ONLY ONE LEFT LD INT90 TEST NEXT CHAR BSI 3 XCAR-X S INT85 IS IT A BSC Z S INT84 IS IT D BSC L INT60,Z BRANCH IF NEITHER MDX INT50 INT55 LD INT90 TEST LAST CHAR BSI 3 XCAR-X EOR INT83 IS IT R BSC L INT60,Z BRANCH IF NOT LD INT82 GIVE THE ATOM A SPECIAL RTE 16 C-R FUNCTION VALUE LD INT88 BSI 3 XCONS-X STO I INT88 INT60 LD INT88 RTE 16 LD I INT94 INSRT NEW ATOM INTO OBLIST BSI 3 XCONS-X STO I INT94 LD INT88 GET NEW ATOM RTE 16 SAVE IN EXT SRA 16 STO INT88 PRESET PROTECTED LOC TO NIL RTE 16 GET ATOM FROM EXT BSI 3 POPJ-X *************************************************** EJCT *************************************************** * READ FUNCTION * *************************************************** DC @LAM+1 (LAMBDA (X) ... READ BSI L SETIN SET INPUT DEVICE DC #READ RD005 STX 2 RD035+1 SAVE XR2 (READSTR ENTRY) LDX I2 INDEV (SETIN SET INDEV PROPERLY) RD010 BSI L PEEK PEEK AT A CHAR S RD901 BSC Z S RD902 BSC L RD020,Z BRANCH UNLESS BLANK OR ) STO L2 INPKC ELSE FORCE NEXT PEEK TO MDX RD010 GET A NEW CHAR RD020 SRA 16 SET REDSW SO EOF CARD STO REDSW IS AN ERROR RD025 BSI 3 PUSHJ-X CALL RECURSIVE DC RD050 S-EXPRESSION READER BSC L RD010,+Z TRY AGAIN IF KEYBOARD KILL STX REDSW RESET REDSW RD035 LDX L2 *-* RESTORE XR2 BSI 3 POPJ-X *************************************************** RD901 DC @ RD902 DC @RPAR-@ *************************************************** REDSW DC *-*+* 0 MEANS EOF CARD IS ERROR *************************************************** RD050 BSI L INPUT INPUT A CHAR BSC +Z BSI 3 POPJ-X POP OUT IF KEYBOARD KILL STO RD910 SAVE CHAR S RD901 BSC L RD050,+- TRY AGAIN IF BLANK S RD911 BSC Z S RD912 BSC L RD060,Z BRANCH UNLESS . OR ) STX 2 RD055 BSI 3 ERROR-X ERROR - INVALID EXPRESSION DC 20+@MAJR RD055 DC *-* RD060 S RD913 BSC L RD600,+- BRANCH IF ( S RD914 BSC L RD580,+- BRANCH IF ' (QUOTE) S RD915 BSC L RD500,+- BRANCH IF , (COMMA) MDX RD100 *************************************************** RD910 DC *-* RD911 DC @PER-@ RD912 DC @RPAR-@PER RD913 DC @LPAR-@RPAR RD914 DC @QUOT-@LPAR RD915 DC @COMA-@QUOT *************************************************** RD100 SLT 32 BSI 3 XCONS-X CREATE ATOM HEADER STO RD920 SAVE ADR FOR PROTECTION A RD921 STO RD922 SAVE ADR TO APPEND CHARS STX 2 RD200+1 SAVE XR2 LDX 2 7 SET BITS IN CHAR TYPE SW STX 2 RD923 (ONLY 2 BITS ARE NOW USED) LDX 2 3 SET XR2 TO SHIFT FIRST CHAR LD RD910 CHECK CHAR RD110 S RD924 BSC L RD120,Z BRANCH UNLESS AMPERSAND STO RD923 ZERO CHAR TYPE SWITCH BSI L INPUT USE NEXT CHAR STO RD910 BSC +Z BSI 3 POPJ-X POP OUT IF KEYBOARD KILL RD120 LD I RD910 GET INDICATOR BITS FOR CHAR SRA 2 SHIFT 3 IF 1ST CHAR, ELSE 0 AND RD923 AND OVER BITS ALREADY THERE STO RD923 LD RD910 APPEND CHAR TO PNAME SRT 16 BSI 3 XCONS-X MDX 2 0 IF FIRST CHAR OR RD925 OR IN ATOM MARK TO ADR STO I RD922 PUT ADR IN LAST NODE STO RD922 SAVE AS ADR FOR NEXT APPEND LDX 2 0 ZERO XR2 FOR OTHER CHARS BSI L PEEK PEEK AT NEXT CHAR S RD901 IS IT BLANK BSC Z S RD911 IS IT . (DOT) BSC Z S RD912 IS IT ) BSC Z S RD913 IS IT ( BSC Z S RD914 IS IT ' (QUOTE) BSC Z S RD915 IS IT , (COMMA) BSC L RD200,+- BRANCH IF ANY ONE OF THEM BSI L INPUT INPUT THE CHAR PEEKED AT STO RD910 SAVE IT BSC L RD110,- BSI 3 POPJ-X POP OUT IF KEYBOARD KILL *************************************************** RD920 DC NIL PROTECTED BY TEMLIST RD921 DC 1 RD922 DC *-* RD923 DC *-* RD924 DC @AMPR RD925 DC @ATOM ALSO CONSTANT /8000 *************************************************** RD200 LDX L2 *-* RESTORE XR2 LD RD923 CHECK CHAR TYPE SWITCH BSC L RD250,E BRANCH IF DECIMAL NUMBER SRA 2 BSC L RD300,E BRANCH IF HEX NUMBER RD210 LD RD920 SET UP ARG FOR INTERN STO 3 @ARG1-X SRA 16 CLEAR PROTECTED LOC TO NIL STO RD920 BSC L INTRN INTERN ATOM AS RESULT RD250 MDX L RD922,1 IS LAST CHAR + OR - LD I RD922 (IF SO, IT IS ONLY CHAR) S RD930 BSC Z S RD931 BSC L RD210,+- IF SO, BRANCH TO INTERN IT STX RD932 SET SIGN SWITCH FOR + SRA 16 STO RD933 CLEAR VALUE LD RD920 STO RD285 SAVE ATOM HEADER FOR ERROR BSI 3 XCAR-X GET ADR OF PNAME STRING STO RD922 BSI 3 XCAR-X CHECK FIRST CHAR S RD930 BSC L RD260,+- BRANCH IF + S RD931 BSC L RD265,Z BRANCH UNLESS - STO RD932 CLEAR SIGN SWITCH FOR - RD260 LD I RD922 SKIP FIRST CHAR STO RD922 RD265 LD RD922 RD267 BSI 3 XCAR-X GET DIGIT S RD934 STO RD935+1 PUTIN WD 2 OF 2-WORD ZERO LD RD933 M RD936 MULTIPLY OLD VALUE BY 10 AD RD935 ADD IN NEW DIGIT BSC L RD280,Z BRANCH IF OVERFLOW SLT 16 STO RD933 SAVE VALUE LD I RD922 CHAIN DOWN LIST OF DIGITS STO RD922 BSC L RD267,Z BRANCH UNLESS DONE STO RD920 CLEAR PROTECTED LOC TO NIL LD RD933 GET VALUE BSC L RD270,- OKAY IF NON-NEGATIVE SLA 1 BSC L RD280,Z ERROR IF LARGER THAN 32768 MDX L RD932,0 ERROR IF EXACTLY 32768 MDX RD280 BUT SIGN IS + RD270 LD RD933 GET VALUE MDX L RD932,0 SKIP IF SIGN SWITCH - MDX RD273 SRA 16 S RD933 RD273 BSI 3 MKFXN-X MAKE A NUMBER BSI 3 POPJ-X POP OUT RD280 STX 2 RD287 BSI 3 ERROR-X ERROR - NUMBER OVERFLOW DC 22+@MINR RD285 DC *-* RD287 DC *-* LD RD925 LD RD925 USE -32768 IF NEGATIVE MDX L RD932,0 LD RD937 USE 32768 IF POSITIVE MDX RD273 *************************************************** RD930 DC @PLUS RD931 DC @DASH-@PLUS RD932 DC *-* RD933 DC *-* RD934 DC @0 RD935 DEC 0 TWO-WORD ZERO, EVEN LOC RD936 DC 10 RD937 DC /7FFF *************************************************** RD300 MDX L RD922,1 IS LAST CHAR / LD I RD922 (IF SO, IT IS ONLY CHAR) S RD940 BSC L RD210,+- IF SO, BRANCH TO INTERN LD RD920 STO RD325 SAVE ATOM HEADER FOR ERROR BSI 3 XCAR-X GET ADR OF PNAME STRING BSI 3 XCDR-X SKIP FIRST CHAR STO RD932 SAVE ADR OF STRING SRA 16 STO RD920 CLEAR PROTECTED LOC TO NIL STO RD933 CLEAR VALUE LDX 2 4 SET COUNTER FOR 4 DIGITS RD310 LD RD933 SHIFT VALUE OVER BY 4 BITS SLA 4 (MULTIPLY BY 16) STO RD933 LD RD932 BSI 3 XCAR-X GET NEXT DIGIT S RD934 BSC +Z SKIP IF 0-9 A RD941 ELSE CORRECT FOR A-F OR RD933 OR NEW DIGIT INTO VALUE STO RD933 LD I RD932 CHAIN DOWN LIST OF DIGITS BSC L RD320,+- BRANCH IF DONE STO RD932 MDX 2 0 SKIP IF XR2 ALREADY 0 MDX 2 -1 ELSE DECR BY 1 NOP MDX RD310 RD320 MDX 2 0 SKIP IF XR2 IS ZERO MDX RD330 LDX I2 RD200+1 RESTORE XR2 STX 2 RD327 MORE THAN 4 HEX DIGITS WERE BSI 3 ERROR-X INPUT - PRINT WARNING DC 42+@MINR RD325 DC *-* RD327 DC *-* RD330 LDX I2 RD200+1 RESTORE XR2 LD RD933 GET VALUE, GO MAKE A NUMBER MDX RD273 AND POP OUT *************************************************** RD940 DC @SLSH RD941 DC @0-@A+10 *************************************************** RD500 LDD RD960 CREATE STRING HEADER BSI 3 XCONS-X STO RD964 SAVE ADR FOR PROTECTION A RD961 STO RD962 SAVE ADR TO APPEND CHARS RD510 BSI L INPUT INPUT A CHAR BSC +Z BSI 3 POPJ-X POP OUT IF KEYBOARD KILL S RD963 BSC L RD530,+- BRANCH IF COMMA RD520 A RD963 SRT 16 APPEND CHAR TO PNAME BSI 3 XCONS-X SRT 15 RD962 IS ODD IF AND ONLY LD RD962 IF THIS IS FIRST CHAR - SLT 15 THIS PROVIDES ATOM MARK STO I RD962 STO RD962 SAVE FOR NEW APPEND ADR MDX RD510 RD530 BSI L PEEK PEEK AT NEXT CHAR S RD963 BSC L RD540,Z BRANCH UNLESS COMMA STO L2 INPKC ERASE CHAR BUFFERED BY PEEK MDX RD520 GO USE COMMA AS NEXT CHAR RD540 LD RD964 SAVE ADR OF STRING STO RD962 SRA 16 STO RD964 LD RD962 RETURN STRING BSI 3 POPJ-X *************************************************** BSS E 0 RD960 DC @STR DC /8000 RD961 DC 1 RD962 DC *-* RD963 DC @COMA RD964 DC NIL PROTECTED BY TEMLIST *************************************************** RD580 BSI 3 PUSHJ-X READ S-EXPRESSION DC RD050 FOLLOWING QUOTE BSC +Z BSI 3 POPJ-X POP OUT IF KEYBOARD KILL SRT 16 BSI 3 XCONS-X FORM LIST RTE 16 LD RD968 RTE 16 BSI 3 XCONS-X FORM LIST (QUOTE S-EXPR) BSI 3 POPJ-X *************************************************** RD968 DC #QUOT *************************************************** RD600 BSI 3 PUSHA-X PUT A NIL (EMPTY LIST) LD L 1 ON STACK, AND THEN ADR OF BSI 3 PUSHA-X THAT NIL FOR APPENDING RD610 BSI L PEEK PEEK AHEAD FOR A NON-BLANK BSC L RD700,+Z BRANCH IF KEYBOARD KILL S RD971 BSC L RD620,Z STO L2 INPKC FORCE NEXT PEEK TO NEW CHAR MDX RD610 RD620 S RD972 BSC L RD680,+- BRANCH IF ) S RD973 BSC L RD630,+- BRANCH IF . (DOT) BSI 3 PUSHJ-X READ AN S-EXPRESSION DC RD050 BSC L RD700,+Z BRANCH IF KEYBOARD KILL SRT 16 BSI 3 XCONS-X STO I1 0 APPEND TO LIST STO 1 0 SAVE ADR FOR NEXT APPEND MDX RD610 RD630 LD 1 1 BRANCH UNLESS NO BSC L RD640,Z ITEM PRECEDED NOT STX 2 RD635 BSI 3 ERROR-X PRINT ERROR MESSAGE DC 23+@MAJR RD635 DC *-* RD640 SRA 16 STO L2 INPKC CLEAR PEEKED DOT BSI 3 PUSHJ-X READ S-EXPRESSION DC RD050 BSC L RD700,+Z BRANCH IF KEYBOARD KILL STO I1 0 PATCH ONTO END OF LIST BSI 3 POPA-X POP OFF TEMP ADR FOR APPEND RD650 BSI L PEEK PEEK AHEAD FOR A NON-BLANK S RD971 BSC L RD660,Z STO L2 INPKC FORCE NEXT PEEK TO NEW CHAR MDX RD650 RD660 S RD972 IS CHAR A ) BSC L RD670,Z BRANCH IF NOT STO L2 INPKC RD665 BSI 3 POPA-X POP OFF NEWLY CREATED LIST BSI 3 POPJ-X POP OUT RD670 BSI 3 POPA-X POP LIST OFF STACK STO RD675 AND USE IN ERROR MESSAGE STX 2 RD677 BSI 3 ERROR-X DC 21+@MAJR RD675 DC *-* RD677 DC *-* RD680 STO L2 INPKC CLEAR PEEKED ) (ACC = 0) BSI 3 POPA-X POP OFF TEMP ADR FOR APPEND MDX RD665 RD700 STO RD962 SAVE KEYBOARD KILL FLAG BSI 3 POPA-X POP TWO THINGS OFF STACK BSI 3 POPA-X LD RD962 GET FLAG BSI 3 POPJ-X *************************************************** RD971 DC @ RD972 DC @RPAR-@ RD973 DC @PER-@RPAR *************************************************** LIST HDNG 19 KEYBOARD INPUT DEVICE HANDLER *************************************************** * KEYBOARD HANDLER * *************************************************** AIF (@KBRD EQ YES),.YES IKBRD EQU 0 FKBRD EQU 0 AGO .NO .YES ANOP IKBRD DC *-* MDX L IKB98,0 SKIP IF NO CHAR IN BUFFER MDX IKB55 IKB05 LD L #DDTI STO IKB95 INIT END SWITCH IKB07 LD IKB96 INIT BUFFER POINTER STO IKB97 STX IKB86 RESET BS SWITCH SRA 16 STO IKB98 INIT BUFFER COUNTER IKB10 LD *-1 PUT 00D NUMBER IN ACC LIBF KBCP0 READ A CHAR RTE 20 AND IKB99 BSC L IKB30,+- BRANCH UNLESS CONTROL SLA 1 BSC L IKB15,Z BRANCH UNLESS CR STX IKB95 SET END SWITCH MDX IKB38 USE BLANK FOR CHAR IKB15 MDX L IKB98,0 BSC +-Z MDX IKB10 BRANCH IF NO CHARS IN BUF BSC L IKB25,- BRANCH UNLESS BS MDX L IKB97,-1 DECR POINTER AND COUNTER MDX L IKB98,-1 NOP LD IKB93 MDX L IKB86,0 SKIP IF LAST CHAR WAS BS BSI IKB70 ECHO NUMBER SIGN SRA 16 SET SW - LAST CHAR WAS BS STO IKB86 LD I IKB97 BSI IKB70 ECHO LAST CHAR TYPED MDX L IKB98,0 MDX IKB10 LD IKB93 IF NONE LEFT ECHO NUMBER,CR BSI IKB70 LD IKB94 BSI IKB70 MDX IKB10 IKB25 LD IKB93 ECHO NUMBER, NUMBER, CR BSI IKB70 LD IKB93 BSI IKB70 LD IKB94 BSI IKB70 MDX IKB07 REINITIALIZE FOR INPUT IKB30 RTE 12 STO IKB92 SAVE CHAR S IKB89 IS IT A 0-8-2 BSC L IKB60,+- BRANCH IF SO LDX 2 -L@EBC SEARCH TABLE IKB35 LD L2 CRDTB+L@EBC EOR IKB92 BSC L IKB40,+- MDX 2 1 MDX IKB35 IKB38 LDX 2 -L@EBC USE BLANK IF NOT FOUND IKB40 LD L 2 CALCULATE ADR A IKB91 IKB45 STO I IKB97 PUT IN BUFFER LD IKB93 MDX L IKB86,0 SKIP IF LAST CHAR WAS BS BSC +-Z BSI IKB70 IF SO, ECHO NUMBER SIGN STX IKB86 RESET BS SWITCH LD I IKB97 GET CHAR AGAIN MDX L IKB97,1 MDX L IKB98,1 BSI IKB70 ECHO IT MDX L IKB95,0 MDX IKB50 BRANCH IF END SW SET LD IKB98 S IKB90 BSC L IKB10,+Z BRANCH UNLESS BUFFER FULL IKB50 MDX L #DDTI,0 MDX IKB52 LD IKB94 ECHO CR BSI IKB70 IKB52 LD IKB96 SET ADR FOR CHAR FETCH STO IKB97 IKB55 LD I IKB97 GET CHAR FROM BUFFER MDX L IKB97,1 MDX L IKB98,-1 NOP BSC I IKBRD IKB60 LD IKB93 ECHO OR,QUES,OR BSI IKB70 LD IKB87 BSI IKB70 LD IKB93 BSI IKB70 LD IKB88 USE -1 FOR KEYBOARD KILL STX IKB95 SET END SWITCH MDX IKB45 *************************************************** IKB86 DC *-*+* ZERO = LAST CHAR WAS BS IKB87 DC @QUES IKB88 DC -1 IKB89 DC /2820 0-8-2 IKB90 DC L@KBD LENGTH OF BUFFER IKB91 DC EBCTB+L@EBC IKB92 DC *-* IKB93 DC @NMBR IKB94 DC @CR IKB95 DC *-* IKB96 DC IKBBF IKB97 DC *-* IKB98 DC 0 CHAR COUNTER IKB99 DC /E000 *************************************************** IKB70 DC *-* ECHO CHAR UNLESS KBECHO NIL IKB72 MDX L #KBEC,0 BSC +-Z MDX IKB75 LDX 2 1 SET OUTPUT FOR TYPEWRITER STX L2 OUTDV BSI L OUTPT LDX I3 $XR3X SET XR3 FOR LIBFS IKB75 BSC I IKB70 *************************************************** FKBRD DC *-* LD IKB94 PRINT CARRIAGE RETURN BSI IKB70 LD IKB96 RESET BUFFER POINTER STO IKB97 SRA 16 STO IKB98 RESET CHAR COUNTER STO L INPKC+6 CLEAR PEEK BUFFER BSC I FKBRD *************************************************** IKBBF BSS 100 KEYBOARD INPUT BUFFER L@KBD EQU *-IKBBF LENGHT OF BUFFER *************************************************** .NO ANOP HDNG EVAL FUNCTION *************************************************** * EVAL FUNCTION * *************************************************** DC @LAM+1 (LAMBDA (ARG) ... EVAL LD 3 @ARG1-X GET ARG BSC +- SKIP UNLESS NIL BSI 3 POPJ-X RETURN NIL IF ARG IS NIL S EV901 BSC L EV010,+Z BRANCH IF NUMBER S EV902 BSC L EV020,+Z BRANCH UNLESS NUMBER EV010 LD 3 @ARG1-X RETURN ARG (NUMBER/STRING) BSI 3 POPJ-X EV020 LD 3 @ARG1-X GET CAR OF ARG A EV903 STO EV030+1 EV030 LD L *-* BSC L EV100,- BRANCH UNLESS ATOM LD I @ARG1 IS IT AN UNDEFINED ATOM S EV903 BSC L EV050,Z BRANCH IF NOT LD 3 @ARG1-X STO EV040 BSI 3 ERROR-X UNBOUND VARIABLE ERROR DC 23+@MAJR EV040 DC *-* EV050 S EV903 IS IT A STRING BSC L EV010,+- BRANCH IF SO LD I @ARG1 RETURN VALUE OF ATOM BSI 3 POPJ-X *************************************************** EV901 DC S@FST EV902 DC E@FST-S@FST EV903 DC 1 *************************************************** EV100 BSC +- RESULT IS NIL IF BSI 3 POPJ-X (CAR ARG) IS NIL STO EV120 SAVE (CAR ARG) S EV901 BSC L EV110,+Z BRANCH IF NUMBER S EV902 BSC L EV130,+Z BRANCH UNLESS NUMBER EV110 BSI 3 ERROR-X INVALID FUNCTION ERROR DC 24+@MAJR EV120 DC *-* EV130 LD EV120 GET (CAR ARG) A EV903 STO EV140+1 EV140 LD L *-* BSC L EV200,- BRANCH IF NOT AN ATOM LD I EV120 GET VALUE OF ATOM S EV903 BSC L EV160,Z BRANCH UNLESS UNDEFINED LD EV120 STO EV150 BSI 3 ERROR-X UNDEFINED FUNCTION ERROR DC 25+@MAJR EV150 DC *-* EV160 S EV903 IS IT A CHAR STRING BSC L EV110,+- BRANCH IF SO (ERROR) LD I EV120 GET VALUE OF (CAR ARG) RTE 16 LD I @ARG1 GET (CDR ARG) BSI 3 XCONS-X CONS THEM STO 3 @ARG1-X SAVE AS NEW ARG MDX EVAL EV200 S EV930 TEST (CAAR ARG) BSC L EV250,+- BRANCH IF SUBR S EV931 BSC L EV300,+- BRANCH IF LAMBDA S EV932 BSC L EV350,+- BRANCH IF NLAMBDA S EV933 BSC L EV400,+- BRANCH IF MLAMBDA S EV934 BSC L EV300,+- BRANCH IF C-R S EV935 BSC L EV500,+- BRANCH IF LABEL LD I @ARG1 GET (CDR ARG) BSI 3 PUSHA-X SAVE ON STACK LD EV120 GET (CAR ARG) STO 3 @ARG1-X BSI 3 PUSHJ-X EVALUATE IT DC EVAL RTE 16 BSI 3 POPA-X POP (CDR ARG) OFF STACK BSI 3 XCONS-X CONS THEM STO 3 @ARG1-X SAVE AS NEW ARG MDX EVAL AND EVALUATE *************************************************** EV930 DC #SUBR EV931 DC #LAM-#SUBR EV932 DC #NLAM-#LAM EV933 DC #MLAM-#NLAM EV934 DC #C@R-#MLAM EV935 DC #LABL-#C@R *************************************************** EV250 LD I EV120 GET (CDAR ARG) STO EV260+1 EV260 LD L *-* GET WORD POINTED TO SRA 14 GET TOP TWO BITS A EV940 STO EV270+1 EV270 BSC I *-* BRANCH ON TWO BITS *************************************************** EV940 DC EV941 EV941 DC EV300 00 = LAMBDA DC EV350 01 = NLAMBDA DC EV400 02 = MLAMBDA DC EV400 11 = UNASSIGNED (MLAMBDA) *************************************************** EV300 LD EV120 GET (CAR ARG) BSI 3 PUSHA-X PUSH ON STACK LD I @ARG1 GET (CDR ARG) BSI 3 PUSHA-X PUSH ON STACK SRA 16 BSI 3 PUSHA-X PUSH NIL ON STACK LD L 1 BSI 3 PUSHA-X PUSH ADR OF NULL LIST LD 1 2 GET (CDR ARG) LIST OF FORMS EV310 BSC L EV330,+- DONE IF ALL FORMS EVALED STO 1 2 SAVE LIST OF FORMS A EV950 STO EV320+1 EV320 LD L *-* GET CAR OF LIST STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL IT DC EVAL RTE 16 SRA 16 BSI 3 XCONS-X CONS IT WITH NIL STO I1 0 APPEND TO LIST OF RESULTS STO 1 0 SAVE ADR FOR NEXT APPEND LD I1 2 TAKE CDR OF LIST OF FORMS MDX EV310 EV330 BSI 3 POPA-X POP OFF ADR FOR APPENDING BSI 3 POPA-X POP OFF LIST OF RESULTS STO 3 @ARG2-X SAVE AS ARG 2 FOR APPLY BSI 3 POPA-X POP OFF LIST OF FORMS BSI 3 POPA-X POP OFF FUNCTION STO 3 @ARG1-X SAVE AS ARG 1 FOR APPLY BSC L APPLY GO APPLY FN TO RESULTS EV350 LD I @ARG1 GET (CDR ARG) STO 3 @ARG2-X SAVE AS ARG2 FOR APPLY LD L EV120 GET (CAR ARG) STO 3 @ARG1-X SAVE AS ARG1 FOR APPLY BSC L APPLY APPLY FN TO UNEVALED FORMS EV400 LD I @ARG1 GET (CDR ARG) STO 3 @ARG2-X SAVE AS ARG2 FOR APPLY LD L EV120 GET (CAR ARG) STO 3 @ARG1-X SAVE AS ARG1 FOR APPLY BSI 3 PUSHJ-X APPLY FN TO UNEVALED FORMS DC APPLY STO 3 @ARG1-X BSC L EVAL NOW GO EVAL RESULT *************************************************** EV950 DC 1 *************************************************** EV500 LD I EV120 GET (CDAR ARG) BSC L EV600,+- ERROR IF NIL A EV950 STO EV510+1 EV510 LD L *-* GET (CADAR ARG) STO EV530 SAVE IT S EV960 BSC L EV520,+Z BRANCH IF NUMBER OR NIL S EV961 BSC L EV520,- BRANCH IF NUMBER LD EV530 A EV950 STO EV515+1 EV515 LD L *-* BSC L EV550,+Z BRANCH IF ATOM EV520 BSI 3 ERROR-X ERROR - BAD FIRST ARG DC 26+@MAJR EV530 DC *-* EV550 LD I EV530 TEST ATOM S EV962 BSC L EV520,+- ERROR IF ACTUALLY A STRING LD EV530 STO EV560 BSI 3 PUSHS-X SAVE ATOM'S OLD VALUE EV560 DC *-* ON SPEC PDL LD I EV120 GET (CDAR ARG) STO EV570+1 EV570 LD L *-* GET (CDDAR ARG) BSC L EV600,+- ERROR IF NIL STO EV580+1 A EV950 STO EV590+1 EV580 LD L *-* GET (CDDDAR ARG) BSC L EV600,Z ERROR IF NOT NIL EV590 LD L *-* GET (CADDAR ARG) STO I EV560 SAVE AS NEW VALUE OF ATOM RTE 16 LD I @ARG1 GET (CDR ARG) BSI 3 XCONS-X CONS THEM STO 3 @ARG1-X SAVE AS ARG BSI 3 PUSHJ-X EVAL IT DC EVAL STO EV530 SAVE VALUE TEMPORARILY BSI 3 POPS-X RESTORE OLD VALUE OF ATOM LD EV530 RETURN VALUE SAVED BSI 3 POPJ-X EV600 LD L EV120 ERROR - WRONG NUMBER STO EV610 OF ARGS FOR LABEL BSI 3 ERROR-X DC 27+@MAJR EV610 DC *-* *************************************************** EV960 DC S@FST EV961 DC E@FST-S@FST EV962 DC @STR *************************************************** HDNG APPLY FUNCTION *************************************************** * APPLY FUNCTION * *************************************************** DC @LAM+2 (LAMBDA (FN ARGS) ... APPLY LD 3 @ARG1-X IS FN AN ATOM BSC +- BSI 3 POPJ-X RETURN NIL IF NIL BSI 3 XATOM-X BSC L AP050,+- AP020 LD 3 @ARG2-X IF SO, SAVE ARGS BSI 3 PUSHA-X BSI 3 PUSHJ-X EVAL FN DC EVAL STO 3 @ARG1-X SAVE AS NEW FN BSI 3 POPA-X GET ARGS STO 3 @ARG2-X MDX APPLY NOW TRY AGAIN TO APPLY AP050 LD 3 @ARG1-X GET (CAR FN) A AP901 STO AP060+1 AP060 LD L *-* S AP902 IS IT LAMBDA BSC Z S AP903 IS IT NLAMBDA BSC Z S AP904 IS IT MLAMBDA BSC L AP400,Z IF NOT, BRANCH STO AP910 CLEAR COUNT OF ARG BINDINGS LD I @ARG1 GET (CDR FN) A AP901 STO AP110+1 AP110 LD L *-* GET (CADR FN) STO AP130 SAVE ADR OF PARAMS AP120 STO AP190 SAVE REST OF PARAMS BSC L AP140,Z BRANCH UNLESS NONE LEFT LD 3 @ARG2-X GET ARGS BSC L AP300,+- BRANCH IF NONE LEFT BSI 3 ERROR-X ERROR - TOO MANY ARGS DC 28+@MAJR AP130 DC *-* AP140 LD AP190 CHECK PARAM LIST S AP912 BSC L AP150,+Z BRANCH IF NUMBER OF NIL S AP913 BSC L AP170,+Z BRANCH UNLESS NUMBER AP150 LD AP130 STO AP160 BSI 3 ERROR-X ERROR - BAD PARAM LIST DC 30+@MAJR AP160 DC *-* AP170 LD AP190 TEST IF PARAM LIST A AP901 IS AN ATOM STO AP180+1 AP180 LD L *-* BSC L AP200,- BRANCH IF NOT LD I AP190 TEST IF IT IS A STRING S AP914 BSC L AP150,+- BRANCH IF SO - ERROR BSI 3 PUSHS-X PUSH OLD VALUE ON SPEC PDL AP190 DC *-* LD 3 @ARG2-X BIND ATOM TO LIST OF STO I AP190 REST OF ARGS MDX L AP910,-1 INCR NEG COUNT OF BINDINGS NOP MDX AP300 AP200 LD 3 @ARG2-X TEST ARGS BSC L AP220,Z BRANCH UNLESS NONE LEFT LD AP130 STO AP210 BSI 3 ERROR-X ERROR - TOO FEW ARGS DC 29+@MAJR AP210 DC *-* AP220 LD AP190 GET CAR OF PARAM LIST A AP901 STO AP230+1 AP230 LD L *-* STO AP250 S AP912 BSC L AP150,+Z BRANCH IF NUMBER OR NIL S AP913 BSC L AP160,- BRANCH IF NUMBER LD AP250 A AP901 STO AP240+1 AP240 LD L *-* BSC L AP150,- BRANCH UNLESS ATOM LD I AP250 S AP914 BSC L AP150,+- BRANCH IF STRING BSI 3 PUSHS-X PUSH OLD VALUE ON SPEC PDL AP250 DC *-* LD 3 @ARG2-X GET CAR OF ARG LIST A AP901 STO AP260+1 AP260 LD L *-* STO I AP250 BIND ATOM TO NEW VALUE MDX L AP910,-1 INCR NEG COUNT OF BINDINGS NOP LD I @ARG2 GET REST OF ARGS STO 3 @ARG2-X AND SAVE LD I AP190 GET REST OF PARAMS MDX AP120 AND GO BIND THEM TOO *************************************************** AP901 DC 1 AP902 DC #LAM AP903 DC #NLAM-#LAM AP904 DC #MLAM-#NLAM AP910 DC *-* AP912 DC S@FST AP913 DC E@FST-S@FST AP914 DC @STR *************************************************** AP300 LD AP910 PUSH NEG COUNT OF BINDINGS BSI 3 PUSHA-X SRA 16 BSI 3 PUSHA-X PUSH A NIL FOR RESULT BSI 3 PUSHA-X PUSH A NIL FOR FORMS LD 3 @ARG1-X STO AP310+1 AP310 LD I *-* GET (CDDR FN) AP320 BSC L AP340,+- DONE IF NO FORMS LEFT STO 1 0 A AP901 STO AP330+1 AP330 LD L *-* GET NEXT FORM ON LIST STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL IT DC EVAL STO 1 1 SAVE RESULT LD I1 0 GET REST OF FORMS MDX AP320 GO EVAL THEM TOO AP340 BSI 3 POPA-X POP OFF LIST OF FORMS BSI 3 POPA-X POP OFF FINAL RESULT BSI 3 POPN-X UNBIND VARIABLES BSI 3 POPJ-X RETURN *************************************************** AP400 S AP930 TEST (CAR FN) BSC L AP700,Z BRANCH UNLESS SUBR LD I @ARG1 GET ADDRESS OF SUBR STO AP933 S AP931 MUST BE BETWEEN END OF BSC L AP410,+Z RESIDENT MONITOR AND S AP932 START OF DATA AREA BSC L AP430,+Z AP410 LD I @ARG1 STO AP420 LD 3 @ARG1-X STO AP425 BSI 3 ERROR-X ERROR IF AT INVALID ADR DC 34+@MAJR AP420 DC *-* AP425 DC *-* AP430 LD I AP933 GET ARGUMENT INDICATOR AND AP934 AND OUT TOP 8 BITS STO AP935 SAVE NUMBER OF ARGS WANTED S AP936 BSC L AP500,+Z BRANCH IF LESS THAN 8 BSC L AP440,Z ERROR IF MORE THAN 8 LD I AP933 SLA 2 BSC L AP500,- ERROR IF 8 PLUS A LIST AP440 LD 3 @ARG1-X STO AP445 LD AP933 STO AP450 BSI 3 ERROR-X DC 33+@MAJR AP445 DC *-* AP450 DC *-* *************************************************** AP930 DC #SUBR-#MLAM AP931 DC $ZEND AP932 DC S@FXB-$ZEND AP933 DC *-* AP934 DC /00FF AP935 DC *-* AP936 DC 8 NUMBER OF @ARGN LOCATIONS *************************************************** AP500 LD AP940 SET UP TO SPREAD ARGS STO AP941 LD 3 @ARG1-X SAVE ARG 1 FOR ERROR MSGS STO AP530 STO AP560 LD 3 @ARG2-X AP510 STO AP942 SAVE REST OF ARGS MDX L AP935,0 SKIP IF NO MORE WANTED MDX AP550 LD I AP933 SLA 2 BSC L AP520,- BRANCH UNLESS LIST WANTED LD AP942 STO I AP941 PUT INTO NEXT ARG MDX AP600 AP520 LD AP942 NO MORE ARGS WANTED AT ALL BSC L AP600,+- BRANCH IF NONE LEFT LD AP933 STO AP540 BSI 3 ERROR-X ERROR - TOO MANY ARGS DC 31+@MAJR AP530 DC *-* AP540 DC *-* AP550 LD AP942 MORE ARGS WANTED BSC L AP580,Z BRANCH UNLESS NONE LEFT LD AP933 STO AP570 BSI 3 ERROR-X ERROR - TOO FEW ARGS DC 32+@MAJR AP560 DC *-* AP570 DC *-* AP580 LD AP942 GET (CAR ARGS) A AP943 STO AP590+1 AP590 LD L *-* STO I AP941 PUT INTO NEXT ARG MDX L AP941,1 INCR ARG POINTER MDX L AP935,-1 DECR ARG COUNT NOP LD I AP942 GET REST OF ARGS AND MDX AP510 GO SPREAD THEM TOO AP600 MDX L AP933,1 INCR TO GET ENTRY POINT BSC I AP933 APPLY'S VALUE IS SUBR'S *************************************************** AP940 DC @ARG1 AP941 DC *-* AP942 DC *-* AP943 DC 1 *************************************************** AP700 S AP950 TEST (CAR FN) BSC L AP020,Z BRANCH UNLESS C-R LD 3 @ARG2-X TEST LIST OF ARGS BSC L AP710,+- BRANCH IF NONE LD I @ARG2 BSC L AP740,+- BRANCH UNLESS TWO OR MORE AP710 LD 3 @ARG1-X STO AP720 LD 3 @ARG2-X STO AP730 BSI 3 ERROR-X WRONG NUMBER OF ARGS DC 35+@MAJR AP720 DC *-* AP730 DC *-* AP740 SRA 16 STO AP941 CLEAR COUNTER LD 3 @ARG2-X A AP943 STO AP745+1 AP745 LD L *-* GET ARG STO AP942 SAVE ARG LD I @ARG1 GET (CDR FN) C-R TYPE ATOM A AP943 STO AP750+1 AP750 LD L *-* GET PRINT NAME STO AP760+1 SKIP FIRST CHAR AP760 LD L *-* STO AP760+1 SAVE LIST OF CHARS A AP943 STO AP770+1 LD I AP760+1 BSC L AP780,+- BRANCH IF LAST CHAR AP770 LD L *-* GET CHAR BSI 3 PUSHA-X PUSH ON STACK MDX L AP941,1 INCR COUNT MDX AP760 AP780 LD AP941 BSC L AP810,+- BRANCH IF NO A'S OR D'S AP785 BSI 3 POPA-X POP OFF AN A OR A D EOR AP951 BSC L AP790,Z BRANCH UNLESS A LD AP942 BSI 3 XCAR-X TAKE CAR MDX AP800 AP790 LD AP942 BSI 3 XCDR-X ELSE TAKE CDR AP800 STO AP942 MDX L AP941,-1 COUNT A'S AND D'S MDX AP785 AP810 LD AP942 RETURN RESULT BSI 3 POPJ-X *************************************************** AP950 DC #C@R-#SUBR AP951 DC @A *************************************************** AP997 DC #LABL AP998 DC #NLAM AP999 DC #MLAM *************************************************** HDNG COND, SET/SETQ/SETQQ FUNCTIONS *************************************************** * COND FUNCTION * *************************************************** DC @NLAM+@LIST (LAMBDA X ... COND LD 3 @ARG1-X GET LIST OF LISTS BSI 3 PUSHA-X SPACE FOR LISTS AND RESULT BSI 3 PUSHA-X SPACE FOR CURRENT LIST COND2 BSC L COND6,+- NO MORE LISTS - RESULT NIL BSI 3 XCAR-X GET NEXT LIST STO 1 0 SAVE BSI 3 XCAR-X GET FIRST ITEM STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL IT DC EVAL BSC L COND4,Z BRANCH UNLESS NIL LD I1 1 GET REST OF LISTS STO 1 1 MDX COND2 GO TRY NEXT ONE COND4 STO 1 1 SAVE VALUE OF ITEM LD I1 0 GET REST OF ITEMS BSC L COND6,+- BRANCH IF NONE LEFT STO 1 0 SAVE BSI 3 XCAR-X GET NEXT ITEM STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL IT DC EVAL MDX COND4 GO TRY REST OF ITEMS COND6 BSI 3 POPA-X POP CURRENT LIST BSI 3 POPA-X POP RESULT BSI 3 POPJ-X RETURN *************************************************** * SET/SETQ/SETQQ FUNCTION * *************************************************** DC @LAM+2 (LAMBDA (X Y) ... SET MDX SET10 *************************************************** DC @NLAM+2 (NLAMBDA (X Y) ... SETQQ MDX SET10 *************************************************** DC @NLAM+2 (NLAMBDA (X Y) ... SETQ LD 3 @ARG1-X BSI 3 PUSHA-X SAVE FIRST ARG LD 3 @ARG2-X STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL SECOND ARG DC EVAL STO 3 @ARG2-X SAVE RESULT BSI 3 POPA-X STO 3 @ARG1-X RESTORE FIRST ARG SET10 LD 3 @ARG1-X CHECK FIRST ARG S SET90 BSC L SET30,+Z ERROR IF NUMBER OR NIL S SET91 BSC L SET30,- ERROR IF NUMBER A SET92 STO SET20+1 SET20 LD L *-* BSC L SET30,- ERROR IF NOT ATOM LD I @ARG1 S SET93 BSC L SET50,Z ERROR IF STRING SET30 LD 3 @ARG1-X STO SET40 BSI 3 ERROR-X BAD FIRST ARG FOR SET DC 36+@MAJR SET40 DC *-* SET50 LD 3 @ARG2-X SET ATOM TO VALUE STO I @ARG1 OF SECOND ARG AND BSI 3 POPJ-X RETURN THAT VALUE *************************************************** SET90 DC S@FST SET91 DC E@FST-S@FST SET92 DC 1+E@FST SET93 DC @STR *************************************************** * LIST FUNCTION * *************************************************** DC @LAM+@LIST LIST LD 3 @ARG1-X GET LIST OF (EVALED) ARGS BSI 3 POPJ-X AND RETURN *************************************************** HDNG 1442 CARD READER INPUT HANDLER *************************************************** * 1442 INPUT HANDLER * *************************************************** AIF (@READ EQ YES),.YES I1442 EQU 0 F1442 EQU 0 AGO .NO .YES ANOP I1442 DC *-* MDX L I1499,0 SKIP UNLESS FLUSH REQUESTED MDX I1450 GO FLUSH MDX L I1498,0 SKIP IF NO CHARS LEFT MDX I1430 I1410 BSI I1460 READ CARD, SKIP IF EOF MDX I1420 MDX L REDSW,0 SKIP IF IN MIDDLE OF READ MDX I1410 BSC L RDEOF GO HANDLE READ EOF ERROR I1420 LD I14BF SET CHAR COUNT STO I1498 LD I1496 SET CHAR POINTER STO I1495 I1430 LD I I1495 GET CHAR MDX L I1495,1 INCR POINTER MDX L I1498,-1 DECR COUNT NOP STO I1494 SAVE CHAR LDX 2 -L@EBC SEARCH TABLE I1435 LD L2 CRDTB+L@EBC EOR I1494 BSC L I1440,+- MDX 2 1 MDX I1435 LDX 2 -L@EBC USE BLANK IF NOT FOUND I1440 LD L 2 CALCULATE ADR A I1493 BSC I I1442 RETURN I1450 SRA 16 STO I1499 CLEAR FLUSH SWITCH I1455 BSI I1460 READ CARD, SKIP IF EOF MDX I1455 IF NOT, TRY AGAIN MDX I1410 IF SO, TRY TO READ A CHAR I1460 DC *-* LIBF CARD0 READ A CARD DC /1000 DC I14BF I1465 LIBF CARD0 WAIT FOR IT DC 0 MDX I1465 LDX 2 5 COMPARE TO /*/*/ I1470 LD L2 I14BF EOR L2 I1492-1 BSC I I1460,Z RETURN IF NON-MATCH MDX 2 -1 MDX I1470 MDX L I1460,1 SKIP ON RETURN IF EOF BSC I I1460 *************************************************** I1492 DC /3000 CARD CODE / DC /4220 CARD CODE * DC /3000 CARD CODE / DC /4220 CARD CODE * DC /3000 CARD CODE / I1493 DC EBCTB+L@EBC I1494 DC *-* I1495 DC I14BF+73 I1496 DC I14BF+1 I1498 DC 0 I1499 DC 0 NON-ZERO = FLUSH REQUEST *************************************************** F1442 DC *-* STX I1499 SET FLUSH SWITCH BSC I F1442 *************************************************** I14BF DC 72 1442 CARD INPUT BUFFER BSS 72 *************************************************** .NO ANOP HDNG 1132 PRINTER OUTPUT HANDLER *************************************************** * 1132 PRINTER OUTPUT HANDLER * *************************************************** AIF (@1132 EQ YES),.YES O1132 EQU 0 P1132 EQU 0 AGO .NO .YES ANOP O1132 DC *-* LD L 2 CHECK CHAR S O1199 BSC L O1135,+- BRANCH IF CARRIAGE RETURN LD O1198 EOR O1197 FLIP BIT 0 OF POINTER BSC - A O1196 IF BIT 0 IS NOW 0, INCR STO O1198 SAVE POINTER SLA 1 PUT BIT 0 IN CARRY LD L2 EBCTB GET CHAR FROM EBCDIC TABLE BSC L O1120,C BRANCH IF BIT 0 WAS 1 AND O1195 AND FLAG BITS OUT OF WORD MDX O1125 O1120 SRA 8 SHIFT TO RIGHT-HAND HALF OR I O1198 OR IN LAST CHAR O1125 STO I O1198 SAVE IN BUFFER MDX L O11BF,1 INCR COUNT (NO. OF CHARS+1) O1127 BSC I O1132 O1135 LD O11BF CHECK COUNT SRA 1 DIVIDE BY 2 BSC L O1150,+ BRANCH IF NO CHARS IN BUF STO O11BF SAVE NUMBER OF WORDS LIBF PRNT1 PRINT LINE DC /2000 DC O11BF DC O1170 O1140 LIBF PRNT1 WAIT UNTIL DONE DC 0 MDX O1140 LD O1196 RESET COUNT STO O11BF LD O1194 RESET POINTER STO O1198 MDX O1127 O1150 LIBF PRNT1 PRINT BLANK LINE (SKIP) DC /3D00 MDX O1127 *************************************************** O1170 DC *-* PRNT1 ERROR HANDLER BSC I O1170 DON'T DO ANYTHING SPECIAL *************************************************** O1194 DC O11BF+/8000 O1195 DC /FF00 O1196 DC 1 O1197 DC /8000 O1198 DC O11BF+/8000 O1199 DC @CR-EBCTB *************************************************** O11BF DC 1 1132 OUTPUT BUFFER BSS 60 *************************************************** P1132 DC *-* 1132 PRINTER PAGESKIP LIBF PRNT1 SKIP TO CHANNEL 1 DC /3100 BSC I P1132 *************************************************** .NO ANOP *************************************************** HDNG ARITHMETIC FUNCTIONS *************************************************** * NUMERIC FUNCTIONS * *************************************************** * THIS ROUTINE HANDLES ALL ARITHMETIC * * FUNCTIONS WHICH TAKE ANY NUMBER OF ARGS. * * THESE INCLUDE BOOLE, PLUS, DIFF, TIMES, * * QUOTIENT, REMAINDER, MAX, MIN, GCD. * *************************************************** DC @LAM+2+@LIST BOOLE LD 3 @ARG1-X GET FIRST ARG BSI 3 XNCHK-X CHECK IT DC #BOOL AND BOOL9 GET LOW 4 BITS STX 2 NF035+1 SAVE XR2 STO L 2 PUT FN INDICATOR IN XR2 LD 3 @ARG2-X STO 3 @ARG1-X LD 3 @ARG3-X STO 3 @ARG2-X BSI NFNCS DC #BOOL BOOLE *************************************************** BOOL9 DC /000F *************************************************** DC @LAM+1+@LIST PLUS STX 2 NF035+1 SAVE XR2 LDX 2 16 SET FN INDICATOR BSI NFNCS DC #PLUS *************************************************** DC @LAM+1+@LIST DIFF STX 2 NF035+1 SAVE XR2 LDX 2 17 SET FN INDICATOR BSI NFNCS DC #DIFF DIFF *************************************************** DC @LAM+1+@LIST TIMES STX 2 NF035+1 SAVE XR2 LDX 2 18 SET FN INDICATOR BSI NFNCS DC #TIMS TIMES *************************************************** DC @LAM+1+@LIST QUO STX 2 NF035+1 SAVE XR2 LDX 2 19 SET FN INDICATOR BSI NFNCS DC #QUO QUOTIENT *************************************************** DC @LAM+1+@LIST REM STX 2 NF035+1 SAVE XR2 LDX 2 20 SET FN INDICATOR BSI NFNCS DC #REM REMAINDER *************************************************** DC @LAM+1+@LIST MAX STX 2 NF035+1 SAVE XR2 LDX 2 21 SET FN INDICATOR BSI NFNCS DC #MAX MAX *************************************************** DC @LAM+1+@LIST MIN STX 2 NF035+1 SAVE XR2 LDX 2 22 SET FN INDICATOR BSI NFNCS DC #MIN MIN *************************************************** DC @LAM+1+@LIST GCD STX 2 NF035+1 SAVE XR2 LDX 2 23 SET FN INDICATOR BSI NFNCS DC #GCD GCD *************************************************** NFNCS DC *-* LD I NFNCS GET FUNCTION NAME STO NF020 STO NF050 LD 3 @ARG1-X GET FIRST ARG BSI 3 XNCHK-X CHECK IT NF020 DC *-* STO NF911 SAVE IT LD 3 @ARG2-X NF030 BSC L NF040,Z BRANCH UNLESS NONE LEFT LD NF911 GET RESULT BSI 3 MKFXN-X MAKE IT A NUMBER NF035 LDX L2 *-* RESTORE XR2 BSI 3 POPJ-X RETURN NF040 BSI 3 XCAR-X GET NEXT ARG BSI 3 XNCHK-X CHECK IT NF050 DC *-* STO NF912 SAVE IT (B) LD NF911 GET LAST PARTIAL RESULT (A) BSC I2 NF055 BRANCH TO DO FUNCTION *************************************************** NF055 DC NFA10 0 DC NFB10 A AND B DC NFC10 (NOT A) AND B DC NFD10 B DC NFE10 A AND (NOT B) DC NFF10 A DC NFG10 A EOR B DC NFH10 A OR B DC NFI10 (NOT A) AND (NOT B) DC NFJ10 A EQV B DC NFK10 NOT A DC NFL10 (NOT A) OR B DC NFM10 NOT B DC NFN10 A OR (NOT B) DC NFO10 (NOT A) OR (NOT B) DC NFP10 1 DC NFQ10 A+B DC NFR10 A-B DC NFS10 A*B DC NFT10 A/B DC NFU10 A REMAINDER B DC NFV10 A MAX B DC NFW10 A MIN B DC NFX10 A GCD B *************************************************** NF060 STO NF911 SAVE NEW PARTIAL RESULT LD I @ARG2 CHAIN DOWN LIST OF ARGS STO 3 @ARG2-X MDX NF030 *************************************************** NF911 DC *-* PARTIAL RESULT NF912 DC *-* NEXT ARG NF913 DC /FFFF *************************************************** NFA10 SRA 16 0 MDX NF060 *************************************************** NFB10 AND NF912 A AND B MDX NF060 *************************************************** NFC10 EOR NF913 (NOT A) AND B MDX NF060 *************************************************** NFD10 LD NF912 B MDX NF060 *************************************************** NFE10 LD NF912 A AND (NOT B) EOR NF913 AND NF911 MDX NF060 *************************************************** NFF10 EQU NF060 A *************************************************** NFG10 EOR NF912 A EOR B MDX NF060 *************************************************** NFH10 OR NF912 A OR B MDX NF060 *************************************************** NFI10 OR NF912 NOT (A OR B) MDX NFK10 *************************************************** NFJ10 EOR NF913 (NOT A) EOR B MDX NFG10 *************************************************** NFK10 EOR NF913 NOT A MDX NF060 *************************************************** NFL10 EOR NF913 (NOT A) OR B MDX NFH10 *************************************************** NFM10 LD NF912 NOT B MDX NFK10 *************************************************** NFN10 EOR NF913 NOT ((NOT A) AND B) NFO10 AND NF912 NOT (A AND B) MDX NFK10 *************************************************** NFP10 LD NF913 1 *************************************************** NFQ10 A NF912 A+B MDX NF060 *************************************************** NFR10 S NF912 A-B MDX NF060 *************************************************** NFS10 M NF912 A*B SLT 16 MDX NF060 *************************************************** NFT10 SRT 16 A/B D NF912 MDX NF060 *************************************************** NFU10 SRT 16 A REMAINDER B D NF912 RTE 16 MDX NF060 *************************************************** NFV10 LDS 0 A MAX B S NF912 BSC O EOR NF913 BSC L NFD10,+Z NFV15 LD NF911 MDX NF060 *************************************************** NFW10 LDS 0 A MIN B S NF912 BSC O EOR NF913 BSC L NFD10,- MDX NFV15 *************************************************** NFX10 SRT 16 D NF912 DIVIDE ACC BY EXT RTE 16 BSC L NFX30,+- BRANCH IF ZERO REMAINDER RTE 16 SAVE REMAINDER LD NF912 GET B RTE 16 STO NF912 MAKE LAST REMAINDER B RTE 16 PUT OLD B IN ACC MDX NFX10 NFX30 LD NF912 RETURN B MDX NF060 *************************************************** * MINUS FUNCTION * *************************************************** DC @LAM+1 MINUS LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #MNUS MNUS5 SRA 16 (ABS BRANCHES HERE) S I @ARG1 GET NEGATIVE OF ARG BSI 3 MKFXN-X BSI 3 POPJ-X *************************************************** * ABS FUNCTION * *************************************************** DC @LAM+1 ABS LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #ABS BSC L MNUS5,+Z IF NEGATIVE, GO NEGATE LD 3 @ARG1-X ELSE RETURN ARG BSI 3 POPJ-X *************************************************** * ZEROP FUNCTION * *************************************************** DC @LAM+1 ZEROP LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #ZERP BSC L ZERP5,Z LD 3 @TRUE-X RETURN T IF ZERO BSI 3 POPJ-X ZERP5 SRA 16 ELSE NIL (MINUSP USES THIS) BSI 3 POPJ-X *************************************************** * MINUSP FUNCTION * *************************************************** DC @LAM+1 MNUSP LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #MNSP BSC L ZERP5,- LD 3 @TRUE-X RETURN T IF NEGATIVE BSI 3 POPJ-X *************************************************** * ADD1 FUNCTION * *************************************************** DC @LAM+1 ADD1 LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #ADD1 S ADD19 ADD ONE BSI 3 MKFXN-X BSI 3 POPJ-X *************************************************** ADD19 DC /FFFF -1 *************************************************** * SUB1 FUNCTION * *************************************************** DC @LAM+1 SUB1 LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #SUB1 A ADD19 SUBTRACT ONE BSI 3 MKFXN-X BSI 3 POPJ-X *************************************************** * LSH FUNCTION * *************************************************** DC @LAM+2 LSH LD 3 @ARG1-X CHECK FIRST ARG BSI 3 XNCHK-X DC #LSH LD 3 @ARG2-X CHECK SECOND ARG BSI 3 XNCHK-X DC #LSH BSC L LSH2,+Z BRANCH IF NEGATIVE AND LSH9 SET UP LEFT SHIFT OR LSH8 MDX LSH4 LSH2 EOR ADD19 NEGATE SECOND ARG S ADD19 AND LSH9 OR LSH7 LSH4 STO LSH5 LD I @ARG1 LSH5 SLA *-* SLA OR SRA GETS PUT HERE BSI 3 MKFXN-X BSI 3 POPJ-X *************************************************** LSH7 SRA 0 LSH8 SLA 0 LSH9 DC /003F *************************************************** * LESSP FUNCTION * *************************************************** DC @LAM+1+@LIST LESSP LD 3 @ARG1-X CHECK FIRST ARG BSI 3 XNCHK-X DC #LESP STO LES99 SAVE IT LD 3 @ARG2-X LES10 BSC L LES20,Z BRANCH UNLESS NO ARGS LEFT LD 3 @TRUE-X RETURN TRUE - ALL TESTS OK BSI 3 POPJ-X LES20 BSI 3 XCAR-X GET NEXT ARG BSI 3 XNCHK-X CHECK IT DC #LESP STO LES98 SAVE IT LD LES99 COMPARE TO LAST LDS 0 S LES98 BSC O EOR *-1 BSC L LES60,- BRANCH IF LAST GE THIS LES30 LD LES98 SAVE THIS ARG TO STO LES99 COMPARE TO NEXT LES50 LD I @ARG2 CHAIN DOWN ARG LIST STO 3 @ARG2-X MDX LES10 LES60 SRA 16 RETURN NIL IF ANY BSI 3 POPJ-X RELATION UNSATISFIED *************************************************** LES97 DC *-* LES98 DC *-* LES99 DC *-* *************************************************** * OR FUNCTION * *************************************************** DC @NLAM+@LIST OR LD 3 @ARG1-X GET LIST OF ARGS BSI 3 PUSHA-X SAVE ON STACK OR2 BSC L OR6,+- BRANCH IF NONE LEFT BSI 3 XCAR-X GET NEXT ARG STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL IT DC EVAL BSC L OR4,Z BRANCH UNLESS NIL LD I1 0 STO 1 0 MDX OR2 OR4 LD 3 @TRUE-X RETURN T OR6 RTE 16 BSI 3 POPA-X POP OFF LIST OF ARGS RTE 16 BSI 3 POPJ-X *************************************************** * AND FUNCTION * *************************************************** DC @NLAM+@LIST AND LD 3 @ARG1-X GET LIST OF ARGS BSI 3 PUSHA-X SAVE ON STACK AND2 BSC L OR4,+- BRANCH IF NONE LEFT BSI 3 XCAR-X GET NEXT ARG STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL IT DC EVAL BSC L OR6,+- BRANCH UNLESS NON-NIL LD I1 0 STO 1 0 MDX AND2 *************************************************** * EXAM FUNCTION * *************************************************** DC @LAM+1 EXAM LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #EXAM STO EXAM3+1 EXAM3 LD L *-* GET WORD AT GIVEN ADR BSI 3 MKFXN-X BSI 3 POPJ-X *************************************************** * DEP FUNCTION * *************************************************** DC @LAM+2 DEP LD 3 @ARG1-X GET ARG 1 BSI 3 XNCHK-X CHECK IT DC #DEP STO DEP3+1 SAVE ADR LD 3 @ARG2-X GET ARG 2 BSI 3 XNCHK-X CHECK IT DC #DEP DEP3 STO L *-* PUT WORD AT GIVEN ADR LD 3 @ARG2-X RETURN ARG 2 BSI 3 POPJ-X *************************************************** * SWITCH FUNCTION * *************************************************** DC @LAM+1 SWTCH LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #SWCH AND SWCH9 TAKE LOW 4 BITS OR SWCH8 CONSTRUCT SHIFT STO SWCH3 XIO SWCH7 READ SWITCHES LD SWCH6 GET SWITCHES SWCH3 SLA *-* PUT PROPER BIT IN BIT 0 BSC L SWCH4,- LD 3 @TRUE-X BSI 3 POPJ-X SWCH4 SRA 16 BSI 3 POPJ-X *************************************************** SWCH6 DC *-* BSS E 0 SWCH7 DC SWCH6 IOCC TO READ DATA SWITCHES DC /3A00 SWCH8 SLA 0 SWCH9 DC /000F *************************************************** * 1442 CARD PUNCH OUTPUT HANDLER * *************************************************** AIF (@PNCH EQ YES),.YES O1442 EQU 0 P1442 EQU 0 AGO .NO .YES AIF (@READ EQ YES),.YES O1442 EQU 0 P1442 EQU 0 AGO .NO .YES ANOP O1442 DC *-* LD L 2 CHECK CHAR S O1499 BSC L O1425,+- BRANCH IF CARRIAGE RETURN LD L2 CRDTB GET CARD CODE CHAR STO I O1498 PUT IN BUFFER MDX L O1498,1 INCR POINTER MDX L O14BF,1 INCR COUNT O1420 BSC I O1442 O1425 BSI L F1442 FLUSH CARD READER INPUT O1427 LIBF CARD0 READ A CARD DC /1000 DC I14BF O1430 LIBF CARD0 WAIT FOR IT DC 0 MDX O1430 LDX 2 72 CHECK FOR BLANK O1435 LD L2 I14BF BSC L O1460,Z BRANCH IF NON-BLANK MDX 2 -1 MDX O1435 LIBF CARD0 SELECT STACKER 2 DC /4000 LD O14BF BSC I O1442,+- RETURN IF NO CHARS TO PUNCH LIBF CARD0 PUNCH A CARD DC /2000 DC O14BF O1445 LIBF CARD0 WAIT FOR IT DC 0 MDX O1445 SRA 16 STO O14BF RESET CHAR COUNT LD O1497 STO O1498 RESET POINTER MDX O1420 O1460 MDX L $IOCT,0 WAIT OUT ALL PENDING MDX O1460 I/O INTERRUPTS LD O1496 PUT /100B FLAG IN ACC BSI L $PRET WAIT FOR OPERATOR MDX O1427 *************************************************** O1496 DC /100B FLAG FOR NON-BLANK WAIT O1497 DC O14BF+1 O1498 DC O14BF+1 O1499 DC @CR-EBCTB *************************************************** O14BF DC 0 1442 CARD OUTPUT BUFFER BSS 72 P1442 DC *-* 1442 CARD PUNCH PAGESKIP LDX 2 -6 P1450 LD L2 P1499+6 OUTPUT '/*/*/',CR BSI L OUTPT (EOF CARD) MDX 2 1 MDX P1450 BSC I P1442 *************************************************** P1499 DC @SLSH / DC @STAR * DC @SLSH / DC @STAR * DC @SLSH / DC @CR CR *************************************************** .NO ANOP *************************************************** * PROG FUNCTION * *************************************************** DC @NLAM+1+@LIST PROG SRA 16 ZERO COUNT OF BINDINGS STO PRG98 LD 3 @ARG1-X STO PRG17 PRG05 BSC L PRG30,+- BRANCH IF NO MORE TO BIND BSI 3 XCAR-X GET NEXT ITEM STO PRG22 S PRG97 BSC L PRG15,+Z BRANCH IF NUMBER OR NIL S PRG96 BSC L PRG15,- BRANCH IF NUMBER A PRG95 STO PRG10+1 PRG10 LD L *-* BSC L PRG15,- BRANCH IF NON-ATOM LD I PRG22 EOR PRG94 BSC L PRG20,Z BRANCH UNLESS STRING PRG15 BSI 3 ERROR-X ERROR IF ANY OF THESE DC 43+@MAJR PRG17 DC *-* PRG20 BSI 3 PUSHS-X PUSH OLD VALUE PRG22 DC *-* SRA 16 BIND ATOM TO NIL VALUE STO I PRG22 MDX L PRG98,-1 INCR NEG COUNT OF BINDINGS NOP LD I @ARG1 CHAIN DOWN VAR LIST STO 3 @ARG1-X MDX PRG05 PRG30 LD PRG98 PUSH NEG COUNT OF BINDINGS BSI 3 PUSHA-X LD 3 @SPDL-X SAVE CURRENT SPEC PDL LEVEL STO PRG98 BSI 3 PUSHS-X PUSH LAST SPEC PDL LEVEL DC PRG99 LD PRG98 PUT THIS LEVEL IN SWITCH STO PRG99 BSI 3 PUSHS-X PUSH REG PDL LEVEL DC 1 LD 3 @ARG2-X SAVE LIST OF FORMS TWICE BSI 3 PUSHA-X ONCE FOR GO SEARCHES BSI 3 PUSHA-X ONCE FOR PROG EVALUATION PRG35 BSC L PRG45,+- BRANCH IF NO FORMS LEFT BSI 3 XCAR-X GET NEXT FORM STO 3 @ARG1-X SAVE AS ARG 1 BSI 3 XATOM-X BSC L PRG40,Z BRANCH IF ATOM BSI 3 PUSHJ-X EVAL FORM DC EVAL PRG40 LD I1 0 CHAIN DOWN LIST OF FORMS STO 1 0 MDX PRG35 PRG45 BSI 3 POPS-X POP REG PDL LEVEL BSI 3 POPS-X POP SPEC PDL LEVEL SW BSI 3 POPN-X POP BINDINGS SRA 16 RETURN NIL BSI 3 POPJ-X *************************************************** PRG94 DC @STR PRG95 DC 1+E@FST PRG96 DC E@FST-S@FST PRG97 DC S@FST PRG98 DC *-* PRG99 DC 0 *************************************************** * GO FUNCTION * *************************************************** DC @NLAM+1 GO LD 3 @ARG1-X GET ARG MDX L PRG99,0 SKIP IF NOT INSIDE PROG MDX GO20 STO GO10 BSI 3 ERROR-X ERROR DC 46+@MAJR GO10 DC *-* GO20 BSI 3 XATOM-X BSC L GO30,Z BRANCH IF ARG IS ATOM BSI 3 PUSHJ-X ELSE EVAL AND TRY AGAIN DC EVAL STO 3 @ARG1-X MDX GO20 GO30 LD PRG99 POP JUNK OFF SPEC PDL S 3 @SPDL-X SRT 1 A GO35 EXCEPT OLD SPEC PDL LEVEL BSI 3 PUSHA-X BSI 3 POPN-X BSI 3 PUSHS-X RE-PUSH REG PDL LEVEL GO35 DC 1 ADR OF XR1 AND CONSTANT 1 MDX 1 -2 RETRIEVE TWO THINGS LD 1 1 SEARCH FOR GO TAG GO40 BSC L GO43,+- BRANCH IF NONE LEFT STO PRG98 BSI 3 XCAR-X EOR 3 @ARG1-X BSC L GO50,+- BRANCH IF MATCH LD I PRG98 ELSE CHAIN DOWN FORMS MDX GO40 GO43 LD 3 @ARG1-X STO GO45 BSI 3 ERROR-X ELSE ERROR DC 44+@MAJR GO45 DC *-* GO50 LD I PRG98 GET REST OF FORMS STO 1 0 SAVE FOR PROG TO DO MDX PRG35 GO HAVE PROG DO THEM *************************************************** * RETURN FUNCTION * *************************************************** DC @LAM+1 RETRN MDX L PRG99,0 SKIP IF NOT INSIDE A PROG MDX RET20 LD 3 @ARG1-X STO RET10 BSI 3 ERROR-X ERROR IF SO DC 45+@MAJR RET10 DC *-* RET20 LD L PRG99 POP JUNK OFF SPEC PDL S 3 @SPDL-X (REG PDL GETS RESTORED) SRT 1 BSI 3 PUSHA-X BSI 3 POPN-X BSI 3 POPN-X POP PROG BINDINGS LD 3 @ARG1-X RETURN ARG BSI 3 POPJ-X *************************************************** * RPLACA/RPLACD FUNCTIONS * *************************************************** DC @LAM+2 RPLCA LD RPLC9 SET UP RPLACA MDX RPLC1 *************************************************** DC @LAM+2 RPLCD SRA 16 SET UP RPLACD RPLC1 STO RPLC8 LD 3 @ARG1-X GET ARG 1 BSC +- SKIP IF NON-NIL LD RPLC7 USE ADR OF NIL IF NIL A RPLC8 GET ADR TO REPLACE STO RPLC3+1 LD 3 @ARG2-X RPLC3 STO L *-* SHOVE SECOND ARG THERE LD 3 @ARG1-X RETURN (ALTERED) ARG 1 BSI 3 POPJ-X *************************************************** RPLC7 DC #NIL RPLC8 DC *-* RPLC9 DC 1 *************************************************** * ASSOC/SASSOC FUNCTIONS * *************************************************** DC @LAM+2 ASSOC SRA 16 SET ARG 3 (FN) TO NIL STO 3 @ARG3-X FOR SASSOC MDX SASOC *************************************************** DC @LAM+3 (LAMBDA (X L FN)... SASOC LD 3 @ARG2-X GET L SASC1 BSC L SASC5,+- BRANCH IF NONE LEFT BSI 3 XCAR-X STO SASC9 SAVE (CAR L) BSI 3 XCAR-X GET (CAAR L) EOR 3 @ARG1-X BSC L SASC3,+- BRANCH IF (EQ X (CAAR L)) LD I @ARG2 ELSE CHAIN DOWN L STO 3 @ARG2-X MDX SASC1 SASC3 LD SASC9 RETURN (CAR L) BSI 3 POPJ-X SASC5 LD 3 @ARG3-X GET FN BSC +- BSI 3 POPJ-X RETURN NIL IF NIL SRT 16 BSI 3 XCONS-X STO 3 @ARG1-X ELSE EVAL AS FUNCTION BSC L EVAL OF NO ARGS *************************************************** SASC9 DC *-* *************************************************** * LENGHT FUNCTION * *************************************************** DC @LAM+1 LNGTH SRA 16 ZERO COUNT STO LNTH9 LD 3 @ARG1-X GET ARG LNTH3 BSC L LNTH6,+- BRANCH IF END STO LNTH4+1 LNTH4 LD L *-* ELSE CHAIN DOWN ONE MDX L LNTH9,1 AND INCR COUNT MDX LNTH3 LNTH6 LD LNTH9 RETURN COUNT BSI 3 MKFXN-X BSI 3 POPJ-X *************************************************** LNTH9 DC *-* *************************************************** * TOPL FUNCTION * *************************************************** DC @LAM+1 TOPL LDX 2 0 SET XR2 TO ZERO LD 3 @ARG1-X BSC L TOPL4,+- BRANCH IF ARG NIL LDX 2 1 SET XR2 TO ONE EOR 3 @TRUE-X BSC L TOPL4,+- BRANCH IF AR IS T LDX 2 2 SET XR2 TO TWO LD 3 @ARG1-X TOPL4 STO L TOPFN SET TOPFN FOR TOP LEVEL STX L2 TOPLV SET TOPLEVEL SW FROM XR2 SRA 16 RETURN NIL BSI 3 POPJ-X *************************************************** * TYP/TEND FUNCTIONS * *************************************************** DC @NLAM TYP LDD TYTN9 GET DEVICE NUMBERS FOR TYP LDX 2 0 SET XR2 TO ZERO MDX TYTN3 *************************************************** DC @NLAM TEND LDD 3 @SYSP-X GET DEVICE NUMBER FOR TEND LDX 2 1 SET XR2 TO ONE TYTN3 STX L2 TOPLV SET TOPLEVEL SW FROM XR2 STO TYTN8 SAVE OUTPUT DEV NUMBER STO 3 @SYSO-X SET DEFAULT DEV NUMBERS RTE 16 BSI 3 MKFXN-X STO L #SYSI SET SYSIN LD TYTN8 BSI 3 MKFXN-X STO L #SYSO SET SYSOUT SRA 16 STO L TOPFN RESET TOPFN BSI 3 POPJ-X RETURN NIL *************************************************** TYTN8 DC *-* BSS E 0 TYTN9 DC 1 TYPEWRITER DEV NUMBER DC 6 KEYBOARD DEV NUMBER *************************************************** * MEMBER FUNCTION * *************************************************** DC @LAM+2 MEMBR LD 3 @ARG1-X SAVE ARG 1 STO MEMB9 LD 3 @ARG2-X SAVE ARG 2 MEMB1 STO MEMB4+1 BSC +- SKIP IF ANY LEFT BSI 3 POPJ-X ELSE RETURN NIL BSI 3 XCAR-X GET NEXT ITEM OF ARG 2 STO 3 @ARG2-X LD MEMB9 STO 3 @ARG1-X BSI 3 PUSHJ-X COMPARE ARG 1 TO ITEM DC EQUAL BSC L MEMB6,Z BRANCH IF EQUAL MEMB4 LD L *-* ELSE CHAIN DOWN ARG 2 MDX MEMB1 MEMB6 LD MEMB4+1 RETURN WHAT'S LEFT OF ARG 2 BSI 3 POPJ-X *************************************************** MEMB9 DC *-* *************************************************** * EQUAL FUNCTION * *************************************************** DC @LAM+2 (LAMBDA (X Y) ... EQUAL LD 3 @ARG1-X COMPARE X AND Y EOR 3 @ARG2-X BSC L EQL15,Z BRANCH UNLESS (EQ X Y) EQL10 LD 3 @TRUE-X RETURN T BSI 3 POPJ-X EQL15 LD 3 @ARG1-X CHECK X BSI 3 XATOM-X BSC L EQL50,+- BRANCH UNLESS (ATOM X) LD 3 @ARG2-X BSI 3 XATOM-X BSC L EQL25,Z BRANCH IF (ATOM Y) EQL20 SRA 16 RETURN NIL BSI L POPJ-X EQL25 LD 3 @ARG1-X BSI 3 XNMBP-X BSC L EQL30,+- BRANCH UNLESS (NUMERBP X) LD 3 @ARG2-X BSI 3 XNMBP-X BSC L EQL20,+- BRANCH UNLESS (NUMBERP Y) LD I @ARG1 COMPARE TWO NUMBERS EOR I @ARG2 BSC L EQL10,+- RETURN T IF SAME VALUE MDX EQL20 ELSE NIL EQL30 LD 3 @ARG1-X BSI 3 XSTRP-X BSC L EQL20,+- BRANCH UNLESS (STRINGP X) LD 3 @ARG2-X BSI 3 XSTRP-X BSC L EQL20,+- BRANCH UNLESS (STRINGP Y) MDX L @ARG1,1 GET PNAME OF ARG 1 MDX L @ARG2,1 GET PNAME OF ARG 2 EQL35 LD I @ARG1 CHAIN DOWN PNAME 1 STO 3 @ARG1-X BSI 3 XCAR-X GET NEXT CHAR STO EQL99 SAVE IT LD I @ARG2 CHAIN DOWN PNAME 2 BSC L EQL20,+- BRANCH IF NONE LEFT STO 3 @ARG2-X BSI 3 XCAR-X GET NEXT CHAR EOR EQL99 COMPARE TO OTHER CHAR BSC L EQL20,Z BRANCH IF UNEQUAL MDX EQL35 ELSE CHECK REST OF CHARS EQL40 LD I @ARG2 CHECK ARG 2 BSC L EQL10,Z BRANCH IF NO CHARS LEFT MDX EQL20 ELSE GO RETURN NIL EQL50 LD 3 @ARG2-X CHECK Y BSI 3 XATOM-X BSC L EQL20,Z BRANCH IF (ATOM Y) LD I @ARG1 SAVE CDR OF EACH ARG BSI 3 PUSHA-X LD I @ARG2 BSI 3 PUSHA-X LD 3 @ARG1-X GET CAR OF EACH ARGS BSI 3 XCAR-X STO 3 @ARG1-X LD 3 @ARG2-X BSI 3 XCAR-X STO 3 @ARG2-X BSI 3 PUSHJ-X COMPARE TWO CARS DC EQUAL BSC L EQL55,Z BRANCH IF EQUAL BSI 3 POPA-X POP TWO CDRS OFF STACK BSI 3 POPA-X MDX EQL20 GO RETURN NIL EQL55 BSI 3 POPA-X POP TWO CDRS STO 3 @ARG2-X BSI 3 POPA-X STO 3 @ARG1-X MDX EQUAL GO COMPARE THEM *************************************************** EQL99 DC *-* *************************************************** * LAST FUNCTION * *************************************************** DC @LAM+1 LAST LD 3 @ARG1-X GET ARG BSC +- BSI 3 POPJ-X RETURN NIL IF NIL LAST3 LD I @ARG1 IS (CDR ARG) NIL BSC L LAST5,Z LD 3 @ARG1-X IF SO, RETURN ARG BSI 3 POPJ-X LAST5 STO 3 @ARG1-X ELSE CHAIN DOWN ARG MDX LAST3 *************************************************** * RANDOM FUNCTION * *************************************************** DC @LAM+1 RANDM LD 3 @ARG1-X GET ARG BSI 3 XNCHK-X CHECK IT DC #RAND BSC L RAN40,Z BRANCH UNLESS ZERO LDD RAN98 DO TWO DISK SEEK OPERATIONS BSI RAN20 LDD RAN96 BSI RAN20 SRA 16 RETURN NIL BSI 3 POPJ-X *************************************************** RAN20 DC *-* BSI L DISKZ DO DISK SEEK LD RAN95 RAN30 A RAN94 WHILE WAITING, KEEP MDX L $DBSY,0 ALTERING SEED (THIS IS A MDX RAN30 FAIRLY RANDOM PROCESS) AND RAN93 AND OUT HIGH BIT OR RAN92 MAKE SURE IT'S ODD STO RAN95 SAVE IT BSC I RAN20 *************************************************** RAN40 LD RAN95 MULTIPLY SEED BY MAGIC M RAN94 NUMBER (899) FOR 1130 SLT 16 POWER-RESIDUE METHOD AND RAN93 AND OUT HIGH BIT STO RAN95 SAVE IT M I @ARG1 TREAT AS A 15-BIT FRACTION SLT 1 AND MULTIPLY BY ARG BSI 3 MKFXN-X RETURN TRSULT AS NUMBER BSI 3 POPJ-X *************************************************** RAN91 DC 899 RAN92 DC 1 RAN93 DC /7FFF RAN94 DC /2895 NUMBER GOT BY COIN FLIPS RAN95 DC *-* BSS E 0 RAN96 DC 0 DC RAN97 RAN97 DC 0 DC 0 RAN98 DC 0 DC RAN99 RAN99 DC 0 DC 8*20 *************************************************** * APPEND FUNCTION * *************************************************** DC @LAM+@LIST APPND LD 3 @ARG1-X GET LIST OF ARGS BSC +- BSI 3 POPJ-X RETURN NIL IF NONE BSI 3 PUSHA-X PUSH LIST OF ARGS BSI 3 PUSHA-X PUSH ROOM FOR FINAL RESULT LD L 1 BSI 3 PUSHA-X PUSH ADR FOR APPENDING APN10 LD I1 2 IS THERE ONLY ONE LIST LEFT BSC L APN20,Z BRANCH IF NOT LD 1 2 BSI 3 XCAR-X ELSE GET IT STO I1 0 APPEND AT END BSI 3 POPA-X POP APPEND ADR BSI 3 POPA-X POP RESULT RTE 16 SAVE IT BSI 3 POPA-X POP LIST OF ARGS RTE 16 GET RESULT AND RETURN BSI 3 POPJ-X APN20 LD 1 2 GET NEXT LIST BSI 3 XCAR-X APN30 BSC L APN40,+- BRANCH IF NONE OF IT LEFT STO APN35+1 ELSE SAVE IT BSI 3 XCAR-X SRT 16 BSI 3 XCONS-X AND COPY IT STO I1 0 APPEND ITEM TO NEW LIST AND STO 1 0 SAVE ADR AS NEW APPEND ADR APN35 LD L *-* CHAIN DOWN LIST MDX APN30 APN40 LD I1 2 CHAIN DOWN LIST OF ARGS STO 1 2 MDX APN10 GO APPEND NEXT ONE *************************************************** * MAP/MAPC/MAPLIST/MAPCAR FUNCTIONS * *************************************************** DC @LAM+1+@LIST MAP LDS 2 SET FOR MAP MDX MAP10 *************************************************** DC @LAM+1+@LIST MAPC LDS 3 SET FOR MAPC MDX MAP10 *************************************************** DC @LAM+1+@LIST MAPLS LDS 0 SET FOR MAPLIST MDX MAP10 *************************************************** DC @LAM+1+@LIST MAPCR LDS 1 SET FOR MAPCAR MAP10 STS MAP20 SAVE STATUS BITS LD MAP20 C = DO NOT SAVE RESULTS STO MAP40 O = TAKE CARS OF LISTS STO MAP45 STO MAP65 LDX 2 0 ZERO COUNT OF ARG LISTS LD 3 @ARG2-X BSC +- BSI 3 POPJ-X RETURN NIL IF NONE MAP15 STO 3 @ARG2-X BSI 3 XCAR-X BSI 3 PUSHA-X ELSE PUSH AND COUNT MDX 2 1 THE ARG LISTS LD I @ARG2 BSC L MAP15,Z LD 3 @ARG1-X SAVE FN BSI 3 PUSHA-X STX 1 MAP35+1 SAVE ADR TO GET FN AND ARGS STX 1 MAP55+1 STX 1 MAP57+1 MAP20 LDS *-* BSC L MAP25,C BRANCH IF MAP/MAPC SRA 16 BSI 3 PUSHA-X PUSH NULL RESULT LIST LD L 1 BSI 3 PUSHA-X PUSH ADR FOR APPENDS MAP25 LD L 2 BSI 3 PUSHA-X PUSH NUMBER OF ARG LISTS MAP30 BSI 3 PUSHA-X PUSH ROOM FOR NEW ARG LIST LD L 1 BSI 3 PUSHA-X PUSH ADR FOR APPENDS LD 1 2 STO L 2 PUT ARG LIST COUNT IN XR2 MAP35 LD L2 *-* GET AN ARG LIST BSC L MAP60,+- BRANCH IF EXHAUSTED MAP40 LDS *-* BSC O SKIP IF MAP/MAPLIST BSI 3 XCAR-X TAKE CAR IF MAPC/MAPCAR SRT 16 BSI 3 XCONS-X STO I1 0 APPEND TO NEW ARG LIST STO 1 0 MDX 2 -1 COUNT LISTS MDX MAP35 BSI 3 POPA-X POP APPEND ADR BSI 3 POPA-X POP NEW ARG LIST STO 3 @ARG2-X LD I MAP35+1 GET FN STO 3 @ARG1-X BSI 3 PUSHJ-X APPLY FN TO ARGS DC APPLY MAP45 LDS *-* SWITCH (ALSO TEMP STORAGE) BSC L MAP50,C BRANCH IF MAP/MAPC SRT 16 BSI 3 XCONS-X STO I1 1 APPEND RESULT TO LIST STO 1 1 MAP50 LD 1 0 STO L 2 PUT ARG LIST COUNT IN XR2 MAP55 LD I2 *-* TAKE CDR OF EACH ARG LIST MAP57 STO L2 *-* MDX 2 -1 MDX MAP55 MDX MAP30 GO MAP NEXT SET OF ARGS MAP60 BSI 3 POPA-X POP APPEND ADR BSI 3 POPA-X POP NEW ARG LIST (UNNEEDED) BSI 3 POPA-X POP ARG LIST COUNT STO L 2 PUT IN XR2 SRA 16 STO MAP45 SET UP NIL RESULT VALUE MAP65 LDS *-* BSC L MAP70,C BRANCH IF MAP/MAPC BSI 3 POPA-X POP APPEND ADR BSI 3 POPA-X POP RESULT LIST STO MAP45 MAKE IT THE RESULT MAP70 BSI 3 POPA-X POP FN MAP73 BSI 3 POPA-X POP ARG LISTS MDX 2 -1 MDX MAP73 LD MAP45 RETURN RESULT BSI 3 POPJ-X *************************************************** * PROG2 FUNCTION * *************************************************** DC @LAM+2+@LIST PROG2 LD 3 @ARG2-X BSI 3 POPJ-X *************************************************** * REVERSE FUNCTION * *************************************************** DC @LAM+1 REVRS SLT 16 SET RESULT IN EXT TO NIL LD 3 @ARG1-X SAVE ARG IN CASE OF GC BSI 3 PUSHA-X RVRS2 BSC L RVRS5,+- BRANCH IF NONE LEFT BSI 3 XCAR-X GET NEXT ITEM OF ARG LIST RTE 16 BSI 3 XCONS-X CONS ONTO HEAD OF NEW LIST RTE 16 LD I1 0 CHAIN DOWN ARG LIST STO 1 0 MDX RVRS2 RVRS5 BSI 3 POPA-X POP ARG OFF STACK RTE 16 GET RESULT FROM EXT BSI 3 POPJ-X *************************************************** * SUBST FUNCTION * *************************************************** DC @LAM+3 SUBST LD 3 @ARG1-X STO SBS99 SAVE ARG 1 LD 3 @ARG2-X STO SBS98 SAVE ARG 2 BSI 3 PUSHJ-X CALL RECURSIVE SUBST-ER DC SBS10 RTE 16 SAVE RESULT IN EXT SRA 16 CLEAR PROTECTED LOCS TO NIL STO SBS98 STO SBS99 RTE 16 RETURN RESULT BSI 3 POPJ-X *************************************************** SBS10 LD 3 @ARG3-X COMPARE ARG 2 AND ARG 3 STO 3 @ARG2-X LD SBS98 STO 3 @ARG1-X BSI 3 PUSHJ-X PUSHJ-X DC EQUAL BSC L SBS20,+- BRANCH IF UNEQUAL LD SBS99 ELSE RETURN ARG 1 BSI 3 POPJ-X SBS20 LD 3 @ARG3-X IS ARG 3 AN ATOM BSI 3 XATOM-X BSC L SBS30,+- BRANCH IF NOT LD 3 @ARG3-X ELSE RETURN ARG 3 BSI 3 POPJ-X SBS30 LD I @ARG3 BSI 3 PUSHA-X SAVE CDR OF ARG 3 LD 3 @ARG3-X BSI 3 XCAR-X GET CAR OF ARG 3 STO 3 @ARG3-X BSI 3 PUSHJ-X SUBST INTO CAR DC SBS10 RTE 16 SAVE RESULT IN EXT LD 1 0 GET CDR STO 3 @ARG3-X RTE 16 STO 1 0 PUT RESULT ON STACK BSI 3 PUSHJ-X SUBST INTO CDR DC SBS10 RTE 16 BSI 3 POPA-X RTE 16 BSI 3 XCONS-X CONS TWO RESULTS BSI 3 POPJ-X *************************************************** SBS98 DC NIL PROTECTED BY TEMLIST SBS99 DC NIL PROTECTED BY TEMLIST *************************************************** * REVSTR FUNCTION * *************************************************** DC @LAM+1 RVSTR LD 3 @ARG1-X GET ARG BSI 3 XSCHK-X CHECK IT DC #RVST STO 3 @ARG1-X BSI 3 PUSHJ-X REVERSE CHAR LIST DC REVRS OR RVST9 MAKE A STRING OF RESULT RTE 16 LD RVST8 BSI 3 XCONS-X BSI 3 POPJ-X *************************************************** RVST9 DC /8000 RVST8 DC @STR *************************************************** * STRLENGTH FUNCTION * *************************************************** DC @LAM+1 SLNTH LD 3 @ARG1-X GET ARG BSI 3 XSCHK-X CHECK FOR STRING DC #SLTH STO 3 @ARG1-X BSC L LNGTH GET LENGTH OF CHAR LIST *************************************************** * PNAME FUNCTION * *************************************************** DC @LAM+1 PNAME LDD I @ARG1 GET TOP NODE OF ARG LD PNAM9 USE STRING VALUE BSI 3 XCONS-X MAKE A STRING BSI 3 POPJ-X *************************************************** PNAM9 DC @STR *************************************************** * GENSYM FUNCTION * *************************************************** DC @LAM+@LIST GNSYM LD 3 @ARG1-X IS THERE AN ARG BSC L GNS20,+- BRANCH IF NOT BSI 3 XCAR-X IF SO, GET IT BSI 3 XSCHK-X CHECK IT (SHOULD BE STRING) DC #GNSM BSC L GNS20,+- BRANCH IF NULL STRING STO 3 @ARG1-X BSI 3 PUSHJ-X REVERSE LIST OF CHARS DC REVRS STO GNS99 SAVE LIST OF CHARS MDX GNS40 GNS20 LD GNS99 GET LIST OF CHARS GNS25 BSC L GNS40,+- BRANCH IF NONE LEFT STO GNS30+1 GNS30 LDD L *-* GET FIRST NODE RTE 16 S GNS98 IS CHAR A NUMBER BSC L GNS40,+Z BRANCH IF NOT A GNS97 INCREMENT IT RTE 16 STD I GNS30+1 PUT IT BACK IN LIST RTE 16 S GNS96 IS IT NOW OVER 9 BSC L GNS40,+ BRANCH IF NOT LD GNS98 ELSE RESET TO 0 RTE 16 STD I GNS30+1 MDX GNS25 NOW GO INCR NEXT ONE GNS40 LD GNS99 GET LIST OF CHARS STO 3 @ARG1-X BSI 3 PUSHJ-X REVERSE IT DC REVRS OR GNS95 MAKE IT AN ATOM LD GNS94 VALUE IS UNDEFINED BSI 3 XCONS-X BSC L INTRN INTERN THE ATOM *************************************************** GNS94 DC @UNDF GNS95 DC /8000 GNS96 DC @9 GNS97 DC @1 EQUALS @0+1 GNS98 DC @0 GNS99 DC $GNSM PROTECTED BY TEMLIST *************************************************** * FLATSIZE/FLATC/PRIN1STR/PRINCSTR FUNCTIONS * *************************************************** DC @LAM+1 FLTSZ LD FLT99 SET UP FOR FLATSIZE LDS 0 MDX FLT10 *************************************************** DC @LAM+1 FLATC LD FLT99 SET UP FOR FLATC LDS 1 MDX FLT10 *************************************************** DC @LAM+1 PRN1S LD FLT98 SET UP FOR PRIN1STR LDS 0 MDX FLT10 *************************************************** DC @LAM+1 PRNCS LD FLT98 SET UP FOR PRINCSTR LDS 1 FLT10 STO L OUTSB SET OUTSB FOR I/O HANDLER SRA 16 STO L OUTDV SET DEVICE NUMBER TO 0 STO FLT94 ZERO FLATSIZE/FLATC COUNT BSC O SKIP IF FLATSIZE/PRIN1STR LD *-1 ELSE SET ACC NON-ZERO STO L AMPSW SET AMPSW SRA 16 BSI 3 PUSHA-X PUSH NULL CHAR LIST STX 1 FLT65+1 SAVE ADR FOR APPENDS STX L OUTCH SET OUTCH POSITIVE LD 3 @ARG1-X 'PRINT' EXPRESSION ONTO BSI 3 PUSHJ-X 'DEVICE 0' I/O HANDLER DC PREXP BSI 3 POPA-X POP CHAR LIST OR FLT92 OR IN ATOM MARK STO FLT97 SAVE IT LD L OUTSB EOR FLT99 BSC L FLT30,Z BRANCH IF PRIN1STR/PRINCSTR LD FLT94 RETURN COUNT OF CHARS BSI 3 MKFXN-X BSI 3 POPJ-X FLT30 LDD FLT96 RETURN STRING OF CHARS BSI 3 XCONS-X BSI 3 POPJ-X *************************************************** FLT92 DC /8000 FLT93 DC EBCTB FLT94 DC *-* BSS E 0 FLT96 DC @STR FLT97 DC *-* FLT98 DC FLT60 FLT99 DC FLT50 *************************************************** FLT50 DC *-* FLATSIZE/FLATC MDX L FLT94,1 INCR CHAR COUNT NOP STX L OUTCH SET OUTCH POSITIVE BSC I FLT50 *************************************************** FLT60 DC *-* PRIN1STR/PRINCSTR LD L 2 GET ADR OF CHAR A FLT93 SRT 16 LDX L3 X XR3 MUST BE SET FOR THIS BSI 3 XCONS-X APPEND TO LIST FLT65 STO L *-* STO FLT65+1 STX L OUTCH SET OUTCH POSITIVE BSC I FLT60 *************************************************** * DEFINEDP FUNCTION * *************************************************** DC @LAM+1 DEFNP LD 3 @ARG1-X CHECK ARG S DEFP9 BSC L DEFP4,+Z BRANCH IF NUMBER OR NIL S DEFP8 BSC L DEFP4,- BRANCH IF NUMBER A DEFP7 STO DEFP2+1 DEFP2 LD L *-* BSC L DEFP4,- BRANCH UNLESS ATOM LD I @ARG1 S DEFP6 BSC L DEFP4,Z BRANCH UNLESS UNDEFINED SRA 16 RETURN NIL BSI 3 POPJ-X DEFP4 LD 3 @TRUE-X RETURN T BSI 3 POPJ-X *************************************************** DEFP6 DC @UNDF DEFP7 DC 1+E@FST DEFP8 DC E@FST-S@FST DEFP9 DC S@FST *************************************************** * CATENATE FUNCTION * *************************************************** DC @LAM+@LIST CATN SRA 16 BSI 3 PUSHA-X PUSH NULL LIST OF LISTS STX 1 CATN4+1 SAVE ADR FOR APPENDS LD 3 @ARG1-X BSI 3 PUSHA-X SAVE LIST OF ARGS CATN2 BSC L CATN6,+- BRANCH IF NONE LEFT BSI 3 XCAR-X GET NEXT ARG BSI 3 XSCHK-X CHECK IT DC #CATN SRT 16 BSI 3 XCONS-X APPEND CHAR LIST TO CATN4 STO L *-* LIST OF LISTS STO CATN4+1 LD I1 0 CHAIN DOWN LIST OF ARGS STO 1 0 MDX CATN2 CATN6 BSI 3 POPA-X POP LIST OF ARGS BSI 3 POPA-X POP LIST OF CHAR LISTS STO 3 @ARG1-X BSI 3 PUSHJ-X APPEND THEM ALL DC APPND OR CATN9 MAKE STRING OF RESULT RTE 16 LD CATN8 BSI 3 XCONS-X BSI 3 POPJ-X *************************************************** CATN8 DC @STR CATN9 DC /8000 *************************************************** * REMOB FUNCTION * *************************************************** DC @NLAM+1 REMOB LD REMO9 GET ADR OF OBLIST REMO2 STO REMO4+1 LD I REMO4+1 GET NEXT ITEM DOWN BSC L REMO6,+- BRANCH IF NONE LEFT BSI 3 XCAR-X ELSE COMPARE EOR 3 @ARG1-X IT TO ARG BSC L REMO4,+- BRANCH IF THE SAME LD I REMO4+1 ELSE CHAIN DOWN OBLIST MDX REMO2 REMO4 LD I *-* REMOVE ATOM FROM OBLIST STO I REMO4+1 REMO6 SRA 16 RETURN NIL BSI 3 POPJ-X *************************************************** REMO9 DC #OBLS *************************************************** * SUBSTR FUNCTION * *************************************************** DC @LAM+2+@LIST SBSTR LD 3 @ARG1-X GET FIRST ARG BSI 3 XSCHK-X CHECK IT DC #SSTR BSC L SST27,+- BRANCH IF NULL STRING SST10 STO SST99 SAVE CHAR LIST LD 3 @ARG2-X BSI 3 XNCHK-X CHECK SECOND ARG DC #SSTR BSC + LD SST98 USE 1 IF NON-POSITIVE STO SST97 SST15 MDX L SST97,-1 COUNT DOWN ARG 2 BSC +-Z MDX SST20 BRANCH IF DONE LD I SST99 CHOP ONE CHAR OFF STRING BSC L SST27,+- BRANCH IF NONE LEFT STO SST99 MDX SST15 SST20 LD 3 @ARG3-X CHECK FOR THIRD ARG BSC L SST30,Z BRANCH UNLESS NONE LD SST99 SST27 OR SST96 MAKE A STRING AND RETURN RTE 16 LD SST95 BSI 3 XCONS-X BSI 3 POPJ-X SST30 BSI 3 XCAR-X GET THIRD ARG BSI 3 XNCHK-X CHECK IT DC #SSTR BSC L SST35,-Z BRANCH IF POSITIVE SRA 16 ELSE RETURN NULL STRING MDX SST27 SST35 STO SST97 SAVE ARG 3 LD SST99 BSI 3 PUSHA-X SAVE ROOM FOR CHAR LIST STX 1 SST99 SAVE ADR FOR APPENDING BSI 3 PUSHA-X SAVE LIST OF CHARS SST40 LD 1 0 BSI 3 XCAR-X GET A CHAR SRT 16 BSI 3 XCONS-X STO I SST99 APPEND TO NEW LIST STO SST99 LD I1 0 CHAIN DOWN LIST OF CHARS BSC L SST50,+- BRANCH IF NO MORE LEFT STO 1 0 MDX L SST97,-1 SKIP IF ARG 3 COUNTED OUT MDX SST40 SST50 BSI 3 POPA-X POP OLD CHAR LIST BSI 3 POPA-X POP NEW CHAR LIST MDX SST27 GO MAKE A STRING *************************************************** SST95 DC @STR SST96 DC /8000 SST97 DC *-* SST98 DC 1 SST99 DC *-* *************************************************** * STRINDEX FUNCTION * *************************************************** DC @LAM+2 SINDX LD 3 @ARG1-X BSI 3 XSCHK-X CHECK ARG 1 DC #SIDX BSC L SID45,+- BRANCH IF NULL STRING STO SID99 SAVE CHAR LIST LD 3 @ARG2-X BSI 3 XSCHK-X CHECK ARG 2 DC #SIDX BSC L SID10,Z BRANCH UNLESS NULL STRING LD SID97 RETURN 1 MDX SID45 SID10 STO SID15+1 SAVE CHAR LIST BSI 3 XCAR-X GET FIRST CHAR OF ARG 2 STO SID96 SAVE IT SID15 LD L *-* GET REST OF ARG 2 CHARS STO SID98 SAVE THEM SRA 16 STO SID95 ZERO INDEX COUNT LD SID99 SID20 MDX L SID95,1 INCR INDEX COUNT BSI 3 XCAR-X GET NEXT CHAR OF ARG 1 EOR SID96 COMPARE TO CHAR 1 OF ARG 2 BSC L SID40,Z BRANCH UNLESS EQUAL LD SID98 COMPARE REST OF ARG 2... BSC L SID50,+- BRANCH IF ARG 2 WAS 1 CHAR STO SID94 LD I SID99 SID30 BSC L SID45,+- BRANCH IF ARG 1 NOW SHORT STO SID93 ELSE SAVE REST BSI 3 XCAR-X STO SID92 SAVE NEXT CHAR LD SID94 BSI 3 XCAR-X GET NEXT CHAR OF ARG 2 EOR SID92 BSC L SID40,Z BRANCH UNLESS CHARS EQUAL LD I SID94 CHAIN DOWN ARG 2 BSC L SID50,+- BRANCH IF NONE LEFT STO SID94 LD I SID93 CHAIN DOWN ARG 1 CHARS MDX SID30 SID40 LD I SID99 CHAIN DOWN ARG 1 STO SID99 BSC L SID20,Z BRANCH UNLESS NONE LEFT SID45 BSI 3 MKFXN-X MAKE A NUMBER AND RETURN BSI 3 POPJ-X SID50 LD SID95 RETURN STRING POSITION MDX SID45 *************************************************** SID92 DC *-* SID93 DC *-* SID94 DC *-* SID95 DC *-* SID96 DC *-* SID97 DC 1 SID98 DC *-* SID99 DC *-* *************************************************** * PAUSE FUNCTION * *************************************************** DC @NLAM PAUSE MDX L $IOCT,0 WAIT OUT ALL PENDING MDX PAUSE I/O INTERRUPTS LDD PAUS9 PUT PRETTY BITS IN ACC AND BSI L $PRET EXT LIGHTS AND WAIT SRA 16 RETURN NIL BSI 3 POPJ-X *************************************************** BSS E 0 PAUS9 DC /AAAA DC /5555 *************************************************** * QUIT FUNCTION * *************************************************** DC @NLAM QUIT BSI 3 ERROR-X PRINT SIGN-OFF MESSAGE DC 48+@INFO EXIT *************************************************** * REMOVE FUNCTION * *************************************************** DC @LAM+3 REMOV LD 3 @ARG3-X BSI 3 XNCHK-X CHECK ARG 3 DC #RMOV BSC L RMV10,-Z BRANCH IF POSITIVE LD 3 @ARG2-X ELSE RETURN ARG 2 BSI 3 POPJ-X RMV10 STO RMV99 SAVE ARG 3 LD 3 @ARG2-X GET ARG 2 BSI 3 PUSHA-X SAVE ROOM FOR NEW LIST STX 1 RMV30+1 SAVE ADR FOR APPENDS BSI 3 PUSHA-X SAVE ARG 2 LD 3 @ARG1-X BSI 3 PUSHA-X SAVE ARG 1 LD 1 1 RMV20 BSC L RMV50,+- BRANCH IF ARG 2 DONE BSI 3 XCAR-X ELSE GET NEXT ITEM STO RMV98+1 STO 3 @ARG2-X LD 1 0 STO 3 @ARG1-X BSI 3 PUSHJ-X COMPARE TO ARG 1 DC EQUAL BSC L RMV40,Z BRANCH UNLESS UNEQUAL LDD RMV98 BSI 3 XCONS-X APPEND ITEM TO NEW LIST RMV30 STO L *-* STO RMV30+1 RMV35 LD I1 1 CHAIN DOWN ARG 2 STO 1 1 MDX RMV20 RMV40 MDX L RMV99,-1 DECR COUNT FOR REMOVALS MDX RMV35 IF NOT ZERO TRY AGAIN LD I1 1 ELSE SIMPY APPEND REST STO I RMV30+1 OF ARG 2 TO NEW LIST RMV50 BSI 3 POPA-X POP ARG 1 BSI 3 POPA-X POP ARG 2 BSI 3 POPA-X POP RESULT BSI 3 POPJ-X *************************************************** BSS E 0 RMV98 DC NIL DC *-* RMV99 DC *-* *************************************************** * EXPT FUNCTION * *************************************************** DC @LAM+2 EXPT LD 3 @ARG2-X BSI 3 XNCHK-X CHECK ARG 2 DC #EXPT STO 3 @ARG2-X SAVE IT LD 3 @ARG1-X BSI 3 XNCHK-X CHECK ARG 1 DC #EXPT BSC L EXP70,+- RESULT 0 IF BASE=0 S EXP99 BSC L EXP20,+- RESULT 1 IF BASE=1 A EXP98 BSC L EXP40,Z BRANCH UNLESS BASE =-1 LD 3 @ARG2-X BSC L EXP30,E BRANCH IF ODD EXPONENT EXP20 LD EXP99 RETURN 1 MDX EXP70 EXP30 LD EXP98 RETURN -1 MDX EXP70 EXP40 LD 3 @ARG2-X CHECK EXPONENT BSC L EXP50,- SRA 16 RETURN 0 IF NEGATIVE MDX EXP70 EXP50 BSC L EXP20,+ RETURN 1 IF ZERO LD EXP99 PUT 1 IN ACC EXP60 M I @ARG1 MULTIPLY BY BASE RTE 16 MDX L @ARG2,-1 DO IT 'EXPONENT' TIMES MDX EXP60 EXP70 BSI 3 MKFXN-X MAKE A NUMBER AND RETURN BSI 3 POPJ-X *************************************************** EXP97 DC -1 EXP98 DC 2 EXP99 DC 1 *************************************************** * READSTR FUNCTION * *************************************************** DC @LAM+1 RDSTR LD 3 @ARG1-X BSI 3 XSCHK-X CHECK ARG DC #RDST BSI 3 PUSHA-X SAVE CHAR LIST ON STACK STO RDS55 AND IN OTHER PLACES STO RDS65+1 STO RDS75 SRA 16 STO L INPKC CLEAR DEVICE 0 PEEK CHAR STO L INDEV SET INPUT DEV NUMBER TO 0 BSI 3 PUSHJ-X READ FROM 'DEVICE 0' DC RD005 RTE 16 SAVE RESULT BSI 3 POPA-X POP CHAR LIST RTE 16 RETURN RESULT FROM READ BSI 3 POPJ-X *************************************************** RDS50 DC *-* LDX L3 X XR3 MUST BE SET FOR THIS LD RDS65+1 ARE THERE ANY CHARS LEFT BSC L RDS60,Z BRANCH IF SO BSI 3 ERROR-X ELSE ERROR DC 49+@MAJR RDS55 DC *-* RDS60 BSI 3 XCAR-X GET NEXT CHAR RTE 16 RDS65 LD L *-* CHAIN DOWN CHAR LIST STO RDS65+1 RTE 16 RETURN CHAR BSC I RDS50 *************************************************** RDS70 DC *-* BSI 3 ERROR-X READ MUST HAVE CAUSED AN DC 50+@MAJR ERROR - KICK IN ANOTHER RDS75 DC *-* TWO CENTS' WORTH *************************************************** * SUBLIS FUNCTION * *************************************************** DC @LAM+2 SBLIS LD 3 @ARG1-X SAVE ARG 1 IN CASE OF GC STO SBL99 BSI 3 PUSHJ-X CALL RECURSIVE SUBLIS-ER DC SBL10 SRA 16 CLEAR PROTECTED STO SBL99 LOC TO NIL RTE 16 RETURN RESULT BSI 3 POPJ-X *************************************************** SBL10 LD 3 @ARG2-X CHECK ARG 2 BSI 3 XATOM-X BSC L SBL40,+- BRANCH UNLESS ATOM LD SBL99 SEARCH ARG 1 SBL20 BSC L SBL35,+- BRANCH IF NONE LEFT STO SBL98 BSI 3 XCAR-X GET CAR OF ARG 1 STO SBL25+1 BSI 3 XCAR-X GET CAAR OF ARG 1 EOR 3 @ARG2-X COMPARE TO ARG 2 BSC L SBL30,Z BRANCH UNLESS EQUAL SBL25 LD L *-* RETURN CDAR OF ARG 1 SBL27 RTE 16 LD *-1 NON-ZERO ACC MEANS CHANGE BSI 3 POPJ-X SBL30 LD I SBL98 CHAIN DOWN ARG 1 MDX SBL20 SBL33 BSI 3 POPA-X SBL35 LD 3 @ARG2-X RETURN ARG 2 RTE 16 SRA 16 BSI 3 POPJ-X ZERO ACC MEANS NO CHANGE SBL40 LD 3 @ARG2-X BSI 3 XCAR-X BSI 3 PUSHA-X SAVE CAR OF ARG 2 LD I @ARG2 STO 3 @ARG2-X GET CDR OF ARG 2 BSI 3 PUSHJ-X SUBLIS IT DC SBL10 STO SBL98 SAVE FLAG LD 1 0 GET CAR OF ARG 2 STO 3 @ARG2-X RTE 16 STO 1 0 SAVE SUBLIS RESULT LD SBL98 BSI 3 PUSHA-X SAVE FLAG BSI 3 PUSHJ-X SUBLIS THE CAR DC SBL10 STO SBL98 SAVE FLAG BSI 3 POPA-X GET FLAG FROM CDR OR SBL98 DID EITHER CHANGE BSC L SBL33,+- BRANCH IF NOT BSI 3 POPA-X POP SUBLIS OF CDR BSI 3 XCONS-X CONS THE SUBLIS RESULTS MDX SBL27 *************************************************** SBL98 DC *-* SBL99 DC NIL PROTECTED BY TEMLIST *************************************************** * PGSKP FUNCTION * *************************************************** DC @LAM+1 PGSKP BSI L STOUT SET OUTPUT DEVICE DC #PSKP LD PSKP9 BSI L OUTPT OUTPUT CARRIAGE RETURN LDX I2 OUTDV LDX I3 $XR3X BSI I2 OPSKP CALL PAGESKIP SUBROUTINE LDX L3 X LD 3 @ARG1-X RETURN ARG (DEV NUMBER) BSI 3 POPJ-X *************************************************** PSKP9 DC @CR *************************************************** * LET/FLET FILE NAME LOOKUP ROUTINE * *************************************************** *************************************************** AIF (@IDSK EQ YES),.YES AIF (@ODSK EQ NO),.NO .YES ANOP LTFLT DC *-* STX L2 LT270+1 SAVE XR2 LD I LTFLT GET FN NAME STO LT010 STO LT060 MDX L LTFLT,1 LD 3 @ARG2-X GET ARG 2 BSC L LT020,+- ASSUME 0 IF NONE BSI 3 XCAR-X BSI 3 XNCHK-X ELSE CHECK FOR NUMBER LT010 DC *-* LT020 STO LT040 STO LT130 STO LT250 STO L LT300 SLA 12 SAVE IN SHIFTED FORM STO 3 @ARG2-X LDX I2 LT040 PUT DRIVE NUMBER IN XR2 BSC L LT030,+Z BAD IF NEGATIVE S LT901 BSC L LT030,- BAD IF GREATER THAN 4 LD L2 $ULET GET DISK ADR OF LET BSC L LT050,Z BAD IF NONE ON CURRENT JOB LT030 BSI 3 ERROR-X ERROR - LOGICAL DRIVE DC 59+@MAJR NOT ON CURRENT JOB LT040 DC *-* LT050 SLT 32 STO LT902 CLEAR FILE NAME WORK AREA LD 3 @ARG1-X GET ARG 1 STO LT090 STO LT120 STO LT240 STO LT290 BSI 3 XSCHK-X CHECK FOR STRING LT060 DC *-* LDX 2 25 LT070 BSC L LT100,+- DONE IF NO CHARS LEFT STO LT080+1 SAVE CHARS BSI 3 XCAR-X BSI 3 XCDR-X GET EBCDIC TABLE ENTRY AND LT903 TRUNCATE EBCDIC TO 6 BITS SRT 24 SLT 2 POSITION FOR NEXT CHAR SRT 1 AD LT902 PUT INTO NAME CODE STO LT902 LT080 LD L *-* CHAIN DOWN LIST OF ADRS MDX 2 -6 MDX LT070 BSC L LT100,+- BRANCH UNLESS MORE THAN 5 BSI 3 ERROR-X PRINT WARNING - USE FIRST 5 DC 55+@MINR LT090 DC *-* LT100 LDX I2 LT040 PUT DRIVE NUMBER IN XR2 LD LT902 CHECK FILE NAME OR LT902+1 BSC L LT200,Z BRANCH UNLESS NULL/BLANK LD L2 $FPAD USE WORKING STORAGE AND LT904 COMPUTE ITS LENGTH STO LT902 LD LT905 S LT902 BSC L LT140,-Z ERROR IF NOT EVEN 1 SECTOR LT110 BSI 3 ERROR-X DC 60+@MAJR LT120 DC *-* LT130 DC *-* LT140 RTE 16 PUT LENGTH IN EXT LD L2 $FPAD GET DISK ADR IN ACC MDX LT270 *************************************************** LT901 DC /5000 LT902 BSS E 2 LT903 DC /3F00 LT904 DC /0FFF LT905 DC 8*200 *************************************************** LT200 SRA 16 CLEAR CUMULATIVE STO LT910 DISK BLOCK COUNT LD L2 $ULET GET DISK ADR OF LET LT210 OR 3 @ARG2-X OR IN DRIVE CODE STO L DSKBF+1 SAVE IN DISK BUFFER LDD LT911 READ A SECTOR OF LET/FLET BSI L DISKZ LT220 MDX L $DBSY,0 MDX LT220 LD LT912 GET 3 TIMES NUMBER OF S L DSKBF+5 ENTRIES IN THIS LET/FLET STO LT913 SECTOR AND SAVE LDX L2 -315 LT230 LD L2 DSKBF+323 GET NAME FROM NEXT ENTRY RTE 16 LD L2 DSKBF+322 SD LT902 COMPARE TO REQUESTED NAME SLT 2 BSC +- RTE 16 BSC L LT280,Z BRANCH IF DIFFERENT LD L2 DSKBF+322 CHECK TYPE CODE SRT 14 BSC L LT260,+ZE BRANCH UNLESS NOT DATA FILE BSI 3 ERROR-X DC 54+@MAJR LT240 DC *-* LT250 DC *-* LT260 LD L2 DSKBF+324 GET DISK BLOCK COUNT SRA 4 CONVERT TO SECTOR COUNT BSC L LT110,+ ERROR IF LESS THAN 1 RTE 16 LD LT910 COMPUTE SECTOR ADDRESS SRA 4 A L DSKBF+3 OR 3 @ARG2-X OR IN DRIVE CODE LT270 LDX L2 *-* RESTORE XR2 BSC I LTFLT RETURN LT280 LD LT910 INCREMENT CUMULATIVE A L2 DSKBF+324 DISK BLOCK COUNT OF STO LT910 ENTRIES ALREADY SEEN MDX 2 3 NOP MDX L LT913,-3 SKIP IF ALL ENTRIES SEEN MDX LT230 ELSE GO LOOG AT NEXT ONE LD L DSKBF+6 GET LET/FLET CHAIN ADR BSC L LT310,Z BRANCH UNLESS NO MORE BSI 3 ERROR-X FILE NAME NOT IN LET/FLET DC 53+@MAJR LT290 DC *-* LT300 DC *-* LT310 OR 3 @ARG2-X OR IN DRIVE CODE S L DSKBF+1 COMPARE SECTOR ADRS BSC L LT320,- BRANCH UNLESS NEXT IF FLET SRA 16 START OF FLET - CLEAR STO LT910 CUMULATIVE DB COUNT LT320 LD L DSKBF+6 GET CHAIN ADR AGAIN MDX LT210 GO GET NEXT LET/FLET SECTOR *************************************************** LT910 DC *-* BSS E 0 LT911 DC 0 DC DSKBF LT912 DC 315 LT913 DC *-* *************************************************** .NO ANOP *************************************************** * DISK FILE INPUT DEVICE HANDLER * *************************************************** AIF (@IDSK EQ YES),.YES IDISK EQU 0 FDISK EQU 0 AGO .NO .YES ANOP IDISK DC *-* MDX L IDKBF+1,0 SKIP IF NO INPUT FILE OPEN MDX ID010 LDX I1 INPT5+1 RESTORE XR1 LDX L3 X RESTORE XR3 BSI 3 ERROR-X ERROR - NO INPUT FILE DC 51+@MAJR ID010 MDX L ID901,0 SKIP UNLESS FLUSH REQUESTED MDX ID100 GO FLUSH MDX L ID902,0 SKIP IF NO CHARS LEFT MDX ID030 ID015 BSI ID200 GET RECORD, SKIP IF EOF MDX ID020 MDX L REDSW,0 SKIP IF IN MIDDLE OF READ MDX ID010 ELSE GO TRY AGAIN BSC L RDEOF GO HANDLE READ EOF ERROR ID020 STO ID040+1 SAVE POINTER TO RECORD LD ID904 STO ID902 SET CHAR COUNT ID030 LD ID040+1 GET POINTER EOR ID905 FLIP BIT 0 BSC +Z SKIP IF BIT 0 IS NOW 0 A ID906 ELSE INCR POINTER STO ID040+1 SLA 1 PUT BIT 0 IN CARRY ID040 LD L *-* GET CHAR IN RIGHT-HAND BSC C HALF OF ACC SRA 8 AND ID907 STO ID903 SAVE EBCDIC CHAR LDX 2 -L@EBC SEARCH TABLE ID050 LD L2 EBCTB+L@EBC SRA 8 EOR ID903 BSC L ID060,+- MDX 2 1 MDX ID050 LDX 2 -L@EBC USE BLANK IF NOT FOUND ID060 LD L 2 CALCULATE ADR A ID050+1 MDX L ID902,-1 DECR CHAR COUNT NOP BSC I IDISK RETURN ID100 SRA 16 STO ID901 CLEAR FLUSH SWITCH ID110 BSI ID200 READ CARD, SKIP IF EOF MDX ID110 IF NOT, TRY AGAIN MDX ID015 IF SO, TRY TO READ CHAR *************************************************** ID901 DC 0 NON-ZERO = FLUSH REQUEST ID902 DC *-* ID903 DC *-* ID904 DC 72 ID905 DC /8000 ID906 DC 1 ID907 DC /00FF *************************************************** ID200 DC *-* MDX L ID940,0 SKIP IF NO RECORD LEFT MDX ID240 MDX L ID941,0 SKIP IF NO SECTOR LEFT MDX ID220 ID205 LD L IDKBF+1 GET LOGICAL DRIVE NUMBER SRA 12 STO ID210 SRA 4 STO L IDKBF+1 CLEAR SECTOR ADR IN BUFFER STO L IDKBF+1 LDX I1 INPT5+1 RESTORE XR1 LDX L3 X RESTORE XR3 BSI 3 ERROR-X ERROR - FILE EXHAUSTED DC 56+@MAJR ID210 DC *-* ID220 LDD ID942 BSI L DISKZ READ NEXT SECTOR ID230 MDX L $DBSY,0 MDX ID230 MDX L IDKBF+1,1 INCR SECTOR ADR MDX L ID941,-1 DECR SECTOR COUNT NOP LD ID943 SET RECORD COUNT STO ID940 LD ID944 SET RECORD POINTER STO ID945 ID240 MDX L ID945,40 INCR RECORD POINTER MDX L ID940,-1 DECR RECORD COUNT NOP LD ID945 A ID906 STO ID250+1 A ID946 STO ID260+1 ID250 LDD L *-* GET FIRST FOUR CHARS SD ID947 BSC +- RTE 16 BSC L ID280,Z BRANCH UNLESS /*/* ID260 LD L *-* GET FIFTH CHAR EOR ID947 SRA 8 BSC L ID270,Z BRANCH UNLESS / MDX L ID200,1 INCR RETURN ADR FOR EOF ID270 LD ID945 RETURN RECORD POINTER BSC I ID200 ID280 LDD I ID250+1 GET FIRST FOUR CHARS SD ID948 BSC +- RTE 16 BSC L ID905,+- BRANCH IF ALL 0-8-2 PUNCHES MDX ID270 ELSE GO RETURN *************************************************** ID940 DC 0 ZERO = NO RECORD LEFT ID941 DC 0 ZERO = NO SECTOR LEFT BSS E 0 ID942 DC 0 DC IDKBF ID943 DC 8 ID944 DC IDKBF+1-40 ID945 DC *-* ID946 DC 2 BSS E 0 ID947 EBC ./*/*. ID948 EBC .. FOUR 0-8-2 PUNCHES *************************************************** FDISK DC *-* STX ID901 SET FLUSH SWITCH BSC I FDISK *************************************************** * INDISK FUNCTION * *************************************************** DC @LAM+1+@LIST INDSK BSI L LTFLT LOOK UP FILE IN LET/FLET DC #IDSK STO IDKBF+1 SAVE DISK ADR RTE 16 STO ID941 SAVE SECTOR COUNT SRA 16 STO ID940 CLEAR RECORD COUNT STO ID902 CLEAR CHAR COUNT STO ID901 CLEAR FLUSH SWITCH BSI 3 POPJ-X *************************************************** BSS E 0 IDKBF DC 320 DC 0 ZERO = NO FILE OPENED BSS E 320 *************************************************** .NO ANOP THIS IS AN IMPORTANT CARD ABE LIST HDNG 101 FIXED-POINT NUMBER SPACE *************************************************** * FXS - FIXED-POINT NUMBER SPACE * *************************************************** S@FXB BSS 16 BIT TABLE FOR FXS GC E@FXB EQU * L@FXB EQU E@FXB-S@FXB S@FXS EQU * FIXED-POINT NUMBER SPACE *************************************************** * FIXED-POINT NUMBERS * *************************************************** $SYSR DC @ISTD SYSREAD VALUE $SYSP DC @OSTD SYSPRINT VALUE $SYSH DC @PSTD SYSPUNCH VALUE $SYSI DC @ISTD SYSIN VALUE $SYSO DC @OSTD SYSOUT VALUE *************************************************** S@FXF BSS 16*L@FXB-*+S@FXS E@FXS EQU * L@FXS EQU E@FXS-S@FXS L@FXF EQU E@FXS-S@FXF LIST HDNG 102 FREE STORAGE (START) *************************************************** * FST - FREE STORAGE SPACE * *************************************************** S@FST BSS E 0 FREE STORAGE SPACE *************************************************** @UNDF EQU 1 MARKER FOR UNDEFINED VALUE @STR EQU 2 MARKER FOR CHARACTER STRING @LAM EQU /0000 FUNCTION @NLAM EQU /4000 TYPE @MLAM EQU /8000 INDICATORS @LIST EQU /2000 1 MORE ARG FOR LIST @ATOM EQU /8000 BIT 0 IN CAR MARKS AN ATOM *************************************************** * LIST OF ALL ATOMS (OBLIST) * *************************************************** $OBLS BSS E 0 #@CR ATOM1 #@CR,CR #ABS SUBR3 ABS,A,B,S #ADD1 SUBR4 ADD1,A,D,D,1 #AND SUBR3 AND,A,N,D #APND SUBR6 APPND,A,P,P,E,N,D #APPL SUBR5 APPLY,A,P,P,L,Y #ASOC SUBR5 ASSOC,A,S,S,O,C #ATOM SUBR4 ATOM,A,T,O,M #BOOL SUBR5 BOOLE,B,O,O,L,E #C@R ATOM3 @UNDF,C,DASH,R #CAR SUBR3 CAR,C,A,R #CATN SUBR8 CATN,C,A,T,E,N,A,T,E #CDR SUBR3 CDR,C,D,R #CHRC SUBR5 CHRCT,C,H,R,C,T #COND SUBR4 COND,C,O,N,D #CONS SUBR4 CONS,C,O,N,S #CR ATOM2 #@CR,C,R #DDTI ATOM5 NIL,D,D,T,I,N #DEFP SUBR8 DEFNP,D,E,F,I,N,E,D,P #DEP SUBR3 DEP,D,E,P #DIFF SUBR4 DIFF,D,I,F,F #EQ SUBR2 EQ,E,Q #EQL SUBR5 EQUAL,E,Q,U,A,L #ERR SUBR3 XERR,E,R,R #ERLS ATOM7 NIL,E,R,R,L,I,S,T #ERST SUBR6 ERSET,E,R,R,S,E,T #EVAL SUBR4 EVAL,E,V,A,L #EXAM SUBR4 EXAM,E,X,A,M #EXPT SUBR4 EXPT,E,X,P,T #FLTC SUBR5 FLATC,F,L,A,T,C #FLSZ SUBR8 FLTSZ,F,L,A,T,S,I,Z,E #GC SUBR2 GC,G,C #GCD SUBR3 GCD,G,C,D #GCGA ATOM5 #T,G,C,G,A,G #GNSM SUBR6 GNSYM,G,E,N,S,Y,M #GO SUBR2 GO,G,O #HEX ATOM3 NIL,H,E,X #IDVP SUBR6 IDEVP,I,N,D,E,V,P #IDSK SUBR6 INDSK,I,N,D,I,S,K #INTN SUBR6 INTRN,I,N,T,E,R,N #KBEC ATOM6 #T,K,B,E,C,H,O #LABL ATOM5 @UNDF,L,A,B,E,L #LAM ATOM6 @UNDF,L,A,M,B,D,A #LAST SUBR4 LAST,L,A,S,T #LNTH SUBR6 LNGTH,L,E,N,G,T,H #LESP SUBR5 LESSP,L,E,S,S,P #LINE SUBR5 LINEL,L,I,N,E,L #LIST SUBR4 LIST,L,I,S,T #LSH SUBR3 LSH,L,S,H #MAP SUBR3 MAP,M,A,P #MAPC SUBR4 MAPC,M,A,P,C #MPCR SUBR6 MAPCR,M,A,P,C,A,R #MPLS SUBR7 MAPLS,M,A,P,L,I,S,T #MAX SUBR3 MAX,M,A,X #MEMB SUBR6 MEMBR,M,E,M,B,E,R #MIN SUBR3 MIN,M,I,N #MNUS SUBR5 MINUS,M,I,N,U,S #MNSP SUBR6 MNUSP,M,I,N,U,S,P #MLAM ATOM7 @UNDF,M,L,A,M,B,D,A #NIL ATOM3 NIL,N,I,L #NLAM ATOM7 @UNDF,N,L,A,M,B,D,A #NOT SUBR3 NOT,N,O,T #NULL SUBR4 NULL,N,U,L,L #NMBP SUBR7 NMBRP,N,U,M,B,E,R,P #OBLS ATOM6 $OBLS,O,B,L,I,S,T #OR SUBR2 OR,O,R #ODVP SUBR7 ODEVP,O,U,T,D,E,V,P #PAUS SUBR5 PAUSE,P,A,U,S,E #PEKC SUBR5 PEEKC,P,E,E,K,C #PKCH SUBR6 PEKCH,P,E,E,K,C,H #PSKP SUBR5 PGSKP,P,G,S,K,P #PLUS SUBR4 PLUS,P,L,U,S #PNAM SUBR5 PNAME,P,N,A,M,E #PRNC SUBR5 PRINC,P,R,I,N,C #PRCS SUBR8 PRNCS,P,R,I,N,C,S,T,R #PRNT SUBR5 PRINT,P,R,I,N,T #PRN1 SUBR5 PRIN1,P,R,I,N,1 #PR1S SUBR8 PRN1S,P,R,I,N,1,S,T,R #PROG SUBR4 PROG,P,R,O,G #PRG2 SUBR5 PROG2,P,R,O,G,2 #QUIT SUBR4 QUIT,Q,U,I,T #QUOT SUBR5 QUOTE,Q,U,O,T,E #QUO SUBR8 QUO,Q,U,O,T,I,E,N,T #RAND SUBR6 RANDM,R,A,N,D,O,M #READ SUBR4 READ,R,E,A,D #REDC SUBR5 READC,R,E,A,D,C #RDCH SUBR6 REDCH,R,E,A,D,C,H #RDST SUBR7 RDSTR,R,E,A,D,S,T,R #REM SUBR9 REM,R,E,M,A,I,N,D,E,R #RMOB SUBR5 REMOB,R,E,M,O,B #RMOV SUBR6 REMOV,R,E,M,O,V,E #RTRN SUBR6 RETRN,R,E,T,U,R,N #RVRS SUBR7 REVRS,R,E,V,E,R,S,E #RVST SUBR6 RVSTR,R,E,V,S,T,R #RPLA SUBR6 RPLCA,R,P,L,A,C,A #RPLD SUBR6 RPLCD,R,P,L,A,C,D #SASC SUBR6 SASOC,S,A,S,S,O,C #SET SUBR3 SET,S,E,T #SETQ SUBR4 SETQ,S,E,T,Q #STQQ SUBR5 SETQQ,S,E,T,Q,Q #SIDX SUBR8 SINDX,S,T,R,I,N,D,E,X #STRP SUBR7 STRP,S,T,R,I,N,G,P #SLTH SUBR9 SLNTH,S,T,R,L,E,N,G,T,H #SBLS SUBR6 SBLIS,S,U,B,L,I,S #SUBR ATOM4 @UNDF,S,U,B,R #SBST SUBR5 SUBST,S,U,B,S,T #SSTR SUBR6 SBSTR,S,U,B,S,T,R #SUB1 SUBR4 SUB1,S,U,B,1 #SWCH SUBR6 SWTCH,S,W,I,T,C,H #SYSI ATOM4 #SYSI,S,Y,S,I #SYSO ATOM4 #SYSO,S,Y,S,O #SYSH ATOM6 $SYSH,S,Y,S,P,C,H #SYSP ATOM5 $SYSP,S,Y,S,P,R #SYSR ATOM5 $SYSR,S,Y,S,R,D #T ATOM1 #T,T #TEND SUBR4 TEND,T,E,N,D #TIMS SUBR5 TIMES,T,I,M,E,S #TOPL SUBR4 TOPL,T,O,P,L #TYI SUBR3 TYI,T,Y,I #TYO SUBR3 TYO,T,Y,O #TYP SUBR3 TYP,T,Y,P #ZERP SUBR5 ZEROP,Z,E,R,O,P,-1 *************************************************** HDNG LIST OF AREAS PROTECTED FROM GC *************************************************** * TEMLIST * *************************************************** $TMLS DC *+1 DC XCNS9 TEMP FOR XCONS DC *+1 DC XCNS9+1 TEMP FOR XCONS DC *+1 DC INT88 TEMP FOR INTRN DC *+1 DC INT95 #OBLS - OBLIST DC *+1 DC XCAR9 #NIL - NIL DC *+1 DC PR200+1 #HEX - HEX DC *+1 DC GC705+1 #GCGA - GCGAG DC *+1 DC IKB05+1 #DDTI - DDTIN DC *+1 DC SYSO2+1 #SYSO - SYSOUT DC *+1 DC RD920 TEMP FOR READ DC *+1 DC RD964 TEMP FOR READ DC *+1 DC RD968 #QUOT - QUOTE DC *+1 DC INT82 #C@R - C-R DC *+1 DC IKB72+1 #KBEC - KBECHO DC *+1 DC EV930 #SUBR - SUBR DC *+1 DC AP997 #LABL - LABEL DC *+1 DC AP902 #LAM - LAMBDA DC *+1 DC AP998 #NLAM - NLAMBDA DC *+1 DC AP999 #MLAM - MLAMBDA DC *+1 DC SYSI2+1 #SYSI - SYSIN DC *+1 DC TOPFN FOR HOLDING USER TOPLEVEL DC *+1 DC LSPR2+1 #ERLS - ERRLIST DC *+1 DC SBS98 TEMP FOR SUBST DC *+1 DC SBS99 TEMP FOR SUBST DC *+1 DC GNS99 CHAR STRING FOR GENSYM DC *+1 DC SBL99 TEMP FOR SUBLIS DC NIL DC @TRUE #T - T *************************************************** * LIST OF CHARS FOR GENSYM FUNCTION * *************************************************** $GNSM DC *+1 STRING OF CHARACTERS DC @9 FOR USE BY GENSYM DC *+1 FUNCTION - GENERATED DC @9 ATOMS WILL BE QX000, DC *+1 QX001, QX002, ETC. DC @9 DC *+1 DC @X DC NIL DC @Q LIST HDNG 200 END OF FREE STORAGE *************************************************** S@FSF BSS E 4800 EMPTY FREE STORAGE SPACE E@FST EQU * L@FST EQU E@FST-S@FST L@FSF EQU E@FST-S@FSF *************************************************** * PUSHDOWN LIST SPACE * *************************************************** S@SPD EQU * START OF SPECIAL PDL BSS 1000 PUSHDOWN LIST SPACE S@RPD EQU *-1 START OF REGULAR PDL *************************************************** LIST *************************************************** * MAIN CONTROL PROGRAM FOR LISP * *************************************************** LISP LDX L1 S@RPD INIT XR1 FOR REG PDL LDX L3 X INIT XR3 FOR SPECIAL AREA LDX L2 L@FSF CLEAR FREE STORAGE SLT 32 LSP10 STO L2 S@FSF-2 MDX 2 -2 MDX LSP10 BSI 3 PUSHJ-X DO GARBAGE COLLECTION DC GC LD L $KCSW BSC L LSP20,+- BRANCH UNLESS // TYP BSI 3 PUSHJ-X SET UP FOR KB INPUT DC TYP LSP20 BSI 3 ERROR-X PRINT HEADER DC 0+@INFO SRA 16 INITIALIZE RANDOM FUNCTION BSI 3 MKFXN-X STO 3 @ARG1-X BSI 3 PUSHJ-X DC RANDM LSP25 LDX L2 1 SET TOPLEVEL TYPE - TOPLV EQU *-1 0=TYP, 1=TEND, 2=USER FORM BSC I2 LSP30 *************************************************** LSP30 DC LSP35 TYP TOPLEVEL DC LSP35 TEND TOPLEVEL DC LSP60 USER TOPLEVEL *************************************************** LSP35 BSI L SYSOU SET SYSTEM OUTPUT LD L OUTDV SAVE OUTPUT DEV NUMBER STO LSP99 BSI L SYSIN SET SYSTEM INPUT LD L INDEV GET INPUT DEV NUMBER BSI 3 MKFXN-X STO 3 @ARG1-X BSI 3 PUSHJ-X READ AN EXPRESSION DC READ MDX L TOPLV,0 SKIP IF TEND TOPLVEL BSI LSP50 ELSE PRINT EXPRESSION STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL EXPRESSION DC EVAL BSI LSP50 PRINT RESULT LD LSP98 PRINT TWO CARRIAGE RETURNS BSI L OUTPT LD LSP98 BSI L OUTPT MDX LSP25 GO DO IT AGAIN *************************************************** LSP50 DC *-* SRT 16 BSI 3 XCONS-X MAKE LIST OF EXPRESSION BSI 3 PUSHA-X SAVE ON STACK LD LSP99 BSI 3 MKFXN-X STO 3 @ARG1-X SET OUTPUT DEVICE NUMBER BSI 3 POPA-X GET EXPRESSION STO 3 @ARG2-X BSI 3 PUSHJ-X PRINT IT DC PRINT BSC I LSP50 *************************************************** TOPFN DC NIL PROTECTED BY TEMLIST LSP98 DC @CR LSP99 DC *-* *************************************************** LSP60 LD TOPFN GET FORM GIVEN BY USER STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL IT DC EVAL MDX LSP25 GO DO IT AGAIN *************************************************** * ERRORS NOT INSIDE AN ERRSET BRANCH HERE * *************************************************** LSPER LDX L1 S@RPD INIT XR1 FOR REG PDL LSPR2 LD L #ERLS (MAPCAR EVAL ERRLIST)... BSI 3 PUSHA-X LSPR3 BSC L LSPR5,+- BRANCH IF NO FORMS LEFT BSI 3 XCAR-X GET NEXT ONE STO 3 @ARG1-X BSI 3 PUSHJ-X EVAL IT DC EVAL LD I1 0 CHAIN DOWN LIST OF FORMS STO 1 0 MDX LSPR3 LSPR5 BSI 3 POPA-X MDX LSP25 GO TO TOP LEVEL *************************************************** * SPARE WORDS FOR MODSF PATCHING * *************************************************** MODSF EBC .******************************. EBC .******************************. *************************************************** @END EQU * END LISP // DUP *DELETE LISP *STORE WS UA LISP *DELETE TLISP *DUMP UA WS LISP *STORECI WS UA TLISP // JOB LISPMACS G STEELE // DUP MACRO LIBRARY FOR LISP ASSEMBLIES *DELETE LMACS *DFILE FX LMACS 0008 *MACRO UPDATE BUILD 'LMACS' SELECT M .********************************************************************** NAME $LABL,$ADR,$1,$ ADD 'SUBR1' LIST OFF # SET $+1 DC #**+#*7 DC * $LABL DC *+3 DC *+@ATOM DC NIL DC @.$1 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$ADR,$1,$2,$ ADD 'SUBR2' LIST OFF # SET $+1 DC #**+#*9 DC * $LABL DC *+5 DC *+@ATOM DC *+1 DC @.$1 DC NIL DC @.$2 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$ADR,$1,$2,$3,$ ADD 'SUBR3' LIST OFF # SET $+1 DC #**+#*11 DC * $LABL DC *+7 DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC NIL DC @.$3 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$ADR,$1,$2,$3,$4,$ ADD 'SUBR4' LIST OFF # SET $+1 DC #**+#*13 DC * $LABL DC *+9 DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC NIL DC @.$4 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$ADR,$1,$2,$3,$4,$5,$ ADD 'SUBR5' LIST OFF # SET $+1 DC #**+#*15 DC * $LABL DC *+11 DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC NIL DC @.$5 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$ADR,$1,$2,$3,$4,$5,$6,$ ADD 'SUBR6' LIST OFF # SET $+1 DC #**+#*17 DC * $LABL DC *+13 DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC *+1 DC @.$5 DC NIL DC @.$6 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$ADR,$1,$2,$3,$4,$5,$6,$7,$ ADD 'SUBR7' LIST OFF # SET $+1 DC #**+#*19 DC * $LABL DC *+15 DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC *+1 DC @.$5 DC *+1 DC @.$6 DC NIL DC @.$7 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$ADR,$1,$2,$3,$4,$5,$6,$7,$8,$ ADD 'SUBR8' LIST OFF # SET $+1 DC #**+#*21 DC * $LABL DC *+17 DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC *+1 DC @.$5 DC *+1 DC @.$6 DC *+1 DC @.$7 DC NIL DC @.$8 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$ADR,$1,$2,$3,$4,$5,$6,$7,$8,$9,$ ADD 'SUBR9' LIST OFF # SET $+1 DC #**+#*23 DC * $LABL DC *+19 DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC *+1 DC @.$5 DC *+1 DC @.$6 DC *+1 DC @.$7 DC *+1 DC @.$8 DC NIL DC @.$9 DC $ADR-1 DC #SUBR LIST .********************************************************************** NAME $LABL,$VAL,$1,$ ADD 'ATOM1' LIST OFF # SET $+1 DC #**+#*5 DC * $LABL DC $VAL DC *+@ATOM DC NIL DC @.$1 LIST .********************************************************************** NAME $LABL,$VAL,$1,$2,$ ADD 'ATOM2' LIST OFF # SET $+1 DC #**+#*7 DC * $LABL DC $VAL DC *+@ATOM DC *+1 DC @.$1 DC NIL DC @.$2 LIST .********************************************************************** NAME $LABL,$VAL,$1,$2,$3,$ ADD 'ATOM3' LIST OFF # SET $+1 DC #**+#*9 DC * $LABL DC $VAL DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC NIL DC @.$3 LIST .********************************************************************** NAME $LABL,$VAL,$1,$2,$3,$4,$ ADD 'ATOM4' LIST OFF # SET $+1 DC #**+#*11 DC * $LABL DC $VAL DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC NIL DC @.$4 LIST .********************************************************************** NAME $LABL,$VAL,$1,$2,$3,$4,$5,$ ADD 'ATOM5' LIST OFF # SET $+1 DC #**+#*13 DC * $LABL DC $VAL DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC NIL DC @.$5 LIST .********************************************************************** NAME $LABL,$VAL,$1,$2,$3,$4,$5,$6,$ ADD 'ATOM6' LIST OFF # SET $+1 DC #**+#*15 DC * $LABL DC $VAL DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC *+1 DC @.$5 DC NIL DC @.$6 LIST .********************************************************************** NAME $LABL,$VAL,$1,$2,$3,$4,$5,$6,$7,$ ADD 'ATOM7' LIST OFF # SET $+1 DC #**+#*17 DC * $LABL DC $VAL DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC *+1 DC @.$5 DC *+1 DC @.$6 DC NIL DC @.$7 LIST .********************************************************************** NAME $LABL,$VAL,$1,$2,$3,$4,$5,$6,$7,$8,$ ADD 'ATOM8' LIST OFF # SET $+1 DC #**+#*19 DC * $LABL DC $VAL DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC *+1 DC @.$5 DC *+1 DC @.$6 DC *+1 DC @.$7 DC NIL DC @.$8 LIST .********************************************************************** NAME $LABL,$VAL,$1,$2,$3,$4,$5,$6,$7,$8,$9,$ ADD 'ATOM9' LIST OFF # SET $+1 DC #**+#*21 DC * $LABL DC $VAL DC *+@ATOM DC *+1 DC @.$1 DC *+1 DC @.$2 DC *+1 DC @.$3 DC *+1 DC @.$4 DC *+1 DC @.$5 DC *+1 DC @.$6 DC *+1 DC @.$7 DC *+1 DC @.$8 DC NIL DC @.$9 LIST . *************************************************** NAME ADD ' ' LIST ON *************************************************** * YOU LEFT A BLANK IN HERE, IDIOT ************* ORG * AT THIS ADDRESS, FOOL ************* *************************************************** LIST .********************************************************************** ENDUP // JOB KBCP0 // ASM *LEVEL 4 HDNG KEYBOARD/CONSOLE PRINTER I/O ROUTINE LIBR ISS 02 KBCP0 *************************************************** * COMMON LIBF ENTRY * *************************************************** KBCP0 MDX WHICH GO PROCESS REQUEST EXIT BSC I *-* RETURN TO LIBF CALLER *************************************************** RESET DC /0F01 SENSE/RESET IOCC *************************************************** * COMMON INTERRUPT ENTRY POINT * *************************************************** INTRP DC *-* XIO RESET-1 RESET INTERRUPTING DEVICE BSC L KBINT,- BRANCH IF KB INTERRUPT LD TBUFR IS ANOTHER CHAR IN BUFFER BSC L TTERM,E BRANCH IF NONE STO CHAR SAVE CHAR FROM BUFFER LDX 1 -15 PUSH DOWN CHARS IN BUFFER TMOVE LD L1 TBUFR+16 STO L1 TBUFR+15 MDX 1 1 MDX TMOVE MDX L POINT,-1 MOVE BACK POINTER LD ONE STO TBUFR+15 CLEAR LAST WORD OF BUFFER TREDY XIO SENSE CHECK FOR TYPEWRITER READY SLA 5 BSC L TTYPE,- BRANCH IF READY LD FLAG BSI L $PST4 ELSE WAIT AT $PST4 MDX TREDY AND TRY AGAIN TTYPE XIO PRINT PRINT NEXT CHAR MDX RETRN+2 RETURN - DON'T DECR I/O CTR TTERM SRA 16 CLEAR BUSY SWITCH STO TBUSY RETRN MDX L $IOCT,-1 DECR I/O COUNTER NOP BSC I INTRP RETURN TO ILS04 KBINT XIO READ READ CHAR FROM KEYBOARD MDX RETRN *************************************************** * CONSTANTS * *************************************************** BSS E 0 CHAR DC *-* SENSE DC /0F00 SENSE WITHOUT RESET IOCC READ DC INPUT DC /0A00 READ KEYBOARD CHAR IOCC PRINT DC CHAR DC /0900 PRINT CHAR IOCC FLAG DC /2000 FLAG FOR I/O TRAP WAITS SLECT DC /0C00 SELECT KB IOCC BLINK DC /1111 JUST FOR FUN - PATTERN DC /1111 FOR BLINKING LIGHTS ONE DC 1 TBUFR DC 1 OUTPUT BUFFER DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 DC 1 POINT DC TBUFR BUFFER POINTER TBUSY DC 0 NON-ZERO=OUTPUT IN PROGRESS INPUT DC *-* *************************************************** * HANDLE CONSOLE PRINTER OUTPUT * *************************************************** WHICH BSC L RDCHR,E /0001 = KB INPUT REQUEST STO INPUT SAVE CHAR TEMPORARILY RMCHK LD TBUFR+15 WAIT FOR SPACE IN BUFFER BSC L *+1,E MDX RMCHK LD INPUT PUT CHAR IN BUFFER STO I POINT MDX L TBUSY,0 IS OUTPUT GOING ALREADY MDX PUTBF YES, GO INCR POINTER LD TBUFR NO, START I/O STO CHAR LD ONE STO TBUFR READY XIO SENSE CHECK FOR TYPEWRITER READY SLA 5 BSC L START,- LD FLAG BSI L $PRET IF NOT, WAIT IN $PRET MDX READY START MDX L $IOCT,1 INCR I/O COUNTER STX TBUSY SET BUSY SWITCH XIO PRINT PRINT CHAR MDX EXIT PUTBF MDX L POINT,1 INCR BUFFER POINTER MDX EXIT *************************************************** * HANDLE KEYBOARD INPUT * *************************************************** RDCHR MDX L $IOCT,1 INCR I/O COUNTER STO INPUT XIO SLECT SELECT KB FOR INPUT LDD BLINK BLINK PRETTY LIGHTS RTE 1 IN ACC AND EXT STO BLINK IWAIT LDD BLINK BSI L $PRET WAIT IN $PRET FOR INPUT LD INPUT DID KB INPUT BSC L IWAIT,E NO, WAIT AGAIN MDX EXIT YES, RETURN WITH CHAR *************************************************** $PRET EQU /28 PREOPERATIVE WAIT TRAP $IOCT EQU /32 I/O COUNTER $PST4 EQU /8D LEVEL 4 INT ERROR TRAP *************************************************** END // DUP *DELETE KBCP0 *STORE WS UA KBCP0 KEYBOARD/CONSOLE PRINTER I/O SUBROUTINE