X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Flambda-list.lisp;h=1a0a6ebd22e468cc02e86cca7fb90d4cb18fa04a;hb=6b930dd4b781a93a4d64252048b15df58036f331;hp=13aee25ca2b8b64db905c292be4e6db607f6d475;hpb=16e2328e2a830aa275e89999d419a5d1991c9549;p=jscl.git diff --git a/src/lambda-list.lisp b/src/lambda-list.lisp index 13aee25..1a0a6eb 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,8 +15,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with JSCL. If not, see . -;;; lambda-list-keywords -;; '(&optional &rest &key &aux &allow-other-keys &body &optional) +(/debug "loading lambda-list.lisp!") + + +(defvar !lambda-list-keywords + '(&optional &rest &key &aux &allow-other-keys &body &optional)) ;;;; Lambda list parsing @@ -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) @@ -121,56 +126,56 @@ ;; position of the lambda list. (in-section-p () (and (consp lambda-list) - (not (find (first lambda-list) lambda-list-keywords))))) + (not (find (first lambda-list) !lambda-list-keywords))))) ;; &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,19 +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."))))) -(defmacro !destructuring-bind (lambda-list expression &body body) - (multiple-value-bind (d-ll) + +(defun !expand-destructuring-bind (lambda-list expression &rest body) + (multiple-value-bind (ll) (parse-destructuring-lambda-list lambda-list) - (let ((reqvar-count (length (d-lambda-list-reqvars d-ll))) - (optvar-count (length (d-lambda-list-optvars d-ll))) - (bindings '())) - (labels (;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))), + (let ((bindings '())) + (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 @@ -235,79 +251,105 @@ ;; symbol it will be bound to the form. The variable ;; where the form is bound is returned. (compute-pbindings (pattern form) - (etypecase pattern - (null) - ;; Bind the symbol to FORM. - (symbol + (cond + ((null pattern)) + ((symbolp pattern) (push `(,pattern ,form) bindings) - (values pattern)) - ;; Bind FORM to a auxiliar variable and bind - ;; pattern agains it recursively. - (d-lambda-list - (let ((subpart (gensym))) - (push `(,subpart - (progn - ,form)) - bindings) - (compute-bindings pattern subpart) - (values subpart))))) + 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) - (compute-pbindings (d-lambda-list-wholevar d-ll) form) - (let ((count 0)) - ;; Required vars - (dolist (reqvar (d-lambda-list-reqvars d-ll)) - (compute-pbindings reqvar (nth-chain form count)) - (incf count)) - ;; Optional vars - (dolist (optvar (d-lambda-list-optvars d-ll)) - (when (optvar-supplied-p-parameter optvar) - (compute-pbindings (optvar-supplied-p-parameter optvar) - `(not (null ,(nth-chain form count t))))) - (compute-pbindings (optvar-variable optvar) - `(if (null ,(nth-chain form count t)) - ,(optvar-initform optvar) - ,(nth-chain form count))) - (incf count)) - - ;; Rest-variable and keywords - (when (or (d-lambda-list-restvar d-ll) - (d-lambda-list-keyvars d-ll)) + (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 (lambda-list-reqvars ll)) + (compute-pbindings reqvar (nth-chain whole count)) + (incf count)) + ;; Optional vars + (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))))) + (compute-pbindings (optvar-variable optvar) + `(if (null ,(nth-chain whole count t)) + ,(optvar-initform optvar) + ,(nth-chain whole count))) + (incf count)) + + ;; Rest-variable and keywords + ;; 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* ((chain (nth-chain form (+ 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)) - (let ((variable (keyvar-variable keyvar)) - (keyword (keyvar-keyword-name keyvar)) - (supplied (or (keyvar-supplied-p-parameter keyvar) - (gensym)))) - (when supplied - (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest))) - (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)))))) + ;; 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) + (gensym)))) + (when supplied + (compute-pbindings supplied `(keyword-supplied-p ,keyword ,rest))) + (compute-pbindings variable `(if ,supplied + (keyword-lookup ,keyword ,rest) + ,(keyvar-initform keyvar))))))) + ;; Aux variables + (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. - (let ((whole (gensym))) - (compute-bindings d-ll whole) - `(let ((,whole ,expression)) - (let* ,(reverse bindings) - ,@body))))))) + (compute-bindings ll expression) + `(let* ,(reverse bindings) + ,@body))))) + +;;; Because DEFMACRO uses destructuring-bind to parse the arguments of +;;; the macro-function, we can't define DESTRUCTURING-BIND with +;;; defmacro to avoid a circularity. So just define the macro function +;;; explicitly. + +#-jscl +(defmacro !destructuring-bind (lambda-list expression &body body) + (apply #'!expand-destructuring-bind lambda-list expression body)) #+jscl -(defmacro destructuring-bind (lambda-list expression &body body) - `(!destructuring-bind ,lambda-list ,expression ,@body)) +(eval-when-compile + (let ((macroexpander + '#'(lambda (form &optional environment) + (declare (ignore environment)) + (apply #'!expand-destructuring-bind form)))) + (%compile-defmacro '!destructuring-bind macroexpander) + (%compile-defmacro 'destructuring-bind macroexpander)))