Build yahtze fasl from source.

Resolves #890.

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) <body>).  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 <name> (<args>) <body>) 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 <name> 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 <tag>)) in every file where it is used, and must
+;(setq <tag> 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))

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 <creation macro> <selection macro> <clause> <clause> ...).
+;A <clause> looks like:  (<token> <mode> [<default>]).
+
+(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 (<token name> <mode> <default>),
+;except that <mode> and <default> 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 <default> in the corresponding spec, or the creation macro for the
+;<mode> 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 <token> <val> ... 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))

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, <modename>, or (<modename> @<list of args>)
+;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.
+
+;<modename> is considered a shorthand for (<modename>), a shorthand for
+;(<modename> 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))
+
+;\<mode>\<frob> becomes (MODE-NOTE <mode> <frob>).
+
+%(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 <name> <key> <domain> <bvl> @<body>)
+       (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 <name> <key> <macro3>)
+	       (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))