Build yahtze fasl from source.

Resolves #890.

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))