diff options
author | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2013-07-19 13:54:00 +0200 |
---|---|---|
committer | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2013-07-19 13:54:09 +0200 |
commit | 13a6877159b2ea1a4c28c9879850c4e7ef6b66c2 (patch) | |
tree | b56da5f3451f36cc8e415e267a78dacf106deff9 | |
parent | eb25925cf42e2bb7631625c6050b1d25fdbba2fa (diff) |
Take a first stab at supporting specials in lambda-lists.
-rw-r--r-- | sb-eval2.lisp | 256 |
1 files changed, 155 insertions, 101 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index 9ce7378..9f15ba7 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -354,7 +354,7 @@ (apply (the (or symbol function) (funcall (the eval-closure f) env)) (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))) -(declaim (ftype (function (list context) eval-closure) prepare-progn)) +(declaim (ftype (function (list context) (values eval-closure &rest nil)) prepare-progn)) (defun prepare-progn (forms context) (let ((body* (mapcar (lambda (form) (prepare-form form context)) forms))) (if (null body*) @@ -418,11 +418,16 @@ ,body-form) context)))) +(defmacro incff (x &optional (num 1)) + (let ((old-x (gensym))) + `(let ((,old-x ,x)) + (incf ,x ,num) + ,old-x))) + (declaim (ftype (function * eval-closure) prepare-lambda)) (defun prepare-lambda (lambda-form context) (destructuring-bind (lambda-list &rest exprs) lambda-form (with-parsed-body (body specials) exprs - ;; FIXME: SPECIAL declarations! (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) (sb-int:parse-lambda-list lambda-list) @@ -449,19 +454,29 @@ (maybe-closes-over-p context `(progn ,@body) argvars) (some (lambda (x) (maybe-closes-over-p context x argvars)) default-values))) - (new-context (context-add-env-lexicals context required)) + (new-context (make-context context)) + (varspecs (list)) (default-values* - (loop for default-value in default-values - for binding in (append optional keys aux) - for vars = (lambda-binding-vars binding) - collect (prepare-form default-value new-context) - do (dolist (var vars) - (context-add-env-lexical! new-context var)) - finally (when restp - (context-add-env-lexical! new-context rest)))) + (flet ((register-var (var) + (if (or (member var specials :test #'eq) + (globally-special-p var)) + (progn + (context-add-special! new-context var) + (push (cons :special var) varspecs)) + (progn + (context-add-env-lexical! new-context var) + (push :lexical varspecs))))) + (mapc #'register-var required) + (loop for default-value in default-values + for binding in (append optional keys aux) + for vars = (lambda-binding-vars binding) + collect (prepare-form default-value new-context) + do (mapc #'register-var vars) + finally (when restp (register-var rest))))) (body* (prepare-progn body new-context)) (unbound (gensym))) - (macrolet ((handle-arguments (args env) + (setq varspecs (nreverse varspecs)) + (macrolet ((handle-arguments (args env body*) ;; All this ELT and LENGTH stuff is not as ;; inefficient as it looks. SBCL transforms ;; &rest into &more here. @@ -473,105 +488,144 @@ below (length ,args) collect (elt ,args i) do (incf restnum)))) + (keys-checked-p nil) (my-default-values* default-values*) - (my-keywords keywords)) - (declare (fixnum restnum)) - (prog ((argi 0) - (vari 0)) - (declare (type fixnum argi vari)) - positional - (when (>= argi (length ,args)) - (go missing-optionals)) - (when (>= argi (the fixnum (+ required-num optional-num))) - (go keys)) - (setf (environment-value ,env 0 vari) (elt ,args argi)) - (when (>= argi required-num) - (pop my-default-values*) - (incf vari) - (setf (environment-value ,env 0 vari) t)) - (incf vari) - (incf argi) - (go positional) - missing-optionals - (unless (>= argi required-num) - (error 'sb-int:simple-program-error - :format-arguments "invalid number of arguments: ~D" (length args))) - (when (>= vari (the fixnum (+ required-num (the fixnum (* 2 optional-num))))) - (go keys)) - (let ((val* (pop my-default-values*))) - (setf (environment-value ,env 0 vari) - (funcall (the eval-closure val*) ,env) - (environment-value ,env 0 (1+ vari)) - nil)) - (incf vari 2) - (go missing-optionals) - keys - (unless keyp - (unless (or restp (= argi (length args))) - (error 'sb-int:simple-program-error - :format-arguments "invalid number of arguments: ~D" (length args))) - (go aux)) - (unless (evenp restnum) - (error 'sb-int:simple-program-error - :format-arguments "odd number of keyword arguments: ~D" rest)) - (when (>= vari - (the fixnum - (+ required-num (* 2 (+ optional-num key-num))))) - ;; fixme: check &allow-other-keys and :allow-other-keys - (unless (or allowp - (getf rest :allow-other-keys nil)) - (loop for (k v) on rest by #'cddr - unless (member k - (cons :allow-other-keys keywords) - :test #'eq) - do (error 'sb-int:simple-program-error - :format-control "unknown &KEY argument: ~A" - :format-arguments (list k)))) - (go aux)) - (let* ((key (the keyword (pop my-keywords))) - (val* (pop my-default-values*)) - (x (getf rest key unbound))) - (if (eq unbound x) - (setf (environment-value ,env 0 vari) - (funcall (the eval-closure val*) ,env) - (environment-value ,env 0 (1+ vari)) - nil) - (setf (environment-value ,env 0 vari) - x - (environment-value ,env 0 (1+ vari)) - t))) - (incf vari 2) - (go keys) - aux - (when (>= vari - (the fixnum - (+ required-num - (the fixnum (* 2 (+ optional-num key-num))) - aux-num))) - (go rest)) - (let ((val* (pop my-default-values*))) - (setf (environment-value ,env 0 vari) - (funcall (the eval-closure val*) ,env))) - (incf vari) - (go aux) - rest - (assert (null my-default-values*)) - (when restp - (setf (environment-value ,env 0 (1- varnum)) - rest)))))) + (my-keywords keywords) + (my-varspecs varspecs) + (argi 0) + (vari 0) + (i 0)) + (declare (fixnum restnum argi vari i)) + (print varspecs) + (print my-default-values*) + (labels + ((iter () + (print "ITER") + (flet ((push-args (&rest values) + ;; Push VALUES onto the + ;; environment. + (format t "~&PUSH-ARG ~D" vari) + (let ((dynvals (list)) + (dynvars (list))) + (dolist (value values) + (incf i) + (let ((varspec (pop my-varspecs))) + (format t "~&VARSPEC = ~S" varspec) + (if (eq varspec :lexical) + (progn + (setf + (environment-value ,env 0 vari) + value) + (incf vari)) + (progn + (assert (eq :special (car varspec)) + (varspec)) + (push (cdr varspec) dynvars) + (push value dynvals))))) + (when dynvals + (progv + dynvars + dynvals + (return-from iter (iter))))))) + (declare (inline push-args)) + (tagbody + positional + (print "; positional") + (when (>= argi (length ,args)) + (go missing-optionals)) + (when (>= argi (the fixnum (+ required-num optional-num))) + (go keys)) + (if (>= argi required-num) + (progn + (print "POP DEFAULT") + (pop my-default-values*) + (push-args (elt ,args (incff argi)) t)) + (push-args (elt ,args (incff argi)))) + (go positional) + missing-optionals + (print "; missing-optionals") + (unless (>= argi required-num) + (error 'sb-int:simple-program-error + :format-control "invalid number of arguments: ~D" + :format-arguments (list (length args)))) + (when (>= i (the fixnum (+ required-num + optional-num))) + (go keys)) + (let ((val* (pop my-default-values*))) + (push-args (funcall (the eval-closure val*) ,env) nil)) + (go missing-optionals) + keys + (print "; missing-optionals") + (unless keyp + (unless (or restp (= argi (length args))) + (error 'sb-int:simple-program-error + :format-control "invalid number of arguments: ~D" + :format-arguments (list (length args)))) + (go aux)) + (unless (evenp restnum) + (error 'sb-int:simple-program-error + :format-control "odd number of keyword arguments: ~D" + :format-arguments (list rest))) + (when (>= i + (the fixnum + (+ required-num + (the fixnum + (+ optional-num + key-num))))) + (unless (or keys-checked-p + allowp + (getf rest :allow-other-keys nil)) + (loop for (k v) on rest by #'cddr + unless (member k + (cons :allow-other-keys keywords) + :test #'eq) + do (error 'sb-int:simple-program-error + :format-control "unknown &KEY argument: ~A" + :format-arguments (list k))) + (setq keys-checked-p t)) + (go aux)) + (let* ((key (the keyword (pop my-keywords))) + (val* (pop my-default-values*)) + (x (getf rest key unbound))) + (if (eq unbound x) + (progn + (push-args (the eval-closure val*) nil)) + (progn + (push-args x t)))) + (go keys) + aux + (when (>= i + (the fixnum + (+ required-num + (the fixnum + (+ optional-num + key-num)) + aux-num))) + (go rest)) + (let ((val* (pop my-default-values*))) + (push-args (funcall (the eval-closure val*) ,env))) + (go aux) + rest + (assert (null my-default-values*)) + (when restp + (push-args rest)) + final-call + (return-from iter + (funcall ,body* ,env)))))) + (iter))))) (if envp (lambda (env) (lambda (&rest args) (declare (dynamic-extent args)) + ;;XXX VARNUM is too big--- need only lexicals (let ((new-env (make-environment env varnum))) - (handle-arguments args new-env) - (funcall body* new-env)))) + (handle-arguments args new-env body*)))) (lambda (env) (lambda (&rest args) (declare (dynamic-extent args)) + ;;XXX VARNUM is too big--- need only lexicals (with-dynamic-extent-environment (new-env env varnum) - (handle-arguments args new-env) - (funcall body* new-env))))))))))) + (handle-arguments args new-env body*))))))))))) (defun context->native-environment (context) ;;FIXME |