Changeset 8768


Ignore:
Timestamp:
03/14/05 17:46:08 (16 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/destructuring-bind.lisp

    r7142 r8768  
    11;;; destructuring-bind.lisp
    22;;;
    3 ;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: destructuring-bind.lisp,v 1.13 2004-06-17 10:50:22 piso Exp $
     3;;; Copyright (C) 2003-2005 Peter Graves
     4;;; $Id: destructuring-bind.lisp,v 1.14 2005-03-14 17:46:08 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1818;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    1919
    20 ;;;; From CMUCL, via GCL.
    21 
    22 (in-package "SYSTEM")
     20;;;; Adapted from CMUCL/SBCL.
     21
     22(in-package #:system)
    2323
    2424(defun parse-body (body &optional (doc-string-allowed t))
     
    4242         (return (values tail (nreverse decls) doc))))))))
    4343
    44 (defvar *arg-tests* ())
    45 
    46 (defvar *system-lets* nil)
    47 
    48 (defvar *user-lets* ())
    49 
    50 (defvar *ignorable-vars*)
     44;; We don't have DEFVAR yet...
     45(eval-when (:compile-toplevel :load-toplevel :execute)
     46  (%defvar '*arg-tests* ())
     47  (%defvar '*system-lets* ())
     48  (%defvar '*user-lets* ())
     49  (%defvar '*ignorable-vars* ())
     50  (%defvar '*env-var* nil))
    5151
    5252(defun do-arg-count-error (error-kind name arg lambda-list minimum maximum)
     
    5555         :format-arguments (list name)))
    5656
    57 (defun parse-defmacro (lambda-list arg-list-name code name error-kind
    58            &key (anonymousp nil)
     57;;; Return, as multiple values, a body, possibly a DECLARE form to put
     58;;; where this code is inserted, the documentation for the parsed
     59;;; body, and bounds on the number of arguments.
     60(defun parse-defmacro (lambda-list arg-list-name body name context
     61           &key
     62           (anonymousp nil)
    5963           (doc-string-allowed t)
    6064           ((:environment env-arg-name))
    61            (error-fun 'error))
    62   (multiple-value-bind (body declarations documentation)
    63            (parse-body code doc-string-allowed)
    64     (let* ((*arg-tests* ())
    65      (*user-lets* ())
    66      (*system-lets* ())
    67      (*ignorable-vars* ()))
    68       (multiple-value-bind
    69     (env-arg-used minimum maximum)
     65           (error-fun 'error)
     66                                   (wrap-block t))
     67  (multiple-value-bind (forms declarations documentation)
     68      (parse-body body doc-string-allowed)
     69    (let ((*arg-tests* ())
     70    (*user-lets* ())
     71    (*system-lets* ())
     72    (*ignorable-vars* ())
     73          (*env-var* nil))
     74      (multiple-value-bind (env-arg-used minimum maximum)
    7075    (parse-defmacro-lambda-list lambda-list arg-list-name name
    71               error-kind error-fun (not anonymousp)
    72               nil env-arg-name)
    73   (values
    74    `(let* ,(nreverse *system-lets*)
    75      ,@(when *ignorable-vars*
    76          `((declare (ignorable ,@*ignorable-vars*))))
    77       ,@*arg-tests*
    78       (let* ,(nreverse *user-lets*)
    79         ,@declarations
    80         ,@body))
    81    `(,@(when (and env-arg-name (not env-arg-used))
    82          `((declare (ignore ,env-arg-name)))))
    83    documentation
    84    minimum
    85    maximum)))))
     76              context error-fun (not anonymousp)
     77              nil)
     78  (values `(let* (,@(when env-arg-used
     79                            `((,*env-var* ,env-arg-name)))
     80                        ,@(nreverse *system-lets*))
     81       ,@(when *ignorable-vars*
     82           `((declare (ignorable ,@*ignorable-vars*))))
     83       ,@*arg-tests*
     84       (let* ,(nreverse *user-lets*)
     85         ,@declarations
     86                     ,@(if wrap-block
     87                           `((block ,name ,@forms))
     88                           forms)))
     89    `(,@(when (and env-arg-name (not env-arg-used))
     90                      `((declare (ignore ,env-arg-name)))))
     91    documentation
     92    minimum
     93    maximum)))))
    8694
    8795(defun defmacro-error (problem name)
     
    102110    ((null (cdr remaining))
    103111     (return (values :odd-length key-list)))
    104     #+nil ;; Not ANSI compliant to disallow duplicate keywords.
    105     ((memql (car remaining) already-processed)
    106      (return (values :duplicate (car remaining))))
    107112    ((or (eq (car remaining) :allow-other-keys)
    108113         (memql (car remaining) valid-keys))
    109114     (push (car remaining) already-processed))
    110115    (t
    111      (setf unknown-keyword (car remaining))))))
     116     (setq unknown-keyword (car remaining))))))
    112117
    113118(defun lookup-keyword (keyword key-list)
     
    123128      (return t))))
    124129
    125 
    126130(defun parse-defmacro-lambda-list
    127131       (lambda-list arg-list-name name error-kind error-fun
    128         &optional top-level env-illegal env-arg-name)
     132        &optional top-level env-illegal ;;env-arg-name
     133                    )
    129134  (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
    130135  (now-processing :required)
     
    146151         ;; Varlist is dotted, treat as &rest arg and exit.
    147152         (t (push-let-binding rest-of-args path nil)
    148       (setf restp t))))
     153      (setq restp t))))
    149154      (let ((var (car rest-of-args)))
    150155  (cond ((eq var '&whole)
    151156         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
    152           (setf rest-of-args (cdr rest-of-args))
     157          (setq rest-of-args (cdr rest-of-args))
    153158          (push-let-binding (car rest-of-args) arg-list-name nil))
    154159         ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
     
    165170        ((eq var '&environment)
    166171         (cond (env-illegal
    167           (error "&ENVIRONMENT not valid with ~S" error-kind))
     172          (error "&ENVIRONMENT is not valid with ~S." error-kind))
    168173         ((not top-level)
    169           (error "&ENVIRONMENT only valid at top level of lambda list")))
     174          (error "&ENVIRONMENT is only valid at top level of lambda list.")))
    170175         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
    171           (setf rest-of-args (cdr rest-of-args))
    172           (push-let-binding (car rest-of-args) env-arg-name nil)
    173           (setf env-arg-used t))
     176          (setq rest-of-args (cdr rest-of-args))
     177                      (setq *env-var* (car rest-of-args)
     178                            env-arg-used t))
    174179         (t
    175180          (defmacro-error "&ENVIRONMENT" error-kind name))))
    176181        ((or (eq var '&rest) (eq var '&body))
    177182         (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
    178           (setf rest-of-args (cdr rest-of-args))
    179           (setf restp t)
     183          (setq rest-of-args (cdr rest-of-args))
     184          (setq restp t)
    180185          (push-let-binding (car rest-of-args) path nil))
    181186         ((and (cdr rest-of-args) (consp (cadr rest-of-args)))
    182187          (pop rest-of-args)
    183           (setf restp t)
     188          (setq restp t)
    184189          (let* ((destructuring-lambda-list (car rest-of-args))
    185190           (sub (gensym "REST-SUBLIST")))
     
    191196          (defmacro-error (symbol-name var) error-kind name))))
    192197        ((eq var '&optional)
    193          (setf now-processing :optionals))
     198         (setq now-processing :optionals))
    194199        ((eq var '&key)
    195          (setf now-processing :keywords)
    196          (setf rest-name (gensym "KEYWORDS-"))
     200         (setq now-processing :keywords)
     201         (setq rest-name (gensym "KEYWORDS-"))
    197202         (push rest-name *ignorable-vars*)
    198          (setf restp t)
     203         (setq restp t)
    199204         (push-let-binding rest-name path t))
    200205        ((eq var '&allow-other-keys)
    201          (setf allow-other-keys-p t))
     206         (setq allow-other-keys-p t))
    202207        ((eq var '&aux)
    203          (setf now-processing :auxs))
     208         (setq now-processing :auxs))
    204209        ((listp var)
    205210         (case now-processing
     
    210215        (parse-defmacro-lambda-list var sub-list-name name
    211216            error-kind error-fun))
    212       (setf path `(cdr ,path))
     217      (setq path `(cdr ,path))
    213218      (incf minimum)
    214219      (incf maximum))
     
    220225           `(not (null ,path)) `(car ,path)
    221226           name error-kind error-fun)
    222       (setf path `(cdr ,path))
     227      (setq path `(cdr ,path))
    223228      (incf maximum))
    224229     (:keywords
     
    245250      (incf maximum)
    246251      (push-let-binding var `(car ,path) nil)
    247       (setf path `(cdr ,path)))
     252      (setq path `(cdr ,path)))
    248253     (:optionals
    249254      (incf maximum)
    250255      (push-let-binding var `(car ,path) nil `(not (null ,path)))
    251       (setf path `(cdr ,path)))
     256      (setq path `(cdr ,path)))
    252257     (:keywords
    253258      (let ((key (make-keyword var)))
     
    325330          name error-kind error-fun)
    326331  (unless supplied-var
    327     (setf supplied-var (gensym "SUPPLIEDP-")))
     332    (setq supplied-var (gensym "SUPPLIEDP-")))
    328333  (push-let-binding supplied-var condition t)
    329334  (cond ((consp value-var)
     
    341346(defmacro destructuring-bind (lambda-list arg-list &rest body)
    342347  (let* ((arg-list-name (gensym "ARG-LIST-")))
    343     (multiple-value-bind
    344   (body local-decls)
     348    (multiple-value-bind (body local-decls)
    345349  (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
    346350      :anonymousp t :doc-string-allowed nil)
     
    348352   ,@local-decls
    349353   ,body))))
     354
     355;; Redefine DEFMACRO to use PARSE-DEFMACRO.
     356(defmacro defmacro (name lambda-list &rest body)
     357  (let* ((form (gensym "WHOLE-"))
     358         (env (gensym "ENVIRONMENT-"))
     359         (body (parse-defmacro lambda-list form body name 'defmacro
     360                               :environment env))
     361         (expander `(lambda (,form ,env) (block ,name ,body))))
     362    `(progn
     363       (let ((macro (make-macro ',name ,expander)))
     364         (if (special-operator-p ',name)
     365             (%put ',name 'macroexpand-macro macro)
     366             (fset ',name macro))
     367         (%set-arglist macro ',lambda-list)
     368         ',name))))
     369
     370;; Redefine SYS:MAKE-EXPANDER-FOR-MACROLET to use PARSE-DEFMACRO.
     371(defun make-expander-for-macrolet (definition)
     372  (let* ((name (car definition))
     373         (lambda-list (cadr definition))
     374         (form (gensym "WHOLE-"))
     375         (env (gensym "ENVIRONMENT-"))
     376         (body (parse-defmacro lambda-list form (cddr definition) name 'defmacro
     377                               :environment env)))
     378    `(lambda (,form ,env) (block ,name ,body))))
Note: See TracChangeset for help on using the changeset viewer.