(DECLARE (LABELTAB QUOTES QVECADR OBJECT CHANGES) SPECIAL)
(DEFUN POST-PROCESS (L)
(MAP (PREPROCESS L)
(FUNCTION
(LAMBDA (X) (RPLACA X (TRANS-REG (EXPAND-LAB (EXPAND-MNEM (CAR X)))))))))
(DEFUN PREPROCESS (L)
(MAPCAN L
(FUNCTION
(LAMBDA (X)
(MATCH X
(('INCRSP) (LIST '(ALR NB F) '(CLR NB SL) '(BC 11 OVFLERR)))
(('IFATOM R DEST) ×((LTR ,R ,R) (BC 11 ,DEST)))
(('IFLIST R DEST) ×((LTR ,R ,R) (BC 4 ,DEST)))
(X ×(,X)))))))
(DEFUN EXPAND-MNEM (X)
(COND ((ATOM X) X)
((GET (FIRST X) 'LAP:ABBR) (APPEND (GET (FIRST X) 'LAP:ABBR) (CDR X)))
(T X)))
(MAPC '((BR . 15) (BHR . 2) (BLR . 4) (BER . 8) (BNHR . 13) (BNLR . 11) (BNER . 7)
(BOR . 1) (BPR . 2) (BMR . 4) (BNPR . 13) (BNMR . 11) (BNZR . 7) (BZR . 8)
(BNOR . 14))
(FUNCTION (LAMBDA (X) (PUTPROP (CAR X) ×(BCR ,(CDR X)) 'LAP:ABBR))))
(MAPC '((B . 15) (BH . 2) (BL . 4) (BE . 8) (BNH . 13) (BNL . 11) (BNE . 7) (BO . 1)
(BP . 2) (BM . 4) (BNP . 13) (BNM . 11) (BNZ . 7) (BZ . 8) (BNO . 14))
(FUNCTION (LAMBDA (X) (PUTPROP (CAR X) ×(BC ,(CDR X)) 'LAP:ABBR))))
(DEFUN EXPAND-LAB (X)
(COND ((ATOM X) X)
((MATCH X
(('INCRSP) (LIST '(ALR NB F) '(CLR NB SL) '(BC 11 OVFLERR)))
(('IFATOM R DEST) ×((LTR ,R ,R) (BC 11 ,DEST)))
(('IFLIST R DEST) ×((LTR ,R ,R) (BC 4 ,DEST)))))
((EQ (CAR (GET (CAR X) 'LAP:MNEM)) 'RX)
(LETS ((TEMP (AND (SYMBOLP (THIRD X)) (GET (THIRD X) 'PREDEF-LAB))))
(COND (TEMP ×(,(FIRST X) ,(SECOND X) (,(* 4 TEMP) E))) (T X))))
((EQ (CAR (GET (CAR X) 'LAP:MNEM)) 'RS)
(LETS ((TEMP (AND (SYMBOLP (FOURTH X)) (GET (FOURTH X) 'PREDEF-LAB))))
(COND (TEMP ×(,(FIRST X) ,(SECOND X) ,(THIRD X) (,(* 4 TEMP) E))) (T X))))
(T X)))
(MAPC '((RETURN . 0) (EVAL . 4) (FUNCALL . 5) (EQUAL . 6) (CONS . 8) (XCONS . 9)
(MKLIST . 10) (MKFLOAT . 11) (MKVECTOR . 12) (MKBLOCK . 13) (MKLIST2 . 14)
(UBVERR . 16) (TYPERR . 17) (INDEXERR . 18) (UDFERR . 19) (PARAMERR . 20)
(UBVERRD . 21) (TYPERRD . 22) (OVFLERR . 23) (RECURSE . 32) (FUNCALSY . 40)
(FUNCALCD . 52) (@FIX . 64) (@FLO . 65) (@STRING . 66) (@VECTOR . 67)
(@STREAM . 68) (@REFER . 69) (@CODE . 70) (@SYMBOL . 71) (@LIST . 72)
(CHARMAX . 73) (BINDTOP . 80))
(FUNCTION (LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'PREDEF-LAB))))
(DEFUN TRANS-REG (X)
(COND ((ATOM X) X)
(T ×(,(FIRST X) . ,(MAPCAR (CDR X) (FUNCTION TRANS-OPERAND-REG))))))
(DEFUN TRANS-OPERAND-REG (X)
(COND ((NUMBERP X) X)
((ATOM X)
(LETS ((TEMP (MEMQ X '(N Z E E2 F SL X NA D A CB SB L NB W WW))))
(COND (TEMP (/- 16 (LENGTH TEMP))) (T X))))
((EQ (FIRST X) 'QUOTE) X)
(T ×(,(FIRST X) . ,(MAPCAR (CDR X) (FUNCTION TRANS-OPERAND-REG))))))
(DEFUN C:LAPERR (OP) (FORMAT "*** ASSEMBLER ERROR *** /S/N" OP) (BREAK))
(DEFUN C:LAP (L)
(LETS ((LABELTAB))
×(,(FIRST L) ,(SECOND L) . ,(LAP:PASS-TWO (CDDR L) (LAP:PASS-ONE (CDDR L))))))
(DEFUN LAP:DEF (MNEMS OPTYPE OPCODE)
(MAPC MNEMS
(FUNCTION
(LAMBDA (X) (PUTPROP X ×(,OPTYPE . ,OPCODE) 'LAP:MNEM) (INCR OPCODE 1)))))
(LAP:DEF
'(SPM BALR BCTR BCR * * SVC * * * MVCL CLCL LPR LNR LTR LCR NR CLR OR XR LR CR
AR SR MR DR ALR SLR LPDR LNDR LTDR LCDR HDR LRDR MXR MXDR LDR CDR ADR SDR MDR
DDR AWR SWR LPER LNER LTER LCER HER LRER AXR SXR LER CER AER SER MER DER AUR
SUR)
'RR
4)
(LAP:DEF
'(STH LA STC IC EX BAL BCT BC LH CH AH SH MH * CVD CVB ST * * * N CL O X L C A S
M D AL SL STD * * * * * * * LD CD AD SD MD DD AW SW STE * * * * * * * LE CE AE
SE ME DE AU SU)
'RX
64)
(LAP:DEF '(BXH BXLE) 'RS 134)
(LAP:DEF '(SRL SLL SRA SLA SRDL SLDL SRDA SLDA) 'RSS 136)
(LAP:DEF '(STM) 'RS 144)
(LAP:DEF '(TM MVI TS NI CLI OI XI) 'SI 145)
(LAP:DEF '(LM) 'RS 152)
(LAP:DEF '(CS CDS) 'RX 186)
(LAP:DEF '(CLM STCM ICM) 'RS 189)
(LAP:DEF '(MVN MVC MVZ NC CLC OC XC) 'SSL 209)
(LAP:DEF '(TR TRT ED EDMK) 'SSL 220)
(LAP:DEF '(SRP MVO PACK UNPK) 'SS 240)
(LAP:DEF '(ZAP CP AP SP MP DP) 'SS 248)
(DEFUN LAP:PASS-ONE (L)
(LETS ((PC 16))
(MAPC L
(FUNCTION
(LAMBDA (X)
(COND ((ATOM X) (PUSH ×(,X . ,PC) LABELTAB))
(T (INCR PC (GET (CAR (GET (CAR X) 'LAP:MNEM)) 'LAP:LENGTH)))))))
PC))
(MAPC '((RR . 2) (RX . 4) (RS . 4) (RSS . 4) (SI . 4) (SSL . 6) (SS . 6))
(FUNCTION (LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'LAP:LENGTH))))
(DEFUN LAP:PASS-TWO (L QVECADR)
(SETQ QVECADR (LOGAND -4 (/+ QVECADR 3)))
(LETS ((OBJECT) (QUOTES))
(MAPC L
(FUNCTION
(LAMBDA (X)
(OR (ATOM X)
(LETS ((TEMP (GET (CAR X) 'LAP:MNEM)))
(FUNCALL (GET (CAR TEMP) 'LAP:PASS2) (CDR TEMP) (CDR X)))))))
(AND (>= (/+ QVECADR (* 4 (LENGTH QUOTES))) 4096) (FORMAT "*** CODE TOO LONG"))
×(,(NREVERSE OBJECT) ,(NREVERSE QUOTES))))
(DEFPROP RR
(LAMBDA (OP ARG) (MATCH ARG ((R1 R2) (GEN-8-4-4 OP R1 R2)) (X (C:LAPERR OP))))
LAP:PASS2)
(DEFPROP RX
(LAMBDA (OP ARG)
(MATCH ARG
((R ADR) (GEN-8-4-4 OP R (LAP:INDEX ADR)) (GEN-16 (LAP:OPERAND ADR)))
(X (C:LAPERR OP))))
LAP:PASS2)
(DEFPROP RS
(LAMBDA (OP ARG)
(MATCH ARG
((R1 R2 ADR) (GEN-8-4-4 OP R1 R2) (GEN-16 (LAP:OPERAND ADR)))
(X (C:LAPERR OP))))
LAP:PASS2)
(DEFPROP RSS
(LAMBDA (OP ARG)
(MATCH ARG
((R AMNT) (GEN-8-4-4 OP R 0) (GEN-16 (LAP:OPERAND AMNT)))
(X (C:LAPERR OP))))
LAP:PASS2)
(DEFPROP SI
(LAMBDA (OP ARG)
(MATCH ARG
((ADR DATA) (GEN-8-8 OP DATA) (GEN-16 (LAP:OPERAND ADR)))
(X (C:LAPERR OP))))
LAP:PASS2)
(DEFPROP SSL
(LAMBDA (OP ARG)
(MATCH ARG
((LENGTH ADR1 ADR2)
(GEN-8-8 OP LENGTH)
(GEN-16 (LAP:OPERAND ADR1))
(GEN-16 (LAP:OPERAND ADR2)))
(X (C:LAPERR OP))))
LAP:PASS2)
(DEFPROP SS
(LAMBDA (OP ARG)
(MATCH ARG
(((ADR1 L1 B1) (ADR2 L2 B2))
(GEN-8-4-4 OP L1 L2)
(GEN-16 (LAP:OPERAND ×(,ADR1 ,B1)))
(GEN-16 (LAP:OPERAND ×(,ADR2 ,B2))))
(X (C:LAPERR OP))))
LAP:PASS2)
(DEFUN LAP:OPERAND (X)
(COND ((SYMBOLP X) (LAP:BASED 10 (CDR (ASSQ X LABELTAB))))
(T (SELECTQ (FIRST X)
'(LETS ((L (MEMBER X QUOTES)))
(LAP:BASED
10
(/+ QVECADR -4 (* 4 (LENGTH (OR L (PUSH ×',(SECOND X) QUOTES)))))))
(CODE (LAP:BASED
10
(/+ QVECADR -4 (* 4 (LENGTH (PUSH ×(LOAD-CODE ',(C:LAP (SECOND X))) QUOTES))))))
(DEFOF (LETS ((Y ×(GETD ',(SECOND X))) (L (MEMBER Y QUOTES)))
(LAP:BASED 10 (/+ QVECADR -4 (* 4 (LENGTH (OR L (PUSH Y QUOTES))))))))
(T (LAP:BASED (SECOND X) (FIRST X)))))))
(DEFUN LAP:INDEX (X) (MATCH X ((ADR BASE LAP:INDEX) LAP:INDEX) (T 0)))
(DEFUN GEN-8-4-4 (OP X Y)
(PUSH (LOGOR (LOGSHIFT OP 8) (LOGSHIFT X 4) Y) OBJECT))
(DEFUN GEN-8-8 (OP X) (PUSH (LOGOR (LOGSHIFT OP 8) X) OBJECT))
(DEFUN GEN-16 (ADR) (PUSH ADR OBJECT))
(DEFUN LAP:BASED (B ADR) (LOGOR (LOGSHIFT B 12) ADR))
(DEFUN LOW-LEVEL-OPTIMIZE (CODES)
(DO ((CHANGES NIL NIL))
((PROGN (LAP:ELIMINATE (CDR CODES) (LAP:SHORTCUT (CDR CODES))) (NOT CHANGES))
(LAP:FINAL CODES))))
(DEFMACRO DEL-SECOND (X) ×(PROGN (SETL (CDR ,X) (CDDR ,X)) (SETQ CHANGES T)))
(DEFMACRO DEL-FIRST (X) ×(PROGN (SETL (CAR ,X) (CADR ,X)) (DEL-SECOND ,X)))
(DEFUN LAP:ELIMINATE (CODES REFERRED)
(DO ((L (SOME CODES
(FUNCTION (LAMBDA (INSTR) (OR (ATOM INSTR) (NEQ (CAR INSTR) 'BC)))))
(CDR L)))
((NULL L))
(DO NIL
((OR (CONSP (CAR L)) (MEMQ (CAR L) REFERRED)))
(DEL-FIRST L)
(SETQ CHANGES T))
(OR (ATOM (CAR L))
(MATCH (CAR L)
(('BC CC LAB)
(COND ((AND (EQ CC 15) (NOT (NULL (CDR L))) (CONSP (SECOND L)))
(SETL (CDR L) (SOME (CDR L) (FUNCTION ATOM)))
(SETQ CHANGES T))
((AND (NOT (NULL (CDR L)))
(CONSP (SECOND L))
(MEMQ (CAR (SECOND L)) '(BC BCR))
(EQ (SECOND (SECOND L)) 15)
(NOT (NULL (CDDR L)))
(EQ LAB (THIRD L)))
(DEL-FIRST L)
(SETL (SECOND (FIRST L)) (/- 15 CC))
(SETQ LAB NIL)))
(COND ((AND (NOT (NULL (CDR L))) (EQ (CADR L) LAB)) (DEL-FIRST L))))
(('BCR 15 REG)
(COND ((AND (NOT (NULL (CDR L))) (CONSP (SECOND L)))
(SETL (CDR L) (SOME (CDR L) (FUNCTION ATOM)))
(SETQ CHANGES T))))))))
(DEFUN LAP:SHORTCUT (CODES)
(DO ((L CODES (CDR L)) (REFERRED))
((NULL L) REFERRED)
(OR (ATOM (CAR L))
(SELECTQ (CAAR L)
(ST (AND (CONSP (SECOND L))
(EQUAL (CDR (FIRST L)) (CDR (SECOND L)))
(MEMQ (CAR (SECOND L)) '(L ST))
(DEL-SECOND L)))
(LA (AND (ATOM (THIRD (FIRST L))) (PUSH (THIRD (FIRST L)) REFERRED)))
(BC (LETS ((LAB (THIRD (CAR L))))
(AND (ATOM LAB)
(LETS ((DEST (MEMQ LAB CODES)))
(DO NIL ((CONSP (SECOND DEST))) (POP DEST) (SETQ CHANGES T))
(MATCH (SECOND DEST)
(('BC 15 LAB)
(COND ((NEQ (THIRD (CAR L)) LAB)
(SETL (THIRD (CAR L)) LAB)
(PUSH LAB REFERRED)
(SETQ CHANGES T))
(T (PUSH (THIRD (CAR L)) REFERRED))))
(('BCR 15 REG)
(SETL (FIRST (CAR L)) 'BCR)
(SETL (THIRD (CAR L)) REG)
(SETQ CHANGES T))
(X (DO NIL
((OR (ATOM (CDR L))
(ATOM (CDR DEST))
(NOT (EQUAL (SECOND L) (SECOND DEST)))
(NOT (MEMQ (CAR (SECOND L))
'(L LA LD LDR LE LER LH LM LR MVC MVI ST STM STD STE STH)))))
(LETS ((LAB (GENSYM "OPT")) (TEMP (FIRST L)))
(SETL (CDDR DEST) ×(,LAB . ,(CDDR DEST)))
(SETQ DEST (CDDR DEST))
(SETL (FIRST L) (SECOND L))
(SETL (SECOND L) TEMP)
(POP L)
(SETQ CHANGES T)))
(SETL (THIRD (CAR L)) (FIRST DEST))
(PUSH (FIRST DEST) REFERRED)))))))
((BXH BXLE)
(LETS ((LAB (FOURTH (CAR L))))
(AND (ATOM LAB)
(LETS ((DEST (MEMQ LAB CODES)))
(DO NIL ((CONSP (SECOND DEST))) (POP DEST) (SETQ CHANGES T))
(DO NIL
((OR (ATOM (CDR L))
(ATOM (CDR DEST))
(NOT (EQUAL (SECOND L) (SECOND DEST)))
(NOT (MEMQ (CAR (SECOND L))
'(L LA LD LDR LE LER LH LM LR MVC MVI ST STM STD STE STH)))))
(LETS ((LAB (GENSYM "OPT")) (TEMP (FIRST L)))
(SETL (CDDR DEST) ×(,LAB . ,(CDDR DEST)))
(SETQ DEST (CDDR DEST))
(SETL (FIRST L) (SECOND L))
(SETL (SECOND L) TEMP)
(POP L)
(SETQ CHANGES T)))
(SETL (FOURTH (CAR L)) (FIRST DEST))
(PUSH (FIRST DEST) REFERRED)))))))))
(DEFUN LAP:FINAL (CODES)
(DO ((L CODES (CDR L)))
((ATOM (CDR L)) CODES)
(MATCH L
((('L R1 (D1 B1)) ('L R2 (D2 B2)) . REST)
(AND (NEQ R1 B1)
(EQ B1 B2)
(COND ((AND (EQ (/1+ R1) R2) (EQ (/+ D1 4) D2))
(DEL-SECOND L)
(SETL (CAR L) ×(LM ,R1 ,R2 (,D1 ,B1))))
((AND (EQ (/1- R1) R2) (EQ (/- D1 4) D2))
(DEL-SECOND L)
(SETL (CAR L) ×(LM ,R2 ,R1 (,D2 ,B1)))))))
((('ST R1 (D1 B1)) ('ST R2 (D2 B2)) . REST)
(AND (EQ B1 B2)
(COND ((AND (EQ (/1+ R1) R2) (EQ (/+ D1 4) D2))
(DEL-SECOND L)
(SETL (CAR L) ×(STM ,R1 ,R2 (,D1 ,B1))))
((AND (EQ (/1- R1) R2) (EQ (/- D1 4) D2))
(DEL-SECOND L)
(SETL (CAR L) ×(STM ,R2 ,R1 (,D2 ,B1))))))))))