Assemble Utilisp.s utilisp.o -lisp.p1 par='Test,Pexit=*Pexit,Sysparm(M/LISP),Macxref'
Assemble Utilisp.s utilisp.tso -lisp.p2 sysmac=*OSmac+*TSOmac par='Test,Sysparm(T/LISP//2),Noexten,Macxref'
$CONTINUE WITH *DUMMY*
UTILISP  TITLE 'MACROS'
         MACRO 
         PREFIX 
         GBLC  &SYSTEM
* 
*        TITLE 'REGISTERS' 
* 
* REGISTERS 
* 
N        EQU   0              CONSTANT "NIL" 
Z        EQU   1              CONSTANT 0 
E        EQU   2              BASE FOR SYSTEM CODE / ENTRY VECTOR TOP 
E2       EQU   3              BASE FOR SYSTEM CODE 
F        EQU   4              CONSTANT 4 
SL       EQU   5              RUN-TIME STACK LIMIT 
X        EQU   6              WORK 
NA       EQU   7              NUMBER OF ACTUALS / WORK 
D        EQU   8              CDR / WORK 
A        EQU   9              CAR / RESULT / WORK 
CB       EQU   10             CURRENT CODE BASE 
SB       EQU   11             CURRENT STACK FRAME BASE 
L        EQU   12             LINKAGE / WORK 
NB       EQU   13             NEW BASE FOR LINKAGE 
W        EQU   14             WORK 
WW       EQU   15             WORK 
* 
* FLOATING POINT REGISTERS 
* 
FR0      EQU   0 
FR2      EQU   2 
FR4      EQU   4 
FR6      EQU   6 
         TITLE 'DUMMY SECTIONS' 
SYMBOL   DSECT 
***WARNING***  VALUE must be the first thing in the SYMBOL DSECT.
VALUE    DS    A              CURRENT BINDING 
PNAME    DS    A              PRINT NAME 
PROPERTY DS    A              PROPERTY LIST 
FUNCDEF  DS    A              FUNCTIONAL DEFINITION 
SYSIZE   EQU   *-SYMBOL 
* 
STREAM   DSECT 
STRMSIZE DS    A              SIZE OF THE CELL (116) 
CURPOS   DS    A              CURRENT POSITION 
RECTOP   DS    A              TOP OF CURRENT RECORD 
RECEND   DS    A              END OF CURRENT RECORD 
MODE     DS    A              MODE OF THE STREAM 
LINEIO   DS    A              LINE I/O ROUTINE ADDR 
         AIF   ('&SYSTEM' EQ 'MTS').#MTS1
DCB      EQU   * 
DCBDSORG EQU   DCB+26 
DCBRECFM EQU   DCB+36 
DCBDDNAM EQU   DCB+40 
DCBOFLGS EQU   DCB+48 
DCBMACR  EQU   DCB+50 
DCBBLKSI EQU   DCB+62 
DCBLRECL EQU   DCB+82 
         AGO   .#MTS1A
.#MTS1   ANOP
IOEOFAD  DS    A              WHERE TO GO ON EOF
IOPARL   DS    5A             PARAMETERS FOR READ/WRITE
IOBUFAD  EQU   IOPARL         LOCATION OF THE BUFFER
IOMODS   DS    XL8            MODIFIERS
IOLDN    DS    CL8            LOGICAL DEVICE NAME OR FDUB
IOLNR    DS    F              LINE NUMBER
IOLEN    DS    3H             LENGTH PARAMETER (TRUNC, MAX, ACTUAL)
.#MTS1A  ANOP
* 
CODE     DSECT 
CODESIZE DS    A 
FUNCNAME DS    A              NAME OF THE FUNCTION 
MAXPARAM DS    A              MAXIMUM NUMBER OF PARAMETERS 
QUOTEVEC DS    A              QUOTE VECTOR POSITION (RELATIVE TO TOP) 
CODETOP  EQU   *              ENTRY FOR SUBRS 
* 
BIGCELL  DSECT 
LENGTH   DS    A              CELL LENGTH (BYTE) 
CELLBODY EQU   * 
* 
STACK    DSECT 
OLDCB    DS    A              OLD CODE BASE 
OLDSB    DS    A              OLD STACK BASE 
RETADR   DS    A              RETURN ADDRESS 
LOCAL1   DS    A 
LOCAL2   DS    A 
LOCAL3   DS    A 
LOCAL4   DS    A 
LOCAL5   DS    A 
LOCAL6   DS    A 
LOCAL7   DS    A 
LOCAL8   DS    A 
LOCAL9   DS    A 
* 
         TITLE 'TAGS' 
SYMTAG   EQU   X'70' 
CODETAG  EQU   X'60' 
STRMTAG  EQU   X'50' 
STRNGTAG EQU   X'40' 
VECTAG   EQU   X'30' 
REFTAG   EQU   X'20' 
FIXTAG   EQU   X'10' 
FLOTAG   EQU   X'18' 
LISTTAG  EQU   X'80' 
* 
UBVTAG   EQU   X'C0' 
UDFTAG   EQU   UBVTAG 
BINDTAG  EQU   X'B0' 
* 
* SPECIAL TAGS( < X'10') 
MARKTAG  EQU   X'01' 
* 
* 
         AIF   ('&SYSTEM' NE 'MTS').EXIT
         TITLE 'GDINFO DSECT'
         GDINFODSECT
.EXIT    MEND 
* 
* 
         MACRO 
&L       $CHARACT 
&L       CL    A,CHARMAX 
         BL    C&SYSNDX 
         $STRING 
         C     Z,0(A) 
         BE    TYPERR 
         IC    A,4(A) 
         N     A,CHARMASK 
         O     A,ZERO 
C&SYSNDX EQU   * 
         MEND 
* 
* 
         MACRO 
&L       $CODE              , CHECK IF "A" IS A CODE 
&L       CLM   A,B'1000',@CODE 
         BNE   TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $CODE1 &R          CHECK IF "&R" IS A CODE 
&L       CLM   &R,B'1000',@CODE 
         BNE   TYPERR1 
         MEND 
* 
* 
         MACRO 
&L       $CODE2 &R          CHECK IF "&R" IS A CODE 
&L       CLM   &R,B'1000',@CODE 
         BNE   TYPERR2 
         MEND 
* 
* 
         MACRO 
&L       $CODE3 &R          CHECK IF "&R" IS A CODE 
&L       CLM   &R,B'1000',@CODE 
         BNE   TYPERR3 
         MEND 
* 
* 
         MACRO 
&L       $FIXNUM            , CHECK IF "A" IS A NUMBER 
&L       CL    A,MAXFIX 
         BNL   TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $FIXNUMD           , CHECK IF "D" IS A NUMBER 
&L       CL    D,MAXFIX 
         BNL   TYPERRD 
         MEND 
* 
* 
         MACRO 
&L       $FIXNUM1 &R 
&L       CL    &R,MAXFIX 
         BNL   TYPERR1 
         MEND 
* 
* 
         MACRO 
&L       $FIXNUM2 &R 
&L       CL    &R,MAXFIX 
         BNL   TYPERR2 
         MEND 
* 
* 
         MACRO 
&L       $FIXNUM3 &R 
&L       CL    &R,MAXFIX 
         BNL   TYPERR3 
         MEND 
* 
* 
         MACRO 
&L       $FLOARG1 , 
&L       L     A,LOCAL1 
         IFFLO A,A&SYSNDX 
         $FIXNUM , 
         SLL   A,8 
         SRA   A,8 
         ST    A,CONVTEMP 
         CVTID FR0,CONVTEMP 
         B     B&SYSNDX 
A&SYSNDX LD    FR0,4(A) 
B&SYSNDX EQU   * 
         MEND 
* 
* 
         MACRO 
&L       $FLOAT &FR 
&L       IFFLO A,A&SYSNDX 
         $FIXNUM 
         SLL   A,8 
         SRA   A,8 
         ST    A,CONVTEMP 
         CVTID &FR,CONVTEMP 
         B     B&SYSNDX 
A&SYSNDX LD    &FR,4(A) 
B&SYSNDX EQU   * 
         MEND 
* 
* 
         MACRO 
&L       $FLONUM 
&L       CLM   A,B'1000',@FLO 
         BNE   TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $FLONUM1 &R 
&L       CLM   &R,B'1000',@FLO 
         BNE   TYPERR1 
         MEND 
* 
* 
         MACRO 
&L       $FLONUM2 &R 
&L       CLM   &R,B'1000',@FLO 
         BNE   TYPERR2 
         MEND 
* 
* 
         MACRO 
&L       $FLONUM3 &R 
&L       CLM   &R,B'1000',@FLO 
         BNE   TYPERR3 
         MEND 
* 
* 
         MACRO 
&L       $LIST              , CHECK IF "A" IS A LIST 
         IFATOM A,TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $NUMBER            , CHECK IF "A" IS A NUMBER 
&L       CL    A,MAXNUM 
         BNL   TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $POSFIX 
&L       CL    A,MINFIX 
         BNL   TYPERR 
          MEND 
* 
* 
         MACRO 
&L       $POSINX 
&L       CL    A,MINFIX 
         BNL   INDEXERR 
         MEND 
* 
* 
         MACRO 
&L       $POSNUM1 &R 
&L       CL    &R,MINNUM 
         BNL   TYPERR1 
         MEND 
* 
* 
         MACRO 
&L       $POSNUM2 &R 
&L       CL    &R,MINNUM 
         BNL   TYPERR2 
         MEND 
* 
* 
         MACRO 
&L       $POSNUM3 &R 
&L       CL    &R,MINNUM 
         BNL   TYPERR3 
         MEND 
* 
* 
         MACRO 
&L       $REFER , 
         CLM   A,B'1000',@REFER 
         BNE   TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $REFER1 &R 
         CLM   &R,B'1000',@REFER 
         BNE   TYPERR1 
         MEND 
* 
* 
         MACRO 
&L       $REFER2 &R 
         CLM   &R,B'1000',@REFER 
         BNE   TYPERR2 
         MEND 
* 
* 
         MACRO 
&L       $REFER3 &R 
         CLM   &R,B'1000',@REFER 
         BNE   TYPERR3 
         MEND 
* 
* 
         MACRO 
&L       $STREAM            , CHECK IF "A" IS A STREAM 
&L       CLM   A,B'1000',@STREAM 
         BNE   TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $STREAM1 &R 
&L       CLM   &R,B'1000',@STREAM 
         BNE   TYPERR1 
         MEND 
* 
* 
         MACRO 
&L       $STREAM2 &R 
&L       CLM   &R,B'1000',@STREAM 
         BNE   TYPERR2 
         MEND 
* 
* 
         MACRO 
&L       $STREAM3 &R 
&L       CLM   &R,B'1000',@STREAM 
         BNE   TYPERR3 
          MEND 
* 
* 
         MACRO 
&L       $STRING            , CHECK IF "A" IS A STRING 
&L       CLM   A,B'1000',@STRING 
         BE    S&SYSNDX 
         IFNOTSY A,TYPERR 
         USING SYMBOL,A 
         L     A,PNAME 
         DROP  A 
S&SYSNDX EQU   * 
         MEND 
* 
* 
         MACRO 
&L       $STRING1 &R 
&L       CLM   &R,B'1000',@STRING 
         BE    S&SYSNDX 
         IFNOTSY &R,TYPERR1 
         USING SYMBOL,&R 
         L     &R,PNAME 
         DROP  &R 
S&SYSNDX EQU   * 
         MEND 
* 
* 
         MACRO 
&L       $STRING2 &R 
&L       CLM   &R,B'1000',@STRING 
         BE    S&SYSNDX 
         IFNOTSY &R,TYPERR2 
         USING SYMBOL,&R 
         L     &R,PNAME 
         DROP  &R 
S&SYSNDX EQU   * 
         MEND 
* 
* 
         MACRO 
&L       $STRING3 &R 
&L       CLM   &R,B'1000',@STRING 
         BE    S&SYSNDX 
         IFNOTSY &R,TYPERR3 
         USING SYMBOL,&R 
         L     &R,PNAME 
         DROP  &R 
S&SYSNDX EQU   * 
         MEND 
* 
* 
         MACRO 
&L       $SYMBOL            , CHECK IF "A" IS A SYMBOL 
&L       CR    A,N 
         BL    TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $SYMBOL1 &R 
&L       CR    &R,N 
         BL    TYPERR1 
         MEND 
* 
* 
         MACRO 
&L       $SYMBOL2 &R 
&L       CR    &R,N 
         BL    TYPERR2 
         MEND 
* 
* 
         MACRO 
&L       $SYMBOL3 &R 
&L       CR    &R,N 
         BL    TYPERR3 
         MEND 
* 
* 
         MACRO 
&L       $VECTOR            , CHECK IF "A" IS A VECTOR 
&L       CLM   A,B'1000',@VECTOR 
         BNE   TYPERR 
         MEND 
* 
* 
         MACRO 
&L       $VECTOR1 &R 
&L       CLM   &R,B'1000',@VECTOR 
         BNE   TYPERR1 
         MEND 
* 
* 
         MACRO 
&L       $VECTOR2 &R 
&L       CLM   &R,B'1000',@VECTOR 
         BNE   TYPERR2 
         MEND 
* 
* 
         MACRO 
&L       $VECTOR3 &R 
&L       CLM   &R,B'1000',@VECTOR 
         BNE   TYPERR3 
         MEND 
* 
* 
         MACRO 
&L       ALIAS &OLDNAME,&VALUE,&VALTAG,&PNAME=NORMAL 
&L       SYM   ALIAS,&VALUE,&VALTAG,PNAME=&PNAME,OLDNAME=&OLDNAME 
         MEND 
* 
* 
         MACRO 
&L       BIND  &R             BIND SYMBOL ON A TO VALUE ON &R 
&L       IFNOTSY A,VARERR     ILLEGAL LAMBDA/PROG VARIABLE 
         USING SYMBOL,A 
         L     W,VALUE 
         ST    W,0(NB)        SAVE OLD VALUE 
         ST    A,4(NB)        AND THE VARIABLE 
         MVI   4(NB),BINDTAG    WITH TAG 
         LA    NB,8(NB)       INCREMENT STACK POINTER 
         ST    NB,BINDTOP 
         ST    &R,VALUE       SET NEW VALUE 
         DROP  A 
         MEND 
* 
* 
         MACRO 
&L       BINDQ &SYM,&R 
&L       L     WW,=A(&SYM) 
         L     W,0(WW) 
         STM   W,WW,0(NB) 
         MVI   4(NB),BINDTAG 
         LA    NB,8(NB) 
         ST    NB,BINDTOP 
         ST    &R,0(WW) 
         MEND 
* 
* 
         MACRO 
&NAME    C$R 
&NAME    SUBR  1,1 
         L     A,LOCAL1 
         LCLA  &L 
         LCLC  &N 
&N       SETC  '&NAME' 
&L       SETA  K'&N-2 
         AIF   (&L EQ 0).EXIT 
.LOOP    AIF   ('&N'(&L+1,1) EQ 'A').CAR 
         CDRA , 
         AGO   .NEXT 
.CAR     ANOP 
         CARA , 
.NEXT    ANOP 
&L       SETA  &L-1 
         AIF   (&L NE 0).LOOP 
.EXIT    ANOP 
         CODEND RET 
         MEND 
* 
* 
         MACRO 
&L       CARA  , 
&L       IFATOM A,TYPERR1 
         L     A,4(A) 
         MEND 
* 
* 
         MACRO 
&L       CDRA  , 
&L       IFATOM A,TYPERR1 
         L     A,0(A) 
         MEND 
* 
* 
         MACRO 
&NAME    CMACRO &VALUE,&VALTAG,&PNAME=NORMAL 
&NAME    SYM   CMACRO,&VALUE,&VALTAG,PNAME=&PNAME 
&NAME.@  CODECON &NAME.# 
         SYMCON MACRO$ 
&NAME    CODE  1,1 
         MEND 
* 
* 
         MACRO 
&NAME    CODE  &MIN,&MAX 
         CNOP  0,4 
&NAME.#  EQU   * 
         USING *,CB 
         USING STACK,SB 
         GBLA  &SCNT 
&SCNT    SETA  &SCNT+1 
         DC    A(BT&SCNT-*-4) 
         SYMCON &NAME.$ 
         DC    A(&MAX*4) 
         DC    A(BT&SCNT-&NAME.#) 
         AIF   ('&MIN' EQ '').EXIT 
         LCLA  &COUNT 
&COUNT   SETA  &MIN 
.LOOP    AIF   (&COUNT EQ 0).EXIT 
         B     RETURN+16*4+4*4  MIMIC OF COMPILED CODE 
&COUNT   SETA  &COUNT-1 
         AGO   .LOOP 
.EXIT    ANOP 
         MEND 
* 
* 
         MACRO 
&L       CODECON &CODE 
         DS    0A 
&L       DC    AL1(CODETAG),AL3(&CODE) 
         MEND 
* 
* 
         MACRO 
         CODEND &RET 
         AIF   ('&RET' EQ '').NORET 
         AIF   ('&RET' EQ 'RETNUM').RETNUM 
         AIF   ('&RET' NE 'RETNIL').JUSTRET 
         LR    A,N 
.JUSTRET ANOP 
         RET 
         AGO   .NORET 
.RETNUM  B     RETNUM 
.NORET   ANOP 
         DROP  CB,SB 
         DS    0A 
         GBLA  &SCNT 
BT&SCNT  EQU   * 
         MEND 
* 
* 
         MACRO 
&L       DISABLE , 
         GBLC  &SYSTEM
&L       MVI   DISABLED,X'FF' 
         C     NB,BINDTOP         We are about to clobber the stack
         BNL   *+8                (probably) by using it for a save
         ST    NB,BINDTOP         area, make sure that UNDO doesn't    @
                                  look at any of the junk we put there
         AIF   ('&SYSTEM' EQ 'MTS').EXIT
         STM   CB,SB,ESTAECB 
.EXIT    MEND 
* 
* 
         MACRO 
&L       ENABLE , 
         GBLC  &SYSTEM
&L       LM    0,1,REGINIT 
         MVI   DISABLED,X'00' 
* 
         AIF   ('&SYSTEM' EQ 'MTS').NOESTAE
         ST    Z,ESTAESB 
.NOESTAE CLI   ATTNFLG,X'FF' 
         BE    ATTNHND1 
         MEND 
* 
* 
         MACRO 
&L       ENABLE0 , 
         GBLC  &SYSTEM
&L       MVI   DISABLED,X'00' 
* 
         AIF   ('&SYSTEM' EQ 'MTS').NOESTAE
         ST    Z,ESTAESB 
.NOESTAE CLI   ATTNFLG,X'FF' 
         BE    ATTNHND1 
         MEND 
* 
* 
         MACRO 
&L       FIXCON &FIX 
         DS    0A 
&L       DC    AL1(FIXTAG),AL3(&FIX) 
         MEND 
* 
* 
         MACRO 
&L       FUNCENT            , ENTRY SEQUENCE 
&L       LA    L,0(L) 
         STM   CB,L,0(NB) 
         LR    SB,NB 
         BXH   NB,F,OVFLERR   CHECK STACK OVERFLOW 
*        BXLE  NB,F,*+8 
*        B     OVFLERR 
         MEND 
* 
* 
         MACRO 
&L       GETNEXT 
&L       BAL   L,GETCH 
         LR    L,W 
         SLA   L,2 
         L     WW,READTAB 
         AL    L,0(WW) 
         MEND 
* 
* 
         MACRO 
&L       GETVALUE &SY         GET VALUE OF A KNOWN SYMBOL ON "A" 
&L       L     A,=A(&SY) 
         CLI   0(A),UBVTAG 
         BE    UBVERR 
         L     A,0(A) 
         MEND 
* 
* 
         MACRO 
&L       IFATOM &R,&ADR       IF &R IS AN ATOM THEN GO TO &ADR 
&L       BXH   &R,Z,&ADR 
*&L       LTR   &R,&R 
*         BH    &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFCODE &R,&ADR 
&L       CLM   &R,B'1000',@CODE 
         BE    &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFFIX &R,&ADR 
&L       CL    &R,MAXFIX 
         BL    &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFFLO &R,&LAB 
&L       CLM   &R,B'1000',@FLO 
         BE    &LAB 
         MEND 
* 
* 
         MACRO 
&L       IFLIST &R,&ADR       IF &R IS A LIST THEN GO TO &ADR 
*&L       BXLE  &R,Z,&ADR 
&L       LTR   &R,&R 
         BNH   &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFNONNUL &R,&ADR     IF &R IS NOT NULL THEN GO TO &ADR 
&L       CR &R,N 
         BNE   &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFNOTCOD &R,&ADR 
&L       CLM   &R,B'1000',@CODE 
         BNE   &ADR 
         MEND 
* 
         MACRO 
&L       IFNOTFIX &R,&PLACE      BRANCH IF "A" IS NOT A FIXBER 
&L       CL    &R,MAXFIX 
         BNL   &PLACE 
         MEND 
* 
* 
         MACRO 
&L       IFNOTFLO &R,&LAB 
&L       CLM   &R,B'1000',@FLO 
         BNE   &LAB 
         MEND 
* 
* 
         MACRO 
&L       IFNOTSTR &R,&ADR     IF &R IS NOT A STRING THEN GOTO &ADR 
&L       CLM   &R,B'1000',@STRING 
         BNE   &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFNOTSY &R,&ADR      IF &R IS NOT A SYMBOL THEN GO TO &ADR 
&L       CR    &R,N 
         BL    &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFNULL &R,&ADR       IF &R IS NULL THEN GO TO &ADR 
&L       CR    &R,N 
         BE    &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFSTRING &R,&ADR     IF &R IS A STRING THEN GOTO &ADR 
&L       CLM   &R,B'1000',@STRING 
         BE    &ADR 
         MEND 
* 
* 
         MACRO 
&L       IFSY  &R,&ADR        IF &R IS A SYMBOL THEN GO TO &ADR 
&L       CR    &R,N 
         BNL   &ADR 
         MEND 
* 
* 
* 
* 
         MACRO 
&L       LISTCON &LIST 
         DS    0A 
&L       DC    AL1(LISTTAG),AL3(&LIST) 
         MEND 
* 
* 
         MACRO 
&NAME    LSUBR &VALUE,&VALTAG,&PNAME=NORMAL 
&NAME    SYM   LSUBR,&VALUE,&VALTAG,PNAME=&PNAME 
&NAME    CODE  0,-1 
         MEND 
* 
* 
         MACRO 
&L       LT    &R,&ADR        LOAD AND TEST 
&L       ICM   &R,B'1111',&ADR 
         MEND 
* 
* 
         MACRO 
&L       NEXTCH ,             SPECIAL PURPOSE MACRO TO READ ONE CHAR 
&L       LA    X,1(X)         ADVANCE CHARACTER POSITION POINTER 
A&SYSNDX CL    X,RECEND       IF END OF LINE IS NOT REACHED YET 
         BL    B&SYSNDX         THEN DO NOTHING MORE 
         ST    L,SAVEL        OTHERWISE, CALL LINE I/O ROUTINE 
         ST    W,SAVEW 
         L     L,LINEIO 
         BALR  L,L 
         L     L,SAVEL 
         L     W,SAVEW 
         L     X,CURPOS       X:=CURRENT CHARACTER POSITION 
         B     A&SYSNDX       CHECK IT AGAIN 
B&SYSNDX EQU   * 
         MEND 
* 
* 
         MACRO 
&L       POPW  &R             POP AN ITEM FROM STACK ONTO &R 
&L       SLR   NB,F 
         L     &R,0(NB) 
         MEND 
* 
* 
         MACRO 
&L       PUSHNC &R             PUSH &R ONTO STACK 
&L       ST    &R,0(NB) 
         ALR   NB,F 
         MEND 
* 
* 
         MACRO 
&L       PUSHW &R             PUSH &R ONTO STACK 
&L       ST    &R,0(NB) 
         BXH   NB,F,OVFLERR 
*        BXLE  NB,F,*+8 
*        B     OVFLERR 
         MEND 
* 
* 
         MACRO 
&L       RET                , RETURNING SEQUENCE 
&L       BR    E 
         MEND 
* 
* 
         MACRO 
&NAME    SPEC  &VALUE,&TAG,&PNAME=NORMAL 
&NAME    SYM   SPEC,&VALUE,&TAG,PNAME=&PNAME 
&SYSECT  CSECT , 
         USING STACK,SB 
         MEND 
* 
* 
         MACRO 
&L       STBUFF ,             STORE ONE CHARACTER IN BUFFER 
&L       STC   W,0(A) 
         LA    A,1(A) 
         CL    A,STRBUFE 
         BH    BUFFERR 
         MEND 
* 
* 
         MACRO 
&NAME    STRING &CHARS 
         LCLA  &L 
&L       SETA  K'&CHARS-2 
&NAME    EQU   * 
         DC    A(&L)          LENGTH 
         DC    C&CHARS 
&L       SETA  (&L+3)/4*4-&L 
         AIF   (&L EQ 0).EXIT 
         DC    FL(&L)'0' 
.EXIT    ANOP 
         MEND 
* 
* 
         MACRO 
&L       STRMCON &STRM 
         DS    0A 
&L       DC    AL1(STRMTAG),AL3(&STRM) 
         MEND 
* 
* 
         MACRO 
&L       STRNGCON &STRNG 
         DS    0A 
&L       DC    AL1(STRNGTAG),AL3(&STRNG) 
         MEND 
* 
* 
         MACRO 
&NAME    SYM   &KIND,&VALUE,&VALTAG,&PNAME=NORMAL,&OLDNAME= 
* 
         LCLC  &PN 
&PN      SETC  '''&NAME''' 
         AIF   ('&PNAME' EQ 'NORMAL').BEGIN 
&PN      SETC  '&PNAME' 
* 
.BEGIN   ANOP 
PDSYM    CSECT 
* 
&NAME.$  EQU   * 
         AIF   ('&VALUE' EQ '').NOVALUE 
         DC    AL1(&VALTAG),AL3(&VALUE) 
         AGO   .PNAME 
.NOVALUE DC    AL1(UBVTAG),AL3(GCZERO) 
* 
.PNAME   STRNGCON P&SYSNDX 
* 
.PROP    SYMCON NIL$ 
* 
         AIF   ('&KIND' EQ '').NOFN 
         AIF   ('&KIND' EQ 'SPEC').SPEC 
         AIF   ('&KIND' EQ 'CMACRO').MACRO 
         AIF   ('&KIND' EQ 'ALIAS').ALIAS 
         CODECON &NAME.# 
         AGO   .STRING 
.SPEC    DC    AL1(UDFTAG),AL3(&NAME.#) 
         AGO   .STRING 
.MACRO   LISTCON &NAME.@ 
         AGO   .STRING 
.ALIAS   CODECON &OLDNAME.# 
         AGO   .STRING 
.NOFN    DC    AL1(UDFTAG),AL3(UDFERR) 
* 
.STRING  ANOP 
PREDEF   CSECT 
P&SYSNDX STRING &PN 
         MEND 
* 
* 
         MACRO 
&NAME    SUBR  &MIN,&MAX,&VALUE,&VALTAG,&PNAME=NORMAL 
&NAME    SYM   SUBR,&VALUE,&VALTAG,PNAME=&PNAME 
&NAME    CODE  &MIN,&MAX 
         MEND 
* 
* 
         MACRO 
&L       SYMCON &SY 
         DS    0A 
&L       DC    AL1(SYMTAG),AL3(&SY) 
         MEND 
* 
* 
         MACRO 
         SYMCONS &SY,&N 
         LCLA  &COUNT 
&COUNT   SETA  &N 
.LOOP    ANOP 
         DC    AL1(SYMTAG),AL3(&SY) 
&COUNT   SETA  &COUNT-1 
         AIF   (&COUNT NE 0).LOOP 
         MEND 
* 
* 
         MACRO 
&L       TAILREC &LABEL       TAIL RECURSION 
&L       LR    L,E 
         B     &LABEL 
         MEND 
* 
* 
         MACRO 
&L       TRTAB &X,&Y 
&L       DC    A(256) 
A&SYSNDX EQU   * 
         LCLA  &COUNT 
&COUNT   SETA  0 
.LOOP    DC    AL1(&COUNT) 
&COUNT   SETA  &COUNT+1 
         AIF   (&COUNT NE 256).LOOP 
&COUNT   SETA  1 
.LOOP2   ORG   A&SYSNDX+C'&X(&COUNT)' 
         DC    AL1(C'&Y(&COUNT)') 
&COUNT   SETA  &COUNT+1 
         AIF   (&COUNT LE N'&X).LOOP2 
         ORG   A&SYSNDX+256 
         MEND 
* 
* 
         MACRO 
&L       UNDO  , 
&L       SL    NB,F8 
         LM    W,WW,0(NB) 
         ST    W,0(WW) 
         ST    NB,BINDTOP 
         MEND 
* 
* 
         MACRO 
&L       VALUEA             , GET VALUE OF SYMBOL ON "A" 
&L       CLI   0(A),UBVTAG 
         BE    UBVERR 
         L     A,0(A) 
         MEND 
* 
* 
         MACRO 
&L       VECCON &VEC 
         DS    0A 
&L       DC    AL1(VECTAG),AL3(&VEC) 
         MEND 
* 
* 
         MACRO 
&L       VECTOR &SIZE 
&L       DC    A(&SIZE*4) 
         LCLA  &COUNT 
&COUNT   SETA  &SIZE 
.LOOP    SYMCON NIL$ 
&COUNT   SETA  &COUNT-1 
         AIF   (&COUNT NE 0).LOOP 
         MEND 
* 
         MACRO 
&LABEL   CVTID &FR,&IN 
* 
         GBLC  &SYSTEM 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO## 
         AIF   ('&SYSTEM' EQ 'MTS').MTS## 
* 
.HITAC   ANOP 
.FACOM   ANOP 
&LABEL   CID   &FR,&IN 
         AGO   .EXIT 
* 
.MTS##   ANOP
.TSO##   ANOP 
&LABEL   STM   0,1,CVTSAVE 
         L     0,&IN 
         LPR   1,0 
         N     0,CVTX80       ; =X'80000000' 
         O     0,CVTX4E       ; =X'4E000000' 
         STM   0,1,CVTWORK 
         LD    &FR,CVTWORK 
         AD    &FR,CVTD0 
         LM    0,1,CVTSAVE 
* 
         AGO   .EXIT 
* 
.EXIT    ANOP 
* 
         MEND 
* 
* 
         MACRO 
&LABEL   CVTDI &FR,&OUT 
* 
         GBLC  &SYSTEM 
* 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO## 
         AIF   ('&SYSTEM' EQ 'MTS').MTS## 
* 
.HITAC   ANOP 
.FACOM   ANOP 
* 
&LABEL   CDI   &FR,&OUT 
* 
         AGO   .EXIT 
* 
.MTS##   ANOP
.TSO##   ANOP 
* 
&LABEL   ST    0,CVTSAVE 
         STD   &FR,CVTFSAVE 
         AD    &FR,CVTXX      ; =X'4F08000000000000' 
         STD   &FR,CVTWORK 
         L     0,CVTWORK+4 
         LTR   0,0 
         ST    0,&OUT 
         L     0,CVTSAVE 
         LD    &FR,CVTFSAVE 
* 
         AGO   .EXIT 
* 
.EXIT    ANOP 
* 
         MEND 
*
*        MACRO TO CALL TPUT OR SERCOM DEPENDING ON WHAT SYSTEM WE
*        ARE RUNNING IN.
*
         MACRO
&LBL     TPUT2 &LOC,&LEN
&LBL     LA    0,&LEN
         L     1,=A(&LOC)
         BAL   L,TPUT2
         MEND
* 
******************************************** 
* 
*  MACRO FOR SYSPARM HANDLING 
* 
*********************************************** 
         MACRO 
         GETPARM 
* 
         GBLC  &RESULT 
         GBLA  &SP 
         LCLA  &I,&K 
* 
         AIF   (&SP GT K'&SYSPARM).ENDPARM 
* 
&I       SETA  &SP 
.LOOP    AIF   ('&SYSPARM'(&I,1) EQ '/').PARM 
&I       SETA  &I+1 
         AIF   (&I LE K'&SYSPARM).LOOP 
* 
.LSTPARM ANOP 
&K       SETA  &I-&SP 
&RESULT  SETC  '&SYSPARM'(&SP,&K) 
&SP      SETA  &I 
         AGO   .EXIT 
* 
.PARM    ANOP 
&K       SETA  &I-&SP 
&RESULT  SETC  '&SYSPARM'(&SP,&K) 
&SP      SETA  &I+1 
         AGO   .EXIT 
* 
.ENDPARM ANOP 
&RESULT  SETC  '' 
* 
.EXIT    ANOP 
         MEND 
* 
* 
************************************************************* 
*   
************************************************************ 
* 
* 
         PRINT ON,NOGEN,NODATA 
* 
         TITLE 'PARAMETER ANALYSIS' 
         ACTR  4096 
         GBLC  &SYSTEM        ; SYSTEM NAME 
         GBLC  &SYSID         ; MANAGER-ID 
         GBLC  &JAA,&JET      ;SYSTEM MACRO HEADER 
         GBLC  &START         ; START ADDRESS 
         GBLC  &VERSION 
         GBLC  &FILESEP       FILE NAME SEPARATOR
* 
         GBLC  &SIZE
&SIZE    SETC  '256'          USED ONLY IF SYSTEM IS MTS
         GBLC  &STACK 
&STACK   SETC  '16' 
         GBLC  &SAVE 
&SAVE    SETC  '64' 
         GBLC  &FIX 
&FIX     SETC  '32' 
         GBLC  &LISPSYS 
&LISPSYS SETC  'LISPSYS.CODE' 
* 
&VERSION SETC  'VERSION 2.3' 
* 
* 
* VARIABLE SYMBOLS FOR MACRO "GETPARM" 
* 
         GBLC  &RESULT 
         GBLA  &SP 
&SP      SETA  1 
* 
* 
MAIN     CSECT 
&START   SETC  'MAIN' 
         AIF   (K'&SYSPARM NE 0).PARM000 
         MNOTE 255,'SYSPARM MISSING!!!!!' 
         AGO   .END 
.PARM000 ANOP 
         GETPARM 
         AIF   ('&RESULT' EQ 'H').HITAC00 
         AIF   ('&RESULT' EQ 'F').FACOM00 
         AIF   ('&RESULT' EQ 'T').TSO##00 
         AIF   ('&RESULT' EQ 'M').MTS##00 
         MNOTE 255,'ILLEGAL SYSTEM NAME -- SYSPARM(&SYSPARM)' 
         AGO   .END 
* 
.HITAC00 ANOP 
&SYSTEM  SETC  'HITAC' 
&JAA     SETC  'JAA' 
&JET     SETC  'JET' 
&FILESEP SETC  '.'
         AGO   .SYSTEM0 
* 
.FACOM00 ANOP 
&SYSTEM  SETC  'FACOM' 
&JAA     SETC  'KAA' 
&JET     SETC  'KEQ' 
&FILESEP SETC  '.'
         AGO   .SYSTEM0 
* 
.TSO##00 ANOP 
&SYSTEM  SETC  'MVS/TSO' 
&JAA     SETC  'IHA' 
&JET     SETC  'IKJ' 
&FILESEP SETC  '.'
         AGO   .SYSTEM0 
* 
.MTS##00 ANOP 
&SYSTEM  SETC  'MTS' 
&JAA     SETC  'YOU''VE GOT TO BE KIDDING'
&JET     SETC  'THIS IS CRAZY'
&FILESEP SETC  ':'
         AGO   .SYSTEM0 
* 
.SYSTEM0 ANOP 
         MNOTE 0,'SYSTEM NAME : &SYSTEM' 
* 
* 
*  MANAGER-ID 
* 
         GETPARM 
         AIF   ('&RESULT' NE '').MID0000 
         MNOTE 255,'MANAGER ID MISSING -- SYSPARM(&SYSPARM)' 
         AGO   .END 
* 
.MID0000 ANOP 
&SYSID   SETC  '&RESULT' 
         MNOTE 0,'MANAGER ID  : &SYSID' 
* 
* TOTAL SIZE 
* 
         AIF   ('&SYSTEM' NE 'MTS').NOSIZE
         GETPARM 
         AIF   ('&RESULT' EQ '').SIZE000 
&SIZE    SETC  '&RESULT' 
.SIZE000 ANOP 
         MNOTE 0,'SIZE        : &SIZE (KW)' 
.NOSIZE  ANOP
* 
* STACK SIZE 
* 
         GETPARM 
         AIF   ('&RESULT' EQ '').STACK00 
&STACK   SETC  '&RESULT' 
.STACK00 ANOP 
         MNOTE 0,'STACK       : &STACK (KW)' 
* 
* SAVE SIZE 
* 
         AIF   ('&SYSTEM' EQ 'MTS').NOSAVE
         GETPARM 
         AIF   ('&RESULT' EQ '').SAVE000 
&SAVE    SETC  '&RESULT' 
.SAVE000 ANOP 
         MNOTE 0,'SAVE        : &SAVE (KW)' 
.NOSAVE  ANOP
* 
* FIX SIZE 
* 
         GETPARM 
         AIF   ('&RESULT' EQ '').FIX0000 
&FIX     SETC  '&RESULT' 
.FIX0000 ANOP 
         MNOTE 0,'FIX         : &FIX (KW)' 
* 
* LISPSYS (UTILISP KERNEL FILE NAME) 
* 
         GETPARM 
         AIF   ('&RESULT' EQ '').LISPSYS 
&LISPSYS SETC  '&RESULT' 
.LISPSYS ANOP 
         MNOTE 0,'LISPSYS     : ''&SYSID&FILESEP&LISPSYS''' 
* 
* 
         AIF   ('&SYSTEM' NE 'MTS').NOCSECT
*
         ASMEDIT REQU=NO,INDCH=NO,TOC=YES
         MACSET LABTYPE=LINE,LITADDR=YES
*
*        THIS THING ASSUMES IT KNOWS HOW THE VARIOUS CSECTS WILL
*        BE ARRANGED IN THE LOAD MODULE.  SINCE MTS DOESN'T HAVE 
*        LOAD MODULES, MAKE IT ALL ONE CSECT, ARRANGED THE WAY IT
*        WANTS.
*
CSECT    OPSYN LOCTR
*
*        GET THEM IN THE RIGHT ORDER
PDSYM    LOCTR
PREDEF   LOCTR
*
.NOCSECT ANOP
*
* 
* 
&START   SETC  'START' 
* 
         PRINT GEN
         PREFIX 
         PRINT NOGEN
         TITLE 'ENTRY VECTOR' 
* 
MAIN     CSECT 
         ACTR  4096 
* 
         USING *,E,E2 
         USING STACK,SB 
*********************************************************************** 
* 
* ENTRY VECTOR 
* 
*********************************************************************** 
RETURN   LR    NB,SB 
         LM    CB,L,0(SB) 
         BR    L 
* 
         ORG   RETURN+4*4     ; BASIC ENTRY 
         B     EVAL           ; ENTRY  4(16) 
         B     FUNCALL        ; ENTRY  5(20) 
         B     EQUAL          ; ENTRY  6(24) 
         DC    A(0)           ;        7(28) 
* 
         ORG   RETURN+8*4     ; CONSTRUCTORS 
         B     CONS           ; ENTRY  8(32) 
         B     XCONS          ; ENTRY  9(36) 
         B     MKLIST         ; ENTRY 10(40) 
         B     MKFLOAT        ; ENTRY 11(44) 
         B     MKVECTOR       ; ENTRY 12(48) 
         B     MKBLOCK        ; ENTRY 13(52) 
         B     MKLIST2        ; ENTRY 14(56) 
         DC    A(0)           ;       15(60) 
* 
         ORG   RETURN+16*4    ; ERROR HANDLERS 
         B     UBVERR         ; ENTRY 16(64) 
         B     TYPERR         ; ENTRY 17(68) 
         B     INDEXERR       ; ENTRY 18(72) 
         B     UDFERR         ; ENTRY 19(76) 
         B     PARAMERR       ; ENTRY 20(80) 
         B     UBVERRD        ; ENTRY 21(84) 
         B     TYPERRD        ; ENTRY 22(88) 
         B     OVFLERR        ; ENTRY 23(92) 
         DC    A(0)           ;       24(96) 
         DC    A(0)           ;       25(100) 
         DC    A(0)           ;       26(104) 
         DC    A(0)           ;       27(108) 
         DC    A(0)           ;       28(112) 
         DC    A(0)           ;       29(116) 
         DC    A(0)           ;       30(120) 
         DC    A(0)           ;       31(124) 
* 
         ORG   RETURN+32*4    ; RECURSIVE FUNCTION ENTRY 
RECURSE  LA    L,0(L) 
         STM   CB,L,0(NB) 
         LR    SB,NB 
         BXLE  NB,F,0(D) 
         B     OVFLERR 
* 
         ORG   RETURN+40*4    ; FUNCALL SYMBOL 
FUNCALSY LA    L,0(L) 
         STM   CB,L,0(NB) 
         LR    SB,NB 
         BXH   NB,F,OVFLERR 
         USING SYMBOL,A 
         CLI   FUNCDEF,CODETAG 
         BNE   FCFNSY 
         L     CB,FUNCDEF 
         DROP  A 
         USING CODE,CB 
         C     NA,MAXPARAM 
         BNH   CODETOP(NA) 
         C     Z,MAXPARAM 
         BH    CODETOP 
         B     PARAMERR 
         DROP  CB 
* 
         ORG   RETURN+52*4    ; FUNCALL CODE 
FUNCALCD LA    L,0(L)         FUNCALL TO A CODE PIECE 
         STM   CB,L,0(NB) 
         LR    SB,NB 
         BXH   NB,F,OVFLERR 
         LR    CB,A 
         USING CODE,CB 
         C     NA,MAXPARAM 
         BNH   CODETOP(NA) 
         C     Z,MAXPARAM 
         BH    CODETOP 
         B     PARAMERR 
         DROP  CB 
*********************************************************************** 
* 
* GLOBAL CONSTANTS AND VARIABLES 
* 
*        THESE ARE ALSO USED BY COMPILED OBJECTS 
* 
*********************************************************************** 
         ORG   RETURN+64*4              ; GLOBAL CONSTANTS 
ZERO     EQU   *                        ; CONST 64(256) 
@FIX     DC    AL1(FIXTAG),AL3(0)       ; CONST --(---) 
MAXFIX   EQU   *                        ; CONST 65(260) 
@FLO     DC    AL1(FLOTAG),AL3(0)       ; CONST --(---) 
@STRING  DC    AL1(STRNGTAG),AL3(0)     ; CONST 66(264) 
@VECTOR  DC    AL1(VECTAG),AL3(0)       ; CONST 67(268) 
@STREAM  DC    AL1(STRMTAG),AL3(0)      ; CONST 68(272) 
MAXNUM   EQU   *                        ; CONST 69(276) 
@REFER   DC    AL1(REFTAG),AL3(0)       ; CONST --(---) 
@CODE    DC    AL1(CODETAG),AL3(0)      ; CONST 70(280) 
@SYMBOL  DC    AL1(SYMTAG),AL3(0)       ; CONST 71(284) 
@LIST    DC    AL1(LISTTAG),AL3(0)      ; CONST 72(288) 
CHARMAX  DC    AL1(FIXTAG),AL3(256)     ; CONST 73(292) 
CATCHTAG DC    AL1(MARKTAG),AL3(0)      ; CONST 74(296) 
         DC    A(0)                     ;       75(300) 
         DC    A(0)                     ;       76(304) 
         DC    A(0)                     ;       77(308) 
         DC    A(0)                     ;       78(312) 
         DC    A(0)                     ;       79(316) 
* 
         ORG   RETURN+80*4              ; GLOBAL VARIABLES 
BINDTOP  DC    F'0'                     ; VAR   80(320) 
********************************************************************** 
* 
* RETURN ENTRIES 
* 
********************************************************************** 
RETNIL   LR    A,N 
         LR    NB,SB 
         LM    CB,L,0(SB) 
         BR    L 
* 
RETT     L     A,T 
         LR    NB,SB 
         LM    CB,L,0(SB) 
         BR    L 
* 
RETNUM0  LA    A,0(A) 
RETNUM   O     A,ZERO 
         LR    NB,SB 
         LM    CB,L,0(SB) 
         BR    L 
         TITLE 'ALLOCATORS' 
*********************************************************************** 
* 
*     ALLOCATORS 
* 
* NOTE : ALL THE OBJECT POINTERS ON REGISTERS MAY MADE OUT OF DATE 
*        BY ALLOCATORS, AS RELOCATION MAY TAKE PLACE. 
* 
*********************************************************************** 
* 
* CONS -- ALLOCATES A LIST CELL 
* 
*   ARGS 
*        A : CAR TO BE 
*        D : CDR TO BE 
*   RESULT 
*        A : CONSED CELL 
* 
NCONSRET LR   D,N             ENTRY FOR TAIL RECURSIVE "NCONS" 
* 
CONSNRET LR    L,E            ENTRY FOR TAIL RECURSION 
* 
CONS     L     W,HEAPTOP 
         LA    WW,8(W)        WW:=NEXT HEAP TOP ADDRESS 
         CL    WW,HEAPLIM     HEAP LIMIT REACHED? 
         BH    CONS2          IF SO, CALL GC 
CONS1    STM   D,A,0(W)       SET CAR AND CDR 
         O     W,@LIST        PUT LIST TAG 
         ST    WW,HEAPTOP     SET NEW HEAPTOP 
         LR    A,W 
         BR    L 
* 
XCONS1   XR    A,D 
         XR    D,A 
         XR    A,D 
CONS2    FUNCENT ,            SAVE RETURN ADDRESS 
         STM   D,A,LOCAL1     SAVE CAR AND CDR 
         LA    NB,LOCAL3      SET NB TO STACK TOP 
         BAL   L,GC           CALL GARBAGE COLLECTOR 
         LR    NB,SB          RECOVER "NB" 
         LM    D,A,LOCAL1     RECOVER CAR AND CDR 
         LM    CB,L,0(SB)     RECOVER CB,L,SB 
         L     W,HEAPTOP      W:=NEW HEAP TOP 
         LA    WW,8(W)        WW:=NEXT HEAP TOP TO BE 
         CL    WW,HEAPLIM     IF SPACE IS SUFFICIENT 
         BNH   CONS1            THEN CONTINUE THE JOB 
         B     SPACERR        ELSE ERROR 
* 
* XCONS -- ALTERNATIVE ENTRY FOR CONS 
* 
*   ARGS 
*        A : CDR TO BE 
*        D : CAR TO BE 
*   RESULT 
*        A : CONSED CELL 
* 
XCONSRET LR    L,E            ENTRY FOR TAIL RECURSION 
* 
XCONS    L     W,HEAPTOP 
         LA    WW,8(W) 
         CL    WW,HEAPLIM 
         BH    XCONS1 
         ST    A,0(W) 
         ST    D,4(W) 
         O     W,@LIST        PUT LIST TAG 
         ST    WW,HEAPTOP 
         LR    A,W 
         BR    L 
*********************************************************************** 
* 
* MKLIST -- ALLOCATES A LIST 
* 
*   ARGS 
*        NA : NUMBER OF ELEMENTS TO BE INCLUDED IN THE LIST 
*        A  : LIST TAIL TO BE 
*   RESULT 
*        A  : ALLOCATED LIST 
* 
MKLISTNR LR    A,N 
* 
MKLISTR  LR    L,E 
* 
MKLIST   SR    NA,F 
         BMR   L 
         L     W,HEAPTOP 
         LA    WW,8(NA,W) 
         ALR   WW,NA 
         CL    WW,HEAPLIM 
         BH    LIST3 
LIST1    ST    WW,HEAPTOP 
         O     W,@LIST 
         LR    D,A 
LIST2    POPW  A 
         STM   D,A,0(W) 
         LR    D,W 
         AL    W,F8 
         SR    NA,F 
         BNM   LIST2 
         LR    A,D 
         BR    L 
* 
LIST3    FUNCENT , 
         LA    NB,LOCAL2 
         ST    A,LOCAL1 
         BAL   L,GC 
         LR    NB,SB 
         L     A,LOCAL1 
         LM    CB,L,0(SB) 
         L     W,HEAPTOP 
         LA    WW,8(NA,W) 
         ALR   WW,NA 
         CL    WW,HEAPLIM 
         BNH   LIST1 
         CL    WW,CURLIM 
         BH    SPACERR 
         ST    WW,HEAPLIM 
         B     LIST1 
*********************************************************************** 
* 
* MKLIST2 -- ALLOCATE A LIST WITH TWO ELEMENTS 
*            MOSTLY FOR COMPILED OBJECTS 
* 
* ARGS 
*        A, D : FIRST AND SECOND ELEMENT TO BE 
* RESULT 
*        A    : RESULTANT LIST 
* 
MKLIST2  L     W,HEAPTOP 
         LA    WW,16(W) 
         CL    WW,HEAPLIM 
         BNL   MKLST2GC 
         ST    N,0(W) 
         ST    D,4(W) 
         O     W,@LIST 
         ST    W,8(W) 
         ST    A,12(W) 
         ST    WW,HEAPTOP 
         LA    A,8(W) 
         O     A,@LIST 
         BR    L 
* 
MKLST2GC ST    A,0(NB) 
         ST    D,4(NB) 
         LR    A,N 
         LA    NA,8 
         LA    NB,8(NB) 
         B     MKLIST 
*********************************************************************** 
* 
* MKFLOAT -- ALLOCATES A FLOATING POINT NUMBER CELL 
* 
*   ARGS 
*        FR0 : FLOATING NUMBER (DOUBLE PREC.) TO BE ALLOCATED 
*   RESULT 
*        A : ALLOCATED NUMBER CELL 
* 
MKFLOATR LR    L,E 
* 
MKFLOAT  L     W,HEAPTOP      W:=CURRENT HEAP TOP 
         LA    WW,12(W)        WW:=NEW HEAP TOP TO BE 
         CL    WW,HEAPLIM     IF HEAP EXHAUSTED 
         BH    MKFLOAT2         THEN CALL G.C. 
MKFLOAT1 ST    WW,HEAPTOP     SET NEW HEAP TOP 
         LA    WW,8 
         ST    WW,0(W) 
         STD   FR0,4(W)       STORE FLOATING POINT VALUE TO NEW CELL 
         LR    A,W            A:=NEW CELL ADDR 
         O     A,@FLO       PUT FLOAT TAG 
         BR    L              RETURN 
* 
MKFLOAT2 FUNCENT ,            GET READY FOR G.C. 
         STD   FR0,MKFLOTMP   SAVE FLOATING POINT VALUE 
         LA    NB,LOCAL1      SET STACK POINTER 
         BAL   L,GC           CALL G.C. 
         LR    NB,SB          RECOVER NB 
         LD    FR0,MKFLOTMP   RECOVER FLOATING POINT VALUE 
         LM    CB,L,0(SB)     RECOVER OTHER REGISTERS 
         L     W,HEAPTOP      W:=HEAP TOP 
         LA    WW,12(W)        WW:=NEW HEAP TOP TO BE 
         CL    WW,HEAPLIM     IF ENOUGH SPACE IS COLLECTED 
         BNH   MKFLOAT1         THEN ALLOCATION SUCCESSFUL 
         B     SPACERR        OTHERWISE, ERROR 
* 
MKFLOTMP DS    D 
*********************************************************************** 
* 
* MKSYM -- ALLOCATES A SYMBOL 
* 
*   ARGS 
*        A : STRING TO BE THE PNAME 
*   RESULT 
*        A : ALLOCATED SYMBOL 
* 
*  FOR THE ALLOCATED SYMBOL : 
*        VALUE IS UNBOUND 
*        PNAME IS AS GIVEN 
*        PROPERTY IS NIL 
*        FUNCDEF IS UNDEFINED 
* 
MKSYMR   LR    L,E            TAIL RECURSIVE ENTRY 
* 
MKSYM    L     W,HEAPTOP 
         USING SYMBOL,W 
         LA    WW,SYSIZE(W)   WW:=NEW HEAPTOP TO BE 
         CL    WW,HEAPLIM     CHECK IF THERE'S ENOUGH SPACE 
         BH    MKSYM2         IF NOT, CALL GC 
MKSYM1   MVC   SYMBOL(SYSIZE),SYMPROTO SET PROTOTYPE 
         ST    A,PNAME        SET PNAME 
         ST    WW,HEAPTOP 
         LR    A,W 
         O     A,@SYMBOL      PUT SYMBOL TAG 
         BR    L 
* 
MKSYM2   FUNCENT ,            SAVE RETURN ADDR, CB, SB 
         ST    A,LOCAL1       SAVE THE PNAME 
         LA    NB,LOCAL2      SET STACK TOP 
         BAL   L,GC           CALL GARBAGE COLLECTOR 
         LR    NB,SB          RECOVER NB 
         L     A,LOCAL1       RECOVER PNAME 
         LM    CB,L,0(SB)     RECOVER CB,L,SB 
         L     W,HEAPTOP 
         LA    WW,SYSIZE(W)   WW:=NEXT HEAP TOP TO BE 
         CL    WW,HEAPLIM     IF SPACE IS SUFFICIENT 
         BNH   MKSYM1           THEN CONTINUE THE JOB 
         B     SPACERR        ELSE ERROR 
* 
         DROP  W 
* 
SYMPROTO DS    0F             PROTOTYPE FOR SYMBOL 
         DC    AL1(UBVTAG),FL3'0' VALUE : UNBOUND 
         DC    F'0'           PNAME : SET LATER 
         SYMCON NIL$          PROPERTY : NIL 
         DC    AL1(UDFTAG),AL3(UDFERR) FUNCDEF : UNDEFINED 
*********************************************************************** 
* 
* MKBLOCK -- ALLOCATES A BLOCK OF HEAP 
* 
*   ARG 
*        A : REQUIRED SIZE OF THE BLOCK TO BE ALLOCATED 
*            (EXCLUDING THE HEADER) 
*   RESULT 
*        A : ALLOCATED BLOCK (TAG NOT SET) 
* 
MKBLOCK  LA    D,7(A)         COMPUTE REAL BLOCK SIZE ON A 
         N     D,WORDBND 
         L     W,HEAPTOP 
         LA    WW,0(D,W)      WW:=NEW HEAP TOP TO BE 
         CL    WW,HEAPLIM     IF NOT ENOUGH SPACE AVAILABLE 
         BH    MKBLOCK2         THEN CALL GARBAGE COLLECTOR 
MKBLOCK1 ST    A,0(W)         SET BLOCK SIZE 
         ST    WW,HEAPTOP     SET NEW HEAP TOP 
         LR    A,W 
         BR    L              RETURN 
* 
MKBLOCK2 FUNCENT ,            SAVE RET ADR, ETC 
         LA    NB,LOCAL1      SET STACK TOP 
         BAL   L,GC           CALL GARBAGE COLLECTOR 
         LR    NB,SB 
         LM    CB,L,0(SB)     RECOVER OTHER REGS 
         L     W,HEAPTOP      TRY AGAIN 
         LA    WW,0(D,W)      WW:=HEAP TOP TO BE 
         CL    WW,HEAPLIM     IF ENOUGH SPACE COLLECTED 
         BNH   MKBLOCK1         THEN IT'S OK, CONTINUE 
         CL    WW,CURLIM      OTHERWISE, EXTEND THE HEAP 
         BH    SPACERR 
         ST    WW,HEAPLIM     IF POSSIBLE 
         B     MKBLOCK1       AND CONTINUE 
*********************************************************************** 
* 
* MKSTRING -- ALLOCATES A STRING 
* 
*   ARG 
*        STRBUFF : CHARACTERS TO CONSITUTE THE STRING 
*        A : LAST CHARACTER POS IN STRBUFF + 1 
*   RESULT 
*        A : ALLOCATED STRING 
* 
MKSTRNGR LR    L,E            TAIL RECURSIVE ENTRY 
* 
MKSTRING LA    L,0(L)         SAVE RETURN ADDRESS 
         PUSHW L 
         SL    A,STRBUFAD     A:=REAL STRING SIZE 
         BAL   L,MKBLOCK      ALLOCATE STRING BLOCK 
         LA    D,4(A)         D:=TOP OF CHARACTYERS 
         LR    X,A            SAVE STRING TOP ON "X" 
         L     WW,0(X)        WW:=LOGICAL LENGTH 
         L     W,STRBUFAD     W:=BUFFER ADDRESS 
         LA    A,3(WW)        A:=PHYSICAL LENGTH 
         N     A,WORDBND        ADJUSTED TO WORD BOUNDARY 
         MVCL  D,W            MOVE CHARACTERS WITH NULL PADDING 
         LR    A,X            RECOVER STRING TOP ON "A" 
         O     A,@STRING      PUT STRING TAG 
         POPW  L              RETURN 
         BR    L 
*********************************************************************** 
* 
* MKVECTOR -- ALLOCATES A VECTOR 
* 
*   ARGS 
*        A : SIZE OF VECTOR (# OF ELEMENTS) 
*   RESULT 
*        A : ALLOCATED VECTOR 
* 
MKVECTOR AR    A,A 
         AR    A,A            A:=VECTOR SIZE IN BYTES 
         LA    L,0(L) 
         PUSHW L              SAVE RETURN ADDRESS 
         BAL   L,MKBLOCK      ALLOCATE VECTOR BLOCK 
         LR    X,Z            INITIATE INDEX 
         B     INITV2 
INITV1   ST    N,4(X,A)       INITIAL VALUE IS NIL 
         AR    X,F 
INITV2   C     X,0(A)         REPEAT UNTIL 
         BNE   INITV1           THE LAST ELEMENT 
         O     A,@VECTOR 
         POPW  L 
         BR    L 
*********************************************************************** 
* 
* MKSTREAM  --  ALLOCATES A STREAM 
* 
*   ARGS 
*        A : STRING WHICH WILL BE THE DDNAME 
*   RESULT 
*        A : ALLOCATED STREAM 
* 
MKSTRMR  LR    L,E            TAIL RECURSIVE ENTRY 
* 
MKSTREAM LT    W,STRMFREE 
         BZ    MKSTRM2 
MKSTRM1  L     WW,0(W) 
         ST    WW,STRMFREE 
         MVC   0(STRMLENG,W),STRMODEL 
         LR    D,A 
         L     A,0(D) 
         USING STREAM,W 
         AIF   ('&SYSTEM' EQ 'MTS').#MTS3
         LA    X,DCBDDNAM 
         DROP  W 
         LR    NA,A 
         ALR   D,F 
         MVCL  X,D 
         AGO   .#MTS3A
.#MTS3   ANOP 
         USING STREAM,W
         LA    X,IOLDN        COPY NAME INTO STREAM LDN OR FDUB
         LA    NA,8 
         ICM   A,B'1000',=C' '
         ALR   D,F
         MVCL  X,D
         LA    X,IOLEN        BUILD PARAMETER LIST
         LA    NA,IOMODS
         STM   X,NA,IOPARL+4
         LA    X,IOLNR
         LA    NA,IOLDN
         STM   X,NA,IOPARL+12
         OI    IOPARL+16,X'80'
         DROP  W
.#MTS3A  ANOP
         O     W,@STREAM      PUT STREAM TAG 
         LR    A,W 
         BR    L 
* 
MKSTRM2  FUNCENT , 
         ST    A,LOCAL1 
         LA    NB,LOCAL2 
         BAL   L,GC           CALL GARBAGE COLLECTOR 
         LR    NB,SB 
         L     A,LOCAL1 
         LM    CB,L,0(SB) 
         L     W,STRMFREE 
         LTR   W,W 
         BNZ   MKSTRM1 
         B     SPACERR 
* 
         DS    0A 
STRMODEL EQU   * 
         DC    A(STRMLENG-4) 
         DC    F'0' 
         DC    F'0' 
         DC    F'0' 
         DC    F'0' 
         DC    A(IOERR) 
         AIF   ('&SYSTEM' EQ 'MTS').#MTS2
         DCB   DSORG=PS,MACRF=(GL),EODAD=EOFERR,EXLST=EXLST,           *
               SYNAD=SYNAD,EROPT=ACC 
         AGO   .#MTS2A
.#MTS2   ANOP
         DC    A(EOFERR)      WHERE TO GO ON EOF
         DC    5A(0)          PARAMETER LIST
         MTSMODS (@MAXLEN),WORDS=2 MODIFIERS
         DC    CL8' '         LDN OR FDUB POINTER
         DC    F'0'           LINE NUMBER
         DC    H'0,255,0'     LENGTH
         DS    0F             END MUST BE FULL WORD ALIGNED
*
.#MTS2A  ANOP
ENDSTRM  EQU   * 
STRMLENG EQU   ENDSTRM-STRMODEL 
* 
         AIF   ('&SYSTEM' EQ 'MTS').#MTS4 SKIP DCB EXITS
DCBEXITS CSECT 
* 
EXLST    DC    X'05',AL3(DCBEXIT) 
         DC    X'06',AL3(DCBEXIT) 
         DC    X'11',AL3(DCBABEND) 
         DC    X'80',AL3(0) 
* 
* 
         USING DCBEXIT,15 
* 
* CAUTION: "NA" MUST POINT TO STREAM BASE. 
* 
         USING STREAM,NA 
DCBEXIT  CLI   DCBRECFM,X'00' 
         BNZ   DCBEXIT2 
         MVI   DCBRECFM,X'50'  ;DEFUALT OF RECFM IS "VB" 
DCBEXIT2 LH    0,DCBLRECL 
         LTR   0,0 
         BNZ   DCBEXIT1 
         LA    0,255 
         TM    DCBRECFM,X'50' ; RECFM IS "VB"? 
         BNZ   DCBEXIT3 
         LA    0,80            ; LRECL OF "FB" IS 80 AS DEFAULT 
DCBEXIT3 STH   0,DCBLRECL 
DCBEXIT1 LH    0,DCBBLKSI 
         LTR   0,0 
         BNZR  14 
         LA    0,2560 
         STH   0,DCBBLKSI 
         BR    14 
         DROP  15 
         DROP  NA 
* 
         USING DCBABEND,15 
DCBABEND MVI   3(1),X'04'     SET OPTION FLAG TO IGNORE THE ERROR 
* ; CAUTION   MVI     2(1),X'04' IS WRONG IN VOS3!!!!!!!!!!!!! 
         MVI   DCBFLAG,X'FF'  SET FLAG FOR LISP SYSTEM 
         BR    14 
         DROP  15 
* 
SYNAD    MVI   DCBFLAG,X'FF' 
         BR    14 
* 
* END OF DCBEXITS 
*        
.#MTS4   ANOP
* 
MAIN     CSECT 
         TITLE 'EVALUATOR' 
*********************************************************************** 
* 
*     EVALUATORS 
* 
* 
*********************************************************************** 
* 
* EVAL -- INTERNAL ENTRY FOR EVAL 
* 
*   ARGS 
*        A : FORM TO BE EVALUATED 
*   RESULT 
*        A : EVALUATED FORM 
* 
EVANDRET LR    L,E            ENTRY FOR TAIL RECURSION 
* 
EVAL     IFLIST A,EVREC 
* 
* EVALUATE AN ATOM 
* 
         CR    A,N            IF NOT SYMBOL 
         BLR   L                THEN JUST RETURN 
* 
* EVALUATE A SYMBOL 
* 
         VALUEA ,             GET VALUE 
         BR    L                AND RETURN 
* 
* EVALUATE A LIST 
*   RECURSION REQUIRED 
* 
EVREC    FUNCENT ,            GET READY FOR RECURSION 
* 
EVL      LM    D,A,0(A) 
         LR    CB,A 
EVL1     IFLIST A,EVFNL       WHEN FN IS A LIST 
* 
* FUNCTION IS AN ATOM 
* 
EVFNA    IFNOTSY A,EVFNNSY 
         USING SYMBOL,A 
         L     A,FUNCDEF 
         DROP  A 
         CL    A,@UDFMIN 
         BNLR  A 
         CLM   A,B'1000',@CODE 
         BNE   EVL1 
         LR    CB,A 
         USING CODE,CB        CALL SUBR 
EVSUBR   LA    NB,LOCAL1      SET STACK POINTER (FOR PUSHING ARGS) 
         IFLIST D,EVSUBR3     IF NO ARGUMENT 
         LR    NA,Z             SET NUMBER-OF-ARG REG 
         B     CODETOP          AND JUMP INTO SUBR 
* 
EVSUBR1  IFNOTSY A,EVSUBR2    WHEN ARG IS ATOM 
         VALUEA ,             GET VALUE IF SYMBOL 
EVSUBR2  PUSHW A              PUSH THE ARG 
         IFATOM D,EVSUBR6     IF NO MORE ARG THEN FINISH 
EVSUBR3  LM    D,A,0(D)       A:=NEXT ARG; D:=REST 
         IFATOM A,EVSUBR1     WHEN ARG IS NOT ATOM 
         IFATOM D,EVSUBR5     AND IT'S NOT THE LAST ONE 
EVSUBR4  PUSHNC D               THEN SAVE REST OF ARGS 
         BAL   L,EVREC          EVALUATE THAT ONE ARG 
         POPW  D                RECOVER REST OF ARGS 
         PUSHNC A               PUSH EVALUATED ARG 
         LM    D,A,0(D)       A:=NEXT ARG; D:=REST 
         IFATOM A,EVSUBR1     IF NEXT ONE IS NOT ATOM 
         IFLIST D,EVSUBR4     AND NOT LAST ONE, THEN REPEAT 
EVSUBR5  BAL   L,EVREC        EVALUATE LAST ARG FORM 
         PUSHW A 
EVSUBR6  LA    W,LOCAL1       W:=FIRST ARG POSITION 
         SLR   NB,W           NB:=# OF ARGS * 4 
         C     NB,MAXPARAM    IF NB DOESN'T EXCEED MAX 
         BNH   CODETOP(NB)      THEN CALL THE SUBR 
         LR    NA,NB 
         C     Z,MAXPARAM     OTHERWISE, IF MAX IS NEGATIVE 
         BH    CODETOP          THEN JUST CALL IT. IT IS AN LSUBR 
         B     PARAMERR       OTHERWISE ERROR 
         DROP  CB 
* 
* FN IS AN ATOM BUT NOT A SYMBOL 
*   IF IT IS A CODE PIECE, THEN CALL IT 
* 
EVFNNSY  CLM   A,B'1000',@CODE 
         BE    EVSUBR 
         B     FNERR          !ATOMIC USED AS A FUNCTION 
* 
* FN IS A LIST 
* 
EVFNL    L     W,MACRO 
         C     W,4(A) 
         BNE   EVPARAM 
         L     A,0(A)         MACRO DEFINITION ON A 
         ST    D,LOCAL4 
         LA    NB,LOCAL1 
         BAL   L,FUNCALL1     EXPAND THE MACRO 
* 
* EVTAIL -- TAIL RECURSIVE ENTRY FOR EVAL 
* 
EVTAIL   IFLIST A,EVL 
         IFNOTSY A,RETURN     RETURN WHEN NUMBER OR ALIKE 
         VALUEA ,             GET VALUE OF SYMBOL 
         RET ,                RETURN 
* 
* FN IS A LIST 
* 
*   EVALUATE PARMETERS FIRST AND CALL "FUNCALL" 
* 
EVPARAM  LR    NA,Z 
         IFATOM D,FCFNL       IF NO ARG, CALL FUNCALL 
* 
* EVALUATE AND EXPAND ACTUALS ON THE STACK 
* 
         LA    NB,LOCAL1 
         LR    NA,A           SAVE FUNCTION ON NA 
EVPAR1   LM    D,A,0(D)       A:=ONE ARG; D:=REST 
         IFLIST A,EVPAR3      IF ARG IS ATOM 
EVPAR2   IFNOTSY A,EVPAR4       THEN IF SYMBOL 
         VALUEA ,                 GET VALUE 
         PUSHW A                PUSH THE ARG 
         IFATOM D,EVPAR5      IF IT IS THE LAST ONE, FINISH 
         LM    D,A,0(D)       A:=NEXT ARG; D:=REST 
         IFATOM A,EVPAR2      IF NEXT ARG IS NOT ATOM THEN 
EVPAR3   STM   NA,D,0(NB)     SAVE FUNCTION AND REST OF ARGS 
         LA    NB,8(NB)         ON THE STACK 
         BAL   L,EVREC 
         SL    NB,F8          RECOVER FUNCTION AND REST OF ARGS 
         LM    NA,D,0(NB) 
EVPAR4   PUSHNC A 
         IFLIST D,EVPAR1 
EVPAR5   LR    A,NA           A:=FUNCTION 
         LR    NA,NB 
         LA    WW,LOCAL1 
         SLR   NA,WW          COMPUTE # OF ACTUALS 
* 
* FN IS A LIST  -  PART OF FUNCALL MOVED  HERE FOR SPEEDING 
* 
FCFNL    L     W,LAMBDA 
         C     W,4(A)         IS THE CAR OF FN "LAMBDA"? 
         BE    FCLAMBDA 
         B     FNERR          !ILLEGAL FUNCTION 
*********************************************************************** 
* 
* FUNCALL -- INTERNAL ENTRY FOR FUNCALL 
* 
*   ARGS 
*        A : FUNCTION TO BE CALLED 
*        NA : NUMBER OF ACTUALS * 4 
*        ACTUALS ARE PUSHED ON STACK 
*          (FIRST - LOCAL1, SECOND - LOCAL2, ETC) 
*   RESULT 
*        A : RESULT OF THE FUNCTION 
* 
         USING STACK,NB 
* 
FUNCALDR LR    L,E 
* 
FUNCALLD ST    D,LOCAL1       ENTRY WITH ONE ARG ON "D" 
         DROP  NB 
* 
FUNCALL1 LR    NA,F           ENTRY WITH ONE ARG 
* 
FUNCALL  FUNCENT , 
* 
* FCTAIL -- TAIL RECURSIVE ENTRY 
*   FUNCTION IS ON A 
* 
FCTAIL   IFLIST A,FCFNL 
         IFNOTSY A,FCFNNSY 
* 
* FN IS A SYMBOL 
* 
FCFNSY   LR    CB,A 
         USING SYMBOL,CB 
         L     A,FUNCDEF 
         DROP  CB 
         CL    A,@UDFMIN 
         BNL   UDFERR 
         B     FCTAIL 
* 
* FN IS AN ATOM BUT NOT A SYMBOL 
*   FN SHOULD BE A CODE PIECE 
* 
FCFNNSY  CLM   A,B'1000',@CODE 
         BNE   FNERR 
* 
* FN IS A SUBR 
*   CHECK NUMBER OF PARAMS AND BRANCH TO CODE 
* 
FCSUBR   LR    CB,A 
         USING CODE,CB 
         C     NA,MAXPARAM 
         BNH   CODETOP(NA)    TAIL RECURSION 
         C     Z,MAXPARAM 
         BH    CODETOP 
         DROP  CB 
         B     PARAMERR 
* 
* FN IS A LAMBDA FORM 
* 
*   LAMBDA VARIABLES CAN HAVE DEFAULT VALUE LIST 
*   WHICH IS EVALUATED IN "PROGN" MANNER AND USED AS DEFAULT 
*   IN CASE CORRESPONDING ACTUAL IS NOT SUPPLIED. 
* 
FCLAMBDA L     D,0(A)         DISCARD "LAMBDA" 
         IFATOM D,FNERR       !ILLEGAL LAMBDA FORM 
         L     L,0(D)         L:=LAMBDA BODY 
         LA    NB,LOCAL1(NA) 
         L     D,4(D)         D:=FORMALS 
         LTR   NA,NA 
         BZ    FCDFLT5        WHEN NO ACTUAL 
* 
* BIND ACTUALS TO FORMALS 
*   AS LONG AS ACTUALS EXIST, DEFAULT VALUES ARE IGNORED. 
* 
         LA    X,LOCAL1 
         LA    WW,0(NA,NB) 
         ALR   WW,NA          WW:=STACK TOP AFTER BINDING 
         CLR   WW,SL 
         BNL   OVFLERR 
FCBIND1  IFATOM D,PARAMERR    !TOO MANY ACTUALS 
         LM    D,A,0(D)       A:=ONE FORMAL; D:=REST 
         IFSY  A,FCBIND2 
         IFATOM A,VARERR 
         L     A,4(A) 
         IFNOTSY A,VARERR 
FCBIND2  L     W,0(A) 
         ST    W,0(NB) 
         ST    A,4(NB) 
         MVI   4(NB),BINDTAG 
         LA    NB,8(NB) 
         ST    NB,BINDTOP 
         L     W,0(X) 
         ST    W,0(A) 
         ALR   X,F            ADVANCE POINTER 
         CR    NB,WW 
         BL    FCBIND1 
* 
* ACTUALS ARE EXHAUSTED 
* NOW, USE DEFAULT VALUE IF ANY FORMALS REMAIN 
* 
         IFATOM D,FCPROGN1    WHEN NO FORMAL REMAINS 
FCDFLT1  LM    D,A,0(D)       A:=ONE FORMAL; D:=REST 
         IFATOM A,PARAMERR    !NO DEFAULT 
         ST    L,0(NB)        SAVE BODY 
         ST    D,4(NB)        SAVE REST OF FORMALS 
         LM    D,A,0(A)       A:=LAMBDA VAR; D:=DEFAULT 
         ST    A,8(NB)        SAVE LAMBDA VAR 
         LA    NB,12(NB) 
         LR    WW,N 
         IFATOM D,FCDFLT4     NO DEFAULT VALUE MEANS NIL 
         LM    D,A,0(D)       PROGN-LIKE EVAL OF DEFAULTS 
         IFATOM D,FCDFLT3 
FCDFLT2  PUSHNC D 
         BAL   L,EVAL 
         POPW  D 
         LM    D,A,0(D) 
         IFLIST D,FCDFLT2 
FCDFLT3  BAL   L,EVAL         THE LAST ONE IS THE VALUE 
         LR    WW,A 
FCDFLT4  SL    NB,F12 
         LM    D,A,4(NB)      A:=LAMBDA VAR; D:=REST 
         L     L,0(NB)        L:=BODY 
         BIND  WW             BIND ONE PARAM 
FCDFLT5  IFLIST D,FCDFLT1 
* 
* NOW EVALUATE THE BODY BY IMPLICIT PROGN EVALUATION 
* 
FCPROGN1 LR    A,N 
         IFATOM L,FCUNDO1 
FCPROGN2 LM    D,A,0(L) 
         IFATOM D,FCPROGN4 
FCPROGN3 PUSHNC D 
         BAL   L,EVAL 
         POPW  L 
         LM    D,A,0(L) 
         IFLIST D,FCPROGN3 
FCPROGN4 BAL   L,EVAL         EVALUATE THE LAST FORM 
* 
* UNDO BINDINGS 
* 
FCUNDO1  SL    NB,F8 
         CLI   4(NB),BINDTAG 
         BNER  E              WHEN NO BINDING 
FCUNDO2  LM    W,WW,0(NB) 
         ST    W,0(WW) 
         SL    NB,F8 
         CLI   4(NB),BINDTAG 
         BE    FCUNDO2 
         ST    NB,BINDTOP 
         RET   , 
*********************************************************************** 
* 
* UNDO  --  UNDOES BINDINGS UPTO GIVEN LIMIT 
* 
*   ARG 
*        SB : LIMIT OF UNDOING 
*   PRESERVES  SB, A, D 
* 
UNDORETN LR    A,N            ENTRY FOR TAIL REC RETURNING NIL 
* 
UNDORET  LR    L,E            ENTRY FOR TAIL RECURSION 
* 
UNDO     L     NB,BINDTOP 
         CLR   NB,SB          RETURN WHEN 
         BNHR  L                NO UNDOING REQUIRED 
         LR    NA,SB          SET UP FOR 
         LNR   X,F              "BXH" AND "BXLE" INSTRUCTIONS 
UNDO1    BXLE  NB,X,UNDO3     WHEN LIMIT REACHED, EXIT 
UNDO2    CLI   0(NB),BINDTAG  IF NOT A BOUND VAR 
         BNE   UNDO1            THEN GO UP TO NEXT 
         SLR   NB,F 
         LM    W,WW,0(NB)     W:=OLD VALUE; WW:=BOUND VAR 
         ST    W,0(WW)        RESTORE OLD VALUE 
         BXH   NB,X,UNDO2     LOOP UNTIL LIMIT 
UNDO3    ST    NB,BINDTOP     SET BINDTOP 
         BR    L                AND RETURN 
*********************************************************************** 
* 
* ENTRIES TO FUNCALL WITH FIXED NUMBER OF ARGUMENTS 
* 
FUNCALL0 LR    NA,Z 
         B     FUNCALL 
* 
FUNCALL2 LA    NA,2*4 
         B     FUNCALL 
* 
FUNCALL3 LA    NA,3*4 
         B     FUNCALL 
         TITLE 'INPUT/OUTPUT' 
*********************************************************************** 
* 
*     INPUT / OUTPUT 
* 
* NOTE : ALL THE I/O ROUTINES PRESERVE CB, SB, NB AND CONSTANT 
*        REGISTERS, IF THEY ARE LEAVED NORMALLY. 
* 
*********************************************************************** 
         USING STREAM,NA 
*********************************************************************** 
* 
* READ TABLE BITS 
* 
* FIRST BYTE = X'10'  -- INDICATING FIX NUM 
* 
* SECOND BYTE 
* 
POINT    EQU   X'80'          DECIMAL POINT 
EXPNT    EQU   X'40'          EXPONENT PART INDICATOR 
* 
* THIRD BYTE 
* 
TERM     EQU   X'80'          TERMINATES PNAMES AND NUMBERS 
SINGLE   EQU   X'40'          SINGLE CHARACTER OBJECT 
BLANK    EQU   X'20'          BLANK AND ALIKE 
LPAR     EQU   X'10'          LEFT PARENTHESIS 
DOT      EQU   X'08'          DOTTED-PAIR DOT 
RPAR     EQU   X'04'          RIGHT PARENTHESIS 
MACROCH  EQU   X'02'          MACRO CHARACTER 
STRQ     EQU   X'01'          STRING QUOTE 
* 
* FOURTH BYTE 
* 
SLASHTOP EQU   X'80'          TO BE SLASHIFIED IF TOP 
SLASH    EQU   X'40'          TO BE SLASHIFIED 
ESC      EQU   X'20'          ESCAPE CHARACTER 
ALT      EQU   X'10'          ALTERNATE MEANING 
SIGN     EQU   X'08'          SIGN 
DIG      EQU   X'04'          DIGIT 
COMBEG   EQU   X'02'          COMMENT BEGINNING CHAR 
ALPHA    EQU   X'01'          ALPHABETIC 
*********************************************************************** 
* 
* STREAM MODE BITS 
* 
INMODE   EQU   B'00000001' 
OUTMODE  EQU   B'00000010' 
*********************************************************************** 
* 
* GETCH -- ONE CHARACTER INPUT 
* 
*   ARGS 
*        NA : STREAM 
*   RESULTS 
*        W : CHARACTER READ 
*   DESTROYS 
*        L, W, WW 
* 
GETCH1   ST    L,SAVEL        SAVE RET ADDR 
         L     L,LINEIO       CALL LINE I/O ROUTINE 
         BALR  L,L 
         L     L,SAVEL        RECOVER RET ADDR 
* 
GETCH    L     WW,CURPOS      WW:=CURRENT POSITION 
         CL    WW,RECEND      IS IT AT THE END? 
         BNL   GETCH1         IF END, GET ONE LINE 
         LR    W,Z 
         IC    W,0(WW) 
         LA    WW,1(WW)       ADVANCE CURRENT POSITION 
         ST    WW,CURPOS 
         BR    L              AND RETURN 
*********************************************************************** 
* 
* PUTBACK -- ONE CHARACTER PUTTING BACK 
* 
*   ARGS 
*        NA : STREAM 
*   DESTROYS 
*        WW, L 
* 
PUTBACK  L     WW,CURPOS      CURRENT POSITION 
         BCTR  WW,0             IS BACKED BY ONE 
         ST    WW,CURPOS        AND RESAVED 
         BR    L 
*********************************************************************** 
* 
* LINEIN -- ONE LINE INPUT 
* 
*   ARGS 
*        NA : STREAM 
*        NB : TOP OF STACK (USED AS THE SAVE AREA) 
*   DESTROYS 
*        L, W, WW 
* 
LINEIN   DISABLE 
         AIF   ('&SYSTEM' EQ 'MTS').#MTSIN
         LA    1,DCB          LOAD DCB ADDRESS ON 1 
         MVI   DCBFLAG,X'00' 
         GET   (1)            GET ONE RECORD (LOCATE MODE) 
         CLI   DCBFLAG,X'00' 
         BNE   IOERR 
         L     N,NIL          RECOVER "N" 
         LH    W,DCBLRECL     COMPUTE THE END OF CURRENT REC 
         ALR   W,1              I.E. RECTOP + LRECL 
         ST    W,RECEND       AND STORE 
         TM    DCBRECFM,B'01000000' 
         BZ    FIXED          IF VARIABLE LENGTH FILE 
         ALR   1,F            THEN IGNORE RECORD DESCRIPTOR 
         AGO   .#MTSIN2
.#MTSIN  ANOP
         LA    1,IOPARL
         CALL  READ
         IF    15,EQ,=F'4'
           L     15,IOEOFAD   GOT AN EOF
           BR    15
         ENDIF
         BH    IOERR
         CLC   IOLEN+2(2),IOLEN+4 SEE IF TRUNCATED
         BL    IOERR          YES
         L     1,IOBUFAD      BEGINING OF RECORD
         LH    W,IOLEN        FIND END
         AR    W,1
         ST    W,RECEND
.#MTSIN2 ANOP
FIXED    ST    1,RECTOP       SAVE RECORD TOP 
         ST    1,CURPOS       SET CURRENT POSITION TO BE AT TOP 
         ENABLE 
         BR    L              AND RETURN 
*********************************************************************** 
* 
* TGET -- ONE LINE INPUT FROM TERMINAL 
* 
*   ARGS 
*        NA : STREAM 
*        NB : TOP OF STACK (USED AS THE SAVE AREA) 
*   DESTROYS 
*        L, W, WW 
* 
TGET     ST    A,SAVEA 
         GETVALUE PROMPT$ 
         $STRING 
         DISABLE 
         AIF   ('&SYSTEM' EQ 'MTS').#MTSTG
         L     0,0(A) 
         LA    1,4(A) 
         TPUT  (1),(0),ASIS 
         L     1,=A(TERMIBUF) 
         LA    0,255 
         CNOP  0,4 
         TGET  (1),(0) 
         LTR   15,15 
         BNZ   TGET1 
         AGO   .#MTSTG2
.#MTSTG  ANOP
TGET2    L     W,=A(TERMIBUF)
         LA    WW,256
         L     1,0(0,A)       LENGTH OF PREFIX
         LA    0,4(0,A)       LOCATION OF PREFIX
         ST    WW,0(0,W)      LENGTH OF BUFFER
         SR    WW,F
         SR    WW,F           REDUCE MAX COUNT
         MIN   1,(WW)         SHORTEN IF NECESSARY
         LR    WW,1           BOTH THE SAME
         ST    1,4(0,W)       LENGTH OF DATA
         LA    W,8(0,W)       PUT IT HERE
         MVCL  W,0            MOVE THE PREFIX
         CALL  CUINFO,(=CL8'PFXSTR',TERMIBUF)
         GUSER TERMIBUF,IBUFLEN,@MAXLEN
         LR    A,15           SAVE RETURN CODE
         CALL  CUINFO,(=CL8'PFXSTR',BLANKPFX)
         LTR   A,A
         BNZ   TGETABND       WHO KNOW'S WHAT EOF SHOULD DO HERE?
         LH    1,IBUFLEN      GET THE LENGTH READ
.#MTSTG2 ANOP
         L     W,=A(TERMIBUF) 
         CLC   0(10,W),=C'!!!!!!!!!!' 
         BE    TGETABND 
         L     0,=A(TERMIBUF) 
         ST    0,CURPOS 
         ST    0,RECTOP 
         ALR   1,0 
         MVI   0(1),C' ' 
         LA    1,1(1) 
         ST    1,RECEND 
TGET1    ENABLE 
         L     A,SAVEA 
         BR    L 
* 
         AIF   ('&SYSTEM' EQ 'MTS').#MTSTG3
TGETABND ESTAE 0 
         ABEND 1023 
         AGO   .#MTSTG4
.#MTSTG3 ANOP
TGETABND SERCOM ' End of file from GUSER'
         ERROR
         GETVALUE PROMPT$ 
         $STRING 
         B     TGET2
*
BLANKPFX DC    F'9,1',C' '
IBUFLEN  DC    H'0,255,0'
*
.#MTSTG4 ANOP
*
*********************************************************************** 
* 
* INTERNAL ENTRY FOR "PRINT" 
*   PRINTS ONE S-EXPRESSION ON STANDARD-OUTPUT STREAM 
* 
*   ARGS 
*        A : S-EXPRESSION TO BE PRINTED 
*        W  : SLASHIFICATION FLAG (LSB) 
*        PRLEV$(VALUE) : HOW MANY LEVELS SHOULD BE PRINTED 
*        PRLEN$(VALUE) : HOW MANY ITEMS IN A LIST SHOULD BE PRINTED 
*        NB : CURRENT TOP OF STACK 
* 
PRINTENT STC   W,PRFLAG       SET FLAG 
         LR    X,A            SAVE "A" ON "X" 
         GETVALUE OUTSTRM$ 
         $STREAM ,            CHECK STREAM 
         LR    NA,A 
         TM    MODE+3,OUTMODE  AND ITS MODE 
         BZ    IOERR 
         GETVALUE READTAB$ 
         $VECTOR ,            CHECK READTABLE 
         LA    W,256*4          AND ITS LENGTH 
         C     W,0(A) 
         BNE   TYPERR 
         ST    A,CURRDTB 
         GETVALUE PRLEN$ 
         LA    A,0(A) 
         ST    A,PRLEN 
         GETVALUE PRLEV$ 
         LA    A,0(A) 
         ST    A,PRLEV 
         LR    A,X 
* 
PRINT    LA    L,0(L)         CLEAR TAG 
         PUSHW L              AND SAVE RETURN ADDRESS 
PRINT1   IFATOM A,PRATOM 
         L     WW,PRLEV 
         BCT   WW,PRLIST      IF MAX LEVEL REACHED 
         L     A,QUESTION       JUST PRINT "?" 
         B     PRSY 
* 
PRLIST   ST    WW,PRLEV 
         L     WW,PRLEN 
         PUSHW WW 
         IC    W,LPARCH 
PR1      BAL   L,PUTCH 
         POPW  WW 
         BCT   WW,PR2         IF MAX LENGTH REACHED 
         TM    0(A),LISTTAG     AND CDR IS NOT AN ATOM 
         BZ    PR2 
         L     A,QUESTS       THEN PRINT "???" 
         BAL   L,PRINT 
         B     PR4 
* 
PR2      PUSHW WW 
         LM    D,A,0(A)       D:=CDR; A:=CAR 
         PUSHW D              SAVE CDR 
         BAL   L,PRINT        PRINT CAR FIRST 
         POPW  A 
         IC    W,SPACECH 
         IFLIST A,PR1         IF CDR IS LIST, CONTINUE 
         IFNULL A,PR3         ELSE IF CDR IS NON-NULL 
         BAL   L,PUTCH          THEN PUT " . " 
         IC    W,DOTCH 
         BAL   L,PUTCH 
         IC    W,SPACECH 
         BAL   L,PUTCH 
         BAL   L,PRINT        AND PRINT THE ATOM 
PR3      SLR   NB,F           DISCARD LENGTH COUNTER ON STACK 
PR4      IC    W,RPARCH       PUT THE LAST ")" 
         BAL   L,PUTCH 
         L     WW,PRLEV 
         LA    WW,1(WW)       INCREASE LEVEL COUNTER 
         ST    WW,PRLEV 
PRRET    POPW  L 
         BR    L 
* 
PRATOM   LR    W,A            IF AN ATOM IS TO BE PRINTED 
         SRL   W,26             BRANCH ON ITS TYPE 
         N     W,WORDBND 
         L     W,PRBTAB(W) 
         BR    W 
* 
PRBTAB   DS    0A 
         DC    A(SYSERR#A)    ? 
         DC    A(PRNUM)       NUMBER 
         DC    A(PRREF)       REFERENCE 
         DC    A(PRVEC)       VECTOR 
         DC    A(PRSTRNG)     STRING 
         DC    A(PRSTRM)      STREAM 
         DC    A(PRCODE)      CODE PIECE 
         DC    A(PRSY)        SYMBOL 
* 
PRNUM    CL    A,MAXFIX 
         BNL   PRFLO 
* 
* PRINT A FIXNUM 
* 
PRFIX    SLL   A,8            GET NUMERICAL VALUE OF THE NUMBER 
         SRA   A,8              BY SHIFTING LEFT AND RIGHT 
         BNM   PRFIX0         IF THE VALUE IS NEGATIVE THEN 
         LPR   A,A              GET ABSOLUTE VALUE 
         IC    W,MINUSCH        AND PUT '-' 
         BAL   L,PUTCH 
PRFIX0   L     X,STRBUFAD 
PRFIX1   LR    D,Z            (D,A) PAIR = ABSOLUTE VALUE 
         D     D,F10       CH := VALUE MOD 10 + ORD('0') 
         LA    W,C'0'(D)      VALUE := VALUE DIV 10 
         STC   W,0(X)         PUT CH IN STRBUFF 
         LA    X,1(X)         ADVANCE POINTER 
         LTR   A,A            VALUE = 0? 
         BNZ   PRFIX1         IF NOT, LOOP 
PRFIX2   BCTR  X,0            DECREASE POINTER 
         LR    W,Z            LOAD ONE CHARACTER 
         IC    W,0(X) 
         BAL   L,PUTCH 
         CL    X,STRBUFAD 
         BNE   PRFIX2 
         B     PRRET 
* 
* PRINT A FLONUM 
* 
PRFLO    LD    FR0,4(A)       FR0:=VALUE OF THE FLONUM 
         IC    W,PLUSCH       IF VALUE IS POSITIVE THEN 
         LTDR  FR0,FR0          USE PLUS SIGN 
         BNM   POSFLO         OTHERWISE 
         IC    W,MINUSCH        USE MINUS SIGN 
POSFLO   BAL   L,PUTCH        PUT SIGN 
         LA    W,C'0'         PUT "0." TO BEGIN WITH 
         BAL   L,PUTCH 
         IC    W,POINTCH 
         BAL   L,PUTCH 
         LR    D,Z            D:=0 (EXPONENTIATING PART TO BE) 
         SDR   FR2,FR2 
         LPDR  FR0,FR0        FR0:=ABS(FR0) 
         BZ    ADJUSTED       IF ZERO, NO ADJUSTMENT REQUIRED 
         LA    D,1 
         CD    FR0,FLO10      ADJUST BETWEEN 1.0 AND 10.0 
         BL    NOTBIG 
         LD    FR4,FLOTENTH 
         LD    FR6,FLOTENTH+8 
TOOBIG   MXR   FR0,FR4 
         LA    D,1(D) 
         CD    FR0,FLO10 
         BNL   TOOBIG 
         B     ADJUSTED 
* 
TOOSMALL MXD   FR0,FLO10 
         BCTR  D,0 
NOTBIG   CD    FR0,FLO1 
         BL    TOOSMALL 
ADJUSTED GETVALUE DIGITS$     A:=NUMBER OF DIGITS IN FRAC PART 
         $POSFIX ,            CHECK TYPE 
         LA    A,0(A)         CLEAR TAG 
         LTR   A,A            IF DIGITS$ = 0 THEN 
         BZ    NOFRAC           NO FRACTION PART REQUIRED 
         LR    WW,A           SAVE FRACTION LENGTH ON "WW" 
         L     X,STRBUFAD     X:=BUFFER TOP 
PRFRAC   CVTDI FR0,0(NB)      CONVERT TO INTEGER (FIRST DECIMAL DIGIT) 
         L     W,0(NB)        W:=DECIMAL VALUE 
         CVTID FR4,0(NB)      CONVERT ONE DIGIT TO FLOAT VALUE AGAIN 
         SDR   FR0,FR4        SUBTRACT THAT VALUE 
         STC   W,1(X) 
         LA    X,1(X) 
         MD    FR0,FLO10 
         BCT   A,PRFRAC 
         CD    FR0,FLO5 
         BL    PRFRAC2 
         LR    A,WW 
* 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC11 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM11 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##11 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##11
* 
.HITAC11 ANOP 
.FACOM11 ANOP 
PRFRAC1  AI    0(X),1 
         AGO   .EXIT011 
* 
.MTS##11 ANOP
.TSO##11 ANOP 
PRFRAC1  XR    W,W 
         IC    W,0(X) 
         LA    W,1(W) 
         STC   W,0(X) 
         ANOP  .EXIT011 
* 
.EXIT011 ANOP 
* 
         CLI   0(X),10 
         BNE   PRFRAC2 
         MVI   0(X),0 
         BCTR  X,0 
         BCT   A,PRFRAC1 
         AL    D,F1 
         MVI   0(X),1 
         BCTR  X,0 
         B     PRFRAC3 
PRFRAC2  L     X,STRBUFAD 
PRFRAC3  LR    A,WW 
PRFRAC4  IC    W,1(X) 
         LA    X,1(X) 
         LA    W,C'0'(W) 
         BAL   L,PUTCH 
         BCT   A,PRFRAC4 
NOFRAC   IC    W,EXPNTCH      PUT EXPONENT INDICATOR 
         BAL   L,PUTCH 
         IC    W,PLUSCH       IF EXPONENT PART IS POSITIVE 
         LTR   D,D              THEN PUT PLUS SIGN 
         BNM   PREXPNT        OTHERWISE 
         IC    W,MINUSCH        PUT MINUS SIGN 
         LPR   D,D            D:=ABS(EXPONENT PART) 
PREXPNT  BAL   L,PUTCH 
         LR    A,D 
         LR    D,Z 
         D     D,F10 
         LA    W,C'0'(A) 
         BAL   L,PUTCH 
         LA    W,C'0'(D) 
         POPW  L 
         B     PUTCH 
* 
* PRINT A SYMBOL 
* 
         USING SYMBOL,A 
PRSY     L     A,PNAME        GET PNAME 
         DROP  A 
         LR    D,Z 
         LR    W,Z            GET FIRST CHARACTER 
         IC    W,4(A) 
         LR    L,W            IS THE FIRST CHAR 
         SLA   L,2              TO BE SLASHIFIED? 
         AL    L,CURRDTB 
         TM    7(L),SLASHTOP 
         BZ    PRSY3          IF NOT, SKIP SLASHIFICATION 
PRSY2    TM    PRFLAG,1       IF SLASHIFICATION SW IS ON 
         BZ    PRSY3 
         IC    W,ESCAPECH       THEN PUT ESCAPE CHAR 
         BAL   L,PUTCH 
         LR    W,Z 
         IC    W,4(D,A) 
PRSY3    BAL   L,PUTSYCH      PUT THE CHARACTER 
         LA    D,1(D)         ADVANCE POINTER 
         C     D,0(A)         REPEAT UNTIL 
         BNL   PRRET            THE END REACHED 
         LR    W,Z            GET NEXT CHARACTER 
         IC    W,4(D,A) 
         LR    L,W            CHECK IF SLASHIFICATION NEEDED 
         SLA   L,2 
         AL    L,CURRDTB 
         TM    7(L),SLASH 
         BZ    PRSY3          IF NOT, PRINT WITHOUT SLASH 
         B     PRSY2          ELSE SLASHIFY 
* 
* PRINT CODE -- C#"ADDR" 
* 
PRCODE   IC    W,CODECH 
         BAL   L,PUTCH 
         IC    W,SEPARCH 
         BAL   L,PUTCH 
         USING CODE,A 
         L     A,FUNCNAME 
         DROP  A 
         B     PRINT1 
* 
* PRINT A STREAM -- S#"ADDR" 
* 
PRSTRM   IC    W,STRMCH 
         B     PRVEC1 
* 
* PRINT A REFERENCE -- R#"ADDR" 
* 
PRREF    IC    W,REFCH 
         B     PRVEC1 
* 
* PRINT A VECTOR -- V#"ADDR" 
* 
PRVEC    IC    W,VECCH 
PRVEC1   BAL   L,PUTCH 
         IC    W,SEPARCH 
         BAL   L,PUTCH 
         B     PRFIX 
* 
* PRINT A STRING 
* 
PRSTRNG  EQU   * 
         USING BIGCELL,A 
         LR    D,Z 
         TM    PRFLAG,1       IF SLASHIFICATION IS OFF 
         BZ    PRSTRNS          THEN PRINT WITHOUT SLASHIFICATION 
         IC    W,STRQCH 
         BAL   L,PUTCH          THEN PUT """" AT THE TOP 
         B     PRSTR4 
* 
PRSTR1   LR    W,Z            GET ONE CHARACTER 
         IC    W,4(D,A) 
         LR    L,W            CHECK IF IT IS A STRING QUOTE CHAR 
         SLA   L,2 
         AL    L,CURRDTB 
         TM    6(L),STRQ 
         BZ    PRSTR3         IF IT IS, 
         BAL   L,PUTCH          THEN DOUBLE THE CHARACTER 
         IC    W,4(D,A) 
PRSTR3   BAL   L,PUTCH        PUT THE CHARACTER 
         LA    D,1(D)         ADVANCE POINTER 
PRSTR4   C     D,LENGTH       REPEAT UNTIL END REACHED 
         BL    PRSTR1 
         IC    W,STRQCH         THEN PUT '"' AT THE END 
         POPW  L 
         B     PUTCH 
* 
PRSTRN1  IC    W,4(D,A)       PRINT WITHOUT SLASHIFICATION 
         BAL   L,PUTCH 
         LA    D,1(D) 
PRSTRNS  C     D,LENGTH 
         BL    PRSTRN1 
         B     PRRET 
         DROP  A 
*********************************************************************** 
* 
* TERPRI -- TERMINATE CURRENT LINE OF THE STANDARD-OUTPUT STREAM 
* 
*        PUTS ONE BLANK FOR NULL LINES 
* 
*   ARGS 
*        NB : CURRENT TOP OF STACK 
* 
TERPRI   GETVALUE OUTSTRM$ 
         $STREAM ,            CHECK STREAM 
         LR    NA,A 
         TM    MODE+3,OUTMODE   AND ITS MODE 
         BZ    IOERR 
         L     W,LINEIO       CALL LINE I/O ROUTINE 
         BR    W                WITH RET ADDR ON "L" 
*********************************************************************** 
* 
* PUTCH -- ONE CHARACTER OUTPUT 
* PUTSYCH -- ONE CHARACTER OUTPUT WITH CONVERSION OF CASES 
* 
*   ARGS 
*        NA : STREAM 
*        W  : CHARACTER TO BE PUT 
*   DESTROYS 
*        L, W, WW 
* 
PUTSYCH  L     WW,PRLOWER 
         C     N,0(WW) 
         BE    PUTCH 
         L     WW,=A(LCTAB) 
         IC    W,4(W,WW) 
PUTCH    L     WW,CURPOS      WW := CURRENT POSITION 
         CL    WW,RECEND       IF END  OF RECORD IS REACHED 
         BL    PUTCH$1 
         ST    W,PUTCH#W 
         ST    L,PUTCH#L 
         L     WW,LINEIO 
         BALR  L,WW 
         L     W,PUTCH#W 
         L     L,PUTCH#L 
         L     WW,CURPOS 
PUTCH$1  STC   W,0(WW)         PUT THE CHARACTER 
         LA    WW,1(WW)       ADVANCE CURRENT POSITION 
         ST    WW,CURPOS 
         BR    L 
* 
PUTCH#W  DS    F 
PUTCH#L  DS    F 
* 
*********************************************************************** 
* 
* LINE OUT -- ONE LINE OUTPUT 
* 
*   ARGS 
*        NA : STREAM 
*        NB : TOP OF STACK (USED AS THE SAVE AREA) 
*   DESTROYS 
*        L, W, WW 
* 
         AIF   ('&SYSTEM' EQ 'MTS').#MTSLO
LINEOUT  TM    DCBRECFM,B'01000000' 
         BNZ   LNOUT$V 
LNOUT$F  L     W,RECEND 
         L     WW,CURPOS 
LNOUT$F1 CLR   WW,W 
         BNL   LINEOUT1 
         MVI   0(WW),C' ' 
         LA    WW,1(WW) 
         B     LNOUT$F1 
LNOUT$V  L     W,RECTOP 
         L     WW,CURPOS 
         CLR   WW,W 
         BH    LNOUT$V1 
         MVI   0(WW),C' ' 
         LA    WW,1(WW) 
LNOUT$V1 SLR   W,F 
         SLR   WW,W 
         STH   WW,0(W) 
         STH   Z,2(W) 
LINEOUT1 DISABLE 
         LA    1,DCB 
         MVI   DCBFLAG,0 
         PUT   (1) 
         CLI   DCBFLAG,X'00' 
         BNE   IOERR 
         LH    W,DCBLRECL     COMPUTE END OF REC POSITION 
         ALR   W,1 
         ST    W,RECEND       STORE END OF RECORD POSITION 
         TM    DCBRECFM,B'01000000' 
         BZ    LINEOUT2 
         ALR   1,F 
LINEOUT2 ST    1,RECTOP       STORE RECORD TOP 
         ST    1,CURPOS       LET CURRENT POSITION AT THE TOP 
         ENABLE , 
         BR    L              AND RETURN 
*  
         AGO   .#MTSLO2
.#MTSLO  ANOP
LINEOUT  L     W,CURPOS       CURRENT POSITIONI
         IF    W,EQ,RECTOP    THEN NULL LINE
           MVI   0(W),C' '    TURN INTO BLANK LINE
           LA    W,1(0,W)
         ENDIF
         S     W,RECTOP       LENGTH
         STH   W,IOLEN        SET IT
         DISABLE
         LA    1,IOPARL
         CALL  WRITE,EXIT=IOERR
LINEOUT1 L     1,IOBUFAD      LOCN OF BUFFER
         ST    1,RECTOP
         ST    1,CURPOS
         AH    1,IOLEN+2      PLUS SIZE OF BUFFER
         ST    1,RECEND
         ENABLE
         BR    L
.#MTSLO2 ANOP
*
*********************************************************************** 
* 
* TPUT -- ONE LINE OUTPUT TO THE TERMINAL 
* 
*   ARGS 
*        NA : STREAM 
*        NB : TOP OF STACK (USED AS THE SAVE AREA) 
* DESTROYS 
*        L, W, WW 
* 
TPUT     DISABLE 
         L     1,RECTOP 
         L     15,CURPOS 
         LR    0,15 
         SLR   0,1 
         AIF   ('&SYSTEM' EQ 'MTS').#MTSTP
         C     0,LINESIZE 
         BE    TPUT1 
         MVI   0(15),X'15' 
         AL    0,F1 
TPUT1    TPUT  (1),(0),ASIS 
         AGO   .#MTSTP2
.#MTSTP  ANOP
         BCTR  1,0            PUT CARRIAGE CONTROL (BLANK) ON THE LINE
         A     0,=F'1'
         SERCOM (1),(0)
.#MTSTP2 ANOP
         L     1,RECTOP 
         ST    1,CURPOS 
         AL    1,LINESIZE 
         ST    1,RECEND 
         ENABLE 
         BR    L 
         SPACE 2
         DROP  NA             DONE WITH STREAM DSECT
         SPACE 2 
*********************************************************************** 
* 
* INTERN -- MAKE A UNIQUE SYMBOL WITH GIVEN PNAME 
* 
*   ARGS 
*        A : STRING WHICH WILL BE THE PNAME 
*        SOFTFLAG : ON WHEN THE STRING IS TO BE INTERNED SOFTLY 
*   RESULT 
*        A : ALLOCATED SYMBOL 
* 
INTRNRET LR    L,E            TAIL RECURSIVE ENTRY 
* 
INTERN   LA    L,0(L)         CLEAR TAG 
         PUSHW L              SAVE RET ADDR 
* 
* TRANSLATE TO UPPER CASE LETTERS 
* 
         LT    D,0(A)         D:=LENGTH 
         BZ    TYPERR         !NULL STRING AS PNAME 
         L     X,=A(UCTAB) 
         LA    W,4(A) 
RAISE1   C     D,F256 
         BNH   RAISE2 
         TR    0(256,W),4(X) 
         LA    W,256(W) 
         S     D,F256 
         B     RAISE1 
* 
RAISETR  TR    0(0,W),4(X) 
* 
RAISE2   BCTR  D,0 
         EX    D,RAISETR 
* 
* COMPUTE HASH VALUE 
* 
         BAL   L,HASHSTR 
* 
* GET CURRENT OBVECTOR 
* 
         LR    WW,A           SAVE THE STRING ON "WW" 
         GETVALUE OBVECT$ 
         $VECTOR , 
         USING BIGCELL,A 
         L     W,LENGTH       CHECK LENGTH OF OBVECTOR 
         LTR   W,W 
         BNP   TYPERR         OBVECTOR LENGTH = 0 
* 
* COMPUTE HASH INDEX 
* 
         LR    X,Z 
         SLDA  X,2 
         DR    X,W            X:= MOD  
         PUSHW X              SAVE INDEX 
         PUSHW A              SAVE OBVECTOR 
* 
* FIND SYMBOL WITH SAME PNAME 
* 
         L     L,CELLBODY(X)  L:=OBVECTOR ITEM (LIST TO BE SEARCHED) 
         DROP  A 
         PUSHW L 
         IFATOM L,NOTFOUND 
TESTNEXT L     A,4(L)         A:=FIRST CANDIDATE 
         $SYMBOL , 
         USING SYMBOL,A 
         L     D,PNAME        D:=PNAME OF "A" 
         DROP  A 
         L     A,0(D) 
         C     A,0(WW) 
         BNE   NOTMATCH 
         ALR   D,F            D:=FIRST CHAR POS 
         LA    X,4(WW)        X:=FIRST CHAR POS 
         LR    NA,A 
         CLCL  X,D            COMPARE CHARACTERS 
         BE    FOUND 
NOTMATCH L     L,0(L)         GET CDR OF CANDIDATE LIST 
         IFLIST L,TESTNEXT 
* 
* WHEN NOT FOUND 
*   ALLOCATE A NEW SYMBOL AND PUT IT INTO OBVECTOR 
* 
NOTFOUND TM    SOFTFLAG,1 
         BNZ   INTERNIL 
         LR    A,WW 
         BAL   L,MKSYM        MAKE A SYMBOL WITH GIVEN PNAME 
         POPW  D              D:=OBVECTOR ITEM 
         BAL   L,CONS         PUT NEW SYMBOL ON THE TOP OF THE LIST 
         POPW  D              D:=OBVECTOR 
         POPW  X              X:=INDEX 
         ST    A,4(X,D)       STORE THE CONSED LIST IN OBVECTOR 
         L     A,4(A)         A:=NEW SYMBOL 
         POPW  L 
         BR    L              RETURN 
INTERNIL LR    A,N 
         SL    NB,F16         DISCARD THREE WORDS 
         L     L,0(NB)        L:=RET ADDR 
         BR    L 
* 
* WHEN FOUND 
* 
FOUND    LR    A,L 
         SL    NB,F16         DISCARD THREE WORDS 
         L     L,0(NB)        L:=RET ADDR 
         TM    SOFTFLAG,1     IF SOFT FLAG IS ON 
         BNZR  L                THEN RETURN THE LIST 
         L     A,4(A)         OTHERWISE RETURN ONE SYMBOL 
         BR    L 
*********************************************************************** 
* 
* HASHSTR -- COMPUTES HASH VALUE OF A STRING 
* 
*   ARGS 
*        A : STRING TO BE HASHED 
*   RESULT 
*        NA : HASH VALUE (WITH 23 SIGNIFICANT BITS) 
* 
HASHSTR  LT    NA,0(A)        SUM ON "NA" 
         BZR   L 
         LR    W,Z            INDEX ON "W" 
HASHLOOP AL    NA,4(W,A)      ADD ONE WORD 
         ALR   W,F            ADVANCE INDEX 
         C     W,0(A)         LOOP UNTIL 
         BL    HASHLOOP         THE LAST WORD 
         LR    W,NA 
         SRL   W,16 
         ALR   NA,W 
         N     NA,=X'007FFFFF' 
         BR    L 
         TITLE 'ERROR HANDLING' 
*********************************************************************** 
* 
*     ERROR HANDLERS 
* 
*********************************************************************** 
UBVERRD  LR    A,D 
UBVERR   O     A,@SYMBOL 
         LA    D,UBVERR$-UBVERR$ 
         B     ERRENTRY 
* 
TYPERR1  L     A,LOCAL1 
         B     TYPERR 
TYPERR2  L     A,LOCAL2 
         B     TYPERR 
TYPERR3  L     D,LOCAL3 
TYPERRD  LR    A,D 
TYPERR   LA    D,TYPERR$-UBVERR$ 
         B     ERRENTRY 
* 
FNERR    LA    D,FNERR$-UBVERR$ 
         B     ERRENTRY 
* 
UDFERR   LR    A,CB 
UDFERRA  LA    D,UDFERR$-UBVERR$ 
         B     ERRENTRY 
* 
IMPLERR  LA    D,IMPLERR$-UBVERR$ 
         B     ERRENTRY 
* 
         AIF   ('&SYSTEM' EQ 'MTS').ESTAERR
ESTAERR  LA    D,ESTAERR$-UBVERR$ 
         B     ERRENTRY 
.ESTAERR ANOP
* 
VARERR   LA    D,VARERR$-UBVERR$ 
         B     ERRENTRY 
* 
PARAMERR LA    D,PARERR$-UBVERR$ 
         B     ERRNIL 
* 
INDEXERR LA    D,INDERR$-UBVERR$ 
         B     ERRENTRY 
* 
READERR  LA    D,READERR$-UBVERR$ 
         LR    A,NA 
         B     ERRENTRY 
* 
IOERR    LA    D,IOERR$-UBVERR$ 
         ENABLE , 
         B     ERRNIL 
* 
OPENERR  LA    D,OPENERR$-UBVERR$ 
         ENABLE , 
         B     ERRENTRY 
* 
EOFERR   ENABLE , 
         LR    A,NA 
         BAL   L,UNDO 
         ST    A,LOCAL1 
         LA    NB,LOCAL2 
         LR    D,A 
         L     A,CLOSE 
         BAL   L,FUNCALLD 
         L     D,LOCAL1 
         LA    NB,LOCAL1 
         GETVALUE EOFERR$ 
         B     FUNCALDR 
* 
RETERR   LA    D,RETERR$-UBVERR$ 
         B     ERRNIL 
* 
GOERR    LA    D,GOERR$-UBVERR$ 
         B     ERRENTRY 
* 
CATCHERR LA    D,CTCHERR$-UBVERR$ 
         B     ERRENTRY 
* 
FPOFERR  LA    D,FPOFERR$-UBVERR$ 
         B     ERRNIL 
* 
DIVERR   LA    D,DIVERR$-UBVERR$ 
         B     ERRNIL 
* 
BUFFERR  LA    D,BUFFERR$-UBVERR$ 
ERRNIL   LR    A,N 
ERRENTRY BAL   L,UNDO 
         ST    A,LOCAL4 
         LA    NB,LOCAL1 
         LR    A,D 
         AL    A,=A(UBVERR$) 
         VALUEA , 
         TAILREC FUNCALL1 
*********************************************************************** 
* 
* STDERR -- STANDARD ERROR HANDLER 
*   ARGS 
*        X : MESSAGE IDENTIFYING ERROR KIND (STRING) 
*        LOCAL1 : FURTHER ERROR INFORMATION 
* 
STDERR   ST    X,LOCAL3       SAVE ERROR MESSAGE 
         LA    NB,LOCAL4 
         L     A,TERMOUT 
         BINDQ OUTSTRM$,A 
         BAL   L,TERPRI 
         L     A,LOCAL3 
         LR    W,Z            PRINT ERROR MESSAGE 
         BAL   L,PRINTENT       WITHOUT SLASHIFICATION 
         BAL   L,TERPRI 
         L     A,LOCAL1 
         LA    W,1            PRINT ERROR INFORMATION 
         BAL   L,PRINTENT       WITH SLASHIFICATION 
         L     A,ERRMSG1 
         LR    W,Z 
         BAL   L,PRINTENT 
         LT    A,LOCAL2 
         BNZ   STDERR1 
         L     A,OLDCB 
STDERR1  LA    W,1 
         BAL   L,PRINTENT 
         BAL   L,TERPRI 
         UNDO  , 
         GETVALUE BREAK$ 
         TAILREC FUNCALL0 
* 
OVFLERR  TPUT2 OVFLMSG,L'OVFLMSG 
         TM    INGC,X'FF' 
         BNZ   OVFLINGC 
OVFLERR1 LM    0,1,REGINIT 
         L     SB,STACKBTM 
         LA    L,TOPLOOP 
         B     UNDO 
* 
OVFLINGC TPUT2 FATALMSG,L'FATALMSG 
         AIF   ('&SYSTEM' EQ 'MTS').#MTSTP5
         ESTAE 0 
         ABEND 4095 
         AGO   .#MTSTP6
.#MTSTP5 ANOP
         ERROR
         B     OVFLINGC
.#MTSTP6 ANOP
* 
SPACERR  TPUT2 SPACEMSG,L'SPACEMSG 
         B     OVFLERR1 
* 
FIXERR   TPUT2 FIXMSG,L'FIXMSG 
         B     OVFLERR1 
* 
SYSERR#A TPUT2 SYSEAMSG,L'SYSEAMSG 
         B     SYSERREN 
* 
SYSERR#B TPUT2 SYSEBMSG,L'SYSEBMSG 
         B     SYSERREN 
* 
SYSERR#C TPUT2 SYSECMSG,L'SYSECMSG 
         AIF   ('&SYSTEM' EQ 'MTS').#MTSTP7
*        B     SYSERREN 
SYSERREN ESTAE 0 
         ABEND 4095 
         AGO   .#MTSTP8
.#MTSTP7 ANOP
         B     SYSERREN
*
SYSERR#D TPUT2 SYSEDMSG,L'SYSEDMSG
         B     SYSERREN
*
SYSERREN ERROR
         B     SYSERREN
.#MTSTP8 ANOP
*
TPUT2    DISABLE
         AIF   ('&SYSTEM' EQ 'MTS').TPUTMTS
         TPUT  (1),(0)
         AGO   .TPUTEND
.TPUTMTS SERCOM (1),(0)
.TPUTEND ENABLE
         BR    L
*
* 
OTHERS   CSECT
OVFLMSG  DC    C'*** RUN TIME STACK OVERFLOW' 
FATALMSG DC    C'!!!! FATAL WHILE GARBAGE COLLECTION !!!!' 
SPACEMSG DC    C'*** NOT ENOUGH SPACE COLLECTED' 
FIXMSG   DC    C'*** NOT ENOUGH SPACE IN FIXED HEAP' 
SYSEAMSG DC    C'!!!! SYSTEM ERROR (PRINT ATOM) !!!!' 
SYSEBMSG DC    C'!!!! SYSTEM ERROR (GARBAGE COLLECTION) !!!!' 
SYSECMSG DC    C'!!!! SYSTEM ERROR (READ MACRO) !!!!' 
         AIF   ('&SYSTEM' NE 'MTS').NOSYSED
SYSEDMSG DC    C'!!!! SYSTEM ERROR (COMMAND CALL) !!!!' 
.NOSYSED ANOP
MAIN     CSECT 
* 
ERRMSG1  STRNGCON ERRM1 
ERRM1    STRING ' -- ' 
*********************************************************************** 
* 
* PROGRAM INTERRUPT EXITS 
* 
OTHERS   CSECT
*
         DS    0H 
         USING *,15 
SPIEXIT  TM    DISABLED,X'FF' 
         BNZR  14 
         CLI   7(1),X'0C' 
         BE    SPIOVFL 
         CLI   7(1),X'1C' 
         BE    SPIOVFL 
         LA    0,DIVERR 
         STCM  0,B'0111',9(1) 
         BR    14 
SPIOVFL  LA    0,FPOFERR 
         STCM  0,B'0111',9(1) 
         BR    14 
*********************************************************************** 
* 
* ATTENTION INTERRUPT HANDLER 
* 
         DS    0H 
         USING *,15 
ATTNEXIT SAVE  (14,12) 
         LM    E,E2,BASEADR-ATTNEXIT(15) 
         DROP  15 
         LR    CB,15
         USING ATTNEXIT,CB
         MVI   ATTNFLG,X'FF' 
*
         AIF   ('&SYSTEM' EQ 'MTS').MTSATTN
         TM    DISABLED,X'FF' 
         BNZ   ATTNDABL 
         L     1,0(1)         TAIE ADDR ON 1 
         L     1,4(1)         R1:=INTERRUPTED ADDRESS 
         MVC   ATTNSAVE(4),0(1) 
         MVC   0(4,1),ATTNBAL 
ATTNR    RETURN (14,12) 
* 
ATTNDABL TM    TASKFLAG,X'FF' 
         BZ    ATTNR 
         POST  TASKECB 
         STATUS STOP,TCB=TCBADDR 
         B     ATTNR 
*
         DROP  CB
*
         AGO   .MTSATN2
.MTSATTN ANOP
         IF    DISABLED,NE,0  THEN ATTNS ARE DISABLED
           MVI   0(1),X'FF'   SIGNAL RESTART
         ELSE
           MVI   0(1),0       NO RESTART
         ENDIF
         LA    0,ATTNEXIT     REENABLE THE EXIT
         L     13,=A(SAVEAREA)
         CALL  ATTNTRP
         LM    4,15,8+4*4(1)  RESTORE REGISTERS TO POINT OF ATTN
         DROP  CB
         B     ATTNHND1       IF WE DIDN'T RESTART, TAKE THE ATTN
*
ATTNAREA DS    0F,XL8,16A
.MTSATN2 ANOP
* 
BASEADR  DC    A(MAIN) 
         DC    A(MAIN+4096) 
*        
MAIN     CSECT
* 
         AIF   ('&SYSTEM' EQ 'MTS').MTSATN3
ATTNSAVE DS    4C 
ATTNBAL  BAL   L,ATTNHNDL 
*
ATTNHNDL MVI   DISABLED,X'00' 
         SLR   L,F 
         MVC   0(4,L),ATTNSAVE 
.MTSATN3 ANOP
*
ATTNHND1 MVI   ATTNFLG,X'00' 
         LM    0,1,REGINIT 
         L     A,TERMIN 
         USING STREAM,A 
         XC    CURPOS(12),CURPOS 
         DROP  A 
         BAL   L,UNDO 
         LA    NB,LOCAL1 
         GETVALUE ATNHNDL$ 
         TAILREC FUNCALL0 
         TITLE 'FUNCTION "EQUAL"' 
* 
* EQUAL  -  TESTS IF TWO S-EXPRS ARE "EQUAL" 
* 
*   ARGS 
*        D,A : TWO S-EXPRS TO BE TESTED 
*   RESULT 
*        A : T OR NIL DEPENDING ON THE RESULT 
* 
EQUAL    LR    NA,NB 
         LA    X,8 
         B     EQUAL2 
* 
EQUALOK  CLR   NB,NA 
         BER   L 
EQUALPOP SLR   NB,X 
         LM    D,A,0(NB) 
EQUAL2   CR    D,A 
         BE    EQUALOK 
EQUAL3   IFLIST A,EQUALLST 
         IFNOTSTR D,EQUALFLO 
         IFNOTSTR A,EQUALNIL 
         L     WW,0(A)        WW:=STRING LENGTH 
         C     WW,0(D)        IF LENGTH IS NOT EQUAL 
         BNE   EQUALNIL         THEN NIL 
         LA    W,4(A)         W:=FIRST CHAR POS 
         ALR   D,F            D:=FIST CHAR POS OF ANOTHER 
         LR    A,WW           A:=STRING LENGTH 
         CLCL  D,W            COMPARE CHARACTERS 
         BE    EQUALOK 
EQUALNIL LR    NB,NA 
         CR    E,E2           SET "NE" FLAG 
         BR    L 
* 
EQUALFLO IFNOTFLO A,EQUALNIL 
         IFNOTFLO D,EQUALNIL
         LD    FR0,4(A) 
         CD    FR0,4(D) 
         BE    EQUALOK 
         LR    NB,NA 
         BR    L 
* 
* 
EQUALLST IFATOM D,EQUALNIL 
         LM    W,WW,0(A) 
         PUSHW W 
         LM    D,A,0(D) 
         PUSHW D 
         LR    D,WW 
         CR    A,D 
         BNE   EQUAL3 
         CLR   NB,NA 
         BNE   EQUALPOP 
         BR    L 
* 
*  CSECT CHANGES "INIT" 
* 
         TITLE 'INITIATION' 
************************************************* 
INIT     CSECT 
         ACTR  4096 
START    SAVE  (14,12) 
         DROP  E,E2 
         USING START,15 
         ST    13,SAVEAREA+4 
         LM    2,3,INITREG+8 
         USING MAIN,E,E2 
         LR    CB,15 
         DROP  15 
         USING START,CB 
         LA    13,SAVEAREA 
*
         AIF   ('&SYSTEM' EQ 'MTS').INITMTS
*
**************************************************************** 
* 
*  OBTAIN UPT, ECT AND PSCB FROM EXTRACT MACRO. 
* 
***************************************************************** 
START$0  LR    X,1            ; SAVE R1  INTO X. 
* 
         EXTRACT TSS#PSCB,'S',FIELDS=(PSB) 
         L     W,TSS#PSCB 
         LTR   W,W 
         BZ    JCLBATCH 
         ST    W,TSS#PSCB 
         L     WW,48(W) 
         L     WW,256(WW) 
         ST    WW,TSS#ECT 
         L     WW,52(W) 
         ST    WW,TSS#UPT 
         L     WW,TSS#ECT 
         TM    28(WW),X'02' 
         BZ    TSSMODE 
TSSBATCH DS    0H 
         MVI   TSS#MODE,X'FF' 
         B     START$1 
* 
TSSMODE  DS    0H 
         MVI   TSS#MODE,X'00' 
         B     START$1 
* 
JCLBATCH DS    0H 
         ABEND  0 
* 
START$1  DS    0H 
         LR    1,X 
* 
         CLC   TSS#UPT(12),4(1) 
         BE    START$2 
* 
* 
* 
*  THIS PROGRAM MAY BE EXECUTED BY CALL COMMAND. 
* 
START$A  DS    0H 
         L     W,0(1) 
         LH    NA,0(W)        ; SOURCE LENGTH 
         LTR   NA,NA 
         BZ    START$3 
         LA    X,2(W)         ; SOURCE ADDR. 
         LA    W,8+2+2(NA) 
         STH   W,TSS#CMD 
         LA    D,TSS#CMD+2+2+8 
         LR    A,NA           ; DEST. LENGTH 
         MVCL  D,X 
* 
START$3  LA    1,TSS#CPPL 
* 
START$2  DS    0H 
         LM    4,7,0(1) 
         LA    8,ECTCOPY 
         MVC   0(56,8),0(7) 
         STM   4,6,CPPLCOPY 
         ST    8,ECTADDR 
         ST    4,LST$BUFF 
         ST    5,LST$UPT 
         ST    8,LST$ECT 
         LA    1,PARSELST 
         LINK EP=&JET.PARS,MF=(E,(1)) 
         LTR   15,15 
         BNZ   INITERR 
* 
* SET LINESIZE OF TERMINAL 
* 
         GTSIZE ,             GET TERMINAL LINE SIZE 
         ST    1,LINESIZE 
* 
*  ANALYSIS OF COMMAND'S OPERANDS 
* 
************************************************************ 
*   DEFINITIONS OF TSS COMMAND OPERANDS 
*    CAUTION : CSECT CHANGED 
******** 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC09 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM09 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##09 
* 
**************************** 
*  START OF TEMPLATE 
* 
*PCL      &JET.PARM DSECT=PDL 
*PDL$STCK &JET.KEYWD 
*         &JET.NAME 'STACK',SUBFLD=STCKSZ 
*PDL$RET  &JET.KEYWD 
*         &JET.NAME 'SAVE',SUBFLD=SAVSZ 
*PDL$FIX  &JET.KEYWD 
*         &JET.NAME 'FIX',SUBFLD=FIXSZ 
*PDL$SYS  &JET.KEYWD 
*         &JET.NAME 'LISPSYS',SUBFLD=LISPSYS 
*PDL$MID  &JET.KEYWD 
*         &JET.NAME 'MANAGER',SUBFLD=MID 
*PDL$PARM &JET.KEYWD 
*         &JET.NAME 'SYSPARM',SUBFLD=SYSPARM 
*PDL$HELP &JET.KEYWD DEFAULT='NOHELP' 
*         &JET.NAME 'HELP',ALIAS=('H','SYNTAX','S') 
*         &JET.NAME 'NOHELP' 
** 
*STCKSZ   &JET.SUBF 
*STCKSZ1  &JET.IDENT 'PAGES(DECIMAL)',INTEG 
*SAVSZ    &JET.SUBF 
*SAVSZ1   &JET.IDENT 'PAGES(DECIMAL)',INTEG 
*FIXSZ    &JET.SUBF 
*FIXSZ1   &JET.IDENT 'PAGES(DECIMAL)',INTEG 
*LISPSYS  &JET.SUBF 
*LISPSYS1 &JET.POSIT DSNAME,USID 
*MID      &JET.SUBF 
*MID1     &JET.POSIT USERID 
*SYSPARM  &JET.SUBF 
*SYSPARM1 &JET.IDENT 'SYSPARM(.....)',CHAR 
*         &JET.ENDP 
* 
*  END OF TEMPLATE 
*********************** 
* 
.HITAC09 ANOP 
* 
******************************* 
*  START OF "HITAC" 
* 
PCL      JETPARM DSECT=PDL 
PDL$STCK JETKEYWD 
         JETNAME 'STACK',SUBFLD=STCKSZ 
PDL$RET  JETKEYWD 
         JETNAME 'SAVE',SUBFLD=SAVSZ 
PDL$FIX  JETKEYWD 
         JETNAME 'FIX',SUBFLD=FIXSZ 
PDL$SYS  JETKEYWD 
         JETNAME 'LISPSYS',SUBFLD=LISPSYS 
PDL$MID  JETKEYWD 
         JETNAME 'MANAGER',SUBFLD=MID 
PDL$PARM JETKEYWD 
         JETNAME 'SYSPARM',SUBFLD=SYSPARM 
PDL$HELP JETKEYWD DEFAULT='NOHELP' 
         JETNAME 'HELP',ALIAS=('H','SYNTAX','S') 
         JETNAME 'NOHELP' 
* 
STCKSZ   JETSUBF 
STCKSZ1  JETIDENT 'PAGES(DECIMAL)',INTEG 
SAVSZ    JETSUBF 
SAVSZ1   JETIDENT 'PAGES(DECIMAL)',INTEG 
FIXSZ    JETSUBF 
FIXSZ1   JETIDENT 'PAGES(DECIMAL)',INTEG 
LISPSYS  JETSUBF 
LISPSYS1 JETPOSIT DSNAME,USID 
MID      JETSUBF 
MID1     JETPOSIT USERID 
SYSPARM  JETSUBF 
SYSPARM1 JETIDENT 'SYSPARM(.....)',CHAR 
         JETENDP 
* 
* END OF "HITAC" 
************************** 
         AGO   .EXIT009 
* 
.FACOM09 ANOP 
* 
******************************* 
*  START OF "FACOM" 
* 
PCL      KEQPARM DSECT=PDL 
PDL$STCK KEQKEYWD 
         KEQNAME 'STACK',SUBFLD=STCKSZ 
PDL$RET  KEQKEYWD 
         KEQNAME 'SAVE',SUBFLD=SAVSZ 
PDL$FIX  KEQKEYWD 
         KEQNAME 'FIX',SUBFLD=FIXSZ 
PDL$SYS  KEQKEYWD 
         KEQNAME 'LISPSYS',SUBFLD=LISPSYS 
PDL$MID  KEQKEYWD 
         KEQNAME 'MANAGER',SUBFLD=MID 
PDL$PARM KEQKEYWD 
         KEQNAME 'SYSPARM',SUBFLD=SYSPARM 
PDL$HELP KEQKEYWD DEFAULT='NOHELP' 
         KEQNAME 'HELP',ALIAS=('H','SYNTAX','S') 
         KEQNAME 'NOHELP' 
* 
STCKSZ   KEQSUBF 
STCKSZ1  KEQIDENT 'PAGES(DECIMAL)',INTEG 
SAVSZ    KEQSUBF 
SAVSZ1   KEQIDENT 'PAGES(DECIMAL)',INTEG 
FIXSZ    KEQSUBF 
FIXSZ1   KEQIDENT 'PAGES(DECIMAL)',INTEG 
LISPSYS  KEQSUBF 
LISPSYS1 KEQPOSIT DSNAME,USID 
MID      KEQSUBF 
MID1     KEQPOSIT USERID 
SYSPARM  KEQSUBF 
SYSPARM1 KEQIDENT 'SYSPARM(.....)',CHAR 
         KEQENDP 
* 
* END OF "FACOM" 
*********************** 
         AGO   .EXIT009 
* 
.TSO##09 ANOP 
* 
*********************************** 
*  START OF "TSO" 
* 
PCL      IKJPARM DSECT=PDL 
PDL$STCK IKJKEYWD 
         IKJNAME 'STACK',SUBFLD=STCKSZ 
PDL$RET  IKJKEYWD 
         IKJNAME 'SAVE',SUBFLD=SAVSZ 
PDL$FIX  IKJKEYWD 
         IKJNAME 'FIX',SUBFLD=FIXSZ 
PDL$SYS  IKJKEYWD 
         IKJNAME 'LISPSYS',SUBFLD=LISPSYS 
PDL$MID  IKJKEYWD 
         IKJNAME 'MANAGER',SUBFLD=MID 
PDL$PARM IKJKEYWD 
         IKJNAME 'SYSPARM',SUBFLD=SYSPARM 
PDL$HELP IKJKEYWD DEFAULT='NOHELP' 
         IKJNAME 'HELP',ALIAS=('H','SYNTAX','S') 
         IKJNAME 'NOHELP' 
* 
STCKSZ   IKJSUBF 
STCKSZ1  IKJIDENT 'PAGES(DECIMAL)',INTEG 
SAVSZ    IKJSUBF 
SAVSZ1   IKJIDENT 'PAGES(DECIMAL)',INTEG 
FIXSZ    IKJSUBF 
FIXSZ1   IKJIDENT 'PAGES(DECIMAL)',INTEG 
LISPSYS  IKJSUBF 
LISPSYS1 IKJPOSIT DSNAME,USID 
MID      IKJSUBF 
MID1     IKJPOSIT USERID 
SYSPARM  IKJSUBF 
SYSPARM1 IKJIDENT 'SYSPARM(.....)',CHAR 
         IKJENDP 
* 
* END OF "TSO" 
******************* 
         AGO   .EXIT009 
* 
* 
.EXIT009 ANOP 
* 
* 
******** 
*  END OF DEFINITIONS 
* 
********************************************** 
INIT     CSECT 
* 
* KEYWORD (HELP/H/SYNTAX/S) 
* 
         L     W,PRSRET 
         USING PDL,W 
* 
         LH    WW,PDL$HELP 
         C     WW,=F'1' 
         BNE   INIT$2 
* 
* PRINT HELP MESSAGES 
* 
         LA    13,SAVEAREA 
         PUTLINE PARM=PUTLPARM,UPT=UPTADDR,ECT=ECTADDR,                *
               OUTPUT=(HELPMSG,MULTLIN,DATA),MF=(E,IOPLPARM) 
* 
         XR    15,15 
         L     13,SAVEAREA+4 
         RETURN (14,12),RC=(15) 
* 
IOPLPARM DC    A(0) 
         DC    A(0) 
         DC    A(IOPLECB) 
         DC    A(0) 
* 
IOPLECB  DC    A(0) 
* 
PUTLPARM PUTLINE ,MF=L 
* 
HELPMSG  DS    0D 
HLPMSG0  DC    A(HLPMSG1) 
         DC    AL2(HLPMSG0@-*),AL2(0) 
         DC    C'  ' 
HLPMSG0@ DS    0C 
* 
HLPMSG1  DC    A(HLPMSG2) 
         DC    AL2(HLPMSG1@-*),AL2(0) 
         DC    C'  --SYNTAX--' 
HLPMSG1@ DS    0C 
* 
HLPMSG2  DC    A(HLPMSG3) 
         DC    AL2(HLPMSG2@-*),AL2(0) 
         DC    C'  ' 
         DC    70C'-' 
HLPMSG2@ DS    0C 
* 
HLPMSG3  DC    A(HLPMSG4) 
         DC    AL2(HLPMSG3@-*),AL2(0) 
         DC    C'  UTILISP  ' 
         DC    C'`,HELP/H/SYNTAX/Sń' 
HLPMSG3@ DS    0C 
* 
HLPMSG4  DC    A(HLPMSG5) 
         DC    AL2(HLPMSG4@-*),AL2(0) 
         DC    CL11'  -------' 
         DC    CL30'`,SAVE(''SIZE IN KW'')ń' 
         DC    C'<<&SAVE>>' 
HLPMSG4@ DS    0C 
* 
HLPMSG5  DC    A(HLPMSG6) 
         DC    AL2(HLPMSG5@-*),AL2(0) 
         DC    CL11' ' 
         DC    CL30'`,STACK(''SIZE IN KW'')ń' 
         DC    C'<<&STACK>>' 
HLPMSG5@ DS    0C 
* 
HLPMSG6  DC    A(HLPMSG7) 
         DC    AL2(HLPMSG6@-*),AL2(0) 
         DC    CL11' ' 
         DC    CL30'`,FIX(''SIZE IN KW'')ń' 
         DC    C'<<&FIX>>' 
HLPMSG6@ DS    0C 
* 
HLPMSG7  DC    A(HLPMSG8) 
         DC    AL2(HLPMSG7@-*),AL2(0) 
         DC    CL11' ' 
         DC    CL30'`,MANAGER(''UID'')ń' 
         DC    C'<<&SYSID>>' 
HLPMSG7@ DS    0C 
* 
HLPMSG8  DC    A(HLPMSG9) 
         DC    AL2(HLPMSG8@-*),AL2(0) 
         DC    CL11' ' 
         DC    CL30'`,LISPSYS(''DATA SET NAME'')ń' 
         DC    C'<<''&SYSID&FILESEP&LISPSYS''>>' 
HLPMSG8@ DS    0C 
* 
HLPMSG9  DC    A(0) 
         DC    AL2(HLPMSG9@-*),AL2(0) 
         DC    CL11' ' 
         DC    C'`,SYSPARM(''CHARACTER STRING'')ń' 
HLPMSG9@ DS    0C 
* 
         AGO   .INIMTS2
.INITMTS ANOP
*
         MVC   PAR$(END$INIT-INIT$PAR),INIT$PAR SET INITIAL VALUES
         LTR   X,1            SAVE PARAMETER LOCN
         IF    (NZ),AND,('LT X,0(X)',NZ)  THEN WE HAVE ONE
           LH    NA,0(0,X)    GET LENGTH
           IF    NA,NZ        THEN NOT NULL
             LA    D,2(0,X)   POINT TO PAR STRING
             CALL  KWSCAN,(LHTLEN,LHT,EXT,(D),RHT,(X),KWSWS,0,0,0,0),VL
             IF    15,NZ      THEN KWSCAN PUNTED
               EXIT 4
             ENDIF
           ENDIF
         ENDIF
*
         LM    0,1,=CL8'SERCOM' GET SERCOM LINE WIDTH
         CALL  GDINFO
         IF    15,Z
           LR    D,1
           USING GDDSECT,D
           IF    (GDLENSW:GDSWS2),AND,                                 @
               (GDLEN,GE,=AL2(GDWIDTH+2-GDDSECT),CLC)
             LH    X,GDWIDTH  USE TERMINAL WIDTH
           ELSE
             LH    X,GDOUTLEN USE TRUNCATION LENGTH
           ENDIF
           FREESPAC (D)       FREE THE GDINFO STUFF
           DROP  D
         ELSE  ,              SERCOM NOT ASSIGNED !?!
           LA    X,72
         ENDIF
         ST    X,LINESIZE
*
         B     INIT$0
*
LHTLEN   DC    Y(LHTEND-LHT)
         DS    0F
KWSWS    DC    X'0000C037'
*
         KWSET RHTABLE=RHT,EXTABLE=EXT,LHTL=2
*
LHT      KWLHT RHTNUM,EXTSTACK,STACK
         KWLHT RHTNUM,EXTFIX,FIX 
         KWLHT RHTNUM,EXTSIZE,SIZE
         KWLHT RHTFILE,EXTLISPSYS,LISPSYS
         KWLHT RHTCCID,EXTMANAGER,MANAGER
         KWLHT RHTNULL,EXTHELP,HELP
         KWLHT RHTNULL,EXTHELP,H
         KWLHT RHTNULL,EXTHELP,SYNTAX
         KWLHT RHTNULL,EXTHELP,S
         KWLHT RHTSTRING,EXTSYSPARM,SYSPARM
LHTEND   EQU   *
*
         KWSET LHTL=2         RESET RHTABLE AND EXTABLE VALUES
*
RHT      DS    0H
*
RHTNUM   KWRHT INTEGER,0,(P,1),(>,1)
         KWRHT END
*
RHTFILE  KWRHT CHARS,0,1,44
         KWRHT END
*
RHTCCID  KWRHT CHARS,0,4,4
         KWRHT END
*
RHTNULL  KWRHT NORHS,0
         KWRHT END
*
RHTSTRING KWRHT DCHARS,0,1,127,'O''"'
         KWRHT END
*
EXT      DS    0H
*
EXTSTACK ST    2,STCKSZ1
*
EXTFIX   ST    2,FIXSZ1
*
EXTSIZE  ST    2,SIZESZ1
*
EXTLISPSYS STM 1,2,LISPSYS1
*
EXTMANAGER STM 1,2,MID1
*
EXTHELP  MVI   HELPSW,1
*
EXTSYSPARM STM 1,2,SYSPARM1
*
PAR$
STCKSZ1  DC    F'&STACK'
FIXSZ1   DC    F'&FIX'
SIZESZ1  DC    F'&SIZE'
LISPSYS1 DC    F'-1',A(0)
MID1     DC    F'-1',A(0)
SYSPARM1 DC    F'-1',A(0)
HELPSW   DC    X'0'
*
INIT$PAR DC    F'&STACK'
         DC    F'&FIX'
         DC    F'&SIZE'
         DC    F'-1',A(0)
         DC    F'-1',A(0)
         DC    F'-1',A(0)
         DC    X'0'
END$INIT EQU   *
*
INIT$0   IF    HELPSW,NE,0    THEY WANT SOME HELP HERE
           PMSG  HELPMSG
           EXIT  0
         ENDIF
         B     INIT$2
*
HELPMSG  PHRASE ' ',/
         PHRASE '  Parameters for UTILISP:',/
         PHRASE '     HELP,H,SYNTAX,S',/
         PHRASE '     SIZE=Memory size in pages'
         PHRASE COL(45),'(&SIZE pages)',/
         PHRASE '     STACK=Stack size in pages'
         PHRASE COL(45),'(&STACK pages)',/
         PHRASE '     FIX=Fixed heap size in pages'
         PHRASE COL(45),'(&FIX pages)',/
         PHRASE '     MANAGER=CCID of manager'
         PHRASE COL(45),'(&SYSID)',/
         PHRASE '     LISPSYS=FDname to initialize from'
         PHRASE COL(45),'(&SYSID&FILESEP&LISPSYS)',/
         PHRASE '     SYSPARM=''Arbitrary character string'''
         PHRASE COL(45),'(null string)',/
         PHRASE ' '
         PHRASE END
*
.INIMTS2 ANOP
*    
* 
*  KEYWORD (LISPSYS) 
* 
INIT$2   DS    0H 
         AIF   ('&SYSTEM' EQ 'MTS').INIMTS3
         TM    LISPSYS1+6,X'80' 
         BZ    DSDFLT 
         LA    X,TUSYSNAM+6   ; X:= DEST. ADDR. 
         LA    NA,44          ; NA :=DEST. LENGTH 
         L     D,LISPSYS1     ; D :=SOURCE ADDR. 
         LH    A,LISPSYS1+4   ; A := SOURCE LENGTH 
         ICM   A,B'1000',MVCLPAD 
         MVCL  X,D 
         TM    LISPSYS1+14,X'80' 
         BZ    INIT$1 
         MVI   ALL$NAM,X'00' 
         MVI   ALL$MEM,X'80' 
         LA    X,TUMEMBER+6 
         LA    NA,8 
         L     D,LISPSYS1+8 
         LH    A,LISPSYS1+12 
         ICM   A,B'1000',MVCLPAD 
         MVCL  X,D 
         B     INIT$1 
* 
DSDFLT   DS    0H 
         TM    LISPSYS1+14,X'80' 
         DROP  W 
         BNZ   DSERR 
*
         AGO   .INIMTS4
.INIMTS3 L     D,LISPSYS1+4   LOCN OF NEW FILE NAME
         IF    D,NZ
           L     A,LISPSYS1   LENGTH - 1
           LA    A,1(0,A)
           ICM   A,B'1000',MVCLPAD PAD WITH BLANKS
           LA    X,TUSYSNAM   PUT IT HERE
           LA    NA,44        IT'S THIS LONG
           MVCL  X,D
         ENDIF
*
.INIMTS4 ANOP
* 
* 
* INITIATION OF STORAGE 
* 
INIT$1   DS    0H 
         AIF   ('&SYSTEM' EQ 'MTS').INIMTS5
         L     A,PRSRET 
         USING PDL,A 
         GETMAIN VC,LA=MINMAX,A=INITTEMP 
         L     NB,INITTEMP    NB:=TOP OF AVAILABLE MEMORY 
         AGO   .INIMTS6
.INIMTS5 L     1,SIZESZ1      SIZE IN PAGES
         SLL   1,12 
         GETSPACE (1),T=3
         ST    1,INITTEMP
         MVC   INITTEMP+4,0(1)
         LR    NB,1
.INIMTS6 ANOP
         ST    NB,BINDTOP     THIS WILL BE THE STACK BOTTOM 
         ST    NB,STACKBTM 
         LR    SL,NB          SET STACK LIMIT 
* 
* STACK (  ) : STACK SIZE(DEFAULT IS  &STACK KW) 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INIMTS7
         LA    D,&STACK 
         TM    STCKSZ1+6,X'80' 
         BZ    STCKDFLT 
         L     D,STCKSZ1        GET STACK SIZE 
         L     D,0(D)           SPECIFIED AS PARAMETER 
         AGO   .INIMTS8
.INIMTS7 L     D,STCKSZ1      STACK SIZE
.INIMTS8 ANOP
STCKDFLT SLA   D,12             IT IS IN KILO WORDS 
         ALR   SL,D           STACK LIMIT IS SET 
         LR    WW,SL          THIS WILL BE THE BOTTOM OF HEAP 
         AL    WW,F4096       4K BYTE FOR STACK TOP FRAME 
         ST    WW,FIXTOP      SET FIXED HEAP TOP 
         L     W,INITTEMP+4   W:=AVAILABLE MEMORY SIZE 
         CLR   W,D            ; CHECK IF W>D 
         BNH   MEMSMALL 
         SLR   W,D            SUBTRACT SPACE FOR STACK 
         CL    W,F4096        ; CHECK IF W>4096 
         BNH   MEMSMALL 
         SL    W,F4096          AND STACK TOP FRAME 
* 
* SAVE  (  ) : SAVE SIZE(DEFAULT IS  &SAVE KW) 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INIMTS9
         LA    X,&SAVE 
         TM    SAVSZ1+6,X'80' 
         BZ    SAVDFLT 
         L     X,SAVSZ1       GET RETURN SIZE 
         L     X,0(X)           SPECIFIED AS PARAMETER 
SAVDFLT  SLA   X,12             IT IS IN KILO WORDS 
         CLR   W,X            ; CHECK IF W>X 
         BNH   MEMSMALL 
         SLR   W,X 
.INIMTS9 ANOP
* 
* FIX   (  ) : FIXED HEAP SIZE(DEFAULT IS  &FIX KW) 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS10
         LA    X,&FIX 
         TM    FIXSZ1+6,X'80' 
         BZ    FIXDFLT 
         L     X,FIXSZ1       GET FIXED HEAP SIZE 
         L     X,0(X)         SPECIFIED AS PARAMETER 
         AGO   .INMTS11
.INMTS10 L     X,FIXSZ1       FIXED HEAP SIZE
.INMTS11 ANOP
FIXDFLT  SLA   X,12           IT IS IN KILO WORDS 
         CLR   W,X            ; CHECK IF W>X 
         BNH   MEMSMALL 
         SLR   W,X            SUBTRACT MEMORY SIZE FOR FIXED HEAP 
         ALR   WW,X 
         ST    WW,FIXLIM 
         SRL   W,1            HALF THE AVAILABLE MEMORY 
         N     W,=X'FFFFF000' ADJUST TO PAGE BOUNDARY 
         LTR   W,W            ; CHECK IF W>0 
         BZ    MEMSMALL 
         ST    W,MINSIZEA 
         ST    WW,CURHEAP     SET CURRENT HEAP TOP 
         ALR   WW,W 
         ST    WW,CURLIM      SET CURRENT HEAP LIMIT 
         ST    WW,ALTHEAP     SET ANOTHER HEAP TOP 
         ALR   WW,W 
         ST    WW,ALTLIM      SET ANOTHER HEAP LIMIT 
         L     D,INITTEMP 
         AL    D,INITTEMP+4 
         S     D,ALTLIM 
         BM    MEMSMALL 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS12
         FREEMAIN E,LV=(D),A=ALTLIM 
.INMTS12 ANOP
* 
* SET HEAP 
* 
         LM    W,WW,CURHEAP   W:=CURRENT HEAP TOP; WW:=ITS LIMIT 
         STM   W,WW,HEAPTOP   SET HEAP 
* 
         LM    0,4,REGINIT 
* 
* INTERN PREDEFINED SYMBOLS 
* 
         L     SB,=A(PDSYM) 
         USING SYMBOL,SB 
INITPD   L     A,PNAME 
         BAL   L,HASHSTR      COMPUTE HASH VALUE ON NA 
         L     WW,OBVECTOR 
         L     W,0(WW) 
         LR    X,Z            (X,NA) PAIR = HASH VALUE 
         SLDA  X,2 
         DR    X,W            X:=HASH INDEX 
         LA    X,4(X,WW)      X:=ENTRY ADDRESS 
         L     D,0(X) 
         LR    A,SB 
         O     A,@SYMBOL 
         BAL   L,CONS 
         ST    A,0(X) 
         LA    SB,SYSIZE(SB) 
         CL    SB,=A(PDSYEND) 
         BL    INITPD 
* 
*  KEYWORD (MANAGER) 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS13
         L     W,PRSRET 
         USING PDL,W 
* 
         TM    MID1+6,X'80' 
         BZ    MIDDFT 
         L     X,STRBUFAD     ; X:= DEST. ADDR. 
         L     D,MID1         ; D := SOURCE ADDR. 
         LH    A,MID1+4       ; A := SOURCE LENGTH 
         AGO   .INMTS14
.INMTS13 LT    D,MID1+4       LOCN OF MANAGER ID
         BZ    MIDDFT         NONE GIVEN
         L     A,MID1         LENGTH-1
         LA    A,1(0,A)
         L     X,STRBUFAD     WHERE TO PUT IT
.INMTS14 ANOP
         LR    NA,A           ; NA := DEST. ADDR 
         MVCL  X,D 
         LR    A,X 
         L     SB,STACKBTM 
         LR    NB,SB 
         BAL   L,MKSTRING 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS17
         DROP  W 
.INMTS17 L     SB,=A(SYSID$) 
         USING SYMBOL,SB 
         ST    A,VALUE 
         DROP  SB 
MIDDFT   DS    0H 
* 
*  KEYWORD (SYSPARM) 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS15
         L     W,PRSRET 
         USING PDL,W 
* 
         TM    SYSPARM1+6,X'80' 
         BZ    NOSYSPRM 
         L     X,STRBUFAD     ; X := DEST. ADDR. 
         L     D,SYSPARM1     ; D := SOURCE ADDR. 
         LH    A,SYSPARM1+4   ; A:= SOURCE LENGTH 
         AGO   .INMTS16
.INMTS15 LT    D,SYSPARM1+4   LOCN OF SYSPARM
         BZ    NOSYSPRM       NONE GIVEN
         L     A,SYSPARM1     LENGTH-1
         LA    A,1(0,A)
         L     X,STRBUFAD     WHERE TO PUT IT
.INMTS16 ANOP
         LR    NA,A 
         MVCL  X,D 
         LR    A,X 
         L     SB,STACKBTM 
         LR    NB,SB 
         BAL   L,MKSTRING 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS18
         DROP  W 
.INMTS18 ANOP
* 
         L     SB,=A(SYSPARM$) 
         USING SYMBOL,SB 
         ST    A,VALUE 
         DROP  SB 
* 
NOSYSPRM DS    0H 
* 
* 
*        &JET.RLSA PRSRET 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC10 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM10 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##10 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##10
* 
.HITAC10 ANOP 
         JETRLSA PRSRET 
         AGO   .EXIT010 
* 
.FACOM10 ANOP 
         KEQRLSA PRSRET 
         AGO   .EXIT010 
* 
.TSO##10 ANOP 
         IKJRLSA PRSRET 
         AGO   .EXIT010 
* 
.MTS##10 ANOP
.EXIT010 ANOP 
* 
* INITIATE CPU TIMER 
* 
         AIF   ('&SYSTEM' EQ 'MTS').TIME0
*
         STIMER TASK,BINTVL=INITTIME 
* 
         AGO   .TIME1
.TIME0   ANOP
         L     NB,STACKBTM
         CALL  TIME,(=F'0',=F'0',0),VL
.TIME1   ANOP
* 
* SET ATTENTION EXIT 
* 
         DISABLE ,            Don't allow interrupts until ready
*
         AIF   ('&SYSTEM' EQ 'MTS').INMTS19
STAXLIST STAX  ATTNEXIT,REPLACE=NO,DEFER=NO 
         AGO   .INMTS20
.INMTS19 ANOP
         LM    0,1,ATTNSTUFF
         MVI   0(1),0         DON'T RESTART
         CALL  ATTNTRP
.INMTS20 ANOP
* 
* SET PROGRAM MASK 
* 
         XR    W,W 
         SPM   W 
* 
* SET PROGRAM INTERRUPT EXITS 
* 
         SPIE  SPIEXIT,(9,12,15) 
* 
* 
* START TIMER TASK AND STOP IT 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS21
         IDENTIFY EP=L#TIMER,ENTRY=TIMERTSK 
         LTR   15,15 
         BNZ   TMR$ERR1 
         ATTACH EP=L#TIMER 
         LTR   15,15 
         BNZ   TMR$ERR2 
         ST    1,TIMERTCB 
         STATUS STOP,TCB=TIMERTCB 
         LTR   15,15 
         BNZ   TMR$ERR3 
.INMTS21 ANOP
* 
* PREPARE FOR SYSTEM FILE 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS22
         LA    1,ALLCSYSP 
         DYNALLOC , 
         LTR   15,15 
         BNZ   ALLOCERR 
         LA    15,1(0)        ; RESET CODE TO FREEDD 
         STH   15,TUSYSDD 
         L     W,=A(DCBSYS) 
         USING DCB,W 
         LA    X,DCBDDNAM     ; X :=DEST. ADDR. 
         DROP  W 
         LA    NA,8           ; NA :=DEST. LENGTH 
         LA    D,TUSYSDD+6    ; D:= SOURCE ADDR. 
         LH    A,TUSYSDD+4    ; A:= SOURCE LENGTH 
         ICM   A,B'1000',MVCLPAD 
         MVCL  X,D 
         L     NA,=A(SYSIN$) 
         L     NB,STACKBTM    ; R13 := REGISTER SAVE AREA 
         MVI   DCBFLAG,X'00' 
         OPEN  (DCBSYS,INPUT) 
         CLI   DCBFLAG,X'00' 
         BNE   DSERR 
         LTR   15,15 
         BNZ   DSERR 
*
         AGO   .INMTS23
.INMTS22 ANOP
*
         L     NB,STACKBTM
         LA    1,TUSYSNAM     NAME OF THE FILE
         CALL  GETFD
         L     NA,=A(SYSIN$)  STREAM FOR THIS
         USING STREAM,NA
         ST    0,IOLDN        SAVE THE FDUB
         CALL  GDINFO
         LTR   X,15
         BNZ   DSERR          BAD FILE NAME
         USING GDDSECT,1
         IF    ¬GDINOK:GDSWS  THEN INPUT NOT ALLOWED
           FREESPAC ,         FREE THE GDINFO STUFF
           B     DSERR        AND PUNT
         ENDIF
         LH    X,GDINLEN      MAX INPUT LENGTH
         IF    X,Z            IF LEN IS ZERO (EMPTY FILE?)
           LA    X,8          GET AN 8 BYTE BUFFER ANYWAY
         ENDIF
         STH   X,IOLEN+2      SAVE IT
         FREESPAC ,           FREE THE GDINFO STUFF
         DROP  1
         LH    1,IOLEN+2      GET A BUFFER FOR IT
         GETSPACE (1),T=3
         ST    1,IOBUFAD
         DROP  NA
*
.INMTS23 ANOP
         B     SYSLOOP$       ; JUMP TO SYSLOOP(MAIN) 
* 
***************************************** 
*  SYSTERM ERROR EXIT 
***************************************88 
*
         AIF   ('&SYSTEM' EQ 'MTS').INMTS24 
*
TMR$ERR1 LA    13,SAVEAREA 
         PUTLINE PARM=PUTLPARM,UPT=UPTADDR,ECT=ECTADDR,                *
               OUTPUT=(TMR1MSG,TERM,SINGLE,DATA),MF=(E,IOPLPARM) 
         B     INITERR 
* 
TMR$ERR2 LA    13,SAVEAREA 
         PUTLINE PARM=PUTLPARM,UPT=UPTADDR,ECT=ECTADDR,                *
               OUTPUT=(TMR2MSG,TERM,SINGLE,DATA),MF=(E,IOPLPARM) 
         B     INITERR 
* 
TMR$ERR3 LA    13,SAVEAREA 
         PUTLINE PARM=PUTLPARM,UPT=UPTADDR,ECT=ECTADDR,                *
               OUTPUT=(TMR3MSG,TERM,SINGLE,DATA),MF=(E,IOPLPARM) 
         B     INITERR 
* 
MEMSMALL LA    13,SAVEAREA 
         PUTLINE PARM=PUTLPARM,UPT=UPTADDR,ECT=ECTADDR,                *
               OUTPUT=(MEMMSG,TERM,SINGLE,DATA),MF=(E,IOPLPARM) 
         B     INITERR 
* 
ALLOCERR LA    13,SAVEAREA 
         PUTLINE PARM=PUTLPARM,UPT=UPTADDR,ECT=ECTADDR,                *
               OUTPUT=(ALLOCMSG,TERM,SINGLE,DATA),MF=(E,IOPLPARM) 
INITERR  ABEND 4095 
* 
DSERR    LA    13,SAVEAREA 
         PUTLINE PARM=PUTLPARM,UPT=UPTADDR,ECT=ECTADDR,                *
               OUTPUT=(DSMSG,TERM,SINGLE,DATA),MF=(E,IOPLPARM) 
         B     INITERR 
*  
         AGO   .INMTS25
.INMTS24 ANOP
*
MEMSMALL PMSG  ' SIZE parameter too small for other parameters given'
         B     INITERR
*
DSERR    PMSG  ' Invalid LISPSYS paramter'
         B     INITERR
*
INITERR  L     1,INITTEMP
         FREESPAC ,           RELEASE THE SPACE WE GOT
         LA    13,SAVEAREA
         EXIT  4
*
ATTNSTUFF DC   A(ATTNEXIT,ATTNAREA)
*
.INMTS25 ANOP
* 
* 
* 
MVCLPAD  DC    C' ',X'000000' 
* 
* 
* 
SAVEAREA DS    18A 
* 
INITREG  SYMCON NIL$ 
         DC    F'0' 
         DC    A(MAIN) 
         DC    A(MAIN+4096) 
         DC    F'4' 
*
         AIF   ('&SYSTEM' EQ 'MTS').INMTS26
* 
TSS#CPPL DS    0A 
TSS#CMDA DC    A(TSS#CMD) 
TSS#UPT  DS    A 
TSS#PSCB DS    A 
TSS#ECT  DS    A 
* 
* 
TSS#CMD  DS    0H 
         DC    H'12',H'8',CL8'UTILISP ' 
         DC    CL100' ' 
* 
PARSELST DS    0A 
LST$UPT  DS    A 
LST$ECT  DS    A 
LST$ECB  DC    A(0) 
LST$PCL  DC    A(PCL) 
LST$RET  DC    A(PRSRET) 
LST$BUFF DS    A 
LST$WARA DC    A(0) 
* 
PRSRET   DS    A 
* 
         DS    0A 
ALLCSYSP DC    X'80',AL3(REQALCSY) 
FREESYSP DC    X'80',AL3(REQFRESY) 
* 
* 
ECTCOPY  DS    12C 
         DC    CL8'UTILISP' 
         DS    36C 
* 
ALLOCMSG DC    AL2(ALLCMSG@-*),AL2(0) 
         DC    C'!!! SYSTEM FILE BUSY: TRY AGAIN !!!' 
ALLCMSG@ DS    0C 
* 
MEMMSG   DC    AL2(MEMMSG@-*),AL2(0) 
         DC    C'!!! NOT ENOUGH MEMORY SPACE AVAILABLE !!!' 
MEMMSG@  DS    0C 
* 
DSMSG    DC    AL2(DSMSG@-*),AL2(0) 
         DC    C'!!! INVALID LISPSYS PARAMETER !!!' 
DSMSG@   DS    0C 
* 
TMR1MSG  DC    AL2(TMR1MSG@-*),AL2(0) 
         DC    C'!!! IDENTIFY FAILED(TIMER) !!!' 
TMR1MSG@ DS    0C 
* 
TMR2MSG  DC    AL2(TMR2MSG@-*),AL2(0) 
         DC    C'!!! ATTACH FAILED(TIMER) !!!' 
TMR2MSG@ DS    0C 
* 
TMR3MSG  DC    AL2(TMR3MSG@-*),AL2(0) 
         DC    C'!!! STATUS STOP FAILED(TIMER) !!!' 
TMR3MSG@ DS    0C 
* 
         DS    0A 
REQALCSY DC    X'14010000' 
         DS    A 
         DC    A(ALLOCSYS) 
         DC    F'0' 
         DS    A 
ALLOCSYS DC    X'00',AL3(TUSYSDD) 
         DC    X'00',AL3(TUSHR) 
ALL$NAM  DC    X'80',AL3(TUSYSNAM) 
ALL$MEM  DC    X'00',AL3(TUMEMBER) 
TUSYSDD  DC    X'0055',H'1',H'8',CL8' ' 
TUSYSNAM DC    X'0002',H'1',H'44',CL44'&SYSID&FILESEP&LISPSYS' 
TUMEMBER DC    X'0003',H'1',H'8',CL8' ' 
TUSHR    DC    X'0004',H'1',H'1',X'08' 
* 
         DS    0A 
REQFRESY DC    X'14020000' 
         DC    F'0' 
         DC    A(FREESYS) 
         DC    F'0' 
         DC    F'0' 
FREESYS  DC    X'80',AL3(TUSYSDD) 
*
         AGO   .INMTS27
.INMTS26 ANOP
*
TUSYSNAM DC    CL45'&SYSID&FILESEP&LISPSYS'
* 
.INMTS27 ANOP
* 
* 
         DROP  CB 
* 
************************************************** 
* 
MAIN     CSECT 
SYSLOOP$ DS    0H 
         L     SB,STACKBTM      In case we get an attn here
         ENABLE ,               Enable attentions for IPL loop
         L     A,SYSIN 
         L     D,INSTRM 
         ST    A,0(D) 
SYSLOOP  L     CB,IPLLOOP     ; FOR ERROR DURING IPL LOOP 
         L     SB,STACKBTM 
         LR    NB,SB 
         L     A,READ 
         BAL   L,FUNCALL0 
         BAL   L,EVAL 
         B     SYSLOOP 
* 
* END OF SYSIN 
* 
         AIF   ('&SYSTEM' EQ 'MTS').ESYSIN
ENDSYS   CLOSE DCBSYS 
         L     1,=A(DCBSYS) 
         FREEPOOL (1) 
         L     1,=A(FREESYSP) 
         DYNALLOC , 
         LM    0,1,REGINIT 
* 
*  SET ESTAE(EXTENDED SPECIFY TASK ABNORMAL EXIT) 
* 
         ESTAE ESTAEXIT,PARAM=ESTAEPRM 
*
         AGO   .ESYSIN2
.ESYSIN  ANOP
*
ENDSYS   L     NB,STACKBTM
         ST    NB,BINDTOP
         L     A,=A(SYSIN$)
         USING STREAM,A
         L     0,IOLDN
         CALL  FREEFD
         L     1,IOBUFAD
         FREESPAC (1)
         DROP  A 
*
.ESYSIN2 ANOP
         LM    0,1,REGINIT 
* 
* TOP LEVEL LOOP 
* 
         L     A,TERMIN 
         L     D,INSTRM 
         ST    A,0(D) 
TOPLOOP  GETVALUE TOPLEV$ 
         L     CB,TOPLEV 
         L     SB,STACKBTM 
         LR    NB,SB 
         BAL   L,FUNCALL0 
         B     TOPLOOP 
* 
         AIF   ('&SYSTEM' EQ 'MTS').INMTS30
ESTAEPRM DS    0F 
ESTAECB  DC    F'0' 
ESTAESB  DC    F'0' 
ABENDCD  DC    F'0'           ; ABEND CODE 
* 
MINMAX   DC    F'0',X'00FFFFFF' 
INITTIME DC    F'1000000' 
.INMTS30 ANOP
STACKBTM DS    A 
INITTEMP DC    2A(0)
* 
REGINIT  SYMCON NIL$ 
         DC    F'0' 
         DC    A(MAIN) 
         DC    A(MAIN+4096) 
         DC    F'4' 
* 
*  TERMINAL CHARACTERICS 
LINESIZE DS    A 
* 
* 
* CPPL BUFFERS 
* 
CPPLCOPY DS    0A 
CMNDBUFF DS    A 
UPTADDR  DC    A(1)           THESE ARE NOT USED
PSCBADDR DC    A(2)           WHEN RUNNING UNDER
ECTADDR  DC    A(3)           MTS.
* 
* 
TSS#MODE DC    X'00' 
* 
* 
* 
*********************************************************************** 
* 
*  EXTENDED SPECIFY TASK ABNORMAL EXIT 
* 
         AIF   ('&SYSTEM' EQ 'MTS').NOESTAE
*
ESTAE    CSECT 
ESTAEXIT DS    0H 
         BALR  12,0 
         USING *,12 
         C     0,=F'12' 
         BE    ESTAE$1 
         L     2,0(1)         ; R2 := ADDR. OF ESTAEPARM 
         L     3,4(2)         ; R3 := ESTAESB 
         LTR   3,3 
         BZ    ESTAE$2 
         L     3,4(1)         ; R3 := ABEND CODE 
         LA    3,0(3) 
         ST    3,8(2)         ; ABENDCD := R3 
         SETRP RC=4,RETADDR=RETRY,FRESDWA=YES 
         RETURN 
* 
ESTAE$2  SETRP RC=0 
         RETURN 
* 
ESTAE$1  L     3,4(2)         ; R3 :=  ESTAESB 
         LTR   3,3 
         BZ    ESTAE$1A 
         LA    1,0(1) 
         ST    1,8(2)         ; ABENDCD := TASK COMPLETION CODE 
         LA    15,4           ; EXECUTE RESUME ROUTINE 
         L     0,=A(RETRY) 
         BR    14 
* 
ESTAE$1A LA    15,0           ; CONTINUE THE ABEND 
         BR    14 
* 
         DROP  12 
* 
RETRY    DS    0H 
         BALR  X,0 
         USING *,X 
         LM    0,4,ESTAEINI 
         USING MAIN,E,E2 
         L     A,ABENDCD 
         O     A,ZERO 
         LM    CB,SB,ESTAECB 
         B     ESTAERR 
* 
ESTAEINI SYMCON NIL$ 
         DC    F'0' 
         DC    A(MAIN) 
         DC    A(MAIN+4096) 
         DC    F'4' 
* 
* 
* 
         DROP  X 
* 
* 
* 
MAIN     CSECT 
.NOESTAE ANOP
         TITLE 'GARBAGE COLLECTOR' 
*********************************************************************** 
* 
*        GARBAGE COLLECTOR 
* 
*        THIS GARBAGE COLLECTOR USES COPYING SCHEME. 
*        GARBAGE COLLECTION, COMPACTIFICATION AND SERIALIZATION ARE 
*        ALL DONE AT THE SAME TIME. 
* 
*********************************************************************** 
GC       DISABLE ,            DISABLE ATTENTION INTERRUPT WHILE GC 
         STM   0,15,GCSAVE 
         MVI   INGC,1 
         L     X,=A(GCBODY) 
         BR    X 
* 
*        BODY OF THE GARBAGE COLLECTOR 
* 
*        THE BODY IS ANOTHER CONTROL SECTION BASED BY X REG 
*        OTHER REGISTERS ARE ALSO USED DIFFERENTLY HERE 
* 
GCAREA   CSECT 
         USING GCBODY,X 
GCBODY   DS    0H 
*
         AIF   ('&SYSTEM' EQ 'MTS').GCTIME1
         TTIMER ,MIC,GCTIME1 
         AGO   .GCTIME2
.GCTIME1 ANOP
         CALL  TIME,(=F'15',=F'0',GCTIME1),VL
.GCTIME2 ANOP
* 
* RELOCATION OF OBJECTS FROM CURRENT HEAP TO ALTERNATIVE HEAP 
* 
         L     W,ALTHEAP      W:=NEW HEAP POINTER 
         LR    N,NB           N:=BOTTOM OF STACK USED BY GC 
* 
* RELOCATE OBJECTS POINTED FROM SYSTEM ROOTS 
* 
         LA    Z,ROOTTOP 
RELROOT  LR    NA,Z           NA POINTS TO THE ADDRESS 
         BAL   L,RELOC          WHICH POINTS THE OBJECT 
         ALR   Z,F 
         CL    Z,=A(ROOTEND) 
         BL    RELROOT 
* 
* RELOCATE OBJECTS POINTED FROM STACK 
* 
         L     Z,STACKBTM 
RELSTACK LR    NA,Z 
         BAL   L,RELOC 
         ALR   Z,F 
         CLR   Z,N 
         BL    RELSTACK 
* 
* PUT THE MARKS ON FIXED AREA CELLS OFF 
* 
         LR    Z,SL 
         AL    Z,F4096        Z:=TOP OF FIXED HEAP 
MARKOFF  NI    0(Z),X'FE' 
         BNZ   MARKOFF1 
         AL    Z,0(Z) 
         LA    Z,3(Z) 
         N     Z,WORDBND 
MARKOFF1 LA    Z,4(Z) 
         CL    Z,FIXTOP 
         BL    MARKOFF 
         L     Z,=A(PRETOP)   Z:=TOP OF PREDEFINED OBJECTS 
MARKOFF2 NI    0(Z),X'FE' 
         BNZ   MARKOFF3 
         AL    Z,0(Z) 
         LA    Z,3(Z) 
         N     Z,WORDBND 
MARKOFF3 LA    Z,4(Z) 
         CL    Z,=A(PREEND) 
         BL    MARKOFF2 
         NI    PRCHARS,X'FE'  FOR SPECIAL CHARACTER TABLE 
* 
* COLLECT STREAM AREA 
* 
         L     Z,=A(STRMTOP) 
         LA    A,0 
COLSTRM  TM    0(Z),GCMARK 
         BZ    COLSTRM1 
         NI    0(Z),X'FE' 
         B     COLSTRM2 
COLSTRM1 ST    A,0(Z) 
         LR    A,Z 
COLSTRM2 LA    Z,STRMLENG(Z) 
         CL    Z,=A(STRMEND) 
         BNE   COLSTRM 
         ST    A,STRMFREE 
* 
* SET NEW HEAP 
*        NEW HEAP WILL BE TWICE AS LARGE AS THE AREA CURRENTLY USED 
*        AS FAR AS THE SIZE GIVEN BY THIS RULE DOES NOT VIOLATE 
*        MINIMUM AND MAXIMUM VALUE. 
* 
         L     A,HEAPTOP 
         SL    A,CURHEAP      A:=AREA USED BEFORE GC 
         SLR   A,W 
         AL    A,ALTHEAP      A:=AREA FREED BY THIS GC 
         AL    A,CUMHEAP      A:=CUMULATIVE HEAP USAGE 
         ST    A,CUMHEAP 
         ST    W,HEAPTOP      SET NEW HEAP TOP 
         SL    W,ALTHEAP      W:=SIZE OF AREA CURRENTLY USED 
         AR    W,W 
         C     W,MINSIZEA 
         BNL   SETSIZE1 
         L     W,MINSIZEA 
SETSIZE1 AL    W,ALTHEAP      W:=NEW HEAP LIMIT 
         LA    W,4095(W)      ADJUST TO PAGE BOUNDARY 
         N     W,=A(-4096) 
         CL    W,ALTLIM 
         BNH   SETSIZE2 
         L     W,ALTLIM 
SETSIZE2 ST    W,HEAPLIM      SET NEW HEAP LIMIT 
* 
* EXCHANGE CURRENT AND ALTERNATIVE HEAP 
* 
         XC    CURHEAP(8),ALTHEAP 
         XC    ALTHEAP(8),CURHEAP 
         XC    CURHEAP(8),ALTHEAP 
* 
* RELEASE ALTERNATIVE HEAP AREA 
*  AND STACK AREA ABOVE CURRENT TOP 
*   TO AVOID MEANINGLESS PAGING OUT 
* 
         AIF   ('&SYSTEM' EQ 'MTS').NORLSE  NO SUCH THING IN MTS
         LM    0,1,ALTHEAP 
         PGRLSE LA=(0),HA=(1) 
         LA    0,72(NB)       72 BYTES FOR SAVE AREA 
         PGRLSE LA=(0),HA=(SL) 
.NORLSE  ANOP
* 
* ACCUMULATE TIME REQUIRED FOR GC 
* 
         AIF   ('&SYSTEM' EQ 'MTS').GCTIME3
*
         TTIMER ,MIC,GCTIME2 
         LM    D,A,GCTIME1 
         SL    D,GCTIME2 
         SL    A,GCTIME2+4 
         BO    GC$TIME1 
         BCTR  D,0 
GC$TIME1 AL    D,GCTIME 
         AL    A,GCTIME+4 
         BNO   GC$TIME2 
         LA    D,1(D) 
GC$TIME2 STM   D,A,GCTIME 
*
         AGO   .GCTIME4
.GCTIME3 ANOP
*     
         CALL  TIME,(=F'15',=F'0',GCTIME2),VL
         LM    D,A,GCTIME2
         S8    D,GCTIME1
         SLDA  D,12           HE WANTS 370 TIMER UNITS
         A8    D,GCTIME
         STM   D,A,GCTIME
*
.GCTIME4 ANOP
*
         L     A,GCCOUNT 
         LA    A,1(A) 
         ST    A,GCCOUNT 
* 
* RETURN TO MAIN PROGRAM 
* 
         B     GCEND 
* 
GCMARK   EQU   B'00000001' 
* 
GCDUMMY  DS    A              DUMMY FOR RELOCATION OF REFERENCES 
GCTIME1  DS    2A 
GCTIME2  DS    2A 
* DUMMY SEROS FOR GC MARKING 
GCZERO   DC    10X'00' 
* 
*********************************************************************** 
* 
* RELOC  --  RELOCATES ALL THE OBJECT POINTED FROM GIVEN ADDRESS 
* 
*   ARGS 
*        NA : ADDRESS OF THE POINTER 
*        NB : CURRENT STACK TOP 
*        L  : RETURN ADDRESS 
*        W  : CURRENT TOP OF NEW HEAP 
*        N  : = NB 
* 
*   PRESERVES N, Z, F, X 
*   WW, D, A, CB, & SB ARE USED AS WORK REGISTERS 
* 
RELMRKED LA    A,0(A)         CLEAR TAG 
         CL    A,FIXLIM       IN FIXED AREA? 
         BL    RELNEXT 
REDIRECT MVC   1(3,NA),1(A)   IF NOT, REDIRECT 
RELNEXT  CLR   NB,N 
         BER   L 
         POPW  NA 
* 
RELOC    L     A,0(NA)        THE POINTER ON "A" 
         CL    A,MAXFIX 
         BL    RELNEXT        NUMBER OR MACHINE ADDR 
         CLI   0(NA),UBVTAG   AVOID REFERENCES TO LOCATION ZERO
         BE    RELNEXT
         TM    0(A),GCMARK 
         BNZ   RELMRKED       ALREADY MARKED 
         LR    WW,A 
         SRL   WW,26 
         N     WW,WORDBND 
         L     WW,RELBTAB(WW) 
         BR    WW             BRANCH ON OBJECT TYPE 
* 
* 
RELBTAB  DC    A(SYSERR#B)    ADDRESS 
         DC    A(RELFLO)      FLONUM (NOT FIXNUM) 
         DC    A(RELREF)      REFERENCE 
         DC    A(RELVEC)      VECTOR 
         DC    A(RELSTRNG)    STRING 
         DC    A(RELSTRM)     STREAM 
         DC    A(RELCODE)     CODE 
         DC    A(RELSYM)      SYMBOL 
         DC    A(RELLIST)     LIST 
         DC    A(SYSERR#B)    ? 
         DC    A(SYSERR#B)    ? 
         DC    A(RELSYM)      BINDTAG 
         DC    A(RELNEXT)     UBV 
         DC    A(SYSERR#B)    ? 
         DC    A(SYSERR#B)    ? 
         DC    A(SYSERR#B)    ? 
* 
* RELOCATION OF FLONUMS 
* 
RELFLO   MVC   0(12,W),0(A) 
         STCM  W,B'0111',1(NA) 
         ST    W,0(A) 
         OI    0(A),GCMARK 
         LA    W,12(W) 
         B     RELNEXT 
* 
* RELOCATION OF CONS CELLS 
* 
RELLIST  LA    A,0(A) 
         CL    A,FIXLIM 
         BL    RELLIST1       IF NOT IN FIXED AREA 
         STCM  W,B'0111',1(NA)  REDIRECT POINTER 
         MVC   0(8,W),0(A)      COPY THE CELL 
         ST    W,0(A)         NOTICE RELOCATED ADDR 
         OI    0(A),GCMARK    PUT MARK 
         LR    A,W 
         LA    W,8(W)           ADVANCE NEW HEAP POINTER 
         B     RELLIST2 
RELLIST1 OI    0(A),GCMARK 
RELLIST2 L     D,0(A)         D:=CDR OF CELL 
         LA    NA,4(A)        NA:=ADDRESS OF CAR 
         CL    D,MAXFIX       IF CDR IS NOT FIXNUM 
         BL    RELOC 
         TM    0(D),GCMARK      IF MARKED THEN 
         BZ    RELLIST3 
         LA    D,0(D) 
         CL    D,FIXLIM 
         BL    RELOC 
         MVC   1(3,A),1(D)        REDIRECT CDR 
         B     RELOC 
RELLIST3 PUSHW A                ELSE PUSH THE ADDR OF CDR 
         B     RELOC          AND RELOCATE CAR 
* 
* RELOCATION OF A STRING 
* 
RELSTRNG LA    A,0(A) 
         CL    A,FIXLIM 
         BL    RELSTRG1 
         STCM  W,B'0111',1(NA) 
         L     WW,0(A)        WW:=SIZE 
         LA    WW,7(WW) 
         N     WW,WORDBND     WW:=WORD-BOUNDARY SIZE 
         LR    CB,A 
         LR    SB,WW 
         LR    D,W            SAVE OLD HEAP TOP ON D 
         MVCL  W,CB           RELOCATION 
         ST    D,0(A)         NOTICE RELOCATED ADDRESS 
RELSTRG1 OI    0(A),GCMARK    PUT MARK 
         B     RELNEXT 
* 
RELSTRM  OI    0(A),GCMARK 
         B     RELNEXT 
* 
* RELOCATION OF A REFERENCE POINTER 
* 
RELREF   TM    0(A),GCMARK    IF THE POINTED ELEMENT IS MARKED 
         BZ    RELREF1 
         MVC   1(3,NA),1(A)     THEN REDIRECT TO THE RELOCATED ADDR 
         B     RELNEXT 
* 
RELREF1  LR    D,A            D:=REFERRED ELEMENT 
RELREF2  SLR   A,F            FIND THE TOP OF VECTOR 
         CLI   0(A),X'00' 
         BNE   RELREF2 
         SLR   D,A            D:=DISPLACEMENT FROM THE TOP 
         ALR   D,W            D:=NEW REFERENCE POINTER VALUE 
         STCM  D,B'0111',1(NA) REDIRECT THE POINTER TO NEW CELL 
         LA    NA,GCDUMMY     DUMMY, TO RELOCATE THE REFERRED VECTOR 
* 
* RELOCATION OF A VECTOR 
* 
RELVEC   OI    0(A),GCMARK    MARK THE CELL, ANYWAY 
         LA    A,0(A) 
         CL    A,FIXLIM       IF NOT IN FIXED AREA 
         BL    RELVEC3          THEN THE VECTOR SHOULD BE COPIED 
* 
* COPYING A VECTOR 
* 
         STCM  W,B'0111',1(NA) REDIRECT TO NEW CELL 
         L     WW,0(A)        WW:=VECTOR SIZE 
         LA    WW,0(WW) 
         ST    WW,0(W)        SET LENGTH OF NEW VECTOR 
         STCM  W,B'0111',1(A) NOTICE RELOCATED ADDRESS 
         LR    SB,W           SB:=TOP OF NEW VECTOR 
         LA    WW,4(WW,A)     WW:=END OF OLD VECTOR 
         B     RELVEC2 
* 
RELVEC1  L     D,0(A)         D:=VECTOR ELEMENT 
         ST    W,0(A)         NOTICE RELOCATED ADDRESS 
         OI    0(A),GCMARK      AND PUT MARK 
         ST    D,0(W)         STORE IN NEW VECTOR 
RELVEC2  ALR   A,F            ADVANCE POINTERS 
         ALR   W,F 
         CLR   A,WW           REPEAT UNTIL 
         BNE   RELVEC1          THE END OF VECTOR IS REACHED 
         LR    A,SB           A:=TOP OF NEW VECTOR 
* 
* RELOCATING ELEMENTS OF A VECTOR 
* 
RELVEC3  L     WW,0(A)        WW:=VECTOR LENGTH 
         LA    WW,4(WW,A)     WW:=END OF VECTOR 
         B     RELVEC6 
* 
RELVEC4  L     D,0(A)         D:=VECTOR ELEMENT 
         CL    D,MAXFIX       IF THE ELEMENT IS NOT A FIXNUM 
         BL    RELVEC6 
         TM    0(D),GCMARK      THEN IF IT IS NOT MARKED 
         BZ    RELVEC5 
         LA    D,0(D) 
         CL    D,FIXLIM         AND NOT IN FIXED AREA 
         BL    RELVEC6 
         MVC   1(3,A),1(D)        THEN REDIRECT TO NEW ADDRESS 
         B     RELVEC6 
RELVEC5  PUSHW A                  ELSE PUSH THE ADDRESS OF THE ELEMENT 
RELVEC6  ALR   A,F            ADVANCE POINTER 
         CLR   A,WW           REPEAT UNTIL 
         BNE   RELVEC4          THE END IS REACHED 
         B     RELNEXT 
* 
RELCODE  L     WW,0(A)        WW:=CODE LENGTH 
         OI    0(A),GCMARK    PUT MARK 
         USING CODE,A 
         L     D,QUOTEVEC 
         CLR   D,WW 
         BH    RELCODE2 
RELCODE1 LA    CB,0(D,A) 
         PUSHW CB 
         ALR   D,F 
         CLR   D,WW 
         BNH   RELCODE1 
RELCODE2 LA    NA,FUNCNAME 
         B     RELOC 
         DROP  A 
* 
* RELOCATION OF A SYMBOL 
* 
RELSYM   LA    A,0(A) 
         CL    A,FIXLIM 
         BL    RELSYM1 
         STCM  W,B'0111',1(NA) REDIRECTION 
         MVC   0(SYSIZE,W),0(A) 
         ST    W,0(A)         NOTICE RELOCATED ADDRESS 
         OI    0(A),GCMARK    PUT MARK 
         LR    A,W 
         LA    W,SYSIZE(W) 
         B     RELSYM2 
RELSYM1  OI    0(A),GCMARK 
RELSYM2  PUSHW A 
         ALR   A,F 
         PUSHW A 
         ALR   A,F 
         PUSHW A 
         LA    NA,4(A) 
         B     RELOC 
* 
         DROP  X 
* 
MAIN     CSECT 
* 
GCEND    LM    0,15,GCSAVE 
         MVI   INGC,0 
         ENABLE 
         BR    L 
* 
CUMHEAP  DC    A(0)           CUMULATIVE HEAP USAGE 
GCTIME   DC    2A(0)          TIME CONSUMED BY GC (CUMULATIVE) 
GCCOUNT  DC    A(0)           NUMBER OF GC CALL 
GCSAVE   DS    16A 
INGC     DC    X'00' 
* 
         TITLE 'GLOBAL CONSTANTS' 
         DS    0A 
ROOTTOP  EQU   * 
NIL      SYMCON NIL$ 
* 
IPLLOOP  SYMCON IPLLOOP$ 
* 
T        SYMCON T$ 
LAMBDA   SYMCON LAMBDA$ 
MACRO    SYMCON MACRO$ 
QUOTE    SYMCON QUOTE$ 
FUNCTI   SYMCON FUNCTI$ 
INSTRM   SYMCON INSTRM$ 
OUTSTRM  SYMCON OUTSTRM$ 
READTAB  SYMCON READTAB$ 
MACTAB   SYMCON MACTAB$ 
DFLTRDTB VECCON DFLTRDT$ 
DFLTMCTB VECCON DFLTMCT$ 
TERMIN   STRMCON TERMIN$ 
SYSIN    STRMCON SYSIN$ 
TERMOUT  STRMCON TERMOUT$ 
TOPLEV   CODECON TOPLEV# 
BREAK    CODECON BREAK# 
INTERNCD CODECON INTERN# 
CURSTRM  STRMCON TERMIN$ 
CURRDTB  VECCON DFLTRDT$ 
QUESTION SYMCON QUEST$ 
QUESTS   SYMCON QUESTS$ 
PRLENGTH SYMCON PRLEN$ 
PRLEVEL  SYMCON PRLEV$ 
OBVECTOR VECCON DFLTOBR$ 
PRLOWER  SYMCON PRLOWER$ 
OPNFLS   SYMCON OPNFLS$ 
GENSTR   STRNGCON STRINGG 
PROG     SYMCON PROG$ 
LOOP     SYMCON LOOP$ 
CLOSE    CODECON CLOSE# 
READ     CODECON READ# 
PUTD     CODECON PUTD# 
SKIPLINE CODECON SKIPLN# 
INOPEN   SYMCON INOPEN$ 
OUTOPEN  SYMCON OTOPEN$ 
* 
ROOTEND  EQU   * 
* 
RDFLAG   DS    C 
PRFLAG   DS    C 
SOFTFLAG DS    C 
DCBFLAG  DS    C 
PRLEN    DS    F 
PRLEV    DS    F 
* 
* 
* HEAP DESCRIPTOR 
* 
HEAPTOP  DS    A              CURRENT HEAP TOP 
HEAPLIM  DS    A              CURRENT HEAP LIMIT 
* 
CURHEAP  DS    A              CURRENT HEAP BEING USED 
CURLIM   DS    A                ITS REAL LIMIT 
ALTHEAP  DS    A              ALTERNATIVE HEAP 
ALTLIM   DS    A                ITS REAL LIMIT 
* 
FIXTOP   DS    A              FIXED HEAP TOP 
FIXLIM   DS    A              FIXED HEAP LIMIT 
* 
STRMFREE DC    A(STRM0)       FREE LIST FOR STREAMS 
* 
MINSIZEA DS    A 
* 
SAVEA    DS    A 
SAVEL    DS    A 
SAVEW    DS    A 
MINFIX   DC    X'10800000' 
CHARMASK DC    X'000000FF' 
WORDBND  DC    X'FFFFFFFC' 
IVALMASK DC    X'00FFFFFF' 
@UDFMIN  DC    AL1(UDFTAG),AL3(0) 
@UDFDEF  DC    AL1(UDFTAG),AL3(UDFERR) 
STRBUFAD DC    A(STRBUFF) 
STRBUFE  DC    A(STRBUFF+BUFFSIZE) 
@BUFSIZE DC    A(BUFFSIZE) 
F1       DC    F'1' 
F8       DC    F'8' 
F10      DC    F'10' 
F12      DC    F'12' 
F16      DC    F'16' 
F44      DC    F'44' 
F127     DC    F'127' 
F255     DC    F'255' 
F256     DC    F'256' 
F4096    DC    F'4096' 
* 
FLO10    DC    L'10.0' 
FLOTENTH DC    L'0.1' 
FLO1     DC    L'1.0' 
FLO5     DC    L'5.0' 
* 
TASKECB  DS    A 
TCBADDR  DS    A 
* 
ATTNFLG  DC    X'00'          ATTENTION INTERRUPT FLAG 
DISABLED DC    X'00'          ATTENTION INTERRUPT DISABLE FLAG 
TASKFLAG DC    X'00'          ON DURING EXECUTION OF SUB TASK 
* 
TIMERFLG DC    X'00' 
         DS    0A 
         AIF   ('&SYSTEM' EQ 'MTS').TIMER3
TIMERTCB DC    A(0) 
         AGO   .TIMER4
.TIMER3  ANOP
TIMERREG DC    A(0)           TIMER EXIT REGION FROM TICALL
TIMERVAL DS    FL8            TIME IN MICROSECONDS
.TIMER4  ANOP 
BINTVL   DC    F'100'         ; MILI SECONDS 
* 
********************************************************************** 
*  TIMER TASK ROUTINE 
********************************************************************** 
*
         AIF   ('&SYSTEM' EQ 'MTS').MTSTIME
*
TIMERTSK EQU   * 
TMR$LOOP STIMER WAIT,BINTVL=BINTVL 
         MVI   TIMERFLG,X'FF' 
         B     TMR$LOOP 
*
         AGO   .TSOTIME
.MTSTIME ANOP
*
TIMESUB  DS    0H             CALLED BY TICALL WHEN TIMER EXPIRES
         PUSH  USING
         DROP
         USING *,15
         L     15,ATIMFLG
         DROP  15
         MVI   0(15),X'FF'    SET THE FLAG
         SR    15,15          RC 0 -> REENABLE THE EXIT
         BR    14
*        
ATIMFLG  DC    A(TIMERFLG)
*
         POP   USING
*
.TSOTIME ANOP
* 
* 
         TITLE 'HEAP OBJECTS' 
*********************************************************************** 
* 
* THERE ARE TWO CONTROL SECTIONS IN "HEAP", NAMELY, "PDSYM" & "PREDEF" 
* "PDSYM" AREA IS SEPARATED BECAUSE IT IS USED TO INITIATE THE 
* OBVECTOR. 
* 
PDSYM    CSECT 
         ACTR  4096 
PRETOP   EQU   *              TOP OF PREDEFINED AREA 
PREDEF   CSECT 
         ACTR  4096 
* 
* INITIATION FOR ASSEMBLY MACROS 
* 
         GBLA  &SCNT 
&SCNT    SETA  0 
NIL      SYM   ,NIL$,SYMTAG 
* 
IPLLOOP  SYM   PNAME='###IPL-LOOP###' 
* 
T        SYM   ,T$,SYMTAG 
LAMBDA   SYM   , 
         USING MAIN,E,E2 
* 
         TITLE 'SPECIAL FORM INTERPRETERS' 
*********************************************************************** 
* 
* SYSTEM FUNCTIONS 
* 
*********************************************************************** 
* 
* SPECIAL FORMS 
*   ARG 
*        D : PARAMETER LIST 
* 
MAIN     CSECT 
* 
AND      SPEC 
AND#     IFATOM D,RETT 
         LA    NB,LOCAL2 
AND1     LM    D,A,0(D) 
         ST    D,LOCAL1 
         BAL   L,EVAL 
         CR    A,N 
         BER   E 
         L     D,LOCAL1 
         IFLIST D,AND1 
         RET 
* 
OR       SPEC 
OR#      IFATOM D,RETNIL 
         LA    NB,LOCAL2 
OR1      LM    D,A,0(D) 
         ST    D,LOCAL1 
         BAL   L,EVAL 
         CR    A,N 
         BNER  E 
         L     D,LOCAL1 
         IFLIST D,OR1 
         RET 
* 
COND     SPEC 
COND#    IFATOM D,RETNIL 
         LA    NB,LOCAL3 
COND1    LM    D,A,0(D) 
         ST    D,LOCAL1 
         IFATOM A,TYPERR 
         LM    D,A,0(A) 
         ST    D,LOCAL2 
         BAL   L,EVAL 
         IFNONNUL A,COND2 
         L     D,LOCAL1 
         IFLIST D,COND1 
         RET   , 
COND2    L     D,LOCAL2 
         IFATOM D,RETURN 
         LM    D,A,0(D) 
         IFATOM D,EVANDRET 
COND3    ST    D,LOCAL2 
         BAL   L,EVAL 
         L     D,LOCAL2 
         LM    D,A,0(D) 
         IFLIST D,COND3 
         B     EVANDRET 
* 
SLCTQ    SPEC  PNAME='SELECTQ' 
SLCTQ#   IFATOM D,PARAMERR 
         LM    D,A,0(D) 
         ST    D,LOCAL1 
         LA    NB,LOCAL2 
         BAL   L,EVAL         EVALUATE THE CASE EXPRESSION 
         L     W,LOCAL1 
         IFATOM W,RETNIL 
SELEQ$1  LM    W,WW,0(W) 
         IFATOM WW,PARAMERR 
         LM    X,NA,0(WW) 
         IFATOM NA,SELEQ$3 
SELEQ$2  C     A,4(NA) 
         BE    SELEQ$5 
         L     NA,0(NA) 
         IFLIST NA,SELEQ$2 
         IFLIST W,SELEQ$1 
         B    RETNIL 
SELEQ$3  CR    A,NA 
         BE    SELEQ$5 
         C     NA,T 
         BE    SELEQ$5 
SELEQ$4  IFLIST W,SELEQ$1 
         B     RETNIL 
SELEQ$5  IFATOM X,RETNIL 
SELEQ$6  LM    D,A,0(X) 
         IFATOM D,EVANDRET 
SELEQ$7  ST    D,LOCAL1 
         BAL   L,EVAL 
         L     X,LOCAL1 
         LM    D,A,0(X) 
         IFLIST D,SELEQ$7 
         B     EVANDRET 
* 
PROG     SPEC  ,              PROG FORM INTERPRETER 
PROG#    IFATOM D,PARAMERR    !PROG VARS MISSING 
         LM    NA,D,0(D)      NA:=BODY; D:=PROG VARS 
         ST    NA,LOCAL1      SAVE BODY IN LOCAL1 
         STM   0,1,LOCAL2     FILL LOCAL2, 3 WITH DUMMY (FOR GC) 
         LA    NB,LOCAL4      SET STACK TOP 
         IFATOM D,PROG$5      IF NO PROG VAR THEN SKIP 
PROG$0   LM    D,A,0(D)       A:=ONE PROG VAR; D:=REST 
         IFATOM A,PROG$4      IF PROG VAR IS LIST, IT HAS INIT FORMS 
PROG$1   ST    D,LOCAL3       SAVE REST OF PROG VARS 
         LM    D,A,0(A)       A:=VAR; D:=INIT FORMS 
         IFATOM D,PROG$4      WHEN NO INIT FORM, INIT WITH NIL 
         PUSHW A              SAVE VARIABLE 
         LM    D,A,0(D)       A:=ONE INIT FORM; D:=REST 
         IFATOM D,PROG$3      IF THERE ARE MORE THAN ONE 
PROG$2   PUSHNC D               SAVE REST OF FORMS 
         BAL   L,EVAL           EVALUATE 
         POPW  D                RECOVER REST OF FORMS 
         LM    D,A,0(D)       A:=NEXT FORM; D:=REST 
         IFLIST D,PROG$2      REPEAT THIS UNTIL INIT FORMS END 
PROG$3   BAL   L,EVAL         EVALUATE THE LAST INIT FORM 
         LR    WW,A           WW:=INITIAL VALUE FOR PROG VAR 
         POPW  A              A:=PROG VAR 
         BIND  WW             BIND INITIAL VALUE 
         L     D,LOCAL3       RECOVER REST OF PROG VARS 
         IFATOM D,PROG$5      REPEAT UNTIL PROG VARS EXHAUST 
         LM     D,A,0(D)      A:=ONE PROG VAR; D:=REST 
         IFLIST A,PROG$1 
PROG$4   BIND  N              IF PROG VAR IS ATOM, BIND WITH NIL 
         CLR   NB,SL          CHECK STACK OVERFLOW 
         BNL   OVFLERR 
         IFLIST D,PROG$0      REPEAT UNTIL PROGVARS EXHAUST 
PROG$5   L     D,LOCAL1       D:=BODY OF PROG 
         IFATOM D,UNDORETN    IF BODY IS EMPTY THEN DO NOTHING 
PROG$6   LM    D,A,0(D)       A:=ONE STATEMENT; D:=REST 
         IFATOM A,PROG$7      ATOM IS A LABEL 
         ST    D,LOCAL2       SAVE REST OF STATEMENTS 
         BAL   L,EVREC        EVALUATE ONE STATEMENT 
         L     D,LOCAL2       RECOVER REST OF STATEMENTS 
PROG$7   IFLIST D,PROG$6      REPEAT UNTIL STATEMENTS EXHAUST 
         B     UNDORETN       UNDO AND RETURN NIL 
* 
PROGENT  EQU   PROG$7         ENTRY FOR "GO" 
* 
CATCH    SPEC  , 
CATCH#   IFATOM D,PARAMERR 
         L     X,CATCHTAG 
         ST    X,LOCAL1 
         LM    D,A,0(D) 
         ST    D,LOCAL2 
         LA    NB,LOCAL3 
         BAL   L,EVAL 
         L     D,LOCAL2 
         ST    A,LOCAL2 
         IFATOM D,RETNIL 
         LA    NB,LOCAL4 
CATCH$1  LM    D,A,0(D) 
         ST    D,LOCAL3 
         BAL   L,EVAL 
         L     D,LOCAL3 
         IFLIST D,CATCH$1 
         RET 
* 
GO       SPEC  , 
GO#      IFATOM D,PARAMERR 
         LM    D,A,0(D)       A:=LABEL TO GO 
         IFLIST D,PARAMERR 
         L     W,PROG         W:=PROG$ 
         LR    NB,SB 
         L     WW,STACKBTM 
         DROP  SB 
         USING STACK,NB 
GO$1     C     W,OLDCB        IS THE NEXT FRAME THAT OF PROG? 
         BE    GO$3           IF IT IS, JUMP 
GO$2     L     NB,OLDSB       OTHERWISE, GO UP TO NEXT FRAME 
         CLR   NB,WW          IF THE BOTTOM IS NOT REACHED 
         BH    GO$1             THEN LOOP 
         B     GOERR          !GO LABEL NOT FOUND 
GO$3     L     X,OLDSB        X:=BASE OF PROG FRAME 
         DROP  NB 
         USING STACK,X 
         L     X,LOCAL1       X:=TOP OF THE PROG BODY 
         DROP  X 
GO$4     IFATOM X,GO$2        IF END OF BODY, FIND ANOTHER 
         LM    X,NA,0(X)      NA:=ONE STAT OR LABEL; X:=REST 
         CR    A,NA           IF THE LABEL DOESN'T MATCH 
         BNE   GO$4             GO DOWN TO THE NEXT 
         LR    A,X            A:=CONTINUATION POINT 
         LR    CB,W           CB:=PROG$ 
         LR    SB,NB 
         USING STACK,SB 
         BAL   L,UNDO         UNDO UPTO THE FRAME NEXT TO PROG FRAME 
         LR    NB,SB          NB:=TOP OF STACK IN PROG FRAME 
         L     SB,OLDSB       SB:=BASE OF PROG FRAME 
         LR    D,A            A:=CONTINUATION POINT 
         B     PROGENT        JUMP INTO PROG INTERPRETER 
* 
QUOTE    SPEC 
QUOTE#   IFATOM D,PARAMERR 
         LM    D,A,0(D) 
         IFATOM D,0(E) 
         B     PARAMERR 
* 
FUNCTI   SPEC  PNAME='FUNCTION' 
FUNCTI#  EQU   QUOTE# 
* 
COMMENT  SPEC 
COMMENT# EQU   RETNIL 
* 
PROGN    SPEC 
PROGN#   IFATOM D,RETNIL 
         LA    NB,LOCAL2 
PROGN$1  LM    D,A,0(D) 
         ST    D,LOCAL1 
         BAL   L,EVAL 
         L     D,LOCAL1 
         IFLIST D,PROGN$1 
         RET 
* 
PROG1    SPEC 
PROG2    SPEC  , 
PROG2#   IFATOM D,PARAMERR 
         LM    D,A,0(D) 
         ST    D,LOCAL1 
         LA    NB,LOCAL2 
         BAL   L,EVAL 
         L     D,LOCAL1 
PROG1#   IFATOM D,PARAMERR 
         LM    D,A,0(D) 
         ST    D,LOCAL1 
         LA    NB,LOCAL2 
         BAL   L,EVAL 
         L     D,LOCAL1 
         IFATOM D,RETURN 
         ST    A,LOCAL2 
         LA    NB,LOCAL3 
PROG1$1  LM    D,A,0(D) 
         ST    D,LOCAL1 
         BAL   L,EVAL 
         L     D,LOCAL1 
         IFLIST D,PROG1$1 
         L     A,LOCAL2 
         RET 
* 
PUSH     SPEC 
PUSH#    IFATOM D,PARAMERR 
         LM    W,WW,0(D) 
         IFATOM W,PARAMERR 
         LM    D,A,0(W) 
         $SYMBOL 
         IFLIST D,PARAMERR 
         ST    A,LOCAL1 
         LR    A,WW 
         LA    NB,LOCAL2 
         BAL   L,EVAL 
         LR    D,A 
         L     A,LOCAL1 
         VALUEA 
         BAL   L,XCONS 
         L     D,LOCAL1 
         ST    A,0(D)         SET VALUE 
         RET 
* 
POP      SPEC 
POP#     IFATOM D,PARAMERR 
         LM    D,A,0(D) 
         $SYMBOL 
         LR    W,A 
         IFLIST D,PARAMERR 
         VALUEA 
         IFATOM A,TYPERR 
         LM    D,A,0(A) 
         ST    D,0(W) 
         RET 
* 
SETQ     SPEC 
SETQ#    IFATOM D,RETNIL 
         LM    D,A,0(D) 
         IFATOM D,PARAMERR 
         $SYMBOL , 
         ST    A,LOCAL1 
         LM    D,A,0(D) 
         LA    NB,LOCAL2 
         IFLIST D,SETQ$1 
         BAL   L,EVAL 
         L     D,LOCAL1 
         ST    A,0(D) 
         RET 
* 
SETQ$1   PUSHNC D 
         BAL   L,EVAL 
         POPW  D 
         PUSHNC A 
         LM    D,A,0(D) 
         IFATOM D,PARAMERR 
         $SYMBOL , 
         PUSHNC A 
         LM    D,A,0(D) 
         IFLIST D,SETQ$1 
         BAL   L,EVAL 
         POPW  D 
         ST    A,0(D) 
         LA    X,LOCAL1 
         CLR   NB,X 
         BER   E 
SETQ$2   SL    NB,F8 
         LM    W,WW,0(NB) 
         ST    WW,0(W) 
         CLR   NB,X 
         BNE   SETQ$2 
         RET 
* 
LOOP     SPEC  , 
LOOP#    LA    NB,LOCAL3 
         ST    D,LOCAL1 
LOOP$0   IFATOM D,LOOP$0 
LOOP$1   LM    D,A,0(D) 
         ST    D,LOCAL2 
         BAL   L,EVAL 
         L     D,LOCAL2 
         IFLIST D,LOOP$1 
         L     D,LOCAL1 
         B     LOOP$1 
* 
MATCH    SPEC  , 
MATCH#   IFATOM D,PARAMERR 
         LM    D,A,0(D)       A:=KEY FORM; D:=BODY 
         ST    D,LOCAL1       SAVE BODY 
         LA    NB,LOCAL2 
         BAL   L,EVAL         EVALUATE KEY FORM 
         ST    A,LOCAL2         AND STORE IN LOCAL2 
         L     NA,QUOTE       NA:=CONSTANT "QUOTE" 
         L     D,LOCAL1       D:=BODY 
         IFATOM D,RETNIL      WHEN BODY'S EMPTY, RETURN NIL 
MTCH$ONE LM    D,A,0(D)       A:=ONE CLAUSE; D:=REST 
         IFATOM A,TYPERR 
         ST    D,LOCAL1       SAVE REST OF CLAUSES 
         LM    D,A,0(A)       A:=PATTERN; D:=CONSEQUENTS 
         ST    D,LOCAL3       SAVE CONSEQUENTS 
         L     WW,LOCAL2      WW:=KEY 
         LA    NB,LOCAL4 
         LR    X,Z            X:=NOT-YET-MATCHED LIST 
         LR    L,Z            L:=ALREADY MATCHED LIST 
         IFATOM A,MTCH$ATM 
MTCH$LST C     NA,4(A)        IF CAR=QUOTE 
         BE    MTCH$QT          THAT'S A QUOTED ITEM 
MTCH$CNS IFATOM WW,MTCH$NO    KEY SHOULD BE CONS TO MATCH 
         LM    D,A,0(A)       A:=CAR; D:=CDR OF PATTERN 
         LM    W,WW,0(WW)     WW:=CAR; W:=CDR OF KEY 
         ST    X,0(NB)        SAVE CDRS AND 
         ST    W,4(NB)          LINK INTO NOT-YET LIST 
         ST    D,8(NB) 
         LR    X,NB 
         AL    NB,F12 
         CLR   NB,SL 
         BNL   OVFLERR 
         IFLIST A,MTCH$LST 
MTCH$ATM CR    A,N            IF NULL OR NOT SYMBOL 
         BNH   MTCH$EQ          THEN THEY MUST BE "EQ" 
         ST    L,0(NB)        OTHERWISE, 
         ST    WW,4(NB)         LINK INTO ALREADY-MATCHED LIST 
         ST    A,8(NB)          FOR LATER BINDING 
         LR    L,NB 
         AL    NB,F12 
         CLR   NB,SL 
         BNL   OVFLERR 
MTCH$NXT LTR   X,X            IF NOT-YET LIST EXHAUSTED 
         BZ    MTCH$OK          MATCHING WAS SUCCESSFUL 
MTCH$POP L     WW,4(X)        OTHERWISE 
         L     A,8(X)           GET ANOTHER PAIR FROM 
         L     X,0(X)           THE NOT-YET LIST 
         IFATOM A,MTCH$ATM 
         B     MTCH$LST 
* 
MTCH$QT  L     D,0(A)         D:=CDR OF (QUOTE ...) 
         IFATOM D,MTCH$CNS    IF CDR IS NOT ATOM 
         C     Z,0(D)           AND ITS CDDR IS AN ATOM 
         BH    MTCH$CNS 
         L     A,4(D)         THEN A:=QUOTED EXPRESSION 
MTCH$EQ  CR    A,WW           COMPARE KEY AND PATTERN 
         BE    MTCH$NXT       ONLY MATCHES WHEN "EQ" 
MTCH$NO  L     D,LOCAL1       GET ANOTHER CLAUSE 
         IFLIST D,MTCH$ONE    IF THERE REMAIN ANY, LOOP 
         B     RETNIL 
* 
MTCH$OK  LA    NB,LOCAL4 
         LR    X,Z            NREVERSE THE ALREADY-MATCHED LIST 
         LTR   L,L 
         BZ    MTCH$PRN 
MTCH$NRV L     W,0(L) 
         ST    X,0(L) 
         LR    X,L 
         LTR   L,W 
         BNZ   MTCH$NRV 
MTCH$BND LM    NA,A,0(X)      D:=KEY; A:=SYMBOL; NA:=NEXT 
         BIND  D              BIND 
         LTR   X,NA           REPEAT UNTIL 
         BNZ   MTCH$BND         THE LIST EXAUST 
MTCH$PRN L     D,LOCAL3       D:=CONSEQUENTS 
         IFATOM D,UNDORETN    NO CONSEQUENTS MEANS NIL 
         LM    D,A,0(D)       A:=ONE FORM; D:=REST 
         IFATOM D,MTCH$EVL 
MTCH$LOP ST    D,LOCAL3       SAVE THE REST 
         BAL   L,EVAL         EVALUATE ONE FORM 
         L     D,LOCAL3 
         LM    D,A,0(D)       REPEAT UNTIL 
         IFLIST D,MTCH$LOP      THE LAST FORM IS REACHED 
MTCH$EVL BAL   L,EVAL         EVALUATE THE LAST FORM 
         B     UNDORET        UNDO AND RETURN THAT RESULT 
         TITLE 'COMMONLY USED PREDICATES' 
*********************************************************************** 
* 
* PREDICATES 
* 
PREDEF   CSECT 
* 
ATOM     SUBR  1,1 
         C     Z,LOCAL1 
         BNH   RETT 
         CODEND RETNIL 
* 
NUMBERP  SUBR  1,1 
         L     A,LOCAL1 
         CL    A,MAXNUM 
         BL    RETT 
         CODEND RETNIL 
* 
STRINGP  SUBR  1,1 
         CLI   LOCAL1,STRNGTAG 
         BE    RETT 
         CODEND RETNIL 
* 
STREAMP  SUBR  1,1 
         CLI   LOCAL1,STRMTAG 
         BE    RETT 
         CODEND RETNIL 
* 
VECTORP  SUBR  1,1 
         CLI   LOCAL1,VECTAG 
         BE    RETT 
         CODEND RETNIL 
* 
REFERP   SUBR  1,1,PNAME='REFERENCEP' 
         CLI   LOCAL1,REFTAG 
         BE    RETT 
         CODEND RETNIL 
* 
SYMBOLP  SUBR  1,1 
         C     N,LOCAL1 
         BNH   RETT 
         CODEND RETNIL 
* 
CONSP    SUBR  1,1 
         C     Z,LOCAL1 
         BH    RETT 
         CODEND RETNIL 
* 
LISTP    ALIAS CONSP 
* 
CODEP    SUBR  1,1 
         CLI   LOCAL1,CODETAG 
         BE    RETT 
         CODEND RETNIL 
* 
PREDEF   SUBR  1,1,PNAME='PREDEFINEDP' 
         L     A,LOCAL1 
         IFFIX A,RETNIL 
         LA    A,0(A) 
         CL    A,=A(PREEND) 
         BL    RETT 
         CODEND RETNIL 
* 
EQ       SUBR  2,2 
         LM    D,A,LOCAL1 
         CR    D,A 
         BE    RETT 
         CODEND RETNIL 
* 
NEQ      SUBR  2,2 
         LM    D,A,LOCAL1 
         CR    D,A 
         BNE   RETT 
         CODEND RETNIL 
* 
EQUAL    SUBR  2,2 
         LM    D,A,LOCAL1 
         LA    NB,LOCAL3 
         BAL   L,EQUAL 
         BE    RETT 
         CODEND RETNIL 
* 
NOT      SUBR  1,1 
         C     N,LOCAL1 
         BE    RETT 
         CODEND RETNIL 
* 
NULL     SUBR  1,1 
         C     N,LOCAL1 
         BE    RETT 
         CODEND RETNIL 
* 
FIXP     SUBR  1,1 
         L     A,LOCAL1 
         CL    A,MAXFIX 
         BL    RETT 
         CODEND RETNIL 
* 
FLOATP   SUBR  1,1 
         CLI   LOCAL1,FLOTAG 
         BE    RETT 
         CODEND RETNIL 
         TITLE 'EVALUATION FUNCTIONS' 
*********************************************************************** 
* 
* EVALUATION 
* 
EVAL     SUBR  1,1 
         L     A,LOCAL1 
         LA    NB,LOCAL2 
         B     EVANDRET 
         CODEND 
* 
APPLY    SUBR  2,2 
         L     A,LOCAL1 
         L     W,LOCAL2 
         LA    NB,LOCAL6      LOCAL3, 4, 5 ARE STACK MARK FOR FC 
         LR    D,NB 
         IFATOM W,APPLY2 
APPLY1   LM    W,WW,0(W) 
         PUSHW WW 
         IFLIST W,APPLY1 
APPLY2   LR    NA,NB 
         SLR   NA,D 
         LA    NB,LOCAL3 
         TAILREC FUNCALL 
         CODEND 
* 
FUNCALL  LSUBR 
         LA    D,LOCAL2 
         LR    A,NA 
         SR    A,F 
         BM    PARAMERR       !FUNCTION IS NOT SUPPLIED 
         LA    W,LOCAL5(NA)   LOCAL2,3,4(NA) ARE STACK MARK 
         LR    WW,A 
         LA    X,0(NA,W)      CHECK OVERFLOW 
         BXH   X,F,OVFLERR 
         MVCL  W,D 
         LA    NB,LOCAL2(NA) 
         L     A,LOCAL1 
         SLR   NA,F 
         TAILREC FUNCALL 
         CODEND 
* 
LET      CMACRO 
         L     A,LOCAL1 
         IFATOM A,PARAMERR 
         LM    D,A,0(A) 
         ST    D,LOCAL1       BODY OF "LET" 
         ST    N,LOCAL2       LOCAL2 : FORMALS 
         ST    N,LOCAL3       LOCAL3 : ACTUALS 
         IFATOM A,LET$2 
LET$1    LM    D,A,0(A) 
         ST    D,LOCAL4 
         IFATOM A,PARAMERR 
         LM    D,A,0(A)       A:=ONE FORMAL 
         ST    D,LOCAL5 
         L     D,LOCAL2 
         LA    NB,LOCAL6 
         BAL   L,CONS 
         ST    A,LOCAL2 
         L     A,LOCAL5       A:=(FORM) 
         IFATOM A,PARAMERR 
         LM    D,A,0(A) 
         IFLIST D,PARAMERR 
         L     D,LOCAL3 
         LA    NB,LOCAL5 
         BAL   L,CONS 
         ST    A,LOCAL3 
         L     A,LOCAL4 
         IFLIST A,LET$1 
LET$2    L     D,LOCAL1       BODY 
         L     A,LOCAL2       FORMALS 
         IFATOM A,LET$4       NREVERSE FORMALS 
         LR    W,N 
LET$3    L     WW,0(A) 
         ST    W,0(A) 
         LR    W,A 
         LR    A,WW 
         IFLIST A,LET$3 
         LR    A,W 
LET$4    LA    NB,LOCAL4 
         BAL   L,CONS 
         L     D,LAMBDA 
         BAL   L,XCONS 
         L     D,LOCAL3       ACTUALS 
         IFATOM D,LET$6       NREVERSE ACTUALS 
         LR    W,N 
LET$5    L     WW,0(D) 
         ST    W,0(D) 
         LR    W,D 
         LR    D,WW 
         IFLIST D,LET$5 
         LR    D,W 
LET$6    B     CONSNRET 
         CODEND 
* 
LETS     CMACRO 
         L     D,LOCAL1 
         L     A,LAMBDA 
         LA    NB,LOCAL2 
         LA    L,NCONSRET 
         B     CONS 
         CODEND 
         TITLE 'CONTROL STRUCTURES' 
*********************************************************************** 
* 
* FLOW CONTROL 
* 
RETURN   LSUBR 
         L     W,PROG         W:=PROG$ 
         LR    NB,SB 
         L     WW,STACKBTM 
         DROP  SB 
         USING STACK,NB 
RET$1    C     W,OLDCB        IF THE NEXT FRAME IS THAT OF PROG 
         BE    RET$2            THEN JUMP 
         L     NB,OLDSB       OTHERWISE GO UP TO NEXT FRAME 
         CLR   NB,WW          LOOP IF 
         BH    RET$1            THE BOTTOM IS NOT REACHED 
         B     RETERR         !RETURN OUTSIDE PROG 
         DROP  NB 
         USING STACK,SB 
RET$2    LR    A,N 
         LTR   NA,NA 
         BZ    RET$3 
         L     A,LOCAL1-4(NA) 
RET$3    DS    0H 
         DROP  SB 
         USING STACK,NB 
         L     SB,OLDSB 
         DROP  NB 
         USING STACK,SB 
         B     UNDORET 
         CODEND 
* 
EXIT     LSUBR 
         L     W,LOOP 
         LR    NB,SB 
         L     WW,STACKBTM 
         DROP  SB 
         USING STACK,NB 
EXIT$1   C     W,OLDCB 
         BE    EXIT$2 
         L     NB,OLDSB 
         CLR   NB,WW 
         BH    EXIT$1 
         B     RETERR 
         DROP  NB 
         USING STACK,SB 
EXIT$2   LR    A,N 
         LTR   NA,NA 
         BZ    EXIT$3 
         L     A,LOCAL1-4(NA) 
EXIT$3   DS    0H 
         DROP  SB 
         USING STACK,NB 
         L     SB,OLDSB 
         DROP  NB 
         USING STACK,SB 
         B     UNDORET 
         CODEND 
* 
UNBRK    LSUBR PNAME='UNBREAK' 
         L     W,BREAK 
         LR    NB,SB 
         L     WW,STACKBTM 
         DROP  SB 
         USING STACK,NB 
UBRK$1   C     W,OLDCB 
         BE    UBRK$2 
         L     NB,OLDSB 
         CLR   NB,WW 
         BH    UBRK$1 
         B     RETERR 
         DROP  NB 
         USING STACK,SB 
UBRK$2   LR    A,N 
         LTR   NA,NA 
         BZ    UBRK$3 
         L     A,LOCAL1-4(NA) 
UBRK$3   DS    0H 
         DROP  SB 
         USING STACK,NB 
         L     SB,OLDSB 
         DROP  NB 
         USING STACK,SB 
         B     UNDORET 
         CODEND 
* 
THROW    LSUBR 
         LTR   NA,NA 
         BZ    PARAMERR 
         L     W,CATCHTAG     ; W:= CATCHTAG 
         L     A,LOCAL1       A:=TAG 
         LR    X,SB 
         L     WW,STACKBTM 
         DROP  SB 
         USING STACK,X 
THROW$1  C     W,LOCAL1       ; IS THE CURRENT ONE CATCH FRAME ? 
         BE    THROW$2        IF IT IS, EXIT LOOP 
THROW$1A CLR   X,WW           IF BOTTOM 
         BNH   CATCHERR       !THROWN TAG NOT CAUGHT 
         L     X,OLDSB        ELSE GO UP TO ANOTHER FRAME 
         B     THROW$1        AND LOOP 
THROW$2  EQU   *              ; X = BASE OF A CATCH FRAME 
         C     A,LOCAL2       DOES THE TAG MATCH? 
         BNE   THROW$1A       IF NOT, FIND ANOTHER 
         DROP  X 
         USING STACK,SB 
         LR    A,N 
         CR    NA,F 
         BE    THROW$3 
         L     A,LOCAL1-4(NA) 
THROW$3  LR    SB,X 
         B     UNDORET 
         CODEND 
* 
         TITLE 'MAPPING FUNCTIONS' 
*********************************************************************** 
* 
* MAPPING FUNCTIONS 
* 
MAP      SUBR  2,2 
         L     D,LOCAL1 
         IFATOM D,MAP$2 
         LA    NB,LOCAL4 
MAP$1    L     W,0(D)         SAVE CDR 
         ST    W,LOCAL3 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         L     D,LOCAL3 
         IFLIST D,MAP$1 
MAP$2    L     A,LOCAL1 
         CODEND RET 
* 
MAPC     SUBR  2,2 
         L     A,LOCAL1 
         IFATOM A,RETURN 
         LA    NB,LOCAL4 
MAPC$1   LM    D,A,0(A) 
         ST    D,LOCAL3 
         LR    D,A 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         L     A,LOCAL3 
         IFLIST A,MAPC$1 
         L     A,LOCAL1 
         CODEND RET 
* 
MAPLIST  SUBR  2,2 
         LA    NB,LOCAL3 
         L     D,LOCAL1 
         IFATOM D,RETNIL 
MAPL$1   L     W,0(D)         SAVE CDR 
         ST    W,LOCAL1 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         PUSHW A 
         L     D,LOCAL1 
         IFLIST D,MAPL$1 
         LR    NA,NB 
         LA    W,LOCAL3 
         SLR   NA,W 
         B     MKLISTNR 
         CODEND 
* 
MAPCAR   SUBR  2,2 
         LA    NB,LOCAL3 
         L     D,LOCAL1 
         IFATOM D,RETNIL 
MAPCAR$1 LM    NA,D,0(D) 
         ST    NA,LOCAL1 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         PUSHW A 
         L     D,LOCAL1 
         IFLIST D,MAPCAR$1 
         LR    NA,NB 
         LA    W,LOCAL3 
         SLR   NA,W 
         B     MKLISTNR 
         CODEND 
* 
MAPCON   SUBR  2,2 
         LA    NB,LOCAL3 
MAPCON$1 L     D,LOCAL1 
         IFATOM D,RETNIL 
         L     W,0(D) 
         ST    W,LOCAL1 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         IFATOM A,MAPCON$1 
         L     D,LOCAL1 
         IFATOM D,RETURN 
         ST    A,LOCAL3 
         LA    NB,LOCAL5 
         ST    A,LOCAL4 
MAPCON$2 L     W,0(D) 
         ST    W,LOCAL1 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         IFATOM A,MAPCON$5 
         L     W,LOCAL4 
         B     MAPCON$4 
MAPCON$3 L     W,0(W) 
MAPCON$4 C     Z,0(W) 
         BH    MAPCON$3 
         ST    A,0(W)         RPLACD 
         ST    A,LOCAL4 
MAPCON$5 L     D,LOCAL1 
         IFLIST D,MAPCON$2 
         L     A,LOCAL3 
         CODEND RET 
* 
MAPCAN   SUBR  2,2 
         LA    NB,LOCAL3 
MAPCAN$1 L     D,LOCAL1 
         IFATOM D,RETNIL 
         LM    NA,D,0(D) 
         ST    NA,LOCAL1 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         IFATOM A,MAPCAN$1 
         L     D,LOCAL1 
         IFATOM D,RETURN 
         ST    A,LOCAL3 
         LA    NB,LOCAL5 
         ST    A,LOCAL4 
MAPCAN$2 LM    NA,D,0(D) 
         ST    NA,LOCAL1 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         IFATOM A,MAPCAN$5 
         L     W,LOCAL4 
         B     MAPCAN$4 
MAPCAN$3 L     W,0(W) 
MAPCAN$4 C     Z,0(W) 
         BH    MAPCAN$3 
         ST    A,0(W)         RPLACD 
         ST    A,LOCAL4 
MAPCAN$5 L     D,LOCAL1 
         IFLIST D,MAPCAN$2 
         L     A,LOCAL3 
         CODEND RET 
* 
MAPV     SUBR  2,2 
         L     A,LOCAL1 
         $VECTOR 
         LR    X,Z 
         C     X,0(A) 
         BE    RETNIL         LENGTH=0 
         LA    NB,LOCAL4 
MAPV$1   ST    X,LOCAL3       SAVE INDEX 
         LA    D,4(X,A) 
         O     D,@REFER 
         L     A,LOCAL2 
         BAL   L,FUNCALLD     APPLY THE FUNCTION 
         L     A,LOCAL1 
         L     X,LOCAL3       RECOVER THE INDEX 
         AR    X,F            INCREMENT INDEX 
         C     X,0(A) 
         BNE   MAPV$1 
         CODEND RET 
* 
MAPVECT  SUBR  2,2,PNAME='MAPVECTOR' 
         L     A,LOCAL1 
         $VECTOR 
         L     A,0(A) 
         SRL   A,2 
         LA    NB,LOCAL3 
         BAL   L,MKVECTOR 
         ST    A,LOCAL3 
         LA    NB,LOCAL5 
         LR    X,Z 
         B     MAPVEC$2 
MAPVEC$1 ST    X,LOCAL4 
         L     D,4(X,A) 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         L     X,LOCAL4 
         L     W,LOCAL3 
         ST    A,4(X,W) 
         ALR   X,F 
         AL    D,F1 
MAPVEC$2 L     A,LOCAL1 
         C     X,0(A) 
         BNE   MAPVEC$1 
         L     A,LOCAL3 
         CODEND RET 
         TITLE 'LIST MANIPULATION FUNCTIONS' 
*********************************************************************** 
* 
* LIST STRUCTURE MANIPULATION 
* 
CR       C$R , 
* 
CAR      C$R , 
CDR      C$R , 
* 
CAAR     C$R , 
CADR     C$R , 
CDAR     C$R , 
CDDR     C$R , 
* 
CAAAR    C$R , 
CAADR    C$R , 
CADAR    C$R , 
CADDR    C$R , 
CDAAR    C$R , 
CDADR    C$R , 
CDDAR    C$R , 
CDDDR    C$R , 
* 
CAAAAR   C$R , 
CAAADR   C$R , 
CAADAR   C$R , 
CAADDR   C$R , 
CADAAR   C$R , 
CADADR   C$R , 
CADDAR   C$R , 
CADDDR   C$R , 
CDAAAR   C$R , 
CDAADR   C$R , 
CDADAR   C$R , 
CDADDR   C$R , 
CDDAAR   C$R , 
CDDADR   C$R , 
CDDDAR   C$R , 
CDDDDR   C$R , 
* 
CONS     SUBR  2,2 
         LM    D,A,LOCAL1 
         LA    NB,LOCAL3 
         B     XCONSRET 
         CODEND 
* 
NCONS    SUBR  1,1 
         L     A,LOCAL1 
         LA    NB,LOCAL2 
         B     NCONSRET 
         CODEND 
* 
XCONS    SUBR  2,2 
         LM    D,A,LOCAL1 
         LA    NB,LOCAL3 
         B     CONSNRET 
         CODEND 
* 
LAST     SUBR  1,1 
         L     D,LOCAL1 
         IFATOM D,TYPERRD 
LAST$1   LR    A,D 
         L     D,0(D) 
         IFLIST D,LAST$1 
         CODEND RET 
* 
LENGTH   SUBR  1,1 
         L     D,LOCAL1 
         LR    A,Z 
         IFATOM D,RETNUM 
LENGTH$1 L     D,0(D) 
         LA    A,1(A) 
         IFLIST D,LENGTH$1 
         CODEND RETNUM 
* 
FIRST    ALIAS CAR 
* 
SECOND   ALIAS CADR 
* 
THIRD    ALIAS CADDR 
* 
FOURTH   SUBR  1,1 
         L     A,LOCAL1 
         CDRA 
         CDRA 
         CDRA 
         CARA 
         CODEND RET 
* 
FIFTH    SUBR  1,1 
         L     A,LOCAL1 
         CDRA 
         CDRA 
         CDRA 
         CDRA 
         CARA 
         CODEND RET 
* 
SIXTH    SUBR  1,1 
         L     A,LOCAL1 
         CDRA 
         CDRA 
         CDRA 
         CDRA 
         CDRA 
         CARA 
         CODEND RET 
* 
SEVENTH  SUBR  1,1 
         L     A,LOCAL1 
         CDRA 
         CDRA 
         CDRA 
         CDRA 
         CDRA 
         CDRA 
         CARA 
         CODEND RET 
* 
NTH      SUBR  2,2 
         L     A,LOCAL1 
         $POSFIX 
         LA    W,1(A)         W:=N+1 
         L     A,LOCAL2 
         B     NTH$2 
NTH$1    CDRA 
NTH$2    BCT   W,NTH$1 
         CARA 
         CODEND RET 
* 
NTHCDR   SUBR  2,2 
         L     A,LOCAL1 
         $POSFIX 
         LA    W,1(A) 
         L     A,LOCAL2 
         B     NTHCDR$2 
NTHCDR$1 CDRA 
NTHCDR$2 BCT   W,NTHCDR$1 
         CODEND RET 
* 
LIST     LSUBR 
         LA    NB,LOCAL1(NA) 
         B     MKLISTNR 
         CODEND 
* 
APPEND   LSUBR 
         CR    NA,F           IF NO ACTUAL 
         BL    RETNIL           RETURN NIL 
         L     A,LOCAL1       IF ONLY ONE ACTUAL 
         BER   E                THEN RETURN THAT 
         LR    X,F            SET INDEX 
         LA    NB,LOCAL1(NA)  SET NB TO STACK TOP 
APPEND$2 IFATOM A,APPEND$4    IF THE ARG IS AN ATOM, SKIP THAT ONE 
         LR    D,A 
APPEND$3 LM    D,A,0(D)       PUSH CAR AND TAKE CDR 
         PUSHW A 
         IFLIST D,APPEND$3    REPEAT THAT UNTIL IT BECOMES AN ATOM 
APPEND$4 L     A,LOCAL1(X)    NEXT ARG ON A 
         ALR   X,F            ADVANCE INDEX 
         CR    X,NA           IF IT IS NOT THE LAST ONE 
         BNE   APPEND$2         REPEAT SPREADING OUT. 
         LA    NA,LOCAL1(NA)  COMPUTE NUMBER OF CONSES REQUIRED 
         SR    NA,NB            ON NA REGISTER 
         LCR   NA,NA 
         B     MKLISTR 
         CODEND 
* 
REVERSE  SUBR  1,1 
         L     A,LOCAL1 
         IFATOM A,RETURN 
         LA    NB,LOCAL3 
         LR    W,A 
         LR    A,N 
REVERS$1 LM    W,WW,0(W) 
         ST    W,LOCAL2 
         LR    D,WW 
         BAL   L,XCONS 
         L     W,LOCAL2 
         IFLIST W,REVERS$1 
         CODEND RET 
* 
NCONC    LSUBR 
         SR    NA,F 
         BM    RETNIL 
         L     A,LOCAL1(NA) 
NCONC$1  SR    NA,F 
         BMR   E 
NCONC$2  L     D,LOCAL1(NA) 
         IFATOM D,NCONC$1 
         LR    X,D 
         C     Z,0(X) 
         BNH   NCONC$4 
NCONC$3  L     X,0(X) 
         C     Z,0(X) 
         BH    NCONC$3 
NCONC$4  ST    A,0(X) 
         LR    A,D 
         SR    NA,F 
         BNM   NCONC$2 
         CODEND RET 
* 
NREVERS  SUBR  1,1,PNAME='NREVERSE' 
         L     A,LOCAL1 
         IFATOM A,RETURN 
         LR    D,N 
NREVER$1 L     W,0(A) 
         ST    D,0(A) 
         LR    D,A 
         LR    A,W 
         IFLIST A,NREVER$1 
         LR    A,D 
         CODEND RET 
* 
RPLACA   SUBR  2,2 
         LM    D,A,LOCAL1 
         IFATOM D,TYPERR1 
         ST    A,4(D) 
         LR    A,D 
         CODEND RET 
* 
RPLACD   SUBR  2,2 
         LM    D,A,LOCAL1 
         IFATOM D,TYPERR1 
         ST    A,0(D) 
         LR    A,D 
         CODEND RET 
* 
MEMQ     SUBR  2,2 
         LM    D,A,LOCAL1 
         IFATOM A,RETNIL 
MEMQ$1   C     D,4(A) 
         BER   E 
         L     A,0(A) 
         IFLIST A,MEMQ$1 
         CODEND RETNIL 
* 
DELQ     SUBR  2,3 
         B     DELQ$1 
         L     X,LOCAL3       X:=COUNT 
         $FIXNUM3 X 
         L     A,LOCAL2       A:=LIST FROM WHICH ITEMS ARE DELETED 
         N     X,IVALMASK     IF COUNT = 0 
         BNZ   DELQ$2 
         RET   ,                THEN RETURN THE LIST 
DELQ$1   LR    X,Z            DEFAULT VALUE FOR COUNT = 0 
         L     A,LOCAL2       A:= LIST 
DELQ$2   L     NA,LOCAL1      NA:=ITEM TO BE DELETED 
DELQ$3   IFATOM A,RETURN      IF THE LIST BECAME AN ATOM, RETURN IT 
         C     NA,4(A)        IF CAR OF LIST IS THE ITEM TO BE DELETED 
         BNE   DELQ$4 
         L     A,0(A)           DELETE IT AND REPEAT 
         BCT   X,DELQ$3         AS FAR AS COUNT IS NOT EXCEEDED 
         RET 
DELQ$4   LR    D,A 
DELQ$5   L     W,0(D)         NEXT CELL ON W 
DELQ$6   IFATOM W,RETURN      IF THE LIST EXHAUSTED, RETURN 
         C     NA,4(W)        IF CAR IS NOT EQ TO ITEM 
         BE    DELQ$7 
         LR    D,W              THEN ADVANCE TO NEXT 
         B     DELQ$5 
DELQ$7   L     W,0(W)         OTHERWISE 
         ST    W,0(D)           DELETE IT BY RPLACD'ING 
         BCT   X,DELQ$6 
         CODEND RET 
* 
REMQ     SUBR  2,3 
         B     REMQ$1 
         L     X,LOCAL3       X:=# OF ITEMS TO BE REMOVED 
         $FIXNUM3 X           CHECK TYPE 
         N     X,IVALMASK     IF NOTHING SHOULD BE DELETED 
         BNZ   REMQ$2 
REMQ$0   L     A,LOCAL2         THEN RETURN THE LIST ITSELF 
         RET 
REMQ$1   LR    X,Z            X:=0 (REMOVE EVERY MATCHED ITEM) 
REMQ$2   LA    NB,LOCAL3      SET STACK POINTER 
         L     W,LOCAL1       W:=ITEM TO BE REMOVED 
         L     D,LOCAL2       D:=LIST FROM WHICH ITEMS ARE REMOVED 
REMQ$3   IFATOM D,REMQ$5      IF END OF LIST IS NOT REACHED YET 
         LM    D,A,0(D)         A:=ONE ITEM OF LIST; D:=REST 
         CR    A,W              IF CAR IS THE PART TO BE REMOVED 
         BE    REMQ$4             THEN DO NOTHING 
         PUSHW A                ELSE SAVE THAT ITEM ON THE STACK 
         B     REMQ$3             AND LOOP 
REMQ$4   BCT   X,REMQ$3       IF MORE ITEMS ARE TO BE REMOVED, LOOP 
REMQ$5   LA    X,LOCAL3       X:=END OF CONSING SATCK POS. 
         LR    A,D            A:=LIST TAIL 
         B     REMQ$7 
REMQ$6   POPW  D              D:=LIST ITEM 
         BAL   L,XCONS        CONS WITH THE TAIL 
REMQ$7   CR    X,NB           LOOP UNTIL 
         BNE   REMQ$6           THE END REACHED 
         CODEND RET 
* 
MEMBER   SUBR  2,2 
         L     D,LOCAL2 
         IFATOM D,RETNIL 
MEMBER$1 L     A,4(D) 
         L     D,LOCAL1 
         LA    NB,LOCAL3 
         BAL   L,EQUAL 
         BE    MEMBER$2 
         L     D,LOCAL2 
         L     D,0(D) 
         ST    D,LOCAL2 
         IFLIST D,MEMBER$1 
         B     RETNIL 
MEMBER$2 L     A,LOCAL2 
         CODEND RET 
* 
MEM      SUBR  3,3 
         L     D,LOCAL3 
         IFATOM D,RETNIL 
         LA    NB,LOCAL4 
MEM$1    L     A,4(D) 
         ST    A,LOCAL8 
         L     A,LOCAL2 
         ST    A,LOCAL7 
         L     A,LOCAL1 
         BAL   L,FUNCALL2 
         IFNONNUL A,MEM$2 
         L     D,LOCAL3 
         L     D,0(D) 
         ST    D,LOCAL3 
         IFLIST D,MEM$1 
         B     RETNIL 
MEM$2    L     A,LOCAL3 
         CODEND RET 
* 
EVERY    SUBR  2,2 
         LA    NB,LOCAL3 
         L     D,LOCAL1 
         IFATOM D,RETT 
EVERY$1  LM    NA,D,0(D) 
         ST    NA,LOCAL1 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         CR    A,N 
         BER   E 
         L     D,LOCAL1 
         IFLIST D,EVERY$1 
         CODEND RETT 
* 
SOME     SUBR  2,2 
         LA    NB,LOCAL3 
         L     A,LOCAL1 
         IFATOM A,RETNIL 
SOME$1   L     D,4(A) 
         L     A,LOCAL2 
         BAL   L,FUNCALLD 
         CR    A,N 
         L     A,LOCAL1 
         BNER  E 
         L     A,0(A) 
         ST    A,LOCAL1 
         IFLIST A,SOME$1 
         CODEND RETNIL 
* 
ASSQ     SUBR  2,2 
         L     W,LOCAL1 
         L     D,LOCAL2 
         IFATOM D,RETNIL 
ASSQ$1   LM    D,A,0(D) 
         IFATOM A,ASSQ$2 
         C     W,4(A) 
         BER   E 
ASSQ$2   IFLIST D,ASSQ$1 
         CODEND RETNIL 
* 
ASSOC    SUBR  2,2 
         L     D,LOCAL2 
         IFATOM D,RETNIL 
         LA    NB,LOCAL4 
ASSOC$1  LM    D,A,0(D) 
         IFATOM A,ASSOC$2 
         STM   D,A,LOCAL2 
         L     A,4(A) 
         L     D,LOCAL1 
         BAL   L,EQUAL 
         BE    ASSOC$3 
         L     D,LOCAL2 
ASSOC$2  IFLIST D,ASSOC$1 
         B     RETNIL 
ASSOC$3  L     A,LOCAL3 
         CODEND RET 
* 
ASS      SUBR  3,3 
         L     D,LOCAL3 
         IFATOM D,RETNIL 
         LA    NB,LOCAL6 
ASS$1    LM    D,A,0(D) 
         IFATOM A,ASS$2 
         STM   D,A,LOCAL4 
         L     A,4(A) 
         L     D,LOCAL2 
         STM   D,A,LOCAL9 
         L     A,LOCAL1 
         BAL   L,FUNCALL2 
         IFNONNUL A,ASS$3 
         L     D,LOCAL4 
ASS$2    IFLIST D,ASS$1 
         B     RETNIL 
ASS$3    L     A,LOCAL5 
         CODEND RET 
* 
COPY     SUBR  1,1 
         L     A,LOCAL1 
         IFATOM A,RETURN 
         LA    NB,LOCAL2 
         LR    X,NB 
COPY$1   LR    NA,Z 
COPY$2   LM    D,A,0(A) 
         ALR   NA,F 
         IFATOM A,COPY$4 
         STM   NA,D,0(NB) 
         ALR   NB,F 
         BXLE  NB,F,COPY$1 
         B     OVFLERR 
COPY$3   SL    NB,F8 
         LM    NA,D,0(NB) 
COPY$4   PUSHW A 
         LR    A,D 
         IFLIST A,COPY$2 
         BAL   L,MKLIST 
         CR    NB,X 
         BNE   COPY$3 
         CODEND RET 
* 
SUBST    SUBR  3,3 
         L     A,LOCAL3       A:=WHOLE S-EXPR 
         C     A,LOCAL2       IF WHOLE S-EXPR = SUBSTITUENT 
         BNE   SUBST$1          THEN 
         L     A,LOCAL1           RETURN THE SUBSTITUTER 
         RET   , 
* 
SUBST$1  IFATOM A,RETURN      IF WHOLE S-EXPR IS ATOM, RETURN THAT 
         LA    NB,LOCAL4      SET STACK POINTER 
         LR    X,NB           X:=BOTTOM OF STACK FOR "SUBST" 
         B     SUBST$3 
* 
SUBST$3  LR    NA,Z            INITIATE LIST ITEM COUNTER 
SUBST$4  LM    D,A,0(A)       A:=ONE LIST ITEM; D:=REST 
         ALR   NA,F           INCREMENT COUNTER 
         C     A,LOCAL2       IF THE ITEM <> SUBSTITUENT 
         BE    SUBST$5          THEN 
         IFATOM A,SUBST$6 
         STM   NA,D,0(NB)     PUSH COUNTER AND REST OF LIST 
         ALR   NB,F 
         BXLE  NB,F,SUBST$3 
         B     OVFLERR 
* 
SUBST$5  L     A,LOCAL1       SUBSTITUTE BY THE SUBSTITUTER 
SUBST$6  PUSHW A              PUSH THE ITEM (POSSIBLY SUBSTITUTED) 
         LR    A,D            A:=REST OF THE LIST 
         C     A,LOCAL2       IF REST <> SUBSTITUENT 
         BE    SUBST$7          THEN 
         IFLIST A,SUBST$4     IF REST IS A LIST, THEN LOOP 
         B     SUBST$8        OTHERWISE, ITS THE END OF LIST 
* 
SUBST$7  L     A,LOCAL1       SUBSTITUTE LIST TAIL 
SUBST$8  BAL   L,MKLIST 
         CR    NB,X           IF STACK FOR SUBST ENAHAUSTED 
         BER   E                THEN THAT'S ALL 
         SL    NB,F8 
         LM    NA,D,0(NB)      POP COUNTER & REST OF PARENT LIST 
         B     SUBST$6        AND LOOP 
         CODEND , 
         TITLE 'SYMBOL MANIPULATION FUNCTIONS' 
*********************************************************************** 
* 
* FUNCTIONS ON SYMBOLS 
* 
SET      SUBR  2,2 
         LM    D,A,LOCAL1 
         $SYMBOL1 D 
         ST    A,0(D) 
         CODEND RET 
* 
MKUB     SUBR  1,1,PNAME='MAKE-UNBOUND' 
         L     A,LOCAL1 
         $SYMBOL 
         MVI   0(A),UBVTAG 
         CODEND RET 
* 
BOUNDP   SUBR  1,1 
         L     A,LOCAL1 
         $SYMBOL 
         CLI   0(A),UBVTAG 
         BNE   RETT 
         CODEND RETNIL 
* 
GET      SUBR  2,2 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         L     D,PROPERTY 
         DROP  A 
         IFATOM D,RETNIL 
         L     W,LOCAL2       W:=INDICATOR 
GET$1    LM    D,A,0(D) 
         CR    A,W 
         BE    GET$2 
         IFATOM D,RETNIL 
         L     D,0(D) 
         IFLIST D,GET$1 
         B     RETNIL 
GET$2    IFATOM D,RETNIL 
         L     A,4(D) 
         CODEND RET 
* 
PUTPROP  SUBR  3,3 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         L     D,PROPERTY 
         DROP  A 
         IFATOM D,PUTP$2 
PUTP$1   LM    D,A,0(D) 
         C     A,LOCAL3 
         BE    PUTP$3 
         IFATOM D,PUTP$2 
         L     D,0(D) 
         IFLIST D,PUTP$1 
PUTP$2   L     A,LOCAL1 
         USING SYMBOL,A 
         L     D,PROPERTY 
         DROP  A 
         L     A,LOCAL2 
         LA    NB,LOCAL4 
         BAL   L,CONS 
         L     D,LOCAL3 
         BAL   L,XCONS 
         L     D,LOCAL1 
         USING SYMBOL,D 
         ST    A,PROPERTY 
         DROP  D 
         L     A,LOCAL2 
         BR    E 
PUTP$3   IFATOM D,PUTP$2 
         L     A,LOCAL2 
         ST    A,4(D) 
         CODEND RET 
* 
REMPROP  SUBR  2,2 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         LA    D,PROPERTY 
         L     W,LOCAL2       INDICATOR 
REMP$1   L     A,0(D) 
         IFATOM A,RETNIL 
         C     W,4(A) 
         BE    REMP$2 
         L     D,0(A) 
         IFLIST D,REMP$1 
         B     RETNIL 
REMP$2   L     A,0(A) 
         IFATOM A,REMP$3 
         L     A,0(A) 
REMP$3   ST    A,0(D) 
         CODEND RETNIL 
* 
PLIST    SUBR  1,1 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         L     A,PROPERTY 
         DROP  A 
         CODEND RET 
* 
SETPLIS  SUBR  2,2,PNAME='SETPLIST' 
         LM    D,A,LOCAL1 
         $SYMBOL1 D 
         USING SYMBOL,D 
         ST    A,PROPERTY 
         DROP  D 
         CODEND RET 
* 
PNAME    SUBR  1,1 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         L     A,PNAME 
         DROP  A 
         CODEND RET 
* 
GENSYM   SUBR  0,2 
         B     GENSYM$2 
         B     GENSYM$1 
         L     A,LOCAL2 
         $FIXNUM 
         LA    A,0(A) 
         CVD   A,GENNUM 
GENSYM$1 L     A,LOCAL1 
         $STRING 
         ST    A,GENSTR 
GENSYM$2 L     W,GENSTR 
         L     WW,0(W) 
         ALR   W,F 
         L     D,STRBUFAD 
         LR    A,WW 
         MVCL  D,W 
         UNPK  0(4,D),GENNUM 
         OI    3(D),X'F0' 
         AP    GENNUM,PACKONE 
         LA    A,4(D) 
         LA    NB,LOCAL1 
         BAL   L,MKSTRING 
         B     MKSYMR 
* 
         DS    0D 
GENNUM   DC    PL8'0' 
PACKONE  DC    PL8'1' 
         CODEND 
* 
STRINGG  STRING 'G' 
* 
SYMBOL   SUBR  1,1 
         L     A,LOCAL1 
         $STRING 
         C     Z,0(A) 
         BE    TYPERR 
         LA    NB,LOCAL2 
         B     MKSYMR 
         CODEND 
* 
* 
SYMBLCP  SUBR  1,1,PNAME='SYMBOL-COPY' 
         L     A,LOCAL1 
         $SYMBOL 
         LR    D,A 
         USING SYMBOL,D 
         L     A,PNAME 
         DROP  D 
         BAL   L,MKSYM 
         L     D,LOCAL1 
         L     W,0(D) 
         ST    W,0(A) 
         L     W,4(D) 
         ST    W,4(A) 
         L     W,8(D) 
         ST    W,8(A) 
         L     W,12(D) 
         ST    W,12(A) 
         CODEND RET 
* 
DEFUN    CMACRO 
         L     A,LOCAL1 
         $LIST , 
         LM    D,A,0(A)       A:=FUNC NAME; D:=DEFINITION 
         $SYMBOL , 
         ST    A,LOCAL2       SAVE FUNC NAME 
         LA    NB,LOCAL3 
         L     A,LAMBDA       MAKE (LAMBDA ...) 
         BAL   L,CONS 
         LR    D,N 
         BAL   L,CONS         ((LAMBDA ...)) 
         L     D,FUNCTI 
         BAL   L,XCONS        '(LAMBDA ...) 
         LR    D,N 
         BAL   L,CONS         ('(LAMBDA ...)) 
         L     D,LOCAL2 
         ST    A,LOCAL2 
         LR    A,N 
         BAL   L,XCONS        (FUNC-NAME) 
         L     D,QUOTE 
         BAL   L,XCONS        'FUNC-NAME 
         L     D,LOCAL2 
         BAL   L,CONS         ('FUNC-NAME '(LAMBDA ...)) 
         L     D,PUTD 
         B     XCONSRET       (PUTD 'FUNC-NAME '(LAMBDA ...)) 
         CODEND 
* 
MACRO    CMACRO 
         L     A,LOCAL1 
         $LIST , 
         LM    D,A,0(A) 
         $SYMBOL , 
         ST    A,LOCAL2 
         LA    NB,LOCAL3 
         L     A,LAMBDA 
         BAL   L,CONS 
         L     D,MACRO 
         BAL   L,XCONS 
         LR    D,N 
         BAL   L,CONS 
         L     D,FUNCTI 
         BAL   L,XCONS 
         LR    D,N 
         BAL   L,CONS 
         L     D,LOCAL2 
         ST    A,LOCAL2 
         LR    A,N 
         BAL   L,XCONS 
         L     D,QUOTE 
         BAL   L,XCONS 
         L     D,LOCAL2 
         BAL   L,CONS 
         L     D,PUTD 
         B     XCONSRET 
         CODEND 
         TITLE 'NUMERICAL FUNCTIONS' 
*********************************************************************** 
* 
* FUNCTIONS ON NUMBERS 
* 
FXZEROP  SUBR  1,1,PNAME='0=' 
         L     A,LOCAL1 
         C     A,ZERO 
         BE    RETT 
         $FIXNUM , 
         CODEND RETNIL 
* 
FLZEROP  SUBR  1,1,PNAME='0=$' 
         L     A,LOCAL1 
         $FLONUM , 
         LD    FR0,4(A) 
         LTDR  FR0,FR0 
         BZ    RETT 
         CODEND RETNIL 
* 
ZEROP    SUBR  1,1 
         L     A,LOCAL1 
         C     A,ZERO 
         BE    RETT 
         IFFIX A,RETNIL 
         $FLONUM 
         LD    FR0,4(A) 
         LTDR  FR0,FR0 
         BE    RETT 
         CODEND RETNIL 
* 
FXPLUSP  SUBR  1,1,PNAME='0<' 
         L     A,LOCAL1 
         CL    A,MINFIX 
         BH    FXPL$1 
         C     A,ZERO 
         BNE   RETT 
         B     RETNIL 
FXPL$1   $FIXNUM , 
         CODEND RETNIL 
* 
FLPL$1   SUBR  1,1,PNAME='0<$' 
         L     A,LOCAL1 
         $FLONUM , 
         LD    FR0,4(A) 
         LTDR  FR0,FR0 
         BP    RETT 
         CODEND RETNIL 
* 
PLUSP    SUBR  1,1 
         L     A,LOCAL1 
         CL    A,MINFIX 
         BNL   PLUSP$1 
         C     A,ZERO 
         BE    RETNIL 
         B     RETT 
PLUSP$1  IFFIX A,RETNIL 
         $FLONUM , 
         LD    FR0,4(A) 
         LTDR  FR0,FR0 
         BP    RETT 
         CODEND RETNIL 
* 
FXMINP   SUBR  1,1,PNAME='0>' 
         L     A,LOCAL1 
         CL    A,MINFIX 
         BL    RETNIL 
         $FIXNUM , 
         B     RETT 
         CODEND 
* 
FLMINSP  SUBR  1,1,PNAME='0>$' 
         L     A,LOCAL1 
         $FLONUM , 
         LD    FR0,4(A) 
         LTDR  FR0,FR0 
         BM    RETT 
         CODEND RETNIL 
* 
MINUSP   SUBR  1,1 
         L     A,LOCAL1 
         CL    A,MINFIX 
         BL    RETNIL 
         IFFIX A,RETT 
         $FLONUM 
         LD    FR0,4(A) 
         LTDR  FR0,FR0 
         BM    RETT 
         CODEND RETNIL 
* 
ODDP     SUBR  1,1 
         L     A,LOCAL1 
         $FIXNUM 
         N     A,F1 
         BNZ   RETT 
         CODEND RETNIL 
* 
NUMEQ    SUBR  2,2,PNAME='=' 
         LM    D,A,LOCAL1 
         $FIXNUM1 D 
         CR    D,A 
         BE    RETT 
         IFFIX A,RETNIL 
         B     TYPERR 
         CODEND 
* 
FLOEQ    SUBR  2,2,PNAME='=$' 
         LM    D,A,LOCAL1 
         $FLONUM1 D 
         $FLONUM , 
         LD    FR0,4(A) 
         CD    FR0,4(D) 
         BE    RETT 
         CODEND RETNIL 
* 
SHARP    SUBR  2,2,PNAME='#' 
         LM    D,A,LOCAL1 
         $FIXNUM1 D 
         CR    D,A 
         BE    RETNIL 
         IFFIX A,RETT 
         B     TYPERR 
         CODEND 
* 
FLOSHRP  SUBR  2,2,PNAME='#$' 
         LM    D,A,LOCAL1 
         $FLONUM1 D 
         $FLONUM , 
         LD    FR0,4(A) 
         CD    FR0,4(D) 
         BNE   RETT 
         CODEND RETNIL 
* 
NUMNEQ   ALIAS SHARP,PNAME='<>' 
* 
FLONEQ   ALIAS FLOSHRP,PNAME='<>$' 
* 
GT       LSUBR PNAME='>' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FIXNUM , 
         SLL   A,8 
GT$1     SR    NA,F 
         BM    RETT 
         LR    D,A 
         L     A,LOCAL1(NA) 
         $FIXNUM , 
         SLL   A,8 
         CR    D,A 
         BL    GT$1 
         CODEND RETNIL 
* 
GTFLO    LSUBR PNAME='>$' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FLONUM , 
GTFLO$1  SR    NA,F 
         BM    RETT 
         LD    FR0,4(A) 
         L     A,LOCAL1(NA) 
         $FLONUM , 
         CD    FR0,4(A) 
         BL    GTFLO$1 
         CODEND RETNIL 
* 
GE       LSUBR PNAME='>=' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FIXNUM , 
         SLL   A,8 
GE$1     SR    NA,F 
         BM    RETT 
         LR    D,A 
         L     A,LOCAL1(NA) 
         $FIXNUM , 
         SLL   A,8 
         CR    D,A 
         BNH   GE$1 
         CODEND RETNIL 
* 
GEFLO    LSUBR PNAME='>=$' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FLONUM , 
GEFLO$1  SR    NA,F 
         BM    RETT 
         LD    FR0,4(A) 
         L     A,LOCAL1(NA) 
         $FLONUM , 
         CD    FR0,4(A) 
         BNH   GEFLO$1 
         CODEND RETNIL 
* 
LT       LSUBR PNAME='<' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FIXNUM , 
         SLL   A,8 
LT$1     SR    NA,F 
         BM    RETT 
         LR    D,A 
         L     A,LOCAL1(NA) 
         $FIXNUM , 
         SLL   A,8 
         CR    D,A 
         BH    LT$1 
         CODEND RETNIL 
* 
LTFLO    LSUBR PNAME='<$' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FLONUM , 
LTFLO$1  SR    NA,F 
         BM    RETT 
         LD    FR0,4(A) 
         L     A,LOCAL1(NA) 
         $FLONUM , 
         CD    FR0,4(A) 
         BH    LTFLO$1 
         CODEND RETNIL 
* 
LE       LSUBR PNAME='<=' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FIXNUM , 
         SLL   A,8 
LE$1     SR    NA,F 
         BM    RETT 
         LR    D,A 
         L     A,LOCAL1(NA) 
         $FIXNUM , 
         SLL   A,8 
         CR    D,A 
         BNL   LE$1 
         CODEND RETNIL 
* 
LEFLO    LSUBR PNAME='<=$' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FLONUM , 
LEFLO$1  SR    NA,F 
         BM    RETT 
         LD    FR0,4(A) 
         L     A,LOCAL1(NA) 
         $FLONUM , 
         CD    FR0,4(A) 
         BNL   LEFLO$1 
         CODEND RETNIL 
* 
GREATER  LSUBR PNAME='GREATERP' 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FLOAT FR0 
GREAT$1  SR    NA,F 
         BM    RETT 
         LDR   FR2,FR0 
         L     A,LOCAL1(NA) 
         $FLOAT FR0 
         CDR   FR0,FR2 
         BH    GREAT$1 
         CODEND RETNIL 
* 
LESSP    LSUBR , 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         $FLOAT FR0 
LESSP$1  SR    NA,F 
         BM    RETT 
         LDR   FR2,FR0 
         L     A,LOCAL1(NA) 
         $FLOAT FR0 
         CDR   FR0,FR2 
         BL    LESSP$1 
         CODEND RETNIL 
* 
SUB      LSUBR PNAME='-' 
         CR    NA,F 
         BL    PARAMERR 
         L     D,LOCAL1 
         $FIXNUM1 D 
         SR    NA,F 
         BNZ   SUB$1 
         LCR   A,D 
         B     RETNUM0 
SUB$1    L     A,LOCAL1(NA) 
         $FIXNUM 
         SLR   D,A 
         SR    NA,F 
         BNZ   SUB$1 
         LA    A,0(D) 
         CODEND RETNUM 
* 
SUBFLO   LSUBR PNAME='-$' 
         CR    NA,F 
         BL    PARAMERR 
         LA    NB,LOCAL1(NA) 
         L     A,LOCAL1 
         $FLONUM , 
         LD    FR0,4(A) 
         SR    NA,F 
         BNZ   SUBFLO$1 
         LCDR  FR0,FR0 
         B     MKFLOATR 
SUBFLO$1 L     A,LOCAL1(NA) 
         $FLONUM , 
         SD    FR0,4(A) 
         SR    NA,F 
         BP    SUBFLO$1 
         B     MKFLOATR 
         CODEND 
* 
ADD      LSUBR PNAME='+' 
         LR    D,Z 
         SR    NA,F 
         BM    ADD$2 
ADD$1    L     A,LOCAL1(NA) 
         $FIXNUM 
         ALR   D,A 
         SR    NA,F 
         BNM   ADD$1 
ADD$2    LA    A,0(D) 
         CODEND RETNUM 
* 
ADDFLO   LSUBR PNAME='+$' 
         LA    NB,LOCAL1(NA) 
         SDR   FR0,FR0 
         SR    NA,F 
         BM    MKFLOATR 
ADDFLO$1 L     A,LOCAL1(NA) 
         $FLONUM , 
         AD    FR0,4(A) 
         SR    NA,F 
         BNM   ADDFLO$1 
         B     MKFLOATR 
         CODEND 
* 
PLUS     LSUBR , 
         LR    D,Z 
         SR    NA,F 
         BM    PLUS$2 
PLUS$1   L     A,LOCAL1(NA) 
         IFNOTFIX A,PLUS$3 
         ALR   D,A 
         SR    NA,F 
         BNM   PLUS$1 
PLUS$2   LA    A,0(D) 
         B     RETNUM 
PLUS$3   SLL   D,8 
         SRA   D,8 
         ST    D,CONVTEMP 
         CVTID FR0,CONVTEMP 
         LA    NB,LOCAL1(NA) 
         $FLONUM , 
         AD    FR0,4(A) 
         SR    NA,F 
         BM    MKFLOATR 
PLUS$4   L     A,LOCAL1(NA) 
         $FLOAT FR2 
         ADR   FR0,FR2 
         SR    NA,F 
         BNM   PLUS$4 
         B     MKFLOATR 
         CODEND 
* 
DIFFER   LSUBR PNAME='DIFFERENCE' 
         LTR   NA,NA 
         BZ    PARAMERR 
         L     D,LOCAL1 
         IFNOTFIX D,DIFFER$3 
         SR    NA,F 
         BM    DIFFER$2 
DIFFER$1 L     A,LOCAL1(NA) 
         IFNOTFIX A,DIFFER$6 
         SLR   D,A 
         SR    NA,F 
         BNZ   DIFFER$1 
DIFFER$2 LA    A,0(D) 
         B     RETNUM 
DIFFER$3 $FLONUM1 D 
         LD    FR0,4(D) 
         LA    NB,LOCAL1(NA) 
         SR    NA,F 
         BM    MKFLOATR 
DIFFER$4 L     A,LOCAL1(NA) 
DIFFER$5 $FLOAT FR2 
         SDR   FR0,FR2 
         SR    NA,F 
         BNZ   DIFFER$4 
         B     MKFLOATR 
DIFFER$6 SLL   D,8 
         SRA   D,8 
         ST    D,CONVTEMP 
         CVTID FR0,CONVTEMP 
         LA    NB,LOCAL1(NA) 
         B     DIFFER$5 
         CODEND 
* 
MULT     LSUBR PNAME='*' 
         LA    WW,1 
         SR    NA,F 
         BM    MULT$2 
MULT$1   L     A,LOCAL1(NA) 
         $FIXNUM 
         MR    W,A 
         SR    NA,F 
         BNM   MULT$1 
MULT$2   LA    A,0(WW) 
         CODEND RETNUM 
* 
MULFLO   LSUBR PNAME='*$' 
         LA    NB,LOCAL1(NA) 
         LD    FR0,FLO1 
         SR    NA,F 
         BM    MKFLOATR 
MULFLO$1 L     A,LOCAL1(NA) 
         $FLONUM , 
         MD    FR0,4(A) 
         SR    NA,F 
         BNM   MULFLO$1 
         B     MKFLOATR 
         CODEND 
* 
TIMES    LSUBR , 
         LA    WW,1 
         SR    NA,F 
         BM    TIMS$2 
TIMS$1   L     A,LOCAL1(NA) 
         IFNOTFIX A,TIMS$3 
         MR    W,A 
         SR    NA,F 
         BNM   TIMS$1 
TIMS$2   LA    A,0(WW) 
         B     RETNUM 
TIMS$3   SLL   WW,8 
         SRA   WW,8 
         ST    WW,CONVTEMP 
         CVTID FR0,CONVTEMP 
         LA    NB,LOCAL1(NA) 
         $FLONUM , 
         MD    FR0,4(A) 
         SR    NA,F 
         BM    MKFLOATR 
TIMS$4   L     A,LOCAL1(NA) 
         $FLOAT FR2 
         MDR   FR0,FR2 
         SR    NA,F 
         BNM   TIMS$4 
         B     MKFLOATR 
         CODEND 
* 
DIV      LSUBR PNAME='/' 
         LTR   NA,NA 
         BZ    PARAMERR 
         L     WW,LOCAL1 
         $FIXNUM1 WW 
         SR    NA,F 
         BZ    DIV$2 
DIV$1    L     A,LOCAL1(NA) 
         $FIXNUM 
         SLL   A,8 
         SRA   A,8 
         SLDL  W,32+8 
         SRDA  W,32+8 
         DR    W,A 
         SR    NA,F 
         BNZ   DIV$1 
DIV$2    LA    A,0(WW) 
         CODEND RETNUM 
* 
DIVFLO   LSUBR PNAME='/$' 
         LTR   NA,NA 
         BZ    PARAMERR 
         L     A,LOCAL1 
         $FLONUM , 
         LD    FR0,4(A) 
         LA    NB,LOCAL1(NA) 
         SR    NA,F 
         BNP   MKFLOATR 
DIVFLO$1 L     A,LOCAL1(NA) 
         $FLONUM , 
         DD    FR0,4(A) 
         SR    NA,F 
         BP    DIVFLO$1 
         B     MKFLOATR 
         CODEND 
* 
QUOTI    LSUBR PNAME='QUOTIENT' 
         LR    X,Z            X: ARGUMENT INDEXER 
         LTR   NA,NA 
         BZ    PARAMERR       AT LEAST ONE ARGUMENT IS REQUIRED 
         L     A,LOCAL1 
         IFNOTFIX A,QUO$3     WHEN 1ST ARG IS FIX NUM 
         LR    W,A              MAKE ITS VALUE ON W&WW REG PAIR 
         SLL   W,8              AS A 64-BIT SIGNED INTEGER VALUE 
         SRDA  W,32+8 
         B     QUO$2 
QUO$1    L     A,LOCAL1(X)    A:=NEXT DEVISOR 
         IFNOTFIX A,QUO$4     IF DIVISOR IS ALSO A FIXNUM 
         SLL   A,8              THEN MAKE ITS VALUE ON A REG 
         SRA   A,8              AS A 32-BIT SIGNED INTEGER 
         DR    W,A              DIVIDE THE DIVIDENT ON W&WW 
         LR    W,WW               WITH THE DIVISOR VALUE 
         SRDA  W,32           W&WW AS 64-BIT QUOTIENT 
QUO$2    ALR   X,F            ADVANCE INDEX 
         CLR   X,NA           REPEAT UNTIL 
         BL    QUO$1            ARGUMENTS EXHAUST 
         LA    A,0(WW)        LOWER 32-BIT OF QUOTIENT ON A-REG 
         B     RETNUM         RETURN THE QUOTIENT (INTEGER) 
QUO$3    $FLONUM ,            WHEN THE 1ST ARG IS A FLONUM 
         LD    FR0,4(A)         FR0 := DIVIDENT 
         LA    NB,LOCAL1(NA)  SET STACK PT FOR ALLOCATION 
         B     QUO$6 
QUO$4    ST    WW,CONVTEMP    FOR MIXED OPERATION 
         CVTID FR0,CONVTEMP     CONVERT QUOTIENT TO FLONUM 
         LA    NB,LOCAL1(NA) 
QUO$5    L     A,LOCAL1(X) 
         $FLOAT FR2           ITS FLOATING VALUE ON FR2 
         DDR   FR0,FR2          DIVIDE 
QUO$6    ALR   X,F 
         CLR   X,NA           REPEAT UNTIL 
         BL    QUO$5            ARGS EXHAUST 
         B     MKFLOATR 
         CODEND 
* 
MOD      SUBR  2,2,PNAME='ő' 
         L     W,LOCAL1 
         $FIXNUM1 W 
         SLL   W,8 
         SRDA  W,32+8 
         L     A,LOCAL2 
         $FIXNUM 
         SLL   A,8 
         SRA   A,8 
         DR    W,A 
         LA    A,0(W) 
         CODEND RETNUM 
*
         AIF   ('&SYSTEM' NE 'MTS').MOD2
MOD2     ALIAS MOD,PNAME='['
.MOD2    AIF   ('&SYSTEM' NE 'MTS' AND '&SYSTEM' NE 'MVS/TSO').MOD3
MOD3     ALIAS MOD,PNAME='\'
.MOD3    ANOP
* 
MODFLO   SUBR  2,2,PNAME='ő$' 
         LM    D,A,LOCAL1 
         $FLONUM1 D 
         $FLONUM , 
         LD    FR0,4(D) 
         DD    FR0,4(A) 
         CVTDI FR0,CONVTEMP 
         CVTID FR0,CONVTEMP 
         MD    FR0,4(A) 
         SD    FR0,4(D) 
         LCDR  FR0,FR0 
         LA    NB,LOCAL3 
         B     MKFLOATR 
         CODEND 
         AIF   ('&SYSTEM' NE 'MTS').MODFLO2
MODFLO2  ALIAS MODFLO,PNAME='[$'
.MODFLO2 AIF   ('&SYSTEM' NE 'MTS' AND '&SYSTEM' NE 'MVS/TSO').MODFLO3
MODFLO3  ALIAS MODFLO,PNAME='\$'
.MODFLO3 ANOP
* 
REMAIND  SUBR  2,2,PNAME='REMAINDER' 
         LM    D,A,LOCAL1 
         IFNOTFIX D,REM$1 
         IFNOTFIX A,REM$2 
         LR    W,D 
         SLL   W,8 
         SRDA  W,32+8 
         SLL   A,8 
         SRA   A,8 
         DR    W,A 
         LA    A,0(W) 
         B     RETNUM 
REM$1    $FLONUM1 D 
         LD    FR0,4(D) 
         $FLOAT FR2 
         B     REM$3 
REM$2    $FLONUM2 A 
         SLL   D,8 
         SRA   D,8 
         ST    D,CONVTEMP 
         CVTID FR0,CONVTEMP 
         LD    FR2,4(A) 
REM$3    LDR   FR4,FR0 
         DDR   FR4,FR2 
         CVTDI FR4,CONVTEMP 
         CVTID FR4,CONVTEMP 
         MDR   FR4,FR2 
         SDR   FR0,FR4 
         LA    NB,LOCAL3 
         B     MKFLOATR 
         CODEND 
* 
A1       SUBR  1,1,PNAME='1+' 
         L     A,LOCAL1 
         $FIXNUM 
         LA    A,1(A) 
         CODEND RETNUM 
* 
A1FLO    SUBR  1,1,PNAME='1+$' 
         LA    NB,LOCAL2 
         L     A,LOCAL1 
         $FLONUM , 
         LD    FR0,4(A) 
         AD    FR0,FLO1 
         B     MKFLOATR 
         CODEND 
* 
ADD1     SUBR  1,1 
         LA    NB,LOCAL2 
         L     A,LOCAL1 
         IFNOTFIX A,ADD1$1 
         LA    A,1(A) 
         B     RETNUM 
ADD1$1   $FLONUM , 
         LD    FR0,4(A) 
         AD    FR0,FLO1 
         B     MKFLOATR 
         CODEND 
* 
S1       SUBR  1,1,PNAME='1-' 
         L     A,LOCAL1 
         $FIXNUM 
         BCTR  A,0 
         B     RETNUM0 
         CODEND 
* 
S1FLO    SUBR  1,1,PNAME='1-$' 
         LA    NB,LOCAL2 
         L     A,LOCAL1 
         $FLONUM , 
         LD    FR0,4(A) 
         SD    FR0,FLO1 
         B     MKFLOATR 
         CODEND 
* 
SUB1     SUBR  1,1 
         LA    NB,LOCAL2 
         L     A,LOCAL1 
         IFNOTFIX A,SUB1$1 
         BCTR  A,0 
         B     RETNUM0 
SUB1$1   $FLONUM , 
         LD    FR0,4(A) 
         SD    FR0,FLO1 
         B     MKFLOATR 
         CODEND 
* 
MAX      LSUBR 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         IFFLO A,MAX$1 
         LR    X,A 
         $FIXNUM , 
         SLL   X,8 
         SRA   X,8 
         ST    X,CONVTEMP 
         CVTID FR2,CONVTEMP 
         B     MAX$2 
MAX$1    LD    FR2,4(A) 
MAX$2    SR    NA,F 
         BMR   E 
         LR    D,A 
         LDR   FR0,FR2 
MAX$3    L     A,LOCAL1(NA) 
         IFFLO A,MAX$4 
         LR    X,A 
         $FIXNUM , 
         SLL   X,8 
         SRA   X,8 
         ST    X,CONVTEMP 
         CVTID FR2,CONVTEMP 
         B     MAX$5 
MAX$4    LD    FR2,4(A) 
MAX$5    CDR   FR2,FR0 
         BH   MAX$2 
         SR    NA,F 
         BNM   MAX$3 
         LR    A,D 
         CODEND RET 
* 
MIN      LSUBR 
         SR    NA,F 
         BM    PARAMERR 
         L     A,LOCAL1(NA) 
         IFFLO A,MIN$1 
         LR    X,A 
         $FIXNUM , 
         SLL   X,8 
         SRA   X,8 
         ST    X,CONVTEMP 
         CVTID FR2,CONVTEMP 
         B     MIN$2 
MIN$1    LD    FR2,4(A) 
MIN$2    SR    NA,F 
         BMR   E 
         LR    D,A 
         LDR   FR0,FR2 
MIN$3    L     A,LOCAL1(NA) 
         IFFLO A,MIN$4 
         LR    X,A 
         $FIXNUM , 
         SLL   X,8 
         SRA   X,8 
         ST    X,CONVTEMP 
         CVTID FR2,CONVTEMP 
         B     MIN$5 
MIN$4    LD    FR2,4(A) 
MIN$5    CDR   FR2,FR0 
         BL    MIN$2 
         SR    NA,F 
         BNM   MIN$3 
         LR    A,D 
         CODEND RET 
* 
ABS      SUBR  1,1 
         L     A,LOCAL1 
         IFNOTFIX A,ABS$1 
         C     A,MINFIX 
         BE    TYPERR 
         SLL   A,8 
         LPR   A,A 
         SRA   A,8 
         B     RETNUM 
ABS$1    $FLONUM , 
         LD    FR0,4(A) 
         LA    NB,LOCAL2 
         LPDR  FR0,FR0 
         B     MKFLOATR 
         CODEND 
* 
MINUS    SUBR  1,1 
         L     A,LOCAL1 
         IFNOTFIX A,MINUS$1 
         LCR   A,A 
         B     RETNUM0 
MINUS$1  $FLONUM , 
         LD    FR0,4(A) 
         LCDR  FR0,FR0 
         LA    NB,LOCAL2 
         B     MKFLOATR 
         CODEND 
* 
LOGOR    LSUBR 
         L     A,ZERO 
         SR    NA,F 
         BMR   E 
LOGOR$1  L     D,LOCAL1(NA) 
         $FIXNUMD , 
         OR    A,D 
         SR    NA,F 
         BNM   LOGOR$1 
         CODEND RET 
* 
LOGAND   LSUBR 
         L     A,=X'10FFFFFF' 
         SR    NA,F 
         BMR   E 
LOGAND$1 L     D,LOCAL1(NA) 
         $FIXNUMD , 
         NR    A,D 
         SR    NA,F 
         BNM   LOGAND$1 
         CODEND RET 
* 
LOGXOR   LSUBR 
         L     A,ZERO 
         SR    NA,F 
         BMR   E 
LOGXOR$1 L     D,LOCAL1(NA) 
         $FIXNUMD , 
         XR    A,D 
         SR    NA,F 
         BNM   LOGXOR$1 
         CODEND RETNUM 
* 
SHIFT    SUBR  2,2,PNAME='LOGSHIFT' 
         LM    D,A,LOCAL1 
         $FIXNUM1 D 
         $FIXNUM 
         SLL   A,8 
         LPR   W,A 
         C     W,=A(32*256) 
         BNL   SHIFT$2 
         SRA   A,8 
         BM    SHIFT$1 
         SLA   D,0(A) 
         LA    A,0(D) 
         B     RETNUM 
* 
SHIFT$1  LPR   A,A 
         LA    D,0(D) 
         SRL   D,0(A) 
         LA    A,0(D) 
         B     RETNUM 
* 
SHIFT$2  L     A,ZERO 
         CODEND RET 
* 
FIX      SUBR  1,1 
         L     A,LOCAL1 
         $FLONUM 
         LD    FR0,4(A) 
         CVTDI FR0,LOCAL2 
         L     A,LOCAL2 
         B     RETNUM0 
         CODEND 
* 
FLOAT    SUBR  1,1 
         L     A,LOCAL1 
         $FIXNUM 
         SLL   A,8 
         SRA   A,8 
         ST    A,LOCAL2 
         CVTID FR0,LOCAL2 
         LA    NB,LOCAL2 
         B     MKFLOATR 
         CODEND 
* 
EXPTFIX  SUBR  2,2,PNAME='^' 
         LM    D,A,LOCAL1 
         $FIXNUM1 D 
         $POSFIX , 
         LA    X,0(A) 
         LR    WW,D 
         LA    A,1 
         LTR   X,X 
         BZ    RETNUM 
EXFIX$1  SRDL  X,1 
         LTR   NA,NA 
         BNM   EXFIX$2 
         MR    D,WW 
EXFIX$2  MR    W,WW 
         LTR   X,X 
         BNZ   EXFIX$1 
         B     RETNUM0 
         CODEND 
*
         AIF   ('&SYSTEM' NE 'MTS').EXPT2
EXPTFIX2 ALIAS EXPTFIX,PNAME='ˇ'
.EXPT2   ANOP
* 
EXPTFLO  SUBR  2,2,PNAME='^$' 
         LA    NB,LOCAL3 
         LM    D,A,LOCAL1 
         $FLONUM1 D 
         $FIXNUM , 
         LR    X,A 
         LD    FR2,4(D) 
         LD    FR0,FLO1 
         SLL   X,8 
         SRA   X,8 
         BZ    RETNUM 
         BM    EXFLO$3 
EXFLO$1  SRDL  X,1 
         LTR   NA,NA 
         BNM   EXFLO$2 
         MDR   FR0,FR2 
EXFLO$2  MDR   FR2,FR2 
         LTR   X,X 
         BNZ   EXFLO$1 
         B     MKFLOATR 
EXFLO$3  LPR   X,X 
EXFLO$4  SRDL  X,1 
         LTR   NA,NA 
         BNM   EXFLO$5 
         DDR   FR0,FR2 
EXFLO$5  MDR   FR2,FR2 
         LTR   X,X 
         BNZ   EXFLO$4 
         B     MKFLOATR 
         CODEND 
*
         AIF   ('&SYSTEM' NE 'MTS').EXPT3
EXPTFLO2 ALIAS EXPTFLO,PNAME='ˇ$'
.EXPT3   ANOP
* 
EXPT     SUBR  2,2 
         LA    NB,LOCAL3 
         LM    D,A,LOCAL1 
         $FIXNUM , 
         LR    X,A 
         IFFIX D,EXPTFIX 
         $FLONUM1 D 
         LD    FR0,FLO1 
         LD    FR2,4(D) 
         SLL   X,8 
         SRA   X,8 
         BM    EXPTFLO3 
         BZ    MKFLOATR 
EXPTFLO1 SRDL  X,1 
         LTR   NA,NA 
         BNM   EXPTFLO2 
         MDR   FR0,FR2 
EXPTFLO2 MDR   FR2,FR2 
         LTR   X,X 
         BNZ   EXPTFLO1 
         B     MKFLOATR 
EXPTNEG  SLL   D,8 
         SRA   D,8 
         ST    D,CONVTEMP 
         CVTID FR2,CONVTEMP 
         LD    FR0,FLO1 
EXPTFLO3 LPR   X,X 
EXPTFLO4 SRDL  X,1 
         LTR   NA,NA 
         BNM   EXPTFLO5 
         DDR   FR0,FR2 
EXPTFLO5 MDR   FR2,FR2 
         LTR   X,X 
         BNZ   EXPTFLO4 
         B     MKFLOATR 
* 
EXPTFIX  SLL   X,8 
         SRA   X,8 
         LA    A,1 
         BZ    RETNUM 
         BM    EXPTNEG 
         LA    WW,0(D) 
EXPTFIX1 SRDL  X,1 
         LTR   NA,NA 
         BNM   EXPTFIX2 
         MR    D,WW 
EXPTFIX2 MR    W,WW 
         LTR   X,X 
         BNZ   EXPTFIX1 
         B     RETNUM0 
         CODEND 
         TITLE 'STRING MANIPULATION FUNCTIONS' 
*********************************************************************** 
* 
*     STRING MANIPULATION 
* 
CHARACT  SUBR  1,1,PNAME='CHARACTER' 
         L     A,LOCAL1 
         $CHARACT 
         CODEND RET 
* 
STRING   SUBR  1,1 
         L     A,LOCAL1 
         IFNOTSY A,STRING$1 
         USING SYMBOL,A 
         L     A,PNAME 
         DROP  A 
STRING$1 CLM   A,B'1000',@STRING 
         BER   E 
         $CHARACT 
         L     W,STRBUFAD 
         STC   A,0(W) 
         LA    A,1(W) 
         LA    NB,LOCAL2 
         B     MKSTRNGR 
         CODEND 
* 
STRLEN   SUBR  1,1,PNAME='STRING-LENGTH' 
         L     A,LOCAL1 
         $STRING 
         L     A,0(A) 
         CODEND RETNUM 
* 
STRLSP   SUBR  2,2,PNAME='STRING-LESSP' 
         L     A,LOCAL1 
         $STRING 
         L     WW,0(A) 
         LA    W,4(A) 
         L     A,LOCAL2 
         $STRING 
         L     NA,0(A) 
         LA    X,4(A) 
         CLCL  W,X 
         BL    RETT 
         CODEND RETNIL 
* 
SUBSTR   SUBR  1,3,PNAME='SUBSTRING' 
         ST    Z,LOCAL2 
         B     SUBSTR$1 
         L     D,LOCAL1       D:=STRING FROM WHICH 
         $STRING1 D                A SUBSTRING IS DERIVED 
         L     A,LOCAL3       THIRD ARG 
         $POSINX                IS THE END POS OF 
         LA    WW,0(A)          SUBSTRING 
         C     WW,0(D)        IF THE END EXCEEDS LENGTH OF STRING 
         BNH   SUBSTR$2 
         B     INDEXERR         THEN ERROR 
SUBSTR$1 L     A,LOCAL1       WHOLE STRING 
         $STRING 
         LR    D,A 
         L     WW,0(D)        DEFAULT END POS IS THE END OF STRING 
SUBSTR$2 L     A,LOCAL2 
         $POSINX              BEGINNING POS OF STRING 
         LA    W,0(A) 
         SR    WW,W 
         BM    INDEXERR 
         LA    D,4(A,D) 
SUBSTR$4 L     X,STRBUFAD 
         LR    W,D 
         LR    NA,WW 
         C     NA,@BUFSIZE 
         BNL   BUFFERR 
         MVCL  X,W 
         LR    A,X 
         LA    NB,LOCAL2 
         B     MKSTRNGR 
         CODEND 
* 
STRAPP   LSUBR PNAME='STRING-APPEND' 
         LR    W,Z            COMPUTE LENGTH OF RESULTANT STRING 
         LR    X,Z            "X" IS USED FOR INDEXING ARGS 
         LTR   NA,NA          IF NO ARGUMENT 
         BZ    STRAPP$2         THEN LENGTH WILL BE ZERO 
STRAPP$1 L     A,LOCAL1(X)    A:=ONE ARGUMENT 
         $STRING              CHECK ITS TYPE 
         ST    A,LOCAL1(X)    SAVE COERCED ARGUMENT 
         AL    W,0(A)         ACCUMULATE LENGTH ON "W" 
         ALR   X,F            ADVANCE TO NEXT ONE 
         CR    X,NA           REPEAT UNTIL ARGS EXHAUST 
         BNE   STRAPP$1 
STRAPP$2 LR    A,W            ALLOCATE BLOCK OF COMPUTED SIZE 
         LA    NB,LOCAL1(NA) 
         BAL   L,MKBLOCK 
         LR    L,A            SAVE ALLOCATED BLOCK ON "L" 
         LT    W,0(L)         W:=SIZE OF ALLOCATED BLOCK 
         BZ    STRAPP$3       IF SIZE IS NOT ZERO 
         LA    W,3(W)           THEN CLEAR THE LAST WORD OF 
         N     W,WORDBND        ALLOCATED BLOCK, FOR HASHING 
         ST    Z,0(W,L) 
STRAPP$3 LA    W,4(L)         W:=TOP OF CHARACTERS 
         LR    X,Z            X IS USED FOR ARGUMENT INDEX 
         CR    X,NA           IF NO ARGUMENT 
         BE    STRAPP$5         THEN DO NOTHING 
STRAPP$4 L     A,LOCAL1(X)    A:=ONE ARGUMENT 
         LA    D,4(A)         D:=TOP OF CHARS OF ARGUMENT 
         L     A,0(A)         A:=LENGTH OF ARGUMENT STRING 
         LR    WW,A 
         MVCL  W,D            MOVE CHARS OF ARG TO THE NEW BLOCK 
         ALR   X,F            ADVANCE POINTER 
         CR    X,NA           REPEAT UNTIL ARGUMENTS EXHAUST 
         BNE   STRAPP$4 
STRAPP$5 LR    A,L            A:=THE NEWLY ALLOCATED BLOCK 
         O     A,@STRING      PUT STRING TAG ON IT 
         CODEND RET 
* 
STRREV   SUBR  1,1,PNAME='STRING-REVERSE' 
         L     A,LOCAL1       A:=ARGUMENT 
         $STRING              CHECK ITS TYPE 
         L     A,0(A)         A:=LENGTH 
         LA    NB,LOCAL2 
         BAL   L,MKBLOCK      ALLOCATE A BLOCK WITH THE SAME SIZE 
         LT    D,0(A)         D:=BLOCK LENGTH 
         BZ    STRREV$2       IF LENGTH=0 THEN RETURN NULL STRING 
         LA    D,3(D)         OTHERWISE, CLEAR THE LAST WORD 
         N     D,WORDBND        OF THE STRING 
         ST    Z,0(D,A) 
         L     D,0(A)         D:=LENGTH OF NEW BLOCK 
         L     W,LOCAL1       W:=ARGUMENT STRING 
         LR    X,Z            X:=CHARACTER INDEX FOR ARG STRING 
STRREV$1 IC    WW,4(X,W)      WW:=ONE CHAR OF ARG STRING 
         STC   WW,3(D,A)      SET THAT CHAR IN NEW STRING 
         LA    X,1(X)         ADVANCE INDEX 
         BCT   D,STRREV$1     REPEAT UNTIL COMPLETELY MOVED 
STRREV$2 O     A,@STRING      PUT STRING TAG 
         CODEND RET 
* 
STRNREV  SUBR  1,1,PNAME='STRING-NREVERSE' 
         L     A,LOCAL1 
         $STRING 
         L     X,0(A) 
         LA    D,4(A) 
         LA    X,3(X,A) 
         CLR   X,D 
         BNHR  E 
STRNRV$1 IC    W,0(X) 
         MVC   0(1,X),0(D) 
         STC   W,0(D) 
         LA    D,1(D) 
         BCTR  X,0 
         CLR   X,D 
         BH    STRNRV$1 
         CODEND RET 
* 
STRSC    SUBR  2,3,PNAME='STRING-SEARCH-CHAR' 
         B     STRSC$1 
         B     STRSC$2 
STRSC$1  L     A,ZERO 
         ST    A,LOCAL3 
STRSC$2  L     A,LOCAL2 
         $STRING 
         LR    W,A 
         XC    TRTTAB$A(256),TRTTAB$A 
         L     A,LOCAL1 
         IFLIST A,STRSC$3 
         $CHARACT 
         STC   F,TRTTAB$A(A) 
         B     STRSC$5 
STRSC$3  LR    D,A 
STRSC$4  LM    D,A,0(D) 
         $CHARACT 
         STC   F,TRTTAB$A(A) 
         IFLIST D,STRSC$4 
STRSC$5  L     A,LOCAL3 
         $POSINX 
         LA    A,0(A) 
         L     WW,0(W) 
         SR    WW,A 
         BNP   RETNIL 
         LA    X,4(A,W) 
         DISABLE 
         DROP  E
STRSC$6  C     WW,F256 
         BNH   STRSC$7 
         TRT   0(256,X),TRTTAB$A 
         BNZ   STRSC$8 
         LA    X,256(X) 
         S     WW,F256 
         BNZ   STRSC$6 
         B     STRSC$9 
STRSC$7  BCTR  WW,0 
         EX    WW,STRSC$OP 
         BZ    STRSC$9 
STRSC$8  LA    A,0(Z) 
         LA    W,4(W) 
         SLR   A,W 
         L     E,=A(MAIN) 
         USING MAIN,E
         ENABLE
         B     RETNUM 
         DROP  E
STRSC$9  L     E,=A(MAIN) 
         USING MAIN,E
         ENABLE 
         B     RETNIL 
STRSC$OP TRT   0(0,X),TRTTAB$A 
TRTTAB$A DS    256C 
         CODEND 
* 
STRSNC   SUBR  2,3,PNAME='STRING-SEARCH-NOT-CHAR' 
         B     STRSNC$1 
         B     STRSNC$2 
STRSNC$1 L     A,ZERO 
         ST    A,LOCAL3 
STRSNC$2 L     A,LOCAL2 
         $STRING 
         LR    W,A 
         MVI   TRTTAB$B,X'FF' 
         MVC   TRTTAB$B+1(255),TRTTAB$B 
         L     A,LOCAL1 
         IFLIST A,STRSNC$3 
         $CHARACT 
         STC   Z,TRTTAB$B(A) 
         B     STRSNC$5 
STRSNC$3 LR    D,A 
STRSNC$4 LM    D,A,0(D) 
         $CHARACT 
         STC   Z,TRTTAB$B(A) 
         IFLIST D,STRSNC$4 
STRSNC$5 L     A,LOCAL3 
         $POSINX 
         LA    A,0(A) 
         L     WW,0(W) 
         SR    WW,A 
         BNP   RETNIL 
         LA    X,4(A,W) 
         DISABLE 
         DROP  E
STRSNC$6 C     WW,F256 
         BNH   STRSNC$7 
         TRT   0(256,X),TRTTAB$B 
         BNZ   STRSNC$8 
         LA    X,256(X) 
         S     WW,F256 
         BNZ   STRSNC$6 
         B     STRSNC$9 
STRSNC$7 BCTR  WW,0 
         EX    WW,STRSNC$O 
         BZ    STRSNC$9 
STRSNC$8 LA    A,0(Z) 
         LA    W,4(W) 
         SLR   A,W 
         L     E,=A(MAIN) 
         USING MAIN,E
         ENABLE
         B     RETNUM 
         DROP  E
STRSNC$9 L     E,=A(MAIN) 
         USING MAIN,E
         ENABLE 
         B     RETNIL 
STRSNC$O TRT   0(0,X),TRTTAB$B 
TRTTAB$B DS    256C 
         CODEND 
* 
GETCHAR  SUBR  2,2 
         LM    D,A,LOCAL1 
         $STRING1 D 
         $FIXNUM 
         LA    X,0(A) 
         C     X,0(D) 
         BNL   INDEXERR 
         IC    W,4(X,D) 
         L     A,STRBUFAD 
         STC   W,0(A) 
         LA    A,1(A) 
         LA    NB,LOCAL3 
         BAL   L,MKSTRING 
         MVI   SOFTFLAG,0 
         B     INTRNRET 
         CODEND 
* 
SREF     SUBR  2,2 
         LM    D,A,LOCAL1 
         $STRING1 D 
         $POSINX 
         LA    X,0(A) 
         C     X,0(D) 
         BNL   INDEXERR 
         LR    A,Z 
         IC    A,4(X,D) 
         CODEND RETNUM 
* 
SSET     SUBR  3,3 
         LM    D,A,LOCAL1 
         $STRING1 D 
         $POSINX 
         LA    X,0(A) 
         C     X,0(D) 
         BNL   INDEXERR 
         L     A,LOCAL3 
         $CHARACT 
         STC   A,4(X,D) 
         CODEND RET 
* 
STREQ    SUBR  2,2,PNAME='STRING-EQUAL' 
         L     W,LOCAL1 
         $STRING1 W 
         L     A,LOCAL2 
         $STRING 
         L     WW,0(A)        WW:=LENGTH OF STRING 
         C     WW,0(W) 
         BNE   RETNIL 
         LA    D,4(A) 
         ALR   W,F 
         LR    A,WW 
         CLCL  D,W 
         BE    RETT 
         CODEND RETNIL 
* 
CUTOUT   SUBR  3,3 
         L     W,LOCAL1 
         $STRING1 W 
         L     A,LOCAL2 
         $POSINX 
         LR    X,A 
         L     A,LOCAL3 
         $FIXNUM 
         LA    D,0(A) 
         LA    WW,0(X,A) 
         C     WW,0(W) 
         BH    INDEXERR 
         BCT   D,CUTOUT$2 
CUTOUT$1 XR    A,A 
         IC    A,4(X,W) 
         B     RETNUM 
CUTOUT$2 BCT   D,CUTOUT$3 
         XR    A,A 
         IC    A,4(X,W) 
         SLL   A,8 
         IC    A,5(X,W) 
         B     RETNUM 
CUTOUT$3 BCT   D,TYPERR 
         IC    A,4(X,W) 
         SLL   A,8 
         IC    A,5(X,W) 
         SLL   A,8 
         IC    A,6(X,W) 
         CODEND RETNUM 
* 
SPREAD   SUBR  2,2 
         L     X,LOCAL1 
         $FIXNUM1 X 
         L     A,LOCAL2 
         $FIXNUM 
         LA    D,0(A) 
         L     W,STRBUFAD 
         BCT   D,SPREAD$2 
SPREAD$1 STC   X,0(W) 
         LA    A,1(W) 
         B     SPREAD$4 
SPREAD$2 BCT   D,SPREAD$3 
         STCM  X,B'0011',0(W) 
         LA    A,2(W) 
         B     SPREAD$4 
SPREAD$3 BCT   D,TYPERR 
         STCM  X,B'0111',0(W) 
         LA    A,3(W) 
SPREAD$4 LA    NB,LOCAL3 
         B     MKSTRNGR 
         CODEND 
* 
TRNSLT   SUBR  2,2,PNAME='TRANSLATE' 
         L     D,LOCAL2 
         $STRING2 D 
         LA    WW,256 
         C     WW,0(D) 
         BNE   TYPERR2 
         L     A,LOCAL1 
         $STRING 
         LT    W,0(A) 
         BZR   E 
         LA    X,4(A) 
TRNSLT$1 CR    W,WW 
         BNH   TRNSLT$2 
         TR    0(256,X),4(D) 
         ALR   X,WW 
         SR    W,WW 
         BP    TRNSLT$1 
         BZR   E 
TRNSLT$2 BCTR  W,0 
         EX    W,TRNSLTTR 
         RET 
TRNSLTTR TR    0(0,X),4(D) 
         CODEND 
* 
AMEND    SUBR  2,3,PNAME='STRING-AMEND' 
         ST    Z,LOCAL3 
         L     D,LOCAL1 
         $STRING1 D 
         L     X,LOCAL2 
         $STRING2 X 
         L     A,LOCAL3 
         $FIXNUM 
         LA    A,0(A) 
         LR    NA,A 
         AL    A,0(X) 
         C     A,0(D) 
         BH    TYPERR2 
         LA    D,4(NA,D) 
         L     A,0(X) 
         LR    NA,A 
         LA    X,4(X) 
         MVCL  D,X 
         L     A,LOCAL1 
         CODEND RET 
* 
AMENDOR  SUBR  2,3,PNAME='STRING-AMEND-OR' 
         ST    Z,LOCAL3 
         L     D,LOCAL1 
         $STRING1 D 
         L     X,LOCAL2 
         $STRING2 X 
         L     A,LOCAL3 
         $FIXNUM 
         LA    A,0(A) 
         LR    NA,A 
         AL    A,0(X) 
         C     A,0(D) 
         BH    TYPERR2 
         ALR   D,NA 
         L     NA,0(X) 
AMNDO$1  C     NA,F256 
         BNH   AMNDO$2 
         OC    4(256,D),4(X) 
         LA    D,256(D) 
         LA    X,256(X) 
         S     NA,F256 
         B     AMNDO$1 
AMNDO$OC OC    4(0,D),4(X) 
AMNDO$2  BCTR  NA,0 
         EX    NA,AMNDO$OC 
         L     A,LOCAL1 
         CODEND RET 
* 
AMENDXR  SUBR  2,3,PNAME='STRING-AMEND-XOR' 
         ST    Z,LOCAL3 
         L     D,LOCAL1 
         $STRING1 D 
         L     X,LOCAL2 
         $STRING2 X 
         L     A,LOCAL3 
         $FIXNUM 
         LA    A,0(A) 
         LR    NA,A 
         AL    A,0(X) 
         C     A,0(D) 
         BH    TYPERR2 
         ALR   D,NA 
         L     NA,0(X) 
AMNDX$1  C     NA,F256 
         BNH   AMNDX$2 
         XC    4(256,D),4(X) 
         LA    D,256(D) 
         LA    X,256(X) 
         S     NA,F256 
         B     AMNDX$1 
AMNDX$XC XC    4(0,D),4(X) 
AMNDX$2  BCTR  NA,0 
         EX    NA,AMNDX$XC 
         L     A,LOCAL1 
         CODEND RET 
* 
AMENDND  SUBR  2,3,PNAME='STRING-AMEND-AND' 
         ST    Z,LOCAL3 
         L     D,LOCAL1 
         $STRING1 D 
         L     X,LOCAL2 
         $STRING2 X 
         L     A,LOCAL3 
         $FIXNUM 
         LA    A,0(A) 
         LR    NA,A 
         AL    A,0(X) 
         C     A,0(D) 
         BH    TYPERR2 
         ALR   D,NA 
         L     NA,0(X) 
AMNDN$1  C     NA,F256 
         BNH   AMNDN$2 
         NC    4(256,D),4(X) 
         LA    D,256(D) 
         LA    X,256(X) 
         S     NA,F256 
         B     AMNDN$1 
AMNDN$NC NC    4(0,D),4(X) 
AMNDN$2  BCTR  NA,0 
         EX    NA,AMNDN$NC 
         L     A,LOCAL1 
         CODEND RET 
* 
MKSTR    SUBR  1,2,PNAME='MAKE-STRING' 
         ST    Z,LOCAL2       DEFAULT INIT CHAR IS NULL 
         L     A,LOCAL1       FIRST ARG = LENGTH 
         $POSFIX ,              WHICH SHOULD BE A POSITIVE NUMBER 
         LA    A,0(A) 
         LA    NB,LOCAL3 
         BAL   L,MKBLOCK      ALLOCATE A NEW STRING 
         LR    D,A            SAVE THAT ON "D" 
         LR    X,Z            (X,NA) PAIR IS DUMMY OPERAND 
         LR    NA,Z             TO CLEAR THE STRING 
         LA    W,4(D)         W:=FIRST CHAR POSITION 
         L     WW,0(D)        WW:=LENGTH OF STRING 
         LA    WW,3(WW)       ADJUST TO WORD BOUNDARY 
         N     WW,WORDBND 
         MVCL  W,X            CLEAR OUT THE ALLOCATED STRING 
         LT    A,LOCAL2       SECOND ARG = INITIAL CHARACTERS 
         BZ    MKSTR$1        IF NOT REALLY GIVEN, RETURN THE STRING 
         $CHARACT ,           OTHERWISE, TEST ITS TYPE 
         LA    W,4(D)         W:=FIRST CHAR POSITION 
         L     WW,0(D)        WW:=LENGTH OF THE STRING 
         LR    NA,A           M.S.BYTE OF NA 
         SLL   NA,24            :=PAD CHARACTER 
         MVCL  W,X            FILL THE STRING WITH GIVEN CHAR 
MKSTR$1  LR    A,D            A:=ALLOCATED STRING 
         O     A,@STRING      PUT TAG ON THE RESULT 
         CODEND RET 
* 
BSET     SUBR  3,3 
         LM    D,A,LOCAL1     D:=STRING TO BE SET; A:=BIT POS 
         $STRING1 D 
         $POSINX 
         LA    X,0(A) 
         SRDL  X,3            X:=BYTE POSITION 
         C     X,0(D)         CHECK INDEX RANGE 
         BH    INDEXERR 
         IC    W,4(X,D)       W:=BYTE TO BE CHANGED 
         SRL   NA,29          NA:=BIT POSITION TO BE SET 
         LA    WW,X'80' 
         SRL   WW,0(NA)       SPECIFIED BIT OF "WW" IS ON 
         C     N,LOCAL3       IF IT IS TO BE CLEARED 
         BE    BSET$1 
         OR    W,WW             THEN SET THAT BIT BY OR'ING 
         B     BSET$2 
BSET$1   X     WW,=A(-1)      OTHERWISE, INVERT ALL BITS 
         NR    W,WW             AND CLEAR THE BIT BY AND'ING 
BSET$2   STC   W,4(X,D)       SET SPECIFIED BYTE 
         LR    A,D            A:=RESULT 
         CODEND RET 
* 
BREF     SUBR  2,2 
         LM    D,A,LOCAL1     D:=STRING TO BE TESTED; A:=BIT POS 
         $STRING1 D 
         $POSINX 
         LA    X,0(A) 
         SRDL  X,3 
         C     X,0(D)         CHECK INDEX RANGE 
         BH    INDEXERR 
         SRL   NA,29          NA:=BIT POSITION 
         LA    W,X'80' 
         SRL   W,0(NA) 
         IC    WW,4(X,D) 
         NR    W,WW           TEST BIT 
         BNZ   RETT 
         CODEND RETNIL 
* 
STRSRCH  SUBR  2,3,PNAME='STRING-SEARCH' 
         B     STRSR$1 
         L     A,LOCAL3       A:=SEARCH START POSITION 
         $POSINX , 
         LA    L,0(A)         L:=START POS 
         B     STRSR$2 
STRSR$1  LR    L,Z            WHEN START POS NOT GIVEN, ASSUME ZERO 
STRSR$2  LM    D,A,LOCAL1     D:=KEY; A:=SEARCHED STRING 
         $STRING1 D 
         $STRING , 
         C     Z,0(D)         IF KEY STRING IS NULL STRING 
         BZ    STRSR$OK         THEN IT IS FOUND, ANYWAY 
         L     W,0(A)         W:=LENGTH OF SEARCHED STRING 
         SL    W,0(D)         W:=LAST POSSIBLE KEY POSITION 
         ST    W,LOCAL4 
         CR    L,W            IF LAST POS < START POS 
         BH    RETNIL           THEN RETURN NIL (NOT FOUND) 
STRSR$3  LA    X,4(D)         X:=KEY STRING TOP 
         L     NA,0(D)        NA:=KEY LENGTH (X & NA AS A PAIR) 
         LA    W,4(L,A)       W:=COMPARED STRING POSITION 
         LR    WW,NA          WW:=LENGTH (W & WW AS A PAIR) 
         CLCL  X,W            COMPARE 
         BE    STRSR$OK       IF MATCHED, THEN THE KEY IS FOUND 
         LA    L,1(L)         ADVANCE START POSITION 
         C     L,LOCAL4       IF THE LAST POS IS NOT EXCEEDED 
         BNH   STRSR$3          THEN LOOP 
         B     RETNIL         OTHERWISE RETURN NIL (NOT FOUND) 
STRSR$OK LR    A,L            A:=FOUND POSITION 
         CODEND RETNUM        RETURN POSITION AS A NUMBER 
         TITLE 'VECTOR MANIPULATION FUNCTIONS' 
*********************************************************************** 
* 
*     VECTOR MANIPULATION 
* 
VECTOR   SUBR  1,2 
         ST    N,LOCAL2 
         L     A,LOCAL1 
         $POSINX 
         LA    A,0(A) 
         LA    NB,LOCAL3 
         BAL   L,MKVECTOR 
         LT    D,0(A)         D:=VECTOR SIZE 
         BER   E              IF SIZE=0 THEN DO NOTHING 
         LR    X,Z            INITIATE INDEX 
         L     W,LOCAL2       W:=VALUE TO BE FILLED WITH 
         CR    W,N            IF VALUE TO BE FILLED IS NIL 
         BER   E                THEN NO FURTHER FILLING REQUIRED 
         IFATOM W,VECTR$2 
VECTR$1  LM    W,WW,0(W)      WW:=ONE VALUE; W:=THE REST 
         ST    WW,4(X,A)      SET ONE VALUE 
         ALR   X,F 
         CR    X,D 
         BER   E              RETURN WHEN FINISHED 
         IFLIST W,VECTR$1     IF MORE ELEMENTS IN LIST, CONTINUE 
         RET 
VECTR$2  CLM   W,B'1000',@VECTOR 
         BE    VECTR$4 
VECTR$3  ST    W,4(X,A) 
         ALR   X,F 
         CR    X,D 
         BNE   VECTR$3 
         RET 
VECTR$4  C     D,0(W) 
         BNH   VECTR$5 
         L     D,0(W) 
VECTR$5  LR    WW,D 
         LA    X,4(A) 
         LA    W,4(W) 
         LR    NA,WW 
         DISABLE 
         MVCL  X,W 
         ENABLE 
         CODEND RET 
* 
VREF     SUBR  2,2 
         LM    D,A,LOCAL1 
         $VECTOR1 D 
         $POSINX 
         LA    X,0(A,A) 
         AR    X,X 
         C     X,0(D) 
         BNL   INDEXERR 
         L     A,4(X,D) 
         CODEND RET 
* 
VSET     SUBR  3,3 
         LM    D,A,LOCAL1 
         $VECTOR1 D 
         $POSINX 
         LA    X,0(A,A) 
         AR    X,X 
         C     X,0(D) 
         BNL   INDEXERR 
         L     A,LOCAL3 
         ST    A,4(X,D) 
         CODEND RET 
* 
VECLEN   SUBR  1,1,PNAME='VECTOR-LENGTH' 
         L     A,LOCAL1 
         $VECTOR 
         L     A,0(A) 
         SRA   A,2 
         CODEND RETNUM 
* 
REFER    SUBR  2,2,PNAME='REFERENCE' 
         LM    D,A,LOCAL1 
         $VECTOR1 D 
         $POSINX 
         LA    W,0(A,A) 
         AR    W,W 
         C     W,0(D) 
         BNL   INDEXERR 
         LA    A,4(D,W) 
         O     A,@REFER 
         CODEND RET 
* 
DEREF    SUBR  1,1 
         L     A,LOCAL1 
         IFSY  A,DEREF$1 
         $REFER 
         L     A,0(A) 
         RET 
DEREF$1  VALUEA , 
         RET 
         CODEND RET 
* 
SETREF   SUBR  2,2 
         LM    D,A,LOCAL1 
         IFSY  D,SETREF$1 
         $REFER1 D 
SETREF$1 ST    A,0(D) 
         CODEND RET 
* 
REFVEC   SUBR  1,1,PNAME='REFERRED-VECTOR' 
         L     A,LOCAL1 
         $REFER 
REFVEC$1 SLR   A,F 
         CLI   0(A),X'00' 
         BNE   REFVEC$1 
         O     A,@VECTOR 
         CODEND RET 
* 
REFINX   SUBR  1,1,PNAME='REFERRED-INDEX' 
         L     A,LOCAL1 
         $REFER 
REFINX$1 SLR   A,F 
         CLI   0(A),X'00' 
         BNE   REFINX$1 
         SL    A,LOCAL1 
         LPR   A,A 
         SRL   A,2 
         BCTR  A,0 
         CODEND RETNUM 
* 
FILLVEC  SUBR  1,2,PNAME='FILL-VECTOR' 
         ST    N,LOCAL2 
         L     A,LOCAL1       A:=VECTOR TO BE FILLED 
         $VECTOR 
         LT    D,0(A)         D:=VECTOR SIZE 
         BER   E              IF SIZE=0 THEN DO NOTHING 
         LR    X,Z            INITIATE INDEX 
         L     W,LOCAL2       W:=VALUE TO BE FILLED WITH 
         IFATOM W,FILLV$2 
FILLV$1  LM    W,WW,0(W)      WW:=ONE VALUE; W:=THE REST 
         ST    WW,4(X,A)      SET ONE VALUE 
         ALR   X,F 
         CR    X,D 
         BER   E              RETURN WHEN FINISHED 
         IFLIST W,FILLV$1     IF MORE ELEMENTS IN LIST, CONTINUE 
         RET 
FILLV$2  CLM   W,B'1000',@VECTOR 
         BE    FILLV$4 
FILLV$3  ST    W,4(X,A) 
         ALR   X,F 
         CR    X,D 
         BNE   FILLV$3 
         RET 
FILLV$4  C     D,0(W) 
         BNH   FILLV$5 
         L     D,0(W) 
FILLV$5  LR    WW,D 
         LA    X,4(A) 
         LA    W,4(W) 
         LR    NA,WW 
         DISABLE 
         MVCL  X,W 
         ENABLE 
         CODEND RET 
         TITLE 'CODE PIECE MANIPULATION FUNCTIONS' 
PUTD     SUBR  2,2 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         L     D,LOCAL2 
         ST    D,FUNCDEF 
         DROP  A 
         CODEND RET 
* 
GETD     SUBR  1,1 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         CLI   FUNCDEF,UDFTAG 
         BE    UDFERRA 
         L     A,FUNCDEF 
         DROP  A 
         CODEND RET 
* 
MAKEUD   SUBR  1,1,PNAME='MAKE-UNDEFINED' 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         L     W,@UDFDEF 
         ST    W,FUNCDEF 
         DROP  A 
         CODEND RET 
* 
DEFINED  SUBR  1,1,PNAME='DEFINEDP' 
         L     A,LOCAL1 
         $SYMBOL 
         USING SYMBOL,A 
         CLI   FUNCDEF,UDFTAG 
         BNE   RETT 
         DROP  A 
         CODEND RETNIL 
* 
SPECP    SUBR  1,1,PNAME='SPECIALP' 
         L     A,LOCAL1 
         $SYMBOL , 
         USING SYMBOL,A 
         L     A,FUNCDEF 
         DROP  A 
         CL    A,@UDFMIN 
         BL    RETNIL 
         C     A,@UDFDEF 
         BNE   RETT 
         CODEND RETNIL 
* 
FNAME    SUBR  1,1,PNAME='FUNCNAME' 
         L     A,LOCAL1 
         $CODE 
         USING CODE,A 
         L     A,FUNCNAME 
         DROP  A 
         CODEND RET 
* 
CSIZE    SUBR  1,1,PNAME='CODESIZE' 
         L     A,LOCAL1 
         $CODE 
         L     A,0(A) 
         SRA   A,2 
         CODEND RETNUM 
* 
MINARG   SUBR  1,1 
         L     NA,LOCAL1 
         $CODE1 NA 
         USING CODE,NA 
         LA    A,CODETOP-4 
         LA    D,4(A) 
         L     W,ERRCODE 
MINARG$1 ALR   A,F 
         C     W,0(A) 
         BE    MINARG$1 
         SLR   A,D 
         SRA   A,2 
         LA    A,0(A) 
         B     RETNUM 
         DS    0A 
ERRCODE  B     RETURN+16*4+4*4          ; 
         DROP  NA 
         CODEND 
* 
MAXARG   SUBR  1,1 
         L     A,LOCAL1 
         $CODE 
         USING CODE,A 
         L     A,MAXPARAM 
         DROP  A 
         SRA   A,2 
         LA    A,0(A) 
         CODEND RETNUM 
* 
LDCODE   SUBR  1,1,PNAME='LOAD-CODE' 
         L     A,LOCAL1 
         IFATOM A,TYPERR 
         LM    D,A,0(A)       A:=FUNCTION NAME 
         $SYMBOL , 
         ST    A,LOCAL1 
         IFATOM D,TYPERR1 
         LM    D,A,0(D)       A:=MAX # OF ARGUMENTS 
         $FIXNUM , 
         ST    A,LOCAL2 
         IFATOM D,TYPERR1 
         LM    D,A,0(D)       A:=CODE 
         ST    A,LOCAL3 
         IFATOM D,TYPERR1 
         LM    D,A,0(D)       A:=QUOTED OBJECT LIST 
         IFLIST D,TYPERR1 
         LA    NB,LOCAL5 
         IFATOM A,LDCODE$2 
LDCODE$1 LM    D,A,0(A) 
         ST    D,LOCAL4 
         BAL   L,EVAL 
         PUSHW A 
         L     A,LOCAL4 
         IFLIST A,LDCODE$1 
LDCODE$2 L     W,FIXTOP 
         USING CODE,W 
         LA    WW,CODETOP 
         CL    WW,FIXLIM 
         BNL   FIXERR 
         L     A,LOCAL1 
         ST    A,FUNCNAME 
         L     A,LOCAL2 
         LA    A,0(A,A) 
         ALR   A,A 
         ST    A,MAXPARAM 
         L     D,LOCAL3       D:=LIST OF CODE 
         IFATOM D,LDCODE$4 
LDCODE$3 LM    D,A,0(D) 
         $FIXNUM , 
         STH   A,0(WW) 
         LA    WW,2(WW) 
         CL    WW,FIXLIM 
         BNL   FIXERR 
         IFLIST D,LDCODE$3 
LDCODE$4 LA    WW,3(WW) 
         N     WW,WORDBND 
         LR    X,WW 
         SLR   X,W 
         ST    X,QUOTEVEC     SET QUOTE VECTOR POSITION 
         LA    X,LOCAL5 
         CLR   NB,X 
         BE    LDCODE$6 
LDCODE$5 L     A,0(X) 
         ST    A,0(WW) 
         ALR   WW,F 
         CL    WW,FIXLIM 
         BNL   FIXERR 
         ALR   X,F 
         CLR   NB,X 
         BNE   LDCODE$5 
LDCODE$6 ST    WW,FIXTOP 
         SLR   WW,W 
         SLR   WW,F 
         ST    WW,CODESIZE 
         LR    A,W 
         O     A,@CODE 
         DROP  W 
         CODEND RET 
         TITLE 'INPUT/OUTPUT FUNCTIONS' 
*********************************************************************** 
* 
*     INPUT / OUTPUT 
* 
PRLOWER  SYM   ,NIL$,SYMTAG,PNAME='USE-LOWER' 
PRLEV    SYM   ,4,FIXTAG,PNAME='PRINTLEVEL' 
PRLEN    SYM   ,10,FIXTAG,PNAME='PRINTLENGTH' 
DIGITS   SYM   ,7,FIXTAG 
QUEST    SYM   PNAME='?' 
QUESTS   SYM   PNAME='???' 
* 
INSTRM   SYM   ,TERMIN$,STRMTAG,PNAME='STANDARD-INPUT' 
OUTSTRM  SYM   ,TERMOUT$,STRMTAG,PNAME='STANDARD-OUTPUT' 
* 
READTAB  SYM   ,DFLTRDT$,VECTAG,PNAME='READTABLE' 
MACTAB   SYM   ,DFLTMCT$,VECTAG,PNAME='MACROTABLE' 
OBVECT   SYM   ,DFLTOBR$,VECTAG,PNAME='OBVECTOR' 
* 
TIN      SYM   ,TERMIN$,STRMTAG,PNAME='TERMINAL-INPUT' 
TOUT     SYM   ,TERMOUT$,STRMTAG,PNAME='TERMINAL-OUTPUT' 
DFLTR    SYM   ,DFLTRDT$,VECTAG,PNAME='DEFAULT-READTABLE' 
DFLTM    SYM   ,DFLTMCT$,VECTAG,PNAME='DEFAULT-MACROTABLE' 
DFLTO    SYM   ,DFLTOBR$,VECTAG,PNAME='DEFAULT-OBVECTOR' 
* 
OPNFLS   SYM   ,NIL$,SYMTAG,PNAME='OPENFILES' 
* 
READ     SUBR  0,1 
         B     READ$1 
         L     A,LOCAL1 
         LA    NB,LOCAL2 
         BINDQ INSTRM$,A 
         BAL   L,READENT 
         UNDO , 
         RET 
READ$1   LA    NB,LOCAL1 
         LR    L,E 
READENT  GETVALUE READTAB$ 
         $VECTOR ,            CHECK READTABLE 
         LA    W,256*4          AND ITS LENGTH 
         CL    W,0(A) 
         BNE   TYPERR 
READREC  LA    L,0(L)         CLEAR TAG 
         PUSHW L              SAVE RET ADDR 
         GETVALUE INSTRM$ 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         TM    MODE+3,INMODE  CHECK STREAM MODE 
         BNZ   RD1 
         B     IOERR 
* 
RDCOM    L     L,LINEIO 
         BALR  L,L 
RD1      GETNEXT 
         TM    6(L),BLANK+RPAR 
         BNZ   RD1 
         TM    7(L),COMBEG 
         BNZ   RDCOM 
         TM    6(L),LPAR+MACROCH+STRQ+SINGLE 
         BZ    SYORNUM 
         TM    6(L),LPAR 
         BNZ   RDLIST 
         TM    6(L),MACROCH 
         BNZ   RDMACRO 
         TM    6(L),STRQ 
         BNZ   RDSTR 
         TM    6(L),SINGLE 
         BZ    SYSERR#C 
* 
* SINGLE CHARACTER OBJECT 
* 
         L     A,STRBUFAD     STORE THE CHARACTER 
         STC   W,0(A)         IN THE STRING BUFFER 
         LA    A,1(A) 
RDSY     BAL   L,MKSTRING     MAKE THE STRING WITH ONE CHAR 
         POPW  L 
         LR    D,A 
         GETVALUE INTERN$ 
         B     FUNCALLD 
* 
* 
* SYMBOL OR NUMBER 
* 
*   RDFLAG MEANS: 
*     X'01' :  MINUS SIGN PRECEEDED 
*     X'02' :  MINUS SIGN IN EXPONENT PART 
* 
SYORNUM  MVI   RDFLAG,0       CLEAR FLAG 
         L     A,STRBUFAD     A:=BUFFER ADDR 
         TM    7(L),SIGN      IF FIRST CHARACTER IS A SIGN CHARACTER 
         BZ    NOSIGN 
         TM    7(L),ALT         THEN IF IT IS A MINUS SIGN 
         BZ    PLUSNUM 
         OI    RDFLAG,1           THEN SET FLAG 
PLUSNUM  STBUFF ,             STORE INTO BUFFER 
         GETNEXT ,            NEXT CHAR 
NOSIGN   TM    7(L),DIG       IF NOT DIGIT THEN 
         BZ    ISSY             SOMETHING READ IN IS A SYMBOL 
         SDR   FR0,FR0        CLEAR FR0 -- ACCUMULATOR 
         LD    FR4,FLO10      FR4:=10.0 
INTPART  STBUFF ,             STORE ONE DIGIT 
         S     W,=A(C'0')     W:=VALUE OF DIGIT 
         ST    W,0(NB)        CONVERT VALUE 
         CVTID FR2,0(NB)        TO FLOATING ON FR2 
         MDR   FR0,FR4        FR0:=10 * FR0 
         ADR   FR0,FR2               + VALUE-OF-NEW-CHAR 
         GETNEXT , 
         TM    7(L),DIG       REPEAT UNTIL 
         BNZ   INTPART          DIGITS ARE EXHAUSTED 
         TM    6(L),TERM      IF ONLY DIGITS (AND POSSIBLY, SIGN) 
         BNZ   ISFIX            IT IS A FIXNUM 
         TM    5(L),POINT     IF DECIMAL POINT IS ENCOUNTERED 
         BZ    RDNOFRAC         THEN COMES THE FRACTION PART 
         STBUFF ,             STORE DECIMAL POINT 
         GETNEXT , 
         TM    7(L),DIG       IF FIRST CHAR IS NOT DIGIT 
         BZ    FRACEND          THAT'S THE END 
         LDR   FR6,FR4        OTHERWISE, FR6:=10.0, FOR INITIAL VALUE 
FRACPART STBUFF ,             STORE ONE DIGIT IN BUFFER 
         S     W,=A(C'0')     W:=VALUE OF THE DIGIT 
         ST    W,0(NB)        CONVERT VALUE INTO FLOATING 
         CVTID FR2,0(NB)        ON FR2 
         DDR   FR2,FR6        DIVIDE IT BY 10, 100, 100, ETC. 
         ADR   FR0,FR2        SUM UP 
         MDR   FR6,FR4        FR6:=10 * FR6 
         GETNEXT , 
         TM    7(L),DIG       REPEAT UNTIL 
         BNZ   FRACPART         DIGITS EXHAUSTED 
FRACEND  TM    6(L),TERM      IF TERMINATOR IS ENCOUNTERED 
         BNZ   ISFLOAT          IT'S A FLOAT NUM WITHOUT EXPONENT PART 
RDNOFRAC TM    5(L),EXPNT     OTHERWISE, IF EXPNT SYMBOL IS NOT FOUND 
         BZ    ISSY             IT MUST BE A SYMBOL 
         STBUFF ,             STORE EXPONENT SYMBOL 
         GETNEXT , 
         TM    7(L),SIGN      IF EXPONENT PART IS PRECEEDED BY A SIGN 
         BZ    NOEXPSGN 
         TM    7(L),ALT         THEN IF SIGN IS MINUS SIGN 
         BZ    PLUSEXP 
         OI    RDFLAG,2           THEN SET FLAG 
PLUSEXP  STBUFF ,               STORE SIGN 
         GETNEXT , 
NOEXPSGN TM    7(L),DIG       IF EXPONENT DOES NOT BEGIN WITH A DIGIT 
         BZ    ISSY             IT IS A SYMBOL 
         LR    D,Z            D:=0 (EXPONENT VALUE IS READ INTO D-REG) 
EXPPART  STBUFF ,             STORE ONE DIGIT 
         S     W,=A(C'0')     W:=VALUE OF THE DIGIT 
         ALR   D,D            D:=10 * D 
         LA    WW,0(D,D) 
         ALR   WW,WW 
         ALR   D,WW 
         ALR   D,W            D:=D + VALUE-OF-ONE-DIGIT 
         GETNEXT , 
         TM    7(L),DIG       REPEAT UNTIL 
         BNZ   EXPPART          DIGITS EXHAUST 
         TM    6(L),TERM      IF TERMINATOR DOES NOT COME NEXT 
         BZ    ISSY             IT IS NOT A NUMBER 
         LTR   D,D            IF EXPONENT PART IS ZERO 
         BZ    ISFLOAT          THEN DO NOTHING 
         SDR   FR2,FR2 
         TM    RDFLAG,2       OTHERWISE, IF EXPONENT IS MINUS 
         BZ    POSEXPNT 
         LD    FR4,FLOTENTH 
         LD    FR6,FLOTENTH+8 
NEGEXPNT MXR   FR0,FR4          THEN DIVIDE THE FLOATING POINT VALUE 
         BCT   D,NEGEXPNT         BY 10.0 FOR EXPONENT TIMES 
         B     ISFLOAT0 
* 
POSEXPNT MXDR  FR0,FR4        IF EXPONENT IS POSITIVE, MULT THE VALUE 
         BCT   D,POSEXPNT       BY 10.0 FOR EXPONENT TIMES 
ISFLOAT0 LRDR  FR0,FR0 
ISFLOAT  BAL   L,PUTBACK      PUT BACK THE LAST CHAR 
         POPW  L              L:=RETURN ADDR 
         TM    RDFLAG,1       IF SIGN IS POSITIVE 
         BZ    MKFLOAT          THEN ALLOCATE AND RETURN 
         LCDR  FR0,FR0        OTHERWISE, NEGATE THE VALUE AND 
         B     MKFLOAT          ALLOCATE AND RETURN 
* 
ISFIX    BAL   L,PUTBACK      PUT BACK LAST CHAR 
         CVTDI FR0,0(NB)      CONVERT TO INTEGER VALUE 
         L     A,0(NB)          ON A-REG 
         TM    RDFLAG,1 
         BZ    ISFIX1         IF SIGNED MINUS 
         LCR   A,A              NEGATE THE VALUE 
ISFIX1   LA    A,0(A)         CLEAR UPPER 8 BITS 
         O     A,@FIX         PUT FIX NUM TAG 
         POPW  L              AND RETURN 
         BR    L 
* 
CHECKESC TM    7(L),ESC       IF ESCAPE CHAR IS ENCOUNTERED 
         BZ    NOESC 
         BAL   L,GETCH          THEN READ ANOTHER CHAR 
NOESC    STBUFF ,             STORE ONE CHAR INTO THE BUFFER 
         GETNEXT ,            GET NEXT CHAR 
ISSY     TM    6(L),TERM      REPEAT UNTIL 
         BZ    CHECKESC         THE TERMINATOR IS ENCOUNTERED 
         BAL   L,PUTBACK      PUT BACK THE TERMINATOR 
         B     RDSY 
* 
* STRING 
* 
RDSTR    L     A,STRBUFAD     A:=STRBUFF TOP 
RDSTR1   GETNEXT ,            GET NEXT CHAR (IGNORE '"') 
         TM    6(L),STRQ      IS IT '"'? 
         BZ    RDSTR2 
         GETNEXT ,            IF '"' APPEARED 
         TM    6(L),STRQ        CHECK IF IT IS DOUBLED 
         BZ    RDSTR3         IF NOT DOUBLED, IT'S THE END 
RDSTR2   STC   W,0(A)         STORE THE CHAR IN THE BUFFER 
         LA    A,1(A)         ADVANCE POINTER 
         CL    A,STRBUFE 
         BL    RDSTR1         LOOP 
         B     BUFFERR        !STRING LOO LONG 
* 
RDSTR3   BAL   L,PUTBACK 
         POPW  L              ALLOCATE STRING 
         B     MKSTRING         AND RETURN 
* 
* LIST 
* 
RDLIST0  BAL   L,PUTBACK 
         BAL   L,READREC      READ ONE LIST ITEM 
         PUSHW A 
         L     A,INSTRM 
         CLI   0(A),STRMTAG 
         BNE   TYPERR 
         L     NA,0(A) 
         TM    MODE+3,INMODE 
         BZ    TYPERR 
RDLIST   GETNEXT              SKIP UNTIL 
         TM    6(L),BLANK       NON-BLANK FOUND 
         BNZ   RDLIST 
         TM    6(L),RPAR      IF RPAR ENCOUNTERED 
         BNZ   RDLIST2          THAT'S THE END OF LIST 
         TM    6(L),DOT       LOOP UNTIL RPAR OR 
         BNZ   RDLSTITM         DOT APPEARS 
         TM    7(L),COMBEG 
         BZ    RDLIST0  
         L     L,LINEIO 
         BALR  L,L 
         B     RDLIST 
* 
RDLSTITM BAL   L,READREC      READ ONE ITEM AFTER DOT 
         LR    D,A 
         L     A,INSTRM 
         CLI   0(A),STRMTAG 
         BNE   TYPERR 
         L     NA,0(A) 
         TM    MODE+3,INMODE 
         BZ    TYPERR 
         LR    A,D 
RDLIST1  GETNEXT              SKIP UNTIL 
         TM    6(L),BLANK       NON-BLANK FOUND 
         BNZ   RDLIST1 
         TM    6(L),RPAR      CHECK IF 
         BNZ   RDLIST3          IT IS AN RPAR 
         TM    7(L),COMBEG    IF NOT RPAR NOR COMMENTING CHAR 
         BZ    READERR          THEN ITS AN ERROR 
         L     L,LINEIO       IF COMMENTING CHAR, 
         BALR  L,L              GET NEXT LINE 
         B     RDLIST1          AND RETRY 
* 
RDLIST2  LR    A,N            NIL FOR LIST TERMINATOR 
RDLIST3  SLR   NB,F           POP STACK 
         TM    0(NB),X'F0'    IF IT IS A RETURN ADDR 
         BZ    RDLIST4          THEN ALL DONE 
         L     D,0(NB)        POP AN ITEM 
         BAL   L,XCONS          AND CONS IT WITH THE REST 
         B     RDLIST3        LOOP 
* 
RDLIST4  L     L,0(NB)        RETURN 
         BR    L 
* 
* READ MACROS 
* 
RDMACRO  GETVALUE MACTAB$     GET MACRO TABLE VALUE 
         $VECTOR ,            CHECK IF ITIS A VECTOR 
         LA    WW,256*4         AND HAS PROPER SIZE 
         USING BIGCELL,A 
         C     WW,LENGTH 
         BNE   TYPERR 
         SLA   W,2            GET MACRO FUNCTION 
         L     A,CELLBODY(W)    FROM THE TABLE 
         DROP  A 
         POPW  L              CALL "FUNCALL" WITH NO ARGUMENT 
         B     FUNCALL0         TAIL RECURSIVELY 
         DROP  NA 
         CODEND 
* 
READLN   SUBR  0,1,PNAME='READLINE' 
         B     READLN$1 
         B     READLN$2 
READLN$1 GETVALUE INSTRM$ 
         ST    A,LOCAL1 
READLN$2 L     A,LOCAL1 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         TM    MODE+3,INMODE 
         BZ    IOERR 
         LA    NB,LOCAL2 
         L     W,CURPOS 
         C     W,RECEND 
         BNE   READLN$3 
         L     L,LINEIO 
         BALR  L,L 
READLN$3 L     A,RECEND 
         SL    A,CURPOS 
         BAL   L,MKBLOCK      ALLOCATE STRING BLOCK 
         L     W,CURPOS 
         L     WW,RECEND      SET THE CURPOS TO RECEND 
         ST    WW,CURPOS 
         L     WW,0(A)        WW:=LENGTH 
         DROP  NA 
         LR    NA,WW          NA:=LENGTH 
         LA    X,4(A) 
         MVCL  X,W            FILL CHARCTERS 
         XC    0(3,X),0(X)    PADDING FOR HASHING 
         O     A,@STRING 
         CODEND RET 
* 
SKIPLN   SUBR  0,1,PNAME='SKIPLINE' 
         B     SKIPLN$1 
         B     SKIPLN$2 
SKIPLN$1 GETVALUE INSTRM$ 
         ST    A,LOCAL1 
SKIPLN$2 L     A,LOCAL1 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         TM    MODE+3,INMODE 
         BZ    IOERR 
         LA    NB,LOCAL2 
         L     W,RECEND 
         C     W,RECTOP 
         BE    SKIPLN$3 
         C     W,CURPOS 
         BNE   SKIPLN$4 
SKIPLN$3 L     L,LINEIO 
         BALR  L,L 
SKIPLN$4 L     WW,RECEND      SET THE CURPOS TO RECEND 
         ST    WW,CURPOS 
         DROP  NA 
         CODEND RETNIL 
* 
CURRLN   SUBR  0,1,PNAME='CURRENT-LINE' 
         B     CURRLN$1 
         B     CURRLN$2 
CURRLN$1 GETVALUE INSTRM$ 
         ST    A,LOCAL1 
CURRLN$2 L     A,LOCAL1 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         TM    MODE+3,INMODE 
         BZ    IOERR 
         LA    NB,LOCAL2 
         L     A,RECEND 
         C     A,RECTOP 
         BE    CURRLN$3 
         C     A,CURPOS 
         BNE   CURRLN$4 
CURRLN$3 L     L,LINEIO 
         BALR  L,L 
         L     A,RECEND 
CURRLN$4 SL    A,RECTOP 
         BAL   L,MKBLOCK      ALLOCATE STRING BLOCK 
         L     W,RECTOP 
         L     WW,0(A)        WW:=LENGTH 
         DROP  NA 
         LR    NA,WW          NA:=LENGTH 
         LA    X,4(A) 
         MVCL  X,W            FILL CHARCTERS 
         XC    0(3,X),0(X)    PADDING FOR HASHING 
         O     A,@STRING 
         CODEND RET 
* 
TYI      SUBR  0,1 
         B     TYI$1 
         B     TYI$2 
TYI$1    GETVALUE INSTRM$ 
         ST    A,LOCAL1 
TYI$2    L     A,LOCAL1 
         $STREAM 
         USING STREAM,A 
         TM    MODE+3,INMODE 
         BZ    IOERR 
         LR    NA,A 
         DROP  A 
         LA    NB,LOCAL2 
         BAL   L,GETCH 
         LR    A,W 
         CODEND RETNUM 
* 
TYIPEEK  SUBR  0,1 
         B     TYIP$1 
         B     TYIP$2 
TYIP$1   GETVALUE INSTRM$ 
         ST    A,LOCAL1 
TYIP$2   L     A,LOCAL1 
         $STREAM 
         USING STREAM,A 
         TM    MODE+3,INMODE 
         BZ    IOERR 
         LR    NA,A 
         DROP  A 
         LA    NB,LOCAL2 
         BAL   L,GETCH 
         LR    A,W 
         BAL   L,PUTBACK 
         CODEND RETNUM 
* 
READCH   SUBR  0,1 
         B     READCH$1 
         B     READCH$2 
READCH$1 GETVALUE INSTRM$ 
         ST    A,LOCAL1 
READCH$2 L     A,LOCAL1 
         $STREAM 
         USING STREAM,A 
         TM    MODE+3,INMODE 
         BZ    IOERR 
         LR    NA,A 
         DROP  A 
         LA    NB,LOCAL2 
         BAL   L,GETCH 
         L     A,STRBUFAD 
         STC   W,0(A) 
         LA    A,1(A) 
         BAL   L,MKSTRING 
         LR    D,A 
         GETVALUE INTERN$ 
         B     FUNCALDR 
         CODEND 
* 
RDQT     SUBR  0,0,PNAME='READQUOTE' 
         LA    NB,LOCAL1 
         L     A,READ 
         BAL   L,FUNCALL0 
         LR    D,N 
         BAL   L,CONS 
         L     D,QUOTE 
         B     XCONSRET 
         CODEND 
* 
RDCODE   SUBR  0,0,PNAME='READCODE' 
         GETVALUE INSTRM$ 
         ST    A,LOCAL1       LOCAL1:=INPUT STREAM SAVE 
         LA    NB,LOCAL2 
         LR    NA,A           NA:=INPUT STREAM 
         USING STREAM,NA 
         L     X,CURPOS 
         BCTR  X,0 
         NEXTCH , 
         L     A,STRBUFAD 
         LR    D,Z 
         IC    D,0(X) 
RDCODE$1 NEXTCH , 
         IC    W,0(X) 
         STC   W,0(A) 
         LA    A,1(A) 
         BCT   D,RDCODE$1 
         ST    X,CURPOS 
         BAL   L,MKSTRING 
         LR    D,A 
         GETVALUE INTERN$ 
         BAL   L,FUNCALLD 
         ST    A,LOCAL2       LOCAL2:=FUNC NAME TO BE 
         LA    NB,LOCAL3 
         L     NA,LOCAL1      NA:=INPUT STREAM 
         L     X,CURPOS 
         NEXTCH , 
         LR    W,Z 
         IC    W,0(X)         W:=MAX # OF ARGS 
         SLL   W,2 
         ST    W,LOCAL3       LOCAL3:=MAX # OF ARGS * 4 
         LA    NB,LOCAL4 
         LR    D,Z 
         NEXTCH , 
         IC    D,0(X) 
         SLL   D,8 
         NEXTCH , 
         IC    D,0(X)         D:=LENGTH OF MACHINE CODE 
         LA    W,0(D,D) 
         ST    W,LOCAL4       LOCAL4:=MACHINE CODE SIZE 
         ST    Z,LOCAL5       LOCAL5:=# OF QUOTED FORMS (TO BE) 
         ST    Z,LOCAL6       LOCAL6:=WORK 
         LA    NB,LOCAL7 
RDCODE2  LR    W,Z 
         NEXTCH , 
         IC    W,0(X) 
         NEXTCH , 
         SLL   W,8 
         IC    W,0(X) 
         PUSHW W 
         BCT   D,RDCODE2 
         NEXTCH , 
         LR    W,Z 
         IC    W,0(X) 
         SLL   W,8 
         NEXTCH , 
         IC    W,0(X) 
         ST    W,LOCAL5       LOCAL5:=# OF QUOTED OBJECTS 
         LA    X,1(X) 
         ST    X,CURPOS 
         DROP  NA 
         LTR   W,W 
         BZ    RDCODE7 
RDCODE3  ST    W,LOCAL6       LOCAL6:=COUNTER 
         L     A,READ 
         BAL   L,FUNCALL0 
         BAL   L,EVAL 
         PUSHW A 
         L     W,LOCAL6 
         BCT   W,RDCODE3 
RDCODE7  L     D,FIXTOP 
         USING CODE,D 
         LA    W,CODETOP 
         L     WW,LOCAL5 
         ALR   WW,WW 
         ALR   WW,WW          WW:=QUOTE VECTOR SIZE (BYTES) 
         AL    W,LOCAL4       ADD MACHINE CODE SIZE 
         ALR   W,WW 
         LA    W,3(W) 
         N     W,WORDBND      ADJUST TO WORD BOUNDARY 
         CL    W,FIXLIM 
         BNL   FIXERR 
         ST    W,FIXTOP 
         SLR   W,D            W:=CODE PIECE SIZE 
         SLR   W,F 
         ST    W,CODESIZE 
         L     W,LOCAL2 
         ST    W,FUNCNAME 
         L     W,LOCAL3 
         ST    W,MAXPARAM 
         LR    W,Z 
         LA    NB,LOCAL7 
RDCODE4  L     WW,0(NB) 
         STH   WW,CODETOP(W) 
         ALR   NB,F 
         LA    W,2(W) 
         CL    W,LOCAL4 
         BNE   RDCODE4 
         LA    W,3(W) 
         N     W,WORDBND      ADJUST TO WORD BOUNDARY 
         LR    WW,W 
         LA    WW,CODETOP-CODESIZE(W) 
         ST    WW,QUOTEVEC 
         L     WW,LOCAL5 
         LTR   WW,WW 
         BZ    RDCODE6 
RDCODE5  L     A,0(NB) 
         ST    A,CODETOP(W) 
         ALR   NB,F 
         ALR   W,F 
         BCT   WW,RDCODE5 
RDCODE6  LR    A,D 
         O     A,@CODE 
         DROP  D 
         CODEND RET 
* 
PRIN1    SUBR  1,2 
         B     PRIN1$1 
         L     A,LOCAL2 
         LA    NB,LOCAL3 
         BINDQ OUTSTRM$,A 
         L     A,LOCAL1 
         LA    W,1 
         BAL   L,PRINTENT 
         UNDO 
         L     A,LOCAL1 
         RET 
PRIN1$1  LA    NB,LOCAL2 
         L     A,LOCAL1 
         LA    W,1 
         BAL   L,PRINTENT 
         L     A,LOCAL1 
         CODEND RET 
* 
PRINT    SUBR  1,2 
         B     PRINT$1 
         L     A,LOCAL2 
         LA    NB,LOCAL3 
         BINDQ OUTSTRM$,A 
         L     A,LOCAL1 
         LA    W,1 
         BAL   L,PRINTENT 
         BAL   L,TERPRI 
         UNDO 
         L     A,LOCAL1 
         RET 
PRINT$1  LA    NB,LOCAL2 
         L     A,LOCAL1 
         LA    W,1 
         BAL   L,PRINTENT 
         BAL   L,TERPRI 
         L     A,LOCAL1 
         CODEND RET 
* 
PRINC    SUBR  1,2 
         B     PRINC$1 
         L     A,LOCAL2 
         LA    NB,LOCAL3 
         BINDQ OUTSTRM$,A 
         L     A,LOCAL1 
         LR    W,Z 
         BAL   L,PRINTENT 
         UNDO 
         L     A,LOCAL1 
         RET 
PRINC$1  LA    NB,LOCAL2 
         L     A,LOCAL1 
         LR    W,Z 
         BAL   L,PRINTENT 
         L     A,LOCAL1 
         CODEND RET 
* 
TYO      SUBR  1,2 
         B     TYO$1 
         B     TYO$2 
TYO$1    GETVALUE OUTSTRM$ 
         ST    A,LOCAL2 
TYO$2    L     A,LOCAL2 
         $STREAM 
         USING STREAM,A 
         TM    MODE+3,OUTMODE 
         BZ    IOERR 
         LR    NA,A 
         DROP  A 
         L     A,LOCAL1 
         $CHARACT 
         LA    W,0(A) 
         LA    NB,LOCAL3 
         BAL   L,PUTCH 
         L     A,LOCAL1 
         CODEND RET 
* 
TERPRI   SUBR  0,1 
         B     TERPRI$1 
         L     A,LOCAL1 
         LA    NB,LOCAL2 
         BINDQ OUTSTRM$,A 
         BAL   L,TERPRI 
         UNDO  , 
         B     RETNIL 
TERPRI$1 LA    NB,LOCAL1 
         LA    L,RETNIL 
         B     TERPRI 
         CODEND 
* 
CURSOR   SUBR  0,1 
         B     CURSOR$1 
         B     CURSOR$2 
CURSOR$1 GETVALUE OUTSTRM$ 
         ST    A,LOCAL1 
CURSOR$2 L     A,LOCAL1 
         $STREAM , 
         LR    NA,A 
         USING STREAM,NA 
         L     A,CURPOS 
         C     A,RECEND 
         BNE   CURSOR$3 
         L     A,ZERO 
         RET 
CURSOR$3 SL    A,RECTOP 
         DROP  NA 
         CODEND RETNUM 
* 
COLLEFT  SUBR  0,1 
         B     COLEFT$1 
         B     COLEFT$2 
COLEFT$1 GETVALUE OUTSTRM$ 
         ST    A,LOCAL1 
COLEFT$2 L     A,LOCAL1 
         $STREAM , 
         LR    NA,A 
         L     N,NIL 
         USING STREAM,NA 
         L     A,RECEND 
         SL    A,CURPOS 
         DROP  NA 
         CODEND RETNUM 
* 
TAB      SUBR  1,2 
         B     TAB$1 
         B     TAB$2 
TAB$1    GETVALUE OUTSTRM$ 
         ST    A,LOCAL2 
TAB$2    L     A,LOCAL2 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         TM    MODE+3,OUTMODE 
         BZ    IOERR 
         L     A,LOCAL1 
         CL    A,MINFIX 
         BNL   TYPERR 
TAB$3    L     D,RECTOP 
         LA    D,0(A,D) 
         CL    D,RECEND 
         BNL   TYPERR 
         L     X,CURPOS 
         CLR   X,D 
         BNH   TAB$5 
         L     L,LINEIO 
         LA    NB,LOCAL2 
         BALR  L,L 
         B     TAB$3 
TAB$4    MVI   0(X),C' ' 
         LA    X,1(X) 
TAB$5    CLR   X,D 
         BNE   TAB$4 
         ST    X,CURPOS 
         DROP  NA 
         CODEND RETNIL 
* 
LINELEN  SUBR  0,1,PNAME='LINELENGTH' 
         B     LL$1 
         B     LL$2 
LL$1     GETVALUE OUTSTRM$ 
         ST    A,LOCAL1 
LL$2     L     A,LOCAL1 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         L     A,RECEND 
         SL    A,RECTOP 
         DROP  NA 
         CODEND RETNUM 
* 
LINESI   SUBR  0,1,PNAME='LINESIZE' 
         B     LS$1 
         L     A,LOCAL1 
         $CHARACT 
         LA    D,0(A) 
         L     NB,LOCAL2 
         DISABLE 
         AIF   ('&SYSTEM' EQ 'MTS').NOSTSIZ
         STSIZE SIZE=(D) 
.NOSTSIZ ANOP
         ST    D,LINESIZE 
         ENABLE 
         RET 
LS$1     L     A,LINESIZE 
         CODEND RETNUM 
* 
LINES    SYM   ,0,FIXTAG,PNAME='LINES' 
* 
STREAM   SUBR  1,1 
         L     A,LOCAL1 
         $STRING 
         LA    W,8 
         C     W,0(A) 
         BL    TYPERR 
         LA    NB,LOCAL2 
         B     MKSTRMR 
         CODEND 
* 
INOPEN   SUBR  1,1 
         L     A,LOCAL1 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         CLI   MODE+3,X'00' 
         BNE   OPENERR 
* 
         AIF   ('&SYSTEM' EQ 'MTS').OPEMTSI
*
         LA    D,DCB 
         MVI   DCBMACR,B'01001000' GET,LOCATE 
         LA    NB,LOCAL2 
         MVI   DCBFLAG,0 
         DISABLE 
         OPEN  ((D),INPUT) 
         LM    0,1,REGINIT 
         CLI   DCBFLAG,X'00' 
         BNE   OPENERR 
         LTR   X,15 
         BNZ   OPENERR 
*
         AGO   .OPETSOI
.OPEMTSI ANOP
*
         LA    NB,LOCAL2
         DISABLE
         LM    0,1,IOLDN      CALL GDINFO TO SEE IF IT IS LEGAL
         CALL  GDINFO
         LTR   X,15
         BNZ   OPENERR        UNIT NOT ASSIGNED OR BAD FDUB
         LR    D,1            POINTER TO INFO GDINFO RETURNED
         USING GDDSECT,D
         IF    ¬GDINOK:GDSWS  THEN INPUT NOT ALLOWED
           FREESPAC ,         FREE THE GDINFO STUFF
           B     OPENERR      AND PUNT
         ENDIF
         LH    X,GDINLEN      MAX INPUT LENGTH
         IF    X,Z            IF LEN IS ZERO (EMPTY FILE?)
           LA    X,8          GET AN 8 BYTE BUFFER ANYWAY
         ENDIF
         STH   X,IOLEN+2      SAVE IT
         IF    GDDTYP,EQ,GDFILE IF IT'S A FILE, REWIND IT
           LM    0,1,IOLDN
           CALL  REWIND#
         ENDIF
         FREESPAC (D)         FREE THE GDINFO STUFF
         DROP  D
         LH    1,IOLEN+2      BUFFER LENGTH
         GETSPACE (1),T=3     GET AN INPUT BUFFER
         ST    1,IOBUFAD
*
.OPETSOI ANOP
*  
         XC    CURPOS(12),CURPOS 
         MVI   MODE+3,INMODE 
         LA    W,LINEIN 
         ST    W,LINEIO 
         DROP  NA 
         LR    D,A 
         GETVALUE OPNFLS$ 
         BAL   L,XCONS 
         L     D,OPNFLS 
         ST    A,0(D) 
         ENABLE , 
         L     A,4(A) 
         CODEND RET 
* 
OTOPEN   SUBR  1,3,PNAME='OUTOPEN' 
         ST    Z,LOCAL2 
         ST    Z,LOCAL3 
         L     A,LOCAL1 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         CLI   MODE+3,X'00' 
         BNE   OPENERR 
*  
         AIF   ('&SYSTEM' EQ 'MTS').OPEMTSO
*
         MVI   DCBMACR+1,B'01001000' PUT, LOCATE 
         MVI   DCBMACR,0 
         MVI   DCBRECFM,X'00' ; DEFAULT IS SET AT DCBEXIT 
         L     A,LOCAL2 
         $POSFIX , 
         LA    A,0(A) 
         STH   A,DCBLRECL 
         L     A,LOCAL3 
         $POSFIX , 
         LA    A,0(A) 
         STH   A,DCBBLKSI 
         LR    A,NA 
         LA    D,DCB 
         LA    NB,LOCAL4 
         DISABLE 
         MVI   DCBFLAG,0 
         OPEN  ((D),OUTPUT) 
         LM    0,1,REGINIT 
         TM    DCBFLAG,X'FF' 
         BNZ   OPENERR 
         LTR   X,15 
         BNZ   OPENERR 
*
         AGO   .OPETSOO
.OPEMTSO ANOP
*
         L     A,LOCAL2 
         $POSFIX , 
         LA    1,0(A) 
         STH   1,IOLEN+2
         LR    A,NA           RESTORE THIS FOR OPENERR
         LA    NB,LOCAL4
         DISABLE
         LM    0,1,IOLDN      CALL GDINFO TO SEE IF IT IS LEGAL
         CALL  GDINFO
         LTR   X,15
         BNZ   OPENERR        UNIT NOT ASSIGNED OR BAD FDUB
         LR    A,1            POINT TO RETURNED INFO
         USING GDDSECT,A
         IF    ¬GDOUTOK:GDSWS THEN OUTPUT IS NOT ALLOWED
           FREESPAC ,         FREE THE GDINFO STUFF
           LR    A,NA         RESTORE FOR OPENERR
           B     OPENERR      AND PUNT
         ENDIF
         IF    (GDLENSW:GDSWS2),AND,                                   @
               (GDLEN,GE,=AL2(GDWIDTH+2-GDDSECT),CLC)
           LH    X,GDWIDTH    USE TERMINAL WIDTH
         ELSE
           LH    X,GDOUTLEN   USE TRUNCATION LENGTH
         ENDIF
         IF    GDDTYP,EQ,GDFILE IF IT'S A FILE, REWIND OR EMPTY IT
           LM    0,1,IOLDN
           IF    (GDEXINCR:GDSWS),OR,((GDEXBLN+GDEXELN):GDSWS2)
             CALL  REWIND#    LINE RANGE GIVEN, DON'T EMPTY IT
           ELSE
             CALL  EMPTY      NO LINE RANGE, EMPTY THE FILE
           ENDIF
         ENDIF
         FREESPAC (A)         FREE THE GDINFO STUFF
         DROP  A
         LH    1,IOLEN+2      LRECL GIVEN IN CALL
         IF    (1,Z),OR,(1,GT,X) NOT GIVEN OR TOO BIG
           LR    1,X          SET LRECL
           STH   1,IOLEN+2
         ENDIF
         GETSPACE (1),T=3
         ST    1,IOBUFAD
         LR    A,NA 
*
.OPETSOO ANOP
*
         LA    W,LINEOUT 
         ST    W,LINEIO 
         XC    CURPOS(12),CURPOS 
         MVI   MODE+3,OUTMODE 
         BAL   L,LINEOUT1 
         DROP  NA 
         LR    D,NA 
         GETVALUE OPNFLS$ 
         BAL   L,XCONS 
         L     D,OPNFLS 
         ST    A,0(D) 
         ENABLE , 
         L     A,4(A) 
         CODEND RET 
* 
CLOSE    SUBR  1,1 
         L     A,LOCAL1 
         $STREAM 
         USING STREAM,A 
         TM    MODE+3,INMODE 
         BNZ   CLOSE$3 
         TM    MODE+3,OUTMODE 
         BZ    IOERR 
         C     A,TERMOUT 
         BE    IOERR 
*
         AIF   ('&SYSTEM' EQ 'MTS').CLOMTS
*
         LA    W,DCB 
         USING DCB,W 
         TM    DCBRECFM,B'01000000' 
         DROP  W 
         BNZ   CLOSE$V 
CLOSE$F  L     W,RECEND 
         L     WW,CURPOS 
CLOSE$F1 CLR   WW,W 
         BNL   CLOSE$3 
         MVI   0(WW),C' ' 
         LA    WW,1(WW) 
         B     CLOSE$F1 
CLOSE$V  L     W,RECTOP 
         L     WW,CURPOS 
         CLR   WW,W 
         BH    CLOSE$V1       ; IF RECORD IS NULL THEN 
         MVI   0(WW),C' '    ; INSERT SINGLE SPACE 
         LA    WW,1(WW) 
CLOSE$V1 SLR   W,F 
         SLR   WW,W 
         STH   WW,0(W) 
         STH   Z,2(W) 
*
         AGO   .CLOTSO
.CLOMTS  ANOP
         IF    CURPOS,NE,RECTOP THEN BUFFER IS NOT EMPTY
           LR    NA,A         CALL LINEOUT TO GET LAST LINE OUT
           LA    NB,LOCAL2
           BAL   L,LINEOUT
         ENDIF
.CLOTSO  ANOP
*
CLOSE$3  C     A,TERMIN 
         BE    IOERR 
*
         AIF   ('&SYSTEM' EQ 'MTS').CLOMTS2
*
         LA    D,DCB 
         LA    NB,LOCAL2 
         DISABLE 
         CLOSE ((D)) 
         LM    0,1,REGINIT 
         LTR   X,15 
         BNZ   CLOSE$ER 
         FREEPOOL (D) 
*
         AGO   .CLOTSO2
.CLOMTS2 ANOP
*
         LA    NB,LOCAL2
         DISABLE
         LA    X,IOLDN
         CALL  CLOSEFIL,((X))
*        IGNORE THE RETURN CODE, IT MAY NOT BE A FILE
         LA    X,IOLDN
         CALL  UNLK,((X))
*        IGNORE THE RETURN CODE, IT MAY NOT BE A FILE
         L     1,IOBUFAD
         FREESPAC (1)
*       
.CLOTSO2 ANOP
*
         LM    0,1,REGINIT 
         MVI   MODE+3,X'00'   NOT OPEN MODE 
         DROP  A 
         L     W,OPNFLS 
CLOSE$4  L     WW,0(W) 
         IFATOM WW,RETNIL 
         C     A,4(WW) 
         BE    CLOSE$5 
         LR    W,WW 
         B     CLOSE$4 
CLOSE$5  L     WW,0(WW) 
         ST    WW,0(W) 
         ENABLE , 
         B     RETNIL 
* 
CLOSE$ER ENABLE , 
         B     OPENERR 
         CODEND 
* 
STRMMOD  SUBR  1,1,PNAME='STREAM-MODE' 
         L     A,LOCAL1 
         $STREAM 
         LR    NA,A 
         USING STREAM,NA 
         L     A,INOPEN 
         CLI   MODE+3,INMODE 
         BER   E 
         L     A,OUTOPEN 
         CLI   MODE+3,OUTMODE 
         BER   E 
         CODEND RETNIL 
* 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC02 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM02 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##02 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##02 
.HITAC02 ANOP 
CLTSS    SUBR  1,1,PNAME='CALLTSS' 
         L     A,LOCAL1 
         $STRING 
         L     W,0(A) 
         ST    W,LOCAL2 
         LA    D,LOCAL2+2 
         LA    A,4(A) 
         LA    NB,LOCAL3 
         DISABLE 
         CALLTSS COMND=(A),LNG=(D) 
         LTR   X,15           CHECK IF NORMALLY TERMINATED 
         BNZ   CLTSS$1        IF NORMAL THEN 
         LR    D,0              D:=RETURN INFO ADDR 
         LH    A,0(D)           A:=RETURN INFO LENGTH 
         LA    W,CLTSSBUF       MOVE RETURN INFORMATION 
         LR    WW,A               TO THE BUFFER 
         MVCL  W,D 
         ST    0,CLTSSFRE       NOW FREE THE MEMORY OF RETURN INFO 
         LA    A,CLTSSFRE       A:=ADDR OF ADDR OF RETURN INFO 
         LH    D,CLTSSBUF       D:=LENGTH OF RETURN INFO 
         FREEMAIN EC,LV=(D),A=(A) 
         ENABLE 
         LA    D,CLTSSBUF 
         TM    20(D),B'10000000' 
         BZ    CLTSS$0 
         L     A,STRBUFAD 
         MVC   0(8,A),24(D) 
         LA    A,8(A) 
         BAL   L,MKSTRING 
         RET 
CLTSS$0  TM    20(D),B'01000000' 
         BZ    CLTSS$1 
         L     A,STRBUFAD 
         MVC   0(44,A),32(D) 
         LA    A,44(A) 
         BAL   L,MKSTRING 
         RET 
CLTSS$1  LR    A,X 
         ENABLE 
         B     RETNUM 
* 
CLTSSFRE DS    A 
CLTSSBUF DS    80C 
* 
         CODEND 
* 
         AGO   .EXIT002 
* 
.TSO##02 ANOP 
.FACOM02 ANOP 
.MTS##02 ANOP
CLTSS    SUBR  1,1,PNAME='CALLTSS' 
         B     IMPLERR 
         CODEND 
.EXIT002 ANOP 
* 
* 
ALLOC    SUBR  1,1 
         L     A,LOCAL1 
         $STRING 
         LT    X,0(A)         ; X := LENG. OF STRING 
         BZ    TYPERR 
         CLI   4(A),C' '      ; CENTINEL 
         BE    TYPERR 
         LA    W,4(A)         ; W POINTS TO TOP OF STRING 
         LA    WW,0(W,X)      ; WW POINTS TO LAST OF STRING 
*                             ; DISCARD TRAILING SPACES 
ALLC$1   BCTR  WW,0 
         CLI   0(WW),C' ' 
         BE    ALLC$1 
* 
         AIF   ('&SYSTEM' EQ 'MTS').ALLC1
         MVI   ALLC#ABS,X'00' ; ABS := FALSE 
.ALLC1   ANOP
         CLI   0(W),C'''' 
         BNE   ALLC$2 
         LA    W,1(W) 
         CLI   0(WW),C'''' 
         BNE   TYPERR 
         BCTR  WW,0 
         CLR   W,WW 
         BH    TYPERR 
         AIF   ('&SYSTEM' EQ 'MTS').ALLC8
         MVI   ALLC#ABS,X'FF' 
ALLC$2   MVI   ALLC#DSP,X'80' ; 
         CLI   0(WW),C')' 
         BNE   ALLC$3 
* 
         LR    X,WW 
ALLC$21  BCTR  X,0 
         CLR   W,X 
         BH    TYPERR 
         CLI   0(X),C'(' 
         BNE   ALLC$21 
* 
         LR    D,X 
         LA    X,1(X) 
         SR    WW,X 
         BZ    TYPERR 
         C     WW,F8 
         BH    TYPERR 
         STH   WW,ALLC#MEM+4 
         BCTR  WW,0 
         EX    WW,ALLC#MVA 
         L     X,=A(UCTAB) 
         EX    WW,ALLC#TRA 
* 
         LR    WW,D 
         BCTR  WW,0 
         MVI   ALLC#DSP,X'00' 
         MVI   ALLC#MMP,X'80' 
* 
ALLC$3   LA    WW,1(WW) 
* 
         SR    WW,W 
         BZ    TYPERR 
         LR    X,WW 
         TM    ALLC#ABS,X'FF' 
         BNZ   ALLC$4 
         L     NA,UPTADDR 
         XR    D,D 
         IC    D,16+7(NA) 
         LA    X,1(D,X) 
ALLC$4   C     X,=F'44' 
         BH    TYPERR 
         STH   X,ALLC#DS+4 
         LA    X,ALLC#DS+6 
         TM    ALLC#ABS,X'FF' 
         BNZ   ALLC$5 
         BCTR  D,0 
         EX    D,ALLC#MVB 
         LA    X,1(D,X) 
         MVI   0(X),C'.' 
         LA    X,1(X) 
ALLC$5   BCTR  WW,0 
         EX    WW,ALLC#MVC 
         LH    WW,ALLC#DS+4 
         L     X,=A(UCTAB) 
         BCTR  WW,0 
         EX    WW,ALLC#TRB 
* 
         MVC   ALLC#DD+6(8),=CL8' ' 
         LA    W,8 
         STH   W,ALLC#DD+4 
         LA    1,ALLC#PTR 
         LA    NB,LOCAL2 
         DISABLE , 
         DYNALLOC , 
         ENABLE  , 
         LTR   15,15 
         BNZ   ALLC$ERR 
         L     A,STRBUFAD 
         MVC   0(8,A),ALLC#DD+6 
         LH    W,ALLC#DD+4 
         ALR   A,W 
         B     MKSTRNGR 
* 
ALLC$ERR LA    X,0(15) 
         O     X,@FIX 
         ST    X,LOCAL1 
         LH    X,ALLC#REQ+4 
         O     X,@FIX 
         ST    X,LOCAL2 
         LH    X,ALLC#REQ+6 
         O     X,@FIX 
         ST    X,LOCAL3 
         LA    NA,3*4 
         LA    NB,LOCAL4 
         B     MKLISTNR 
* 
         DS    0A 
ALLC#PTR DC    X'80',AL3(ALLC#REQ) 
* 
         DS    0A 
ALLC#REQ DC    X'14010000' 
         DC    F'0' 
         DC    A(ALLC#TXT) 
         DC    F'0' 
         DC    F'0' 
* 
ALLC#TXT DC    X'00',AL3(ALLC#DD) 
         DC    X'00',AL3(ALLC#SHR) 
ALLC#DSP DC    X'00',AL3(ALLC#DS) 
* 
ALLC#MMP DC    X'00',AL3(ALLC#MEM) 
         DS    0A 
ALLC#DS  DC    X'0002',X'0001' 
         DS    H 
         DS    44C 
* 
         DS    0A 
ALLC#MEM DC    X'0003',X'0001' 
         DS    H 
         DS    8C 
* 
         DS    0A 
ALLC#SHR DC    X'0004',X'0001' 
         DC    X'0001',X'08' 
* 
         DS    0A 
ALLC#DD  DC    X'0055',X'0001' 
         DS    H 
         DS    8C 
* 
         DS    0H 
ALLC#MVA MVC   ALLC#MEM+6(0),0(X) 
ALLC#TRA TR    ALLC#MEM+6(0),4(X) 
ALLC#MVB MVC   0(0,X),16(NA) 
ALLC#MVC MVC   0(0,X),0(W) 
ALLC#TRB TR    ALLC#DS+6(0),4(X) 
* 
ALLC#ABS DS    C 
*
         AGO   .ALLC9
.ALLC8   ANOP
*
ALLC$2   LA    WW,1(WW) 
         SR    WW,W 
         BZ    TYPERR 
         LA    0,ALLC#DS      WHERE TO PUT NAME
         LA    1,45           MAX LEN WITH TRAILING BLANK
         ICM   WW,B'1000',=C' '  
         MVCL  0,W            COPY FDNAME
         LA    NB,LOCAL2      A SAVE AREA
         DISABLE
         IF    ALLC#DS,NE,'-' THEN IT'S NOT A SCRATCH FILE
           CALL  CHKFILE,(ALLC#DS),VL SEE IF THE FILE EXISTS
           LTR   15,15
           BNZ   ALLC$ERR     NOPE, DOESN'T EXIST
         ENDIF
         LA    1,ALLC#DS      POINT TO NAME
         CALL  GETFD          GET A FDUB FOR IT
         L     A,STRBUFAD     POINT TO STRING BUFFER
         ST    0,0(0,A)       STORE FDUB POINTER
         ENABLE
         LA    A,4(0,A)       POINT PAST END OF "STRING"
         B     MKSTRNGR       RETURN IT AS A STRING
* 
ALLC$ERR LA    X,0(15) 
         ENABLE
         O     X,@FIX 
         ST    X,LOCAL1 
         SR    X,X            THE OTHER TWO NUMBERS DON'T MAKE SENSE
         O     X,@FIX           IN MTS.
         ST    X,LOCAL2 
         ST    X,LOCAL3 
         LA    NA,3*4 
         LA    NB,LOCAL4 
         B     MKLISTNR 
*
ALLC#DS  DS    CL45           PLACE FOR FDNAME
*
.ALLC9   ANOP
* 
         CODEND 
* 
ALLOCP   SUBR  1,1,PNAME='ALLOCP' 
         L     A,LOCAL1 
         $STRING 
         LT    X,0(A) 
         BZ    TYPERR 
         C     X,F8 
         BH    TYPERR 
* 
         STH   X,ALCP#DD+4 
         MVC   ALCP#DD+6(8),=CL8' '
         BCTR  X,0 
         EX    X,ALCP#MVA 
*
         AIF   ('&SYSTEM' EQ 'MTS').ALCP1
*
         LA    1,ALCP#PTR 
         LA    NB,LOCAL2 
         DISABLE , 
         DYNALLOC , 
         ENABLE , 
         LTR   15,15 
         BZ    RETT 
* 
         LH    A,ALCP#REQ+4 
         SLL   15,16 
         OR    A,15 
         C     A,=X'00040438' 
         BE    RETNIL 
         B     RETNUM0 
* 
         DS    0A 
ALCP#PTR DC    X'80',AL3(ALCP#REQ) 
* 
         DS    0A 
ALCP#REQ DC    X'14070000' 
         DC    F'0' 
         DC    A(ALCP#TXT) 
         DC    F'0' 
         DC    F'0' 
* 
ALCP#TXT DC    X'80',AL3(ALCP#DD) 
*
         AGO   .ALCP2
.ALCP1   ANOP
*
         LT    0,ALCP#DD+6
         LT    1,ALCP#DD+10
         LA    NB,LOCAL2
         DISABLE
         CALL  GDINFO2
         IF    15,Z
           USING GDDSECT,1
           L     X,GDTYPE
           FREESPAC
           DROP  1
           ENABLE
           C     X,=C'NONE'
           L     A,=X'00040000'
           BE    RETNUM0
           B     RETT
         ENDIF
         ENABLE
         LR    A,15
         SLL   A,16
         B     RETNUM0
.ALCP2   ANOP
* 
         DS    0A 
ALCP#DD  DC    X'0001',X'0001' 
         DS    H 
         DS    8C 
* 
ALCP#MVA MVC   ALCP#DD+6(0),4(A) 
* 
         CODEND 
DYNALLC  LSUBR PNAME='SYSTEM-DYNALLOC' 
*       
         AIF   ('&SYSTEM' EQ 'MTS').DYNALC1
*
         C     NA,F8 
         BL    PARAMERR 
* 
         L     A,LOCAL1 
         $FIXNUM 
         LA    W,0(A) 
         CR    W,Z 
         BNH   TYPERR 
         C     W,F8 
         BNL   TYPERR 
         STC   W,DYNA#REQ+1 
* 
         LA    NB,LOCAL1(NA) 
         LA    WW,LOCAL2 
DYNA$1   L     A,0(WW) 
         IFNOTSTR A,TYPERR 
         LA    A,4(A) 
         ST    A,0(WW) 
         LA    WW,4(WW) 
         CLR   WW,NB 
         BL    DYNA$1 
         SLR   WW,F 
         MVI   0(WW),X'80' 
         LA    W,LOCAL2 
         ST    W,DYNA#REQ+8 
         DISABLE , 
         LA    1,DYNA#PTR 
         DYNALLOC , 
         ENABLE , 
         LTR   15,15 
         BZ    RETT 
* 
         LA    X,0(15) 
         O     X,@FIX 
         ST    X,LOCAL1 
         LH    X,DYNA#REQ+4 
         O     X,@FIX 
         ST    X,LOCAL2 
         LH    X,DYNA#REQ+6 
         O     X,@FIX 
         ST    X,LOCAL3 
         LA    NA,3*4 
         LA    NB,LOCAL4 
         B     MKLISTNR 
* 
         DS    0A 
DYNA#PTR DC    X'80',AL3(DYNA#REQ) 
* 
         DS    0A 
DYNA#REQ DC    X'14',X'00',H'0' 
         DC    F'0' 
         DS    A 
         DC    F'0' 
         DC    F'0' 
* 
         AGO   .DYNALC2
.DYNALC1 ANOP
         B     IMPLERR
.DYNALC2 ANOP
*
         CODEND 
* 
INTERN   SUBR  1,2,INTERN$,SYMTAG 
         B     INTERN$1 
         L     A,LOCAL2 
         LA    NB,LOCAL3 
         BINDQ OBVECT$,A 
         L     A,LOCAL1 
         $STRING 
         MVI   SOFTFLAG,0 
         BAL   L,INTERN 
         UNDO 
         RET 
INTERN$1 L     A,LOCAL1 
         $STRING 
         MVI   SOFTFLAG,0 
         LA    NB,LOCAL2 
         B     INTRNRET 
         CODEND 
* 
INTSOFT  SUBR  1,2,PNAME='INTERN-SOFT' 
         B     INTSFT$1 
         L     A,LOCAL2 
         LA    NB,LOCAL3 
         BINDQ OBVECT$,A 
         L     A,LOCAL1 
         $STRING 
         MVI   SOFTFLAG,1 
         BAL   L,INTERN 
         UNDO  , 
         RET   , 
INTSFT$1 L     A,LOCAL1 
         $STRING 
         MVI   SOFTFLAG,1 
         LA    NB,LOCAL2 
         B     INTRNRET 
         CODEND 
* 
READMC   SUBR  2,4,PNAME='READMACRO' 
         B     READMC$1 
         B     READMC$2 
         B     READMC$3 
READMC$1 GETVALUE READTAB$ 
         ST    A,LOCAL3 
READMC$2 GETVALUE MACTAB$ 
         ST    A,LOCAL4 
READMC$3 L     A,LOCAL1 
         $CHARACT 
         SLDL  D,32+2 
         L     A,LOCAL3 
         $VECTOR 
         LA    W,256*4 
         CL    W,0(A) 
         BNE   TYPERR 
         L     WW,=X'100082C0' 
         ST    WW,4(D,A) 
         L     A,LOCAL4 
         $VECTOR 
         CL    W,0(A) 
         BNE   TYPERR 
         L     WW,LOCAL2 
         ST    WW,4(D,A) 
         CODEND RETNIL 
* 
SNGLCH   SUBR  1,2,PNAME='SINGLE-CHARACTER' 
         B     SNGLC$1 
         B     SNGLC$2 
SNGLC$1  GETVALUE READTAB$ 
         ST    A,LOCAL2 
SNGLC$2  L     A,LOCAL1 
         $CHARACT 
         SLDL  D,32+2 
         L     A,LOCAL2 
         $VECTOR 
         LA    W,256*4 
         C     W,0(A) 
         BNE   TYPERR 
         L     WW,=X'1000C0C0' 
         ST    WW,4(D,A) 
         CODEND RETNIL 
* 
         AIF   ('&SYSTEM' EQ 'MTS').FLSTRM3
*
FLSTRM   SUBR  1,2,PNAME='FILE-STREAM' 
         ST    Z,LOCAL2       DUMMY ZERO FOR OPTIONAL "MEMBER" ARG 
*
         AGO   .FLSTRM4
.FLSTRM3 ANOP
*
FLSTRM   SUBR  1,1,PNAME='FILE-STREAM' 
*
.FLSTRM4 ANOP
*
         L     A,LOCAL1       A:=FILE NAME STRING 
         $STRING ,            CHECK ITS TYPE 
         LT    D,0(A)         NAME LENGTH SHOULD RESIDE BETWEEN 
         BZ    TYPERR           ONE AND 
         C     D,F44            44 
         BH    TYPERR 
*
         AIF   ('&SYSTEM' EQ 'MTS').FLSTRM1
*
         STH   D,FLS$DSN+4    SET FILE NAME LENGTH IN TEXT UNIT 
         BCTR  D,0 
         EX    D,FLS$MVC1     SET FILE NAME STRING IN TEXT UNIT 
         LT    A,LOCAL2       A:=MEMBER NAME 
         BZ    FLS$1          IF NOT SUPPLIED, SKIP 
         $STRING ,            CHECK ITS TYPE 
         LT    D,0(A)         IF MEMBER NAME IS NULL STRING 
         BZ    FLS$1            THEN NO MEMBER SPECIFICATION ASSUMED 
         C     D,F8           MEM NAME SHOULDN'T BE LONGER THAN 8 CHARS 
         BH    TYPERR 
         STH   D,FLS$MEM+4    SET MEM NAME LENGTH IN TEXT UNIT 
         BCTR  D,0 
         EX    D,FLS$MVC2     SET MEM NAME STRING IN TEXT UNIT 
         LA    D,FLSTBMEM     USE TEXT BLOCK WITH MEMBER NAME 
         B     FLS$2 
FLS$1    LA    D,FLSTBSEQ     USE TEXT BLOCK WITHOUT MEMBER NAME 
FLS$2    ST    D,FLS$RB+8     STORE TEXT BLOCK ADDR 
         LA    W,8            SET LENGTH OF DDNAME TO BE RETURNED 
         STH   W,FLS$DDN+4      TO ITS MAXIMUM (8) 
         LA    1,FLS$RBP 
         LA    NB,LOCAL3 
         DISABLE , 
         DYNALLOC , 
         ENABLE , 
         LTR   15,15          TEST IF NORMALLY ALLOCATED 
         BNZ   FLS$ERR 
         L     A,STRBUFAD     ALLOCATE DDNAME STRING 
         MVC   0(8,A),FLS$DDN+6 
         LH    W,FLS$DDN+4      W:=DDNAME LENGTH 
         ALR   A,W              A:=LAST CHAR POS + 1 
         BAL   L,MKSTRING     ALLOCATE DDNAME STRING 
         B     MKSTRMR        ALLOCATE STREAM WITH DDNAME AND RETURN
FLS$ERR  LH    A,FLS$RB+4     IF ALLOCATION WAS UNSUCCESSFUL 
         B     RETNUM0          RETURN ERROR CODE AS FIXNUM 
* 
         DS    0A 
FLS$RBP  DC    X'80',AL3(FLS$RB) 
FLS$RB   DC    X'14010000'    REQUEST BLOCK - DYNAMIC ALLOCATION 
         DS    A 
         DS    A 
         DC    F'0' 
         DC    F'0' 
FLSTBSEQ DC    X'00',AL3(FLS$DSN) TEXT BLOCK FOR PS FILE 
         DC    X'00',AL3(FLS$SHR) 
         DC    X'80',AL3(FLS$DDN) 
FLSTBMEM DC    X'00',AL3(FLS$DSN) TEXT BLOCK FOR PO MEMBER 
         DC    X'00',AL3(FLS$MEM) 
         DC    X'00',AL3(FLS$SHR) 
         DC    X'80',AL3(FLS$DDN) 
FLS$DSN  DC    X'0002',H'1'   TEXT UNIT FOR DATA SET NAME 
         DS    H 
         DS    44C 
FLS$MEM  DC    X'0003',H'1'   TEXT UNIT FOR MEMBER NAME 
         DS    H 
         DS    8C 
FLS$SHR  DC    X'0004',H'1',H'1',X'08' 
         DS    0H 
FLS$DDN  DC    X'0055',H'1'   TEXT UNIT TO WHICH DDNAME IS RETURNED 
         DS    H 
         DS    8C 
FLS$MVC1 MVC   FLS$DSN+6(0),4(A) 
FLS$MVC2 MVC   FLS$MEM+6(0),4(A) 
*      
         AGO   .FLSTRM2
.FLSTRM1 ANOP
*
         MVI   FLS$DSN,C' '   BLANK THE FDNAME FIELD
         MVC   FLS$DSN+1(44),FLS$DSN
         BCTR  D,0 
         EX    D,FLS$MVC1     SET FILE NAME STRING IN TEXT UNIT 
         LA    1,FLS$DSN 
         LA    NB,LOCAL3 
         DISABLE , 
         CALL  GETFD
         LR    W,0            SAVE FDUB POINTER
         ENABLE , 
         LTR   15,15          TEST IF NORMALLY ALLOCATED 
         BNZ   FLS$ERR 
         L     A,STRBUFAD     ALLOCATE FDUB PTR STRING 
         ST    W,0(A)       
         LA    W,4              W:=FDUB PTR LENGTH 
         ALR   A,W              A:=LAST CHAR POS + 1 
         BAL   L,MKSTRING     ALLOCATE DDNAME STRING 
         B     MKSTRMR        ALLOCATE STREAM WITH DDNAME AND RETURN
FLS$ERR  LR    A,15           IF ALLOCATION WAS UNSUCCESSFUL 
         B     RETNUM0          RETURN ERROR CODE AS FIXNUM 
*
FLS$DSN  DS    CL45
* 
FLS$MVC1 MVC   FLS$DSN(0),4(A) MOVE THE FDNAME INTO FLS$DSN
*
.FLSTRM2 ANOP
*
         CODEND 
* 
FREE     SUBR  1,1 
         L     A,LOCAL1       A:=STREAM TO BE FREED 
         $STREAM ,            CHECK ITS TYPE 
         USING STREAM,A 
         CLI   MODE+3,0       IF STREAM IS OPEN NOW, 
         BE    FREE$1 
         LA    NB,LOCAL2        THEN CLOSE IT BEFORE DISALLOCATION 
         LR    D,A 
         L     A,CLOSE 
         BAL   L,FUNCALLD 
         L     A,LOCAL1 
*
         AIF   ('&SYSTEM' EQ 'MTS').FREE$1
*
FREE$1   MVC   FREE$DDN+6(8),DCBDDNAM  SET TEXT BLOCK FOR DDNAME 
         LA    1,FREE$RBP 
         LA    NB,LOCAL2 
         DISABLE , 
         DYNALLOC , 
         ENABLE , 
         LTR   15,15          IF NORMALLY DISALLOCATED 
         BZ    RETNIL           RETURN NIL 
         LH    A,FREE$RB+4    OTHERWISE, RETURN ERROR CODE 
         B     RETNUM0          AS A FIXED NUMBER 
         DS    0A 
FREE$RBP DC    X'80',AL3(FREE$RB)  REQUEST BLOCK POINTER FOR DISALLOC 
FREE$RB  DC    X'14020000'         REQUEST BLOCK FOR DISALLOCATION 
         DS    A 
         DC    A(FREE$TB) 
         DC    F'0' 
         DC    F'0' 
FREE$TB  DC    X'80',AL3(FREE$DDN) TEXT BLOCK 
FREE$DDN DC    X'0001',H'1',H'8',8C' ' TEXT UNIT FOR DDNAME 
*
         AGO   .FREE$2
.FREE$1  ANOP
*
FREE$1   L     0,IOLDN        GET POSSIBLE FDUB POINTER
         LA    NB,LOCAL2      SAVE AREA
         DISABLE
         CALL  FREEFD         FREE THE FDUB, IF ANY
         ENABLE
         B     RETNIL
*
.FREE$2  ANOP
*
         DROP  A 
         CODEND 
* 
SPECHAR  SYM   ,PRCHARS,STRNGTAG,PNAME='SPECIAL-CHARACTERS' 
         TITLE 'HASHING FUNCTIONS' 
*********************************************************************** 
* 
*   HASHING FUNCTIONS 
* 
*********************************************************************** 
HASH     SUBR  1,1 
         L     A,LOCAL1 
         LA    NB,LOCAL2 
         BAL   L,HASH$1 
         LR    A,NA 
         B     RETNUM 
* 
HASH$1   IFLIST A,HASH$3 
         LA    NA,0(A) 
         IFFIX A,0(L) 
         IFNOTSY A,HASH$2 
         USING SYMBOL,A 
         L     A,PNAME 
         DROP  A 
HASH$2   CLM   A,B'1000',@STRING 
         BE    HASHSTR 
         IFFLO A,HASHSTR 
         LR    NA,Z 
         BR    L 
HASH$3   LM    D,A,0(A) 
         LA    L,0(L) 
         PUSHW L 
         PUSHW D 
         BAL   L,HASH$1 
         POPW  A 
         PUSHW NA 
         BAL   L,HASH$1 
         POPW  W              HASH VALUE OF CAR PART 
         ALR   NA,NA 
         LA    NA,0(NA,W) 
         POPW  L 
         BR    L 
         CODEND 
         TITLE 'ERROR HANDLING AND DEBUGGING FUNCTIONS' 
*********************************************************************** 
* 
* ERROR HANDLING AND DEBUGGING 
* 
UBVERR   SUBR  1,2,UBVERR$,SYMTAG,PNAME='ERR:UNBOUND-VARIABLE' 
         ST    Z,LOCAL2 
         L     X,UBVM 
         B     STDERR 
UBVM     STRNGCON UBVMSG 
         CODEND 
* 
TYPERR   SUBR  1,2,TYPERR$,SYMTAG,PNAME='ERR:ARGUMENT-TYPE' 
         ST    Z,LOCAL2 
         L     X,TYPM 
         B     STDERR 
TYPM     STRNGCON TYPEMSG 
         CODEND 
* 
UDFERR   SUBR  1,2,UDFERR$,SYMTAG,PNAME='ERR:UNDEFINED-FUNCTION' 
         ST    Z,LOCAL2 
         L     X,UDFM 
         B     STDERR 
UDFM     STRNGCON UDFMSG 
         CODEND 
* 
IMPLERR  SUBR  1,2,IMPLERR$,SYMTAG,                                    *
               PNAME='ERR:IMPLEMENTATION-RESTRICTION' 
         ST    Z,LOCAL2 
         L     X,IMPLM 
         B     STDERR 
IMPLM    STRNGCON IMPLMSG 
         CODEND 
* 
ESTAERR  SUBR  1,2,ESTAERR$,SYMTAG,PNAME='ERR:ABEND-EXIT' 
*
         AIF   ('&SYSTEM' EQ 'MTS').ESTERR1
*
         ST    Z,LOCAL2 
* 
         L     A,LOCAL1       ; CONVERT CODE TO HEXADECIMAL 
         ST    A,EST#PBUF 
         UNPK  EST#UPBF(7),EST#PBUF(4) 
         XR    W,W 
         IC    W,EST#UPBF+6 
         SRL   W,4 
         STC   W,EST#UPBF+7 
         MVZ   EST#UPBF(8),EST#ZERO 
         TR    EST#UPBF(8),EST#TAB 
         L     W,EST#SC3 
         MVC   4(3,W),EST#UPBF+2 
         L     W,EST#SC5 
         MVC   4(3,W),EST#UPBF+5 
* 
         LA    NB,LOCAL3 
         L     A,TERMOUT 
         BINDQ OUTSTRM$,A 
* 
         BAL   L,TERPRI 
* 
         L     A,EST#SC1 
         LR    W,Z            ; PRINT MESSAGE 1 
         BAL   L,PRINTENT     ;     WITHOUT SLASHIFICATION 
         BAL   L,TERPRI 
* 
         L     A,EST#SC2 
         LR    W,Z 
         BAL   L,PRINTENT 
         L     A,EST#SC3 
         LR    W,Z 
         BAL   L,PRINTENT 
         L     A,EST#SC4 
         LR    W,Z 
         BAL   L,PRINTENT 
         L     A,EST#SC5 
         LR    W,Z 
         BAL   L,PRINTENT 
         BAL   L,TERPRI 
* 
         L     A,EST#SC6 
         LR    W,Z 
         BAL   L,PRINTENT 
         BAL   L,TERPRI 
* 
         UNDO  , 
         ST    N,LOCAL1 
         L     X,ESTAEM 
         B     STDERR 
* 
EST#PBUF DC    F'0' 
EST#UPBF DC    CL8' ' 
EST#ZERO DC    XL8'00' 
EST#TAB  DC    C'0123456789ABCDEF' 
* 
EST#SC1  STRNGCON EST#MSG1 
EST#SC2  STRNGCON EST#MSG2 
EST#SC3  STRNGCON EST#MSG3 
EST#SC4  STRNGCON EST#MSG4 
EST#SC5  STRNGCON EST#MSG5 
EST#SC6 STRNGCON EST#MSG6 
* 
EST#MSG1 STRING ' !!!!! TASK ABNORMAL EXIT !!!!! ' 
EST#MSG2 STRING ' ABEND/TERMINATION CODE IS S' 
EST#MSG3 STRING 'XXX' 
EST#MSG4 STRING ' / U' 
EST#MSG5 STRING 'XXX' 
EST#MSG6 STRING ' UTILISP SYSTEM RECOVERED' 
* 
ESTAEM   STRNGCON ESTAEMSG 
*
         AGO   .ESTERR2
.ESTERR1 ANOP
*
         B     IMPLERR
.ESTERR2 ANOP
*
         CODEND 
* 
FNERR    SUBR  1,2,FNERR$,SYMTAG,PNAME='ERR:FUNCTION' 
         ST    Z,LOCAL2 
         L     X,FNM 
         B     STDERR 
FNM      STRNGCON FNMSG 
         CODEND 
* 
VARERR   SUBR  1,2,VARERR$,SYMTAG,PNAME='ERR:VARIABLE' 
         ST    Z,LOCAL2 
         L     X,VARM 
         B     STDERR 
VARM     STRNGCON VARMSG 
         CODEND 
* 
PARERR   SUBR  1,2,PARERR$,SYMTAG,PNAME='ERR:NUMBER-OF-ARGUMENTS' 
         ST    Z,LOCAL2 
         L     X,PARM 
         B     STDERR 
PARM     STRNGCON PARMSG 
         CODEND 
* 
INDERR   SUBR  1,2,INDERR$,SYMTAG,PNAME='ERR:INDEX' 
         ST    Z,LOCAL2 
         L     X,INDM 
         B     STDERR 
INDM     STRNGCON INDMSG 
         CODEND 
* 
READERR  SUBR  1,2,READERR$,SYMTAG,PNAME='ERR:READ' 
         ST    Z,LOCAL2 
         L     X,READM 
         B     STDERR 
READM    STRNGCON READMSG 
         CODEND 
* 
IOERR    SUBR  1,2,IOERR$,SYMTAG,PNAME='ERR:IO' 
         ST    Z,LOCAL2 
         L     X,IOM 
         B     STDERR 
IOM      STRNGCON IOMSG 
         CODEND 
* 
OPENERR  SUBR  1,2,OPENERR$,SYMTAG,PNAME='ERR:OPEN-CLOSE' 
         ST    Z,LOCAL2 
         L     X,OPENM 
         B     STDERR 
OPENM    STRNGCON OPENMSG 
         CODEND 
* 
EOFERR   SUBR  1,2,EOFERR$,SYMTAG,PNAME='ERR:END-OF-FILE' 
         ST    Z,LOCAL2 
         L     X,EOFM 
         B     STDERR 
EOFM     STRNGCON EOFMSG 
         CODEND 
* 
RETERR   SUBR  1,2,RETERR$,SYMTAG,PNAME='ERR:RETURN' 
         ST    Z,LOCAL2 
         L     X,RETM 
         B     STDERR 
RETM     STRNGCON RETMSG 
         CODEND 
* 
GOERR    SUBR  1,2,GOERR$,SYMTAG,PNAME='ERR:GO' 
         ST    Z,LOCAL2 
         L     X,GOM 
         B     STDERR 
GOM      STRNGCON GOMSG 
         CODEND 
* 
CTCHERR  SUBR  1,2,CTCHERR$,SYMTAG,PNAME='ERR:CATCH' 
         ST    Z,LOCAL2 
         L     X,CTCHM 
         B     STDERR 
CTCHM    STRNGCON CTCHMSG 
         CODEND 
* 
FPOFERR  SUBR  1,2,FPOFERR$,SYMTAG,PNAME='ERR:FLOATING-OVERFLOW' 
         ST    Z,LOCAL2 
         L     X,FPOFM 
         B     STDERR 
FPOFM    STRNGCON FPOFMSG 
         CODEND 
* 
DIVERR   SUBR  1,2,DIVERR$,SYMTAG,PNAME='ERR:ZERO-DIVISION' 
         ST    Z,LOCAL2 
         L     X,DIVM 
         B     STDERR 
DIVM     STRNGCON DIVMSG 
         CODEND 
* 
BUFFERR  SUBR  1,2,BUFFERR$,SYMTAG,PNAME='ERR:BUFFER-OVERFLOW' 
         ST    Z,LOCAL2 
         L     X,BUFFMSG 
         B     STDERR 
BUFFM    STRNGCON BUFFMSG 
         CODEND 
* 
UBVMSG   STRING '@@@ UNBOUND VARIABLE' 
TYPEMSG  STRING '@@@ ILLEGAL ARGUMENT TYPE' 
UDFMSG   STRING '@@@ UNDEFINED FUNCTION' 
IMPLMSG  STRING '@@@ IMPLEMENTATION RESTRICTION' 
         AIF   ('&SYSTEM' EQ 'MTS').ESTMSG
ESTAEMSG STRING '@@@ ABEND EXIT' 
.ESTMSG  ANOP
FNMSG    STRING '@@@ ILLEGAL FUNCTION' 
VARMSG   STRING '@@@ ILLEGAL LAMBDA/PROG VARIABLE' 
PARMSG   STRING '@@@ MISMATCHED NUMBER OF ARGUMENTS' 
INDMSG   STRING '@@@ STRING OR VECTOR INDEX OUT OF RANGE' 
READMSG  STRING '@@@ ILLEGAL OBJECT READ' 
IOMSG    STRING '@@@ ERROR IN INPUT/OUTPUT' 
OPENMSG  STRING '@@@ ERROR IN OPEN/CLOSE' 
EOFMSG   STRING '@@@ END OF FILE REACHED WHILE READING' 
RETMSG   STRING '@@@ CATCHING STRUCTURE NOT FOUND' 
GOMSG    STRING '@@@ GO LABEL NOT FOUND' 
CTCHMSG  STRING '@@@ TAG NOT CAUGHT' 
FPOFMSG  STRING '@@@ FLOATING-POINT OVERFLOW' 
DIVMSG   STRING '@@@ DIVISION BY ZERO' 
BUFFMSG  STRING '@@@ STRING BUFFER OVERFLOW' 
* 
ATNHNDL  SYM   ,BREAK$,SYMTAG,PNAME='ATTENTION-HANDLER' 
* 
* 
BCKTRC   SUBR  0,1,PNAME='BACKTRACE' 
         B     BCKTRC$1 
         L     A,LOCAL1 
         $POSINX 
         LA    NA,0(A) 
         B     BCKTRC$2 
BCKTRC$1 LR    NA,Z 
BCKTRC$2 LA    NB,LOCAL1 
         LR    X,SB 
         DROP  SB 
         USING STACK,X 
BCKTRC$3 CL    X,STACKBTM 
         BNH   BCKTRC$5 
         L     W,OLDCB 
         IFNOTCOD W,BCKTRC$4 
         USING CODE,W 
         L     W,FUNCNAME 
         DROP  W 
BCKTRC$4 PUSHW W 
         L     X,OLDSB 
         BCT   NA,BCKTRC$3 
         DROP  X 
         USING STACK,SB 
BCKTRC$5 LA    X,LOCAL1 
         LR    A,N 
         CLR   NB,X 
         BER   E 
BCKTRC$6 POPW  D 
         BAL   L,XCONS 
         CLR   NB,X 
         BNE   BCKTRC$6 
         CODEND RET 
* 
OLDVAL   SUBR  0,1,PNAME='OLDVALUE' 
         B     OLDVAL$1 
         L     A,LOCAL1 
         $POSFIX 
         LA    NA,0(A) 
         B     OLDVAL$2 
OLDVAL$1 LR    NA,Z 
OLDVAL$2 LA    NB,LOCAL1 
         LR    X,SB 
OLDVAL$3 SLR   X,F 
         CL    X,STACKBTM 
         BNH   OLDVAL$6 
         CLI   0(X),BINDTAG 
         BNE   OLDVAL$3 
         L     A,0(X) 
         LA    A,0(A) 
         O     A,@SYMBOL 
         SLR   X,F 
         CLI   0(X),UBVTAG 
         BE    OLDVAL$4 
         L     D,0(X) 
         B     OLDVAL$5 
OLDVAL$4 L     D,OV$UBV 
OLDVAL$5 BAL   L,CONS 
         PUSHW A 
         BCT   NA,OLDVAL$3 
OLDVAL$6 LR    A,N 
         LA    X,LOCAL1 
         CLR   NB,X 
         BER   E 
OLDVAL$7 POPW  D 
         BAL   L,XCONS 
         CLR   NB,X 
         BNE   OLDVAL$7 
         RET 
OV$UBV   SYMCON UBVSYM$ 
         CODEND 
* 
UBVSYM   SYM    PNAME='*UBV*' 
* 
ADDRSS   SUBR  1,1,PNAME='ADDRESS' 
         L     A,LOCAL1 
         B     RETNUM0 
         CODEND 
* 
*        (PEEK ADDRESS LENGTH-IN-BYTES) MAKES STRING OF THAT MANY
*        BYTES AT THAT ADDRESS.
*
PEEK     SUBR  2,2 
         L     W,LOCAL1 
         L     A,LOCAL2 
         CL    A,MINFIX 
         BNL   TYPERR 
         LA    A,0(A) 
         LR    WW,A 
         LR    NA,A 
         L     D,STRBUFAD 
         LA    NB,LOCAL3 
         MVCL  D,W 
         AIF   ('&SYSTEM' NE 'MTS').NOBPI
         BPI   OPND,RETNIL    RETURN NIL IF ADDRESS IS NOT VALID
.NOBPI   ANOP
         LR    A,D 
         B     MKSTRNGR 
         CODEND 
         TITLE 'MEMORY MANAGEMENT FUNCTIONS' 
*********************************************************************** 
* 
*        MEMORY MANAGEMENT FUNCTIONS 
* 
HEAPSIZ  SUBR  0,1,PNAME='HEAP-SIZE' 
         B     HEAPSZ$1 
         L     A,LOCAL1 
         $POSFIX 
         L     W,CURHEAP 
         LA    WW,0(A,A) 
         ALR   WW,WW 
         LA    W,0(WW,W) 
         CL    W,CURLIM 
         BH    TYPERR 
         CL    W,HEAPTOP 
         BL    TYPERR 
         ST    W,HEAPLIM 
         RET 
* 
HEAPSZ$1 L     A,FIXLIM 
         SLR   A,SL 
         SL    A,F4096 
         SRL   A,2 
         O     A,ZERO 
         LA    NB,LOCAL1 
         LR    D,N 
         BAL   L,CONS 
         L     D,HEAPLIM 
         SL    D,CURHEAP 
         SRA   D,2 
         O     D,ZERO 
         BAL   L,XCONS 
         CODEND RET 
* 
MINSIZE  SUBR  0,1,PNAME='MINIMUM-HEAP-SIZE' 
         B     MINSIZ$1 
         L     A,LOCAL1 
         $POSFIX 
         LA    D,0(A) 
         SLA   D,2 
         ST    D,MINSIZEA 
         RET 
MINSIZ$1 L     A,MINSIZEA 
         SRA   A,2 
         CODEND RETNUM 
* 
MAXSIZE  SUBR  0,0,PNAME='MAXIMUM-HEAP-SIZE' 
         L     A,CURLIM 
         SL    A,CURHEAP 
         SRA   A,2 
         CODEND RETNUM 
* 
HEAPUSE  SUBR  0,0,PNAME='HEAP-USED' 
         L     D,FIXTOP 
         SLR   D,SL 
         SL    D,F4096 
         SRA   D,2 
         O     D,ZERO 
         LR    A,N 
         LA    NB,LOCAL1 
         BAL   L,XCONS 
         L     D,HEAPTOP 
         SL    D,CURHEAP 
         AL    D,CUMHEAP 
         SRA   D,2 
         O     D,ZERO 
         BAL   L,XCONS 
         L     D,HEAPTOP 
         SL    D,CURHEAP 
         SL    D,F8 
         SRA   D,2 
         O     D,ZERO 
         B     XCONSRET 
         CODEND 
* 
STCKUSD  SUBR  0,0,PNAME='STACK-USED' 
         LR    A,SB 
         SL    A,STACKBTM 
         SRA   A,2 
         CODEND RETNUM 
* 
STCKSIZ  SUBR  0,0,PNAME='STACK-SIZE' 
         LR    A,SL 
         SL    A,STACKBTM 
         SRA   A,2 
         CODEND RETNUM 
* 
GC       SUBR  0,0 
         LA    NB,LOCAL1 
         FUNCENT , 
         LA    NB,LOCAL1 
         BAL   L,GC 
         LR    NB,SB 
         LM    CB,L,0(SB) 
         CODEND RETNIL 
* 
GCTIME   SUBR  0,0 
         LM    D,A,GCTIME 
         D     D,=A(4096*1000) 
         B     RETNUM0 
         CODEND 
* 
GCCOUNT  SUBR  0,0 
         L     A,GCCOUNT 
         B     RETNUM0 
         CODEND 
         TITLE 'MISCELLANEOUS FUNCTIONS' 
*********************************************************************** 
* 
*     MISCELLANEOUS FUNCTIONS 
* 
TIME     SUBR  0,1 
         B     TIME$0 
         LA    NB,LOCAL2 
         DISABLE 
         AIF   ('&SYSTEM' EQ 'MTS').TIME1A
         TTIMER ,MIC,TIMETEMP 
         AGO   .TIME2
.TIME1A  ANOP
         CALL  TIME,(=F'1',=F'0',TIMETEMP),VL
.TIME2   ANOP
         ENABLE 
         L     A,LOCAL1 
         BAL   L,EVAL 
         DISABLE 
         AIF   ('&SYSTEM' EQ 'MTS').TIME3
         TTIMER ,MIC,TIMETMP2 
         LM    D,A,TIMETEMP 
         S     D,TIMETMP2 
         SL    A,TIMETMP2+4 
         BO    TIME$1 
         BCTR  D,0 
TIME$1   D     D,=A(1000*4096) 
         AGO   .TIME4
.TIME3   ANOP
         CALL  TIME,(=F'1',=F'0',TIMETMP2),VL
         L     A,TIMETMP2
         S     A,TIMETEMP
.TIME4   ANOP
         ENABLE
         B     RETNUM0 
TIME$0   LA    NB,LOCAL1 
         DISABLE 
         AIF   ('&SYSTEM' EQ 'MTS').TIME5
         TTIMER ,MIC,TIMETEMP 
         LM    D,A,TIMETEMP 
         D     D,=A(1000*4096) 
         LR    D,A 
         L     A,=F'10000000' 
         SR    A,D 
         AGO   .TIME6
.TIME5   ANOP
         CALL  TIME,(=F'1',=F'0',TIMETEMP),VL
         L     A,TIMETEMP
.TIME6   ANOP
         ENABLE 
         B     RETNUM0 
TIMETEMP DS    2A 
TIMETMP2 DS    2A 
         CODEND 
* 
QUIT     SUBR  0,1 
         ST    Z,LOCAL1 
         L     A,LOCAL1 
         $FIXNUM 
         LA    A,0(A) 
QUIT$1   ST    A,LOCAL1 
         LA    NB,LOCAL3 
         GETVALUE OPNFLS$ 
         IFATOM A,QUIT$3 
QUIT$2   LM    NA,D,0(A) 
         ST    NA,LOCAL2 
         L     A,CLOSE 
         BAL   L,FUNCALLD 
         L     A,LOCAL2 
         IFLIST A,QUIT$2 
QUIT$3   DS    0H
         AIF   ('&SYSTEM' EQ 'MTS').QUIT1
         STAX 
         L     15,LOCAL1 
         AGO   .QUIT2
.QUIT1   ANOP
         L     2,LOCAL1       GET RC WHILE IT'S STILL THERE
         L     1,=A(INITTEMP) FREE THE SPACE WE GOT
         L     1,0(0,1)
         FREESPAC ,
         LR    15,2           MOVE RC
.QUIT2   ANOP
         L     13,=A(SAVEAREA+4) 
         L     13,0(13) 
         RETURN (14,12),RC=(15) 
         CODEND 
* 
ABEND    SUBR  0,1 
         AIF   ('&SYSTEM' EQ 'MTS').ABEND1
*
         B     ABEND$0 
         L     A,LOCAL1 
         $POSFIX 
         LA    A,0(A) 
         B     ABEND$1 
ABEND$0  LA    A,4095 
ABEND$1  ESTAE 0 
         ABEND (A) 
*
         AGO   .ABEND2
.ABEND1  ANOP
         NOP   0              FOR NO PARAMETERS
         ERROR
         B     RETNIL
.ABEND2  ANOP
*
         CODEND 
* 
BREAK    SUBR  0,1,BREAK$,SYMTAG 
         ST    Z,LOCAL1       PUSH ZERO FOR OPTIONAL 1ST PARM. 
         LA    NB,LOCAL2      SET STACK TOP 
         L     A,TERMIN       FOR TERMINAL INPUT STREAM 
         USING STREAM,A         IGNORE THE REST OF THE CHARACTERS 
         ST    Z,RECTOP         ON THE CURRENT INPUT LINE. 
         ST    Z,RECEND 
         ST    Z,CURPOS 
         DROP  A 
         BINDQ INSTRM$,A      BIND STANDARD-INPUT WITH TERMINAL-INPUT 
         L     A,TERMOUT      BIND STANDARD-OUTPUT 
         BINDQ OUTSTRM$,A       WITH TERMINAL-OUTPUT 
         L     A,INTERNCD     BIND INTERN WITH ITSELF 
         BINDQ INTERN$,A 
         L     A,BRKPRMPT 
         C     Z,LOCAL1       IF 1ST PARAM IS GIVEN 
         BE    BREAK$0 
         L     A,LOCAL1         THEN IT MUST BE A PROMPT STRING. 
         $STRING 
BREAK$0  BINDQ PROMPT$,A      BIND GIVEN (OR DEFAULT) PROMPTER 
         L     A,DFLTRDTB     BIND READTABLE 
         BINDQ READTAB$,A       WITH DEFAULT ONE 
         L     A,DFLTMCTB     BIND MACROTABLE 
         BINDQ MACTAB$,A        WITH DEFAULT ONE 
BREAK$1  L     A,READ         READ ONE S-EXPR 
         BAL   L,FUNCALL0 
         BAL   L,EVAL         EVALUATE 
         L     D,QUESTION     SET THE RESULT TO THE SYMBOL "?" 
         ST    A,0(D) 
         LA    W,1            PRINT THE RESULT 
         BAL   L,PRINTENT       WITH SLASHIFICATION 
         BAL   L,TERPRI       TERMINATE THE LINE 
         B     BREAK$1        AND LOOP. 
BRKPRMPT STRNGCON ATMARK      DEFAULT PROMPTING CHAR "@" 
         CODEND 
* 
TOPLEV   SUBR  0,0,UTILISP$,SYMTAG,PNAME='TOPLEVEL' 
         L     SB,STACKBTM 
         BAL   L,UNDO 
         B     TOPLOOP 
         CODEND 
* 
UTILISP  SUBR  0,0 
         LA    NB,LOCAL1 
         L     A,TERMIN 
         BINDQ INSTRM$,A 
         L     A,TERMOUT 
         BINDQ OUTSTRM$,A 
         L     A,TOPPRMPT 
         BINDQ PROMPT$,A 
TOPLEV$1 L     A,READ 
         BAL   L,FUNCALL0 
         BAL   L,EVAL 
         L     D,QUESTION 
         ST    A,0(D) 
         LA    W,0 
         BAL   L,PRINTENT 
         BAL   L,TERPRI 
         B     TOPLEV$1 
TOPPRMPT STRNGCON KET 
         CODEND 
* 
ATMARK   STRING '@' 
KET      STRING '>' 
* 
ATOMLEN  SUBR  1,1,PNAME='ATOMLENGTH' 
         L     A,LOCAL1 
         IFLIST A,TYPERR 
         IFSY  A,SYMLEN 
         LA    W,2 
         CLM   A,B'1000',@STRING 
         BE    STRLEN 
         CLM   A,B'1000',@VECTOR 
         BE    FIXLEN 
         CLM   A,B'1000',@REFER 
         BE    FIXLEN 
         CLM   A,B'1000',@STREAM 
         BE    FIXLEN 
         CLM   A,B'1000',@CODE 
         BE    CODELEN 
         IFNOTFIX A,FLOLEN 
         LR    W,Z 
FIXLEN   SLL   A,8 
         SRA   A,8 
         BNM   FIXLEN1 
         LA    W,1(W) 
         LPR   A,A 
FIXLEN1  LR    D,Z 
         D     D,F10 
         LA    W,1(W) 
         LTR   A,A 
         BNZ   FIXLEN1 
         LR    A,W 
         B     RETNUM 
* 
FLOLEN   GETVALUE DIGITS$ 
         LA    A,7(A) 
         B     RETNUM 
* 
STRLEN   LR    D,A 
         GETVALUE READTAB$ 
         $VECTOR 
         LA    WW,256*4 
         C     WW,0(A) 
         BNE   TYPERR 
         LR    NA,A 
         L     A,0(D)         A:=STRING LENGTH 
         LA    W,2(A)         W:=LENGTH OF STRING + 2 (FOR "") 
         LTR   A,A            IF NO CHAR IN THE STRING 
         BZ    STRLEN3          THEN ITS THE END 
STRLEN1  LR    X,Z 
         IC    X,3(A,D) 
         SLL   X,2 
         ALR   X,NA 
         TM    6(X),STRQ 
         BZ    STRLEN2 
         LA    W,1(W) 
STRLEN2  BCT   A,STRLEN1 
STRLEN3  LR    A,W            LENGTH ON A REG 
         B     RETNUM 
* 
         USING CODE,A 
CODELEN  L     A,FUNCNAME 
         DROP  A 
         B     SYMLEN0 
* 
SYMLEN   LR    W,Z 
         USING SYMBOL,A 
SYMLEN0  L     D,PNAME 
         DROP  A 
         GETVALUE READTAB$ 
         $VECTOR 
         LA    WW,256*4 
         C     WW,0(A) 
         BNE   TYPERR 
         LR    NA,A 
         L     A,0(D) 
         AR    W,A 
         LR    X,Z 
         IC    X,4(D) 
         SLL   X,2 
         ALR   X,NA 
         TM    7(X),SLASHTOP 
         BZ    SYMLEN3 
         B     SYMLEN2 
SYMLEN1  LR    X,Z 
         IC    X,4(A,D) 
         SLL   X,2 
         ALR   X,NA 
         TM    7(X),SLASH 
         BZ    SYMLEN3 
SYMLEN2  LA    W,1(W) 
SYMLEN3  BCT   A,SYMLEN1 
         LR    A,W 
         CODEND RETNUM 
* 
VERSION  SYM   ,VERSION,STRNGTAG 
VERSION  STRING '&VERSION.(&SYSDATE.)' 
* 
SYSNAME  SYM   ,SYSNAME,STRNGTAG,PNAME='SYSTEM-NAME' 
SYSNAME  STRING '&SYSTEM' 
* 
UPT      SUBR  0,0,PNAME='UPT-ADDRESS' 
         L     A,UPTADDR 
         B     RETNUM0 
         CODEND 
* 
ECT      SUBR  0,0,PNAME='ECT-ADDRESS' 
         L     A,ECTADDR 
         B     RETNUM0 
         CODEND 
* 
PSCB     SUBR  0,0,PNAME='PSCB-ADDRESS' 
         L     A,PSCBADDR 
         B     RETNUM0 
         CODEND 
* 
* 
* 
DATE     SUBR  0,0,PNAME='DATE-TIME' 
         LA    NB,LOCAL1 
         DISABLE 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC03 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM03 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##03 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##03
.HITAC03 ANOP 
         TIME  DEC,DTYPE=YMD 
         AGO   .EXIT003 
.FACOM03 ANOP 
         TIME  DEC,DATE=YMD 
         AGO   .EXIT003 
.TSO##03 ANOP 
         TIME  DEC 
.EXIT003 ANOP 
         STM   0,1,LOCAL1 
         ENABLE 
         UNPK  LOCAL3(15),LOCAL1(8) 
         OI    LOCAL6+2,X'F0' 
         L     D,STRBUFAD 
         MVC   0(6,D),LOCAL5+1 
         MVC   6(8,D),LOCAL3 
         AGO   .DATE2
.MTS##03 CALL  TIME,(=F'11',=F'0',DATEOUT),VL
         ENABLE
         L     D,STRBUFAD
         MVC   0(2,D),DATEOUT+14  YY
         MVC   2(2,D),DATEOUT+8   MM
         MVC   4(2,D),DATEOUT+11  DD
         MVC   6(2,D),DATEOUT     HH
         MVC   8(2,D),DATEOUT+3   MM
         MVC   10(2,D),DATEOUT+6  SS
         MVC   12(2,D),=C'00'     TT
.DATE2   ANOP
         LA    A,14(D) 
         B     MKSTRNGR 
         CODEND 
*
DATEOUT  DS    CL16
* 
CALL     SUBR  1,2 
         B     CALL$1 
         B     CALL$2 
CALL$1   L     A,NULLSTR 
         ST    A,LOCAL2 
CALL$2   EQU   * 
         LA    NB,LOCAL3      SET SAVE AREA 
         L     X,STRBUFAD     X:=COMMAND BUFFER ADDR 
         L     A,LOCAL1       COMMAND NAME 
         $STRING 
         LT    WW,0(A)        COMMAND NAME LENGTH SHOULD RESIDE 
         BZ    TYPERR           BETWEEN ZERO AND 
*
         AIF   ('&SYSTEM' EQ 'MTS').CALL$1
*
         C     WW,F8            EIGHT 
         BH    TYPERR 
         LA    W,4(A)         MOVE COMMAND NAME TO THE BUFFER 
         LA    D,4(X) 
         MVC   0(13,X),BUFFMDL 
         LR    A,WW 
         MVCL  D,W 
         L     W,ECTADDR 
         MVC   12(8,W),4(X) 
         L     A,LOCAL2       OPERAND 
         $STRING 
         L     WW,0(A) 
         LA    W,4(A) 
* 
         LTR   WW,WW 
         BZ    CALL$NO 
CALL$3   CLI   0(W),C' ' 
         BNZ   CALL$YES 
         LA    W,1(W) 
         BCT   WW,CALL$3 
CALL$NO  L     W,ECTADDR 
         OI    28(W),X'80'     ; SET BIT0 OF FLAG3 IN ECT 
         B     CALL$4 
CALL$YES L     W,ECTADDR 
         NI    28(W),X'7F'     ; RESET BIT0 OF FLAG3 IN ECT 
* 
CALL$4   L     WW,0(A) 
         LA    W,4(A) 
         LR    A,WW 
         LA    NA,13(WW) 
         STH   NA,0(X) 
         LA    D,13(X) 
         MVCL  D,W 
         LA    D,4(X)         D:=COMMAND NAME ADDRESSS 
         ST    Z,TASKECB 
         DISABLE 
         MVI   TASKFLAG,X'FF' 
         L     A,UPTADDR 
         L     NA,PSCBADDR 
         L     L,ECTADDR 
         ATTACH EPLOC=(D),PARAM=((X),(A),(NA),(L)),                    *
               ECB=TASKECB,SHSPV=78,ESTAI=(ESTAI) 
         ST    1,TCBADDR 
         WAIT  ECB=TASKECB    OTHERWISE WAIT TASK COMPLETION 
         MVI   TASKFLAG,X'00' 
         DETACH TCBADDR 
         ENABLE 
         L     A,TASKECB 
         LA    A,0(A) 
         LTR   A,A 
         BZ    RETNIL 
         B     RETNUM 
* 
ESTAI    SETRP RC=16 
         RETURN , 
* 
NULLSTR  STRNGCON NLLSTRNG 
CALLSAVE DS    18A 
BUFFMDL  DC    A(9),CL9' ' 
*
         AGO   .CALL$2
.CALL$1  ANOP
*
         LA    W,4(A)         MOVE COMMAND NAME TO THE BUFFER 
         LR    D,X            PUT THE COMMAND NAME HERE
         LA    A,1(0,WW)      ADD ONE FOR A BLANK
         ICM   WW,B'1000',=C' ' PAD WITH BLANKS
         MVCL  D,W            MOVE COMMAND NAME
         L     A,LOCAL2       OPERAND 
         $STRING 
         L     WW,0(0,A)      LENGTH OF PARAMETER
         LA    W,4(0,A)       LOCN OF PARAMETER
         LR    A,WW           SET BOTH LENGTHS
         MVCL  D,W            MOVE THE PARAMETER
         S     D,STRBUFAD     COMPUTE TOTAL LENGTH OF COMMAND
         ST    D,CALL$LEN     SAVE IT
         DISABLE
         CALL  COMMAND,(STRBUFF,CALL$LEN,=X'00000006',CALL$SUM),VL
         ENABLE 
         C     15,=F'4'       CHECK RETURN CODE
         BH    SYSERR#D
         L     A,CALL$SUM
         LTR   A,A
         BZ    RETNIL
         B     RETNUM
*
NULLSTR  STRNGCON NLLSTRNG
CALL$LEN DS    F
CALL$SUM DS    F
*
.CALL$2  ANOP
         CODEND 
* 
NLLSTRNG DC    F'0' 
* 
*  SYSTEM DUMMY SECTION MACRO 
* 
*        &JAA.SDWA ,          ; FOR "SETRP" MACRO 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC08 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM08 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##08 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##08
* 
.HITAC08 ANOP 
         JAASDWA , 
         AGO   .EXIT008 
* 
.FACOM08 ANOP 
         KAASDWA , 
         AGO   .EXIT008 
* 
.TSO##08 ANOP 
         IHASDWA , 
         AGO   .EXIT008 
.MTS##08 ANOP
.EXIT008 ANOP 
* 
* 
* 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC05 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM05 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##05 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##05
.HITAC05 ANOP 
DEFCS    SUBR  2,2 
         L     A,LOCAL1 
         $STRING 
         LA    D,2(A) 
         L     A,LOCAL2 
         LA    NB,LOCAL3 
         IFNOTFIX A,DEFCS$1 
         SLL   A,8 
         SRA   A,8 
         ST    A,DEFCSTMP 
         DISABLE 
         DEFCS CSN=(D),VALUE=DEFCSTMP-2,TYPE=FIXED,BRANCH=NO 
         B     DEFCS$2 
DEFCS$1  $STRING 
         LA    A,2(A) 
         DISABLE 
         DEFCS CSN=(D),VALUE=(A),TYPE=CHAR,BRANCH=NO 
DEFCS$2  ENABLE 
         L     A,LOCAL2 
         RET 
         CNOP 2,4 
         DC    H'4' 
DEFCSTMP DS    A 
         CODEND 
         AGO   .EXIT005 
* 
.MTS##05
.TSO##05 ANOP 
.FACOM05 ANOP 
DEFCS    SUBR  2,2 
         B     IMPLERR 
         CODEND 
.EXIT005 ANOP 
* 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC06 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM06 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##06 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##06
.HITAC06 ANOP 
DELCS    SUBR  1,1 
         L     A,LOCAL1 
         $STRING 
         LA    NB,LOCAL2 
         LA    A,2(A) 
         DISABLE 
         DELCS CSN=(A),BRANCH=NO 
         ENABLE 
         L     A,LOCAL1 
         CODEND RET 
         AGO   .EXIT006 
* 
.MTS##06 ANOP
.TSO##06 ANOP 
.FACOM06 ANOP 
DELCS    SUBR  2,2 
         B     IMPLERR 
         CODEND 
.EXIT006 ANOP 
* 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC07 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM07 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##07 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##07
.HITAC07 ANOP 
DETCS    SUBR  1,1 
         L     A,LOCAL1 
         $STRING 
         LA    D,LOCAL2+2 
         LA    NB,LOCAL2+256+4 
         LA    W,256 
         STH   W,0(D) 
         LA    A,2(A) 
         DISABLE 
         DETCS CSN=(A),VALUE=(D),MF=(E,DETCS$L) 
         ENABLE 
         LTR   15,15 
         BNZ   RETNIL 
         TM    DETCS$L+15,X'02' 
         BNZ   DETCSINT 
         LH    A,LOCAL2+2 
         LA    D,LOCAL3 
         L     X,STRBUFAD 
         LR    NA,A 
         MVCL  X,D 
         LR    A,X 
         B     MKSTRNGR 
DETCS$L  DETCS MF=L 
DETCSINT L     A,LOCAL3 
         B     RETNUM0 
         CODEND 
         AGO   .EXIT007 
* 
.MTS##07 ANOP
.TSO##07 ANOP 
.FACOM07 ANOP 
DETCS    SUBR  1,1 
         B     IMPLERR 
         CODEND 
.EXIT007 ANOP 
*
*   (USERID)  RETURNS THE USERID AS A STRING
*
         AIF   ('&SYSTEM' NE 'MTS').NOUID  DEFINED IN LISP IF NOT MTS
USERID   SUBR  0,0
         LA    NB,LOCAL1      SAVE AREA POINTER
         DISABLE
         CALL  GUSERID
         L     X,STRBUFAD
         ST    1,0(0,X)
         LA    A,4(0,X)       FOUR BYTES LONG
         ENABLE
         B     MKSTRNGR
         CODEND
*
.NOUID   ANOP
* 
************************* CAUTION **************************** 
*******                                                  ***** 
*******    OK.RETURN : ( ADDRESS . # OF BYTES )          ***** 
*******    NG.RETURN : R15<<12 + R1  IN FIX NUMBER       ***** 
*******                                                  ***** 
************************************************************** 
* 
PROGLD   SUBR  1,2,PNAME='PROGRAM-LOAD' 
         B     PROGLD$0 
         L     A,LOCAL2 
         $STRING 
         L     WW,0(A) 
         C     WW,=A(L'LDDCBDD)
         BH    TYPERR 
         LA    W,4(A) 
         LA    D,LDDCBDD 
         LA    A,L'LDDCBDD
         ICM   WW,B'1000',=C' '
         MVCL  D,W 
         LA    NB,LOCAL3 
         AIF   ('&SYSTEM' EQ 'MTS').PGLD1
         DISABLE , 
         OPEN  (LDDCB,INPUT) 
         LM    0,1,REGINIT 
.PGLD1   ANOP
         LA    X,LDDCB 
         B     PROGLD$1 
         AIF   ('&SYSTEM' EQ 'MTS').PGLD2
PROGLD$0 XR    X,X 
         AGO   .PGLD3
.PGLD2   ANOP
PROGLD$0 LA    X,=C'*DUMMY* '
.PGLD3   ANOP
         ST    Z,LOCAL2 
PROGLD$1 L     A,LOCAL1 
         $STRING 
         L     WW,0(A) 
         C     WW,F8 
         BH    TYPERR 
         MVC   ENTRPNT,=CL8' ' 
         LA    W,4(A) 
         LA    D,ENTRPNT 
         LR    A,WW 
         MVCL  D,W 
         AIF   ('&SYSTEM' EQ 'MTS').PGLD4
         O     X,=X'80000000' 
         LA    NB,LOCAL3
         DISABLE , 
         LR    1,X 
         LA    0,ENTRPNT 
         SVC   8 
         LTR   15,15 
         BNZ   LDERR 
         LR    A,0      ENTRY ADDRESS 
         LA    A,0(A)   LOWER 3 BYTES 
         O     A,@FIX 
         LA    D,0(1)   LENGTH IN D-WORD 
         SLL   D,3 
         O     D,@FIX 
         LM    0,1,REGINIT
         C     Z,LOCAL2 
         BE    PROGLD$2 
         CLOSE LDDCB 
* 
         AGO   .PGLD5
.PGLD4   ANOP
*
         LA    NB,LOCAL3 
         DISABLE
         CALL  LOAD,((X),LDINESD,LDSWS,0),VL
         LTR   15,15          DID IT LOAD OK?
         BNZ   PGLD$OK        YES
         LTR   1,1            MAYBE, CHECK ERROR CODE
         BNZ   LDERR          NOPE
PGLD$OK  CALL  LOADINFO,(=F'1',ENTRPNT,LDINFBITS,LDINFOUT),VL
         LTR   1,15           DID LOADINFO GET IT
         BNZ   LDERR          NO
         TM    LDINFBITS+3,X'02' DOES IT HAVE AN ADDRESS?
         LA    15,4
         BZ    LDERR          NO
         L     A,LDINFOUT+8   GET THE ADDRESS
         LA    A,0(0,A)       24 BIT ADDRESS
         O     A,@FIX
         IF    X'08':LDINFBITS+3 THEN WE GOT A CSECT LENGTH
           L     D,LDINFOUT+16
         ELSE  ,
           SR    D,D          WE CAN'T TELL HOW LONG IT IS
         ENDIF
         O     D,@FIX
.PGLD5   ANOP
*
PROGLD$2 ENABLE , 
         LA    NB,LOCAL3 
         B     CONSNRET 
LDERR    SLL   15,12 
         LA    15,0(15) 
         LR    A,1 
         ALR   A,15 
         AIF   ('&SYSTEM' EQ 'MTS').PGLD6
         LM    0,1,REGINIT
         C     Z,LOCAL2 
         BE    LDERR$1 
         CLOSE LDDCB 
.PGLD6   ANOP
LDERR$1  ENABLE , 
         B     RETNUM 
*
         AIF   ('&SYSTEM' EQ 'MTS').PGLD7
ENTRPNT  DC    CL8' ' 
LDDCB    DCB   DSORG=PO,MACRF=R 
LDDCBDD  EQU   LDDCB+40,8
         AGO   .PGLD8
.PGLD7   ANOP
LDDCB    DS    0X
LDDCBDD  DC    CL44' ',C' '
LDINESD  DC    H'0,1' 
ENTRPNT  DC    CL8' ',A(0)
*
LDSWS    DC    X'00000061'
*
LDINFBITS DC   XL4'0'
LDINFOUT DS    XL(20*4)
*
.PGLD8   ANOP
         CODEND 
* 
PROGDL   SUBR  1,1,PNAME='PROGRAM-DELETE' 
         L     A,LOCAL1 
         $STRING 
         L     WW,0(A) 
         C     WW,F8 
         BH    TYPERR 
         LA    W,4(A) 
         LA    D,DLENTR 
         LR    A,WW 
         MVC   DLENTR,=CL8' ' 
         MVCL  D,W 
         LA    NB,LOCAL2 
         DISABLE , 
         AIF   ('&SYSTEM' EQ 'MTS').PGDL1
         DELETE EPLOC=DLENTR 
         AGO   .PGDL2
.PGDL1   ANOP
         CALL  UNLOAD,(DLENTR,0,=F'1'),VL
.PGDL2   ANOP
         ENABLE , 
         LA    A,0(15) 
         B     RETNUM 
DLENTR   DC    CL8' ' 
         CODEND 
* 
PROGCL   SUBR  1,2,PNAME='PROGRAM-CALL' 
         ST    N,LOCAL2 
         L     A,LOCAL1 
         $STRING 
         L     WW,0(A) 
         C     WW,=A(L'CLENTR)
         BH    TYPERR 
         LA    W,4(A) 
         LA    A,L'CLENTR
         LA    D,CLENTR 
         ICM   WW,B'1000',=C' '
         MVCL  D,W 
         LA    A,LOCAL2 
         ST    A,CMNDBUFF 
         LA    NB,LOCAL3 
         DISABLE , 
         AIF   ('&SYSTEM' EQ 'MTS').PGCL1
         LA    1,CPPLCOPY 
         LINK  EPLOC=CLENTR,ERRET=CLERR 
         AGO   .PGCL2
.PGCL1   ANOP
         CALL  LINK,(CLENTR,0,CPPLCOPY),VL
.PGCL2   ANOP
CLERR    ENABLE , 
         LA    A,0(15) 
         B     RETNUM 
         AIF   ('&SYSTEM' EQ 'MTS').PGCL3
CLENTR   DC    CL8' ' 
*
         AGO   .PGCL4
.PGCL3   ANOP
*
CLENTR   DC    CL44' ',C' '   FILE NAME OR FDUB POINTER
*
.PGCL4   ANOP
*
         CODEND 
* 
PROGLNK  LSUBR PNAME='PROGRAM-LINK' 
         C     NA,F8          CHECK NUMBER OF ARGUMENTS 
         BL    PARAMERR 
         L     W,LOCAL2       SAVE THE RESULT TYPE INDICATOR 
         ST    W,LINK$TYP 
         LA    W,LNGAREA      INITIATE STRING LENGTH AREA POINTER 
         ST    W,LOCAL2 
         ST    W,LNGAREAP 
* 
         LA    NB,LOCAL1(NA)  SET STACK POINTER 
         LR    NA,NB            AND END-OF-THE-ARGUMENTS POINTER (NA) 
         LA    X,LOCAL3       SET ARGUMENT POINTER(X) 
         CLR   X,NA           IF NO ARGUMENT TO THE PROGRAM CALLED 
         BE    LINK$RES         THEN NO PROCESSING FOR ARGUMENTS NEEDED 
* 
LINK$ARG CLI   0(X),FIXTAG    BRANCH ON THE TYPE OF THE ARGUMENTS 
         BE    ARG$FIX 
         CLI   0(X),FLOTAG 
         BE    ARG$FLO 
         CLI   0(X),STRNGTAG 
         BE    ARG$STR 
* 
* WHEN NEITHER FIXNUM NOR FLONUM NOR STRING 
*   ALLOCATE ONE WORD FOR "TAGGED POINTER" TO THE OBJECT 
*   AND PLACE ADDRESS POINTER TO IT IN THE PARAMETER LIST. 
* 
         L     W,0(X)         LISP OBJECT POINTER TO BE PASSED 
         ST    NB,0(X)        POINTER INTO STACK IN ARG LIST 
         PUSHW W              PUSH THE OBJECT IN THE STACK 
         B     ARG$NXT 
* 
* WHEN FIXNUM 
*   ALLOCATE ONE WORD FOR THE INTEGER VALUE 
*   AND PLACE ADDRESS OF THE AREA IN THE PARAMETER LIST. 
* 
ARG$FIX  L     W,0(X)         W:=FIXNUM TO BE PASSED 
         SLL   W,8            SIGN EXTENSION TO MAKE 32BIT VALUE 
         SRA   W,8 
         ST    NB,0(X)        POINTER INTO STACK IN THE ARG LIST 
         PUSHW W              PUSH THE INTEGER VALUE IN THE STACK 
         B     ARG$NXT 
* 
* WHEN THE ARG IS A FLONUM 
*   PUT ADDRESS OF THE DATA PART OF THE OBJECT 
*   IN THE PARAMETER LIST. 
* 
ARG$FLO  L     W,0(X)         W:=FLONUM OBJECT TO BE PASSED 
         LA    W,4(W)         W:=POINTER TO ITS VALUE PORTION 
         ST    W,0(X)         THIS POINTER IS SET IN THE ARG LIST 
         B     ARG$NXT 
* 
* WHEN THE ARG IS A STRING 
*   MAKE THE ARGUMENT STRING LENGTH TABLE. 
*   THE PARAMETER LIST CONTAINS THE ADDRESS OF THE 
*   TOP OF THE STRING CHARACTERS. 
* 
ARG$STR  L     W,0(X)         W:=STRING OBJECT TO BE PASSED 
         L     WW,0(W)        WW:=LENGTH OF THE STRING 
         L     A,LNGAREAP     A:=STRING LENGTH AREA POINTER 
         CL    A,=A(LNGAREAE) CHECK STRING LENGTH AREA OVERFLOW 
         BE    PARAMERR 
         STH   WW,0(A)        PLACE LENGTH IN THE LENGTH AREA 
         LA    A,2(A)         ADVANCE POINTER 
         ST    A,LNGAREAP 
         LA    W,4(W)         PLACE ADDRESS OF THE STRING BODY 
         ST    W,0(X)           IN THE ARGUMENT LIST 
*        B     ARG$NXT 
* 
ARG$NXT  ALR   X,F 
         CLR   X,NA 
         BNE   LINK$ARG 
* 
         SLR   X,F 
         OI    0(X),X'80'     SET LAST ARGUMENT BIT 
* 
* SET RESULT STRING AREA 
*   ONLY REQUIRED WHEN THE RESULT TYPE IS STRING, 
*   I.E., THE SECOND ARGUMENT OF "PROGRAM-LINK" IS A STRING, 
*   YET, THE STACK TOP AREA WILL BE PREPARED AS DEFAULT RESULT AREA 
*   FOR A FAULT-TOLERANT SYSTEM. 
* 
LINK$RES LA    X,LINK$SAV 
         ST    X,4(NB) 
         ST    NB,8(X) 
         LA    X,72(NB)       72 BYTES FOR SAVE AREA 
         ST    Z,0(X)         ONE WORD FOR LENGTH (ZERO) 
         ALR   X,F            NOW X POINTS TO THE DUMMY STRING 
         CLI   LINK$TYP,STRNGTAG 
         BNE   LINK$CAL 
         L     X,LINK$TYP     IF THE RESULT SPECIFIED IS STRING 
         LA    X,4(X)           USE THAT STRING INSTEAD OF DUMMY 
* 
* CALL THE SPECIFIED PROGRAM 
* 
*   WHEN THE 1ST ARG IS A FIXNUM, 
*     THIS WILL BE INTERPRETED AS THE ROUTINE ENTRY ADDRESS. 
*   WHEN IT IS A STRING, 
*     THEN THIS WILL BE INTERPRETED AS THE ENTRY NAME. 
* 
LINK$CAL CLI   LOCAL1,FIXTAG  IF 1ST ARG TO PROGRAM-LOAD IS NOT FIXTAG 
         BNE   LINK$NAM         THEN IT IS THE ENTRY NAME 
* 
* CALLING WITH ADDRESS 
* 
LINK$ADR L     15,LOCAL1      R15:=ENTRY ADDRESS 
         LA    15,0(15) 
         DISABLE 
         LR    0,X 
         LA    1,LOCAL3 
         CLR   1,NA 
         BNE   LINK$AD1 
         SR    1,1 
LINK$AD1 BALR  14,15          CALL THE PROGRAM 
         ENABLE0 
         B     LINK$RET 
* 
* CALLING WITH THE ENTRY NAME 
* 
LINK$NAM L     A,LOCAL1       A:=STRING WHICH CONTAINS THE ENTRY NAME 
         $STRING              CHECK ITS TYPE 
         LA    D,4(A)         D:=TOP OF CHARACTERS 
         L     A,0(A)         A:=STRING LENGTH 
         C     A,=A(L'LINK$ENT) ENTRY NAME LENGTH SHOULD SHORT ENOUGH 
         BH    TYPERR1 
         O     A,=X'40000000' USE BLANK AS THE PADDING CHARACTER 
         LA    W,LINK$ENT     SET W&WW PAIR THE ADDRESS 
         LA    WW,L'LINK$ENT    WHERE THE ENTRY NAME SHOULD BE STORED. 
         MVCL  W,D            MOVE ENTRY NAME 
         DISABLE 
         LR    0,X 
         LA    1,LOCAL3 
         CLR   1,NA 
         BNE   LINK$NM1 
         SR    1,1 
         AIF   ('&SYSTEM' EQ 'MTS').PGLNK1
LINK$NM1 LINK  EPLOC=LINK$ENT CALL THE PROGRAM 
         AGO   .PGLNK2
.PGLNK1  ANOP
LINK$NM1 LR    W,1
         CALL  LINK,(LINK$ENT,0,(W)),VL
.PGLNK2  ANOP
         ENABLE0 
*        B     LINK$RET 
* 
* PROCESSING OF THE RESULT 
* 
LINK$RET CLI   LINK$TYP,FIXTAG 
         BE    LINK$FIX 
         CLI   LINK$TYP,FLOTAG 
         BE    LINK$FLO 
         CLI   LINK$TYP,STRNGTAG 
         BE    LINK$STR 
* 
         LA    A,0(15)        WHEN NOT FIX, FLOAT NOR STRING 
         LM    0,1,REGINIT      THEN THE RESULT WILL BE THE RETURN CODE 
         B     RETNUM0 
* 
LINK$FIX LR    A,0            WHEN FIXNUM IS SPECIFIED 
         LM    0,1,REGINIT      THEN THE RESULT IS ON R0 
         B     RETNUM 
* 
LINK$FLO L     A,LINK$TYP     WHEN FLONUM IS SPECIFIED 
         STD   FR0,4(A)         THEN THE RESULT IS ON FR0 
         LM    0,1,REGINIT 
         RET                    SO COPY IT BACK INTO THE FLONUM PASSED 
* 
LINK$STR L     A,LINK$TYP     WHEN THE RESULT TYPE IS STRING 
         LM    0,1,REGINIT 
         RET                    THEN RETURN PASSED STRING (CHANGEDń) 
* 
* 
LINK$TYP DS    A              SAVE AREA FOR THE RETURN TYPE INDICATOR 
LNGAREAP DS    A              POINTER FOR THE STRING LENGTH AREA 
* 
LNGAREA  DS    20H            UPTO 20 STRING ARGUMENTS CAN BE PASSED 
LNGAREAE EQU   * 
         AIF   ('&SYSTEM' EQ 'MTS').PGLNK3
LINK$ENT DS    CL8 
         AGO   .PGLNK4
.PGLNK3  ANOP
LINK$ENT DC    CL44' ',C' ' 
.PGLNK4  ANOP
* 
* 
         DS    0D 
LINK$SAV DC    18A(0) 
         CODEND 
* 
* 
ATTACHW  LSUBR PNAME='ATTACH-WAIT' 
         CR    NA,Z           CHECK NUMBER OF ARGUMENTS 
         BE    PARAMERR 
         LA    NB,LOCAL1(NA)  SET STACK POINTER 
         LR    NA,NB            AND END-OF-THE-ARGUMENTS POINTER (NA) 
         LA    X,LOCAL2       SET ARGUMENT POINTER(X) 
         CLR   X,NA           IF NO ARGUMENT TO THE PROGRAM CALLED 
         BE    ATTW$CAL         THEN NO PROCESSING FOR ARGUMENTS NEEDED 
* 
ATTW$ARG L     W,0(X)         W:=ARG 
         CLI   0(X),FLOTAG 
         BE    ATW$FLO 
         CLI   0(X),STRNGTAG 
         BE    ATW$STR 
         CLI   0(X),FIXTAG    BRANCH ON THE TYPE OF THE ARGUMENTS 
         BNE   ATW$FIX1 
ATW$FIX  SLL   W,8            SIGN EXTENSION TO MAKE 32BIT VALUE 
         SRA   W,8 
ATW$FIX1 ST    NB,0(X)        POINTER INTO STACK IN THE ARG LIST 
         PUSHW W              PUSH THE INTEGER VALUE IN THE STACK 
         B     ATW$NXT 
* 
ATW$FLO  LA    W,4(W)         W:=POINTER TO ITS VALUE PORTION 
         ST    W,0(X)         THIS POINTER IS SET IN THE ARG LIST 
         B     ATW$NXT 
* 
ATW$STR  LA    W,2(W)         W:=POINTER TO LENGTH (HALF-WORD) 
         ST    W,0(X) 
*        B     ATW$NXT 
* 
ATW$NXT  ALR   X,F 
         CLR   X,NA 
         BNE   ATTW$ARG 
* 
         SLR   X,F 
         OI    0(X),X'80'     SET LAST ARGUMENT BIT 
* 
* CALL THE SPECIFIED PROGRAM 
* 
ATTW$CAL L     A,LOCAL1       A:=STRING WHICH CONTAINS THE ENTRY NAME 
         $STRING              CHECK ITS TYPE 
         LA    D,4(A)         D:=TOP OF CHARACTERS 
         L     A,0(A)         A:=STRING LENGTH 
         C     A,=A(L'ATTW$ENT) ENTRY NAME LENGTH SHOULD BE THIS SHORT
         BH    TYPERR1 
         O     A,=X'40000000' USE BLANK AS THE PADDING CHARACTER 
         LA    W,ATTW$ENT     SET W&WW PAIR THE ADDRESS 
         LA    WW,L'ATTW$ENT    WHERE THE ENTRY NAME SHOULD BE STORED. 
         MVCL  W,D            MOVE ENTRY NAME 
         DISABLE 
         AIF   ('&SYSTEM' NE 'MTS').ATTW1
         ST    Z,TASKECB 
         MVI   TASKFLAG,X'FF' 
.ATTW1   ANOP
         LA    1,LOCAL2 
         CLR   1,NA 
         BNE   ATW$CAL1 
         SR    1,1 
         AIF   ('&SYSTEM' EQ 'MTS').ATTW2
ATW$CAL1 ATTACH EPLOC=ATTW$ENT,                                        *
               ECB=TASKECB,SZERO=NO,ESTAI=(ESTAI) 
         ST    1,TCBADDR 
         WAIT  ECB=TASKECB 
         MVI   TASKFLAG,X'00' 
         DETACH TCBADDR 
         ENABLE 
         L     A,TASKECB 
         AGO   .ATTW3
.ATTW2   ANOP
ATW$CAL1 LR    W,1
         CALL  LINK,(ATTW$ENT,0,(W)),VL
         LR    A,15           RETURN CODE
         ENABLE
.ATTW3   ANOP
         LA    A,0(A) 
         LTR   A,A 
         BZ    RETNIL 
         B     RETNUM 
* 
         AIF   ('&SYSTEM' EQ 'MTS').ATTW4
ATTW$ENT DS    CL8 
         AGO   .ATTW5
.ATTW4   ANOP
ATTW$ENT DC    CL44' ',C' '
.ATTW5   ANOP
* 
         CODEND 
* 
* INTERVAL TIMER FUNCTIONS 
* 
TMRSTRT  SUBR  0,1,PNAME='INTERVAL-TIMER-START' 
         B     TMRSTA$1 
         L     A,LOCAL1 
         $POSFIX 
         LR    W,Z 
         LA    WW,0(A) 
         D     W,=F'10' 
         ST    WW,BINTVL 
         LA    NB,LOCAL2
         B     TMRSTA$2
TMRSTA$1 LA    NB,LOCAL1
TMRSTA$2 DISABLE , 
*        
         AIF   ('&SYSTEM' EQ 'MTS').TIMER1
*
         STATUS START,TCB=TIMERTCB 
         AGO   .TIMER2
.TIMER1  ANOP
*
         CALL  RSTIME,(=A(TIMESUB),TIMERVAL,TIMERREG),VL 
         L     A,BINTVL
         M     D,=F'10000'    1/100 SECOND TO MICRO SECOND
         STM   D,A,TIMERVAL
         CALL  TICALL,(=F'0',=A(TIMESUB),TIMERVAL),VL
         ST    0,TIMERREG
.TIMER2  ANOP 
         ENABLE , 
* 
*
         LTR   15,15 
         BNZ   RETNIL 
         B     RETT 
         CODEND 
* 
TMRSTOP  SUBR  0,0,PNAME='INTERVAL-TIMER-STOP' 
         LA    NB,LOCAL1 
         DISABLE , 
*       
         AIF   ('&SYSTEM' EQ 'MTS').TIMER5
         STATUS STOP,TCB=TIMERTCB 
*
         AGO   .TIMER6
.TIMER5  ANOP
         CALL  RSTIME,(=A(TIMESUB),TIMERVAL,TIMERREG),VL 
.TIMER6  ANOP
*
         ENABLE , 
         LTR   15,15 
         BNZ   RETNIL 
         B     RETT 
         CODEND 
* 
TMRFLAG  SUBR  0,0,PNAME='INTERVAL-TIMER-FLAG' 
         CLI   TIMERFLG,X'FF' 
         BE    RETT 
         B     RETNIL 
         CODEND 
* 
TMRCHCK  SUBR  0,0,PNAME='INTERVAL-TIMER-CHECK' 
         XR    X,X 
         IC    X,TIMERFLG 
         MVI   TIMERFLG,X'00' 
         LTR   X,X 
         BZ    RETNIL 
         B     RETT 
         CODEND 
* 
         TITLE 'OTHER HEAP OBJECTS' 
* 
* OBJECTS OTHER THAN SYMBOLS 
* 
PREDEF   CSECT 
* 
TERMIN$  DS    0F             TERMINAL INPUT STREAM 
         DC    A(5*4) 
         DC    F'0'           CURPOS 
         DC    F'0'           RECTOP 
         DC    F'0'           RECEND 
         DC    F'1'           MODE=INPUT 
         DC    A(TGET)        LINEIO 
* 
SYSIN$   DS    0F             SYSTEM LIBRARY INPUT STREAM 
         DC    A(STRMLENG-4) 
         DC    F'0'           CURPOS 
         DC    F'0'           RECTOP 
         DC    F'0'           RECEND 
         DC    F'1'           MODE=INPUT 
         DC    A(LINEIN)      LINEIO 
         AIF   ('&SYSTEM' EQ 'MTS').SYSIN1
DCBSYS   DCB   DSORG=PS,MACRF=(GL),EODAD=ENDSYS,EXLST=EXLST,           *
               SYNAD=SYNAD,EROPT=ACC 
         AGO   .SYSIN2
.SYSIN1  ANOP
         DC    A(ENDSYS)      WHERE TO GO ON EOF
         DC    A(0,SYSLEN,SYSMODS,SYSLNR,SYSLDN) PARLIST
SYSMODS  MTSMODS (@MAXLEN),WORDS=2
SYSLDN   DC    CL8' '
SYSLNR   DC    F'0'
SYSLEN   DC    H'0,255,0'
.SYSIN2  ANOP
* 
TERMOUT$ DS    0F             TERMINAL OUTPUT STREAM 
         DC    A(5*4) 
         DC    A(TERMOBUF)    CURPOS 
         DC    A(TERMOBUF)    RECTOP 
         DC    A(TERMOBUF+256) RECEND 
         DC    F'2'           MODE=OUTPUT 
         DC    A(TPUT)        LINEIO 
* 
PROMPT   SYM   ,PROMPTSQ,STRNGTAG 
PROMPTSQ STRING '>' 
* 
SYSID    SYM   ,SYSIDSTR,STRNGTAG,PNAME='MANAGER-ID' 
SYSIDSTR STRING '&SYSID' 
* 
SYSPARM SYM    ,SYSNULL,STRNGTAG 
SYSNULL DC     F'0' 
* 
DFLTMCT$ DC    A(1024) 
         SYMCONS NIL$,28 
         SYMCON RDCODE$ 
         SYMCONS NIL$,96      96=C''''-28-1 
         SYMCON RDQT$ 
         SYMCONS NIL$,130     130=256-C''''-1 
* 
DFLTOBR$ VECTOR 1013          DEFAULT OBVECTOR 
* 
DFLTRDT$ EQU   *              DEFAULT READ TABLE 
* 
         DC    A(256*4)       SIZE=256 
TOP      DC    256X'10000001'        USUALLY ALPHABETS 
* 
         ORG   TOP+C' '*4     BLANK 
         DC    X'1000A0C0'    TERM+BLANK+SLASHTOP+SLASH 
         ORG   TOP+C'('*4     LEFT PARENTHESIS 
         DC    X'100090C0'    TERM+LPAR+SLASHTOP+SLASH 
         ORG   TOP+C')'*4     RIGHT PARENTHESIS 
         DC    X'100084C0'    TERM+RPAR+SLASHTOP+SLASH 
         ORG   TOP+C'.'*4     DOT 
         DC    X'10800880'    DOT+POINT+SLASHTOP 
         ORG   TOP+C'/'*4     SLANT (ESCAPE) 
         DC    X'100000E0'    SLASHTOP+SLASH+ESCAPE 
         ORG   TOP+C'"'*4     STRING QUOTE 
         DC    X'100081C0'    TERM+STRQ+SLASHTOP+SLASH 
         ORG   TOP+C'+'*4     PLUS SIGN 
         DC    X'10000088'    SLASHTOP+SIGN 
         ORG   TOP+C'-'*4     MINUS SIGN 
         DC    X'10000098'    SLASHTOP+ALT+SIGN 
         ORG   TOP+C'0'*4     DIGITS 
         DC    10X'10000084'  SLASHTOP+DIG 
         ORG   TOP+C''''*4    QUOTE 
         DC    X'100082C0'    TERM+MACROCH+SLASHTOP+SLASH 
         ORG   TOP+28*4       MACHINE CODE ESCAPE 
         DC    X'100082C0'    TERM+MACROCH+SLASHTOP+SLASH 
         ORG   TOP+C';'*4     COMMENT BEGINNING CHARACTER 
         DC    X'100080C2'    TERM+SLASHTOP+SLASH+COMBEG 
         AIF   ('&SYSTEM' EQ 'MTS').FLOEXP1
         ORG   TOP+C'^'*4     EXPONENT PART INDICATOR 
         AGO   .FLOEXP2
.FLOEXP1 ANOP
         ORG   TOP+C'ˇ'*4     EXPONENT PART INDICATOR 
.FLOEXP2 ANOP
         DC    X'10400041'    EXPT+SLASH 
         ORG 
* 
LCTAB    TRTAB (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z),  *
               (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) 
UCTAB    TRTAB (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z),  *
               (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z) 
* 
LCTAB    SYM   ,LCTAB,STRNGTAG,PNAME='LOWER-CASE' 
UCTAB    SYM   ,UCTAB,STRNGTAG,PNAME='UPPER-CASE' 
* 
PREDEF   CSECT 
PREEND   EQU   * 
PDSYM    CSECT 
PDSYEND  EQU   * 
         TITLE 'WORK AREA, ETC.' 
MAIN     CSECT 
* 
CONVTEMP DS    A              ; AREA FOR CONV. BETWEEN FIX AND FLOAT 
* 
         AIF   ('&SYSTEM' EQ 'HITAC').HITAC12 
         AIF   ('&SYSTEM' EQ 'FACOM').FACOM12 
         AIF   ('&SYSTEM' EQ 'MVS/TSO').TSO##12 
         AIF   ('&SYSTEM' EQ 'MTS').MTS##12
* 
.MTS##12 ANOP
.TSO##12 ANOP 
CVTSAVE  DS    2A 
CVTFSAVE DS    1D 
CVTWORK  DS    1D 
CVTX80   DC    X'80000000' 
CVTX4E   DC    X'4E000000' 
CVTD0    DC    D'0' 
CVTXX    DC    X'4F08000000000000' 
* 
         AGO   .EXIT012 
* 
.HITAC12 ANOP 
.FACOM12 ANOP 
* 
.EXIT012 ANOP 
* 
PRCHARS  DC    F'15' 
SPACECH  DC    C' ' 
LPARCH   DC    C'(' 
RPARCH   DC    C')' 
DOTCH    DC    C'.' 
ESCAPECH DC    C'/' 
STRQCH   DC    C'"' 
PLUSCH   DC    C'+' 
MINUSCH  DC    C'-' 
POINTCH  DC    C'.' 
         AIF   ('&SYSTEM' EQ 'MTS').FLOEXP3
EXPNTCH  DC    C'^' 
         AGO   .FLOEXP4
.FLOEXP3 ANOP
EXPNTCH  DC    C'ˇ' 
.FLOEXP4 ANOP
SEPARCH  DC    C'#' 
CODECH   DC    C'C' 
STRMCH   DC    C'S' 
VECCH    DC    C'V' 
REFCH    DC    C'R' 
         DC    F'00'          PADDING 
         LTORG 
*
         DS    0F             Align for start of PDSYM
* 
* 
* STREAM AREA 
* 
OTHERS   CSECT 
STRMTOP  EQU   * 
STRM0    DC    A(STRM1) 
         DS    (STRMLENG-4)C 
STRM1    DC    A(STRM2) 
         DS    (STRMLENG-4)C 
STRM2    DC    A(STRM3) 
         DS    (STRMLENG-4)C 
STRM3    DC    A(STRM4) 
         DS    (STRMLENG-4)C 
STRM4    DC    A(STRM5) 
         DS    (STRMLENG-4)C 
STRM5    DC    A(STRM6) 
         DS    (STRMLENG-4)C 
STRM6    DC    A(STRM7) 
         DS    (STRMLENG-4)C 
STRM7    DC    A(STRM8) 
         DS    (STRMLENG-4)C 
STRM8    DC    A(STRM9) 
         DS    (STRMLENG-4)C 
STRM9    DC    A(0) 
         DS    (STRMLENG-4)C 
STRMEND  EQU   * 
* 
TERMIBUF DS    256C 
*     
         AIF   ('&SYSTEM' NE 'MTS').NOCC
         DC    C' '           CARRIAGE CONTROL FOR TERMOBUF
.NOCC    ANOP
*
TERMOBUF DS    256C 
* 
* 
STRBUFF  DS    1000C 
BUFFSIZE EQU   1000 
* 
.END     ANOP 
         END   &START