From: David Vázquez <davazp@gmail.com>
Date: Wed, 1 May 2013 03:50:11 +0000 (+0100)
Subject: Ignore declarations in lambdas
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7c2abe8024928a07577fefc447238388de6cdfa4;p=jscl.git

Ignore declarations in lambdas
---

diff --git a/src/compiler.lisp b/src/compiler.lisp
index bf9b8ec..4914c9d 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -444,50 +444,75 @@
                       "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
              "}" *newline*)))))
 
+(defun parse-lambda-list (ll)
+  (values (ll-required-arguments ll)
+          (ll-optional-arguments ll)
+          (ll-keyword-arguments  ll)
+          (ll-rest-argument      ll)))
+
+;;; Process BODY for declarations and/or docstrings. Return as
+;;; multiple values the BODY without docstrings or declarations, the
+;;; list of declaration forms and the docstring.
+(defun parse-body (body &key declarations docstring)
+  (let ((value-declarations)
+        (value-docstring))
+    ;; Parse declarations
+    (when declarations
+      (do* ((rest body (cdr rest))
+            (form (car rest) (car rest)))
+           ((or (atom form) (not (eq (car form) 'declare)))
+            (setf body rest))
+        (push form value-declarations)))
+    ;; Parse docstring
+    (when (and docstring
+               (stringp (car body))
+               (not (null (cdr body))))
+      (setq value-docstring (car body))
+      (setq body (cdr body)))
+    (values body value-declarations value-docstring)))
+
 ;;; Compile a lambda function with lambda list LL and body BODY. If
 ;;; NAME is given, it should be a constant string and it will become
 ;;; the name of the function. If BLOCK is non-NIL, a named block is
 ;;; created around the body. NOTE: No block (even anonymous) is
 ;;; created if BLOCk is NIL.
 (defun compile-lambda (ll body &key name block)
-  (let ((required-arguments (ll-required-arguments ll))
-        (optional-arguments (ll-optional-arguments ll))
-	(keyword-arguments  (ll-keyword-arguments  ll))
-        (rest-argument      (ll-rest-argument      ll))
-        documentation)
-    ;; Get the documentation string for the lambda function
-    (when (and (stringp (car body))
-               (not (null (cdr body))))
-      (setq documentation (car body))
-      (setq body (cdr body)))
-    (let ((n-required-arguments (length required-arguments))
-          (n-optional-arguments (length optional-arguments))
-          (*environment* (extend-local-env
-                          (append (ensure-list rest-argument)
-                                  required-arguments
-                                  optional-arguments
-				  keyword-arguments
-                                  (ll-svars ll)))))
-      (lambda-name/docstring-wrapper name documentation
-       "(function ("
-       (join (cons "values"
-                   (mapcar #'translate-variable
-                           (append required-arguments optional-arguments)))
-             ",")
-       "){" *newline*
-       (indent
-        ;; Check number of arguments
-        (lambda-check-argument-count n-required-arguments
-                                     n-optional-arguments
-                                     (or rest-argument keyword-arguments))
-	(compile-lambda-optional ll)
-	(compile-lambda-rest ll)
-	(compile-lambda-parse-keywords ll)
-        (let ((*multiple-value-p* t))
-          (if block
-              (ls-compile-block `((block ,block ,@body)) t)
-              (ls-compile-block body t))))
-       "})"))))
+  (multiple-value-bind (required-arguments
+                        optional-arguments
+                        keyword-arguments
+                        rest-argument)
+      (parse-lambda-list ll)
+    (multiple-value-bind (body decls documentation)
+        (parse-body body :declarations t :docstring t)
+      (declare (ignore decls))
+      (let ((n-required-arguments (length required-arguments))
+            (n-optional-arguments (length optional-arguments))
+            (*environment* (extend-local-env
+                            (append (ensure-list rest-argument)
+                                    required-arguments
+                                    optional-arguments
+                                    keyword-arguments
+                                    (ll-svars ll)))))
+        (lambda-name/docstring-wrapper name documentation
+         "(function ("
+         (join (cons "values"
+                     (mapcar #'translate-variable
+                             (append required-arguments optional-arguments)))
+               ",")
+         "){" *newline*
+         (indent
+          ;; Check number of arguments
+          (lambda-check-argument-count n-required-arguments
+                                       n-optional-arguments
+                                       (or rest-argument keyword-arguments))
+                                        (compile-lambda-optional ll)
+                                        (compile-lambda-rest ll)
+                                        (compile-lambda-parse-keywords ll)
+                                        (let ((*multiple-value-p* t))
+                                          (if block
+                                              (ls-compile-block `((block ,block ,@body)) t)
+                                              (ls-compile-block body t))))
+         "})")))))
 
 
 (defun setq-pair (var val)
diff --git a/src/toplevel.lisp b/src/toplevel.lisp
index 97ba95b..6dfe781 100644
--- a/src/toplevel.lisp
+++ b/src/toplevel.lisp
@@ -55,7 +55,7 @@
           cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr caar cadddr caddr
           cadr car car case catch cdar cdddr cddr cdr cdr char
           char-code char= code-char cond cons consp constantly
-          copy-list copy-tree decf declaim defconstant define-setf-expander
+          copy-list copy-tree decf declaim declare defconstant define-setf-expander
           define-symbol-macro defmacro defparameter defun defvar
           digit-char digit-char-p disassemble do do* documentation
           dolist dotimes ecase eq eql equal error eval every export expt