mirror of
https://github.com/PDP-10/its.git
synced 2026-03-23 09:19:24 +00:00
556 lines
18 KiB
Common Lisp
556 lines
18 KiB
Common Lisp
;-*-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))
|