X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Flambda-list.lisp;h=799e72770f9255ba029cc2a1a10dfd20fe63d96c;hb=e8992591d4100811ac125bf97c5b153ddecb0250;hp=1048e85cf0016cec419ed482aa00fa6a954cdd0f;hpb=6e92a7fcdc8d2a0663a7a8328f56672f5e32efcf;p=jscl.git diff --git a/src/lambda-list.lisp b/src/lambda-list.lisp index 1048e85..799e727 100644 --- a/src/lambda-list.lisp +++ b/src/lambda-list.lisp @@ -1,5 +1,7 @@ ;;; lambda-list.lisp --- Lambda list parsing and destructuring +;;; Copyright (C) 2013 David Vazquez + ;; JSCL is free software: you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation, either version 3 of the @@ -13,6 +15,9 @@ ;; You should have received a copy of the GNU General Public License ;; along with JSCL. If not, see . +(/debug "loading lambda-list.lisp!") + + (defvar !lambda-list-keywords '(&optional &rest &key &aux &allow-other-keys &body &optional)) @@ -27,7 +32,7 @@ (def!struct auxvar variable initform) -(def!struct d-lambda-list +(def!struct lambda-list wholevar reqvars optvars @@ -102,10 +107,10 @@ (defun parse-destructuring-lambda-list (lambda-list) (let (;; Destructured lambda list structure where we accumulate the ;; results of the parsing. - (d-ll (make-d-lambda-list)) + (ll (make-lambda-list)) ;; List of lambda list keywords which we have already seen. (lambda-keywords nil)) - (flet ( ;; Check if we are in the beginning of the section NAME in + (flet (;; Check if we are in the beginning of the section NAME in ;; the lambda list. It checks also if the section is in the ;; proper place and it is new. (lambda-section (name) @@ -126,51 +131,51 @@ ;; &whole var (when (lambda-section '&whole) (let ((wholevar (pop lambda-list))) - (setf (d-lambda-list-wholevar d-ll) (var-or-pattern wholevar)))) + (setf (lambda-list-wholevar ll) (var-or-pattern wholevar)))) ;; required vars (while (in-section-p) (let ((var (pop lambda-list))) - (push (var-or-pattern var) (d-lambda-list-reqvars d-ll)))) - (setf (d-lambda-list-reqvars d-ll) - (reverse (d-lambda-list-reqvars d-ll))) + (push (var-or-pattern var) (lambda-list-reqvars ll)))) + (setf (lambda-list-reqvars ll) + (reverse (lambda-list-reqvars ll))) ;; optional vars (when (lambda-section '&optional) (while (in-section-p) (push (parse-optvar (pop lambda-list)) - (d-lambda-list-optvars d-ll))) - (setf (d-lambda-list-optvars d-ll) - (reverse (d-lambda-list-optvars d-ll)))) + (lambda-list-optvars ll))) + (setf (lambda-list-optvars ll) + (reverse (lambda-list-optvars ll)))) ;; Dotted lambda-list and &rest/&body vars. If the lambda-list ;; is dotted. Convert it the tail to a &rest and finish. (when (and lambda-list (atom lambda-list)) - (push lambda-list (d-lambda-list-restvar d-ll)) + (push lambda-list (lambda-list-restvar ll)) (setq lambda-list nil)) (when (find (car lambda-list) '(&body &rest)) (pop lambda-list) - (setf (d-lambda-list-restvar d-ll) + (setf (lambda-list-restvar ll) (var-or-pattern (pop lambda-list)))) ;; Keyword arguments (when (lambda-section '&key) (while (in-section-p) (push (parse-keyvar (pop lambda-list)) - (d-lambda-list-keyvars d-ll))) - (setf (d-lambda-list-keyvars d-ll) - (reverse (d-lambda-list-keyvars d-ll)))) + (lambda-list-keyvars ll))) + (setf (lambda-list-keyvars ll) + (reverse (lambda-list-keyvars ll)))) (when (lambda-section '&allow-other-keys) - (setf (d-lambda-list-allow-other-keys d-ll) t)) + (setf (lambda-list-allow-other-keys ll) t)) ;; Aux variables (when (lambda-section '&aux) (while (in-section-p) (push (parse-auxvar (pop lambda-list)) - (d-lambda-list-auxvars d-ll))) - (setf (d-lambda-list-auxvars d-ll) - (reverse (d-lambda-list-auxvars d-ll)))) - d-ll))) + (lambda-list-auxvars ll))) + (setf (lambda-list-auxvars ll) + (reverse (lambda-list-auxvars ll)))) + ll))) ;;;; Destructuring @@ -198,6 +203,18 @@ (when (eq key keyword) (return value)) (setq list (cddr list)))) +(defun validate-reqvars (list n) + (unless (listp list) + (error "`~S' is not a list." list)) + (unless (<= n (length list)) + (error "Invalid number of elements in `~S'" list)) + list) + +(defun validate-max-args (list) + (unless (null list) + (error "Too many elements `~S' in the lambda-list" list)) + list) + ;;; Validate a list of keyword arguments. (defun validate-keyvars (list keyword-list &optional allow-other-keys) (let (;; If it is non-NIL, we have to check for unknown keyword @@ -211,17 +228,18 @@ (error "Unknown keyword argument `~S'." key)))) (do* ((tail list (cddr tail)) (key (car tail) (car tail))) - ((null list)) + ((null tail) list) (unless (symbolp key) (error "Keyword argument `~S' is not a symbol." key)) - (unless (consp tail) + (unless (consp (cdr tail)) (error "Odd number of keyword arguments."))))) + (defun !expand-destructuring-bind (lambda-list expression &rest body) - (multiple-value-bind (d-ll) + (multiple-value-bind (ll) (parse-destructuring-lambda-list lambda-list) (let ((bindings '())) - (labels (;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))), + (labels ( ;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))), ;; such that there are N calls to CDR. (nth-chain (x n &optional tail) (if tail @@ -236,22 +254,29 @@ (cond ((null pattern)) ((symbolp pattern) - (push `(,pattern ,form) bindings)) - ((d-lambda-list-p pattern) + (push `(,pattern ,form) bindings) + pattern) + ((lambda-list-p pattern) (compute-bindings pattern form)))) - ;; Compute the bindings for the full D-LAMBDA-LIST d-ll + ;; Compute the bindings for the full LAMBDA-LIST ll ;; against FORM. - (compute-bindings (d-ll form) - (let ((whole (or (d-lambda-list-wholevar d-ll) (gensym)))) - (push `(,whole ,form) bindings) + (compute-bindings (ll form) + (let ((reqvar-count (length (lambda-list-reqvars ll))) + (optvar-count (length (lambda-list-optvars ll))) + (whole (or (lambda-list-wholevar ll) (gensym)))) + ;; Create a binding for the whole expression + ;; FORM. It will match to LL, so we validate the + ;; number of elements on the result of FORM. + (compute-pbindings whole `(validate-reqvars ,form ,reqvar-count)) + (let ((count 0)) ;; Required vars - (dolist (reqvar (d-lambda-list-reqvars d-ll)) + (dolist (reqvar (lambda-list-reqvars ll)) (compute-pbindings reqvar (nth-chain whole count)) (incf count)) ;; Optional vars - (dolist (optvar (d-lambda-list-optvars d-ll)) + (dolist (optvar (lambda-list-optvars ll)) (when (optvar-supplied-p-parameter optvar) (compute-pbindings (optvar-supplied-p-parameter optvar) `(not (null ,(nth-chain whole count t))))) @@ -262,20 +287,33 @@ (incf count)) ;; Rest-variable and keywords - (when (or (d-lambda-list-restvar d-ll) - (d-lambda-list-keyvars d-ll)) - ;; If there is a rest or keyword variable, we - ;; will add a binding for the rest or an - ;; auxiliary variable. The computations in of the - ;; keyword start in this variable, so we avoid - ;; the long tail of nested CAR/CDR operations - ;; each time. - (let* ((reqvar-count (length (d-lambda-list-reqvars d-ll))) - (optvar-count (length (d-lambda-list-optvars d-ll))) - (chain (nth-chain whole (+ reqvar-count optvar-count) t)) - (pattern (or (d-lambda-list-restvar d-ll) (gensym))) - (rest (compute-pbindings pattern chain))) - (dolist (keyvar (d-lambda-list-keyvars d-ll)) + + ;; If there is a rest or keyword variable, we + ;; will add a binding for the rest or an + ;; auxiliary variable. The computations in of the + ;; keyword start in this variable, so we avoid + ;; the long tail of nested CAR/CDR operations + ;; each time. We also include validation of + ;; keywords if there is any. + (let* ((chain (nth-chain whole (+ reqvar-count optvar-count) t)) + (restvar (lambda-list-restvar ll)) + (pattern (or restvar (gensym))) + (keywords (mapcar #'keyvar-keyword-name (lambda-list-keyvars ll))) + (rest + ;; Create a binding for the rest of the + ;; arguments. If there is keywords, then + ;; validate this list. If there is no + ;; keywords and no &rest variable, then + ;; validate that the rest is empty, it is + ;; to say, there is no more arguments + ;; that we expect. + (cond + (keywords (compute-pbindings pattern `(validate-keyvars ,chain ',keywords ,(lambda-list-allow-other-keys ll)))) + (restvar (compute-pbindings pattern chain)) + (t (compute-pbindings pattern `(validate-max-args ,chain)))))) + (when (lambda-list-keyvars ll) + ;; Keywords + (dolist (keyvar (lambda-list-keyvars ll)) (let ((variable (keyvar-variable keyvar)) (keyword (keyvar-keyword-name keyvar)) (supplied (or (keyvar-supplied-p-parameter keyvar) @@ -285,14 +323,15 @@ (compute-pbindings variable `(if ,supplied (keyword-lookup ,keyword ,rest) ,(keyvar-initform keyvar))))))) - ;; Aux variables - (dolist (auxvar (d-lambda-list-auxvars d-ll)) - (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar))))))) + (dolist (auxvar (lambda-list-auxvars ll)) + (compute-pbindings (auxvar-variable auxvar) (auxvar-initform auxvar)))) + + whole))) ;; Macroexpansion. Compute bindings and generate code for them ;; and some necessary checking. - (compute-bindings d-ll expression) + (compute-bindings ll expression) `(let* ,(reverse bindings) ,@body))))) @@ -302,12 +341,12 @@ ;;; defmacro to avoid a circularity. So just define the macro function ;;; explicitly. -#+common-lisp +#-jscl (defmacro !destructuring-bind (lambda-list expression &body body) (apply #'!expand-destructuring-bind lambda-list expression body)) #+jscl -(eval-when-compile +(eval-when (:compile-toplevel) (let ((macroexpander '#'(lambda (form &optional environment) (declare (ignore environment))