-(in-package parenscript)
-;;;; This software was taken from the SBCL system. there are very few
-;;;; changes, and one SBCL-specific thing left (sb-c::collect
+(in-package :parenscript)
+
+;;;; This software was taken from the SBCL system, mostly verbatim.
;;; if you have found this on google, THIS IS NOT AN SBCL SOURCE FILE
;;; 12. the &MORE count var;
;;; 13. true if any lambda list keyword is present (only for
;;; PARSE-LAMBDA-LIST-LIKE-THING).
+;;; 14. the &KEY-OBJECT var
;;;
;;; The top level lambda list syntax is checked for validity, but the
-;;; arg specifiers are just passed through untouched. If something is
-;;; wrong, we use COMPILER-ERROR, aborting compilation to the last
-;;; recovery point.
+;;; arg specifiers are just passed through untouched.
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun collect-list-expander (n-value n-tail forms)
(let ((n-res (gensym)))
`(progn
- ,@(mapcar (lambda (form)
- `(let ((,n-res (cons ,form nil)))
- (cond (,n-tail
- (setf (cdr ,n-tail) ,n-res)
- (setq ,n-tail ,n-res))
- (t
- (setq ,n-tail ,n-res ,n-value ,n-res)))))
- forms)
- ,n-value))))
+ ,@(mapcar (lambda (form)
+ `(let ((,n-res (cons ,form nil)))
+ (cond (,n-tail
+ (setf (cdr ,n-tail) ,n-res)
+ (setq ,n-tail ,n-res))
+ (t
+ (setq ,n-tail ,n-res ,n-value ,n-res)))))
+ forms)
+ ,n-value))))
(defmacro collect (collections &body body)
(let ((macros ())
- (binds ()))
+ (binds ()))
(dolist (spec collections)
- ; (unless (proper-list-of-length-p spec 1 3)
- ; (error "malformed collection specifier: ~S" spec))
+ ;;(unless (proper-list-of-length-p spec 1 3)
+ ;; (error "malformed collection specifier: ~S" spec))
(let* ((name (first spec))
- (default (second spec))
- (kind (or (third spec) 'collect))
- (n-value (gensym (concatenate 'string
- (symbol-name name)
- "-N-VALUE-"))))
- (push `(,n-value ,default) binds)
- (if (eq kind 'collect)
- (let ((n-tail (gensym (concatenate 'string
- (symbol-name name)
- "-N-TAIL-"))))
- (if default
- (push `(,n-tail (last ,n-value)) binds)
- (push n-tail binds))
- (push `(,name (&rest args)
- (collect-list-expander ',n-value ',n-tail args))
- macros))
- (push `(,name (&rest args)
- (collect-normal-expander ',n-value ',kind args))
- macros))))
+ (default (second spec))
+ (kind (or (third spec) 'collect))
+ (n-value (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-VALUE-"))))
+ (push `(,n-value ,default) binds)
+ (if (eq kind 'collect)
+ (let ((n-tail (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-TAIL-"))))
+ (if default
+ (push `(,n-tail (last ,n-value)) binds)
+ (push n-tail binds))
+ (push `(,name (&rest args)
+ (collect-list-expander ',n-value ',n-tail args))
+ macros))
+ (push `(,name (&rest args)
+ (collect-normal-expander ',n-value ',kind args))
+ macros))))
`(macrolet ,macros (let* ,(nreverse binds) ,@body))))
(defparameter *lambda-list-keywords*
- '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
+ '(&allow-other-keys &aux &body &environment &key &key-object &optional &rest &whole))
(defun style-warn (&rest args) (apply #'format t args))
(keyp nil)
(auxp nil)
(allowp nil)
+ (key-object nil)
(state :required))
(declare (type (member :allow-other-keys :aux
:key
:more-context :more-count
:optional
:post-more :post-rest
- :required :rest)
+ :required :rest
+ :key-object :post-key)
state))
(dolist (arg list)
(if (member arg *lambda-list-keywords*)
(&optional
(unless (eq state :required)
(format t "misplaced &OPTIONAL in lambda list: ~S"
- list))
+ list))
(setq state :optional))
(&rest
(unless (member state '(:required :optional))
(unless (member state
'(:required :optional :post-rest :post-more))
(format t "misplaced &KEY in lambda list: ~S" list))
- #-sb-xc-host
(when (optional)
- (format t
- "&OPTIONAL and &KEY found in the same lambda list: ~S" list))
+ (format t "&OPTIONAL and &KEY found in the same lambda list: ~S" list))
(setq keyp t
state :key))
(&allow-other-keys
- (unless (eq state ':key)
+ (unless (member state '(:key :post-key))
(format t "misplaced &ALLOW-OTHER-KEYS in ~
lambda list: ~S"
list))
(format t "multiple &AUX in lambda list: ~S" list))
(setq auxp t
state :aux))
+ (&key-object
+ (unless (member state '(:key :allow-other-keys))
+ (format t "&key-object misplaced in lmabda list: ~S. Belongs after &key" list))
+ (setf state :key-object))
(t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg)))
(progn
(when (symbolp arg)
(setq more-count arg
state :post-more))
(:key (keys arg))
+ (:key-object (setf key-object arg) (setf state :post-key))
(:aux (aux arg))
(t
(format t "found garbage in lambda list when expecting ~
(values (required) (optional) restp rest keyp (keys) allowp auxp (aux)
morep more-context more-count
- (not (eq state :required))))))
+ (not (eq state :required))
+ key-object))))
;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument
;;; really *is* a lambda list, not just a "lambda-list-like thing", so
;;; even if they could conceivably be legal in not-quite-a-lambda-list
;;; weirdosities
(defun parse-lambda-list (lambda-list)
-
;; Classify parameters without checking their validity individually.
(multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
- morep more-context more-count)
+ morep more-context more-count beyond-requireds? key-object)
(parse-lambda-list-like-thing lambda-list)
-
+ (declare (ignore beyond-requireds?))
;; Check validity of parameters.
(flet ((need-symbol (x why)
- (unless (or (symbolp x) t)
+ (unless (symbolp x)
(format t "~A is not a symbol: ~S" why x))))
(dolist (i required)
(need-symbol i "Required argument"))
(t
(format t "&KEY parameter is not a symbol or cons: ~S"
i))))))
-
;; Voila.
(values required optional restp rest keyp keys allowp auxp aux
- morep more-context more-count)))
+ morep more-context more-count key-object)))
HCoop / clinton / parenscript.git / blobdiff