(DECLARE
   (CODE EXPR TYPECHECK INDEXCHECK UBVCHECK UDFCHECK TLAB NLAB DISCARD NOTAG TAIL 
    DISPL LOCALS SPECIALS UNDOLIST CURRENT-FN FUNCTION-NAME CURRENT-MAX-ARG 
    PROG-LABELS END-PROG PROG-UNDO END-LOOP LOOP-UNDO LOOP-DISCARD)
   SPECIAL)
(MACRO COMPILE (FNS)
   ×(MAPCAN ',FNS
       (FUNCTION
        (LAMBDA (FN)
         (AND (DEFINEDP FN)
              (NOT (CODEP (GETD FN)))
              (PUTPROP FN (GETD FN) 'PREVIOUS-DEFINITION))
         (C:FN FN)
         ×(,FN)))))
(MACRO REVERT (FNS)
   ×(MAPCAN ',FNS
       (FUNCTION
        (LAMBDA (FN)
         (LETS ((TEMP (GET FN 'PREVIOUS-DEFINITION)))
          (COND (TEMP (PUTD FN TEMP) (REMPROP FN 'PREVIOUS-DEFINITION) ×(,FN))
                (T (FORMAT "*** PREVIOUS DEFINITION OF /S NOT FOUND" FN))))))))
(DEFUN RESET-COMPILATION-FLAGS NIL
   (DO ((L (OBLIST) (CDR L)))
       ((ATOM L))
       (REMPROP (CAR L) 'SPECIAL)
       (REMPROP (CAR L) 'REDEFINE)))
(MACRO C:GEN (L)
   ×(PROGN . ,(MAPCAR L (FUNCTION (LAMBDA (X) ×(PUSH ,X CODE))))))
(DEFUN C:INIT NIL
   (DECLARE
      (? ATTENTION-HANDLER BREAK DEFAULT-MACROTABLE DEFAULT-OBVECTOR 
       DEFAULT-READTABLE DIGITS ERR:ABEND-EXIT ERR:ARGUMENT-TYPE ERR:BUFFER-OVERFLOW 
       ERR:CATCH ERR:END-OF-FILE ERR:FLOATING-OVERFLOW ERR:FUNCTION ERR:GO 
       ERR:IMPLEMENTATION-RESTRICTION ERR:INDEX ERR:IO ERR:NUMBER-OF-ARGUMENTS 
       ERR:OPEN-CLOSE ERR:READ ERR:RETURN ERR:UNBOUND-VARIABLE ERR:UNDEFINED-FUNCTION 
       ERR:VARIABLE ERR:ZERO-DIVISION INTERN LOWER-CASE MACROTABLE MANAGER-ID 
       OBVECTOR OPENFILES PRINTLENGTH PRINTLEVEL PROMPT READTABLE SPECIAL-CHARACTERS 
       STANDARD-INPUT STANDARD-OUTPUT SYSPARM SYSTEM-NAME TERMINAL-INPUT 
       TERMINAL-OUTPUT TOPLEVEL UPPER-CASE USE-LOWER USEBQ VERSION FILE-SEPARATOR)
      SPECIAL)
   (DECLARE
      (/+ /- * // õ ^ /1+ /1- [ \ ¡ LOGAND LOGOR LOGXOR LOGSHIFT SREF SSET VECTOR-LENGTH 
       STRING-LENGTH ATOMLENGTH)
      FIX-RESULT)
   (SETQ TYPECHECK T)
   (SETQ INDEXCHECK T)
   (SETQ UBVCHECK T)
   (SETQ UDFCHECK T))
(C:INIT)
(DEFUN C:PP (FN)
   (LETS ((DEF (MATCH (GETD FN)
                  (('LAMBDA . X) (GETD FN))
                  (('MACRO 'LAMBDA . X) (CDR (GETD FN)))
                  (X (MATCH (GET FN 'PREVIOUS-DEFINITION)
                        (('LAMBDA . X) (GET FN 'PREVIOUS-DEFINITION))
                        (('MACRO 'LAMBDA . X) (CDR (GET FN 'PREVIOUS-DEFINITION)))))))
          (CODE (C:LAMBDA DEF FN)))
    (FORMAT "FUNCTION NAME:  /S   MAXIMUM # OF ARG:  /S/N" FN (CAR CODE))
    (MAPC (CDR (LOW-LEVEL-OPTIMIZE CODE))
       (FUNCTION
        (LAMBDA (X) (COND ((ATOM X) (TAB 1) (PRINC X)) (T (TAB '15) (PRIND X))))))
    NIL))
(DEFUN C:FN (FUNCTION-NAME)
   (COND ((NOT (DEFINEDP FUNCTION-NAME)) (C:ERR "NOT FUNCTION NAME" FUNCTION-NAME))
         (T (LETS ((DEF (GETD FUNCTION-NAME)))
             (COND ((AND (ATOM DEF) (ATOM (SETQ DEF (GET FUNCTION-NAME 'PREVIOUS-DEFINITION))))
                    (C:ERR "NOT INTERPRETIVE FUNC OR MACRO" FUNCTION-NAME))
                   ((EQ (CAR DEF) 'LAMBDA)
                    (PUTD FUNCTION-NAME
                          (LOAD-CODE
                             (PUTPROP FUNCTION-NAME
                                (C:LAP ×(,FUNCTION-NAME . ,(LOW-LEVEL-OPTIMIZE (C:LAMBDA DEF FUNCTION-NAME))))
                                'COMPILED-CODE))))
                   ((EQ (CAR DEF) 'MACRO)
                    (AND (OR (ATOM (CDR DEF)) (NEQ (CADR DEF) 'LAMBDA))
                         (OR (ATOM (SETQ DEF (GET FUNCTION-NAME 'PREVIOUS-DEFINITION)))
                             (ATOM (CDR DEF))
                             (NEQ (CADR DEF) 'LAMBDA))
                         (C:ERR "NOT INTERPRETIVE MACRO" FUNCTION-NAME))
                    (PUTD FUNCTION-NAME
                          ×(MACRO . 
                            ,(LOAD-CODE
                                (CDR (PUTPROP FUNCTION-NAME
                                        ×(MACRO . 
                                          ,(C:LAP ×(,FUNCTION-NAME . ,(LOW-LEVEL-OPTIMIZE (C:LAMBDA (CDR DEF) FUNCTION-NAME)))))
                                        'COMPILED-CODE))))))
                   (T (C:ERR "ILLEGAL FUNCTION NAME" FUNCTION-NAME)))))))
(DEFUN C:LAMBDA (DEF (CURRENT-FN))
   (COND ((ATOM (CDR DEF)) (C:ERR "ILLEGAL LAMBDA FORM" DEF))
         (T (LETS ((FORMALS (SECOND DEF)) (BODY (CDDR DEF)) (LOCALS) (CODE) (DISPL 12) (UNDOLIST) 
                   (PROG-LABELS) (CURRENT-MAX-ARG (LENGTH FORMALS)))
             (C:FORMALS FORMALS)
             (C:LOAD-A-REG (C:SEQ BODY NIL NIL NIL NIL T))
             (C:UNDO-UPTO NIL)
             (C:GEN '(BR E))
             ×(,CURRENT-MAX-ARG . ,(POST-PROCESS (NREVERSE CODE)))))))
(DEFUN C:FORMALS (FORMALS)
   (DO ((L FORMALS (CDR L)) (FLAG NIL))
       ((ATOM L))
       (COND ((CONSP (CAR L))
              (SETQ FLAG T)
              (C:GEN ×(ST Z (,DISPL SB)))
              (PUSH ×(,(CAAR L) . ,DISPL) LOCALS)
              (C:VARCHECK (CAAR L)))
             (T (C:GEN '(B PARAMERR))
                (PUSH ×(,(CAR L) . ,DISPL) LOCALS)
                (C:VARCHECK (CAR L))
                (AND FLAG (C:ERR "ILLEGAL LAMBDA LIST" FORMALS))))
       (INCR DISPL 4))
   (DO ((L (REVERSE LOCALS) (CDR L)) (F FORMALS (CDR F)))
       ((NULL L))
       (AND (CONSP (CAR F))
            (LETS ((LAB (GENSYM "BIND")))
             (C:GEN ×(C Z (,(CDAR L) SB))
                    ×(BNE ,LAB)
                    ×(ST ,(SECOND (C:LOAD-TO-REG (C:SEQ (CDAR F)))) (,(CDAR L) SB))
                    LAB)))
       (AND (GET (CAAR L) 'SPECIAL) (C:BIND (CAAR L) (CDAR L)))))
(DEFUN C:PROGN (ARGS)
   (COND ((ATOM ARGS) '(CONST NIL))
         (T (DO ((L ARGS (CDR L)))
                ((ATOM (CDR L)) (C:EVAL-AGAIN (CAR L)))
                (C:EVAL (CAR L) NIL NIL T)))))
(DEFUN C:SEQ (ARGS (TLAB) (NLAB) (DISCARD) (NOTAG) (TAIL))
   (COND ((ATOM ARGS) '(CONST NIL))
         (T (DO ((L ARGS (CDR L)))
                ((ATOM (CDR L)) (C:EVAL-AGAIN (CAR L)))
                (C:EVAL (CAR L) NIL NIL T)))))
(DEFUN C:VARCHECK (VAR) (OR (SYMBOLP VAR) (C:ERR "INVALID VARIABLE" VAR)))
(DEFUN C:DECLARE (X (TYPE 'SPECIAL)) (PUTPROP X T TYPE))
(DEFUN C:EVAL (EXPR (TLAB) (NLAB) (DISCARD) (NOTAG) (TAIL))
   (COND ((EQ EXPR 'C:ALREADY-EVALUATED-FORM) '(ONREG A))
         ((ATOM EXPR) (C:EVATOM EXPR))
         ((SYMBOLP (CAR EXPR)) (C:APSY (CAR EXPR) (CDR EXPR)))
         ((ATOM (CAR EXPR)) (C:ERR "ILLEGAL FUNCTION" (CAR EXPR)))
         ((EQ (CAAR EXPR) 'LAMBDA) (C:APLAMBDA (CAR EXPR) (CDR EXPR)))
         (T (C:ERR "ILLEGAL FUNCTION" (CAR EXPR)))))
(DEFUN C:EVAL-AGAIN (EXPR) (C:EVAL EXPR TLAB NLAB DISCARD NOTAG TAIL))
(DEFUN C:EVATOM (ATOM)
   (COND ((SYMBOLP ATOM)
          (COND ((GET ATOM 'SPECIAL) ×(SPECIAL ,ATOM))
                ((MEMQ ATOM '(T NIL)) ×(CONST ,ATOM))
                (T (LETS ((TEMP (ASSQ ATOM LOCALS)))
                    (COND ((NULL TEMP) (C:WARN "ASSUMED SPECIAL" ATOM) (C:DECLARE ATOM) ×(SPECIAL ,ATOM))
                          (T ×(LOCAL ,(CDR TEMP))))))))
         (T ×(CONST ,ATOM))))
(DEFUN C:APSY (FN ARGS)
   (LETS ((LENG (LENGTH ARGS)))
    (COND ((EQ FN CURRENT-FN)
           (OR (<= LENG CURRENT-MAX-ARG) (C:ERR "TOO MANY ARGS" FN))
           (COND ((AND TAIL (NULL UNDOLIST))
                  (C:TAIL-CALL-EXPAND ARGS LENG)
                  (C:GEN ×(B (,(/+ 16 (* 4 LENG)) CB)))
                  '(NOVALUE))
                 (T (LETS ((LAB (GENSYM "REC")) (BASE DISPL) (DISPL (/+ DISPL 12)))
                     (C:GEN ×(LA L ,LAB) ×(STM CB L (,BASE SB)))
                     (MAPC ARGS (FUNCTION C:EVAL-PUSH))
                     (C:GEN ×(LA SB (,BASE SB)) ×(B (,(/+ 16 (* 4 LENG)) CB)) LAB)
                     '(ONREG A)))))
          ((AND (GET FN 'C:APFN) (NOT (GET FN 'REDEFINE)))
           (FUNCALL (GET FN 'C:APFN) ARGS FN))
          ((AND (DEFINEDP FN) (CONSP (GETD FN)) (EQ (CAR (GETD FN)) 'MACRO))
           (C:EVAL-AGAIN (FUNCALL (CDR (GETD FN)) ARGS)))
          ((AND (DEFINEDP FN)
                (CODEP (GETD FN))
                (PREDEFINEDP (GETD FN))
                (NOT (GET FN 'REDEFINE)))
           (C:CALLCD FN ARGS LENG)
           '(ONREG A))
          (T (OR (DEFINEDP FN) (C:WARN "ASSUMED NON-MACRO" FN))
             (C:EXPAND ARGS)
             (C:CALLSY FN LENG)
             '(ONREG A)))))
(DEFUN C:CALLSY (FN LENG)
   (C:LOAD-CONST 'NA (* 4 LENG))
   (C:GEN ×(L A ',FN))
   (C:SYSCALL 'FUNCALSY))
(DEFUN C:CALLCD (FN ARGS LENG)
   (OR (<= (MINARG (GETD FN)) LENG (MAXARG (GETD FN)))
       (/0> (MAXARG (GETD FN)))
       (C:NARGERR))
   (COND ((AND TAIL (NULL UNDOLIST))
          (C:TAIL-CALL-EXPAND ARGS LENG)
          (C:GEN ×(L CB (DEFOF ,FN)))
          (COND ((/0> (MAXARG (GETD FN))) (C:LOAD-CONST 'NA (* 4 LENG)) (C:GEN '(B (16 CB))))
                (T (C:GEN ×(B (,(/+ 16 (* 4 LENG)) CB))))))
         (T (C:EXPAND ARGS)
            (C:LOAD-CONST 'NA (* 4 LENG))
            (C:GEN ×(L A (DEFOF ,FN)))
            (C:SYSCALL 'FUNCALCD))))
(DEFUN C:SYSCALL (SYSENT (ISTAIL TAIL))
   (C:GEN ×(LA NB (,DISPL SB)))
   (COND ((AND ISTAIL (NULL UNDOLIST)) (C:GEN '(LR L E) ×(B ,SYSENT)))
         (T (C:GEN ×(BAL L ,SYSENT)))))
(DEFUN C:APLAMBDA (FN ARGS)
   (AND (ATOM (CDR FN)) (C:ERR "ILLEGAL FUNCTION" FN))
   (LETS ((FORMALS (CADR FN)) (BODY (CDDR FN)) (VDISPL DISPL) (DISPL DISPL) 
          (LOCALS LOCALS) (UNDOLIST UNDOLIST) (SAVE UNDOLIST))
    (MAPC ARGS (FUNCTION C:EVAL-PUSH))
    (LOOP (AND (ATOM FORMALS) (EXIT))
          (AND (ATOM ARGS) (EXIT))
          (POP ARGS)
          (C:BIND (POP FORMALS) VDISPL)
          (INCR VDISPL 4))
    (AND (CONSP ARGS) (C:ERR "TOO MANY ARGS" FN))
    (LOOP (AND (ATOM FORMALS) (EXIT))
          (LETS ((FORMAL (POP FORMALS)))
           (COND ((ATOM FORMAL) (C:ERR "TOO FEW ARGS" FN))
                 (T (C:PUSH (C:SEQ (CDR FORMAL))) (C:BIND (CAR FORMAL) (/- DISPL 4))))))
    (C:LOAD-A-REG (C:PROGN BODY))
    (C:UNDO-UPTO SAVE)
    '(ONREG A)))
(DEFUN C:EXPAND (ARGS)
   (LETS ((DISPL DISPL))
    (COND ((EVERY ARGS (FUNCTION C:EASY?)) (INCR DISPL 12)) (T (C:MARK)))
    (MAPC ARGS (FUNCTION C:EVAL-PUSH))))
(DEFUN C:MARK NIL (C:GEN ×(STM 0 2 (,DISPL SB))) (INCR DISPL 12))
(DEFUN C:TAIL-CALL-EXPAND (ARGS LENG)
   (OR (ATOM ARGS)
       (DO ((L ARGS (CDR L)) (DISPL DISPL) (FIRST DISPL))
           ((OR (ATOM (CDR L)) (AND (ATOM (CDDR L)) (C:EASY? (SECOND L))))
            (COND ((ATOM (CDR L))
                   (C:EVAL-LOAD-A (FIRST L))
                   (COND ((<= LENG 4)
                          (COND ((= LENG 1))
                                ((= LENG 2) (C:GEN ×(L D (,FIRST SB))))
                                (T (C:GEN ×(LM ,(/- 10 LENG) 8 (,FIRST SB)))))
                          (COND ((EQ LENG 1) (C:GEN '(ST 9 (12 SB))))
                                (T (C:GEN ×(STM ,(/- 10 LENG) 9 (12 SB))))))
                         (T (C:GEN ×(MVC ,(* 4 (/1- LENG)) (12 SB) (,FIRST SB))
                                   ×(ST A (,(/+ 12 (* 4 (/1- LENG))) SB))))))
                  (T (C:LOAD-D-A (FIRST L) (SECOND L))
                     (COND ((<= LENG 4)
                            (COND ((= LENG 2))
                                  ((= LENG 3) (C:GEN ×(L NA (,FIRST SB))))
                                  (T (C:GEN ×(LM ,(/- 10 LENG) 7 (,FIRST SB)))))
                            (C:GEN ×(STM ,(/- 10 LENG) 9 (12 SB))))
                           (T (C:GEN ×(MVC ,(* 4 (/- LENG 2)) (12 SB) (,FIRST SB))
                                     ×(STM D A (,(/+ 12 (* 4 (/- LENG 2))) SB))))))))
           (C:EVAL-PUSH (CAR L)))))
(DEFUN C:PUSH (STATE)
   (C:GEN ×(ST ,(SECOND (C:LOAD-TO-REG STATE)) (,DISPL SB)))
   (INCR DISPL 4))
(DEFUN C:EVAL-PUSH (FORM) (C:PUSH (C:EVAL FORM)))
(DEFUN C:PUSH-REG (REG) (C:GEN ×(ST ,REG (,DISPL SB))) (INCR DISPL 4))
(DEFUN C:PUSH-SAVING (FORM REG)
   (COND ((C:EASY? FORM)
          (COND ((EQ REG 'A) (C:EVAL-LOAD-D FORM) (C:PUSH-REG 'D))
                (T (C:EVAL-PUSH FORM))))
         (T (C:PUSH-REG REG)
            (COND ((EQ REG 'A) (C:EVAL-LOAD-D FORM) (C:POP-TO 'A) (C:PUSH-REG 'D))
                  (T (C:EVAL-LOAD-A FORM) (C:POP-TO REG) (C:PUSH-REG 'A))))))
(DEFUN C:STORE (VAR (REG 'A))
   (COND ((GET VAR 'SPECIAL) (C:GEN ×(L W ',VAR) ×(ST ,REG (0 W))))
         (T (LETS ((TEMP (ASSQ VAR LOCALS)))
             (COND (TEMP (C:GEN ×(ST ,REG (,(CDR TEMP) SB))))
                   (T (C:WARN "ASSUMED SPECIAL" VAR)
                      (C:DECLARE VAR)
                      (C:GEN ×(L W ',VAR) ×(ST ,REG (0 W)))))))))
(DEFUN C:GEN-POP (OP REG) (C:GEN ×(,OP ,REG (,(DECR DISPL 4) SB))))
(DEFUN C:GEN-OP (OP REG STATE)
   (MATCH STATE
      (('CONST Y)
       (COND ((NULL Y)
              (C:GEN ×(,(CDR (ASSQ OP
                                '((L . LR) (A . AR) (AL . ALR) (S . SR) (SL . SLR) (C . CR) (CL . CLR) (M . MR) 
                                  (D . DR) (N . NR) (O . OR) (STATE . XR))))
                       ,REG
                       N)))
             (T (C:GEN ×(,OP ,REG ',Y)))))
      (('CODE Y) (C:GEN ×(,OP ,REG ,STATE)))
      (('LOCAL Y) (C:GEN ×(,OP ,REG (,Y SB))))
      (('SPECIAL Y) (C:GEN ×(L D ',Y)) (C:UBVCHECK-D) (C:GEN ×(,OP ,REG (0 D))))
      (('CAROF Y)
       (COND ((C:EASY-ACCESS? Y) (C:LOAD-D-REG Y) (C:CONSCHECK-D) (C:GEN ×(,OP ,REG (4 D))))
             (T (C:GEN ×(,OP ,REG (4 ,(C:LOAD-CONS Y)))))))
      (('CDROF Y)
       (COND ((C:EASY-ACCESS? Y) (C:LOAD-D-REG Y) (C:CONSCHECK-D) (C:GEN ×(,OP ,REG (0 D))))
             (T (C:GEN ×(,OP ,REG (0 ,(C:LOAD-CONS Y)))))))
      (Y (C:GEN ×(,(CDR (ASSQ OP
                           '((L . LR) (A . AR) (AL . ALR) (S . SR) (SL . SLR) (C . CR) (CL . CLR) (M . MR) 
                             (D . DR) (N . NR) (O . OR) (STATE . XR))))
                  ,REG
                  ,(SECOND (C:LOAD-TO-REG Y)))))))
(DEFUN C:POP-TO (REG)
   (DECR DISPL 4)
   (C:GEN ×(L ,REG (,DISPL SB)))
   ×(ONREG ,REG))
(COMMENT BINDINGS)
(DEFUN C:BIND (VAR VDISPL)
   (COND ((NOT (OR (SYMBOLP VAR) (AND (CONSP VAR) (SYMBOLP (SETQ VAR (CAR VAR))))))
          (C:ERR "ILLEGAL LAMBDA VAR" VAR))
         ((GET VAR 'SPECIAL) (C:GEN ×(L A (,VDISPL SB))) (C:BIND-SPECIAL VAR 'A))
         (T (PUSH ×(,VAR . ,VDISPL) LOCALS))))
(DEFUN C:BIND-INIT (VAR VALUE)
   (COND ((NOT (SYMBOLP VAR)) (C:ERR "ILLEGAL VARIABLE" VAR))
         ((GET VAR 'SPECIAL) (C:BIND-SPECIAL VAR (SECOND (C:LOAD-TO-REG VALUE))))
         (T (PUSH ×(,VAR . ,DISPL) LOCALS) (C:PUSH VALUE))))
(DEFUN C:BIND-SPECIAL (VAR REG)
   (PUSH DISPL UNDOLIST)
   (C:GEN ×(L WW ',VAR)
          '(L W (0 WW))
          ×(STM W WW (,DISPL SB))
          ×(MVI (,(/+ DISPL 4) SB) 176)
          ×(LA NB (,(/+ DISPL 8) SB))
          '(ST NB BINDTOP)
          ×(ST ,REG (0 WW)))
   (INCR DISPL 8))
(COMMENT UNDO)
(DEFUN C:UNDO-UPTO (OLD)
   (COND ((EQ UNDOLIST OLD))
         (T (DO ((L UNDOLIST (CDR L)))
                ((EQ (CDR L) OLD)
                 (C:GEN ×(LM W WW (,(CAR L) SB)) '(ST W (0 WW)))
                 (C:GEN ×(LA NB (,(CAR L) SB)) '(ST NB BINDTOP)))
                (C:GEN ×(LM W WW (,(CAR L) SB)) '(ST W (0 WW)))))))
(COMMENT LOAD)
(DEFUN C:LOAD-TO-REG (STATE)
   ×(ONREG ,(MATCH STATE
               (('CONST Y) (COND ((NULL Y) 'N) (T (C:GEN ×(L A ',Y)) 'A)))
               (('CODE Y) (C:GEN ×(L A ,STATE)) 'A)
               (('LOCAL Y) (C:GEN ×(L A (,Y SB))) 'A)
               (('SPECIAL Y) (C:GEN ×(L A ',Y)) (C:UBVCHECK-A) (C:GEN '(L A (0 A))) 'A)
               (('CC Y) (C:LOAD-CC Y))
               (('ISNULL Y) (C:LOAD-CC (LOGXOR (C:MAKE-CC Y) 15)))
               (('ISATOM Y) (C:LOAD-CC (C:ISATOM-CC Y)))
               (('ONREG Y) Y)
               (('CAROF Y) (C:GEN ×(L A (4 ,(C:LOAD-CONS Y)))) 'A)
               (('CDROF Y) (C:GEN ×(L A (0 ,(C:LOAD-CONS Y)))) 'A)
               (('NOVALUE) 'A)
               (Y (C:SYSERR STATE)))))
(DEFUN C:MAKE-CC (STATE)
   (MATCH STATE
      (('CONST Y) (COND ((NULL Y) 15) (T 0)))
      (('CODE Y) 0)
      (('LOCAL Y) (C:GEN ×(C N (,Y SB))) 8)
      (('SPECIAL Y) (C:GEN ×(L A ',Y)) (C:UBVCHECK-A) (C:GEN '(C N (0 A))) 8)
      (('CC Y) Y)
      (('ONREG Y) (COND ((EQ Y 'N) 15) (T (C:GEN ×(CR N ,Y)) 8)))
      (('ISNULL Y) (LOGXOR 15 (C:MAKE-CC Y)))
      (('ISATOM Y) (C:ISATOM-CC Y))
      (('CAROF Y) (C:GEN ×(C N (4 ,(C:LOAD-CONS Y)))) 8)
      (('CDROF Y) (C:GEN ×(C N (0 ,(C:LOAD-CONS Y)))) 8)
      (('NOVALUE) 0)
      (Y (C:SYSERR Y))))
(DEFUN C:ISATOM-CC (STATE)
   (MATCH STATE
      (('CONST Y) (COND ((ATOM Y) 0) (T 15)))
      (('CODE Y) 0)
      (('ISATOM Y) 0)
      (('ISNULL Y) 0)
      (('CC Y) 0)
      (Y (C:GEN-OP 'C 'Z Y) 2)))
(DEFUN C:EQ (X) (C:GEN-OP 'C 'A X) '(CC 7))
(DEFUN C:LOAD-CONST (REG N)
   (COND ((/0= N) (C:GEN ×(LR ,REG Z)))
         ((= N 4) (C:GEN ×(LR ,REG F)))
         (T (C:GEN ×(LA ,REG (,N 0))))))
(DEFUN C:LOAD-CC (CC)
   (COND ((EQ CC 15) 'N)
         ((/0= CC) (C:GEN '(L A 'T)) 'A)
         (T (LETS ((LAB (GENSYM "CC"))) (C:GEN '(LR A N) ×(BC ,CC ,LAB) '(L A 'T) LAB))
            'A)))
(DEFUN C:LOAD-CONS (STATE)
   (LETS ((REG (SECOND (C:LOAD-TO-REG STATE))))
    (COND ((EQ REG 'N) (C:ERR "CAR/CDR OF AN ATOM" NIL) 'N)
          (TYPECHECK (C:GEN ×(IFATOM ,REG TYPERR)) REG)
          (T REG))))
(DEFUN C:LOAD-A-REG (STATE)
   (LETS ((TEMP (C:LOAD-TO-REG STATE)))
    (AND (NEQ (SECOND TEMP) 'A) (C:GEN ×(LR A ,(SECOND TEMP))))
    '(ONREG A)))
(DEFUN C:LOAD-D-REG (STATE) (C:GEN-OP 'L 'D STATE))
(DEFUN C:EVAL-LOAD-A (FORM) (C:LOAD-A-REG (C:EVAL FORM)))
(DEFUN C:EVAL-LOAD-D (FORM) (C:LOAD-D-REG (C:EVAL FORM)))
(DEFUN C:LOAD-A-D (FORM1 FORM2)
   (COND ((C:EASY? FORM2) (C:EVAL-LOAD-A FORM1) (C:EVAL-LOAD-D FORM2))
         ((C:EXCHANGE? FORM1 FORM2) (C:EVAL-LOAD-D FORM2) (C:EVAL-LOAD-A FORM1))
         (T (C:EVAL-PUSH FORM1) (C:EVAL-LOAD-D FORM2) (C:POP-TO 'A))))
(DEFUN C:LOAD-D-A (FORM1 FORM2)
   (COND ((C:EASY? FORM2)
          (COND ((C:EASY? FORM1) (C:EVAL-LOAD-D FORM1))
                (T (C:EVAL-LOAD-A FORM1) (C:GEN '(LR D A))))
          (C:EVAL-LOAD-A FORM2))
         ((C:EXCHANGE? FORM1 FORM2) (C:EVAL-LOAD-A FORM2) (C:EVAL-LOAD-D FORM1))
         (T (C:EVAL-PUSH FORM1) (C:EVAL-LOAD-A FORM2) (C:POP-TO 'D))))
(DEFUN C:CONSCHECK-A NIL (AND TYPECHECK (C:GEN '(IFATOM A TYPERR))))
(DEFUN C:CONSCHECK-D NIL (AND TYPECHECK (C:GEN '(IFATOM D TYPERRD))))
(DEFUN C:SYCHECK-A NIL (AND TYPECHECK (C:GEN '(CR A N) '(BL TYPERR))))
(DEFUN C:SYCHECK-D NIL (AND TYPECHECK (C:GEN '(CR D N) '(BL TYPERRD))))
(DEFUN C:UBVCHECK-A NIL (AND UBVCHECK (C:GEN '(CLI (0 A) 192) '(BE UBVERR))))
(DEFUN C:UBVCHECK-D NIL (AND UBVCHECK (C:GEN '(CLI (0 D) 192) '(BE UBVERRD))))
(DEFUN C:UDFCHECK-A NIL (AND UDFCHECK (C:GEN '(CLI (12 A) 192) '(BE UDFERR))))
(COMMENT ERROR:HANDLER)
(DEFUN C:WARN (MSG X)
   (FORMAT "*WARNING* /S - /C/TIN /S/N"
           X
           MSG
           55
           (COND ((BOUNDP 'FUNCTION-NAME) FUNCTION-NAME) (T '?))))
(DEFUN C:NARGERR NIL (C:ERR "MISMATCHED # OF ARGS" EXPR))
(DEFUN C:SYSERR (X) (C:ERR "COMPILER ERROR" X))
(DEFUN C:ERR (MSG X)
   (FORMAT "**ERROR** /S - /C/TIN /S/N"
           X
           MSG
           55
           (COND ((BOUNDP 'FUNCTION-NAME) FUNCTION-NAME) (T '?)))
   (BREAK))
(DEFUN C:TYPERR (X) (C:ERR "ILLEGAL TYPE OF ARGUMENT" X))
(DEFUN C:NOSIDE? (FORM)
   (OR (ATOM FORM)
       (MEMQ (CAR FORM) '(FUNCTION QUOTE))
       (AND (SYMBOLP (CAR FORM))
            (GET (CAR FORM) 'NOSIDE)
            (NOT (GET (CAR FORM) 'REDEFINE))
            (EVERY (CDR FORM) (FUNCTION C:NOSIDE?)))))
(MAPC '(ATOM EQ NEQ NULL NOT SYMBOLP CONSP CONSP NUMBERP FIXP FLOATP STRINGP VECTORP 
        REFERENCEP STREAMP CODEP EQUAL AND OR OR PROGN PROG1 PROG2 LOOP EXIT AND CR 
        CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR 
        CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR 
        CDADDR CDDAAR CDDADR CDDDAR CDDDDR FIRST SECOND THIRD FOURTH FIFTH SIXTH 
        SEVENTH /+ /- * // õ [ \ /1+ /1- < <= => > <$ <=$ =>$ >$ GREATERP LESSP /0< /0= 
        /0> /0<$ /0=$ /0>$ PLUSP ZEROP MINUSP LOGAND LOGOR LOGXOR ASSQ ASSOC MEMQ 
        MEMBER GET GETD VREF SREF DEREF CONS XCONS NCONS LIST APPEND REVERSE SUBST 
        LAST LENGTH NTH NTHCDR)
   (FUNCTION (LAMBDA (X) (PUTPROP X 'T 'NOSIDE))))
(DEFUN C:EASY? (FORM)
   (OR (ATOM FORM)
       (EQ (CAR FORM) 'QUOTE)
       (EQ (CAR FORM) 'FUNCTION)
       (AND (SYMBOLP (CAR FORM))
            (GET (CAR FORM) 'EASY)
            (NOT (GET (CAR FORM) 'REDEFINE))
            (EVERY (CDR FORM) (FUNCTION C:EASY?)))))
(DEFUN C:EASY-ACCESS? (STATE)
   (OR (MEMQ (FIRST STATE) '(CONST CODE LOCAL SPECIAL ONREG NOVALUE))
       (AND (MEMQ (FIRST STATE) '(CAROF CDROF)) (C:EASY-ACCESS? (SECOND STATE)))))
(MAPC '(CR CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR 
        CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR 
        CDADDR CDDAAR CDDADR CDDDAR CDDDDR FIRST SECOND THIRD FOURTH)
   (FUNCTION (LAMBDA (X) (PUTPROP X T 'EASY))))
(DEFUN C:CONST? (FORM)
   (COND ((ATOM FORM) (NOT (SYMBOLP FORM)))
         (T (OR (EQ (CAR FORM) 'QUOTE) (EQ (CAR FORM) 'FUNCTION)))))
(DEFUN C:EXCHANGE? (FORM1 FORM2)
   (AND (C:EASY? FORM1) (C:NOSIDE? FORM1) (OR (C:CONST? FORM1) (C:NOSIDE? FORM2))))
(DEFUN C:LOAD-FIX-A (FORM)
   (COND ((FIXP FORM)
          (COND ((<= 0 FORM 4095) (C:LOAD-CONST 'A FORM)) (T (C:EVAL-LOAD-A FORM))))
         ((SYMBOLP FORM) (C:EVAL-LOAD-A FORM) (OR (GET FORM 'FIX-VALUE) (C:FIXCHECK-A)))
         ((CONSP FORM)
          (COND ((AND (GET (CAR FORM) 'FIX-RESULT) (NOT (GET (CAR FORM) 'REDEFINE)))
                 (C:LOAD-A-REG (C:EVAL FORM NIL NIL NIL T)))
                (T (C:EVAL-LOAD-A FORM) (C:FIXCHECK-A))))
         (T (C:TYPERR FORM)))
   '(ONREG A))
(DEFUN C:PUSH-FIX (FORM)
   (C:EVAL-LOAD-A FORM)
   (OR (C:FIX-VALUE? FORM) (C:FIXCHECK-A))
   (C:PUSH-REG 'A))
(DEFUN C:GEN-FIX-OP (OP REG FORM)
   (COND ((FIXP FORM) (C:GEN ×(,OP ,REG ',FORM)))
         ((AND (SYMBOLP FORM) (GET FORM 'FIX-VALUE))
          (LETS ((TEMP (ASSQ FORM LOCALS)))
           (COND (TEMP (C:GEN ×(,OP ,REG (,(CDR TEMP) SB))))
                 (T (OR (GET FORM 'SPECIAL)
                        (PROGN (C:WARN "ASSUMED SPECIAL" FORM) (C:DECLARE FORM)))
                    (C:GEN ×(L D ',FORM))
                    (C:UBVCHECK-D)
                    (C:GEN ×(,OP ,REG (0 D)))))))
         (T (C:EVAL-LOAD-D FORM)
            (C:FIXCHECK-D)
            (C:GEN ×(,(CDR (ASSQ OP
                              '((A . AR) (AL . ALR) (S . SR) (SL . SLR) (C . CR) (CL . CLR) (M . MR) (D . DR) 
                                (N . NR) (O . OR) (X . XR))))
                     ,REG
                     D)))))
(DEFUN C:FIX-RESULT ((CONST 0))
   (COND ((<= 1 CONST 4095) (C:GEN ×(LA A (,CONST A))))
         (T (COND ((/0= CONST))
                  ((EQ CONST -4) (C:GEN '(SLR A F)))
                  ((EQ CONST -1) (C:GEN '(BCTR A 0)))
                  (T (C:GEN ×(AL A ',CONST))))
            (OR NOTAG (C:GEN '(LA A (0 A))))))
   (C:PUTTAG-A '@FIX))
(DEFUN C:FIX-VALUE? (FORM)
   (COND ((ATOM FORM) (OR (FIXP FORM) (AND (SYMBOLP FORM) (GET FORM 'FIX-VALUE))))
         ((SYMBOLP (CAR FORM))
          (AND (GET (CAR FORM) 'FIX-RESULT) (NOT (GET (CAR FORM) 'REDEFINE))))))
(DEFUN C:FIXCHECK-A NIL (AND TYPECHECK (C:GEN '(CL A @FLO) '(BNL TYPERR))))
(DEFUN C:FIXCHECK-D NIL (AND TYPECHECK (C:GEN '(CL D @FLO) '(BNL TYPERRD))))
(DEFUN C:LOAD-CHAR-A (FORM)
   (COND ((FIXP FORM)
          (COND ((<= 0 FORM 255) (C:LOAD-CONST 'A FORM)) (T (C:TYPERR FORM))))
         ((STRINGP FORM)
          (AND (/0= (STRING-LENGTH FORM)) (C:TYPERR FORM))
          (C:LOAD-CONST 'A (SREF FORM 0)))
         (T (C:EVAL-LOAD-A FORM)
            (COND ((C:FIX-VALUE? FORM) (C:CHARCHECK-A)) (T (C:CHARCOERCE)))))
   '(ONREG A))
(DEFUN C:CHARCHECK-A NIL (AND TYPECHECK (C:GEN '(C A CHARMAX) '(BNL TYPERR))))
(DEFUN C:CHARCOERCE NIL
   (LETS ((LAB1 (GENSYM "CHAR")) (LAB2 (GENSYM "CHAR")))
    (C:GEN '(CR A N)
           ×(BL ,LAB1)
           '(L A (4 A))
           LAB1
           '(CLM A 8 @STRING)
           ×(BNE ,LAB2)
           '(C Z (0 A))
           '(BE TYPERR)
           '(IC A (4 A))
           '(N A '255)
           '(O A @FIX)
           LAB2))
   (C:CHARCHECK-A))
(DEFUN C:STRING-VALUE? (FORM)
   (COND ((ATOM FORM) (STRINGP FORM))
         ((SYMBOLP (CAR FORM))
          (AND (GET (CAR FORM) 'STRING-RESULT)
               (NOT (GET (CAR FORM) 'REDEFINE))
               (EVERY (CDR FORM) (FUNCTION C:STRING-VALUE?))))))
(MAPC '(PNAME SUBSTRING STRING-APPEND STRING-AMEND STRING-AMEND-AND STRING-AMEND-AND 
        STRING-AMEND-XOR MAKE-STRING STRING-REVERSE STRING-NREVERSE)
   (FUNCTION (LAMBDA (X) (PUTPROP X T 'STRING-RESULT))))
(DEFUN C:STRINGCHECK-A NIL
   (LETS ((LAB (GENSYM "STR")))
    (C:GEN '(CR A N) ×(BL ,LAB) '(L A (4 A)) LAB)
    (AND TYPECHECK (C:GEN '(CLM A 8 @STRING) '(BNE TYPERR)))))
(DEFUN C:STRINGCHECK-D NIL
   (LETS ((LAB (GENSYM "STR")))
    (C:GEN '(CR D N) ×(BL ,LAB) '(L D (4 D)) LAB)
    (AND TYPECHECK (C:GEN '(CLM D 8 @STRING) '(BNE TYPERRD)))))
(DEFUN C:VECTORCHECK-A NIL
   (AND TYPECHECK (C:GEN '(CLM A 8 @VECTOR) '(BNE TYPERR))))
(DEFUN C:VECTORCHECK-D NIL
   (AND TYPECHECK (C:GEN '(CLM D 8 @VECTOR) '(BNE TYPERRD))))
(DEFUN C:REFCHECK-A NIL
   (AND TYPECHECK (C:GEN '(CLM A 8 @REFER) '(BNE TYPERR))))
(DEFUN C:REFCHECK-D NIL
   (AND TYPECHECK (C:GEN '(CLM D 8 @REFER) '(BNE TYPERRD))))
(DEFUN C:INDEXCHECK (STRREG INDREG)
   (AND INDEXCHECK (C:GEN ×(C ,INDREG (0 ,STRREG)) '(BNL INDEXERR))))
(DEFUN C:PUTTAG-A (TAG) (OR NOTAG (C:GEN ×(O A ,TAG))))
(DEFUN C:JMP (TO) (C:GEN ×(BC 15 ,TO)))
(DEFUN C:JT (X TO)
   (LETS ((CC (/- 15 (C:MAKE-CC X)))) (OR (/0= CC) (C:GEN ×(BC ,CC ,TO)))))
(DEFUN C:JN (X TO)
   (LETS ((CC (C:MAKE-CC X))) (OR (/0= CC) (C:GEN ×(BC ,CC ,TO)))))
(COMMENT "C..R")
(DEFUN C:CARCDR (ARGS FN)
   (MATCH ARGS
      ((ARG)
       (DO ((X (C:EVAL ARG)
               ×(,(COND ((EQ (SREF PN I) (CHARACTER "A")) 'CAROF) (T 'CDROF)) ,X))
            (PN (PNAME FN))
            (I (/- (STRING-LENGTH FN) 2) (/1- I)))
           ((/0= I) X)))
      (X (C:NARGERR))))
(MAPC '(CR CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR 
        CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR 
        CDADDR CDDAAR CDDADR CDDDAR CDDDDR)
   (FUNCTION (LAMBDA (X) (PUTPROP X (FUNCTION C:CARCDR) 'C:APFN))))
(DEFPROP FIRST (LAMBDA (ARGS FN) (C:APSY 'CAR ARGS)) C:APFN)
(DEFPROP SECOND (LAMBDA (ARGS FN) (C:APSY 'CADR ARGS)) C:APFN)
(DEFPROP THIRD (LAMBDA (ARGS FN) (C:APSY 'CADDR ARGS)) C:APFN)
(DEFPROP FOURTH (LAMBDA (ARGS FN) (C:APSY 'CADDDR ARGS)) C:APFN)
(DEFPROP QUOTE
   (LAMBDA (ARGS FN) (MATCH ARGS ((X) ×(CONST ,X)) (X (C:NARGERR))))
   C:APFN)
(DEFPROP FUNCTION
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((('LAMBDA . X)) ×(CODE (NIL . ,(LOW-LEVEL-OPTIMIZE (C:LAMBDA (CAR ARGS))))))
       ((X) ×(CONST ,X))
       (X (C:NARGERR))))
   C:APFN)
(DEFPROP COMMENT (LAMBDA (ARGS FN) '(CONST NIL)) C:APFN)
(DEFPROP AND
   (LAMBDA (ARGS FN)
    (COND ((ATOM ARGS) '(CONST T))
          (T (DO ((LAST (OR NLAB (GENSYM "END-AND")))
                  (NEXT (GENSYM FN) (GENSYM FN))
                  (L ARGS (CDR L)))
                 ((ATOM (CDR L))
                  (LETS ((X (C:EVAL (CAR L) TLAB LAST)))
                   (COND (NLAB X)
                         (TLAB (C:JT X TLAB) (C:GEN LAST) '(CONST NIL))
                         (DISCARD (C:GEN LAST) '(NOVALUE))
                         (T (C:LOAD-A-REG X) (C:JMP NEXT) (C:GEN LAST '(LR A N) NEXT) '(ONREG A)))))
                 (C:JN (C:EVAL (CAR L) NEXT LAST) LAST)
                 (C:GEN NEXT)))))
   C:APFN)
(DEFPROP OR
   (LAMBDA (ARGS FN)
    (COND ((ATOM ARGS) '(CONST NIL))
          (T (DO ((LAST (GENSYM "END-OR")) (NEXT (GENSYM FN) (GENSYM FN)) (L ARGS (CDR L)))
                 ((ATOM (CDR L))
                  (LETS ((X (C:EVAL (CAR L) TLAB NLAB)))
                   (COND (TLAB X) (T (OR DISCARD (C:LOAD-A-REG X)) (C:GEN LAST) '(ONREG A)))))
                 (LETS ((X (C:EVAL (CAR L) TLAB NEXT)))
                  (COND (TLAB (C:JT X TLAB))
                        (T (C:JT (COND (DISCARD X) (T (C:LOAD-A-REG X))) LAST))))
                 (C:GEN NEXT)))))
   C:APFN)
(DEFPROP COND
   (LAMBDA (ARGS FN)
    (DO ((LAST (GENSYM "END-COND"))
         (THIS (GENSYM FN) (GENSYM FN))
         (NEXT (GENSYM FN) (GENSYM FN))
         (L ARGS (CDR L)))
        ((ATOM L)
         (COND (NLAB (C:JMP NLAB)) ((NOT DISCARD) (C:GEN '(LR A N))))
         (C:GEN LAST)
         '(ONREG A))
        (MATCH (CAR L)
           ((PRED)
            (C:JT (COND (DISCARD (C:EVAL PRED TLAB NEXT))
                        (T (C:LOAD-A-REG (C:EVAL PRED TLAB NEXT))))
                  (OR TLAB LAST)))
           ((PRED . BODY) (C:JN (C:EVAL PRED THIS NEXT) NEXT) (C:GEN THIS) 
            (COND (DISCARD (C:PROGN BODY)) (T (C:LOAD-A-REG (C:PROGN BODY)))) (C:JMP LAST))
           (X (C:ERR "ILLEGAL COND CLAUSE" X)))
        (C:GEN NEXT)))
   C:APFN)
(DEFPROP ATOM
   (LAMBDA (ARGS FN) (MATCH ARGS ((ARG) ×(ISATOM ,(C:EVAL ARG))) (X (C:NARGERR))))
   C:APFN)
(DEFPROP CONSP
   (LAMBDA (ARGS FN)
    (MATCH ARGS ((ARG) ×(ISNULL (ISATOM ,(C:EVAL ARG)))) (X (C:NARGERR))))
   C:APFN)
(PUTPROP 'LISTP (GET 'CONSP 'C:APFN) 'C:APFN)
(DEFUN C:TYPEP (ARGS TYPETAG TAGADDR)
   (MATCH ARGS
      ((ARG)
       (COND ((SYMBOLP ARG)
              (COND ((EQ ARG 'C:ALREADY-EVALUATED-FORM) (C:GEN ×(CLM A 8 ,TAGADDR)))
                    ((ASSQ ARG LOCALS) (C:GEN ×(CLI (,(CDR (ASSQ ARG LOCALS)) SB) ,TYPETAG)))
                    (T (OR (GET ARG 'SPECIAL) (PROGN (C:WARN "ASSUMED SPECIAL" ARG) (C:DECLARE ARG)))
                       (C:GEN ×(L A ',ARG))
                       (C:UBVCHECK-A)
                       (C:GEN ×(CLI (0 A) ,TYPETAG)))))
             (T (C:EVAL-LOAD-A ARG) (C:GEN ×(CLM A 8 ,TAGADDR)))))
      (X (C:NARGERR)))
   '(CC 7))
(DEFPROP FIXP (LAMBDA (ARGS FN) (C:TYPEP ARGS 16 '@FIX)) C:APFN)
(DEFPROP SYMBOLP (LAMBDA (ARGS FN) (C:TYPEP ARGS 112 '@SYMBOL)) C:APFN)
(DEFPROP FLOATP (LAMBDA (ARGS FN) (C:TYPEP ARGS 24 '@FLOAT)) C:APFN)
(DEFPROP REFERENCEP (LAMBDA (ARGS FN) (C:TYPEP ARGS 32 '@REFER)) C:APFN)
(DEFPROP VECTORP (LAMBDA (ARGS FN) (C:TYPEP ARGS 48 '@VECTOR)) C:APFN)
(DEFPROP STRINGP (LAMBDA (ARGS FN) (C:TYPEP ARGS 64 '@STRING)) C:APFN)
(DEFPROP STREAMP (LAMBDA (ARGS FN) (C:TYPEP ARGS 80 '@STREAM)) C:APFN)
(DEFPROP CODEP (LAMBDA (ARGS FN) (C:TYPEP ARGS 96 '@CODE)) C:APFN)
(DEFPROP BOUNDP
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((ARG) (C:EVAL-LOAD-A ARG) (C:SYCHECK-A) (C:GEN '(CLI (0 A) 192)))
       (X (C:NARGERR)))
    '(CC 8))
   C:APFN)
(DEFPROP DEFINEDP
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((ARG) (C:EVAL-LOAD-A ARG) (C:SYCHECK-A) (C:GEN '(CLI (12 A) 192)))
       (X (C:NARGERR)))
    '(CC 8))
   C:APFN)
(DEFPROP GETD
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X) (C:EVAL-LOAD-A X) (C:SYCHECK-A) (C:UDFCHECK-A) (C:GEN '(L A (12 A))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP PNAME
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X) (C:EVAL-LOAD-A X) (C:SYCHECK-A) (C:GEN '(L A (4 A))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP DEREF
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X)
        (C:EVAL-LOAD-A X)
        (LETS ((LAB1 (GENSYM FN)) (LAB2 (GENSYM FN)))
         (C:GEN '(CR A N) ×(BNL ,LAB1))
         (C:REFCHECK-A)
         (C:GEN ×(B ,LAB2) LAB1)
         (C:UBVCHECK-A)
         (C:GEN LAB2 '(L A (0 A)))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP SETREF
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y) (C:LOAD-D-A X Y) (C:REFCHECK-D) (C:GEN '(ST A (0 A))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP REFERENCE
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (C:LOAD-D-A X Y)
        (C:VECTORCHECK-D)
        (OR (C:FIX-VALUE? Y) (C:FIXCHECK-A))
        (C:GEN '(LA X (0 A A)) '(ALR X X))
        (C:INDEXCHECK 'D 'X)
        (C:GEN '(LA A (4 X D)))
        (C:PUTTAG-A '@REFER))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP STRING-LENGTH
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X)
        (C:EVAL-LOAD-A X)
        (OR (C:STRING-VALUE? X) (C:STRINGCHECK-A))
        (C:GEN '(L A (0 A)))
        (C:PUTTAG-A '@FIX))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP VECTOR-LENGTH
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X)
        (C:EVAL-LOAD-A X)
        (C:VECTORCHECK-A)
        (C:GEN '(L A (0 A)) '(SRL A (2 0)))
        (C:PUTTAG-A '@FIX))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP NULL
   (LAMBDA (ARGS FN)
    (MATCH ARGS ((ARG) ×(ISNULL ,(C:EVAL ARG NLAB TLAB))) (X (C:NARGERR))))
   C:APFN)
(PUTPROP 'NOT (GET 'NULL 'C:APFN) 'C:APFN)
(DEFPROP EQ
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (COND ((C:EASY? Y) (C:EVAL-LOAD-A X) (C:EQ (C:EVAL Y)))
              ((C:EXCHANGE? X Y) (C:EVAL-LOAD-A Y) (C:EQ (C:EVAL X)))
              (T (C:EVAL-PUSH X) (C:EVAL-LOAD-A Y) (C:GEN-POP 'C 'A) '(CC 7))))
       (X (C:NARGERR) '(NOVALUE))))
   C:APFN)
(DEFPROP EQUAL
   (LAMBDA (ARGS FN)
    (MATCH ARGS ((X Y) (C:LOAD-D-A X Y) (C:SYSCALL 'EQUAL NIL)) (X (C:NARGERR)))
    '(CC 7))
   C:APFN)
(DEFPROP NEQ
   (LAMBDA (ARGS FN) ×(ISNULL ,(FUNCALL (GET 'EQ 'C:APFN) ARGS FN)))
   C:APFN)
(DEFPROP CONS
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (COND ((C:EASY? Y) (C:LOAD-A-D X Y) (C:SYSCALL 'CONS))
              (T (C:LOAD-D-A X Y) (C:SYSCALL 'XCONS))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP XCONS
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (COND ((C:EASY? Y) (C:LOAD-A-D X Y) (C:SYSCALL 'XCONS))
              (T (C:LOAD-D-A X Y) (C:SYSCALL 'CONS))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP NCONS
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X) (C:EVAL-LOAD-A X) (C:GEN '(LR D N)) (C:SYSCALL 'CONS))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP LIST
   (LAMBDA (ARGS FN)
    (COND ((ATOM ARGS) '(CONST NIL))
          ((ATOM (CDR ARGS)) (C:APSY 'NCONS ARGS))
          ((ATOM (CDDR ARGS))
           (C:LOAD-A-D (FIRST ARGS) (SECOND ARGS))
           (C:SYSCALL 'MKLIST2)
           '(ONREG A))
          (T (DO ((SAVE DISPL) (DISPL DISPL) (L ARGS (CDR L)))
                 ((ATOM L)
                  (C:LOAD-CONST 'NA (/- DISPL SAVE))
                  (C:GEN '(LR A N))
                  (C:SYSCALL 'MKLIST)
                  '(ONREG A))
                 (C:EVAL-PUSH (CAR L))))))
   C:APFN)
(DEFPROP PROGN (LAMBDA (ARGS FN) (C:PROGN ARGS)) C:APFN)
(DEFPROP PROG1
   (LAMBDA (ARGS FN)
    (COND (DISCARD (C:SEQ ARGS NIL NIL T) '(NOVALUE))
          (T (MATCH ARGS
                ((ONE . REST) (C:EVAL-PUSH ONE) (C:SEQ REST NIL NIL T) (C:POP-TO 'A))
                (X (C:NARGERR)))
             '(ONREG A))))
   C:APFN)
(DEFPROP PROG2
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((ONE) (C:NARGERR))
       ((ONE TWO . REST) (C:EVAL-AGAIN ×(PROGN ,ONE (PROG1 . ,(CDR ARGS)))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP LOOP
   (LAMBDA (ARGS FN)
    (LETS ((END-LOOP (GENSYM "END-LOOP")) (TOP (GENSYM FN)) (LOOP-UNDO UNDOLIST) 
           (LOOP-DISCARD DISCARD))
     (C:GEN TOP)
     (C:SEQ ARGS NIL NIL T)
     (C:JMP TOP)
     (C:GEN END-LOOP)
     '(ONREG A)))
   C:APFN)
(DEFPROP EXIT
   (LAMBDA (ARGS FN)
    (OR (BOUNDP 'END-LOOP) (C:ERR "EXIT OUTSIDE LOOP" ×(,FN . ,ARGS)))
    (COND (LOOP-DISCARD (C:SEQ ARGS NIL NIL T)) (T (C:LOAD-A-REG (C:SEQ ARGS))))
    (C:UNDO-UPTO LOOP-UNDO)
    (C:JMP END-LOOP)
    '(NOVALUE))
   C:APFN)
(DEFPROP PROG
   (LAMBDA (ARGS FN)
    (LETS ((END-PROG (GENSYM "END-PROG")) (UNDO-SAVE UNDOLIST) (PROG-LABELS PROG-LABELS) 
           (DISPL DISPL) (LOCALS LOCALS))
     (DO ((L (CAR ARGS) (CDR L)))
         ((ATOM L))
         (MATCH (CAR L)
            ((VAR . INITS) (C:BIND-INIT VAR (C:SEQ INITS)))
            (VAR (C:BIND-INIT VAR '(CONST NIL)))))
     (DO ((L (CDR ARGS) (CDR L)))
         ((ATOM L))
         (AND (ATOM (CAR L)) (PUSH ×(,(CAR L) ,(GENSYM FN) ,UNDOLIST) PROG-LABELS)))
     (DO ((L (CDR ARGS) (CDR L)) (PROG-UNDO UNDOLIST))
         ((ATOM L))
         (COND ((ATOM (CAR L)) (C:GEN (SECOND (ASSQ (CAR L) PROG-LABELS))))
               (T (C:EVAL (CAR L) NIL NIL T))))
     (C:LOAD-A-REG '(CONST NIL))
     (C:GEN END-PROG)
     (C:UNDO-UPTO UNDO-SAVE)
     '(ONREG A)))
   C:APFN)
(DEFPROP RETURN
   (LAMBDA (ARGS FN)
    (C:LOAD-A-REG (C:SEQ ARGS))
    (COND ((BOUNDP 'END-PROG) (C:UNDO-UPTO PROG-UNDO) (C:JMP END-PROG))
          (T (C:ERR "RETURN OUTSIDE PROG" ×(,FN . ,ARGS))))
    '(NOVALUE))
   C:APFN)
(DEFPROP GO
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((TAG)
        (MATCH (ASSQ TAG PROG-LABELS)
           ((TAG TAG-ADDR UNDO) (C:UNDO-UPTO UNDO) (C:JMP TAG-ADDR))
           (X (C:ERR "UNDEFINED GO LABEL" TAG))))
       (X (C:NARGERR))))
   C:APFN)
(DEFPROP CATCH
   (LAMBDA (ARGS FN) (C:GEN ×(L A '(,FN . ,ARGS))) (C:SYSCALL 'EVAL) '(ONREG A))
   C:APFN)
(DEFPROP SELECTQ
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((KEY . CLAUSES) (C:EVAL-LOAD-A KEY) 
        (LETS ((END (GENSYM "END-SELECTQ")))
         (DO ((NEXT (GENSYM FN) (GENSYM FN)) (L CLAUSES (CDR L)))
             ((ATOM L))
             (MATCH (CAR L)
                ((PATTERN . BODY) 
                 (COND ((EQ PATTERN T))
                       ((ATOM PATTERN) (C:GEN ×(C A ',PATTERN) ×(BNE ,NEXT)))
                       (T (DO ((L PATTERN (CDR L)) (THIS (GENSYM FN)))
                              ((ATOM L) (C:GEN ×(B ,NEXT) THIS))
                              (C:GEN ×(C A ',(CAR L)) ×(BE ,THIS)))))
                 (COND (DISCARD (C:PROGN BODY)) (T (C:LOAD-A-REG (C:PROGN BODY)))) (C:JMP END) 
                 (C:GEN NEXT))
                (X (C:NARGERR))))
         (OR DISCARD (C:LOAD-A-REG '(CONST NIL)))
         (C:GEN END)))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP MATCH
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((KEY . CLAUSES) (C:EVAL-LOAD-D KEY) (C:GEN ×(ST D (,DISPL SB))) 
        (DO ((END (GENSYM "END-MATCH"))
             (NEXT (GENSYM FN) (GENSYM FN))
             (MATCH-UNDO UNDOLIST)
             (L CLAUSES (CDR L))
             (KEYDISPL DISPL)
             (DISPL (/+ DISPL 4)))
            ((ATOM L) (OR DISCARD (C:LOAD-A-REG '(CONST NIL))) (C:GEN END))
            (LETS ((LOCALS LOCALS) (UNDOLIST UNDOLIST) (DISPL DISPL) (SPECIALS NIL))
             (C:GEN ×(L D (,KEYDISPL SB)))
             (MATCH (CAR L)
                ((PATTERN . BODY) (C:MATCH-PATTERN PATTERN NEXT) 
                 (MAPC (NREVERSE SPECIALS)
                    (FUNCTION
                     (LAMBDA (X) (C:GEN ×(L A (,(CDR X) SB))) (C:BIND-SPECIAL (CAR X) 'A))))
                 (COND (DISCARD (C:PROGN BODY)) (T (C:LOAD-A-REG (C:PROGN BODY)))) 
                 (C:UNDO-UPTO MATCH-UNDO) (C:JMP END))
                (X (C:TYPERR X)))
             (C:GEN NEXT))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFUN C:MATCH-PATTERN (PATTERN FAILLAB)
   (COND ((NULL PATTERN) (C:GEN '(CR D N) ×(BNE ,FAILLAB)))
         ((SYMBOLP PATTERN)
          (C:GEN ×(ST D (,DISPL SB)))
          (COND ((GET PATTERN 'SPECIAL) (PUSH ×(,PATTERN . ,DISPL) SPECIALS))
                (T (PUSH ×(,PATTERN . ,DISPL) LOCALS)))
          (INCR DISPL 4))
         ((ATOM PATTERN) (C:GEN ×(C D ',PATTERN) ×(BNE ,FAILLAB)))
         ((AND (EQ (CAR PATTERN) 'QUOTE) (CONSP (CDR PATTERN)) (NULL (CDDR PATTERN)))
          (C:GEN ×(C D ',(SECOND PATTERN)) ×(BNE ,FAILLAB)))
         (T (DO ((L PATTERN (CDR L)) (SAVE))
                ((ATOM L) (C:MATCH-PATTERN L FAILLAB))
                (C:GEN ×(IFATOM D ,FAILLAB) '(LM D A (0 D)))
                (COND ((NULL (CAR L)) (C:GEN '(CR A N) ×(BNE ,FAILLAB)))
                      ((SYMBOLP (CAR L))
                       (C:GEN ×(ST A (,DISPL SB)))
                       (COND ((GET (CAR L) 'SPECIAL) (PUSH ×(,(CAR L) . ,DISPL) SPECIALS))
                             (T (PUSH ×(,(CAR L) . ,DISPL) LOCALS)))
                       (INCR DISPL 4))
                      ((ATOM (CAR L)) (C:GEN ×(C A ',(CAR L)) ×(BNE ,FAILLAB)))
                      ((AND (EQ (CAAR L) 'QUOTE) (CONSP (CDAR L)) (NULL (CDDAR L)))
                       (C:GEN ×(C A ',(SECOND (CAR L))) ×(BNE ,FAILLAB)))
                      (T (C:GEN ×(ST D (,(OR SAVE (PROG1 (SETQ SAVE DISPL) (INCR DISPL 4))) SB))
                                '(LR D A))
                         (C:MATCH-PATTERN (CAR L) FAILLAB)
                         (C:GEN ×(L D (,SAVE SB)))))))))
(DEFPROP SETQ
   (LAMBDA (ARGS FN)
    (COND ((ATOM ARGS) '(CONST NIL))
          ((ODDP (LENGTH ARGS)) (C:NARGERR) '(NOVALUE))
          ((EQ (LENGTH ARGS) 4)
           (C:LOAD-D-A (SECOND ARGS) (FOURTH ARGS))
           (C:STORE (FIRST ARGS) 'D)
           (C:STORE (THIRD ARGS) 'A)
           '(ONREG A))
          (T (DO ((L (CDDR ARGS) (CDDR L))
                  (VAR (FIRST ARGS) (FIRST L))
                  (VALUE (SECOND ARGS) (SECOND L))
                  (VARS NIL ×(,VAR . ,VARS)))
                 ((ATOM L)
                  (LETS ((X (C:LOAD-TO-REG (C:EVAL VALUE))))
                   (C:STORE VAR (SECOND X))
                   (MAPC VARS (FUNCTION (LAMBDA (X) (C:POP-TO 'WW) (C:STORE X 'WW))))
                   X))
                 (C:EVAL-PUSH VALUE)))))
   C:APFN)
(DEFPROP SET
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y) (C:LOAD-D-A X Y) (C:SYCHECK-D) (C:GEN '(ST A (0 D))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP /1+
   (LAMBDA (ARGS FN)
    (MATCH ARGS ((X) (C:LOAD-FIX-A X) (C:FIX-RESULT 1)) (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP /1-
   (LAMBDA (ARGS FN)
    (MATCH ARGS ((X) (C:LOAD-FIX-A X) (C:FIX-RESULT -1)) (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP NCONC
   (LAMBDA (ARGS FN)
    (COND ((ATOM ARGS) '(CONST NIL))
          (T (MATCH ARGS
                ((X) (C:EVAL-AGAIN X))
                ((X Y)
                 (C:LOAD-A-D X Y)
                 (LETS ((LAB1 (GENSYM FN)) (LAB2 (GENSYM FN)) (LAB3 (GENSYM FN)))
                  (C:GEN '(LTR X A)
                         ×(BM ,LAB2)
                         '(LR A D)
                         ×(B ,LAB3)
                         LAB1
                         '(L X (0 X))
                         LAB2
                         '(C Z (0 X))
                         ×(BH ,LAB1)
                         '(ST D (0 X))
                         LAB3))
                 '(ONREG A))
                (ARGS (C:CALLCD FN ARGS (LENGTH ARGS)) '(ONREG A))))))
   C:APFN)
(DEFPROP APPEND
   (LAMBDA (ARGS FN)
    (COND ((ATOM ARGS) '(CONST NIL))
          ((ATOM (CDR ARGS)) (C:EVAL-AGAIN (CAR ARGS)))
          (T (LETS ((FIRST DISPL) (DISPL DISPL))
              (DO NIL ((ATOM (CDDR ARGS))) (C:EVAL-PUSH (POP ARGS)))
              (C:LOAD-D-A (FIRST ARGS) (SECOND ARGS))
              (C:GEN ×(LA NB (,DISPL SB)) '(LCR NA NB))
              (DO ((I FIRST (/+ I 4))) ((EQ I DISPL)) (C:GEN ×(L W (,I SB))) (C:EXPAND-LIST))
              (C:GEN '(LR W D))
              (C:EXPAND-LIST)
              (C:GEN '(ALR NA NB) '(BAL L MKLIST))
              '(ONREG A)))))
   C:APFN)
(DEFUN C:EXPAND-LIST NIL
   (LETS ((LAB1 (GENSYM "EXPAND")) (LAB2 (GENSYM "EXPAND")))
    (C:GEN ×(IFATOM W ,LAB2)
           LAB1
           '(LM W WW (0 W))
           '(ST WW (0 NB))
           '(INCRSP)
           ×(BXLE W Z ,LAB1)
           LAB2)))
(DEFPROP LENGTH
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X)
        (LETS ((LAB1 (GENSYM FN)) (LAB2 (GENSYM FN)))
         (C:EVAL-LOAD-D X)
         (C:GEN '(LR A Z)
                ×(IFATOM D ,LAB2)
                LAB1
                '(LA A (1 A))
                '(L D (0 D))
                ×(BXLE D Z ,LAB1)
                LAB2)
         (C:PUTTAG-A '@FIX)))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP LAST
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X)
        (LETS ((LAB1 (GENSYM FN)) (LAB2 (GENSYM FN)))
         (C:EVAL-LOAD-A X)
         (C:GEN '(IFATOM A TYPERR)
                LAB1
                '(L D (0 A))
                ×(IFATOM D ,LAB2)
                '(L A (0 D))
                ×(BXLE A Z ,LAB1)
                '(LR A D)
                LAB2)))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP NREVERSE
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X)
        (LETS ((LAB1 (GENSYM FN)) (LAB2 (GENSYM FN)))
         (C:EVAL-LOAD-A X)
         (C:GEN ×(IFATOM A ,LAB2)
                '(LR D N)
                LAB1
                '(L W (0 A))
                '(ST D (0 A))
                '(LR D A)
                '(LR A W)
                ×(BXLE A Z ,LAB1)
                '(LR A D)
                LAB2)))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP EVAL
   (LAMBDA (ARGS FN)
    (MATCH ARGS ((X) (C:EVAL-LOAD-A X) (C:SYSCALL 'EVAL)) (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP FUNCALL
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((F) (C:EVAL-LOAD-A F) (C:GEN '(LR NA Z)) (C:SYSCALL 'FUNCALL))
       ((F . AS) 
        (COND ((EVERY ARGS (FUNCTION C:NOSIDE?))
               (C:EXPAND AS)
               (C:EVAL-LOAD-A F)
               (C:LOAD-CONST 'NA (* (LENGTH AS) 4))
               (C:SYSCALL 'FUNCALL))
              (T (C:EVAL-PUSH F)
                 (C:EXPAND AS)
                 (C:GEN ×(L A (,(/- DISPL 4) SB)))
                 (C:LOAD-CONST 'NA (* 4 (LENGTH AS)))
                 (C:SYSCALL 'FUNCALL)
                 (DECR DISPL 4))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP RPLACA
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X 'NIL) (C:EVAL-LOAD-A X) (C:CONSCHECK-A) (C:GEN '(ST N (4 A))))
       ((X Y) (C:LOAD-A-D X Y) (C:CONSCHECK-A) (C:GEN '(ST D (4 A))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP RPLACD
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X 'NIL) (C:EVAL-LOAD-A X) (C:CONSCHECK-A) (C:GEN '(ST N (0 A))))
       ((X Y) (C:LOAD-A-D X Y) (C:CONSCHECK-A) (C:GEN '(ST D (0 A))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP PUSH
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((VALUE VAR)
        (OR (SYMBOLP VAR) (C:TYPERR VAR))
        (C:LOAD-A-D VALUE VAR)
        (C:SYSCALL 'CONS NIL)
        (C:STORE VAR 'A))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP POP
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((VAR)
        (C:EVAL-LOAD-A VAR)
        (C:CONSCHECK-A)
        (COND (DISCARD (C:GEN '(L D (0 A)))) (T (C:GEN '(LM D A (0 A)))))
        (C:STORE VAR 'D))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP MEMQ
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (COND ((AND TLAB
                    (CONSP Y)
                    (EQ (CAR Y) 'QUOTE)
                    (NULL (CDDR Y))
                    (< (LENGTH (SECOND Y)) 7))
               (C:EVAL-LOAD-A X)
               (DO ((L (SECOND Y) (CDR L))) ((ATOM L)) (C:GEN ×(C A ',(CAR L)) ×(BE ,TLAB)))
               '(CONST NIL))
              (T (C:LOAD-D-A X Y)
                 (LETS ((LAB1 (GENSYM FN)) (LAB2 (GENSYM FN)) (LAB3 (GENSYM FN)))
                  (C:GEN ×(IFATOM A ,(OR NLAB LAB2))
                         LAB1
                         '(C D (4 A))
                         ×(BE ,(OR TLAB LAB3))
                         '(L A (0 A))
                         ×(BXLE A Z ,LAB1)
                         LAB2)
                  (COND (NLAB (C:GEN ×(B ,NLAB))) ((NOT DISCARD) (C:GEN '(LR A N))))
                  (C:GEN LAB3))
                 '(ONREG A))))
       (X (C:NARGERR))))
   C:APFN)
(DEFPROP ASSQ
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (C:LOAD-A-D X Y)
        (LETS ((LAB1 (GENSYM FN)) (LAB2 (GENSYM FN)) (LAB3 (GENSYM FN)))
         (C:GEN ×(IFATOM D ,(OR NLAB LAB2))
                '(LR W A)
                LAB1
                '(LM D A (0 D))
                '(C W (4 A))
                ×(BE ,(OR TLAB LAB3))
                ×(BXLE D Z ,LAB1)
                LAB2)
         (COND (NLAB (C:JMP NLAB)) ((NOT DISCARD) (C:GEN '(LR A N))))
         (C:GEN LAB3)))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP /+
   (LAMBDA (ARGS FN)
    (COND ((EVERY ARGS (FUNCTION FIXP)) ×(CONST ,(APPLY FN ARGS)))
          (T (DO ((L ARGS (CDR L)) (CONST 0) (FIRST DISPL))
                 ((EVERY (CDR L) (FUNCTION C:EASY?))
                  (C:LOAD-FIX-A (POP L))
                  (DO NIL ((EQ DISPL FIRST)) (C:GEN-POP 'AL 'A))
                  (DO ((L L (CDR L)))
                      ((ATOM L))
                      (COND ((FIXP (CAR L)) (INCR CONST (CAR L))) (T (C:GEN-FIX-OP 'AL 'A (CAR L)))))
                  (C:FIX-RESULT CONST))
                 (COND ((FIXP (CAR L)) (INCR CONST (CAR L))) (T (C:PUSH-FIX (CAR L)))))
             '(ONREG A))))
   C:APFN)
(DEFPROP /-
   (LAMBDA (ARGS FN)
    (COND ((ATOM ARGS) (C:NARGERR) '(NOVALUE))
          ((ATOM (CDR ARGS))
           (COND ((FIXP (CAR ARGS)) ×(CONST ,(/- (CAR ARGS))))
                 (T (C:LOAD-FIX-A (CAR ARGS)) (C:GEN '(LCR A A)) (C:FIX-RESULT) '(ONREG A))))
          (T (LETS ((CONST 0) (OLD DISPL) (DISPL DISPL))
              (COND ((EVERY (CDR ARGS) (FUNCTION C:EASY?)) (C:LOAD-FIX-A (POP ARGS)))
                    (T (C:PUSH-FIX (CAR ARGS))
                       (DO ((L (CDR ARGS) (CDR L)))
                           ((EVERY L (FUNCTION C:EASY?)) (SETQ ARGS L))
                           (COND ((FIXP (CAR L)) (DECR CONST (CAR L))) (T (C:PUSH-FIX (CAR L)))))
                       (C:GEN ×(L A (,OLD SB)))
                       (DO ((I (/+ OLD 4) (/+ I 4))) ((EQ I DISPL)) (C:GEN ×(SL A (,I SB))))))
              (DO ((L ARGS (CDR L)))
                  ((ATOM L))
                  (COND ((FIXP (CAR L)) (DECR CONST (CAR L))) (T (C:GEN-FIX-OP 'SL 'A (CAR L)))))
              (C:FIX-RESULT CONST)
              '(ONREG A)))))
   C:APFN)
(DEFPROP *
   (LAMBDA (ARGS FN)
    (COND ((EVERY ARGS (FUNCTION FIXP)) ×(CONST ,(APPLY FN ARGS)))
          (T (DO ((L ARGS (CDR L)) (CONST 1) (FIRST DISPL))
                 ((EVERY (CDR L) (FUNCTION C:EASY?))
                  (C:LOAD-FIX-A (POP L))
                  (DO NIL ((EQ DISPL FIRST)) (C:GEN-POP 'M 'D))
                  (DO ((L L (CDR L)))
                      ((ATOM L))
                      (COND ((FIXP (CAR L)) (SETQ CONST (* (CAR L) CONST)))
                            (T (C:GEN-FIX-OP 'M 'D (CAR L)))))
                  (COND ((EQ CONST 1))
                        ((EQ CONST -1) (C:GEN '(LCR A A)))
                        ((EQ CONST 2) (C:GEN '(ALR A A)))
                        ((EQ CONST 4) (C:GEN '(SLL A (2 0))))
                        (T (C:GEN ×(M D ',CONST))))
                  (C:FIX-RESULT))
                 (COND ((FIXP (CAR L)) (SETQ CONST (* (CAR L) CONST))) (T (C:PUSH-FIX (CAR L)))))
             '(ONREG A))))
   C:APFN)
(DEFPROP //
   (LAMBDA (ARGS FN)
    (COND ((ATOM ARGS) (C:NARGERR) '(NOVALUE))
          (T (LETS ((CONST 1) (OLD DISPL) (DISPL DISPL))
              (COND ((EVERY (CDR ARGS) (FUNCTION C:EASY?)) (C:LOAD-FIX-A (POP ARGS)))
                    (T (C:PUSH-FIX (CAR ARGS))
                       (DO ((L (CDR ARGS) (CDR L)))
                           ((EVERY L (FUNCTION C:EASY?)) (SETQ ARGS L))
                           (COND ((FIXP (CAR L)) (SETQ CONST (* CONST (CAR L)))) (T (C:PUSH-FIX (CAR L)))))
                       (C:GEN ×(L A (,OLD SB)))
                       (DO ((I (/+ OLD 4) (/+ I 4)))
                           ((EQ I DISPL))
                           (C:GEN '(SLDL D (40 0))
                                  '(SRDA D (40 0))
                                  ×(L W (,I SB))
                                  '(SLL W (8 0))
                                  '(SRA W (8 0))
                                  '(DR D W)))))
              (DO ((L ARGS (CDR L)))
                  ((ATOM L))
                  (COND ((FIXP (CAR L)) (SETQ CONST (* CONST (CAR L))))
                        (T (C:EVAL-LOAD-D (CAR L))
                           (OR (C:FIX-VALUE? (CAR L)) (C:FIXCHECK-D))
                           (C:GEN '(LR W D)
                                  '(SLL W (8 0))
                                  '(SRA W (8 0))
                                  '(SLDL D (40 0))
                                  '(SRDA D (40 0))
                                  '(DR D W)))))
              (COND ((EQ CONST 1))
                    ((EQ CONST -1) (C:GEN '(LCR A A)))
                    (T (COND ((<= 0 CONST 4095) (C:LOAD-CONST 'W CONST))
                             (T (C:GEN ×(L W ',CONST) '(SLL W (8 0)) '(SRA W (8 0)))))
                       (C:GEN '(SLDL D (40 0)) '(SRDA D (40 0)) '(DR D W))))
              (C:FIX-RESULT)
              '(ONREG A)))))
   C:APFN)
(DEFPROP õ
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (C:LOAD-A-D X Y)
        (OR (C:FIX-VALUE? X) (C:FIXCHECK-A))
        (OR (C:FIX-VALUE? Y) (C:FIXCHECK-D))
        (C:GEN '(LR W D)
               '(SLL W (8 0))
               '(SRA W (8 0))
               '(SLDL D (40 0))
               '(SRDL D (40 0))
               '(DR D W)
               '(LR A D))
        (C:FIX-RESULT))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(PUTPROP '[ (GET 'õ 'C:APFN) 'C:APFN))
(PUTPROP '\ (GET 'õ 'C:APFN) 'C:APFN))
(DEFPROP LOGAND
   (LAMBDA (ARGS FN)
    (COND ((EVERY ARGS (FUNCTION FIXP)) ×(CONST ,(APPLY FN ARGS)))
          (T (DO ((L ARGS (CDR L)) (CONST -1) (FIRST DISPL))
                 ((EVERY (CDR L) (FUNCTION C:EASY?))
                  (C:LOAD-FIX-A (POP L))
                  (DO NIL ((EQ DISPL FIRST)) (C:GEN-POP 'N 'A))
                  (DO ((L L (CDR L)))
                      ((ATOM L))
                      (COND ((FIXP (CAR L)) (SETQ CONST (LOGAND CONST (CAR L))))
                            (T (C:GEN-FIX-OP 'N 'A (CAR L)))))
                  (OR (EQ CONST -1) (C:GEN ×(N A ',CONST)))
                  (C:FIX-RESULT))
                 (COND ((FIXP (CAR L)) (SETQ CONST (LOGAND CONST (CAR L))))
                       (T (C:PUSH-FIX (CAR L)))))
             '(ONREG A))))
   C:APFN)
(DEFPROP LOGOR
   (LAMBDA (ARGS FN)
    (COND ((EVERY ARGS (FUNCTION FIXP)) ×(CONST ,(APPLY FN ARGS)))
          (T (DO ((L ARGS (CDR L)) (CONST 0) (FIRST DISPL))
                 ((EVERY (CDR L) (FUNCTION C:EASY?))
                  (C:LOAD-FIX-A (POP L))
                  (DO NIL ((EQ DISPL FIRST)) (C:GEN-POP 'O 'A))
                  (DO ((L L (CDR L)))
                      ((ATOM L))
                      (COND ((FIXP (CAR L)) (SETQ CONST (LOGOR CONST (CAR L))))
                            (T (C:GEN-FIX-OP 'O 'A (CAR L)))))
                  (OR (EQ CONST -1) (C:GEN ×(O A ',CONST)))
                  (C:FIX-RESULT 0))
                 (COND ((FIXP (CAR L)) (SETQ CONST (LOGOR CONST (CAR L))))
                       (T (C:PUSH-FIX (CAR L)))))
             '(ONREG A))))
   C:APFN)
(DEFPROP LOGXOR
   (LAMBDA (ARGS FN)
    (COND ((EVERY ARGS (FUNCTION FIXP)) ×(CONST ,(APPLY FN ARGS)))
          (T (DO ((L ARGS (CDR L)) (CONST 0) (FIRST DISPL))
                 ((EVERY (CDR L) (FUNCTION C:EASY?))
                  (C:LOAD-FIX-A (POP L))
                  (DO NIL ((EQ DISPL FIRST)) (C:GEN-POP 'X 'A))
                  (DO ((L L (CDR L)))
                      ((ATOM L))
                      (COND ((FIXP (CAR L)) (SETQ CONST (LOGXOR CONST (CAR L))))
                            (T (C:GEN-FIX-OP 'X 'A (CAR L)))))
                  (OR (EQ CONST 0) (C:GEN ×(X A ',CONST)))
                  (C:FIX-RESULT 0))
                 (COND ((FIXP (CAR L)) (SETQ CONST (LOGXOR CONST (CAR L))))
                       (T (C:PUSH-FIX (CAR L)))))
             '(ONREG A))))
   C:APFN)
(DEFUN C:COMPARE (ARGS BCC)
   (COND ((ATOM ARGS) (C:NARGERR))
         ((= (LENGTH ARGS) 2)
          (C:LOAD-D-A (FIRST ARGS) (SECOND ARGS))
          (C:GEN '(SLL A (8 0)) '(SLL D (8 0)) '(CR D A)))
         (T (DO ((L ARGS (CDR L)))
                ((ATOM (CDR L)))
                (OR (FIXP (CAR L)) (C:PUSH-FIX (CAR L))))
            (C:LOAD-FIX-A (CAR (LAST ARGS)))
            (C:GEN '(SLL A (8 0)))
            (DO ((L (CDR (REVERSE ARGS)) (CDR L)) (LAB (GENSYM "COMPARE")))
                ((ATOM L) (C:GEN LAB))
                (C:GEN '(LR D A))
                (COND ((FIXP (CAR L)) (C:LOAD-FIX-A (CAR L))) (T (C:POP-TO 'A)))
                (C:GEN '(SLL A (8 0)) '(CR A D))
                (OR (ATOM (CDR L)) (C:GEN ×(BC ,BCC ,(OR NLAB LAB)))))))
   ×(CC ,BCC))
(DEFPROP > (LAMBDA (ARGS FN) (C:COMPARE ARGS 13)) C:APFN)
(DEFPROP >= (LAMBDA (ARGS FN) (C:COMPARE ARGS 4)) C:APFN)
(DEFPROP <= (LAMBDA (ARGS FN) (C:COMPARE ARGS 2)) C:APFN)
(DEFPROP < (LAMBDA (ARGS FN) (C:COMPARE ARGS 11)) C:APFN)
(DEFUN C:TEST (ARGS BCC)
   (MATCH ARGS
      ((X) (C:LOAD-FIX-A X) (C:GEN '(SLL A (8 0)) '(LTR A A)))
      (X (C:NARGERR)))
   ×(CC ,BCC))
(DEFPROP /0= (LAMBDA (ARGS FN) (C:TEST ARGS 7)) C:APFN)
(DEFPROP /0< (LAMBDA (ARGS FN) (C:TEST ARGS 13)) C:APFN)
(DEFPROP /0> (LAMBDA (ARGS FN) (C:TEST ARGS 11)) C:APFN)
(DEFPROP GET
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (C:LOAD-A-D X Y)
        (C:SYCHECK-A)
        (C:GEN '(L X (8 A)))
        (OR DISCARD NLAB (C:GEN '(LR A N)))
        (LETS ((LAB1 (GENSYM FN)) (LAB2 (GENSYM FN)) (LAB3 (GENSYM FN)))
         (C:GEN ×(IFATOM X ,(OR NLAB LAB3))
                LAB1
                '(LM X NA (0 X))
                '(CR D NA)
                ×(BE ,LAB2)
                ×(IFATOM X ,(OR NLAB LAB3))
                '(L X (0 X))
                ×(IFLIST X ,LAB1)
                ×(B ,(OR NLAB LAB3))
                LAB2)
         (OR DISCARD (C:GEN ×(IFATOM X ,(OR NLAB LAB3)) '(L A (4 X))))
         (C:GEN LAB3)))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP SREF
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (COND ((AND (FIXP Y) (NOT INDEXCHECK))
               (C:EVAL-LOAD-D X)
               (OR (C:STRING-VALUE? X) (C:STRINGCHECK-D))
               (COND ((<= 0 Y 4091) (C:GEN '(L A @FIX) ×(IC A (,(/+ Y 4) D))))
                     (T (C:GEN ×(L X ',Y) '(L A @FIX) '(IC A (4 X D))))))
              (T (C:LOAD-D-A X Y)
                 (OR (C:FIX-VALUE? Y) (C:FIXCHECK-A))
                 (OR (C:STRING-VALUE? X) (C:STRINGCHECK-D))
                 (C:GEN '(LA X (0 A)))
                 (C:INDEXCHECK 'D 'X)
                 (C:GEN '(L A @FIX) '(IC A (4 X D))))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP VREF
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y)
        (COND ((AND (FIXP Y) (NOT INDEXCHECK))
               (C:EVAL-LOAD-A X)
               (C:VECTORCHECK-A)
               (COND ((<= 0 Y 1022) (C:GEN ×(L A (,(/+ (* 4 Y) 4) A))))
                     (T (C:GEN ×(L X ',(* 4 Y)) '(L A (4 X A))))))
              (T (C:LOAD-D-A X Y)
                 (OR (C:FIX-VALUE? Y) (C:FIXCHECK-A))
                 (C:VECTORCHECK-D)
                 (C:GEN '(LA X (0 A A)) '(ALR X X))
                 (C:INDEXCHECK 'D 'X)
                 (C:GEN '(L A (4 X D))))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP SSET
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y Z)
        (C:LOAD-D-A X Y)
        (OR (C:FIX-VALUE? Y) (C:FIXCHECK-A))
        (OR (C:STRING-VALUE? X) (C:STRINGCHECK-D))
        (C:GEN '(LA X (0 A)))
        (C:INDEXCHECK 'D 'X)
        (COND ((AND DISCARD (FIXP Z) (< 0 Z 255) (FIXP Y) (<= 0 Y 4091))
               (C:GEN ×(MVI (,(/+ 4 Y) D) ,Z)))
              ((C:EASY? Z) (C:LOAD-CHAR-A Z) (C:GEN '(STC A (4 X D))) (C:PUTTAG-A '@FIX))
              (T (C:GEN ×(STM D A (,DISPL SB)))
                 (INCR DISPL 8)
                 (C:LOAD-CHAR-A Z)
                 (C:GEN ×(LM X NA (,(DECR DISPL 8) SB)) '(STC A (4 X NA)))
                 (C:PUTTAG-A '@FIX))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP VSET
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((X Y Z)
        (COND ((AND (FIXP Y) (NOT INDEXCHECK))
               (C:LOAD-D-A X Z)
               (C:VECTORCHECK-D)
               (COND ((<= 0 Y 1022) (C:GEN ×(ST A (,(/+ (* Y 4) 4) D))))
                     (T (C:GEN ×(L X ',(* Y 4)) '(ST A (4 X D))))))
              (T (C:LOAD-D-A X Y)
                 (OR (C:FIX-VALUE? Y) (C:FIXCHECK-A))
                 (C:VECTORCHECK-D)
                 (C:GEN '(LA X (0 A A)) '(ALR X X))
                 (C:INDEXCHECK 'D 'X)
                 (COND ((C:EASY? Z) (C:EVAL-LOAD-A Z) (C:GEN '(ST A (4 X D))))
                       (T (C:GEN ×(ST D (,DISPL SB)) ×(ST X (,(/+ DISPL 4) SB)))
                          (INCR DISPL 8)
                          (C:EVAL-LOAD-A Z)
                          (C:GEN ×(LM X NA (,(DECR DISPL 8) SB)) '(ST A (4 X NA))))))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFUN C:STRING-COMPARE (ARGS BCC)
   (MATCH ARGS
      ((X Y)
       (C:LOAD-A-D X Y)
       (OR (C:STRING-VALUE? X) (C:STRINGCHECK-A))
       (OR (C:STRING-VALUE? Y) (C:STRINGCHECK-D))
       (C:GEN '(L NA (0 A)) '(LA X (4 A)) '(L A (0 D)) '(LA D (4 D)) '(CLCL X D)))
      (X (C:NARGERR)))
   ×(CC ,BCC))
(DEFPROP STRING-EQUAL (LAMBDA (ARGS FN) (C:STRING-COMPARE ARGS 7)) C:APFN)
(DEFPROP STRING-LESSP (LAMBDA (ARGS FN) (C:STRING-COMPARE ARGS 11)) C:APFN)
(DEFPROP CHARACTER
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((('QUOTE X))
        (COND ((FIXP X) (OR (<= 0 X 255) (C:TYPERR X)) ×(CONST ,X))
              ((OR (SYMBOLP X) (STRINGP X))
               (AND (/0= (STRING-LENGTH X)) (C:TYPERR X))
               ×(CONST ,(SREF X 0)))
              (T (C:TYPERR X))))
       ((X)
        (COND ((FIXP X) (OR (<= 0 X 255) (C:TYPERR X)) ×(CONST ,X))
              ((STRINGP X) (AND (/0= (STRING-LENGTH X)) (C:TYPERR X)) ×(CONST ,(SREF X 0)))
              (T (C:LOAD-CHAR-A X))))
       (X (C:NARGERR))))
   C:APFN)
(DEFUN C:EXPAND-MAP (ARGS TAKECAR DISPOSAL)
   (MATCH ARGS
      ((L F)
       (LETS ((LAB1 (GENSYM "MAP")) (LAB2 (GENSYM "MAP")) (RESULT-POS DISPL) (FUNCPOS) 
              (DISPL DISPL))
        (C:EVAL-LOAD-A L)
        (SELECTQ DISPOSAL
           (DISCARD (OR DISCARD (C:PUSH-REG 'A)))
           (CONS (C:PUSH-REG 'N))
           (NCONC (C:GEN ×(ST N (,DISPL SB)) ×(ST N (,(/+ DISPL 4) SB))) (INCR DISPL 8)))
        (OR (C:CONST? F) (PROGN (SETQ FUNCPOS DISPL) (C:PUSH-SAVING F 'A)))
        (C:GEN ×(IFATOM A ,LAB2)
               LAB1
               (COND (TAKECAR '(LM D A (0 A))) (T '(L D (0 A)))))
        (C:PUSH-REG 'D)
        (LETS ((RESULT (C:APPLY (OR FUNCPOS ×(,F)) NIL NIL (EQ DISPOSAL 'DISCARD))))
         (SELECTQ DISPOSAL
            (CONS (C:LOAD-A-REG RESULT)
                  (C:GEN ×(L D (,RESULT-POS SB)))
                  (C:SYSCALL 'CONS NIL)
                  (C:GEN ×(ST A (,RESULT-POS SB))))
            (NCONC (C:LOAD-A-REG RESULT)
                   (LETS ((L1 (GENSYM "MAP")) (L2 (GENSYM "MAP")) (L3 (GENSYM "MAP")) 
                          (L4 (GENSYM "MAP")))
                    (C:GEN ×(IFATOM A ,L4)
                           ×(L X (,(/+ RESULT-POS 4) SB))
                           ×(IFLIST X ,L2)
                           ×(ST A (,RESULT-POS SB))
                           ×(B ,L3)
                           L1
                           '(L X (0 X))
                           L2
                           '(C Z (0 X))
                           ×(BH ,L1)
                           '(ST A (0 X))
                           L3
                           ×(ST A (,(/+ RESULT-POS 4) SB))
                           L4)))
            (DISCARD)))
        (C:POP-TO 'A)
        (C:GEN ×(BXLE A Z ,LAB1) LAB2)
        (SELECTQ DISPOSAL
           (DISCARD (OR DISCARD (C:GEN ×(L A (,RESULT-POS SB)))))
           (NCONC (C:GEN ×(L A (,RESULT-POS SB))))
           (CONS (LETS ((L1 (GENSYM "MAP")) (L2 (GENSYM "MAP")))
                  (C:GEN ×(L D (,RESULT-POS SB))
                         '(LR A N)
                         ×(IFATOM D ,L2)
                         L1
                         '(L X (0 D))
                         '(ST A (0 D))
                         '(LR A D)
                         '(LR D X)
                         ×(BXLE D Z ,L1)
                         L2))))))
      (X (C:NARGERR)))
   '(ONREG A))
(DEFUN C:APPLY (F (TLAB) (NLAB) (DISCARD) (NOTAG) (TAIL))
   (COND ((ATOM F)
          (C:GEN ×(ST A (,(/+ DISPL 12) SB)) '(LR NA F) ×(L A (,F SB)))
          (C:SYSCALL 'FUNCALL NIL)
          '(ONREG A))
         (T (MATCH (CAR F)
               (('FUNCTION ('LAMBDA (X) . BODY))
                (OR (ATOM X) (SETQ X (CAR X)))
                (C:VARCHECK X)
                (LETS ((DISPL DISPL) (LOCALS LOCALS) (UNDOSAVE UNDOLIST) (UNDOLIST UNDOLIST))
                 (COND ((GET X 'SPECIAL) (C:BIND-SPECIAL X 'A))
                       (T (PUSH ×(,X . ,DISPL) LOCALS) (C:PUSH-REG 'A)))
                 (PROG1 (C:SEQ BODY NIL NIL DISCARD) (C:UNDO-UPTO UNDOSAVE))))
               (('FUNCTION F)
                (COND ((NOT (SYMBOLP F))
                       (C:GEN ×(ST A (,(/+ DISPL 12) SB)) '(LR NA F) ×(L A ',F))
                       (C:SYSCALL 'FUNCALL NIL)
                       '(ONREG A))
                      ((EQ F CURRENT-FN)
                       (OR (<= 1 CURRENT-MAX-ARG) (C:ERR "TOO MANY ARGS" F))
                       (LETS ((LAB (GENSYM "REC")))
                        (C:GEN ×(LA L ,LAB)
                               ×(STM CB L (,DISPL SB))
                               ×(ST A (,(/+ DISPL 12) SB))
                               ×(LA SB (,DISPL SB))
                               ×(B (,(/+ 16 4) CB))
                               LAB)
                        '(ONREG A)))
                      ((AND (SPECIALP F) (NOT (GET F 'REDEFINE)))
                       (C:ERR "ILLEGAL FUNCTION FOR MAPPING" F))
                      ((AND (GET F 'C:APFN) (NOT (GET F 'REDEFINE)))
                       (FUNCALL (GET F 'C:APFN) '(C:ALREADY-EVALUATED-FORM) F))
                      ((AND (DEFINEDP F)
                            (CODEP (GETD F))
                            (PREDEFINEDP (GETD F))
                            (NOT (GET F 'REDEFINE)))
                       (C:CALLCD F '(C:ALREADY-EVALUATED-FORM) 1)
                       '(ONREG A))
                      (T (OR (DEFINEDP F) (C:WARN "ASSUMED NON-MACRO" F))
                         (C:GEN ×(ST A (,(/+ DISPL 12) SB)))
                         (C:CALLSY F 1)
                         '(ONREG A))))
               (F (C:GEN ×(ST A (,(/+ DISPL 12) SB)) '(LR NA F))
                  (C:EVAL-LOAD-A F)
                  (C:SYSCALL 'FUNCALL NIL)
                  '(ONREG A))))))
(DEFPROP MAP (LAMBDA (ARGS FN) (C:EXPAND-MAP ARGS NIL 'DISCARD)) C:APFN)
(DEFPROP MAPC (LAMBDA (ARGS FN) (C:EXPAND-MAP ARGS T 'DISCARD)) C:APFN)
(DEFPROP MAPLIST (LAMBDA (ARGS FN) (C:EXPAND-MAP ARGS NIL 'CONS)) C:APFN)
(DEFPROP MAPCAR (LAMBDA (ARGS FN) (C:EXPAND-MAP ARGS T 'CONS)) C:APFN)
(DEFPROP MAPCON (LAMBDA (ARGS FN) (C:EXPAND-MAP ARGS NIL 'NCONC)) C:APFN)
(DEFPROP MAPCAN (LAMBDA (ARGS FN) (C:EXPAND-MAP ARGS T 'NCONC)) C:APFN)
(DEFPROP SOME
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((L F)
        (LETS ((LOOP (GENSYM FN)) (NEXT (GENSYM FN)) (FOUND (GENSYM FN)) (END (GENSYM FN)) 
               (FUNCPOS) (DISPL DISPL))
         (C:EVAL-LOAD-D L)
         (OR (C:CONST? F) (PROGN (SETQ FUNCPOS DISPL) (C:PUSH-SAVING F 'D)))
         (LETS ((SAVE DISPL) (DISPL (/+ DISPL 4)))
          (C:GEN ×(IFLIST D ,LOOP))
          (OR NLAB DISCARD (C:GEN '(LR A N)))
          (C:GEN ×(B ,(OR NLAB END))
                 LOOP
                 (COND ((OR TLAB DISCARD) '(LM D A (0 D))) (T '(L A (4 D))))
                 ×(ST D (,SAVE SB)))
          (C:JT (C:APPLY (OR FUNCPOS ×(,F)) (OR TLAB FOUND) NEXT NIL) (OR TLAB FOUND))
          (C:GEN NEXT ×(L D (,SAVE SB)))
          (OR DISCARD TLAB (C:GEN '(L D (0 D))))
          (C:GEN ×(BXLE D Z ,LOOP))
          (OR NLAB DISCARD (C:GEN '(LR A N)))
          (C:GEN ×(B ,(OR NLAB END)) FOUND ×(L A (,SAVE SB)) END))))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)
(DEFPROP EVERY
   (LAMBDA (ARGS FN)
    (MATCH ARGS
       ((L F)
        (LETS ((LOOP (GENSYM FN)) (NEXT (GENSYM FN)) (TRUE (GENSYM FN)) (FOUND (GENSYM FN)) 
               (END (GENSYM FN)) (FUNCPOS) (DISPL DISPL))
         (C:EVAL-LOAD-D L)
         (OR (C:CONST? F) (PROGN (SETQ FUNCPOS DISPL) (C:PUSH-SAVING F 'D)))
         (C:GEN ×(IFATOM D ,(OR TLAB TRUE)) LOOP '(LM D A (0 D)))
         (C:PUSH-REG 'D)
         (LETS ((RESULT (C:APPLY (OR FUNCPOS ×(,F)) NEXT (OR NLAB FOUND) NIL)))
          (C:JN (COND ((OR TLAB DISCARD) RESULT) (T (C:LOAD-A-REG RESULT)))
                (OR NLAB END)))
         (C:GEN NEXT)
         (C:POP-TO 'D)
         (C:GEN ×(BXLE D Z ,LOOP) TRUE)
         (OR TLAB DISCARD (C:GEN '(L A 'T)))
         (C:GEN ×(B ,(OR TLAB END)) FOUND '(LR A N) END)))
       (X (C:NARGERR)))
    '(ONREG A))
   C:APFN)