Ignore:
Timestamp:
02/01/04 16:46:34 (18 years ago)
Author:
piso
Message:

PARSE-BODY

File:
1 edited

Legend:

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

    r5122 r5640  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: destructuring-bind.lisp,v 1.9 2003-12-13 21:25:06 piso Exp $
     4;;; $Id: destructuring-bind.lisp,v 1.10 2004-02-01 16:46:34 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2222(in-package "SYSTEM")
    2323
     24(defun parse-body (body &optional (doc-string-allowed t))
     25  (let ((decls ())
     26  (doc nil))
     27    (do ((tail body (cdr tail)))
     28  ((endp tail)
     29   (values tail (nreverse decls) doc))
     30      (let ((form (car tail)))
     31  (cond ((and (stringp form) (cdr tail))
     32         (if doc-string-allowed
     33       (setq doc form
     34       ;; Only one doc string is allowed.
     35       doc-string-allowed nil)
     36       (return (values tail (nreverse decls) doc))))
     37        ((not (and (consp form) (symbolp (car form))))
     38         (return (values tail (nreverse decls) doc)))
     39        ((eq (car form) 'declare)
     40         (push form decls))
     41        (t
     42         (return (values tail (nreverse decls) doc))))))))
     43
    2444(defvar *arg-tests* ())
    2545
     
    3151
    3252(defun do-arg-count-error (error-kind name arg lambda-list minimum maximum)
    33   (error 'program-error "wrong number of arguments for ~S" name))
     53  (error 'program-error
     54         :format-control "Wrong number of arguments for ~S."
     55         :format-arguments (list name)))
    3456
    3557(defun parse-defmacro (lambda-list arg-list-name code name error-kind
     
    3961           (error-fun 'error))
    4062  (multiple-value-bind (body declarations documentation)
    41            (parse-body code nil doc-string-allowed)
     63           (parse-body code doc-string-allowed)
    4264    (let* ((*arg-tests* ())
    4365     (*user-lets* ())
     
    152174          (setf restp t)
    153175          (push-let-binding (car rest-of-args) path nil))
    154          ;;
    155          ;; This branch implements an incompatible extension to
    156          ;; Common Lisp.  In place of a symbol following &body,
    157          ;; there may be a list of up to three elements which will
    158          ;; be bound to the body, declarations, and doc-string of
    159          ;; the body.
    160          ((and (cdr rest-of-args)
    161          (consp (cadr rest-of-args))
    162          (symbolp (caadr rest-of-args)))
    163           (setf rest-of-args (cdr rest-of-args))
    164           (setf restp t)
    165           (let ((body-name (caar rest-of-args))
    166           (declarations-name (cadar rest-of-args))
    167           (doc-string-name (caddar rest-of-args))
    168           (parse-body-values (gensym)))
    169       (push-let-binding
    170        parse-body-values
    171        `(multiple-value-list
    172          (parse-body ,path ,env-arg-name
    173                ,(not (null doc-string-name))))
    174        t)
    175       (setf env-arg-used t)
    176       (when body-name
    177         (push-let-binding body-name
    178               `(car ,parse-body-values) nil))
    179       (when declarations-name
    180         (push-let-binding declarations-name
    181               `(cadr ,parse-body-values) nil))
    182       (when doc-string-name
    183         (push-let-binding doc-string-name
    184               `(caddr ,parse-body-values) nil))))
    185176         (t
    186177          (defmacro-error (symbol-name var) error-kind name))))
     
    334325   (error "Illegal optional variable name: ~S" value-var))))
    335326
    336 (defun parse-body (body environment &optional (doc-string-allowed t))
    337   (let ((decls ())
    338   (doc nil))
    339     (do ((tail body (cdr tail)))
    340   ((endp tail)
    341    (values tail (nreverse decls) doc))
    342       (let ((form (car tail)))
    343   (cond ((and (stringp form) (cdr tail))
    344          (if doc-string-allowed
    345        (setq doc form
    346        ;; Only one doc string is allowed.
    347        doc-string-allowed nil)
    348        (return (values tail (nreverse decls) doc))))
    349         ((not (and (consp form) (symbolp (car form))))
    350          (return (values tail (nreverse decls) doc)))
    351         ((eq (car form) 'declare)
    352          (push form decls))
    353         (t
    354          (return (values tail (nreverse decls) doc))))))))
    355 
    356327(defmacro destructuring-bind (lambda-list arg-list &rest body)
    357328  (let* ((arg-list-name (gensym "ARG-LIST-")))
Note: See TracChangeset for help on using the changeset viewer.