![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to macros.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to macros.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 ! root 1: (setq rcs-macros- ! 2: "$Header: macros.l,v 1.6 83/11/09 07:09:42 jkf Exp $") ! 3: ! 4: ;; macros.l -[Wed Nov 9 07:09:26 1983 by jkf]- ! 5: ;; ! 6: ;; The file contains the common macros for Franz lisp. ! 7: ;; contents: ! 8: ;; defmacro ! 9: ;; setf ! 10: ;; defsetf ! 11: ;; push ! 12: ;; pop ! 13: ;; let ! 14: ;; let* ! 15: ;; caseq ! 16: ;; listify ! 17: ;; include-if ! 18: ;; includef-if ! 19: ;; defvar ! 20: ! 21: ! 22: (declare (macros t)) ! 23: ! 24: ;; defmacro ! 25: (declare (special defmacrooptlist protect-list protect-evform)) ! 26: ! 27: ;--- defmacro - name - name of macro being defined ! 28: ; - pattrn - formal arguments plus other fun stuff ! 29: ; - body - body of the macro ! 30: ; This is an intellegent macro creator. The pattern may contain ! 31: ; symbols which are formal paramters, lists which show how the ! 32: ; actual paramters will appear in the args, and these key words ! 33: ; &rest name - the rest of the args (or nil if there are no other args) ! 34: ; is bound to name ! 35: ; &optional name - bind the next arg to name if it exists, otherwise ! 36: ; bind it to nil ! 37: ; &optional (name init) - bind the next arg to name if it exists, otherwise ! 38: ; bind it to init evaluted. (the evaluation is done left ! 39: ; to right for optional forms) ! 40: ; &optional (name init given) - bind the next arg to name and given to t ! 41: ; if the arg exists, else bind name to the value of ! 42: ; init and given to nil. ! 43: ; &aux name ! 44: ; &aux (name init) ! 45: ; ! 46: ; Method of operation: ! 47: ; the list returned from defmcrosrc has the form ((cxxr name) ...) ! 48: ; where cxxr is the loc of the macro arg and name is it formal name ! 49: ; defmcrooptlist has the form ((initv cxxr name) ...) ! 50: ; which is use for &optional args with an initial value. ! 51: ; here cxxr looks like cdd..dr which will test of the arg exists. ! 52: ; ! 53: ; the variable defmacro-for-compiling determines if the defmacro forms ! 54: ; will be compiled. If it is t, then we return (progn 'compile (def xx..)) ! 55: ; to insure that it is compiled ! 56: ; ! 57: (declare (special defmacro-for-compiling)) ! 58: (cond ((null (boundp 'defmacro-for-compiling)) ; insure it has a value ! 59: (setq defmacro-for-compiling nil))) ! 60: ! 61: (def defmacro ! 62: (macro (args) ! 63: ((lambda ! 64: (tmp tmp2 defmacrooptlist body protect-evform protect-list gutz) ! 65: (setq tmp (defmcrosrch (caddr args) '(d r) nil) ! 66: body ! 67: `(def ,(cadr args) ! 68: (macro (defmacroarg) ! 69: ((lambda ,(mapcar 'cdr tmp) ! 70: ,@(mapcar ! 71: '(lambda (arg) ! 72: `(cond ((setq ,(caddr arg) ! 73: (,(cadr arg) ! 74: defmacroarg)) ! 75: ,@(cond ((setq tmp2 (cadddr arg)) ! 76: `((setq ,tmp2 t)))) ! 77: (setq ,(caddr arg) ! 78: (car ,(caddr arg)))) ! 79: (t (setq ,(caddr arg) ! 80: ,(car arg))))) ! 81: defmacrooptlist) ! 82: ,@(cond (protect-evform ! 83: (setq gutz ! 84: (eval `((lambda ,(mapcar 'cdr tmp) ! 85: ,@(cdddr args)) ! 86: ,@(mapcar ! 87: '(lambda (x) `',(cdr x)) ! 88: tmp)))) ! 89: (ncons ! 90: `(cond (,protect-evform ! 91: (copy ! 92: `((lambda ,',(mapcar 'cdr tmp) ! 93: ,',gutz) ! 94: ,,@(mapcar 'cdr tmp)))) ! 95: (t ,@(cdddr args))))) ! 96: (t (cdddr args)))) ! 97: ,@(mapcar '(lambda (arg) ! 98: (cond ((dtpr (car arg)) ! 99: (caar arg)) ! 100: ((car arg) ! 101: `(,(car arg) defmacroarg)))) ! 102: tmp))))) ! 103: (cond (defmacro-for-compiling `(progn 'compile ,body)) ! 104: (t body))) ! 105: ! 106: nil nil nil nil nil nil nil))) ! 107: ! 108: (def defmcrosrch ! 109: (lambda (pat form sofar) ! 110: (cond ((null pat) sofar) ! 111: ((atom pat) (cons (cons (concatl `(c ,@form)) pat) ! 112: sofar)) ! 113: ((memq (car pat) '(&rest &body)) ! 114: (append (defmcrosrch (cadr pat) form nil) ! 115: (defmcrosrch (cddr pat) form sofar))) ! 116: ((eq (car pat) '&optional) ! 117: (defmcrooption (cdr pat) form sofar)) ! 118: ((eq (car pat) '&protect) ! 119: (setq protect-list (cond ((atom (cadr pat)) ! 120: (ncons (cadr pat))) ! 121: (t (cadr pat))) ! 122: protect-evform (cons 'or (mapcar '(lambda (x) ! 123: `(dtpr ,x)) ! 124: protect-list))) ! 125: (defmcrosrch (cddr pat) form sofar)) ! 126: ((eq (car pat) '&aux) ! 127: (mapcar '(lambda (frm) ! 128: (cond ((atom frm) `((nil) . ,frm)) ! 129: (t `((,(cadr frm)) . ,(car frm))))) ! 130: (cdr pat))) ! 131: (t (append (defmcrosrch (car pat) (cons 'a form) nil) ! 132: (defmcrosrch (cdr pat) (cons 'd form) sofar)))))) ! 133: ! 134: (def defmcrooption ! 135: (lambda (pat form sofar) ! 136: ((lambda (tmp tmp2) ! 137: (cond ((null pat) sofar) ! 138: ((memq (car pat) '(&rest &body)) ! 139: (defmcrosrch (cadr pat) form sofar)) ! 140: (t (cond ((atom (car pat)) ! 141: (setq tmp (car pat))) ! 142: (t (setq tmp (caar pat)) ! 143: (setq defmacrooptlist ! 144: `((,(cadar pat) ! 145: ,(concatl `(c ,@form)) ! 146: ,tmp ! 147: ,(setq tmp2 (caddar pat))) ! 148: . ,defmacrooptlist)))) ! 149: (defmcrooption ! 150: (cdr pat) ! 151: (cons 'd form) ! 152: `( (,(concatl `(ca ,@form)) . ,tmp) ! 153: ,@(cond (tmp2 `((nil . ,tmp2)))) ! 154: . ,sofar))))) ! 155: nil nil))) ! 156: ! 157: ! 158: ;--- lambdacvt :: new lambda converter. ! 159: ; ! 160: ; - input is a lambda body beginning with the argument list. ! 161: ; ! 162: ; vrbls :: list of (name n) where n is the arg number for name ! 163: ; optlist :: list of (name n defval pred) where optional variable name is ! 164: ; (arg n) [if it exists], initval is the value if it doesn't ! 165: ; exist, pred is set to non nil if the arg exists ! 166: ; auxlist :: list of (name initial-value) for auxillary variables. (&aux) ! 167: ; restform :: (name n) where args n to #args should be consed and assigned ! 168: ; to name. ! 169: ; ! 170: ;; strategy: ! 171: ; Until the compiler can compiler lexprs better, we try to avoid creating ! 172: ; a lexpr. A lexpr is only required if &optional or &rest forms ! 173: ; appear. ! 174: ; Formal parameters which come after &aux are bound and evaluated in a let* ! 175: ; surrounding the body. The parameter after a &rest is put in the let* ! 176: ; too, with an init form which is a complex do loop. The parameters ! 177: ; after &optional are put in the lambda expression just below the lexpr. ! 178: ; ! 179: (defun lambdacvt (exp) ! 180: (prog (vrbls optlist auxlist restform vbl fl-type optcode mainvar ! 181: minargs maxargs) ! 182: (do ((reallist (car exp) (cdr reallist)) ! 183: (count 1 (1+ count))) ! 184: ((null reallist)) ! 185: (setq vbl (car reallist)) ! 186: (cond ((memq vbl '(&rest &body)) ! 187: (setq fl-type '&rest count (1- count))) ! 188: ((eq '&aux vbl) ! 189: (setq fl-type '&aux count (1- count))) ! 190: ((eq '&optional vbl) ! 191: (setq fl-type '&optional count (1- count))) ! 192: ((null fl-type) ; just a variable ! 193: (setq vrbls (cons (list vbl count) vrbls))) ! 194: ((eq fl-type '&rest) ! 195: (cond (restform (error "Too many &rest parameters " vbl))) ! 196: (setq restform (list vbl count))) ! 197: ((eq fl-type '&aux) ! 198: (cond ((atom vbl) ! 199: (setq auxlist (cons (list vbl nil) auxlist))) ! 200: (t (setq auxlist (cons (list (car vbl) (cadr vbl)) ! 201: auxlist))))) ! 202: ((eq fl-type '&optional) ! 203: (cond ((atom vbl) ! 204: (setq optlist ! 205: (cons (list vbl count) optlist))) ! 206: (t (setq optlist ! 207: (cons (cons (car vbl) ! 208: (cons count ! 209: (cdr vbl))) ! 210: optlist))))))) ! 211: ! 212: ;; arguments are collected in reverse order, but set them straight ! 213: (setq vrbls (nreverse vrbls) ! 214: optlist (nreverse optlist) ! 215: auxlist (nreverse auxlist) ! 216: minargs (length vrbls) ! 217: maxargs (cond (restform nil) ! 218: (t (+ (length optlist) minargs)))) ! 219: ! 220: ;; we must covert to a lexpr if there are &optional or &rest forms ! 221: (cond ((or optlist restform) (setq mainvar (gensym)))) ! 222: ! 223: ; generate optionals code ! 224: (cond (optlist ! 225: (setq optcode ! 226: (mapcar '(lambda (x) ! 227: `(cond ((> ,(cadr x) ,mainvar) ! 228: (setq ,(car x) ,(caddr x))) ! 229: (t (setq ,(car x) ! 230: (arg ,(cadr x))) ! 231: ,(cond ((cdddr x) ! 232: `(setq ,(cadddr x) t)))))) ! 233: optlist)))) ! 234: ! 235: ;; do the rest forms ! 236: (cond (restform ! 237: (let ((dumind (gensym)) ! 238: (dumcol (gensym))) ! 239: (setq restform ! 240: `((,(car restform) ! 241: (do ((,dumind ,mainvar (1- ,dumind)) ! 242: (,dumcol nil (cons (arg ,dumind) ,dumcol))) ! 243: ((< ,dumind ,(cadr restform)) ,dumcol)))))))) ! 244: ! 245: ;; calculate body ! 246: (let (body) ! 247: (setq body (cond ((or auxlist restform) ! 248: `((let* ,(append restform auxlist) ! 249: ,@(cdr exp)))) ! 250: (t (cdr exp)))) ! 251: (cond ((null mainvar) ; no &optional or &rest ! 252: (return `(lambda ,(mapcar 'car vrbls) ! 253: (declare (*args ,minargs ,maxargs)) ! 254: ,@body))) ! 255: (t (return ! 256: `(lexpr (,mainvar) ! 257: (declare (*args ,minargs ,maxargs)) ! 258: ((lambda ! 259: ,(nconc ! 260: (mapcar 'car vrbls) ! 261: (mapcan '(lambda (x) ; may be two vrbls ! 262: (cons (car x) ! 263: (cond ((cdddr x) ;pred? ! 264: (ncons ! 265: (cadddr x)))))) ! 266: optlist)) ! 267: ,@optcode ,@body) ! 268: ,@(nconc (mapcar '(lambda (x) `(arg ,(cadr x))) ! 269: vrbls) ! 270: (mapcan '(lambda (x) ! 271: (cond ((cdddr x) ! 272: (list nil nil)) ! 273: (t (list nil)))) ! 274: optlist)))))))))) ! 275: ! 276: ;--- defcmacro :: like defmacro but result ends up under cmacro ind ! 277: ; ! 278: (def defcmacro ! 279: (macro (args) ! 280: (let ((name (concat (cadr args) "::cmacro:" (gensym)))) ! 281: `(eval-when (compile load eval) ! 282: (defmacro ,name ,@(cddr args)) ! 283: (putprop ',(cadr args) (getd ',name) 'cmacro) ! 284: (remob ',name))))) ! 285: ! 286: ;;; --- setf macro ! 287: ; ! 288: ;(setf (cadr x) 3) --> (rplaca (cdr x) 3) ! 289: ! 290: (defmacro setf (expr val &rest rest) ! 291: (cond ((atom expr) ! 292: (or (symbolp expr) ! 293: (error '|-- setf can't handle this.| expr)) ! 294: `(setq ,expr ,val)) ! 295: (t ! 296: (do ((y) ! 297: (tmp)) ! 298: (nil) ! 299: (and (dtpr (car expr)) ! 300: (setq tmp ! 301: (setf-record-package-access-check expr val)) ! 302: (return tmp)) ! 303: (or (symbolp (car expr)) ! 304: (error '|-- setf can't handle this.| expr)) ! 305: (and (setq y (get (car expr) 'setf-expand)) ! 306: (return (apply y `(,expr ,val ,@rest)))) ! 307: (or (setf-check-cad+r (car expr)) ! 308: (and ! 309: (or (setq y (get (car expr) 'cmacro)) ! 310: (setq y (getd (car expr)))) ! 311: (or (and (dtpr y) ! 312: (eq (car y) 'macro)) ! 313: (and (bcdp y) ! 314: (eq (getdisc y) 'macro))) ! 315: (setq expr (apply y expr))) ! 316: (error '|-- setf can't handle this.| expr)))))) ! 317: ! 318: (defun setf-check-cad+r (name) ! 319: ;; invert all c{ad}+r combinations ! 320: (if (eq (getcharn name 1) #/c) ! 321: then (let ((letters (nreverse (cdr (exploden name))))) ! 322: (if (eq (car letters) #/r) ! 323: then (do ((xx (cdr letters) (cdr xx))) ! 324: ((null xx) ! 325: ;; form is c{ad}+r, setf form is ! 326: ;; (rplac<first a or d> (c<rest of a's + d's>r x)) ! 327: (setq letters (nreverse letters)) ! 328: (eval ! 329: `(defsetf ,name (e v) ! 330: (list ! 331: ',(concat "rplac" (ascii (car letters))) ! 332: (list ! 333: ',(implode `(#/c ,@(cdr letters))) ! 334: (cadr e)) ! 335: v))) ! 336: t) ! 337: (if (not (memq (car xx) '(#/a #/d))) ! 338: then (return nil))))))) ! 339: ! 340: (defun setf-record-package-access-check (form val) ! 341: ;; When the record package is given the 'access-check' flag, ! 342: ;; the access macros it generates have this form: ! 343: ;; ((lambda (defrecord-acma) ! 344: ;; (cond (...) ! 345: ;; (t (access-form)))) ! 346: ;; res) ! 347: ;; To invert this, we make a copy of the form and replace the ! 348: ;; access-form with (setf (access-form) val) ! 349: ;; ! 350: ;; we return nil if the form passed isn't a recognized form ! 351: ;; ! 352: (cond ((and (dtpr form) ! 353: (dtpr (car form)) ! 354: (eq 'lambda (car (car form))) ! 355: (dtpr (cadr (car form))) ! 356: (eq (car (cadr (car form))) ! 357: 'defrecord-acma)) ! 358: ((lambda (newform acc) ! 359: ; newform is a copy of the given form, so we can ! 360: ; clobber it ! 361: ; locate the second clause of the cond ! 362: (setq acc (cadr ;; right the 't' ! 363: (caddr ;; second cond clause ! 364: (caddr ;; cond is third thing in lambda ! 365: (car newform))))) ! 366: (rplaca (cdaddaddar newform) (list 'setf acc val)) ! 367: newform) ! 368: (copy form) nil)) ! 369: (t nil))) ! 370: ! 371: (defmacro defsetf (name vars &rest body) ! 372: `(eval-when ! 373: (compile load eval) ! 374: (defun (,name setf-expand) ,vars . ,body))) ! 375: ! 376: ;--- other setf's for car's and cdr's are generated automatically ! 377: ; ! 378: (defsetf car (e v) `(rplaca ,(cadr e) ,v)) ! 379: (defsetf caar (e v) `(rplaca (car ,(cadr e)) ,v)) ! 380: (defsetf cadr (e v) `(rplaca (cdr ,(cadr e)) ,v)) ! 381: (defsetf cdr (e v) `(rplacd ,(cadr e) ,v)) ! 382: (defsetf cdar (e v) `(rplacd (car ,(cadr e)) ,v)) ! 383: (defsetf cddr (e v) `(rplacd (cdr ,(cadr e)) ,v)) ! 384: (defsetf cxr (e v) `(rplacx ,(cadr e) ,(caddr e) ,v)) ! 385: ! 386: (defsetf vref (e v) `(vset ,(cadr e) ,(caddr e) ,v)) ! 387: (defsetf vrefi-byte (e v) `(vseti-byte ,(cadr e) ,(caddr e) ,v)) ! 388: (defsetf vrefi-word (e v) `(vseti-word ,(cadr e) ,(caddr e) ,v)) ! 389: (defsetf vrefi-long (e v) `(vseti-long ,(cadr e) ,(caddr e) ,v)) ! 390: ! 391: (defsetf nth (e v) `(rplaca (nthcdr ,(cadr e) ,(caddr e)) ,v)) ! 392: (defsetf nthelem (e v) `(rplaca (nthcdr (1- ,(cadr e)) ,(caddr e)) ,v)) ! 393: (defsetf nthcdr (e v) `(rplacd (nthcdr (1- ,(cadr e)) ,(caddr e)) ,v)) ! 394: ! 395: (defsetf arraycall (e v) `(store ,e ,v)) ! 396: (defsetf get (e v) `(putprop ,(cadr e) ,v ,(caddr e))) ! 397: ! 398: (defsetf plist (e v) `(setplist ,(cadr e) ,v)) ! 399: ! 400: (defsetf symeval (e v) `(set ,(cadr e) ,v)) ! 401: ! 402: (defsetf arg (e v) `(setarg ,(cadr e) ,v)) ! 403: ! 404: (defsetf args (e v) `(args ,(cadr e) ,v)) ! 405: ! 406: ! 407: (defmacro push (object list) `(setf ,list (cons ,object ,list))) ! 408: ! 409: ; this relies on the fact that setf returns the value stored. ! 410: (defmacro pop (list &optional (into nil into-p)) ! 411: (cond (into-p `(prog1 (setf ,into (car ,list)) ! 412: (setf ,list (cdr ,list)))) ! 413: (t `(prog1 (car ,list) ! 414: (setf ,list (cdr ,list)))))) ! 415: ! 416: ; let for franz (with destructuring) ! 417: ;--- let ! 418: ; - binds - binding forms ! 419: ; - . body - forms to execute ! 420: ; the binding forms may have these forms ! 421: ; a local variable a, initially nil ! 422: ; (a x) local variable a, x is evaled and a gets its value initially ! 423: ; ((a . (b . c)) x) three local variables, a,b and c which are given ! 424: ; values corresponding to the location in the value ! 425: ; of x. Any structure is allowed here. ! 426: ; ! 427: (defmacro let (binds &rest body &aux vrbls vals destrs newgen) ! 428: (mapc '(lambda (form) ! 429: (cond ((atom form) ! 430: (setq vrbls (cons form vrbls) ! 431: vals (cons nil vals))) ! 432: ((atom (car form)) ! 433: (setq vrbls (cons (car form) vrbls) ! 434: vals (cons (cadr form) vals))) ! 435: (t (setq newgen (gensym) ! 436: destrs `((,newgen ,@(de-compose (car form) '(r))) ! 437: ,@destrs) ! 438: vrbls (cons newgen vrbls) ! 439: vals (cons (cadr form) vals))))) ! 440: binds) ! 441: ! 442: (mapc '(lambda (frm) ! 443: (do ((ll (cdr frm) (cdr ll))) ! 444: ((null ll)) ! 445: (setq vrbls (cons (cdar ll) vrbls) ! 446: vals (cons nil vals)))) ! 447: destrs) ! 448: ! 449: (setq vals (nreverse vals) ! 450: vrbls (nreverse vrbls) ! 451: destrs (nreverse destrs)) ! 452: `((lambda ,vrbls ! 453: ,@(mapcan '(lambda (frm) ! 454: (mapcar '(lambda (vrb) ! 455: `(setq ,(cdr vrb) (,(car vrb) ! 456: ,(car frm)))) ! 457: (cdr frm))) ! 458: destrs) ! 459: ,@body) ! 460: ,@vals)) ! 461: ! 462: ;--- de-compose ! 463: ; form - pattern to de-compose ! 464: ; sofar - the sequence of cxxr's needed to get to this part ! 465: ; of the pattern ! 466: ; de-compose returns a list of this form ! 467: ; ! 468: ; ((cxxr . a) (cyyr . b) ... ) ! 469: ; which tells how to get to the value for a and b ..etc.. ! 470: ; ! 471: (def de-compose ! 472: (lambda (form sofar) ! 473: (cond ((null form ) nil) ! 474: ((atom form) (ncons (cons (apply 'concat (cons 'c sofar)) ! 475: form))) ! 476: (t (nconc (de-compose (car form) (cons 'a sofar)) ! 477: (de-compose (cdr form) (cons 'd sofar))))))) ! 478: ! 479: ;--- caseq ! 480: ; use is ! 481: ; (caseq expr ! 482: ; (match1 do1) ! 483: ; (match2 do2) ! 484: ; (t doifallelsefails)) ! 485: ; the matchi can be atoms in which case an 'eq' test is done, or they ! 486: ; can be lists in which case a 'memq' test is done. ! 487: ; ! 488: ! 489: (defmacro caseq (switch &body clauses &aux var code) ! 490: (setq var (cond ((symbolp switch) switch) ((gensym 'Z)))) ! 491: (setq code ! 492: `(cond . ,(mapcar '(lambda (clause) ! 493: (cons ! 494: (let ((test (car clause))) ! 495: (cond ((eq test t) t) ! 496: ((dtpr test) ! 497: `(memq ,var ',test)) ! 498: (t `(eq ,var ',test)))) ! 499: (cdr clause))) ! 500: clauses))) ! 501: (cond ((symbolp switch) code) ! 502: (`((lambda (,var) ,code) ,switch)))) ! 503: ! 504: ;--- selectq :: just like caseq ! 505: ; except 'otherwise' is recogized as equivalent to 't' as a key ! 506: ; ! 507: (defmacro selectq (key . forms) ! 508: (setq forms ! 509: (mapcar '(lambda (form) (if (eq (car form) 'otherwise) ! 510: (cons t (cdr form)) form)) ! 511: forms)) ! 512: `(caseq ,key . ,forms)) ! 513: ! 514: ;--- let* ! 515: ; - binds - binding forms (like let) ! 516: ; - body - forms to eval (like let) ! 517: ; this is the same as let, except forms are done in a left to right manner ! 518: ; in fact, all we do is generate nested lets ! 519: ; ! 520: (defmacro let* (binds &rest body) ! 521: (do ((ll (reverse binds) (cdr ll))) ! 522: ((null ll) (car body)) ! 523: (setq body `((let (,(car ll)) ,@body))))) ! 524: ! 525: ! 526: ! 527: ;--- listify : n - integer ! 528: ; returns a list of the first n args to the enclosing lexpr if ! 529: ; n is positive, else returns the last -n args to the lexpr if n is ! 530: ; negative. ! 531: ; returns nil if n is 0 ! 532: ; ! 533: (def listify ! 534: (macro (lis) ! 535: `(let ((n ,(cadr lis))) ! 536: (cond ((eq n 0) nil) ! 537: ((minusp n) ! 538: (do ((i (arg nil) (1- i)) ! 539: (result nil (cons (arg i) result))) ! 540: ((<& i (+ (arg nil) n 1)) result) )) ! 541: (t (do ((i n (1- i)) ! 542: (result nil (cons (arg i) result))) ! 543: ((<& i 1) result) )))))) ! 544: ! 545: ;--- include-if ! 546: ; form: (include-if <predicate> <filename>) ! 547: ; will return (include <filename>) if <predicate> is non-nil ! 548: ; This is useful at the beginning of a file to conditionally ! 549: ; include a file based on whether it has already been included. ! 550: ; ! 551: (defmacro include-if (pred filename) ! 552: (cond ((eval pred) `(include ,filename)))) ! 553: ! 554: ;--- includef-if ! 555: ; form: (includef-if <predicate> '<filename>) ! 556: ; like the above except it includef's the file. ! 557: ; ! 558: (defmacro includef-if (pred filenameexpr) ! 559: (cond ((eval pred) `(includef ,filenameexpr)))) ! 560: ! 561: ;--- if :: macro for doing conditionalization ! 562: ; ! 563: ; This macro is compatible with both the crufty mit-version and ! 564: ; the keyword version at ucb. ! 565: ; ! 566: ; simple summary: ! 567: ; non-keyword use: ! 568: ; (if a b) ==> (cond (a b)) ! 569: ; (if a b c d e ...) ==> (cond (a b) (t c d e ...)) ! 570: ; with keywords: ! 571: ; (if a then b) ==> (cond (a b)) ! 572: ; (if a thenret) ==> (cond (a)) ! 573: ; (if a then b c d e) ==> (cond (a b c d e)) ! 574: ; (if a then b c else d) ==> (cond (a b c) (t d)) ! 575: ; (if a then b c elseif d thenret else g) ! 576: ; ==> (cond (a b c) (d) (t g)) ! 577: ; ! 578: ; ! 579: ; ! 580: ; ! 581: ; In the syntax description below, ! 582: ; optional parts are surrounded by [ and ], ! 583: ; + means one or more instances. ! 584: ; | means 'or' ! 585: ; <expr> is an lisp expression which isn't a keyword ! 586: ; The keywords are: then, thenret, else, elseif. ! 587: ; <pred> is also a lisp expression which isn't a keyword. ! 588: ; ! 589: ; <if-stmt> ::= <simple-if-stmt> ! 590: ; | <keyword-if-stmt> ! 591: ; ! 592: ; <simple-if-stmt> ::= (if <pred> <expr>) ! 593: ; | (if <pred> <expr> <expr>) ! 594: ; ! 595: ; <keyword-if-stmt> ::= (if <pred> <then-clause> [ <else-clause> ] ) ! 596: ; ! 597: ; <then-clause> ::= then <expr>+ ! 598: ; | thenret ! 599: ; ! 600: ; <else-clause> ::= else <expr>+ ! 601: ; | elseif <pred> <then-clause> [ <else-clause> ] ! 602: ; ! 603: ! 604: (declare (special if-keyword-list)) ! 605: ! 606: (eval-when (compile load eval) ! 607: (setq if-keyword-list '(then thenret elseif else))) ! 608: ! 609: ;--- if ! 610: ; ! 611: ; the keyword if expression is parsed using a simple four state ! 612: ; automaton. The expression is parsed in reverse. ! 613: ; States: ! 614: ; init - have parsed a complete predicate, then clause ! 615: ; col - have collected at least one non keyword in col ! 616: ; then - have just seen a then, looking for a predicate ! 617: ; compl - have just seen a predicate after an then, looking ! 618: ; for elseif or if (i.e. end of forms). ! 619: ; ! 620: (defmacro if (&rest args) ! 621: (let ((len (length args))) ! 622: ;; first eliminate the non-keyword if macro cases ! 623: (cond ((<& len 2) ! 624: (error "if: not enough arguments " args)) ! 625: ((and (=& len 2) ! 626: (not (memq (cadr args) if-keyword-list))) ! 627: `(cond (,(car args) ,(cadr args)))) ! 628: ; clause if there are not keywords (and len > 2) ! 629: ((do ((xx args (cdr xx))) ! 630: ((null xx) t) ! 631: (cond ((memq (car xx) if-keyword-list) ! 632: (return nil)))) ! 633: `(cond (,(car args) ,(cadr args)) ! 634: (t ,@(cddr args)))) ! 635: ! 636: ;; must be an instance of a keyword if macro ! 637: ! 638: (t (do ((xx (reverse args) (cdr xx)) ! 639: (state 'init) ! 640: (elseseen nil) ! 641: (totalcol nil) ! 642: (col nil)) ! 643: ((null xx) ! 644: (cond ((eq state 'compl) ! 645: `(cond ,@totalcol)) ! 646: (t (error "if: illegal form " args)))) ! 647: (cond ((eq state 'init) ! 648: (cond ((memq (car xx) if-keyword-list) ! 649: (cond ((eq (car xx) 'thenret) ! 650: (setq col nil ! 651: state 'then)) ! 652: (t (error "if: bad keyword " ! 653: (car xx) args)))) ! 654: (t (setq state 'col ! 655: col nil) ! 656: (push (car xx) col)))) ! 657: ((eq state 'col) ! 658: (cond ((memq (car xx) if-keyword-list) ! 659: (cond ((eq (car xx) 'else) ! 660: (cond (elseseen ! 661: (error ! 662: "if: multiples elses " ! 663: args))) ! 664: (setq elseseen t) ! 665: (setq state 'init) ! 666: (push `(t ,@col) totalcol)) ! 667: ((eq (car xx) 'then) ! 668: (setq state 'then)) ! 669: (t (error "if: bad keyword " ! 670: (car xx) args)))) ! 671: (t (push (car xx) col)))) ! 672: ((eq state 'then) ! 673: (cond ((memq (car xx) if-keyword-list) ! 674: (error "if: keyword at the wrong place " ! 675: (car xx) args)) ! 676: (t (setq state 'compl) ! 677: (push `(,(car xx) ,@col) totalcol)))) ! 678: ((eq state 'compl) ! 679: (cond ((not (eq (car xx) 'elseif)) ! 680: (error "if: missing elseif clause " args))) ! 681: (setq state 'init)))))))) ! 682: ! 683: ;--- If :: the same as 'if' but defined for those programs that still ! 684: ; use it. ! 685: ; ! 686: (putd 'If (getd 'if)) ! 687: ! 688: ;--- defvar :: a macro for declaring a variable special ! 689: ; a variable declared special with defvar will be special when the ! 690: ; file containing the variable is compiled and also when the file ! 691: ; containing the defvar is loaded in. Furthermore, you can specify ! 692: ; an default value for the variable. It will be set to that value ! 693: ; iff it is unbound ! 694: ; ! 695: (defmacro defvar (variable &optional (initial-value nil iv-p) documentation) ! 696: (if iv-p ! 697: then `(progn 'compile ! 698: (eval-when (eval compile load) ! 699: (eval '(liszt-declare (special ,variable)))) ! 700: (or (boundp ',variable) (setq ,variable ,initial-value))) ! 701: else `(eval-when (eval compile load) ! 702: (eval '(liszt-declare (special ,variable)))))) ! 703: ! 704: ! 705: ! 706: ! 707: (defmacro list* (&rest forms) ! 708: (cond ((null forms) nil) ! 709: ((null (cdr forms)) (car forms)) ! 710: (t (construct-list* forms)))) ! 711: ! 712: (eval-when (load compile eval) ! 713: (defun construct-list* (forms) ! 714: (setq forms (reverse forms)) ! 715: (do ((forms (cddr forms) (cdr forms)) ! 716: (return-form `(cons ,(cadr forms) ,(car forms)) ! 717: `(cons ,(car forms) ,return-form))) ! 718: ((null forms) return-form)))) ! 719: ! 720: ;; (<= a b) --> (not (> a b)) ! 721: ;; (<= a b c) --> (not (or (> a b) (> b c))) ! 722: ;; funny arglist to check for correct number of arguments. ! 723: ! 724: ! 725: (defmacro <= (arg1 arg2 &rest rest &aux result) ! 726: (setq rest (list* arg1 arg2 rest)) ! 727: (do l rest (cdr l) (null (cdr l)) ! 728: (push `(> ,(car l) ,(cadr l)) result)) ! 729: (cond ((null (cdr result)) `(not ,(car result))) ! 730: (t `(not (or . ,(nreverse result)))))) ! 731: ! 732: (defmacro <=& (x y) ! 733: `(not (>& ,x ,y))) ! 734: ! 735: ;; (>= a b) --> (not (< a b)) ! 736: ;; (>= a b c) --> (not (or (< a b) (< b c))) ! 737: ;; funny arglist to check for correct number of arguments. ! 738: ! 739: (defmacro >= (arg1 arg2 &rest rest &aux result) ! 740: (setq rest (list* arg1 arg2 rest)) ! 741: (do l rest (cdr l) (null (cdr l)) ! 742: (push `(< ,(car l) ,(cadr l)) result)) ! 743: (cond ((null (cdr result)) `(not ,(car result))) ! 744: (t `(not (or . ,(nreverse result)))))) ! 745: ! 746: ! 747: (defmacro >=& (x y) ! 748: `(not (<& ,x ,y)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.