mirror of
https://github.com/PDP-10/its.git
synced 2026-02-16 21:01:16 +00:00
445 lines
14 KiB
Common Lisp
445 lines
14 KiB
Common Lisp
;-*-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))
|