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