Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/scheme/pcscheme/geneva/sources.exe/SOURCES/LISP/DEFMACRO.LSP

Lisp/Scheme | 1990-09-08 | 21.1 KB | 584 lines

;; PC Scheme Common Lisp Compatibility Package
;;
;; (c) Copyright 1990 Carl W. Hoffman.  All rights reserved.
;;
;; This file may be freely copied, distributed, or modified for non-commercial
;; use provided that this copyright notice is not removed.  For further
;; information about other utilities for Common Lisp or Scheme, contact the
;; following address:
;;
;;   Carl W. Hoffman, 363 Marlborough Street, Boston, MA 02115, U.S.A.
;;   Internet: [e-mail]    CompuServe: 76416,3365    Fax: [phone]

;; DEFMACRO, DOTIMES, DOLIST, DEFUN
;; SETQ, SETF, PUSH, POP, INCF, DECF
;; DESCRIBE, ARGLIST

;; To do:
;;   -P variables for DEFUN &OPTIONAL
;;   Define LAMBDA as a macro so that isolated LAMBDA expressions
;;     can have &OPTIONAL, etc.
;;   PSETQ, PSETF
;;   Check for too many arguments to function when &OPTIONAL used but
;;     not &REST.
;;   DESTRUCTURING-BIND, destructuring DEFMACRO
;;   Allow . as synonym for &REST in DEFMACRO and DEFUN
;;   DEFSETF (then use with PICT.SCM XSET/XREF)

(defun-clcp symbol-append (&rest symbols)
  (intern (apply string-append (mapcar string symbols))))

(defun-clcp %%check-defmacro-args (pattern form)
  (let ((optional? nil)
        (rest? nil))
    (do ((patternl pattern)
         (forml form))
        ((or rest?
             (and optional? (null forml))
             (and (null patternl) (null forml))))
      (when (null patternl)
        (error "The form ~S has more arguments than the DEFMACRO pattern ~S."
               form pattern))
      (let ((var (car patternl)))
        (cond ((eq var '&whole)
               (pop patternl)
               (pop patternl))
              ((eq var '&environment)
               (pop patternl)
               (pop patternl))
              ((eq var '&optional)
               (setq optional? t)
               (pop patternl))
              ((member var '(&rest &body))
               (setq rest? t))
              (else
               (when (null forml)
                 (error "The form ~S has fewer arguments than the DEFMACRO ~
                         pattern ~S"
                        form pattern))
               (pop patternl)
               (pop forml)
               ))))))

(defun-clcp %%construct-defmacro-bindings (bvl)
  (let ((optional? nil)
        (rest? nil)
        (result ()))
    (do ((varl bvl (cdr varl)))
        ((null varl))
      (let ((var (car varl)))
        (cond ((eq var '&whole)
               (unless (cdr varl)
                 (error "No tokens follow the &WHOLE keyword."))
               (pop varl)
               (setq var (car varl))
               (push `(,var defmacro-whole-form) result))
              ((eq var '&environment)
               (pop varl)
               (setq var (car varl))
               (push `(,var nil) result))
              (else
               (when rest?
                 (error "The additional tokens ~S follow ~
                         a &REST or &BODY variable."
                        bvl))
               (cond ((eq var '&optional)
                      (when optional?
                        (error "The &OPTIONAL keyword appears twice in ~S."
                               bvl))
                      (setq optional? t)
                      (unless (cdr varl)
                        (error "No tokens follow the &OPTIONAL keyword in ~S."
                               bvl)))
                     ((member var '(&rest &body))
                      (setq rest? t)
                      (pop varl)
                      (unless varl
                        (if (eq var '&rest)
                            (error "No variable follows the &REST keyword.")
                            (error "No variable follows the &BODY keyword.")))
                      (setq var (car varl))
                      (push `(,var defmacro-form) result))
                     (optional?
                      (when (and (listp var) (caddr var))
                        (push `(,(caddr var) (not (null defmacro-form)))
                              result))
                      (push
                        (if (listp var)
                           `(,(car var)
                              (if (null defmacro-form)
                                  ,(cadr var)
                                  (pop defmacro-form)))
                           `(,var (,(if (cdr varl) 'pop 'car) defmacro-form)))
                        result))
                     (else
                      (push `(,var (,(if (cdr varl) 'pop 'car) defmacro-form))
                            result)))))))
    (nreverse result)))

(defvar *include-arglist* t)

;; This implementation captures the variables DEFMACRO-WHOLE-FORM and
;; DEFMACRO-FORM.  PP incorrectly displays this function.  The ". ,body"
;; confuses it.

(defmacro defmacro (name bvl &body body)
  (unless (symbolp name)
    (error "The first argument to DEFMACRO, ~S, was not a symbol." name))
  (unless (listp bvl)
    (error "The second argument to DEFMACRO, ~S, was not a list." bvl))
  ;; PC Scheme barfs if LET or LET* has an empty body.
  (cond ((null body)
         (setq body '(nil)))
        ((stringp (car body))
         (pop body)))
  (let ((function-name (symbol-append 'expand- name)))
    `(prog2
       (define (,function-name defmacro-whole-form)
         (scheme-let ((defmacro-form (cdr defmacro-whole-form)))
           (%%check-defmacro-args ',bvl defmacro-form)
           . ,(let ((bindings (%%construct-defmacro-bindings bvl)))
                (if (null bindings)
                    body
                    `((scheme-let* ,bindings . ,body))))))
       (macro ,name ,function-name)
       ,@ (if *include-arglist*
              `((putprop ',name ',bvl 'arglist))))))

;; SETQ and SETF

;; SET! only allows one variable/value pair.
;; The return value of SETQ must be the last value assigned.
;; The return value of SET! is unspecified.
;; The following implementation of SETQ relies upon the fact that
;; PC Scheme SET! returns the value assigned.

(defun-clcp %%construct-setq (variable value)
  `(set! ,variable ,value))

;; Multi-form syntax definitions such as this one don't work.
;; Only the most recently seen form remains in effect.
;; (syntax (setf a b) (set! a b))
;; (syntax (setf (char s i) c) (string-set! s i c))

(defun-clcp %%construct-setf (place value)
  (cond ((symbolp place)
         `(set! ,place ,value))
        ((not (consp place))
         (error "The first argument to SETF, ~S, was not a symbol or form."
                place))
        (else
         (let ((fcn       (first place))
               (thing     (second place))
               (subscript (third place)))
           (cond
             ((eq fcn 'fluid)
              `(set! ,place ,value))
             ((member fcn '(car first))
              `(rplaca ,thing ,value))
             ((member fcn '(cdr rest))
              `(rplacd ,thing ,value))
             ((member fcn '(cadr second))
              `(rplaca (cdr ,thing) ,value))
             ((eq fcn 'cddr)
              `(rplacd (cdr ,thing) ,value))
             ((member fcn '(char string-ref))
              `(string-set! ,thing ,subscript ,value))
             ((member fcn '(svref vector-ref))
              `(vector-set! ,thing ,subscript ,value))
             ((eq fcn 'aref)
              `(%%setf-aref ,value ,thing ,subscript))
             ((member fcn '(get getprop))
              `(putprop ,thing ,value ,subscript))
             ((eq fcn 'macro-function)
              `(putprop ,thing ,value 'pcs*macro))
             ((eq fcn 'primop-handler)
              `(putprop ,thing ,value 'pcs*primop-handler))
             ;; An accessor defined with DEFINE-STRUCTURE will have
             ;; a PCS*PRIMOP-HANDLER property.  Check this after
             ;; checking for everything else.
             ((get fcn 'pcs*primop-handler)
              `(set! ,place ,value))
             (else
              (error "The first argument to SETF, ~S, was unrecognized."
                     place)))))))

(defun-clcp %%construct-setq-setf (constructor variable value vars-and-vals)
  (if (null vars-and-vals)
      (constructor variable value)
      (let ((result (list `(set! ,variable ,value))))
        (do ((l vars-and-vals))
            ((null l))
          (when (null (cdr l))
            (error "The last variable in a SETQ or SETF form, ~S, ~
                    doesn't have a matching value."
              (car l)))
          (push (constructor (car l) (cadr l)) result)
          (setq l (cddr l)))
        `(begin . ,(nreverse result)))))

(defmacro setq (variable value &rest vars-and-vals)
  (%%construct-setq-setf %%construct-setq variable value vars-and-vals))

(defmacro setf (place value &rest places-and-vals)
  (%%construct-setq-setf %%construct-setf place value places-and-vals))

;; These macros need to "once only" PLACE.  Also, as Steele points out,
;; PUSH and PUSHNEW could be implemented more efficiently.

(defmacro push (item place)
  `(setf ,place (cons ,item ,place)))

(defmacro pushnew (item place)
  `(setf ,place (adjoin ,item ,place)))

(defmacro pop (place)
  `(prog1 (car ,place)
          (setf ,place (cdr ,place))))

(defmacro incf (place &optional amount)
  `(setf ,place
         ,(if amount `(+ ,place ,amount) `(1+ ,place))))

(defmacro decf (place &optional amount)
  `(setf ,place
         ,(if amount `(- ,place ,amount) `(1-, place))))

;; It would be nice to use (VALUES) rather than NIL here, but
;; (EVAL (VALUES)) causes an error.

(defmacro comment (&body ignore) nil)

;; This should be implemented as a function, not a special form.

(defmacro funcall (fcn &rest arguments)
  (cons fcn arguments))

;; This implements RESULTFORM as specified by Common Lisp, even though
;; the feature appears to be useless.

;; This should use destructuring DEFMACRO and N-ary <=.

(defmacro dolist (var-list &body body)
  (unless (and (listp var-list)
               (<= 2 (length var-list))
               (<= (length var-list) 3))
    (error "The first argument to DOLIST was ~S, which does not match ~
            the pattern (VAR LISTFORM) or ~
            the pattern (VAR LISTFORM RESULTFORM)."
           bvl))
  ;; This should use DESTRUCTURING-BIND.
  (let ((var        (car var-list))
        (listform   (cadr var-list))
        (resultform (caddr var-list)))
    (unless (symbolp var)
      (error "The binding variable, ~S, was not a symbol." var))
    `(block nil
       (for-each (lambda (,var) . ,body) ,listform)
       ,(if (null resultform)
            'nil
            `(lambda ((,var nil)) ,resultform)))))

(defun-clcp %%dotimes (thunk count)
  (do ((i 0 (1+ i)))
      ((>= i count))
    (thunk i)))

;; This should use destructuring DEFMACRO and N-ary <=.

(defmacro dotimes (pattern &body body)
  (unless (and (listp pattern)
               (<= 2 (length pattern))
               (<= (length pattern) 3))
    (error "The first argument to DOTIMES was ~S, which does not match ~
            the pattern (VAR COUNTFORM) or ~
            the pattern (VAR COUNTFORM RESULTFORM)."
           bvl))
  (let ((var        (car pattern))
        (countform  (cadr pattern))
        (resultform (caddr pattern)))
    (unless (symbolp var)
      (error "The binding variable, ~S, was not a symbol." var))
    `(block nil
       ,(if (null resultform)
            `(%%dotimes (lambda (,var) . ,body) ,countform)
            `(let ((,var ,countform))
               (%%dotimes (lambda (,var) . ,body) ,var)
               ,resultform)))))

(defun macroexpand (form &optional environment)
  (expand-macro form))

(defun macroexpand-1 (form &optional environment)
  (expand-macro form))

(defun-clcp %%construct-lambda-args (bvl)
  (let ((optional? nil)
        (rest? nil)
        (aux? nil)
        (tail nil)
        (result ()))
    (do ((varl bvl (cdr varl)))
        ((null varl))
      (let ((var (car varl)))
        (cond
          (aux?
            (when (memq var '(&optional &rest &aux))
              (error "The token following &AUX, ~S, is an &keyword, which ~
                      cannot be the name of a local variable."
                     var))
            (cond ((symbolp var))
                  ((consp var)
                   (unless (= (length var) 2)
                     (error "The &AUX declaration, ~S, ~
                             is not a list of length 2."
                            var)))
                  (else
                    (error "The token following the &AUX keyword, ~S, ~
                            was not a symbol or list of length 2."
                           var))))
          ((eq var '&aux)
           (setq aux? t))
          (else
            (when rest?
              (error "Additional tokens follow &REST variable" bvl))
            (cond
              ((eq var '&optional)
               (when optional?
                 (error "&OPTIONAL keyword appears twice" bvl))
               (setq optional? t)
               (unless (cdr varl)
                 (error "No tokens follow &OPTIONAL keyword" bvl))
               (setq tail (gensym)))
              ((eq var '&rest)
               (setq rest? t)
               (pop varl)
               (unless varl
                 (error "No tokens follow &REST keyword" bvl))
               (setq var (car varl))
               (unless (symbolp var)
                 (error "&REST declaration must be a symbol" var))
               (unless tail
                 (setq tail var)))
              ;; The token isn't an & keyword.
              (optional?
                (cond
                  ((symbolp var))
                  ((consp var)
                   (unless (= (length var) 2)
                     (error
                       "The &OPTIONAL declaration, ~S, was not a list ~
                        of length 2."
                       var)))
                  (else
                    (error
                      "&OPTIONAL declaration must be symbols or lists"
                      var))))
              ((symbolp var)
               (push var result))
              (else
                (error "Required variable declarations must be symbols"
                       var)))))))
    (dolist (r result)
      (push r tail))
    tail))

(defun-clcp %%construct-lambda-bindings (bvl tail)
  (let ((optional? nil)
        (rest? nil)
        (aux? nil)
        (result ()))
    (do ((varl bvl (cdr varl)))
        ((null varl))
      (let ((var (car varl)))
        (cond (aux?
               (push (if (symbolp var) `(,var nil) var) result))
              ((eq var '&aux)
               (setq aux? t))
              ((eq var '&optional)
               (setq optional? t))
              ((eq var '&rest)
               (setq rest? t))
              (rest?
               (when optional?
                 (push `(,var ,tail) result)))
              ((not optional?))
              (else
               (let ((next (if (cdr varl) 'pop 'car)))
                 (push
                   (if (symbolp var)
                       `(,var (,next ,tail))
                       `(,(car var) (if ,tail (,next ,tail) ,(cadr var))))
                   result))))))
    (nreverse result)))

(defun-clcp %%construct-lambda (block-name bvl body)
  ;; Discard declarations and the documentation string for now.
  (let ((documentation-seen? nil))
    (loop
      (if (not (consp body))
          (return)
          (let ((form (car body)))
            (cond
              ((eq form 'declare)
               (pop body))
              ((stringp form)
               (when (null (cdr body))
                 (return))
               (when documentation-seen?
                 (error
                   "Only one documentation string allowed per LAMBDA."))
               (pop body)
               (setq documentation-seen? t))
              (else
                (return)))))))
  ;; PC Scheme barfs if LET or LET* has an empty body.
  (when (null body)
    (setq body '(nil)))
  (let* ((args
           (%%construct-lambda-args bvl))
         (bindings
           (%%construct-lambda-bindings bvl
             (if (symbolp args) args (cdr (last args)))))
         (definition nil))
    (when bindings
      (setq body `((let* ,bindings . ,body))))
    ;; The compiler doesn't optimize this out when there is
    ;; no RETURN-FROM so we will have to map over the body
    ;; and do so ourselves.
    (when block-name
      (setq body `((block ,block-name . ,body))))
    (cons args body)))

(defun-clcp %%defun (name bvl body definer block-name arglist?)
  (unless (symbolp name)
    (error "The first argument to DEFUN, ~A, was not a symbol." name))
  (unless (listp bvl)
    (error "The second argument to DEFUN, ~A, was not a list." bvl))
  (let ((definition (%%construct-lambda block-name bvl body)))
    (setq definition
          `(,definer ,(cons name (car definition)) . ,(cdr definition)))
    (if (and arglist? *include-arglist*)
        `(begin (putprop ',name ',bvl 'arglist) ,definition)
        definition)))

(defmacro defun (name bvl &body body)
  (%%defun name bvl body
           'define name t))

(defmacro defun-inline (name bvl &body body)
  (%%defun name bvl body
           'define-integrable nil t))

(defmacro defun-clcp (name bvl &body body)
  (%%defun name bvl body
           'define nil nil))

(defmacro defun-clcp-inline (name bvl &body body)
  (%%defun name bvl body
           'define-integrable nil nil))

;; This should check that (CAR DEF) is a symbol and (CADR DEF) is a list.

(defun-clcp %%make-flet-bindings (let-type definitions body)
  `(,let-type
      ,(map (lambda (def)
              `(,(car def)
                 (lambda . ,(%%construct-lambda nil (cadr def) (cddr def)))))
            definitions)
      . ,body))

(defmacro flet (definitions &body body)
  (%%make-flet-bindings 'let definitions body))

(defmacro labels (definitions &body body)
  (%%make-flet-bindings 'letrec definitions body))

(defconstant lambda-list-keywords
  '(&optional &rest &key &allow-other-keys &aux &body &whole &environment))

(defconstant lambda-parameters-limit 50)

;; This is not standard CL, it should be.  Make it user visible anyway.

(defun arglist (symbol)
  (get symbol 'arglist))

(defun-clcp %%describe-symbol (symbol)
  (let ((arglist (arglist symbol))
        (global-binding
          (assq symbol (environment-bindings user-global-environment)))
        (initial-binding
          (assq symbol (environment-bindings user-initial-environment)))
        (macro-function (macro-function symbol))
        (primop-handler (primop-handler symbol)))
    (format t "~&~S is a symbol." symbol)
    (when global-binding
      (format t "~&  Global binding:   ~S" (cdr global-binding)))
    (when initial-binding
      (format t "~&  Initial binding:  ~S" (cdr initial-binding)))
    (when arglist
      (format t "~&  Arglist:          ~S" arglist))
    (when macro-function
      (format t "~&  Macro definition: ~S" macro-function))
    (when primop-handler
      (format t "~&  Primop handler:   ~S" primop-handler))
    (do ((l (symbol-plist symbol) (cddr l))
         (herald? nil))
        ((null l))
      (let ((property (first l)))
        (unless (memq property '(arglist pcs*macro pcs*primop-handler))
          (unless herald?
            (format t "~&  Other properties:")
            (setq herald? t))
          (format t "~&    ~S -> ~S" property (second l)))))))

(defun-clcp %%describe-structure (structure class)
  (let ((slots (get class 'defstruct-slots))
        (structure-length (vector-length structure)))
    (format t "~S is an object of type ~A with the following slots:~%"
            structure class)
    (do ((i 1 (1+ i))
         (l slots (cdr l)))
        (nil)
      (when (= i structure-length)
        (unless (null l)
          (error "Structure template has more slots than instance"))
        (return nil))
      (when (null l)
        (error "Structure instance has more slots than template"))
      (let* ((slot (car l))
             (slot-length (string-length (symbol->string slot))))
        (format t "  ~A:" slot)
        (dotimes (i (max 1 (- 25 slot-length)))
          (write-char #\space)))
      (format t "~S~%" (vector-ref structure i)))))

(defun-clcp %%describe-list (list)
  (format t "~&~S is a list." list))

(defun-clcp %%describe-vector (vector)
  (format t "~&~S is a vector of length ~D." vector (vector-length vector)))

(defun-clcp %%describe-environment (environment)
  (format t "~&~S is an environment with ~D bindings."
            environment (length (environment-bindings environment))))

(defun-clcp describe (thing)
  (let ((class (%%structurep thing)))
    (cond
      (class
       (%%describe-structure thing class))
      ((symbolp thing)
       (%%describe-symbol thing))
      ((listp thing)
       (%%describe-list thing))
      ((vectorp thing)
       (%%describe-vector thing))
      ((environment? thing)
       (%%describe-environment thing))
      (else
        (display "Cannot describe ")
        (write thing :escape t))))
  (values))