diff options
| -rw-r--r-- | sb-eval2.lisp | 227 |
1 files changed, 109 insertions, 118 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index 2791352..9c76095 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -455,13 +455,11 @@ (new-context (make-lexical-context context)) (varspecs (list)) (varnum 0) - (specialsp nil) (default-values* (flet ((register-var (var) (if (or (member var specials :test #'eq) (globally-special-p var)) (progn - (setq specialsp t) (context-add-special! new-context var) (push (cons :special var) varspecs)) (progn @@ -502,9 +500,8 @@ (my-keywords keywords) (my-varspecs varspecs) (saved-binding-pointer - (when specialsp - (sb-c::%primitive - sb-c::current-binding-pointer))) + (sb-c::%primitive + sb-c::current-binding-pointer)) (argi 0) ;how many actual arguments have ;been processed (vari 0) ;how many lexical vars have been @@ -512,119 +509,113 @@ (i 0)) ;how many formal arguments have ;been processed (declare (fixnum restnum argi vari i)) - (labels - ((iter () - (flet ((push-args (&rest values) - ;; Push VALUES onto the - ;; environment. - (let () - (incf i) - (dolist (value values) - (let ((varspec (pop my-varspecs))) - (if (eq varspec :lexical) - (progn - (setf - (environment-value *new-env* 0 vari) - value) - (incf vari)) - (progn - (assert (eq :special - (car varspec)) - (varspec)) - (assert specialsp) - (sb-c::%primitive - sb-c::bind value (cdr varspec))))))))) - (declare (inline push-args)) - (tagbody - positional - (when (>= argi (length args)) - (go missing-optionals)) - (when (>= argi (the fixnum - (+ required-num optional-num))) - (go keys)) - (if (>= argi required-num) - (progn - (pop my-default-values*) - (push-args (elt args (incff argi)) t)) - (push-args (elt args (incff argi)))) - (go positional) - 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*) - *new-env*) - nil)) - (go missing-optionals) - keys - (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*) - *new-env*))) - (go aux) - rest - (assert (null my-default-values*) - (my-default-values*)) - (when restp - (push-args rest)) - final-call - (return-from iter - (unwind-protect - (funcall body* *new-env*) - (when specialsp - (sb-c::%primitive - sb-c::unbind-to-here saved-binding-pointer)))))))) - (iter))))) + (flet ((push-args (&rest values) + ;; Push VALUES onto the + ;; environment. + (incf i) + (dolist (value values) + (let ((varspec (pop my-varspecs))) + (if (eq varspec :lexical) + (progn + (setf + (environment-value *new-env* 0 vari) + value) + (incf vari)) + (progn + (assert (eq :special + (car varspec)) + (varspec)) + (sb-c::%primitive + sb-c::bind value (cdr varspec)))))))) + (declare (inline push-args)) + (prog () + positional + (when (>= argi (length args)) + (go missing-optionals)) + (when (>= argi (the fixnum + (+ required-num optional-num))) + (go keys)) + (if (>= argi required-num) + (progn + (pop my-default-values*) + (push-args (elt args (incff argi)) t)) + (push-args (elt args (incff argi)))) + (go positional) + 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*) + *new-env*) + nil)) + (go missing-optionals) + keys + (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*) + *new-env*))) + (go aux) + rest + (assert (null my-default-values*) + (my-default-values*)) + (when restp + (push-args rest)) + final-call + (return + (unwind-protect + (funcall body* *new-env*) + (sb-c::%primitive + sb-c::unbind-to-here saved-binding-pointer)))))))) ;;(declare (inline handle-arguments)) (if envp (lambda (env) |