Last active
July 4, 2022 08:22
-
-
Save texdraft/5570f5e7a9b71f245d8eb1f442c9c47c to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| (defpackage :LISP-1.5-compiler | |
| (:use :Common-Lisp) | |
| (:shadow :length ; defined by the compiler | |
| :reverse ; defined by the compiler | |
| :member ; defined by the compiler | |
| :map ; like mapl, and function is first argument | |
| :exp ; used as special variable in the compiler | |
| :compile ; defined by the compiler | |
| :maplist ; takes function first | |
| :mapcon ; takes function first | |
| :car ; can be used on atoms | |
| :cdr ; can be used on atoms | |
| :caar | |
| :cadr | |
| :cdar | |
| :cddr | |
| :caadr | |
| :cadar | |
| :caddr | |
| :cdaar | |
| :cddar | |
| :caadar | |
| :caaddr | |
| :cadadr | |
| :caddar | |
| :cdadar | |
| :cdaddr | |
| :error)) ; different arguments in LISP 1.5 | |
| (in-package :LISP-1.5-compiler) | |
| (defun remove-declares (form) | |
| (if (listp form) | |
| (loop for subform in form | |
| if (or (atom subform) | |
| (and (listp subform) | |
| (not (eq (first subform) 'declare)))) | |
| collect (remove-declares subform)) | |
| form)) | |
| (defmacro define (((&rest definitions))) | |
| `(progn ,@(loop for (name expression) in definitions | |
| collect `(progn (setf (get ',name 'expr) ',(remove-declares expression)) | |
| (defun ,name ,@(rest expression)))))) | |
| (setf (get 'prog 'fsubr) t | |
| (get 'return 'subr) t | |
| (get 'sub1 'subr) t | |
| (get 'equal 'subr) t | |
| (get 'times 'subr) t | |
| (get 'cond 'fsubr) t | |
| (get 'go 'fsubr) t | |
| (get 'select 'fexpr) t | |
| (get 'list 'subr) t | |
| (get 'eval 'subr) t | |
| (get 'conc 'fexpr) t | |
| (get 'function 'fsubr) t | |
| (get 'csetq 'fsubr) t | |
| (get 'map 'subr) t | |
| (get 'pair 'expr) t | |
| (get 'setq 'fsubr) t | |
| (get 'prog2 'subr) t | |
| (get 'gensym 'subr) t | |
| (get 'cons 'subr) t | |
| (get 'and 'fsubr) t | |
| (get 'or 'fsubr) t | |
| (get 'quote 'fsubr) t | |
| (get 'add1 'subr) t) | |
| ;; In LISP 1.5., car and cdr can be applied to atomic arguments. | |
| ;; Luckily the compiler never uses the fact that the cdr of a | |
| ;; symbol is its property list. | |
| (defun car (list?) | |
| (when (listp list?) | |
| (Common-Lisp:car list?))) | |
| (defun cdr (list?) | |
| (when (listp list?) | |
| (Common-Lisp:cdr list?))) | |
| (macrolet ((define-composition (name &rest parts) | |
| (let ((parameter (gensym))) | |
| `(defun ,name (,parameter) | |
| ,(reduce #'list (append parts (list parameter)) :from-end t))))) | |
| (define-composition caar car car) | |
| (define-composition cadr car cdr) | |
| (define-composition cdar cdr car) | |
| (define-composition cddr cdr cdr) | |
| (define-composition caadr car car cdr) | |
| (define-composition cadar car cdr car) | |
| (define-composition caddr car cdr cdr) | |
| (define-composition cdaar cdr car car) | |
| (define-composition cddar cdr cdr car) | |
| (define-composition caadar car car cdr car) | |
| (define-composition caaddr car car cdr cdr) | |
| (define-composition cadadr car cdr car cdr) | |
| (define-composition caddar car cdr cdr car) | |
| (define-composition cdadar cdr car cdr car) | |
| (define-composition cdaddr cdr car cdr cdr)) | |
| (defun error (whatever) | |
| (Common-Lisp:error "LISP 1.5 error ~A" whatever)) | |
| (defun map (list function) | |
| (mapl function list)) | |
| (defun maplist (list function) | |
| (Common-Lisp:maplist function list)) | |
| (defun mapcon (list function) | |
| (Common-Lisp:mapcon function list)) | |
| (defun add1 (number) | |
| (+ number 1)) | |
| (defun sub1 (number) | |
| (- number 1)) | |
| (defun greaterp (number1 number2) | |
| (> number1 number2)) | |
| (defun lessp (number1 number2) | |
| (< number1 number2)) | |
| (defun plus (&rest numbers) | |
| (apply #'+ numbers)) | |
| (defun difference (number1 number2) | |
| (- number1 number2)) | |
| (defun times (&rest numbers) | |
| (apply #'* numbers)) | |
| (defun flag (symbol indicator) | |
| (setf (get symbol indicator) t)) | |
| (defun remflag (symbols indicator) | |
| (mapcar (lambda (symbol) | |
| (setf (get symbol indicator) nil)) | |
| symbols)) | |
| (defun lap (&rest arguments) | |
| (print arguments) | |
| (terpri)) | |
| (defun conc (&rest lists) | |
| (mapcan #'list* lists)) | |
| (defun sassoc (item list function) | |
| (cond ((null list) | |
| (funcall function)) | |
| ((eq (first (first list)) item) | |
| (first list)) | |
| (t | |
| (sassoc item (rest list) function)))) | |
| (defun deflist (pairs indicator) | |
| (loop for (symbol value) in pairs do | |
| (setf (get symbol indicator) value))) | |
| (defun pair (keys values) | |
| (pairlis keys values)) | |
| (defmacro select (item &rest rest) | |
| ;; This evaluates item multiple times, but it's OK here. | |
| `(cond ,@(loop for clauses on rest | |
| as clause := (first clauses) | |
| collect (if (null (rest clauses)) | |
| (list 't clause) | |
| `((equal ,item ,(first clause)) | |
| ,(second clause)))))) | |
| (defvar f nil) | |
| (DEFINE (( | |
| (LENGTH | |
| (LAMBDA (M) | |
| (PROG (N) | |
| (SETQ N 0) | |
| A (COND ((NULL M) | |
| (RETURN N))) | |
| (SETQ N (ADD1 N)) | |
| (SETQ M (CDR M)) | |
| (GO A)))) | |
| (REVERSE | |
| (LAMBDA (X) | |
| (PROG (Y) | |
| A (COND ((NULL X) | |
| (RETURN Y))) | |
| (SETQ Y (CONS (CAR X) Y)) | |
| (SETQ X (CDR X)) | |
| (GO A)))) | |
| (MEMBER | |
| (LAMBDA (U V) | |
| (COND ((NULL V) | |
| NIL) | |
| ((EQUAL (CAR V) U) | |
| T) | |
| (T | |
| (MEMBER U (CDR V)))))) | |
| (COMVAL | |
| (LAMBDA (EXP STOMAP NAME) | |
| (declare (special ac stomap name)) | |
| (PROG NIL | |
| (COND ((OR (ATOM EXP) | |
| (MEMBER (CAR EXP) (QUOTE (QUOTE SPECIAL)))) | |
| (LAC EXP)) | |
| ((EQ (CAR EXP) (QUOTE SETQ)) | |
| (PROG NIL | |
| (COMVAL (CADDR EXP) STOMAP NAME) | |
| (ATTACH (LIST (CONS (QUOTE STO) (LOCATE (CADR EXP))))))) | |
| ((EQ (CAR EXP) (QUOTE COND)) | |
| (COMCOND (CDR EXP) T)) | |
| ((EQ (CAR EXP) (QUOTE PROG)) | |
| (COMPROG (CDDR EXP) (CADR EXP) NAME)) | |
| ((EQ (CAR EXP) (QUOTE OR)) | |
| (COMBOOL F F (CDR EXP) NIL)) | |
| ((EQ (CAR EXP) (QUOTE AND)) | |
| (COMBOOL T F (CDR EXP) NIL)) | |
| ((ATOM (CAR EXP)) | |
| (CALL (CAR EXP) (COMLIS (CDR EXP)))) | |
| (T | |
| (PROG NIL | |
| (COMPLY (CAR EXP) (CDR EXP)) | |
| (COMVAL (CADDAR EXP) STOMAP NAME)))) | |
| (SETQ AC NAME) | |
| (RETURN NAME)))) | |
| (COMPLY | |
| (LAMBDA (FN ARGS) | |
| (declare (special stomap)) | |
| (MAP (PAIR (CADR FN) ARGS) | |
| (FUNCTION (LAMBDA (J) | |
| (PROG NIL | |
| (COMVAL (CDAR J) STOMAP (GENSYM)) | |
| (STORE (CAAR J) T))))))) | |
| (COMLIS | |
| (LAMBDA (EXP) | |
| (declare (special stomap ac)) | |
| (PROG (X) | |
| (RETURN (MAPLIST EXP (FUNCTION (LAMBDA (J) | |
| (COND ((OR (EQ (CAAR J) (QUOTE QUOTE)) | |
| (ATOM (CAR J))) | |
| (CAR J)) | |
| (X | |
| (PROG2 (STORE AC T) | |
| (COMVAL (CAR J) STOMAP (GENSYM)))) | |
| (T | |
| (PROG2 (SETQ X T) | |
| (COMVAL (CAR J) STOMAP (GENSYM)))))))))))) | |
| (LAC | |
| (LAMBDA (X) | |
| (declare (special ac)) | |
| (COND ((EQUAL AC X) | |
| NIL) | |
| (T | |
| (ATTACH (LIST (CONS (QUOTE CLA) (LOCATE X)))))))) | |
| (STORE | |
| (LAMBDA (X Y) | |
| (declare (special stomap length)) | |
| (PROG NIL | |
| (COND ((OR (NULL X) | |
| (EQ (CAR X) (QUOTE QUOTE))) | |
| (RETURN NIL))) | |
| (SETQ STOMAP (CONS (CONS X (LIST (LIST (ADD1 (CAADAR STOMAP)) | |
| (QUOTE *N)) | |
| 1)) | |
| STOMAP)) | |
| (COND (Y | |
| (ATTACH (LIST (CONS (QUOTE STO) (LOCATE X)))))) | |
| (SETQ LENGTH (MAX LENGTH (CAADAR STOMAP)))))) | |
| (PHASE2X | |
| (LAMBDA (J) | |
| (declare (special exp)) | |
| (AND (EQ (CAADR EXP) (CADAR J)) | |
| (EQ (CAAR J) (QUOTE NULL)) | |
| (EQUAL (CADR J) (QUOTE (QUOTE NIL))))) | |
| #|(CADAR (CDDR EXP))|#) | |
| (PHASE2Y | |
| (LAMBDA (J) | |
| (LIST (COND ((LESSP J 3) | |
| 0) | |
| (T | |
| (DIFFERENCE (TIMES J 2) 4)))))) | |
| (PHASE2 | |
| (LAMBDA (EXP NAME) | |
| (declare (special exp)) | |
| (PROG (AC LISTING STOMAP LENGTH) | |
| (declare (special stomap ac listing length)) | |
| (COND ((PHASE2X (CADAR (CDDR EXP))) | |
| (PROG2 (ATTACH (QUOTE ((TZE 1 4)))) | |
| (SETQ EXP (LIST (CAR EXP) | |
| (CADR EXP) | |
| (CONS (QUOTE COND) (CDDAR (CDDR EXP)))))))) | |
| (ATTACH (LIST (LIST (QUOTE TNX) | |
| (LIST (QUOTE E) NAME) | |
| 1 | |
| (QUOTE *MN)) | |
| (APPEND (QUOTE (TSX *MOVE 1)) (PHASE2Y (LENGTH (CADR EXP)))))) | |
| (SETQ LENGTH 0) | |
| (SETQ STOMAP (QUOTE ((NIL (0 *N) 1)))) | |
| (MAP (CADR EXP) (FUNCTION (LAMBDA (J) | |
| (STORE (CAR J) F)))) | |
| (SETQ AC NIL) | |
| (COMVAL (CADDR EXP) STOMAP NIL) | |
| (COND ((NOT (MEMBER (CAADDR EXP) (QUOTE (COND PROG)))) | |
| (ATTACH (QUOTE ((TXI *RETURN 1 *MN)))))) | |
| (SETQ EXP (REVERSE LISTING)) | |
| (RETURN (LIST EXP (LIST (CONS (QUOTE *MN) (PLUS LENGTH 2)) | |
| (CONS (QUOTE *N) (DIFFERENCE -2 LENGTH)))))))) | |
| (COMPROG | |
| (LAMBDA (EXP PROGLIS RETN) | |
| (declare (special length stomap ac retn)) | |
| (PROG (GOLIST HOLD NAME SETS S) | |
| (declare (special golist name)) | |
| (SETQ HOLD EXP) | |
| A (COND ((NULL HOLD) | |
| (GO B)) | |
| ((ATOM (CAR HOLD)) | |
| (SETQ GOLIST (CONS (CONS (CAR HOLD) (GENSYM)) GOLIST))) | |
| ((NOT SETS) | |
| (COND ((EQ (CAAR HOLD) (QUOTE SPECBIND)) | |
| (SETQ S (CADADR HOLD))) | |
| (T | |
| (SETQ SETS T))))) | |
| (SETQ HOLD (CDR HOLD)) | |
| (GO A) | |
| B (SETQ HOLD PROGLIS) | |
| C (COND ((NULL HOLD) | |
| (GO G))) | |
| (STORE (CAR HOLD) NIL) | |
| (COND ((NOT (EQ (CAR HOLD) S)) | |
| (ATTACH (LIST (CONS (QUOTE STZ) (LOCATE (CAR HOLD))))))) | |
| (SETQ HOLD (CDR HOLD)) | |
| (GO C) | |
| G (SETQ HOLD EXP) | |
| D (SETQ AC NIL) | |
| (SETQ NAME (GENSYM)) | |
| (COND ((NULL HOLD) | |
| (GO E)) | |
| ((ATOM (CAR HOLD)) | |
| (ATTACH (LIST (CDR (SASSOC (CAR HOLD) GOLIST NIL))))) | |
| ((EQ (CAAR HOLD) (QUOTE GO)) | |
| (ATTACH (LIST (LIST (QUOTE TRA) | |
| (CDR (SASSOC (CADAR HOLD) | |
| GOLIST | |
| (FUNCTION (LAMBDA NIL | |
| (ERROR (QUOTE GO)))))))))) | |
| ((EQ (CAAR HOLD) (QUOTE COND)) | |
| (COMCOND (CDAR HOLD) F)) | |
| (T | |
| (COMVAL (CAR HOLD) STOMAP NAME))) | |
| (SETQ HOLD (CDR HOLD)) | |
| (GO D) | |
| E (COND (RETN | |
| (ATTACH (LIST RETN))))))) | |
| (COMPACT | |
| (LAMBDA (EXP NAME) | |
| (declare (special stomap flag switch name)) | |
| (COND ((EQ (CAR EXP) (QUOTE NULL)) | |
| (PROG2 (SETQ SWITCH (NOT SWITCH)) | |
| (COMPACT (CADR EXP) NAME))) | |
| ((EQUAL EXP (QUOTE (QUOTE *T*))) | |
| (COND (SWITCH | |
| (ATTACH (LIST (LIST (QUOTE TRA) NAME)))) | |
| (T | |
| (SETQ FLAG F)))) | |
| ((EQ (CAR EXP) (QUOTE OR)) | |
| (COMBOOL F T (CDR EXP) SWITCH)) | |
| ((EQ (CAR EXP) (QUOTE AND)) | |
| (COMBOOL T T (CDR EXP) SWITCH)) | |
| (T | |
| (PROG2 (COND ((EQ (CAR EXP) (QUOTE EQ)) | |
| (CEQ EXP STOMAP)) | |
| (T | |
| (COMVAL EXP STOMAP (GENSYM)))) | |
| (ATTACH (LIST (LIST (COND (SWITCH | |
| (QUOTE TNZ)) | |
| (T | |
| (QUOTE TZE))) | |
| NAME)))))))) | |
| (COMBOOL | |
| (LAMBDA (FN MODE EXP A) | |
| (PROG (GEN SWITCH) | |
| (declare (special switch listing ac name)) | |
| (SETQ GEN (GENSYM)) | |
| A (SETQ SWITCH NIL) | |
| (COND ((NULL EXP) | |
| (GO C)) | |
| ((AND MODE | |
| (NULL (CDR EXP)) | |
| (EQ A FN)) | |
| (GO B))) | |
| (COMPACT (COND (FN | |
| (CAR EXP)) | |
| (T | |
| (LIST (QUOTE NULL) (CAR EXP)))) | |
| (COND ((AND MODE (NOT A)) | |
| (COND (FN | |
| NAME) | |
| (T | |
| GEN))) | |
| (T | |
| (COND ((NOT MODE) | |
| GEN) | |
| (FN | |
| GEN) | |
| (T | |
| NAME))))) | |
| (SETQ AC (COND ((EQ (CAAR LISTING) (QUOTE TNZ)) | |
| (QUOTE (QUOTE NIL))) | |
| (T | |
| (QUOTE (QUOTE *T*))))) | |
| (SETQ EXP (CDR EXP)) | |
| (GO A) | |
| B (COMPACT (COND (FN | |
| (LIST (QUOTE NULL) (CAR EXP))) | |
| (T | |
| (CAR EXP))) | |
| NAME) | |
| C (COND ((NOT MODE) | |
| (ATTACH (LIST (QUOTE (TRA (* 2))) | |
| (LIST (QUOTE CLA) | |
| (LIST (QUOTE QUOTE) FN)))))) | |
| (ATTACH (LIST GEN)) | |
| (COND ((NOT MODE) | |
| (ATTACH (LIST (LIST (QUOTE CLA) | |
| (LIST (QUOTE QUOTE) | |
| (NOT FN)))))))))) | |
| (COMCOND | |
| (LAMBDA (EXP MODE) | |
| (PROG (FLAG SWITCH GEN) | |
| (declare (special switch ac golist name stomap)) | |
| (SETQ FLAG T) | |
| A (COND ((NULL EXP) | |
| (GO B))) | |
| (SETQ GEN (GENSYM)) | |
| (SETQ SWITCH NIL) | |
| (COND ((AND (NOT MODE) | |
| (EQ (CAADAR EXP) (QUOTE GO))) | |
| (GO C))) | |
| (COMPACT (CAAR EXP) GEN) | |
| (SETQ AC (COND (SWITCH | |
| (QUOTE (QUOTE NIL))) | |
| (T | |
| NIL))) | |
| (COMVAL (CADAR EXP) STOMAP NAME) | |
| (COND ((OR (AND NAME (NULL (CDR EXP))) | |
| (MEMBER (CAADAR EXP) (QUOTE (RETURN GO)))) | |
| (GO L))) | |
| (ATTACH (LIST (COND (NAME | |
| (LIST (QUOTE TRA) NAME)) | |
| (T | |
| (QUOTE (TXI *RETURN 1 *MN)))))) | |
| L (ATTACH (LIST GEN)) | |
| D (SETQ EXP (CDR EXP)) | |
| (SETQ AC (COND (SWITCH | |
| (QUOTE NIL)) | |
| (T | |
| (QUOTE (QUOTE NIL))))) | |
| (GO A) | |
| B (COND (NAME | |
| (ATTACH (LIST NAME)))) | |
| (RETURN NIL) | |
| C (COMPACT (LIST (QUOTE NULL) (CAAR EXP)) | |
| (CDR (SASSOC (CADR (CADAR EXP)) | |
| GOLIST | |
| (FUNCTION (LAMBDA () | |
| (ERROR (QUOTE GO))))))) | |
| (GO D)))) | |
| (CEQ | |
| (LAMBDA (EXP STOMAP) | |
| (declare (special stomap)) | |
| (PROG (A) | |
| (declare (special ac switch)) | |
| (SETQ A (COMLIS (CDR EXP))) | |
| (COND ((EQUAL (CAR A) AC) | |
| (ATTACH (LIST (CONS (QUOTE SUB) | |
| (LOCATE (CADR A)))))) | |
| (T | |
| (PROG2 (LAC (CADR A)) | |
| (ATTACH (LIST (CONS (QUOTE SUB) | |
| (LOCATE (CAR A)))))))) | |
| (SETQ SWITCH (NOT SWITCH))))) | |
| (CALL | |
| (LAMBDA (FN ARGS) | |
| (PROG (HOLD ITEM NUM) | |
| (declare (special ac retn)) | |
| (COND ((MEMBER FN (QUOTE (SPECBIND SPECRSTR LIST RETURN GO))) | |
| (GO E)) | |
| ((NULL ARGS) | |
| (GO D)) | |
| ((NULL (CDR ARGS)) | |
| (GO C))) | |
| (SETQ HOLD (REVERSE (CDDR ARGS))) | |
| (SETQ NUM (LENGTH ARGS)) | |
| (COND ((GREATERP NUM 20) | |
| (ERROR (QUOTE ARGS)))) | |
| A (COND ((NULL HOLD) (GO B))) | |
| (SETQ ITEM (CAR HOLD)) | |
| (COND ((EQUAL ITEM (QUOTE (QUOTE NIL))) | |
| (ATTACH (LIST (LIST (QUOTE STZ) | |
| (LIST (QUOTE $ALIST) NUM))))) | |
| ((EQUAL ITEM AC) | |
| (ATTACH (LIST (LIST (QUOTE STO) | |
| (LIST (QUOTE $ALIST) NUM))))) | |
| (T | |
| (ATTACH (LIST (LIST (QUOTE STQ) | |
| (LIST (QUOTE $ALIST) NUM)) | |
| (CONS (QUOTE LDQ) (LOCATE ITEM)))))) | |
| (SETQ HOLD (CDR HOLD)) | |
| (SETQ NUM (SUB1 NUM)) | |
| (GO A) | |
| B (COND ((EQUAL AC (CADR ARGS)) | |
| (COND ((EQUAL AC (CAR ARGS)) | |
| (ATTACH (QUOTE ((LDQ ($ALIST 2)) | |
| (STO ($ALIST 2)))))) | |
| (T | |
| (ATTACH (QUOTE ((XCA))))))) | |
| (T | |
| (ATTACH (LIST (CONS (QUOTE LDQ) | |
| (LOCATE (CADR ARGS))))))) | |
| C (LAC (CAR ARGS)) | |
| D (ATTACH (LIST (LIST (QUOTE STR) | |
| (LIST (QUOTE E) FN) | |
| 7 | |
| (LENGTH ARGS)))) | |
| (RETURN NIL) | |
| E (COND ((EQ FN (QUOTE GO)) | |
| (ERROR (QUOTE GO))) | |
| ((EQ FN (QUOTE RETURN)) | |
| (PROG NIL | |
| (LAC (CAR ARGS)) | |
| (ATTACH (LIST (COND (RETN | |
| (LIST (QUOTE TRA) RETN)) | |
| (T | |
| (QUOTE (TXI *RETURN 1 *MN)))))))) | |
| ((EQ FN (QUOTE LIST)) | |
| (PROG (X) | |
| (COND ((NULL ARGS) | |
| (RETURN (ATTACH (QUOTE ((CLA (QUOTE NIL)))))))) | |
| (COND (AC | |
| (LOCATE AC))) | |
| (ATTACH (QUOTE ((TSX *LIST 4)))) | |
| (ATTACH (LIST (CONS (TIMES (LENGTH ARGS) #o100000000) | |
| (LOCATE (CAR ARGS))))) | |
| (SETQ X (CDR ARGS)) | |
| A (COND ((NULL X) | |
| (RETURN NIL))) | |
| (ATTACH (LIST (CONS 0 (LOCATE (CAR X))))) | |
| (SETQ X (CDR X)) | |
| (GO A))) | |
| ((MEMBER FN (QUOTE (SPECBIND SPECRSTR))) | |
| (PROG NIL | |
| (ATTACH (LIST (LIST (QUOTE TSX) | |
| FN | |
| 4))) | |
| (MAPLIST (CADAR ARGS) | |
| (FUNCTION (LAMBDA (J) | |
| (ATTACH (LIST (LIST (COND ((CDR J) | |
| 0) | |
| (T | |
| (QUOTE STR))) | |
| (CAR (LOCATE (CAR J))) | |
| 1 | |
| (LIST (QUOTE SPECIAL) | |
| (CAR J)))))))))))))) | |
| (ATTACH | |
| (LAMBDA (A) | |
| (declare (special listing)) | |
| (COND ((AND (EQUAL (CAR A) (QUOTE (TXI *RETURN 1 *MN))) | |
| (MEMBER (CAAR LISTING) (QUOTE (TXI TRA)))) | |
| NIL) | |
| (T | |
| (SETQ LISTING (APPEND A LISTING)))))) | |
| (LOCATE | |
| (LAMBDA (X) | |
| (declare (special ac stomap)) | |
| (COND ((OR (EQ (CAR X) (QUOTE QUOTE)) | |
| (EQ (CAR X) (QUOTE SPECIAL)) | |
| (EQ X (QUOTE $ALIST))) | |
| (LIST X)) | |
| (T | |
| (CDR (SASSOC X | |
| STOMAP | |
| (FUNCTION (LAMBDA NIL | |
| (COND ((EQ X AC) | |
| (PROG NIL | |
| (STORE AC T) | |
| (RETURN (SASSOC X | |
| STOMAP | |
| (constantly nil))))) | |
| (T | |
| (ERROR (LIST X (QUOTE UNDECLARED))))))))))))) | |
| (DELETEL | |
| (LAMBDA (L M) | |
| (MAPCON M (FUNCTION (LAMBDA (J) | |
| (COND ((MEMBER (CAR J) L) | |
| NIL) | |
| (T | |
| (LIST (CAR J))))))))) | |
| (PASSONE | |
| (LAMBDA (NAME FN) | |
| (PALAM (PROGITER NAME FN) NIL))) | |
| (PA1 | |
| (LAMBDA (L) | |
| (declare (special b)) | |
| (MAPLIST L (FUNCTION (LAMBDA (J) | |
| (PAFORM (CAR J) B)))))) | |
| (PA4 | |
| (LAMBDA (COMS SPECS G) | |
| (declare (special b fn)) | |
| (COND ((AND (NULL COMS) | |
| (NULL SPECS)) | |
| (LIST (QUOTE LAMBDA) | |
| (CADR FN) | |
| (PAFORM (CADDR FN) | |
| (APPEND (CADR FN) B)))) | |
| (T | |
| (LIST (QUOTE LAMBDA) | |
| (CADR FN) | |
| (CONC (LIST (QUOTE PROG) (LIST G)) | |
| (PA11 COMS (QUOTE COMBIND)) | |
| (PA9 SPECS (QUOTE SPECBIND)) | |
| (LIST (LIST (QUOTE SETQ) | |
| G | |
| (PAFORM (CADDR FN) (APPEND (CADR FN) B)))) | |
| (PA9 SPECS (QUOTE SPECRSTR)) | |
| (PA14 COMS) | |
| (PA12 G))))))) | |
| (PA3 | |
| (LAMBDA (L) | |
| (declare (special b g)) | |
| (COND ((NULL (CDR L)) | |
| (LIST (LIST (QUOTE (QUOTE *T*)) | |
| (PAFORM (CAR L) B)))) | |
| (T | |
| (CONS (LIST (LIST (QUOTE EQ) G (PAFORM (CAAR L) B)) | |
| (PAFORM (CADAR L) B)) | |
| (PA3 (CDR L))))))) | |
| (PA5 | |
| (LAMBDA (VARS PROP) | |
| (COND ((NULL VARS) | |
| NIL) | |
| ((GET (CAR VARS) PROP) | |
| (CONS (CAR VARS) | |
| (PA5 (CDR VARS) PROP))) | |
| (T | |
| (PA5 (CDR VARS) PROP))))) | |
| (PA6 | |
| (LAMBDA (KIND VAR) | |
| (LIST (LIST KIND (LIST (QUOTE QUOTE) VAR) | |
| (CONS (QUOTE LIST) VAR))))) | |
| (PA7 | |
| (LAMBDA (L B) | |
| (COND ((NULL L) | |
| (QUOTE ((RETURN (QUOTE NIL))))) | |
| ((AND (NULL (CDR L)) | |
| (EQ (CAAR L) (QUOTE GO))) | |
| L) | |
| ((ATOM (CAR L)) | |
| (CONS (CAR L) (PA7 (CDR L) B))) | |
| (T | |
| (CONS (PAFORM (CAR L) B) | |
| (PA7 (CDR L) B)))))) | |
| (PA11 | |
| (LAMBDA (VARS FUNC) | |
| (COND (VARS | |
| (PA6 FUNC VARS)) | |
| (T | |
| NIL)))) | |
| (PA14 | |
| (LAMBDA (COMS) | |
| (COND (COMS | |
| (LIST (LIST (QUOTE COMRSTR) | |
| (LIST (QUOTE QUOTE) (LENGTH COMS))))) | |
| (T | |
| NIL)))) | |
| (PA12 | |
| (LAMBDA (G) | |
| (LIST (LIST (QUOTE RETURN) G)))) | |
| (compile | |
| (LAMBDA (L) | |
| (MAPLIST L (FUNCTION (LAMBDA (J) | |
| (COM1 (CAR J) | |
| (GET (CAR J) (QUOTE EXPR)) | |
| (GET (CAR J) (QUOTE FEXPR)))))))) | |
| (COM1 | |
| (LAMBDA (N A B) | |
| (PROG2 (COND (A | |
| (COM2 (QUOTE SUBR) (LENGTH (CADR A)) A N)) | |
| (B | |
| (COM2 (QUOTE FSUBR) (LENGTH (CADR B)) B N)) | |
| (T | |
| (PRINT (LIST N (QUOTE UNDEFINED))))) | |
| N))) | |
| (COM2 | |
| (LAMBDA (TYPE LENGTH EXP NAME) | |
| (PROG (LISTING) | |
| (SETQ LISTING (PHASE2 (PASSONE NAME EXP) NAME)) | |
| (TERPRI) | |
| (TERPRI) | |
| (TERPRI) | |
| (PRINT (LIST NAME TYPE LENGTH)) | |
| (MAP (CAR LISTING) | |
| (FUNCTION (LAMBDA (J) | |
| (PRINT (CAR J))))) | |
| (TERPRI) | |
| (LAP (CONS (LIST NAME TYPE LENGTH) | |
| (CAR LISTING)) | |
| (CADR LISTING)) | |
| (REMPROP NAME (QUOTE EXPR)) | |
| (REMPROP NAME (QUOTE FEXPR)) | |
| (RETURN NAME)))) | |
| (COMMON | |
| (LAMBDA (L) | |
| (FLAG L (QUOTE COMMON)))) | |
| (UNCOMMON | |
| (LAMBDA (L) | |
| (REMFLAG L (QUOTE COMMON)))) | |
| (1.5-SPECIAL | |
| (LAMBDA (X) | |
| (MAPLIST X (FUNCTION (LAMBDA (J) | |
| (DEFLIST (LIST (LIST (CAR J) (LIST NIL))) | |
| (QUOTE SPECIAL))))))) | |
| (UNSPECIAL | |
| (LAMBDA (L) | |
| (MAP L (FUNCTION (LAMBDA (J) | |
| (REMPROP (CAR J) (QUOTE SPECIAL))))))) | |
| (progiter1 | |
| (LAMBDA (G1 G2 VS GS) | |
| (declare (special exp g2 gs)) | |
| (LIST (QUOTE LAMBDA) | |
| VS | |
| (CONS (QUOTE PROG) | |
| (CONS GS (CONS G1 (PI3 (CDADDR EXP) | |
| NIL | |
| (CONS G2 (PAIRMAP VS | |
| GS | |
| (FUNCTION PI2) | |
| (LIST (LIST (QUOTE GO) G1))))))))))) | |
| (PROGITER | |
| (LAMBDA (NAME EXP) | |
| (declare (special name exp)) | |
| (COND ((AND (EQ (CAADDR EXP) (QUOTE COND)) | |
| (PI1 (CDADDR EXP))) | |
| (progiter1 (GENSYM) | |
| (GENSYM) | |
| (CADR EXP) | |
| (MAPLIST (CADR EXP) (lambda (_) | |
| (declare (ignore _)) | |
| (gensym))))) | |
| (T | |
| EXP)))) | |
| (PI1 | |
| (LAMBDA (L) | |
| (declare (special name)) | |
| (COND ((NULL L) | |
| F) | |
| ((EQ (CAADAR L) NAME) | |
| T) | |
| (T | |
| (PI1 (CDR L)))))) | |
| (PI2 | |
| (LAMBDA (J K) | |
| (LIST (QUOTE SETQ) J K))) | |
| (PI31 | |
| (LAMBDA (G3) | |
| (declare (special g2 c gs l s)) | |
| (PI3 (CDR L) | |
| (NCONC C (LIST (LIST (CAAR L) (LIST (QUOTE GO) G3)))) | |
| (CONS G3 (PAIRMAP GS | |
| (CDADAR L) | |
| (FUNCTION PI2) | |
| (CONS (LIST (QUOTE GO) G2) S)))))) | |
| (PI3 | |
| (LAMBDA (L C S) | |
| (declare (special l c s name)) | |
| (COND ((NULL L) | |
| (CONS (CONS (QUOTE COND) C) S)) | |
| ((EQ (CAADAR L) NAME) | |
| (PI31 (GENSYM))) | |
| (T | |
| (PI3 (CDR L) | |
| (NCONC C (LIST (LIST (CAAR L) | |
| (LIST (QUOTE RETURN) | |
| (CADAR L))))) | |
| S))))) | |
| (PALAM | |
| (LAMBDA (FN B) | |
| (declare (special fn b)) | |
| (COND ((ATOM FN) | |
| FN) | |
| ((EQ (CAR FN) (QUOTE LAMBDA)) | |
| (PA4 (PA5 (CADR FN) (QUOTE COMMON)) | |
| (PA5 (CADR FN) (QUOTE SPECIAL)) | |
| (GENSYM))) | |
| ((EQ (CAR FN) (QUOTE LABEL)) | |
| (COMP (CADR FN) (CADDR FN))) | |
| (T | |
| (ERROR (CONS FN (QUOTE (NOT FUNCTION)))))))) | |
| (PAFORM | |
| (LAMBDA (FORM B) | |
| (declare (special form b)) | |
| (COND ((ATOM FORM) | |
| (COND ((OR (NUMBERP FORM) | |
| (MEMBER FORM (QUOTE (NIL *T*)))) | |
| (LIST (QUOTE QUOTE) FORM)) | |
| ((EQ FORM (QUOTE T)) | |
| (QUOTE (QUOTE *T*))) | |
| ((EQ FORM (QUOTE F)) | |
| (QUOTE (QUOTE NIL))) | |
| ((GET FORM (QUOTE COMMON)) | |
| (LIST (QUOTE EVAL) (LIST (QUOTE QUOTE) FORM) (QUOTE $ALIST))) | |
| ((GET FORM (QUOTE SPECIAL)) | |
| (LIST (QUOTE SPECIAL) FORM)) | |
| ((MEMBER FORM B) | |
| FORM) | |
| (T | |
| (PROG NIL | |
| (PRINT (CONS FORM (QUOTE (UNDECLARED)))) | |
| (RETURN (LIST (QUOTE EVAL) | |
| (LIST (QUOTE QUOTE) FORM) | |
| (QUOTE $ALIST))))))) | |
| ((ATOM (CAR FORM)) | |
| (COND ((OR (GET (CAR FORM) (QUOTE FSUBR)) | |
| (GET (CAR FORM) (QUOTE FEXPR))) | |
| (COND ((MEMBER (CAR FORM) (QUOTE (AND OR))) | |
| (CONS (CAR FORM) (PA1 (CDR FORM)))) | |
| ((MEMBER (CAR FORM) (QUOTE (MAX MIN PLUS TIMES LOGOR LOGAND LOGXOR))) | |
| (LIST (CAR FORM) | |
| (CONS (QUOTE LIST) (PA1 (CDR FORM))) | |
| (QUOTE $ALIST))) | |
| (T | |
| (SELECT (CAR FORM) | |
| ((QUOTE COND) | |
| (CONS (QUOTE COND) | |
| (MAPLIST (CDR FORM) | |
| (FUNCTION (LAMBDA (J) | |
| (LIST (PAFORM (CAAR J) B) | |
| (PAFORM (CADAR J) B))))))) | |
| ((QUOTE LIST) | |
| (CONS (QUOTE LIST) (PA1 (CDR FORM)))) | |
| ((QUOTE QUOTE) | |
| FORM) | |
| ((QUOTE PROG) | |
| (PA8 (PA5 (CADR FORM) (QUOTE COMMON)) | |
| (PA5 (CADR FORM) (QUOTE SPECIAL)) | |
| (GENSYM))) | |
| ((QUOTE FUNCTION) | |
| (LIST (QUOTE FUNC) | |
| (LIST (QUOTE QUOTE) (COMP (GENSYM) (CADR FORM))) | |
| (QUOTE $ALIST))) | |
| ((QUOTE SETQ) | |
| (COND ((GET (CADR FORM) (QUOTE COMMON)) | |
| (LIST (QUOTE SETC) | |
| (LIST (QUOTE QUOTE) (CADR FORM)) | |
| (PAFORM (CADDR FORM) B))) | |
| (T | |
| (LIST (QUOTE SETQ) | |
| (PAFORM (CADR FORM) B) | |
| (PAFORM (CADDR FORM) B))))) | |
| ((QUOTE GO) | |
| FORM) | |
| ((QUOTE CSETQ) | |
| (LIST (QUOTE CSET) | |
| (LIST (QUOTE QUOTE) (CADR FORM)) | |
| (PAFORM (CADDR FORM) B))) | |
| ((QUOTE SELECT) | |
| ((LAMBDA (G) | |
| (declare (special g)) | |
| (LIST (LIST (QUOTE LAMBDA) | |
| (LIST G) | |
| (CONS (QUOTE COND) | |
| (PA3 (CDDR FORM)))) | |
| (PAFORM (CADR FORM) B))) | |
| (GENSYM))) | |
| ((QUOTE CONC) | |
| (PA2 (CDR FORM))) | |
| (LIST (CAR FORM) | |
| (LIST (QUOTE QUOTE) (CDR FORM)) | |
| (QUOTE $ALIST)))))) | |
| ((EQ (CAR FORM) (QUOTE NOT)) | |
| (LIST (QUOTE NULL) | |
| (PAFORM (CADR FORM) B))) | |
| ((EQ (CAR FORM) (QUOTE SET)) | |
| (LIST (QUOTE SETC) | |
| (PAFORM (CADR FORM) B) | |
| (PAFORM (CADDR FORM) B))) | |
| (T | |
| (CONS (CAR FORM) (PA1 (CDR FORM)))))) | |
| ((OR (EQ (CAAR FORM) (QUOTE LAMBDA)) | |
| (EQ (CAAR FORM) (QUOTE LABEL))) | |
| (CONS (PALAM (CAR FORM) B) (PA1 (CDR FORM)))) | |
| (T | |
| (LIST (QUOTE APPLY) | |
| (PAFORM (CAR FORM) B) | |
| (CONS (QUOTE LIST) (PA1 (CDR FORM))) | |
| (QUOTE $ALIST)))))) | |
| (PAIRMAP | |
| (LAMBDA (L M FARG Z) | |
| (PROG (A B) | |
| (COND ((NULL L) | |
| (RETURN Z))) | |
| (SETQ A (SETQ B (CONS (funcall FARG (CAR L) (CAR M)) Z))) | |
| A (SETQ L (CDR L)) | |
| (SETQ M (CDR M)) | |
| (COND ((NULL L) | |
| (RETURN A))) | |
| (SETQ B (CDR (RPLACD B (CONS (funcall FARG (CAR L) (CAR M)) Z)))) | |
| (GO A)))) | |
| (PA8 | |
| (LAMBDA (COMS SPECS G) | |
| (declare (special b form)) | |
| (COND ((AND (NULL COMS) (NULL SPECS)) | |
| (CONS (QUOTE PROG) | |
| (CONS (CADR FORM) | |
| (PA7 (CDDR FORM) (APPEND (CADR FORM) B))))) | |
| (T | |
| (CONC (LIST (QUOTE PROG) | |
| (CONS G (APPEND COMS SPECS))) | |
| (PA11 COMS (QUOTE COMBIND)) | |
| (PA9 SPECS (QUOTE SPECBIND)) | |
| (LIST (LIST (QUOTE SETQ) | |
| G | |
| (CONS (QUOTE PROG) | |
| (CONS (DELETEL (APPEND COMS SPECS) (CADR FORM)) | |
| (PA7 (CDDR FORM) (APPEND (CADR FORM) B)))))) | |
| (PA9 SPECS (QUOTE SPECRSTR)) | |
| (PA14 COMS) | |
| (PA12 G)))))) | |
| (COMP | |
| (LAMBDA (N E) | |
| (COND ((ATOM E) | |
| E) | |
| (T | |
| (COM2 (QUOTE SUBR) (LENGTH (CADR E)) E N))))) | |
| (PA9 | |
| (LAMBDA (V K) | |
| (COND (V | |
| (LIST (LIST K (LIST (QUOTE QUOTE) V)))) | |
| (T | |
| NIL)))) | |
| (PA2 | |
| (LAMBDA (L) | |
| (declare (special b)) | |
| (COND ((NULL L) | |
| (QUOTE (QUOTE NIL))) | |
| (T | |
| (LIST (QUOTE APPEND) | |
| (PAFORM (CAR L) B) | |
| (PA2 (CDR L))))))) | |
| ))) | |
| ;; Uncomment the rest of this file to compile the compiler. | |
| #| | |
| (COMPILE '(PA5 COMP PA9 PA12 PA7)) | |
| (1.5-SPECIAL '(NAME GS G2 FN B FORM LENGTH AC STOMAP LISTING SWITCH FLAG RETN GOLIST | |
| RENAME HOLD EXP X L C S G | |
| )) | |
| (COMPILE '( | |
| COM2 PROGITER PROGITER1 PI1 PI2 PI3 PI31 PALAM PA4 PAFORM PA1 PA2 PA3 PA8 | |
| DELETEL PHASE2 PHASE2Y PHASE2X COMVAL COMPROG COMCOND COMBOOL COMPACT CEQ | |
| COMPLY COMLIS STORE CALL LAC ATTACH LOCATE COMPACT COM1 PA6 PA11 PA14 | |
| COMPILE | |
| )) | |
| (UNSPECIAL '( | |
| NAME GS G2 FN B FORM LEN AC STOMAP LISTING SWITCH FLAG RETN GOLIST | |
| RENAME HOLD EXP | |
| )) | |
| |# |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment