Added header comment to lisp15.lisp

Pascal J. Bourguignon [2012-12-15 15:27]
Added header comment to lisp15.lisp
Filename
lisp15.lisp
diff --git a/lisp15.lisp b/lisp15.lisp
index e349d16..e1e7e91 100644
--- a/lisp15.lisp
+++ b/lisp15.lisp
@@ -1,29 +1,66 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(cl:in-package :common-lisp-user)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               lisp15.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    A LISP 1.5 implementation written in Common Lisp.
+;;;;    (Far from completed yet).
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2012-12-15 <PJB> Added this header.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************


-(defpackage "IBM7090"
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; IBM-7090 words and characters encoding.
+;;;
+
+(defpackage "IBM-7090"
   (:use "COMMON-LISP")
-  (:SHADOW "CODE-CHAR" "CHAR-CODE")
-  (:EXPORT "+CHARSET+"  "CODE-CHAR" "CHAR-CODE"
+  (:shadow "CODE-CHAR" "CHAR-CODE")
+  (:export "+CHARSET+"  "CODE-CHAR" "CHAR-CODE"
    "CONVERT-STRING-TO-WORDS" "CONVERT-STRING-FROM-WORDS"
-   "CONVERT-BYTES-TO-WORDS"  "CONVERT-BYTES-FROM-WORDS"))
-(cl:in-package "IBM7090")
+   "CONVERT-BYTES-TO-WORDS"  "CONVERT-BYTES-FROM-WORDS")
+  (:documentation "Implements the IBM-7090 words and character encodings."))
+(in-package "IBM-7090")


 ;; Normal encoding:
 ;;
 ;; (defparameter +charset+
-;;   "0123456789#=\"###+ABCDEFGHI%.)###-JKLMNOPQR'*### /STUVWXYZ,(###"
-;;   "Maps lisp characters to IBM7090 character code (position of the character
+;;   "0123456789#=\"###+ABCDEFGHI%.)###-JKLMNOPQRØ'*### /STUVWXYZ±,(###"
+;;   "Maps lisp characters to IBM-7090 character code (position of the character
 ;;    in the string.  Invalid character codes are denoted by '#'.")


 ;; LISP1.5 encoding:
 (defparameter +charset+
-  "0123456789#=\"###+ABCDEFGHI%.)###-JKLMNOPQR$*### /STUVWXYZ,(###"
-  "Maps lisp characters to IBM7090 character code (position of the character
+  "0123456789#=\"###+ABCDEFGHI%.)###-JKLMNOPQRØ$*### /STUVWXYZ±,(###"
+  "Maps lisp characters to IBM-7090 character code (position of the character
    in the string.  Invalid character codes are denoted by '#'.")


@@ -46,7 +83,7 @@ NOTE:   An error is raised if not (every (function char-code)
           (ch)
           (let ((result (char-code ch)))
             (unless result
-              (error "Character '~C' cannot be encoded to IBM7090." ch))
+              (error "Character '~C' cannot be encoded to IBM-7090." ch))
             result)))
     (loop with 6filler = (* filler #o010101010101)
           with result = (make-array (ceiling (- end start) 6)
@@ -215,120 +252,120 @@ START and END are expressed in bytes, not in words.



-;;  http://www.frobenius.com/instruction-formats.htm

 (defparameter +op-codes+
+  ;;  http://www.frobenius.com/instruction-formats.htm
   '(

     ;; page 20.
-    (CLA +0500 f t y "Clear and Add")
-    (CAL -0500 f t y "Clear and Add Logical Word")
-    (CLS +0502 f t y "Clear and Substract")
-    (ADD +0400 f t y "Add")
-    (ADM +0401 f t y "Add Magnitude")
+    (cla +0500 f t y "Clear and Add")
+    (cal -0500 f t y "Clear and Add Logical Word")
+    (cls +0502 f t y "Clear and Substract")
+    (add +0400 f t y "Add")
+    (adm +0401 f t y "Add Magnitude")
     ;; page 21.
-    (SUB +0402 f t y "Substract")
-    (SBM -0400 f t y "Substract Magnitude")
-    (ACL +0361 f t y "Add and Carry Logical Word")
+    (sub +0402 f t y "Substract")
+    (sbm -0400 f t y "Substract Magnitude")
+    (acl +0361 f t y "Add and Carry Logical Word")
     ;; page 22.
-    (MPY +0200 f t y "Multiply")
-    (MPR -0200 f t y "Multiply and Round")
-    (RND +0760 t 00010 "Round" )
-    (VLM +0204 c t t "Variable Length Multiply")
+    (mpy +0200 f t y "Multiply")
+    (mpr -0200 f t y "Multiply and Round")
+    (rnd +0760 t 00010 "Round" )
+    (vlm +0204 c t t "Variable Length Multiply")
     ;; page 24.
-    (DVH +0220 f t y "Divide or Halt")
-    (DVP +0221 f t y "Divide or Proceed")
-    (VDH +0224 c t y "Variable Lengh Divide or Halt")
-    (VDP +0225 c t y "Variable Lengh Divide or Proceed")
+    (dvh +0220 f t y "Divide or Halt")
+    (dvp +0221 f t y "Divide or Proceed")
+    (vdh +0224 c t y "Variable Lengh Divide or Halt")
+    (vdp +0225 c t y "Variable Lengh Divide or Proceed")
     ;; page 27.
-    (FAD +0300 f t y "Floating Add")
-    (FAM +0304 f t y "Floating Add Magnitude")
-    (UFA -0300 f t y "Unnormalized Floating Add")
-    (FSB +0302 f t y "Floating Substract")
+    (fad +0300 f t y "Floating Add")
+    (fam +0304 f t y "Floating Add Magnitude")
+    (ufa -0300 f t y "Unnormalized Floating Add")
+    (fsb +0302 f t y "Floating Substract")
     ;; page 28.
-    (UAM -0304 f t y "Unnormalized Add Magnitude")
-    (FSM +0306 f t y "Floating Substract Magnitude")
-    (UFS -0302 f t y "Unnormalized Floating Substract")
-    (USM -0306 f t y "Unnormalized Floating Substract Magnitude")
-    (FRN +0760 t 00011 "Floating Round")
+    (uam -0304 f t y "Unnormalized Add Magnitude")
+    (fsm +0306 f t y "Floating Substract Magnitude")
+    (ufs -0302 f t y "Unnormalized Floating Substract")
+    (usm -0306 f t y "Unnormalized Floating Substract Magnitude")
+    (frn +0760 t 00011 "Floating Round")
     ;; page 29.
-    (FMP +0260 f t y "Floating Multiply")
-    (UFM -0260 f t y "Unnormalized Floating Multiply")
+    (fmp +0260 f t y "Floating Multiply")
+    (ufm -0260 f t y "Unnormalized Floating Multiply")
     ;; page 30.
-    (FDH +0240 f t y "Floating Divide or Halt")
-    (FDP +0241 f t y "Floating Divide or Proceed")
+    (fdh +0240 f t y "Floating Divide or Halt")
+    (fdp +0241 f t y "Floating Divide or Proceed")
     ;; page 31.
-    (ALS +0767 t y "Accumulator Left Shift")
-    (ARS +0771 t y "Accumulator Right Shift")
-    (LLS +0763 t y "Long Left Shift")
-    (LRS +0765 t y "Long Right Shift")
-    (LGL -0763 t y "Logical Left Shift")
-    (LGR -0765 t y "Logical Right Shift")
-    (RQL -0773 t y "Rotate MQ Left")
-    (LDQ +0560 f t y "Load MQ")
-    (STQ -0600 f t y "Store MQ")
-    (SLQ -0620 f t y "Store Left Half MQ")    ; (setcdr! y (cdr mq))
-    (STO +0601 f t y "Store")
-    (SLW +0602 f t y "Store Logical Word")
-    (STP +0630 f t y "Store Prefix")
-    (STD +0622 f t y "Store Decrement")       ; (setcdr! y (cdr a))
-    (STT +0625 f t y "Store Tag")
-    (STA +0621 f t y "Store Address")         ; (setcar! y (car a))
-    (STL -0625 f t y "Store Instruction Location Counter")
-    (STR -1 "Store Location and Trap")
-    (STZ +0600 f t y "Store Zero")
-    (XCA +0131 "Exchange AC and MQ")
-    (XCL -0130 "Exclange Logical AC and MQ")
-    (ENK +0760 t 00004 "Enter Keys")
-    (HTR +0000 f t y "Halt and Transfer")
-    (NOP +0761 "No Operation")
-    (HPR +0420 "Halt and Proceed")
-    (XEC +0522 f t y "Execute")
-    (TRA +0020 f t y "Transfer")
-    (ETM +0760 t 00007 "Enter Trap Mode")
-    (LTM -0760 t 00007 "Leave Trap Mode")
-    (TTR +0021 f t y "Trap Transfer")
-    (TZE +0100 f t y "Transfer on Zero")
-    (TNZ -0100 f t y "Transfer on No Zero")
-    (TPL +0120 f t y "Transfer on Plus")
-    (TMI -0120 f t y "Transfer on Minus")
-    (TOV +0140 f t y "Transfer on Overflow")
-    (TNO -0140 f t y "Transfer on No Overflow")
-    (TQP +0162 f t y "Transfer on MQ Plus")
-    (TQO +0161 f t y "Transfer on MQ Overflow" "704 floating point mode")
+    (als +0767 t y "Accumulator Left Shift")
+    (ars +0771 t y "Accumulator Right Shift")
+    (lls +0763 t y "Long Left Shift")
+    (lrs +0765 t y "Long Right Shift")
+    (lgl -0763 t y "Logical Left Shift")
+    (lgr -0765 t y "Logical Right Shift")
+    (rql -0773 t y "Rotate MQ Left")
+    (ldq +0560 f t y "Load MQ")
+    (stq -0600 f t y "Store MQ")
+    (slq -0620 f t y "Store Left Half MQ")    ; (setcdr! y (cdr mq))
+    (sto +0601 f t y "Store")
+    (slw +0602 f t y "Store Logical Word")
+    (stp +0630 f t y "Store Prefix")
+    (std +0622 f t y "Store Decrement")       ; (setcdr! y (cdr a))
+    (stt +0625 f t y "Store Tag")
+    (sta +0621 f t y "Store Address")         ; (setcar! y (car a))
+    (stl -0625 f t y "Store Instruction Location Counter")
+    (str -1 "Store Location and Trap")
+    (stz +0600 f t y "Store Zero")
+    (xca +0131 "Exchange AC and MQ")
+    (xcl -0130 "Exclange Logical AC and MQ")
+    (enk +0760 t 00004 "Enter Keys")
+    (htr +0000 f t y "Halt and Transfer")
+    (nop +0761 "No Operation")
+    (hpr +0420 "Halt and Proceed")
+    (xec +0522 f t y "Execute")
+    (tra +0020 f t y "Transfer")
+    (etm +0760 t 00007 "Enter Trap Mode")
+    (ltm -0760 t 00007 "Leave Trap Mode")
+    (ttr +0021 f t y "Trap Transfer")
+    (tze +0100 f t y "Transfer on Zero")
+    (tnz -0100 f t y "Transfer on No Zero")
+    (tpl +0120 f t y "Transfer on Plus")
+    (tmi -0120 f t y "Transfer on Minus")
+    (tov +0140 f t y "Transfer on Overflow")
+    (tno -0140 f t y "Transfer on No Overflow")
+    (tqp +0162 f t y "Transfer on MQ Plus")
+    (tqo +0161 f t y "Transfer on MQ Overflow" "704 floating point mode")
     ;; page 39.
-    (TLQ +0040 f t y "Transfer on Low MQ")
-    (TSX +0074 t y "Transfer and Set Index")
-    (TXI +1 d t y "Transer with Index Incremented")
-    (TXH +3 d t y "Transfer on Index High")
+    (tlq +0040 f t y "Transfer on Low MQ")
+    (tsx +0074 t y "Transfer and Set Index")
+    (txi +1 d t y "Transer with Index Incremented")
+    (txh +3 d t y "Transfer on Index High")
     (txl -3 d t y "Transfer on Index Low or Equal")
     (tix +2 d t y "Transfer on Index")
     (tnx -2 d t y "Transfer on No Index")
     (pse +0760 t (or 00140 ; slf
-                     (integer 00141 00144) ; sln
-                     (integer 00161 00166) ; swt
-                     (integer 01341 01342) ; spu
-                     (integer 02341 02342)
-                     (integer 03341 03342)
-                     (integer 04341 04342)
-                     (integer 05341 05342)
-                     (integer 06341 06342)
-                     (integer 07341 07342)
-                     (integer 10341 10342)
-                     01360 02360 03360 04360 05360 06360 07360 10360 ; spt
-                     (integer 01361 01362) ; spr
-                     (integer 02361 02362)
-                     (integer 03361 03362)
-                     (integer 04361 04362)
-                     (integer 05361 05362)
-                     (integer 06361 06362)
-                     (integer 07361 07362)
-                     (integer 10361 10362))  "Plus Sense")
+                  (integer 00141 00144) ; sln
+                  (integer 00161 00166) ; swt
+                  (integer 01341 01342) ; spu
+                  (integer 02341 02342)
+                  (integer 03341 03342)
+                  (integer 04341 04342)
+                  (integer 05341 05342)
+                  (integer 06341 06342)
+                  (integer 07341 07342)
+                  (integer 10341 10342)
+                  01360 02360 03360 04360 05360 06360 07360 10360 ; spt
+                  (integer 01361 01362) ; spr
+                  (integer 02361 02362)
+                  (integer 03361 03362)
+                  (integer 04361 04362)
+                  (integer 05361 05362)
+                  (integer 06361 06362)
+                  (integer 07361 07362)
+                  (integer 10361 10362))  "Plus Sense")
     (mse -0760 t (integer 00141 00144) "Minus Sense")
     (btt -0760 t (or 01000 02000 03000 04000 05000 06000 07000 10000)
-         "Beginning of Tape test")
+     "Beginning of Tape test")
     (ett -0760 t (or 01000 02000 03000 04000 05000 06000 07000 10000)
-         "End of Tape test")
+     "End of Tape test")
     (iot +0760 t 00005 "Input-Output Check Test")
     (pbt -0760 t 00001 "P-Bit Test")
     (lbt +0760 t 00001 "Low-Order Bit Test")
@@ -474,9 +511,9 @@ START and END are expressed in bytes, not in words.
     (enb +0564 f t y "Enable Traps from Y")
     (rct +0760 t 00014 "Restore Channel Traps")
     (esnt -0021 f t y "Enter Storage Nullification and Transfer"
-          "Enters 709 mode")
+     "Enters 709 mode")
     (lsnm -0760 t 00010 "Leave Storage Nullification Mode"
-          "Leaves 709 mode")
+     "Leaves 709 mode")
     (estm -0760 t 00005 "Enter Select Trap Mode")
     (ectm -0760 t 00006 "Enter Copy Trap Mode")
     (eftm -0760 t 00002 "Enter Floating Trap Mode")
@@ -485,6 +522,8 @@ START and END are expressed in bytes, not in words.


     ))
+
+
 (defparameter +data-channel-commands+
   '(
     ;; page 62.
@@ -579,9 +618,11 @@ START and END are expressed in bytes, not in words.
 ;; #define NOOPERAND 16		/* If we get this far, no variable field */
 ;; #define RIGHTMARGIN 71		/* End of variable field */

-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(cl:in-package :common-lisp-user)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+
+

 ;; * CONSW        PUTS FILL WORDS IN FULL WORD SPACE
 ;;
@@ -680,17 +721,15 @@ START and END are expressed in bytes, not in words.



+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;;  LISP15-PRIMITIVES
+;;;

-
-
-
-
-
-
-(DEFPACKAGE "LISP15-PRIMITIVES"
-  (:USE "COMMON-LISP")
+(defpackage "LISP15-PRIMITIVES"
+  (:use "COMMON-LISP")
   (:shadow "ERROR")
-  (:EXPORT
+  (:export
    "COND"
    "NULL" "NIL"
    "CONSP" "CONS" "CAR" "CDR"
@@ -702,26 +741,32 @@ START and END are expressed in bytes, not in words.
    "DEFPARAMETER" "DEFCONSTANT"
    "AREF" "TRUNCATE" "MOD" "+" "FORMAT"
    ))
-(cl:in-package "LISP15-PRIMITIVES")
+(in-package "LISP15-PRIMITIVES")
+

 (defmacro error (message &optional in-extenso)
   `(common-lisp:error message))


-(DEFPACKAGE "LISP15"
-  (:USE "LISP15-PRIMITIVES"))
-(cl:in-package "LISP15")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;;  LISP15
+;;;
+
+(defpackage "LISP15"
+  (:use "LISP15-PRIMITIVES"))
+(in-package "LISP15")


-(DEFUN CONSW (WORD)
+(defun consw (word)
   "
 WORD can be a cons cell, nil or a fixnum, or a char, or a float,
 or a pointer to a symbol or an array,
 or, a pointer to something else
 "
-  (COND
-   ((CONSP WORD) (CONS (CAR WORD) (CDR WORD)))
-   (WORD)))
+  (cond
+   ((consp word) (cons (car word) (cdr word)))
+   (word)))


 ;; * AC := CONSW(AC)
@@ -733,9 +778,9 @@ or, a pointer to something else
 ;;                   OTHERWISE CONS(CONSW(CWR(CAR(L)))),CP1(CDR(L))))


-(DEFUN CP1 (L)
-  (COND ((NULL L) NIL)
-        (T (CONS (CONSW (CAR L)) (CP1 (CDR L))))))
+(defun cp1 (l)
+  (cond ((null l) nil)
+        (t (cons (consw (car l)) (cp1 (cdr l))))))



@@ -745,12 +790,12 @@ or, a pointer to something else
 ;;        CAR(M)=-1 YIELDS M
 ;;        1 YIELDS CONS(SUBST(L,V,CAR(M)),SUBSTL,V,CDR(M))))

-(DEFUN SUBST (L V M)
-  (COND
-   ((NULL M)    NIL)
-   ((EQUAL M V) (COPY L))
-   ((ATOM M)    M)
-   (T           (CONS (SUBST L V (CAR M)) (SUBST L V (CDR M))))))
+(defun subst (l v m)
+  (cond
+   ((null m)    nil)
+   ((equal m v) (copy l))
+   ((atom m)    m)
+   (t           (cons (subst l v (car m)) (subst l v (cdr m))))))


 ;; SUBLISP
@@ -758,12 +803,12 @@ or, a pointer to something else
 ;;            APPEND(L1,L2)=
 ;;            (L1=0 YIELDS L2,1 YIELDS CONS(CAR(L1),APPEND(CDR(L1),L2))

-(DEFUN APPEND (L1 L2)
-  (COND ((NULL L1) L2)
-        (T (CONS (CAR L1) (APPEND (CDR L1) L2)))))
+(defun append (l1 l2)
+  (cond ((null l1) l2)
+        (t (cons (car l1) (append (cdr l1) l2)))))


-(DEFUN PAIR (key data)
+(defun pair (key data)
   (let ((result
          (maplis
           (lambda (key)
@@ -868,15 +913,15 @@ or, a pointer to something else
 ;;  DIGIT BCI     1,000000

 (defconstant +dmask+ #o000000077777)
-(DEFCONSTANT  LETTR 23)
-(DEFPARAMETER DIGIT 0)
+(defconstant  lettr 23)
+(defparameter digit 0)


 (defparameter ac 0)
 (defparameter mq 0)

-(DEFUN GENSYM ()
-  (SETF DIGIT (+ DIGIT 1))
+(defun gensym ()
+  (setf digit (+ digit 1))
   (cons
    +dmask+
    (cons
@@ -884,9 +929,9 @@ or, a pointer to something else
     (cons
      (cons
       (cons
-       (FORMAT NIL "~C~5,'0O"
-               (AREF ibm7090:+CHARSET+ (or 23 (truncate digit #o100000)))
-               (MOD digit #o100000))
+       (format nil "~C~5,'0O"
+               (aref ibm-7090:+charset+ (or 23 (truncate digit #o100000)))
+               (mod digit #o100000))
        mq) nil) nil))))


@@ -903,98 +948,98 @@ or, a pointer to something else


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(cl:in-package :common-lisp-user)
+(in-package :common-lisp-user)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



 (defun generate-oblb ()
   (let ((line -1))
-    (DOLIST
-        (ITEM
-         `(("    -II14" ADD 1)
+    (dolist
+        (item
+         `(("    -II14" add 1)
            ("    -)ALST")
-           AND F1 F18 APVAL
-           ("    -II1" ARRAY)
-           ATOM F29 CAR CDR CAAR CDAR CADR CDDR CAAAR CAADR CADAR CADDR
-           CDAAR CDADR CDDAR CDDDR COND CONSN COPYN
+           and f1 f18 apval
+           ("    -II1" array)
+           atom f29 car cdr caar cdar cadr cddr caaar caadr cadar caddr
+           cdaar cdadr cddar cdddr cond consn copyn
            ("    DUMP")
-           F12 F35
-           ("    -IJ01" DIFFER)
-           ("    -IJ02" DIVIDE)
-           EQ F8 F21 F19 EVLISL EXPR F32 FEXPR
-           FIX    ("    -II11" FIX P)
-           FLOAT  ("    -II12" FLOAT P)
-           FSUBR FUNARG FUNCT SYMGEN GO
-           ("    -II3" GREATER THAN P)
-           F16 LABEL LAMBDA
+           f12 f35
+           ("    -IJ01" differ)
+           ("    -IJ02" divide)
+           eq f8 f21 f19 evlisl expr f32 fexpr
+           fix    ("    -II11" fix p)
+           float  ("    -II12" float p)
+           fsubr funarg funct symgen go
+           ("    -II3" greater than p)
+           f16 label lambda
            ("    LAP")
-           ("    -II4" LESS THAN P)
-           LIST
-           ("    LOADA" LOADER OBJECT)
-           PMAPCA
+           ("    -II4" less than p)
+           list
+           ("    LOADA" loader object)
+           pmapca
            ("-)069B")
            ("-)069A")
-           ("    -II7" MAXIMUM)
-           ("    -II8" MINIMUM)
-           MINUS
-           ("    -II16" MINUS P)
-           F3 NIL NOT NULL
-           ("    -II13" NUMBER P)
-           ("    OBLBA" OBLIST OBJECT)
-           ("    -II9" ONE P)
-           OR F2 PAUSE PLB PLUS PNAME F4 PROG PROPO
-           ("    -IJ05" PUNCH)
-           QUOTE
-           ("    -IJ03" QUOTIENT)
-           F13
-           ("    -II18" RECIP)
-           RCLAM PRPLCA PRPLCD
-           ("    -IJ04" REMAINDER)
-           ("    RETATM" RETURN)
-           SASCO SRCH SET SETQ F34 STOP SUBR
+           ("    -II7" maximum)
+           ("    -II8" minimum)
+           minus
+           ("    -II16" minus p)
+           f3 nil not null
+           ("    -II13" number p)
+           ("    OBLBA" oblist object)
+           ("    -II9" one p)
+           or f2 pause plb plus pname f4 prog propo
+           ("    -IJ05" punch)
+           quote
+           ("    -IJ03" quotient)
+           f13
+           ("    -II18" recip)
+           rclam prplca prplcd
+           ("    -IJ04" remainder)
+           ("    RETATM" return)
+           sasco srch set setq f34 stop subr
            ("    TRACE")
            ("    SMOVE")
            ("    SRETUR")
            ("    SLIST")
            ("    SPECAL")
-           ("    -II15" SUBTRACT 1)
-           F17 F30
-           ("    1" *T* BINARY TRUE ATOM)
-           F27
+           ("    -II15" subtract 1)
+           f17 f30
+           ("    1" *t* binary true atom)
+           f27
            ("    SYM")
-           TIMES F36
-           ("    -II10" ZERO P)
-           CGET
+           times f36
+           ("    -II10" zero p)
+           cget
            ("    REMPP")
-           ,@(LOOP FOR I BELOW 64
-                   COLLECT (FORMAT NIL "H~2,'0O" (CASE I
-                                                   ((#O15) #O14) ((#O14) #O15)
-                                                   (OTHERWISE I))))
-           ,@(LOOP FOR I FROM 1 TO 39
-                   UNLESS (MEMBER I '(3 13 20 22 29))
-                   COLLECT (FORMAT NIL "~APJ~D" (IF (< I 24) "" "    ") I))
-           ("    ERSETO" ERRORSET)
+           ,@(loop for i below 64
+                   collect (format nil "H~2,'0O" (case i
+                                                   ((#o15) #o14) ((#o14) #o15)
+                                                   (otherwise i))))
+           ,@(loop for i from 1 to 39
+                   unless (member i '(3 13 20 22 29))
+                   collect (format nil "~APJ~D" (if (< i 24) "" "    ") i))
+           ("    ERSETO" errorset)
            ("    PVW1" "LAST OBJECT   - LEFTSHIFT")
            ))
       (format t "~72AGENER~3,'0D~%"
-              (IF (ATOM  ITEM)
-                (FORMAT NIL "           ~A"
-                        (FORMAT NIL "~A,,-*-1" ITEM))
-                (FORMAT NIL "           ~22A~{ ~A~}"
-                        (FORMAT NIL "~A,,-*-1" (CAR ITEM)) (CDR ITEM)))
+              (if (atom  item)
+                (format nil "           ~A"
+                        (format nil "~A,,-*-1" item))
+                (format nil "           ~22A~{ ~A~}"
+                        (format nil "~A,,-*-1" (car item)) (cdr item)))

               (incf line)))))


 (defun string-to-list (string)
-  (coerce (ibm7090:convert-string-to-words string) 'list))
+  (coerce (ibm-7090:convert-string-to-words string) 'list))



 (defparameter *code-output* t "Stream where code is output")
 (defparameter *code* nil)
-(DEFPARAMETER *LINE* -1)
+(defparameter *line* -1)
 (defparameter *id* "")

 (defun geninit (id)
@@ -1004,12 +1049,12 @@ or, a pointer to something else
 (defun generate (label cop car tag cdr comment)
   (vector-push-extend (list label cop car tag cdr comment) *code*))

-(DEFUN PUNCH (LINE &optional (ID *id*))
-  (FORMAT *CODE-OUTPUT* "~72A~4A~4,'0D~%" LINE ID (incf *line*)))
+(defun punch (line &optional (id *id*))
+  (format *code-output* "~72A~4A~4,'0D~%" line id (incf *line*)))


 (defun print-code (addr code)
-  (PUNCH
+  (punch
    (with-output-to-string (*standard-output*)
      (labels ((print-address (target) (unless (zerop target)
                                         (format t "-*-~A" (- addr target))))
@@ -1037,7 +1082,7 @@ or, a pointer to something else
                         (if (addressp cdr)
                           (print-address (second cdr))
                           (format t "~A" cdr)))))))
-         (format T "~:[~;~:*~A~]" comment))))))
+         (format t "~:[~;~:*~A~]" comment))))))


 (defun generate-item (item next &key label comment)
@@ -1050,17 +1095,17 @@ or, a pointer to something else
                               'pze `(address ,(generate-string item next))
                               nil `(address ,next) (or comment item)))
    ((consp    item)
-    (CASE (FIRST ITEM)
+    (case (first item)
       ((function)
        (generate label
                  'pze `(address
                          ,(generate nil 'txl (second item)
                                     nil (third item) nil))
                  nil `(address ,next) comment))
-      ((ASM)
-       (generate label (SECOND ITEM) (THIRD ITEM) (FOURTH ITEM) (FIFTH ITEM)
-                 COMMENT))
-      (OTHERWISE
+      ((asm)
+       (generate label (second item) (third item) (fourth item) (fifth item)
+                 comment))
+      (otherwise
        (generate label
                  'pze `(address ,(generate-list item))
                  nil `(address ,next) comment))))
@@ -1084,252 +1129,252 @@ or, a pointer to something else
         finally (return addr)))

 (defun generate-plist (item &key (id *id*) comment)
-  (LET ((LABEL (FIRST ITEM))
-        (PLIST (SECOND ITEM)))
-    (GENINIT id)
-    (GENERATE-LIST PLIST :comment comment)
-    (SETF (FIRST (AREF *CODE* (1- (FILL-POINTER *CODE*)))) LABEL)
-    (LOOP FOR PC FROM (1- (FILL-POINTER *CODE*)) DOWNTO 1
-          FOR LINE = (AREF *CODE* PC)
-          DO (PRINT-CODE PC LINE))))
+  (let ((label (first item))
+        (plist (second item)))
+    (geninit id)
+    (generate-list plist :comment comment)
+    (setf (first (aref *code* (1- (fill-pointer *code*)))) label)
+    (loop for pc from (1- (fill-pointer *code*)) downto 1
+          for line = (aref *code* pc)
+          do (print-code pc line))))

 (defparameter +symbols+
-  `((II14       (-1  $SUBR (FUNCTION ADD1   1) $PNAME "ADD1"))
-    (")PJ2"     (-1   SUBR (FUNCTION ADVANC 0)  PNAME "ADVANCE"))
-    (")ALST"    (-1   PNAME"$ALIST" SYM -C$ALST))
-    (")002"     (-1  FSUBR (FUNCTION $EVAND 0) $PNAME "AND"))
-    (")003"     (-1   SUBR (FUNCTION APPEND 2)  PNAME "APPEND"))
-    (")004"     (-1   SUBR (FUNCTION APPLY  3)  PNAME "APPLY"))
-    (")005"     (-1   PNAME "APVAL"))
-    ("II1"      (-1   SUBR (FUNCTION ARYMAK 1)  PNAME "ARRAY"))
-    (")007"     (-1   SUBR (FUNCTION ATOMP  1)  PNAME "ATOM"))
-    (")008"     (-1   SUBR (FUNCTION ATTRIB 2)  PNAME "ATTRIB"))
-    (")PJ12"    (-1   PNAME "BLANK" APVAL1 (H60)))
-    (")011"     (-1   SUBR (FUNCTION CARP   1)  PNAME "CAR"))
-    (")012"     (-1   SUBR (FUNCTION CDRP   1)  PNAME "CDR"))
-    (")201"     (-1   SUBR (FUNCTION CAARXX 1)  PNAME "CAAR"))
-    (")202"     (-1   SUBR (FUNCTION CDARXX 1)  PNAME "CDAR"))
-    (")203"     (-1   SUBR (FUNCTION CADRXX 1)  PNAME "CADR"))
-    (")204"     (-1   SUBR (FUNCTION CDDRXX 1)  PNAME "CDDR"))
-    (")205"     (-1   SUBR (FUNCTION CAAARX 1)  PNAME "CAAAR"))
-    (")206"     (-1   SUBR (FUNCTION CAADRX 1)  PNAME "CAADR"))
-    (")207"     (-1   SUBR (FUNCTION CADARX 1)  PNAME "CADAR"))
-    (")208"     (-1   SUBR (FUNCTION CADDRX 1)  PNAME "CADDR"))
-    (")209"     (-1   SUBR (FUNCTION CDAARX 1)  PNAME "CDAAR"))
-    (")210"     (-1   SUBR (FUNCTION CDADRX 1)  PNAME "CDADR"))
-    (")211"     (-1   SUBR (FUNCTION CDDARX 1)  PNAME "CDDAR"))
-    (")212"     (-1   SUBR (FUNCTION CDDDRX 1)  PNAME "CDDDR"))
-    (")PJ32"    (-1   PNAME "CHARCOUNT" APVAL1 (((ASM MZE -1 1 -CHACT)))))
-    (")PJ27"    (-1   SUBR (FUNCTION CLEAR  0)  PNAME "CLEARBUFF"))
-    (")PJ6"     (-1   PNAME "COMMA" APVAL1 (H73)))
-    (")016"     (-1  FSUBR (FUNCTION $EVCON 0)  PNAME "COND"))
-    (")017"     (-1   SUBR (FUNCTION CONS   2)  PNAME "CONS"))
-    (")019"     (-1   SUBR (FUNCTION CP1    1)  PNAME "CP1"))
-    (")020"     (-1   SUBR (FUNCTION $COPY  1)  PNAME "COPY"))
-    (")021"     (-1   SUBR (FUNCTION COUNT  0)  PNAME "COUNT"))
-    (")PJ1"     (-1   APVAL1 -CURC1  PNAME "CURCHAR" SPECAL -CURC))
-    (")PJ16"    (-1   APVAL1 (H40)   PNAME "DASH"))
-    (IJ01       (-1  $SUBR (FUNCTION DIFFER 2) $PNAME "DIFFERENCE"))
-    (")PJ19"    (-1   SUBR (FUNCTION DIGIT  1)  PNAME "DIGIT"))
-    (IJ02       (-1  $SUBR (FUNCTION DIVIDE 2) $PNAME "DIVIDE"))
-    (")PJ10"    (-1   PNAME "DOLLAR" APVAL1 (H53)))
-    (DMPCB      (-1   SUBR (FUNCTION DUMPXX 4)  PNAME "DUMP"))
-    (")PJ30"    (-1   SUBR (FUNCTION ENDRED 0)  PNAME "ENDREAD"))
-    (")PJ34"    (-1   APVAL1 (H12)  PNAME "EOF"))
-    (")PJ35"    (-1   APVAL1 (H72)  PNAME "EOR"))
-    (")030"     (-1   SUBR (FUNCTION EQ     2)  PNAME "EQ"))
-    (")PJ5"     (-1   PNAME "EQSIGN" APVAL1 (H13)))
-    (")032"     (-1   SUBR (FUNCTION EQUAL  2)  PNAME "EQUAL"))
-    (")034"     (-1   SUBR (FUNCTION ERROR1 1)  PNAME "ERROR"))
-    (")PJ4"     (-1   SUBR (FUNCTION EROR1  0)  PNAME "ERROR1"))
-    (")PJ41"    (-1   SUBR (FUNCTION ERRSET 3)  PNAME "ERRORSET"))
-    (")035"     (-1   SUBR (FUNCTION EVAL   2)  PNAME "EVAL"))
-    (")036"     (-1  $SUBR (FUNCTION EVLIS  2) $PNAME "EVLIS"))
-    (")037"     (-1   PNAME "EXPR"))
-    (")038"     (-1   SUBR (FUNCTION EXPT   2)  PNAME "EXPT"))
-    (")040"     (-1   PNAME "FEXPR"))
-    (")041"     (-1   PNAME "FIX"))
-    (ii11       (-1  $SUBR (FUNCTION FIXP   1) $PNAME "FIXP"))
-    (")042"     (-1   PNAME "FLOAT"))
-    (II12       (-1  $SUBR (FUNCTION FLOATP 1) $PNAME "FLOATP"))
-    (")043"     (-1   PNAME "FSUBR"))
-    (")044"     (-1   PNAME "FUNARG"))
-    (")045"     (-1  FSUBR (FUNCTION $LAMP  0)  PNAME "FUNCTION"))
-    (")046"     (-1  $SUBR (FUNCTION GENSYM 0) $PNAME "GENSYM"))
-    (")231"     (-1   SUBR (FUNCTION C$GET  2)  PNAME "GET"))
-    (")047"     (-1 $FSUBR (FUNCTION GOGOGO 1)  PNAME "GO"))
-    (II3        (-1  $SUBR (FUNCTION GRTRTP 2) $PNAME "GREATERP"))
-    (")052"     (-1   SUBR (FUNCTION INTRN1 1)  PNAME "INTERN"))
-    (")054"     (-1  FSUBR (FUNCTION LABP   0)  PNAME "LABEL"))
-    (")055"     (-1   PNAME "LABEL"))
-    (")LAP"     (-1   SUBR (FUNCTION C$LAP  2)  PNAME "LAP"))
-    (PVV1       (-1   SUBR (FUNCTION LSHIFT 2)  PNAME "LEFTSHIFT"))
-    (II4        (-1  $SUBR (FUNCTION LESSTP 2) $PNAME "LESSP"))
-    (")057"     (-1  FSUBR (FUNCTION EVLIS  0)  PNAME "LIST"))
-    (")PJ17"    (-1   SUBR (FUNCTION LITER  1)  PNAME "LITER"))
-    (")234A"    (-1   SUBR (FUNCTION LOADER 0)  PNAME "LOAD"))
-    (")PJ37"    (-1  FSUBR (FUNCTION LOGAND 0)  PNAME "LOGAND"))
-    (")PJ36"    (-1  FSUBR (FUNCTION LOGOR  0)  PNAME "LOGOR"))
-    (")PJ38"    (-1  FSUBR (FUNCTION LOGXOR 0)  PNAME "LOGXOR"))
-    (")PJ7"     (-1   PNAME "LPAR" APVAL1 (H74)))
-    (")065"     (-1   SUBR (FUNCTION MAPCAR 2)  PNAME "MAP"))
-    (")069B"    (-1   SUBR (FUNCTION MAPCON 2)  PNAME "MAPCON"))
-    (")069A"    (-1   SUBR (FUNCTION MAPLIS 2)  PNAME "MAPLIST"))
-    (II7        (-1 $FSUBR (FUNCTION MAX    2) $PNAME "MAX"))
-    (II8        (-1 $FSUBR (FUNCTION MIN    2) $PNAME "MIN"))
-    (")070"     (-1  $SUBR (FUNCTION MNSPRG 1) $PNAME "MINUS"))
-    (II16       (-1  $SUBR (FUNCTION MINUSP 1) $PNAME "MINUSP"))
-    (")PJ26"    (-1   SUBR (FUNCTION MKNAM  0)  PNAME "MKNAM"))
-    (")071"     (-1   SUBR (FUNCTION NCONC  2)  PNAME "NCONC"))
-    (")074"     (-1  $SUBR (FUNCTION NOTS   1) $PNAME "NOT"))
-    (")075"     (-1   SUBR (FUNCTION NULLP  1)  PNAME "NULL"))
-    (II13       (-1  $SUBR (FUNCTION NUMBRP 1) $PNAME "NUMBERP"))
-    (")PJ25"    (-1   SUBR (FUNCTION NUMOB  0)  PNAME "NUMOB"))
-    (")079A"    (-1   APVAL1 (-OBLIST) PNAME "OBLIST"))
-    (")PJ28"    (-1   PNAME "OCTAL" ))
-    (II9        (-1  $SUBR (FUNCTION ONEP   1) $PNAME "ONEP"))
-    (")PJ18"    (-1   SUBR (FUNCTION OPCHAR 1)  PNAME "OPCHAR"))
-    (")079"     (-1  FSUBR (FUNCTION $EVOR  0) $PNAME "OR"))
-    (")PJ24"    (-1   SUBR (FUNCTION PACK   1)  PNAME "PACK"))
-    (")080"     (-1   SUBR (FUNCTION PAIR   2)  PNAME "PAIR"))
-    (")234C"    (-1   SUBR (FUNCTION PAUSEF 0)  PNAME "PAUSE"))
-    (")PJ9"     (-1   PNAME "PERIOD" APVAL1 (H33)))
-    (")234B"    (-1   SUBR (FUNCTION PSHLDB 0)  PNAME "PLB"))
-    (")081"     (-1 $FSUBR (FUNCTION ADDP   2) $PNAME "PLUS"))
-    (")PJ11"    (-1   PNAME "PLUSS" APVAL1 (H20)))
-    (")083"     (-1   PNAME "PNAME"))
-    (")PJ33"    (-1   SUBR (FUNCTION $PRIN1 1)  PNAME "PRIN1"))
-    (")087"     (-1   SUBR (FUNCTION PRINT  1)  PNAME "PRINT"))
-    (")PJ39"    (-1   SUBR (FUNCTION $PRIN2 1)  PNAME "PRINT2"))
-    (")089"     (-1  FSUBR (FUNCTION INTER  0)  PNAME "PROG"))
-    (IJ05       (-1  $SUBR (FUNCTION $PUNCH 1) $PNAME "PUNCH"))
-    (")090"     (-1   SUBR (FUNCTION APROP  3)  PNAME "PROP"))
-    (")094"     (-1  FSUBR (FUNCTION CARP   0)  PNAME "QUOTE"))
-    (IJ03       (-1  $SUBR (FUNCTION QUOTEN 2) $PNAME "QUOTIENT"))
-    (")096"     (-1   SUBR (FUNCTION READ   0)  PNAME "READ"))
-    (II18       (-1  $SUBR (FUNCTION RCPPRG 1) $PNAME "RECIP"))
-    (")234D"    (-1   SUBR (FUNCTION RECLAM 0)  PNAME "RECLAIM"))
-    (IJ04       (-1  $SUBR (FUNCTION REMAIN 2) $PNAME "REMAINDER"))
-    (")250"     (-1   SUBR (FUNCTION REMPRP 2)  PNAME "REMPROP"))
-    (")I02"     (-1  $SUBR (FUNCTION RETURN 1) $PNAME "RETURN"))
-    (")100"     (-1   SUBR (FUNCTION RPLACA 0)  PNAME "RPLACA"))
-    (")101"     (-1   SUBR (FUNCTION RPLACD 0)  PNAME "RPLACD"))
-    (")PJ8"     (-1   PNAME "RPAR" APVAL1 (H34)))
-    (")SPCL"    (-1   PNAME "SPECIAL"))
-    (")MOV"     (-1   PNAME "*MOVE"   SYM (ASM MZE -C$MOV)))
-    (")RTRN"    (-1   PNAME "*RETURN" SYM (ASM MZE -C$RTRN)))
-    (")LST"     (-1   PNAME "*LIST"   SYM (ASM MZE -C$LSTR)))
-    (")I06"     (-1   SUBR (FUNCTION APSSOC 3)  PNAME "SASSOC"))
-    (")236"     (-1   SUBR (FUNCTION SEARCH 4)  PNAME "SEARCH"))
-    (")107"     (-1  $SUBR (FUNCTION SETP   2) $PNAME "SET"))
-    (")108"     (-1 $FSUBR (FUNCTION SETQP  0)  PNAME "SETQ"))
-    (")PJ14"    (-1   PNAME "SLASH" APVAL1 (H61)))
-    (")109"     (-1   SUBR (FUNCTION SPEAK 4)  PNAME "SPEAK"))
-    (")111"     (-1   PNAME "STOP"))
-    (")PJ15"    (-1   PNAME "STAR" APVAL1 (H54)))
-    (")PJ21"    (-1   SUBR (FUNCTION STREAD 0)  PNAME "STARTREAD"))
-    (II15       (-1  $SUBR (FUNCTION SUB1   2) $PNAME "SUB1"))
-    (")113"     (-1   PNAME "SUBR"))
-    (")114"     (-1   SUBR (FUNCTION SUBLIS 2)  PNAME "SUBLIS"))
-    (")115"     (-1   SUBR (FUNCTION SUBST  3)  PNAME "SUBST"))
-    (")SYM"     (-1   PNAME "SYM"))
-    (")PJ23"    (-1   SUBR (FUNCTION TERPRI 0)  PNAME "TERPRI"))
-    (")122"     (-1   SUBR (FUNCTION $TIME  0)  PNAME "TEMPUS-FUGIT"))
-    (")124"     (-1 $FSUBR (FUNCTION MULT   2) $PNAME "TIMES"))
-    (")213"     (-1  $PNAME "TRACE"))
-    (")127"     (-1   SUBR (FUNCTION UNCONT 0)  PNAME "UNCOUNT"))
-    (")PJ31"    (-1   SUBR (FUNCTION UNPACK 1)  PNAME "UNPACK"))
-    (II10       (-1  $SUBR (FUNCTION ZEROP  1) $PNAME "ZEROP"))
+  `((ii14       (-1  $subr (function add1   1) $pname "ADD1"))
+    (")PJ2"     (-1   subr (function advanc 0)  pname "ADVANCE"))
+    (")ALST"    (-1   pname"$ALIST" sym -c$alst))
+    (")002"     (-1  fsubr (function $evand 0) $pname "AND"))
+    (")003"     (-1   subr (function append 2)  pname "APPEND"))
+    (")004"     (-1   subr (function apply  3)  pname "APPLY"))
+    (")005"     (-1   pname "APVAL"))
+    ("II1"      (-1   subr (function arymak 1)  pname "ARRAY"))
+    (")007"     (-1   subr (function atomp  1)  pname "ATOM"))
+    (")008"     (-1   subr (function attrib 2)  pname "ATTRIB"))
+    (")PJ12"    (-1   pname "BLANK" apval1 (h60)))
+    (")011"     (-1   subr (function carp   1)  pname "CAR"))
+    (")012"     (-1   subr (function cdrp   1)  pname "CDR"))
+    (")201"     (-1   subr (function caarxx 1)  pname "CAAR"))
+    (")202"     (-1   subr (function cdarxx 1)  pname "CDAR"))
+    (")203"     (-1   subr (function cadrxx 1)  pname "CADR"))
+    (")204"     (-1   subr (function cddrxx 1)  pname "CDDR"))
+    (")205"     (-1   subr (function caaarx 1)  pname "CAAAR"))
+    (")206"     (-1   subr (function caadrx 1)  pname "CAADR"))
+    (")207"     (-1   subr (function cadarx 1)  pname "CADAR"))
+    (")208"     (-1   subr (function caddrx 1)  pname "CADDR"))
+    (")209"     (-1   subr (function cdaarx 1)  pname "CDAAR"))
+    (")210"     (-1   subr (function cdadrx 1)  pname "CDADR"))
+    (")211"     (-1   subr (function cddarx 1)  pname "CDDAR"))
+    (")212"     (-1   subr (function cdddrx 1)  pname "CDDDR"))
+    (")PJ32"    (-1   pname "CHARCOUNT" apval1 (((asm mze -1 1 -chact)))))
+    (")PJ27"    (-1   subr (function clear  0)  pname "CLEARBUFF"))
+    (")PJ6"     (-1   pname "COMMA" apval1 (h73)))
+    (")016"     (-1  fsubr (function $evcon 0)  pname "COND"))
+    (")017"     (-1   subr (function cons   2)  pname "CONS"))
+    (")019"     (-1   subr (function cp1    1)  pname "CP1"))
+    (")020"     (-1   subr (function $copy  1)  pname "COPY"))
+    (")021"     (-1   subr (function count  0)  pname "COUNT"))
+    (")PJ1"     (-1   apval1 -curc1  pname "CURCHAR" specal -curc))
+    (")PJ16"    (-1   apval1 (h40)   pname "DASH"))
+    (ij01       (-1  $subr (function differ 2) $pname "DIFFERENCE"))
+    (")PJ19"    (-1   subr (function digit  1)  pname "DIGIT"))
+    (ij02       (-1  $subr (function divide 2) $pname "DIVIDE"))
+    (")PJ10"    (-1   pname "DOLLAR" apval1 (h53)))
+    (dmpcb      (-1   subr (function dumpxx 4)  pname "DUMP"))
+    (")PJ30"    (-1   subr (function endred 0)  pname "ENDREAD"))
+    (")PJ34"    (-1   apval1 (h12)  pname "EOF"))
+    (")PJ35"    (-1   apval1 (h72)  pname "EOR"))
+    (")030"     (-1   subr (function eq     2)  pname "EQ"))
+    (")PJ5"     (-1   pname "EQSIGN" apval1 (h13)))
+    (")032"     (-1   subr (function equal  2)  pname "EQUAL"))
+    (")034"     (-1   subr (function error1 1)  pname "ERROR"))
+    (")PJ4"     (-1   subr (function eror1  0)  pname "ERROR1"))
+    (")PJ41"    (-1   subr (function errset 3)  pname "ERRORSET"))
+    (")035"     (-1   subr (function eval   2)  pname "EVAL"))
+    (")036"     (-1  $subr (function evlis  2) $pname "EVLIS"))
+    (")037"     (-1   pname "EXPR"))
+    (")038"     (-1   subr (function expt   2)  pname "EXPT"))
+    (")040"     (-1   pname "FEXPR"))
+    (")041"     (-1   pname "FIX"))
+    (ii11       (-1  $subr (function fixp   1) $pname "FIXP"))
+    (")042"     (-1   pname "FLOAT"))
+    (ii12       (-1  $subr (function floatp 1) $pname "FLOATP"))
+    (")043"     (-1   pname "FSUBR"))
+    (")044"     (-1   pname "FUNARG"))
+    (")045"     (-1  fsubr (function $lamp  0)  pname "FUNCTION"))
+    (")046"     (-1  $subr (function gensym 0) $pname "GENSYM"))
+    (")231"     (-1   subr (function c$get  2)  pname "GET"))
+    (")047"     (-1 $fsubr (function gogogo 1)  pname "GO"))
+    (ii3        (-1  $subr (function grtrtp 2) $pname "GREATERP"))
+    (")052"     (-1   subr (function intrn1 1)  pname "INTERN"))
+    (")054"     (-1  fsubr (function labp   0)  pname "LABEL"))
+    (")055"     (-1   pname "LABEL"))
+    (")LAP"     (-1   subr (function c$lap  2)  pname "LAP"))
+    (pvv1       (-1   subr (function lshift 2)  pname "LEFTSHIFT"))
+    (ii4        (-1  $subr (function lesstp 2) $pname "LESSP"))
+    (")057"     (-1  fsubr (function evlis  0)  pname "LIST"))
+    (")PJ17"    (-1   subr (function liter  1)  pname "LITER"))
+    (")234A"    (-1   subr (function loader 0)  pname "LOAD"))
+    (")PJ37"    (-1  fsubr (function logand 0)  pname "LOGAND"))
+    (")PJ36"    (-1  fsubr (function logor  0)  pname "LOGOR"))
+    (")PJ38"    (-1  fsubr (function logxor 0)  pname "LOGXOR"))
+    (")PJ7"     (-1   pname "LPAR" apval1 (h74)))
+    (")065"     (-1   subr (function mapcar 2)  pname "MAP"))
+    (")069B"    (-1   subr (function mapcon 2)  pname "MAPCON"))
+    (")069A"    (-1   subr (function maplis 2)  pname "MAPLIST"))
+    (ii7        (-1 $fsubr (function max    2) $pname "MAX"))
+    (ii8        (-1 $fsubr (function min    2) $pname "MIN"))
+    (")070"     (-1  $subr (function mnsprg 1) $pname "MINUS"))
+    (ii16       (-1  $subr (function minusp 1) $pname "MINUSP"))
+    (")PJ26"    (-1   subr (function mknam  0)  pname "MKNAM"))
+    (")071"     (-1   subr (function nconc  2)  pname "NCONC"))
+    (")074"     (-1  $subr (function nots   1) $pname "NOT"))
+    (")075"     (-1   subr (function nullp  1)  pname "NULL"))
+    (ii13       (-1  $subr (function numbrp 1) $pname "NUMBERP"))
+    (")PJ25"    (-1   subr (function numob  0)  pname "NUMOB"))
+    (")079A"    (-1   apval1 (-oblist) pname "OBLIST"))
+    (")PJ28"    (-1   pname "OCTAL" ))
+    (ii9        (-1  $subr (function onep   1) $pname "ONEP"))
+    (")PJ18"    (-1   subr (function opchar 1)  pname "OPCHAR"))
+    (")079"     (-1  fsubr (function $evor  0) $pname "OR"))
+    (")PJ24"    (-1   subr (function pack   1)  pname "PACK"))
+    (")080"     (-1   subr (function pair   2)  pname "PAIR"))
+    (")234C"    (-1   subr (function pausef 0)  pname "PAUSE"))
+    (")PJ9"     (-1   pname "PERIOD" apval1 (h33)))
+    (")234B"    (-1   subr (function pshldb 0)  pname "PLB"))
+    (")081"     (-1 $fsubr (function addp   2) $pname "PLUS"))
+    (")PJ11"    (-1   pname "PLUSS" apval1 (h20)))
+    (")083"     (-1   pname "PNAME"))
+    (")PJ33"    (-1   subr (function $prin1 1)  pname "PRIN1"))
+    (")087"     (-1   subr (function print  1)  pname "PRINT"))
+    (")PJ39"    (-1   subr (function $prin2 1)  pname "PRINT2"))
+    (")089"     (-1  fsubr (function inter  0)  pname "PROG"))
+    (ij05       (-1  $subr (function $punch 1) $pname "PUNCH"))
+    (")090"     (-1   subr (function aprop  3)  pname "PROP"))
+    (")094"     (-1  fsubr (function carp   0)  pname "QUOTE"))
+    (ij03       (-1  $subr (function quoten 2) $pname "QUOTIENT"))
+    (")096"     (-1   subr (function read   0)  pname "READ"))
+    (ii18       (-1  $subr (function rcpprg 1) $pname "RECIP"))
+    (")234D"    (-1   subr (function reclam 0)  pname "RECLAIM"))
+    (ij04       (-1  $subr (function remain 2) $pname "REMAINDER"))
+    (")250"     (-1   subr (function remprp 2)  pname "REMPROP"))
+    (")I02"     (-1  $subr (function return 1) $pname "RETURN"))
+    (")100"     (-1   subr (function rplaca 0)  pname "RPLACA"))
+    (")101"     (-1   subr (function rplacd 0)  pname "RPLACD"))
+    (")PJ8"     (-1   pname "RPAR" apval1 (h34)))
+    (")SPCL"    (-1   pname "SPECIAL"))
+    (")MOV"     (-1   pname "*MOVE"   sym (asm mze -c$mov)))
+    (")RTRN"    (-1   pname "*RETURN" sym (asm mze -c$rtrn)))
+    (")LST"     (-1   pname "*LIST"   sym (asm mze -c$lstr)))
+    (")I06"     (-1   subr (function apssoc 3)  pname "SASSOC"))
+    (")236"     (-1   subr (function search 4)  pname "SEARCH"))
+    (")107"     (-1  $subr (function setp   2) $pname "SET"))
+    (")108"     (-1 $fsubr (function setqp  0)  pname "SETQ"))
+    (")PJ14"    (-1   pname "SLASH" apval1 (h61)))
+    (")109"     (-1   subr (function speak 4)  pname "SPEAK"))
+    (")111"     (-1   pname "STOP"))
+    (")PJ15"    (-1   pname "STAR" apval1 (h54)))
+    (")PJ21"    (-1   subr (function stread 0)  pname "STARTREAD"))
+    (ii15       (-1  $subr (function sub1   2) $pname "SUB1"))
+    (")113"     (-1   pname "SUBR"))
+    (")114"     (-1   subr (function sublis 2)  pname "SUBLIS"))
+    (")115"     (-1   subr (function subst  3)  pname "SUBST"))
+    (")SYM"     (-1   pname "SYM"))
+    (")PJ23"    (-1   subr (function terpri 0)  pname "TERPRI"))
+    (")122"     (-1   subr (function $time  0)  pname "TEMPUS-FUGIT"))
+    (")124"     (-1 $fsubr (function mult   2) $pname "TIMES"))
+    (")213"     (-1  $pname "TRACE"))
+    (")127"     (-1   subr (function uncont 0)  pname "UNCOUNT"))
+    (")PJ31"    (-1   subr (function unpack 1)  pname "UNPACK"))
+    (ii10       (-1  $subr (function zerop  1) $pname "ZEROP"))
     ))



-(DEFUN GENERATE-PLISTS ()
+(defun generate-plists ()
   (setf *line* -1)
-  (DOLIST (ITEM +symbols+)
+  (dolist (item +symbols+)
     (generate-plist item :id "GPLI" :comment nil)
-    (PUNCH "*")))
+    (punch "*")))




 (defparameter +alphabet+
   '( ;;                                    PNAME
-    (#o00  DIGIT         "0"              "0")
-    (#o01  DIGIT         "1"              "1")
-    (#o02  DIGIT         "2"              "2")
-    (#o03  DIGIT         "3"              "3")
-    (#o04  DIGIT         "4"              "4")
-    (#o05  DIGIT         "5"              "5")
-    (#o06  DIGIT         "6"              "6")
-    (#o07  DIGIT         "7"              "7")
-    (#o10  DIGIT         "8"              "8")
-    (#o11  DIGIT         "9"              "9")
-    (#o12  OTHER         "END OF FILE"    "$EOF$"  APVAL1 (H12))
-    (#o13  OPERATION     "="              "=")
-    (#o14  OPERATION     "8-4 MINUS"      "\"")
-    (#o15  ILLEGAL       "ILLEGAL"        "$IL15$")
-    (#o16  ILLEGAL       "ILLEGAL"        "$IL16$")
-    (#o17  ILLEGAL       "ILLEGAL"        "$IL17$")
-    (#o20  OPERATION     "+"              "+")
-    (#o21  LETTER        "A"              "A")
-    (#o22  LETTER        "B"              "B")
-    (#o23  LETTER        "C"              "C")
-    (#o24  LETTER        "D"              "D")
-    (#o25  LETTER        "E"              "E")
-    (#o26  LETTER        "F"              "F"      APVAL (0))
-    (#o27  LETTER        "G"              "G")
-    (#o30  LETTER        "H"              "H")
-    (#o31  LETTER        "I"              "I")
-    (#o32  OTHER         "+0"             "$IL32$")
-    (#o33  OTHER         "."              ".")
-    (#o34  OTHER         ")"              ")")
-    (#o35  ILLEGAL       "ILLEGAL"        "$IL35$")
-    (#o36  ILLEGAL       "ILLEGAL"        "$IL36$")
-    (#o37  ILLEGAL       "ILLEGAL"        "$IL37$")
-    (#o40  OPERATION     "11 MINUS"       "-")
-    (#o41  LETTER        "J"              "J")
-    (#o42  LETTER        "K"              "K")
-    (#o43  LETTER        "L"              "L")
-    (#o44  LETTER        "M"              "M")
-    (#o45  LETTER        "N"              "N")
-    (#o46  LETTER        "O"              "O")
-    (#o47  LETTER        "P"              "P")
-    (#o50  LETTER        "Q"              "Q")
-    (#o51  LETTER        "R"              "R")
-    (#o52  OTHER         "-0"             "$IL52$")
-    (#o53  OTHER         "$"              "$")
-    (#o54  OPERATION     "*"              "*"      SYM -C$STAR)
-    (#o55  ILLEGAL       "ILLEGAL"        "$IL55$")
-    (#o56  ILLEGAL       "ILLEGAL"        "$IL56$")
-    (#o57  ILLEGAL       "ILLEGAL"        "$IL57$")
-    (#o60  OTHER         "BLANK"          " ")
-    (#o61  OPERATION     "/"              "/")
-    (#o62  LETTER        "S"              "S")
-    (#o63  LETTER        "T"              "T"      APVAL (1))
-    (#o64  LETTER        "U"              "U")
-    (#o65  LETTER        "V"              "V")
-    (#o66  LETTER        "W"              "W")
-    (#o67  LETTER        "X"              "X")
-    (#o70  LETTER        "Y"              "Y")
-    (#o71  LETTER        "Z"              "Z")
-    (#o72  OTHER         "END OF RECORD"  "$EOR$"  APVAL1 (H72))
-    (#o73  OTHER         ","              ",")
-    (#o74  OTHER         "("              "(")
-    (#o75  ILLEGAL       "ILLEGAL"        "$IL75$")
-    (#o76  ILLEGAL       "ILLEGAL"        "$IL76$")
-    (#o77  ILLEGAL       "ILLEGAL"        "$IL77$")))
-
-
-(DEFPARAMETER +stars-sep+
+    (#o00  digit         "0"              "0")
+    (#o01  digit         "1"              "1")
+    (#o02  digit         "2"              "2")
+    (#o03  digit         "3"              "3")
+    (#o04  digit         "4"              "4")
+    (#o05  digit         "5"              "5")
+    (#o06  digit         "6"              "6")
+    (#o07  digit         "7"              "7")
+    (#o10  digit         "8"              "8")
+    (#o11  digit         "9"              "9")
+    (#o12  other         "END OF FILE"    "$EOF$"  apval1 (h12))
+    (#o13  operation     "="              "=")
+    (#o14  operation     "8-4 MINUS"      "\"")
+    (#o15  illegal       "ILLEGAL"        "$IL15$")
+    (#o16  illegal       "ILLEGAL"        "$IL16$")
+    (#o17  illegal       "ILLEGAL"        "$IL17$")
+    (#o20  operation     "+"              "+")
+    (#o21  letter        "A"              "A")
+    (#o22  letter        "B"              "B")
+    (#o23  letter        "C"              "C")
+    (#o24  letter        "D"              "D")
+    (#o25  letter        "E"              "E")
+    (#o26  letter        "F"              "F"      apval (0))
+    (#o27  letter        "G"              "G")
+    (#o30  letter        "H"              "H")
+    (#o31  letter        "I"              "I")
+    (#o32  other         "+0"             "$IL32$")
+    (#o33  other         "."              ".")
+    (#o34  other         ")"              ")")
+    (#o35  illegal       "ILLEGAL"        "$IL35$")
+    (#o36  illegal       "ILLEGAL"        "$IL36$")
+    (#o37  illegal       "ILLEGAL"        "$IL37$")
+    (#o40  operation     "11 MINUS"       "-")
+    (#o41  letter        "J"              "J")
+    (#o42  letter        "K"              "K")
+    (#o43  letter        "L"              "L")
+    (#o44  letter        "M"              "M")
+    (#o45  letter        "N"              "N")
+    (#o46  letter        "O"              "O")
+    (#o47  letter        "P"              "P")
+    (#o50  letter        "Q"              "Q")
+    (#o51  letter        "R"              "R")
+    (#o52  other         "-0"             "$IL52$")
+    (#o53  other         "$"              "$")
+    (#o54  operation     "*"              "*"      sym -c$star)
+    (#o55  illegal       "ILLEGAL"        "$IL55$")
+    (#o56  illegal       "ILLEGAL"        "$IL56$")
+    (#o57  illegal       "ILLEGAL"        "$IL57$")
+    (#o60  other         "BLANK"          " ")
+    (#o61  operation     "/"              "/")
+    (#o62  letter        "S"              "S")
+    (#o63  letter        "T"              "T"      apval (1))
+    (#o64  letter        "U"              "U")
+    (#o65  letter        "V"              "V")
+    (#o66  letter        "W"              "W")
+    (#o67  letter        "X"              "X")
+    (#o70  letter        "Y"              "Y")
+    (#o71  letter        "Z"              "Z")
+    (#o72  other         "END OF RECORD"  "$EOR$"  apval1 (h72))
+    (#o73  other         ","              ",")
+    (#o74  other         "("              "(")
+    (#o75  illegal       "ILLEGAL"        "$IL75$")
+    (#o76  illegal       "ILLEGAL"        "$IL76$")
+    (#o77  illegal       "ILLEGAL"        "$IL77$")))
+
+
+(defparameter +stars-sep+
   "**         * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *")

 (generate-oblb)
-(GENERATE-PLISTS)
+(generate-plists)

 (defun generate-plao ()
-  (LOOP initially (setf *line* -1)
-        FOR (code type comment pname . plist) IN +ALPHABET+
+  (loop initially (setf *line* -1)
+        for (code type comment pname . plist) in +alphabet+
         for label = (format nil "HH~2,'0O" code)
         do (if (eq type 'digit)
              (progn
@@ -1350,7 +1395,7 @@ or, a pointer to something else
                        (format nil ")H~2,'0O" code) ""
                        (format nil "-1,~A,-HH~2,'0O"
                                (if (< code 10) 1 "") code)) "GPLA"))
-  (FORMAT *CODE-OUTPUT*
+  (format *code-output*
 "UPERML BSS     0
        EJECT                                                            PAGE 217
        EJECT                                                            PAGE 218
@@ -1358,7 +1403,7 @@ or, a pointer to something else
 *      SYN CARDS CAUSE MANY SYMBOLS TO HAVE O-HEADED EQUIVALENTS
 *
 ")
-  (loop for code from 0 UPTO #o77 do
+  (loop for code from 0 upto #o77 do
         (punch (format nil "~6A ~7A ~A"
                        (format nil "H~2,'0O" code)
                        "SYN"
@@ -1386,7 +1431,9 @@ or, a pointer to something else
                           (format nil "-)~A" name)) "")))

 ;; (generate-oblb)
- (GENERATE-PLISTS)
+ (generate-plists)
 ;; (generate-plao)
 ;; (generate-syns)
-;; (generate-pjs)
\ No newline at end of file
+;; (generate-pjs)
+
+;;;; THE END ;;;;
ViewGit