From 8ce4632ed1690604cfa7f5bce383a7cd6d9d4e9f Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Tue, 25 Sep 2018 19:06:50 -0700 Subject: [PATCH] Build yahtze fasl from source. Resolves #890. --- Makefile | 2 +- build/lisp.tcl | 14 ++ src/sca/macros.107 | 555 +++++++++++++++++++++++++++++++++++++++++++++ src/sca/mode.192 | 467 ++++++++++++++++++++++++++++++++++++++ src/sca/modeb.187 | 444 ++++++++++++++++++++++++++++++++++++ 5 files changed, 1481 insertions(+), 1 deletion(-) create mode 100644 src/sca/macros.107 create mode 100644 src/sca/mode.192 create mode 100644 src/sca/modeb.187 diff --git a/Makefile b/Makefile index 3c5cc585..13aa7bc1 100644 --- a/Makefile +++ b/Makefile @@ -25,7 +25,7 @@ SRC = syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ tensor transl wgd zz graphs lmlib pratt quux scheme gsb ejs mudsys \ draw wl taa tj6 budd sharem ucode rvb kldcp math as imsrc gls demo \ macsym lmcons dmcg hack hibou agb gt40 rug maeda ms kle aap common \ - fonts zork 11logo kmp info aplogo bkph bbn pdp11 chsncp + fonts zork 11logo kmp info aplogo bkph bbn pdp11 chsncp sca DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ diff --git a/build/lisp.tcl b/build/lisp.tcl index baae99de..1e2fc4d4 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -888,6 +888,20 @@ respond "_" "games;_chase\r" respond "_" "\032" type ":kill\r" +# yahtze +respond "*" "complr\013" +respond "_" "sca;macros\r" +respond "_" "sca;modeb\r" +respond "_" "\032" +type ":kill\r" + +# note sca;mode > will not compile. Yahtze will load it interpreted + +respond "*" "complr\013" +respond "_" "games;yahtze\r" +respond "_" "\032" +type ":kill\r" + # ITSter respond "*" "complr\013" respond "_" "games;_hibou;itster\r" diff --git a/src/sca/macros.107 b/src/sca/macros.107 new file mode 100644 index 00000000..cc1cc404 --- /dev/null +++ b/src/sca/macros.107 @@ -0,0 +1,555 @@ +;-*-lisp-*- +;*********************************************************************** +;**************** Assorted Macros for Extending Maclisp **************** +;****** (c) copyright 1977 Massachusetts Institute of Technology ******* +;*********************************************************************** +;********************* Do not modify this file !!! ********************* +;*********************************************************************** + +;These are general macros for extending MACLISP. The major ones are `, +;MACRO-EXPAND, DEFUN-SMAC, MACRODEF, BIND, ERLIST, and CASE. The ` gives a +;MUDDLE-like syntax for quoting expressions: it works like ', except that +;items preceded by "," (comma) are not quoted, and items preceded by "@" +;(at-sign) are also not quoted, and their values are APPEND'ed into the list. +;MACRO-EXPAND will expand all macros in a form. DEFUN-SMAC allows macros to +;be defined using a pattern-matching type description of the argument. +;MACRODEF allows MACRO's to be defined much like EXPR's are with DEFUN. BIND +;is a shorthand for LAMBDA, where the values which arguments are bound to are +;listed at the beginning of the form, rather than at the end. ERLIST is a +;macro which outputs an error message and signals an error. CASE expands into +;a COND, with several special features. Finally, _ is a sort of generalized +;setq, which accepts non-atomic first arguments. +; +;These macros and many minor ones are defined and further documented below. +;This file (actually SCA;MACROS FASL) should be FASLOAD'ed into any file which +;uses it by: +; +;(DECLARE (EVAL (READ))) +;(LOAD '((DSK SCA) MACROS FASL)) +; +;Also, the file SCA;MFCNS FASL should be loaded into a lisp, as it contains +;definitions of expr's which these macros may expand into. + +(declare (mapex t) + (genprefix scamac) + (macros t) + (special compiler-state scachars scaibase scabase sca*nopoint) + (fixnum scachars) + (*lexpr sfuncall)) + +;Since they are not yet fully implemented: + +(declare (defun @define macro (l) nil)) +(defun @define macro (l) nil) +(declare (defun symbolp macro (l) (subst (cadr l) 'x '(eq (typep x) 'symbol)))) +(defun symbolp macro (l) (subst (cadr l) 'x '(eq (typep x) 'symbol))) +(declare (defun bssq macro (l) (cons 'assq (cdr l)))) +(defun bssq macro (l) (cons 'assq (cdr l))) + +(declare (@define omacrodef |MACRO|)) + +(comment subtitle Syntax Macros) + +;Macros and functions which should both be known by the compiler and come +;through to the final file are preceded by a "%". [For macros, one needs a +;(declare (macros t)) also.] This is given a character-macro property: a +;no-op for the interpreter, and the correct meaning for the compiler. Things +;only for the compiler (unless not compiled) should be preceded by a "#". + +(defun scachar macro (l) + (setsyntax '/% 'macro '(lambda () (eval-and-compile (read)))) + (setsyntax '/# 'macro '(lambda () (evalmacro (eval (read))))) + (setsyntax '/` 'macro + '(lambda () + ((lambda (readtable) (qexpander (read))) + (get 'muddle-quote-readtable 'array)))) + (setsyntax '/\ 'macro 'make-mode-note) + (setsyntax '/: 'macro 'infix-select) + (setsyntax '/[ 'macro 'left-bracket) ;used like a comment + (setsyntax '/] 'macro '(lambda () '/])) ;[eye-catcher] + (cond ((= scachars 0) + (setq scabase base scaibase ibase sca*nopoint *nopoint))) + (setq base 10. ibase 10. *nopoint t) + (setq scachars (1+ scachars)) + t) + +(defun scaunchar macro (l) + (setq scachars (1- scachars)) + (cond ((= scachars 0) + (setsyntax '/% 'macro nil) ;right method? + (setsyntax '/# 'macro nil) + (setsyntax '/` 'macro nil) + (setsyntax '/\ 'macro nil) + (setsyntax '/: 'macro nil) + (setsyntax '/[ 'macro nil) + (setsyntax '/] 'macro nil) + (setq base scabase ibase scaibase *nopoint sca*nopoint))) + (signp ge scachars)) + +(declare (setq scachars 0)) +(setq scachars 0) + +(scachar) + + +(declare + (defun eval-and-compile (f) + (cond ((and (boundp 'compiler-state) + compiler-state + (not (eq compiler-state 'toplevel))) + ((lambda (compiler-state) (eval f)) nil) f) + (t f)))) + +(defun eval-and-compile (f) + (cond ((and (boundp 'compiler-state) + compiler-state + (not (eq compiler-state 'toplevel))) + ((lambda (compiler-state) (eval f)) nil) f) + (t f))) + +(defun evalmacro macro (l) + ((lambda (compiler-state) (eval (cadr l)) t) nil)) + +%(*array 'muddle-quote-readtable 'readtable) + +%((lambda (readtable) + (setsyntax '/, 'macro '(lambda () (cons '/, (read)))) + (setsyntax '/@ 'macro '(lambda () (cons '/@ (read)))) + (scachar) + (setq scachars (1- scachars))) + (get 'muddle-quote-readtable 'array)) + +%(defun qexpander (m) + (prog (x y) + (cond ((atom m) (return (list 'quote m))) + ((eq (car m) '/,) (return (cdr m))) + ((and (not (atom (car m))) + (eq (caar m) '/@)) + (cond ((cdr m) + (return + (list 'append (cdar m) (qexpander (cdr m))))) + (t (return (cdar m)))))) + (setq x (qexpander (car m)) + y (qexpander (cdr m))) + (and (not (atom x)) + (not (atom y)) + (eq (car x) 'quote) + (eq (car y) 'quote) + (eq (cadr x) (car m)) + (eq (cadr y) (cdr m)) + (return (list 'quote m))) + (return (list 'cons x y)))) + +%(defun left-bracket () + (do ((l (list (read)) (cons (read) l))) + ((eq '/] (car l)) (nreverse (cdr l))))) + +(comment subtitle Macro Expanders) + +;Don't have any screwy FSUBR's around: +%(defun macro-expand (e) ;e should be an expression to evaluate + (cond ((or (atom e) (eq (car e) 'quote)) e) + ((atom (car e)) + (cond ((get (car e) 'macro) + (macro-expand (funcall (get (car e) 'macro) e))) + ((eq (car e) 'function) + (cond ((or (atom (cadr e)) (not (eq (caadr e) 'lambda))) + e) + (t + `(function + (lambda ,(cadadr e) + @(mapcar (function macro-expand) + (cddadr e))))))) + ((eq (car e) 'cond) + `(cond @(mapcar (function + (lambda (clause) + (mapcar (function macro-expand) + clause))) + (cdr e)))) + ((eq (car e) 'do) + (cond ((and (cadr e) (atom (cadr e))) + `(do @(mapcar (function macro-expand) (cdr e)))) + (t + `(do + ,(mapcar (function + (lambda (stepper) + (mapcar (function macro-expand) + stepper))) + (cadr e)) + ,(mapcar (function macro-expand) + (caddr e)) + . ,(mapcar (function macro-expand) (cdddr e)))))) + ((memq (car e) '(prog lambda)) ;lambda is a no-no + `(,(car e) ,(cadr e) @(mapcar (function macro-expand) + (cddr e)))) + ((eq (car e) 'defun) + (cond ((or (memq (cadr e) '(macro fexpr)) + (memq (caddr e) '(macro fexpr))) + `(,(car e) ,(cadr e) ,(caddr e) ,(cadddr e) + @(mapcar (function macro-expand) + (cddddr e)))) + (t + `(,(car e) ,(cadr e) ,(caddr e) + @(mapcar (function macro-expand) + (cdddr e)))))) + (t (cons (car e) (mapcar 'macro-expand (cdr e)))))) + (t + ((lambda (fn) + (cond ((atom fn) (macro-expand (cons fn (cdr e)))) + (t + (cons fn (mapcar (function macro-expand) + (cdr e)))))) + (macro-expand (car e)))))) + +%(defun macro-expand-t (l) ;just top level + (cond ((atom l) l) + ((not (atom (car l))) l) ;this shouldn't hurt (one + ;could macro-expand the car) + ((not (symbolp (car l))) (ce-err l)) + ((get (car l) 'macro) + (macro-expand-t (funcall (get (car l) 'macro) l))) + (t l))) + +%(defun macro-expand-t1 (l) ;useful for debugging + (cond ((atom l) l) + ((not (atom (car l))) l) ;this shouldn't hurt (one + ;could macro-expand the car) + ((not (symbolp (car l))) (ce-err l)) + ((get (car l) 'macro) + (funcall (get (car l) 'macro) l)) + (t l))) + +(comment subtitle DEFUN-SMAC Macro - Sapply Sugar) + +;The key to defun-smac is sapply, which allows generalized lambda-expressions +;like (lambda ((a b nil c) ((d nil e) . f) . g) ). It binds the +;in the obvious pattern-matching way. It only handles cons's (no hunks or +;arrays). Arguments which correspond to NIL slots are ignored. + +(defun defun-smac macro (l) ;smac stands for Sugar-Macro + `(defun ,(cadr l) macro (l) + (displace l (sapply '(lambda @(cddr l)) (cdr l))))) + +%(defun sfuncall nargs + (sapply (arg 1) (listify (- 1 nargs)))) + +%(defun sapply (f args) + (cond ((or (atom f) (not (eq (car f) 'lambda))) (apply f args)) + (t + ((lambda (l) + (apply + `(lambda ,(mapcar (function car) l) @(cddr f)) + (mapcar (function cdr) l))) + (s-list (cadr f) args))))) + +%(defun s-list (bvl args) + (do ((rout nil)) + ((null bvl) (nreverse rout)) + (cond ((atom bvl) (return (nreconc rout (list (cons bvl args))))) + ((null (car bvl)) (setq bvl (cdr bvl) args (cdr args))) + ((atom (car bvl)) + (setq rout (cons (cons (car bvl) (car args)) rout) + bvl (cdr bvl) + args (cdr args))) + (t + (setq rout (nreconc (s-list (car bvl) (car args)) rout) + bvl (cdr bvl) + args (cdr args)))))) + +(comment subtitle Macrodef Routines) + +;(macrodef () ) is a lot like defun, except that a macro is +;created. It will be the right thing in all cases except where the order of +;evaluation of the arguments is critical, or where some arg is not supposed to +;be evaluated (for instance if it is used in functional position in the body). + +;(omacrodef ...) is similar, except that straight substitution is done, which +;makes it more of a syntactic device. + +(defun-smac omacrodef (name bvl . body) + `(defun ,name macro (x) + (displace x (sublis (s-list ',bvl (cdr x)) + ',(addprogn body))))) + +%(defun addprogn (l) (cond ((cdr l) (cons 'progn l)) (t (car l)))) + +(defun-smac alias (name real-name) ;can't (ALIAS ZZARGS) + `(omacrodef ,name zzargs (,real-name . zzargs))) + +(defun-smac macrodef (name bvl . body) + `(defun ,name macro (x) + (displace x + (sublis0 x + ',bvl + ',(macro-expand (cons 'mprogn body)))))) + +;%(defun displace (x y) ;a master function, which clobbers the +; (cond ((or *rset (atom y)) y) ;call by the product of the call +; (t (rplaca x (car y)) +; (rplacd x (cdr y))))) + +%(defun sublis0 (vals vars exp) + (cond ((not (= (length vars) (length (cdr vals)))) (wna-err vals))) + (sublis1 + (mapcar (function (lambda (a b) (cons b (macro-expand a)))) + (cdr vals) vars) + exp)) + +%(defun sublis1 (alist exp) + (do ((a alist (cdr a)) + (blist nil) (clist nil)) + ((null a) (sublis2 clist blist exp)) + (cond ((or (atom (cdar a)) + (eq (cadar a) 'quote) + (< (numtimes (caar a) exp) 2)) + (setq clist (cons (car a) clist))) + (t (setq blist (cons (car a) blist)))))) + +%(defun sublis2 (slist blist exp) + (prog (glist hlist) + (cond ((null blist) (return (sublis slist exp)))) + (setq glist (do ((bl blist (cdr bl)) + (out nil (cons (gensym) out))) + ((null bl) out))) + (setq hlist (mapcar (function (lambda (x y) (cons (car x) y))) + blist glist)) + (return `((lambda ,glist ,(sublis (nconc hlist slist) exp)) + ;all substitutions done in parallel + @(mapcar (function cdr) blist))))) + +%(defun numtimes (var exp) + (declare (fixnum n)) + (do ((e exp (cdr e)) + (n 0 (+ n (numtimes var (car e))))) + ((atom e) (cond ((eq var e) (1+ n)) (t n))))) + +(defun-smac mprogn l + (setq l (mapcar (function macro-expand) l)) + (do nil + ((null (cdr l)) (car l)) + (cond ((memq (car l) '(t nil)) (setq l (cdr l))) + (t (return (cons 'progn l)))))) + +(comment subtitle Random Macros) + +(omacrodef prog1 frobs (prog2 nil . frobs)) + +(macrodef lcopy (l) (subst nil nil l)) ;won't work for hunks, arrays + +(macrodef lcopy1 (l) (append l nil)) + +(omacrodef delet (x y . frobs) (delete x (lcopy1 y) . frobs)) + +(omacrodef lpush (x pdl) (setq pdl (cons x pdl))) + +(omacrodef lpop (pdl) (prog1 (car pdl) (setq pdl (cdr pdl)))) + +(omacrodef exch (a b) (setq a (prog1 b (setq b a)))) + +(omacrodef repeat (index limit . body) + (do index 0 (1+ index) (= index limit) . body)) + +(omacrodef while (pred . body) (do () ((not pred)) . body)) + +(omacrodef logor frobs (boole 7 . frobs)) + +(omacrodef logand frobs (boole 1 . frobs)) + +(omacrodef logxor frobs (boole 6 . frobs)) + +(macrodef evenp (x) (not (oddp x))) + +(omacrodef maplac (f l) ;l is evaluated, but f is not + (do l1 l (cdr l1) (null l1) (rplaca l1 (f (car l1))))) + +(omacrodef maploc (f l) ;l is evaluated, but f is not + (do l1 l (cdr l1) (null l1) (rplaca l1 (f l1)))) + +(macrodef >= (x y) (not (< x y))) + +(macrodef <= (x y) (not (> x y))) + +(macrodef macret (l) + (cond ((and (compiling) macros) + `(progn ,l)) + (t t))) + +(macrodef al-desugar (x) (if (and x (atom x)) (list x) x)) + +;ERR-CATCH and ERR-THROW are alternatives to catch and throw which may be used +;when an error may be likely due to a throw without a matching catch. One must +;(declare (special )) in every file where it is used, and must +;(setq nil) for initialization somewhere. + +;;; Apparently, lisp already checks for throws without matching catches, and +;;; since it doesn't handle err from compiled code correctly, one is better off +;;; with throw and catch than err-throw and err-catch! (As of 8/25/77.) + +(omacrodef err-catch (form tag) (bind ((tag <- t)) (catch form tag))) + +(omacrodef err-throw (val tag . messages) + (cond (tag (throw val tag)) + (t (progn . messages) (err)))) + +(defun-smac fn (bvl . body) + (macro-expand `(function (lambda ,bvl @body)))) + +(defun-smac if (pred f1 . f2) ;f2 is optional + (cond ((null f2) `(cond (,pred ,f1))) + (t `(cond (,pred ,f1) (t @f2))))) + +(macrodef compiling () + (and (boundp 'compiler-state) + compiler-state + (not (eq compiler-state 'toplevel)) + (not (eq compiler-state 'loading)))) + +(defun-smac if-compiling (f1 f2) ;checks compiler-state at EXPAND time + (if (compiling) f1 f2)) + +;There are some small glitches in the following two macros. For instance, in +;fastfunarg, var must be a symbol, etc. Also, the property must be a +;subr-property. (There is one more thing which I forget - ask RZ). + +(defun-smac fastfunarg (var prop) + (if (compiling) + `(setq ,var (get ,var ',prop)) + `(comment (,var ,prop)))) + +(defun-smac fastcall body + (if (compiling) + `(subrcall @body) + `(funcall @(cdr body)))) + +(defun-smac bind (bindings . body) + (nconc (list 'do + (mapcar (fn (q) + (cond ((atom q) (list q)) + ((memq (cadr q) '(|<-| |_|)) + (list (car q) (caddr q))) + (t q))) + bindings) + nil) + (maplist (fn (x) + (cond ((null (cdr x)) + (cons 'return x)) + (t (car x)))) + body))) + +;erlist (see below) was originally a hack to avoid creating new atoms (see +;erlist1). It is unnecessary if vertical bars are used to delimit strings. + +(defun-smac erlist (message) + (cond ((or (atom message) (not (eq (car message) 'quote))) + `(erlist1 ,message)) + (t + (and (not (atom (setq message (cadr message)))) + (setq message (mapcar (fn (y) + `(| | @(explodec y))) + message) + message (maknam (cdr (apply 'nconc message))))) + `(progn (princ ',message) (err))))) + +;May be useful (clobbering o.k.?): +%(defun lsubr-oper-expander (fn l) + (bind ((ans <- l)) + (do ((l ans (caddr l))) + ((null (cddr l)) + (rplacd l (list (car l) (cadr l))) + (rplaca l fn) + ans) + (rplacd l (list (car l) (cdr l))) + (rplaca l fn)))) + +(comment subtitle Case Macro) + +;Case takes forms such as: (case caseitem clause clause ...). The caseitem +;is evaluated, and should produce either a fixnum, flonum, or symbol. It is +;then matched against the clauses, which are of the form: (t frobs), +;(e frobs), ((e1 e2 ...) frobs), or (((low high) ...) frobs). These expand to +;COND clauses, where t has its normal meaning, e[i]'s return t iff any one +;matches the caseitem, for fixnums, low <= caseitem <= high returns true, and +;for flonums, low < caseitem < high returns true. The e[i]'s, low, and high +;are not evaluated. + +;;; BODY is a list of clauses, and there must be a single TYPE: +;;; Clobbering is not done in case we are in *RSET mode: +(defun-smac case (case-item . body) + (setq case-item (macro-expand case-item)) + (bind ((genvar <- (if (atom case-item) case-item (gensym))) type) + (setq body + (maplist (fn (y) + (and (cdr y) (eq (caar y) t) + (error '|Illegal "t" clause in case| + (car y))) + (cond ((or (eq (caar y) t) + (not (atom (caar y)))) + (car y)) + (t + (cons (ncons (caar y)) (cdar y))))) + body)) + (setq type + (typep + (cond ((atom (caar body))) ;only if (caar body) = t + ((atom (caaar body)) (caaar body)) + (t (caaaar body))))) + (or (memq type '(fixnum flonum symbol)) + (error '|Illegal case item type| (car body))) + (mapc (fn (clause) + (and (not (eq (car clause) t)) + (mapc (fn (item) + + (cond ((atom item) + (or (eq (typep item) type) + (error '|Conflicting case item type| (list type item)))) + ((or (eq type 'symbol) + (not (eq (typep (car item)) type)) + (not (eq (typep (cadr item)) type))) + (error '|Conflicting type in case range| (list type item))) + ((or (not (= (length item) 2)) + (not (< (car item) (cadr item)))) + (error '|Inconsistent case range| item)))) + + (car clause)))) + body) + (setq body (mapcar (fn (clause) + + (cons + (if (eq (car clause) t) t + ((lambda (condpred) + (if (null (cdr condpred)) (car condpred) + `(or @condpred))) + (mapcar + (fn (item) + (cond ((atom item) + `(,(if (eq type 'symbol) 'eq '=) + ,genvar ',item)) + ((eq type 'fixnum) + `(and (not (< ,genvar ,(car item))) + (not (> ,genvar ,(cadr item))))) + (t `(and (> ,genvar ,(car item)) + (< ,genvar ,(cadr item)))))) + (car clause)))) + (cdr clause))) + + body)) + (if (atom case-item) `(cond @body) + `((lambda (,genvar) (cond @body)) ,case-item)))) + +(comment subtitle Error Messages) + +%(defun ce-err (l) + (terpri) + (princ '|Cannot expand |) (princ l) + (err)) + +%(defun wna-err (l) + (terpri) + (princ '|Wrong number of args in form |) (princ l) + (err)) + +(declare (unspecial compiler-state scachars scaibase scabase sca*nopoint)) + +(scaunchar) + +(declare (macros nil)) diff --git a/src/sca/mode.192 b/src/sca/mode.192 new file mode 100644 index 00000000..8e6a3aa8 --- /dev/null +++ b/src/sca/mode.192 @@ -0,0 +1,467 @@ +;-*-lisp-*- +;*********************************************************************** +;********************* Modes for Extending Maclisp ********************* +;****** (c) copyright 1977 Massachusetts Institute of Technology ******* +;*********************************************************************** +;********************* Do not modify this file !!! ********************* +;*********************************************************************** + +;***Revise this page. + +;One can construct, modify, and extract parts of objects [STRUCT's?] defined +;using modes. The particular set of functions which perform these actions are +;determined by the "type" of the mode. The currently existing mode types and +;their corresponding functions are: +; +; (1) Primitive - This should be called atomic, but that term is used by +;lisp. This category includes things like booleans, integers, flonums, +;character objects, etc. There are no non-trivial constructors, modifiers, or +;selectors. +; (2) *** + +;Maclisp already knows about some +;modes: Booleans (T and NIL), Fixnums, Flonums, Integers (Fixnums and +;Bignums), Hunks (including Conses), Lists, and Arrays. + +;Files should (declare ((lambda (macros) (eval (read))) nil)) +;(load '((sca) mode fasl)) [rather than (macros fasl)] to use the mode +;package. Users should also (load '((sca) mfcns fasl)) at run-time. + +;This file should be expanded as needed. + +;***FIXED-PROP replaces RWK-PROP? +;***Create an ALIST and a PLIST mode (and a HASHED mode?). + +;;; (declare ((lambda (macros) (load '((sca) modeb fasl))) nil)) +;;; is usable with QNCOMPLR only +(include ((sca) modeb >)) + +(declare (mapex t) + (genprefix scamode) + (macros t)) + +(declare (@define omacrodef |MACRO|) + (@define defmode |MODE|) + (@define defmconstr |MCONSTR|) + (@define defmmacro |MMACRO|) + (@define mdefun |EXPR|)) + +(scachar) + +(comment subtitle SELECT Macro) + +%(defun infix-select () + (do ((l (list (read)) (cons (read) l))) + ((not (= 58. (tyipeek))) ;|:| + (cons 'select (nreverse l))) + (tyi))) + +(defun select macro (l) ;Document this macro. + (do ((ret (cadr l) `(select1 ,ret ,(car selectors))) + (selectors (cddr l) (cdr selectors))) + ((null selectors) ret))) + +(comment subtitle CREATE Mmacro Stuff) + +%(defun nmconstr (m bvl name) + (putprop name '(lambda (l) `\,(car l)\(create @(cdr l))) 'macro)) + +(defmmacro create ret nil (l) + (cond ((cddr l) (wna-err l)) + (t (cadr l)))) + +(defun-smac _create (slot . frobs) + `(_ ,slot (create @frobs))) + +(alias <-create _create) + +(comment subtitle QUOTE Mode) + +(defmode quote (x) + nil + (mconstr nmconstr) + (mmacro create ret (lambda (l m) m)) + (mmacro ? 0 + (lambda (l m) `\boolean\(,(if (symbolp (cadr m)) 'eq 'equal) + ,(caddr l) ,m)))) + +;(comment subtitle LISP Modes - FIXNUM, SYMBOL) + +(defmode fixnum () + nil + (mmacro m+ ret (lambda (l m) `\,m\(+ @(cdr l)))) + (mmacro m- 1 (lambda (l m) `\,m\(- @(cdr l)))) + (mmacro m0? 1 (lambda ((nil var) m) `\boolean\(= ,var 0))) + ;***use ZEROP instead of (= ,var 0)? + (mmacro m* ret (lambda (l m) `\,m\(* @(cdr m)))) + (mmacro mdot ret (lambda (l m) `\,m\(* @(cdr m)))) +;*** write m<, m=, m> for bignum & check special case? + (mmacro create ret (lambda (l m) 0))) +;;; (if (cddr l) (caddr l) 0) ;no good + +;(defmode fixnum () (ident (nil nil 0))) gives FIXNUM a macro property +;[mmexpander] which screws (declare (fixnum ...)). + +(defmode flonum () nil) +(defmode atom () nil) +(defmode file () nil) +(defmode bignum () nil) +(defmode array () nil) +(defmode symbol () nil) ;to make RWK happy + +(comment subtitle *STRUCT Mode) + +;*STRUCT is the internal mode which cons's, hunk's, struct's, etc. turn into. +;*STRUCT modes have creation (name) and selection (select) [and assignment (_)] +;macros. A *STRUCT mode looks like: +;(*STRUCT ...). +;A looks like: ( []). + +(defmode *struct l + nil + (mmacro create ret + (lambda (l m) + (funcall (cadr m) (clean-list (cdr l) (cdddr m))))) + (mmacro sel 1 *struct-sel) + (mmacro select1 1 *struct-select1)) + +;L is an even-length list alternating between token names and values, and M +;is a list of specs, where a spec looks like ( ), +;except that and may be missing. Clean-list returns a list +;of forms, corresponding to the specs of M, where these forms are either gotten +;from L, the in the corresponding spec, or the creation macro for the +; in the spec: +%(defun clean-list (l m) + (mapcar (fn (l1) + (bind ((x <- (and (car l1) + (getl (cons nil l) (list (car l1)))))) + (cond (x `\,(cadr l1)\,(cadr x)) + ((cddr l1) `\,(cadr l1)\,(caddr l1)) + ((cadr l1) `\,(cadr l1)\(create @l)) + (t (ndf-err (car l1) m))))) + m)) + +%(defun *struct-sel (l m msf) + (declare (fixnum n nt)) + (bind ((out <- nil) (n <- 0) (nt <- (length (cdddr m))) + (selfun <- (caddr m)) (arg <- (cadr l)) (token <- (caddr l))) + (mapc (fn (clause) + + (_ n (1+ n)) + (cond ((eq token (car clause)) + (if out (ams-err token m) + (_ out `\,(cadr clause)\,(funcall selfun n nt arg)))) + ((null (car clause)) + (bind ((nout <- (mmlm2 (get 'sel 'mmacro) + `(sel ,(funcall selfun n nt arg) ,token) + (al-desugar (cadr clause)) + (cons m msf)))) + (and nout + (if out (ams-err token m) + (_ out nout))))))) + + (cdddr m)) + out)) + +%(defun *struct-select1 (l m msf) + (declare (fixnum n nt)) + (or (*struct-sel l m msf) + (bind ((out <- nil) nout (n <- 0) (nt <- (length (cdddr m))) + (selfun <- (caddr m)) (arg <- (cadr l)) (token <- (caddr l))) + (mapc (fn (clause) + + (_ n (1+ n) + nout (mmlm2 (get 'select1 'mmacro) + `(select1 ,(funcall selfun n nt arg) ,token) + (al-desugar (cadr clause)) + (cons m msf))) + (and nout + (if out (ams-err token m) + (_ out nout)))) + + (cdddr m)) + out))) + +(comment subtitle Specific STRUCT Modes) + +%(defun scmcmac (m) + (mapcar (fn (clause) + (cond ((null clause) nil) + ((atom clause) (list clause nil)) + ((eq (car clause) 'quote) (list nil clause clause)) + (t clause))) + m)) + +;;;(declare (fixnum n n1 nt)) - not needed since not compiled + +(defmode ident l ;a funny struct for when you later plan + ;to make a real struct out of it (yes, + ;it is rather obscure) + (eval `(*struct (lambda (l) (car l)) + (lambda (n nt arg) arg) + @(scmcmac l))) + (mconstr nmconstr)) + +(defmode ncons l ;unnecessary - could use hunk + (eval `(*struct (lambda (l) `(ncons @l)) + (lambda (n nt arg) `(car ,arg)) + @(scmcmac l))) + (mconstr nmconstr)) + +(defmode cons l ;unnecessary - could use hunk + (eval `(*struct (lambda (l) `(cons @l)) + (lambda (n nt arg) + (cond ((= n 1) `(car ,arg)) + ((= n 2) `(cdr ,arg)))) + @(scmcmac l))) + (mconstr nmconstr)) + +(defmode hunk l ;note lousy hunk numbering system everywhere + (eval `(*struct (lambda (l) `(hunk @l)) + (lambda (n nt arg) + (cond ((= nt 1) `(cxr 1 ,arg)) ;ncons case + ((= n nt) `(cxr 0 ,arg)) ;cdr case + (t `(cxr ,n ,arg)))) + @(scmcmac l))) + (mconstr nmconstr)) + +(defmode struct-list l + (eval `(*struct (lambda (l) `(list @l)) + (lambda (n nt arg) + (repeat n1 (1- n) (_ arg `(cdr ,arg))) + `(car ,arg)) + @(scmcmac l))) + (mconstr nmconstr)) + +(defmode struct-array l ;doesn't know about number or + (eval `(*struct ;un-garbage-collected arrays + (lambda (l) + (bind ((var <- (gensym)) (nt <- (length l))) + `(progn (_ ,var (array nil t ,nt)) + @(do ((l1 l (cdr l1)) + (n 1 (1+ n)) + (retl)) + ((null l1) (nreverse retl)) + (lpush `(store + (arraycall t ,var ,(1- n)) + ,(car l1)) + retl)) + ,var))) + (lambda (n nt arg) `(arraycall t ,arg ,(1- n))) + @(scmcmac l))) + (mconstr nmconstr)) + +;;;(declare (notype n n1 nt)) - see above + +(defmode struct l +;;; (declare (fixnum len)) - not needed since not compiled + (eval + (bind ((len <- (length l))) + (cond ((> len 128.) `(struct-array @l)) + ((= len 0) ''nil) + + ((= len 1) `(ncons @l)) ;Because the compiler + ((= len 2) `(cons @l)) ;is stupid. + + ((memq len '(3 4 6 7 8 13 14 15 16)) `(hunk @l)) + (t `(hunk @l)))))) ;Because I'm lazy. + +;It's not clear what struct should expand into. If you're time conscious, +;use hunks. The best theoretical answer for large LEN may be arrays, but +;there are problems with the current compactifying garbage collector. +;[If you're worried about space, then +;(memq len '(5 9 10 11 17 18 19)) => use two hunks, and +;(= len 12) => use three hunks.] + +;(comment subtitle TAG, DISJ, UNION, and INTERSECT Modes) + +(defmode tag l + (*struct nil + (lambda (n nt arg) (if (= n 1) `(car ,arg) `(cdr ,arg))) + (mtag) . l) + (mconstr nmconstr) + (mmacro create ret + (lambda ((nil tag value) m) + (and (assq tag (cdr m)) + `(cons ',tag ,value)))) + (mmacro mcase 1 ;***won't work for T clauses & should declare + (lambda (l m) `(case (car ,(cadr l)) @(cddr l))))) ;mode of item + ;in each clause? + +(defmode disj l + (*struct nil (lambda (n nt arg) arg) . l) + (mconstr nmconstr) + (mmacro create ret + (lambda (l m) + (and (assq (cadr l) (cdr m)) + `\,(cadr (assq (cadr l) (cdr m)))\,(caddr l)))) + (mmacro mcase 1 + (lambda ((nil item . frobs) m) + (_ item `\,(mode item)\,(macro-expand item)) + (bind ((var <- (if (atom (caddr item)) item (gensym)))) + (_ frobs + `(cond @(mapcar (fn (clause) + `(,(bind ((temp <- (caddr clause))) + (or (null temp) + `(,temp ,var))) + @(cdr (assq (car clause) frobs)))) + (cdr m)))) + (if (atom (caddr item)) frobs + `(bind ((,var <- ,item)) ,frobs)))))) + +(defmode union l + (*struct nil (lambda (n nt arg) arg) . l) + (mconstr nmconstr) + (mmacro create ret + (lambda (l m) + (and (assq (cadr l) (cdr m)) + (or (caddr l) ''nil))))) + +(defmode intersect l ;Same effects as union + (*struct nil (lambda (n nt arg) arg) . l) + (mconstr nmconstr) + (mmacro create ret + (lambda (l m) + (and (assq (cadr l) (cdr m)) + (or (caddr l) ''nil))))) + +(comment subtitle BOOLEAN Mode) + +(defmode boolean () + (disj (true 't boolean$true?) (false 'nil)) + (macrodef true? (x) x)) + +(comment subtitle HOMOGENEOUS Modes) + +;***Unfinished: One could create more homogeneous modes, and one could add new +;mmacros to LIST (BACKWARDS, ADD-TO-SET, etc.). + +(comment subtitle LIST Mode) + +(defmode list (elts-mode) + nil + + (mmacro empty ret (lambda (l m) ''nil)) + (mmacro create ret (lambda (l m) `(list @(cdr l)))) + (mmacro ttf -1 + (lambda (l m) + (cond ((null (cddr l)) `\,m\,(cadr l)) + (t `\,m\(cons ,(cadr l) (ttf @(cddr l))))))) + + (mmacro empty? 1 (lambda (l m) `\boolean\(null ,(cadr l)))) + (mmacro size 1 (lambda (l m) `\fixnum\(length ,(cadr l)))) + + (mmacro first 1 (lambda (l m) `\,(cadr m)\(car ,(cadr l)))) + (mmacro select1 1 ;uses 1-based indexing + (lambda (l m msf) + (cond ((numberp (caddr l)) + (bind ((out <- (cadr l)) (n <- (caddr l))) + (repeat i (1- n) (_ out `(cdr ,out))) + `\,(cadr m)\(car ,out))) + ((eq (caddr l) 'first) `\,(cadr m)\(car ,(cadr l))) + ((eq (caddr l) 'rest) `\,m\(cdr ,(cadr l))) + (t + (mmlm2 (get 'select1 'mmacro) + `(select1 \,(cadr m)\(car ,(cadr l)) + ,(caddr l)) + (al-desugar (cadr m)) + (cons m msf)))))) + (mmacro rest 1 (lambda (l m) `\,m\(cdr ,(cadr l)))) + + ;values returned by _first & _rest are meaningless: + (mmacro _first 1 (lambda (l m) `(rplaca ,(cadr l) ,(caddr l)))) + (mmacro _rest 1 (lambda (l m) `(rplacd ,(cadr l) ,(caddr l)))) + ;_first & _rest are unnecessary: use + ;(_ (first ...) ...) & (_ (rest ...) ...). + + (mconstr nmconstr)) + +(defun push macro (l) ;value returned is meaningless + `(_ ,(car (last l)) (ttf @(cdr l)))) + +(defmmacro pop 1 (list) ((nil arg) m) + `\,(cadr m)\(prog1 (first ,arg) (_ ,arg (rest ,arg)))) + +(comment subtitle MULT-LIST Mode) + +(defmode mult-list l + (eval + `(disj (empty 'nil null) + (non-empty + ,(do ((l (reverse l) (cdr l)) + (rout `(rest (mult-list @l) nil) + `(nil (cons ,(car l) ,rout)))) + ;uses old [?] NIL default-token-select convention + ((null l) (cadr rout)))))) + + (mmacro empty ret (lambda (l m) ''nil)) + (mmacro create ret + (lambda (l m) + `\,(simp-mode m)\(create ,(if (cdr l) 'non-empty 'empty) + (create @(cdr l))))) + ;simply using ,l for the last line will give bugs because of + ;clobbering + +;For LIST-type CREATE and TTF use (create ... REST (create ...)) + + (mmacro empty? 1 (lambda (l m) `\boolean\(null ,(cadr l)))) + (mmacro size 1 + (lambda (l m) `\fixnum\(// (length ,(cadr l)) ,(length (cdr m))))) + +;FIRST is meaningless + + (mmacro select1 1 ;uses 1-based indexing + (lambda (l m msf) + (cond ((numberp (caddr l)) + (bind ((out <- (cadr l)) (n <- (caddr l))) + (repeat i (1- n) (_ out `(rest ,out))) + `\,m\,out)) + (t + (mmlm2 (get 'select1 'mmacro) + `(select1 \,(simp-mode m)\,(cadr l) ,(caddr l)) + (simp-mode m) + (cons m msf)))))) + (mmacro rest 1 (lambda (l m) `\,m\:,(cadr l):rest)) + + ;value returned by _rest is meaningless: + (mmacro _rest 1 (lambda (l m) `(_ :,(cadr l):rest ,(caddr l)))) + ;_rest is unnecessary: use (_ (rest ...) ...). + + (mconstr nmconstr)) ;actually unnecessary because of DISJ + +(comment subtitle FIXED-PROP Mode) + +(defmode fixed-prop (name val-mode . val-default) ;default is optional + (*struct (lambda (l) `(putprop @l)) + (lambda (n nt arg) (case n + (1 arg) + (2 `(get ,arg 'name)) + (3 ''name))) + (symbol nil) + (prop-val val-mode . val-default) + (nil 'name)) + (mconstr nmconstr)) + +(comment subtitle Error Messages) + +%(defun ndf-err (token mode) + (terpri) + (princ '|No default given for token |) (princ token) + (terpri) (princ '| in structure |) (princ mode) + (err)) + +%(defun csm-err (selector mode) ;unused + (terpri) + (princ '|Cannot select |) (princ selector) + (princ '| from mode |) (princ mode) + (err)) + +%(defun ams-err (selector mode) + (terpri) + (princ selector) (princ '| is an ambiguous selection from mode |) + (terpri) (princ mode) + (err)) + +(scaunchar) + +(declare (macros nil)) diff --git a/src/sca/modeb.187 b/src/sca/modeb.187 new file mode 100644 index 00000000..2a4dfa53 --- /dev/null +++ b/src/sca/modeb.187 @@ -0,0 +1,444 @@ +;-*-lisp-*- +;*********************************************************************** +;************* Base for Mode Macros for Extending Maclisp ************** +;****** (c) copyright 1977 Massachusetts Institute of Technology ******* +;*********************************************************************** +;********************* Do not modify this file !!! ********************* +;*********************************************************************** + +(comment subtitle Introduction) + +;***Revise this page. + +;This is a "stupid" mode package in that all complicated issues, such as +;manifestation, choice of alternative but isomorphic representations, etc., +;are left to the user. This is because these issues involve heuristic +;decisions that will affect space and time efficiencies. Also, one cannot +;define or use modes at run-time, unless this package is loaded first. There +;are, however, two good reasons for using (stupid) modes: (1) They allow the +;use of mnemonic names, which makes code easier to write and read, and (2) They +;make code somewhat extensible, as well as changeable (representation +;independent). + +;One can define new +;modes out of old ones using DEFMODE. Some "modes", such as STRUCT, are +;actually mode "functions". One can define new modes, or new mode functions. +;***unfinished + +;MODES can be used for anything where (at least one of) these two goals apply, +;in particular whenever there exist several alternate implementations of a +;particular idea. [No - modes raise LEVEL of thinking - ??] + +;A mode is a mapping from a set of lisp objects to a set of abstract +;constructive objects. (Bijective/injective/surjective/well-defined?) + +;It is dangerous to do type checking because of clashes which are only +;apparent. + +;Note that MODE, MCONSTR, and MMACRO properties are put on various symbols. + +;MODE's: nil, , or ( @) +;MOBJECT's: on alist's MSYMBOLS, MFUNCTIONS +;MCONSTR's: symbols with MCONSTR properties +;MMACRO's: symbols with MMACRO properties: key, domain, macro3 +;mconstr: (lambda (m bvl name)) +;mmacro: (lambda (l m msf)) + +;Defmodes, mmacros, and mconstrs may not be destroyed or made local. + +;No mode can be named nil. + +; is considered a shorthand for (), a shorthand for +;( nil nil ... nil). + +;MODE's returned by mode and simp-mode, generated by search-modes, found in +;mode properties, or passed as arguments to MCONSTR's & MMACRO's are +;al-desugar'ed. + +;***Eliminate MCONSTR's? +;***Add tree-called functions (modes with sub-modes & run-time disambiguation)? +;***Rewrite BIND, etc., [all of sca;macros?] to do type-checking? +;***Allow (mdeclare (poly (pplus poly poly))) ? +;***Allow a run-time debug-mode with run-time type checking? + +;;; (declare (load '((sca) macros fasl))) - usable with QNCOMPLR only +(include ((sca) macros >)) + +(declare (mapex t) + (genprefix scamodeb) + (macros t) + (special compiler-state macros) + (*lexpr sfuncall)) + +(declare (@define omacrodef |MACRO|) + (@define defmode |MODE|) + (@define defmconstr |MCONSTR|) + (@define defmmacro |MMACRO|) + (@define mdefun |EXPR|)) + +(scachar) + +(comment subtitle Mode Tracking Routines) + +(declare (special msymbols mfunctions *msymbols *mfunctions)) + +%(setq msymbols nil mfunctions nil) + +(defun mprogn macro (l) ;redefined [also in sca;macros >] + ((lambda (msymbols mfunctions) + (setq l (mapcar (function macro-expand) (cdr l)))) + msymbols mfunctions) + (do nil + ((null (cdr l)) (car l)) + (cond ((memq (car l) '(t nil)) (setq l (cdr l))) + (t (return (cons 'progn l)))))) + +(defun mdeclare macro (l) + (mapc (fn (l1) + (mapc (fn (v) + (cond ((atom v) + (lpush (cons v (car l1)) msymbols)) + (t + (lpush (cons (car v) (car l1)) mfunctions)))) + (cdr l1))) + (cdr l)) + t) + +(defun mundeclare macro (l) + (mapc (fn (l1) + (mapc (fn (v) + (cond ((atom v) + (setq msymbols + (delet (cons v (car l1)) + msymbols + 1))) + (t + (setq mfunctions + (delet (cons (car v) (car l1)) + mfunctions + 1))))) + (cdr l1))) + (cdr l)) + t) + +(defun mdefun macro (l) ;Makes MDECLARE's local + (cond ((compiling) + `(progn 'COMPILE + (declare (setq *msymbols msymbols + *mfunctions mfunctions)) + (defun . ,(cdr l)) + (declare (setq msymbols *msymbols + mfunctions *mfunctions)))) + (t + (cond ((or (memq (cadr l) '(fexpr macro)) + (memq (caddr l) '(fexpr macro))) + `(defun ,(cadr l) ,(caddr l) ,(cadddr l) + ((lambda (msymbols mfunctions) + @(cddddr l)) + ',msymbols ',mfunctions))) + (t `(defun ,(cadr l) ,(caddr l) + ((lambda (msymbols mfunctions) + @(cdddr l)) + ',msymbols ',mfunctions))))))) + +%(defun must-mode (l) + (or (mode l) (ndm-err l))) + +%(defun mode (l) ;returned value is al-desugar'ed + (al-desugar (cond ((symbolp l) (cdr (assq l msymbols))) + ((numberp l) (typep l)) ;FIXNUM, FLONUM, or BIGNUM + ((atom l) nil) + ((not (symbolp (car l))) nil) + ((eq (car l) 'mode-note) (cadr l)) + ((cdr (assq (car l) mfunctions))) + ((get (car l) 'macro) (mode (macro-expand-t1 l)))))) + +(declare (unspecial msymbols *msymbols mfunctions *mfuncions)) + +;\\ becomes (MODE-NOTE ). + +%(defun make-mode-note () + (cond ((= (tyipeek) 32.) '/\) ;| | + ((= (tyipeek) 92.) (tyi) '/\/\) ;|\| + (t `(mode-note ,(read) ,(progn (tyi) (read)))))) + +(defun-smac mode-note (mode form) +;*** [compatibility stuff] + (search-modes m mode + (if (and (not (atom form)) + (symbolp (car form)) + (eq (car (get (car form) 'mmacro)) 'return)) + `\,mode\,(mmlm (get (car form) 'mmacro) + form mode) + form) + (and (eq (car m) 'quote) (return m)))) + +(comment subtitle Mode Handlers) + +(omacrodef search-modes (var init defaultret . body) ;ZZMODELIST cannot + (do ((var (al-desugar init) (simp-mode var)) ;appear in call + (zzmodelist nil (cons var zzmodelist))) + ((member var zzmodelist) defaultret) + . body)) ;var will be al-desugar'ed + +(omacrodef search-modes1 (var init defaultret other . body) + (do ((var (al-desugar init) (simp-mode var)) + (zzmodelist nil (cons var zzmodelist)) ;ZZMODELIST cannot + . other) ;appear in call + ((member var zzmodelist) defaultret) + . body)) ;var will be al-desugar'ed + +%(defun simp-mode (m) ;returned value is al-desugar'ed + (cond ((null m) nil) + (t + (setq m (al-desugar m)) + (bind ((temp <- (get (car m) 'mode))) + (if (null temp) (nm-err m) + (simp-mode1 (cdr m) (car temp) (cdr temp))))))) + +%(defun simp-mode1 (args bvl mode) + (al-desugar (if (eq (car mode) 'eval) + (sapply `(lambda ,bvl @(cdr mode)) args) + (sublis (s-list bvl args) mode)))) + +(comment subtitle Mmacro Handlers) + +%(defun make-mmacro (name domain macro3 key) + (if (eq key 'ret) (setq key 'return)) + (bind ((mm <- (get name 'mmacro))) + (and mm (not (equal key (car mm))) (mmt-err name (car mm) key)) + (if (atom domain) (setq domain (list domain))) + (bind ((temp <- (assoc domain (cdr mm)))) + (cond (temp ;for reloading [saves space] + (rplacd temp macro3)) + (mm + (rplacd mm (cons (cons domain macro3) (cdr mm)))) + (t + (putprop name + (cons key (ncons (cons domain macro3))) + 'mmacro) + (putprop name (function mmexpander) 'macro)))))) + +%(defun mmexpander (l) + (bind ((mm <- (get (car l) 'mmacro)) m key) + (setq key (car mm)) + (setq m (cond ((not (fixp key)) (ce-err l)) + ((= key 0) (cadr l)) + (t + (if (< key 0) (setq key (+ (length l) key))) + (mode (l0nth l key))))) + (mmlm mm l m))) + +%(defun mmlm (mm l m) (or (mmlm1 mm l m) (ce-err l))) + +%(defun mmlm1 (mm l m) (mmlm2 mm l (al-desugar m) nil)) + +%(defun mmlm2 (mm l m msf) + (cond ((or (null m) (member m msf)) nil) + ((bind ((temp <- (cdr (lssq (car m) (cdr mm))))) + (and temp + (setq temp (sfuncall temp l m msf)) + (displace l temp)))) + ((mmlm2 mm l (simp-mode m) (cons m msf))) + ((memq (car m) '(intersect union disj)) + (bind ((ans <- nil) nans) + (mapc (fn (clause) + (setq nans + (mmlm2 mm l (al-desugar (cadr clause)) + msf)) + (and nans + (if ans (ce-err l) + (setq ans nans)))) + (cdr m)) + ans)))) + +%(defun l0nth (l n) + (declare (fixnum n)) + (do ((l l (cdr l)) + (n n (1- n))) + ((= n 0) (car l)))) + +%(defun lssq (sym l) + (do ((l l (cdr l))) + ((null l) nil) + (if (memq sym (caar l)) (return (car l))))) + +;(comment subtitle MODE, MCONSTR, and MMACRO Definers) + +(defun defmode macro (l) + (bind ((name <- (cadr l)) + (bvl <- (caddr l)) + (mode <- (cadddr l)) + (frobs <- (cddddr l)) + name$) + (putprop name + (cond ((null mode) (ncons nil)) ;just for fun + ((atom mode) (cons bvl (ncons mode))) + (t (cons bvl mode))) + 'mode) + (search-modes mode ;Should one search branches of + (simp-mode name) ;UNION's, etc., also? + nil + (and (get (car mode) 'mconstr) + (sfuncall (get (car mode) 'mconstr) + mode bvl name))) + (setq name$ (nconc (explodec name) (list '$))) + `(progn 'compile ,(macret `(defmode ,name ,bvl ,mode)) + @(mapcar (fn (clause) (dm-clause clause name name$)) + frobs)))) + +(defun defmconstr macro (l) + (putprop (cadr l) `(lambda . ,(cddr l)) 'mconstr) + (macret l)) + +(defun defmmacro macro (l) ;(defmmacro @) + (make-mmacro (cadr l) (cadddr l) (cons 'lambda (cddddr l)) (caddr l)) + (macret l)) + +(macrodef dm-nm (clause) (implode (append name$ (explodec (cadr clause))))) +(macrodef dm$nm (nm) (implode (append name$ (explodec nm)))) + +%(defun dm-clause (clause name name$) + (case (car clause) + ((macro expr fexpr lexpr) + `(defun ,(dm-nm clause) ,(car clause) . ,(cddr clause))) + (smac + `(defun-smac ,(dm-nm clause) @(cddr clause))) + ((defun mdefun adefun) + `(,(car clause) ,(dm-nm clause) @(cddr clause))) + (function + `(defun ,(dm-nm clause) @(cddr clause))) + ((cfunction compiler-function) + (eval `(defun ,(dm-nm clause) . ,(cddr clause))) + t) + ((bfunction both-function) + (eval `(defun ,(dm-nm clause) . ,(cddr clause))) + (if (compiling) `(defun ,(dm-nm clause) . ,(cddr clause)) t)) + ((macrodef omacrodef alias) + `(,(car clause) ,(dm-nm clause) . ,(cddr clause))) + (inherit + `(progn 'compile + @(mapcar (fn (nm) + `(defun ,(dm$nm nm) macro (l) + (mmlm (get ',nm 'mmacro) + (cond ((= (car (get ',nm 'mmacro)) 0) + (cons ',nm (cons ',name (cdr l)))) + (t (cons ',nm (cdr l)))) + ',name))) + (cdr clause)))) + (mconstr + (putprop name (cadr clause) 'mconstr) + (macret `(defprop ,name ,(cadr clause) mconstr))) + (mmacro ;(mmacro ) + (make-mmacro (cadr clause) name (cadddr clause) (caddr clause)) + (macret + `(make-mmacro ',(cadr clause) ',name + ',(cadddr clause) ',(caddr clause)))) + ((prop property) + (putprop name (caddr clause) (cadr clause)) + (macret `(defprop ,name ,(caddr clause) ,(cadr clause)))) + (other t) + (t (udm-err clause name)))) + +(comment subtitle Assignment Macro) ;Doesn't work for named arrays, or + ;anything not explicit (grab-able). +(defun _ macro (l) ;Also, value returned is random, and + (do ((l1 (cdr l) (cddr l1)) ;it doesn't like eval, member, or memq. + (cell) (mode) (value) (nl)) + ((null l1) (cons 'progn (nreverse nl))) + (setq mode (mode (car l1))) + (setq cell (macro-expand-t (car l1))) + (setq value `\,mode\,(cadr l1)) + (setq nl (cons + (cond ((symbolp cell) `(setq ,cell ,value)) + ((atom cell) (cat-err cell)) + ((eval (cadr (bssq (car cell) + + '((car `(rplaca ,(cadr cell) ,value)) + (cdr `(rplacd ,(cadr cell) ,value)) + (cxr `(rplacx ,(cadr cell) ,(caddr cell) ,value)) + (arraycall `(store ,cell ,value)) + (get `(putprop ,(cadr cell) ,value ,(caddr cell))) + (symeval `(set ,(cadr cell) ,value)) + (plist `(setplist ,(cadr cell) ,value)) + (args `(args ,(cadr cell) ,value)) + +;Still need: +;getchar, getcharn, substr, pnget, get_pname, status, last, and getl. + +;Status I don't understand (what are all the screwy cases?). + +;Last and getl are special: one usually does (car (last foo)), +;(cdr (last foo)), or (cadr (getl foo boo)). + + (caar `(rplaca (car ,(cadr cell)) ,value)) + (cadr `(rplaca (cdr ,(cadr cell)) ,value)) + (cdar `(rplacd (car ,(cadr cell)) ,value)) + (cddr `(rplacd (cdr ,(cadr cell)) ,value)) + (caaar `(rplaca (caar ,(cadr cell)) ,value)) + (caadr `(rplaca (cadr ,(cadr cell)) ,value)) + (cadar `(rplaca (cdar ,(cadr cell)) ,value)) + (caddr `(rplaca (cddr ,(cadr cell)) ,value)) + (cdaar `(rplacd (caar ,(cadr cell)) ,value)) + (cdadr `(rplacd (cadr ,(cadr cell)) ,value)) + (cddar `(rplacd (cdar ,(cadr cell)) ,value)) + (cdddr `(rplacd (cddr ,(cadr cell)) ,value)) + (caaaar `(rplaca (caaar ,(cadr cell)) ,value)) + (caaadr `(rplaca (caadr ,(cadr cell)) ,value)) + (caadar `(rplaca (cadar ,(cadr cell)) ,value)) + (caaddr `(rplaca (caddr ,(cadr cell)) ,value)) + (cadaar `(rplaca (cdaar ,(cadr cell)) ,value)) + (cadadr `(rplaca (cdadr ,(cadr cell)) ,value)) + (caddar `(rplaca (cddar ,(cadr cell)) ,value)) + (cadddr `(rplaca (cdddr ,(cadr cell)) ,value)) + (cdaaar `(rplacd (caaar ,(cadr cell)) ,value)) + (cdaadr `(rplacd (caadr ,(cadr cell)) ,value)) + (cdadar `(rplacd (cadar ,(cadr cell)) ,value)) + (cdaddr `(rplacd (caddr ,(cadr cell)) ,value)) + (cddaar `(rplacd (cdaar ,(cadr cell)) ,value)) + (cddadr `(rplacd (cdadr ,(cadr cell)) ,value)) + (cdddar `(rplacd (cddar ,(cadr cell)) ,value)) + (cddddr `(rplacd (cdddr ,(cadr cell)) ,value))))))) + + (t (cat-err cell))) + nl)))) + +(alias <- _) + +(omacrodef swap (a b) (_ a (prog1 b (_ b a)))) + ;inefficient if a and b take several steps to obtain correct slot + +(comment subtitle Error Messages) + +%(defun ndm-err (l) + (terpri) + (princ '|Cannot determine the mode of |) (princ l) + (err)) + +%(defun nm-err (m) + (terpri) + (princ (car m)) (princ '| not a mode in mode |) (princ m) + (err)) + +%(defun mmt-err (name k1 k2) + (terpri) + (princ '|Conflicting TYPEs for mmacro |) (princ name) + (princ '| - |) (princ k1) (princ '| & |) (princ k2) + (err)) + +%(defun udm-err (clause name) + (terpri) + (princ '|Unrecognizable clause |) (princ clause) + (princ '| in DEFMODE for |) (princ name) + (err)) + +%(defun cat-err (l) + (terpri) + (princ '|Cannot assign to |) (princ l) + (err)) + +(declare (unspecial compiler-state macros)) + +(scaunchar) + +(declare (macros nil))