;-*- cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved. (defmacro when (pred &body body) "SYNTAX: (WHEN pred {form}*) A one-armed conditional equivalent to (AND pred (PROGN {form}*)" `(and ,pred (progn ,@body))) (defmacro unless (pred &body body) "SYNTAX: (UNLESS pred {form}*) A one-armed conditional equivalent to (AND (NOT pred) (PROGN {form}*)" `(cond (,pred nil) (t . ,body))) ;;; `(AND (NOT ,pred) (PROGN ,@BODY))) (defmacro typecase (object &body clauses) "Execute the first clause whose type specifier OBJECT fits. The first element of each clause is a type specifier. It is used as the second argument to TYPEP to test the type of OBJECT. If the result is T, the rest of that clause is excuted and the values of the last form in it are the values of the TYPECASE form. If no clause fits, the value of the TYPECASE is NIL." `(cond . ,(loop for (type . consequents) in clauses collect `(,(progn (macro-type-check-warning 'typecase type) (cond ((member type '(t otherwise) :test #'eq) 't) (t `(typep ,object ',type)))) nil . ,consequents)))) (defsubst neq (x y) "T if X and Y are not the same object." (not (eq x y))) (defprop .case.item. t compiler:ignorable-variable) (deff-macro zlc:selectq 'case) (deff-macro zlc:caseq 'case) (defmacro case (test-object &body clauses) "Execute the first clause that matches TEST-OBJECT. The first element of each clause is a match value or a list of match values. TEST-OBJECT is compared with the match values using EQL. When a match-value matches, the rest of that clause is executed and the value of the last thing in the clause is the value of the CASE. T or OTHERWISE as the first element of a clause matches any test object." (let (test-exp cond-exp) (setq test-exp ;; If TEST-OBJECT is an eval-at-load-time, ;; we will treat it as a random expression, which is right. (cond ((or (atom test-object) (and (member (car test-object) '(car cdr caar cadr cdar cddr) :test #'eq) (atom (cadr test-object)))) test-object) (t '.case.item.))) (setq cond-exp (cons 'cond (mapcar #'(lambda (clause) (macro-type-check-warning 'case (car clause)) (cond ((member (car clause) '(otherwise :otherwise t) :test #'eq) (list* t nil (cdr clause))) ((atom (car clause)) `((eql ,test-exp ',(car clause)) nil . ,(cdr clause))) (t `((member ,test-exp ',(car clause) :test #'eql) nil . ,(cdr clause))))) clauses))) (dead-clauses-warning (cdr cond-exp) 'case) (if (eql test-exp test-object) cond-exp `(let ((.case.item. ,test-object)) ,cond-exp)))) (defmacro select-memq (test-list &body clauses) "Execute the first clause that matches some element of TEST-LIST. The first element of each clause is a match value or a list of match values. Each match value is compare with each element of TEST-LIST, using EQ. When a match-value matches, the rest of that clause is executed and the value of the last thing in the clause is the value of the SELECT-MEMQ. T or :OTHERWISE as the first element of a clause matches any test object." (let (test-exp cond-exp) (setq test-exp ;; If TEST-LIST is an eval-at-load-time, ;; we will treat it as a random expression, which is right. (cond ((or (atom test-list) (and (member (car test-list) '(car cdr caar cadr cdar cddr) :test #'eq) (atom (cadr test-list)))) test-list) (t '.case.item.))) (setq cond-exp (cons 'cond (mapcar #'(lambda (clause) (macro-type-check-warning 'select-memq (car clause)) (cond ((member (car clause) '(otherwise :otherwise t) :test #'eq) (list* t nil (cdr clause))) ((atom (car clause)) `((member ',(car clause) ,test-exp :test #'eq) nil . ,(cdr clause))) (t `((or . ,(mapcar #'(lambda (match-value) `(member ',match-value ,test-exp :test #'eq)) (car clause))) nil . ,(cdr clause))))) clauses))) (dead-clauses-warning (cdr cond-exp) 'select-memq) (cond ((eq test-exp test-list) cond-exp) (t `(let ((.case.item. ,test-list)) ,cond-exp))))) (defmacro select (test-object &body clauses) "Execute the first clause that matches TEST-OBJECT. The first element of each clause is a match value expression or a list of such. TEST-OBJECT is compared with the VALUES of the match expressions, using EQ. When a match-value matches, the rest of that clause is executed and the value of the last thing in the clause is the value of the SELECT. T or :OTHERWISE as the first element of a clause matches any test object. This is a special exception, in that :OTHERWISE is not evaluated." (let (test-exp cond-exp) (setq test-exp ;; If TEST-OBJECT is an eval-at-load-time, ;; we will treat it as a random expression, which is right. (cond ((or (atom test-object) (and (member (car test-object) '(car cdr caar cadr cdar cddr) :test #'eq) (atom (cadr test-object)))) test-object) (t '.case.item.))) (setq cond-exp (cons 'cond (mapcar #'(lambda (clause) (macro-type-check-warning 'select (car clause)) (cond ((member (car clause) '(otherwise :otherwise t) :test #'eq) (list* t nil (cdr clause))) ((atom (car clause)) `((eq ,test-exp ,(car clause)) nil . ,(cdr clause))) (t `((or . ,(mapcar #'(lambda (form) `(eq ,test-exp ,form)) (car clause))) nil . ,(cdr clause))))) clauses))) (dead-clauses-warning (cdr cond-exp) 'select) (cond ((eq test-exp test-object) cond-exp) (t `(let ((.case.item. ,test-object)) ,cond-exp))))) (defmacro selector (test-object test-function &body clauses) "Execute the first clause that matches TEST-OBJECT. The first element of each clause is a match value expression or a list of such. TEST-OBJECT is compared with the VALUES of the match expressions, using TEST-FUNCTION. When a match-value matches, the rest of that clause is executed and the value of the last thing in the clause is the value of the SELECTor. T or :OTHERWISE as the first element of a clause matches any test object. This is a special exception, in that :OTHERWISE is not evaluated." (let (test-exp cond-exp) (setq test-exp ;; If TEST-OBJECT is an eval-at-load-time, ;; we will treat it as a random expression, which is right. (cond ((or (atom test-object) (and (member (car test-object) '(car cdr caar cadr cdar cddr) :test #'eq) (atom (cadr test-object)))) test-object) (t '.case.item.))) (setq cond-exp (cons 'cond (mapcar #'(lambda (clause) (macro-type-check-warning 'selector (car clause)) (cond ((member (car clause) '(otherwise :otherwise t) :test #'eq) (list* t nil (cdr clause))) ((atom (car clause)) `((,test-function ,test-exp ,(car clause)) nil . ,(cdr clause))) (t `((or . ,(mapcar #'(lambda (form) `(,test-function ,test-exp ,form)) (car clause))) nil . ,(cdr clause))))) clauses))) (dead-clauses-warning (cdr cond-exp) 'selector) (cond ((eq test-exp test-object) cond-exp) (t `(let ((.case.item. ,test-object)) ,cond-exp))))) (defmacro cond-every (&body clauses) "COND-EVERY has a COND-like syntax. Unlike COND, though, it executes all the clauses whose tests succede. It also recognizes two special keywords (instead of a test): :ALWAYS executes in all cases, and :OTHERWISE executes if no previous clause has executed. The value returned is that of the last clause executed, or NIL if no clauses executed, and the macro will not return multiple-values." (let ((flag (gensym)) (value (gensym))) `(let ((,flag) (,value)) ,@(do ((cs clauses (cdr cs)) (clause (car clauses) (cadr cs)) (forms nil) (seen-otherwise-or-always)) ((null cs) (nreverse forms)) (push (case (car clause) ((:always t always) (setq seen-otherwise-or-always :always) `(setq ,value (progn . ,(cdr clause)))) ((:otherwise otherwise) (if seen-otherwise-or-always (ferror () ":OTHERWISE after a previous :OTHERWISE or :ALWAYS") (progn (setq seen-otherwise-or-always :otherwise) `(or ,flag (setq ,value (progn . ,(cdr clause))))))) (otherwise `(and ,(car clause) (setq ,value (progn . ,(cdr clause)) ,@(if seen-otherwise-or-always () `(,flag t)))))) forms)) ,value))) (defmacro selectq-every (obj &body clauses) "Just like COND-EVERY but with CASE-like syntax." (if (atom obj) (selectq-every-generate-code obj clauses) (let ((sym (gensym))) `(let ((,sym ,obj)) ,(selectq-every-generate-code sym clauses))))) (defun selectq-every-generate-code (compare-against clauses) `(cond-every . ,(do ((cs clauses (cdr cs)) (clause (car clauses) (cadr cs)) (forms nil)) ((null cs) (nreverse forms)) (push (cond ((member (car clause) '(:otherwise :always otherwise always t) :test #'eq) clause) (t `((,(if (consp (car clause)) 'zlc:memq 'eq) ,compare-against ',(car clause)) . ,(cdr clause)))) forms)))) ;;PAD 2/3/87 Changed tests to eql to allow compiler optimization (defmacro dispatch (ppss word &body clauses) "Extract the byte PPSS from WORD and execute a clause selected by the value. The first element of each clause is a value to compare with the byte value, or a list of byte values. These byte values are evaluated!. T or :OTHERWISE as the first element of a clause matches any test object. This is a special exception, in that :OTHERWISE is not evaluated." (let ((foo (gensym))) `(let ((,foo (ldb ,ppss ,word))) (cond ,@(mapcar #'(lambda (clause) (macro-type-check-warning 'dispatch (car clause)) `(,(cond ((member (car clause) '(otherwise :otherwise t) :test #'eq) 't) ((atom (car clause)) `(eql ,foo ,(car clause))) (t `(or ,@(mapcar #'(lambda (item) `(eql ,foo ,item)) (car clause))))) nil . ,(cdr clause))) clauses))))) ;;PAD-PHD, Added Support for THE special form. (defmacro once-only (variable-list &body body) "Generate code that evaluates certain expressions only once. This is used in macros, for computing expansions. VARIABLE-LIST is a list of symbols, whose values are subexpressions to be substituted into a larger expression. BODY is what uses those symbols' values and constructs the larger expression. ONCE-ONLY modifies BODY so that it constructs a different expression, which when run will evaluate the subsexpressions only once, save the values in temporary variables, and use those from then on. Example: \(DEFMACRO DOUBLE (ARG) `(+ ,ARG ,ARG)) expands into code that computes ARG twice. \(DEFMACRO DOUBLE (ARG) (ONCE-ONLY (ARG) `(+ ,ARG ,ARG))) will not." (dolist (variable variable-list) (if (not (symbolp variable)) (ferror nil "~S is not a variable" variable))) (let ((bind-vars (gensym)) (bind-vals (gensym)) (tem (gensym))) `(let ((,bind-vars nil) (,bind-vals nil)) (let ((result ((,(if (common-lisp-on-p) 'cli:lambda 'global:lambda) ,variable-list . ,body) . ,(loop for variable in variable-list collect `(if (let ((variable ,variable)) (loop (when (atom variable) (return t)) (when (or (eq (car variable) 'quote) (eq (car variable) 'function)) (return t)) (if (eq (car variable) 'the) (setf variable (cadr-safe (cdr-safe variable))) (return nil)))) ,variable (let ((,tem (gensym))) (push ,tem ,bind-vars) (push ,variable ,bind-vals) ,tem)))))) (if (null ,bind-vars) result `((,(if (common-lisp-on-p) 'cli:lambda 'global:lambda) ,(nreverse ,bind-vars) ,result) . ,(nreverse ,bind-vals))))))) (defsubst true () "Returns T" 't) (defsubst false () "Returns NIL" 'nil) ;;; (CHECK-ARG ), for example: ;;; (CHECK-ARG STRING STRINGP "a string") signals an error if STRING is not a string. ;;; The error signals condition :WRONG-TYPE-ARGUMENT with arguments ;;; which are STRINGP (the predicate), the value of STRING (the losing value), ;;; the name of the argument (STRING), and the string "a string". ;;; If you try to proceed and do not supply a valid string to replace it, ;;; the error happens again. ;;; The second form may be the name of a predicate function, or it may be a full ;;; predicate form, as in: ;;; (CHECK-ARG A (AND (NUMBERP A) (< A 10.) (> A 0.)) "a number from one to ten" ONE-TO-TEN) ;;; ONE-TO-TEN is a symbol for the "type" which the argument failed to be. ;;; It is used instead of the second argument (the predicate) when signalling the error, ;;; since the second argument is not a suitable symbol. ;;; The value returned by CHECK-ARG is the argument's (original or respecified) value. ;;; In general, the condition :WRONG-TYPE-ARGUMENT is signalled with arguments ;;; (1) A symbol for the desired type (NIL if not supplied) ;;; (2) The bad value ;;; (3) The name of the argument ;;; (4) A string for the desired type. (defmacro check-arg (arg-name predicate type-string &optional error-type-name) "Generate error if the value of ARG-NAME doesn't satisfy PREDICATE. PREDICATE is a function name (a symbol) or an expression to compute. TYPE-STRING is a string to use in the error message, such as \"a list\". ERROR-TYPE-NAME is a keyword that tells condition handlers what type was desired." (and (null error-type-name) (symbolp predicate) (setq error-type-name predicate)) `(do () (,(cond ((symbolp predicate) `(,predicate ,arg-name)) (t predicate)) ,arg-name) (setf ,arg-name (cerror '(:argument-value) nil 'wrong-type-argument "The argument ~2@*~A was ~1@*~S, which is not ~3@*~A." ',error-type-name ,arg-name ',arg-name ',type-string)))) (deff check-type 'check-arg-type) ;;; (CHECK-ARG-TYPE X FIXNUM) signals an error if (TYPEP X 'FIXNUM) is not true. (defmacro check-arg-type (arg-name type &optional type-string) "Generate an error unless (TYPEP ARG-NAME 'TYPE). TYPE-STRING is a string to use in the error message, such as \"a list\". If you omit it, it will be computed from TYPE's pname." (when (null type-string) (setq type-string (type-pretty-name type))) `(do () ((typep ,arg-name ',type)) (setf ,arg-name (cerror '(:argument-value) nil 'wrong-type-argument "The argument ~2@*~A was ~1@*~S, which is not ~3@*~A." ',type ,arg-name ',arg-name ',type-string)))) ;;PAD 2/10/87 No explicit OTHERWISE or T clause is permitted. (defmacro etypecase (object &body clauses) "Execute the first clause whose type specifier OBJECT fits. The first element of each clause is a type specifier. It is used as the second argument to TYPEP to test the type of OBJECT. If the result is T, the rest of that clause is excuted and the values of the last form in it are the values of the ETYPECASE form. If no clause fits, an uncorrectable error is signaled." (let ((save-object object)) (once-only (object) `(cond ,@(loop for (type . consequents) in clauses collect `(,(progn (when (member type '(otherwise t) :test #'eq) (ferror nil "Etypecase may not contain an otherwise or t clause.")) (macro-type-check-warning 'typecase type) `(typep ,object ',type)) nil . ,consequents)) (t (ferror nil "The argument ~2@*~A was ~1@*~S, which is not ~3@*~A." '(or . ,(mapcar 'car clauses)) ,object ',save-object ,(type-pretty-name `(or . ,(mapcar 'car clauses))))))))) ;;PAD 2/10/87 No explicit OTHERWISE or T clause is permitted. (defmacro ctypecase (object &body clauses) "Execute the first clause whose type specifier OBJECT fits. The first element of each clause is a type specifier. It is used as the second argument to TYPEP to test the type of OBJECT. If the result is T, the rest of that clause is excuted and the values of the last form in it are the values of the CTYPECASE form. If no clause fits, a correctable error is signaled. The user can correct with a new value for OBJECT." (let ((save-object object)) `(block ctypecase-loop (tagbody ctypecase-loop (return-from ctypecase-loop ,(once-only (object) `(cond ,@(loop for (type . consequents) in clauses collect `(,(progn (when (member type '(otherwise t) :test #'eq) (ferror nil "Ctypecase may not contain an otherwise or t clause.")) (macro-type-check-warning 'typecase type) `(typep ,object ',type)) nil . ,consequents)) (t (setf ,save-object (cerror '(:argument-value) nil 'wrong-type-argument "The argument ~2@*~A was ~1@*~S, which is not ~3@*~A." '(or . ,(mapcar 'car clauses)) ,object ',save-object ,(type-pretty-name `(or . ,(mapcar 'car clauses))))) (go ctypecase-loop))))))))) ;;PAD 2/10/87 No explicit OTHERWISE or T clause is permitted. (defmacro ccase (test-object &body clauses) "Execute the first clause that matches TEST-OBJECT. The first element of each clause is a match value or a list of match values. TEST-OBJECT is compared with the match values using EQL. When a match-value matches, the rest of that clause is executed and the value of the last thing in the clause is the value of the CCASE. If no clause matches, a correctable error is signaled. The user can correct with a new value for TEST-OBJECT." (let (test-exp cond-exp type-for-error) (setq test-exp ;; If TEST-OBJECT is an eval-at-load-time, ;; we will treat it as a random expression, which is right. (cond ((or (atom test-object) (and (member (car test-object) '(car cdr caar cadr cdar cddr) :test #'eq) (atom (cadr test-object)))) test-object) (t '.case.item.))) (setq type-for-error `(member . ,(mapcan #'(lambda (clause) (let ((match (car clause))) (if (not (consp match)) (list match) (copy-list match)))) clauses))) (setq cond-exp `(cond ,@(mapcar #'(lambda (clause) (let ((car-clause (car clause))) (macro-type-check-warning 'ccase car-clause) (if (atom car-clause) (progn (when (member car-clause '(otherwise :otherwise t) :test #'eq) (ferror nil "Ccase may not contain an OTHERWISE or T clause.")) `((eql ,test-exp ',car-clause) nil . ,(cdr clause))) `((member-eql ,test-exp ',car-clause) nil . ,(cdr clause))))) clauses) (t (setf ,test-object (cerror '(:argument-value) nil 'wrong-type-argument "The argument ~2@*~A was ~1@*~S, which is not ~3@*~A." ',type-for-error ,test-exp ',test-object ,(type-pretty-name type-for-error))) (go ccase-loop)))) (dead-clauses-warning (cdr cond-exp) 'ccase) (unless (eql test-exp test-object) (setq cond-exp `(let ((.case.item. ,test-object)) ,cond-exp))) `(block ccase-loop (tagbody ccase-loop (return-from ccase-loop ,cond-exp))))) ;;PAD 2/10/87 No explicit OTHERWISE or T clause is permitted. (defmacro ecase (test-object &body clauses) "Execute the first clause that matches TEST-OBJECT. The first element of each clause is a match value or a list of match values. TEST-OBJECT is compared with the match values using EQL. When a match-value matches, the rest of that clause is executed and the value of the last thing in the clause is the value of the ECASE. If no clause matches, an uncorrectable error is signaled." (let (test-exp cond-exp type-for-error) (setq test-exp ;; If TEST-OBJECT is an eval-at-load-time, ;; we will treat it as a random expression, which is right. (cond ((or (atom test-object) (and (member (car test-object) '(car cdr caar cadr cdar cddr) :test #'eq) (atom (cadr test-object)))) test-object) (t '.case.item.))) (setq type-for-error `(member . ,(mapcan #'(lambda (clause) (let ((match (car clause))) (if (not (consp match)) (list match) (copy-list match)))) clauses))) (setq cond-exp `(cond ,@(mapcar #'(lambda (clause) (let ((car-clause (car clause))) (macro-type-check-warning 'ecase (car clause)) (if (atom car-clause) (progn (when (member car-clause '(otherwise :otherwise t) :test #'eq) (ferror nil "Ecase may not contain an OTHERWISE or T clause.")) `((eql ,test-exp ',car-clause) nil . ,(cdr clause))) `((member-eql ,test-exp ',car-clause) nil . ,(cdr clause))))) clauses) (t (ferror nil "The argument ~2@*~A was ~1@*~S, which is not ~3@*~A." ',type-for-error ,test-exp ',test-object ,(type-pretty-name type-for-error))))) (dead-clauses-warning (cdr cond-exp) 'ecase) (unless (eql test-exp test-object) (setq cond-exp `(let ((.case.item. ,test-object)) ,cond-exp))) cond-exp)) (defmacro assert (test-form &optional places (format-string "Assertion failed.") &rest args) "Signals an error if TEST-FORM evals to NIL. PLACES are SETF'able things that the user should be able to change when proceeding. Typically they are things used in TEST-FORM. Each one becomes a proceed-type which means to set that place. FORMAT-STRING and ARGS are passed to FORMAT to make the error message." (declare (arglist test-form &optional places format-string &rest args)) (if (null places) `(unless ,test-form (ferror (make-condition 'eh:failed-assertion ':places () ':format-string ,format-string ':format-args (list . ,args)) )) `(do () (,test-form) (signal-proceed-case ((value) 'eh:failed-assertion ':places ',places ':format-string ,format-string ':format-args (list . ,args)) . ,(mapcar #'(lambda (place) `((,place) (setf ,place value))) places))) ))