diff options
| author | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2013-07-20 17:20:59 +0200 |
|---|---|---|
| committer | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2013-07-20 17:20:59 +0200 |
| commit | 529ea9384002f0852bab6657e21404ce5374d22f (patch) | |
| tree | d2850ff29a1196031bc0c9ae45e3385efb101c95 | |
| parent | 687f989581d2a51e0be60e3d298e0a243de794dd (diff) | |
LABELS, FLET: Add implicit block to function definitions.
| -rw-r--r-- | sb-eval2.lisp | 21 |
1 files changed, 13 insertions, 8 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index a9a28a1..cb4935a 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -430,9 +430,10 @@ name 'macrolet :environment env))) - (prepare-form `(lambda (,whole ,env) - ,body-form) - context)))) + (prepare-lambda `((,whole ,env) ,body-form) + context + ;;:name name + )))) (defmacro incff (x &optional (num 1)) (let ((old-x (gensym))) @@ -446,7 +447,7 @@ (,loop-var ,@(mapcar #'second bindings)))) (declaim (ftype (function * eval-closure) prepare-lambda)) -(defun prepare-lambda (lambda-form context) +(defun prepare-lambda (lambda-form context &key (name nil namep)) (destructuring-bind (lambda-list &rest exprs) lambda-form (with-parsed-body (body specials) exprs (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux @@ -495,8 +496,10 @@ (maybe-closes-over-p context `(progn ,@body) argvars) (some (lambda (x) (maybe-closes-over-p context x argvars)) default-values))) - (body* (prepare-progn body - (context-add-specials new-context specials))) + (body-context (context-add-specials new-context specials)) + (body* (if (and namep (symbolp name)) + (prepare-form `(block ,name ,@body) body-context) + (prepare-progn body body-context))) (unbound (gensym))) (setq varspecs (nreverse varspecs)) (flet @@ -781,7 +784,9 @@ (let* ((bindings* (mapcar (lambda (form) (if (listp form) (cons (first form) - (prepare-lambda (rest form) context)) + (prepare-lambda (rest form) + context + :name (first form))) (cons form (prepare-nil)))) bindings)) (new-context @@ -805,7 +810,7 @@ (bindings* (mapcar (lambda (form) (if (listp form) (cons (first form) - (prepare-lambda (rest form) new-context)) + (prepare-lambda (rest form) new-context :name (first form))) (cons form (prepare-nil)))) bindings)) (functions (mapcar #'cdr bindings*)) |