From 3a2f1fd5c85ba93860d6a7d205bcea2994374ecc Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Wed, 2 May 2012 00:46:48 +0000
Subject: 	* interp/vmlisp.lisp (COMPILE1): Move to lisp-backend.boot. 
 ($lamName): Rename from *LAM-NAME*.

---
 src/ChangeLog                |  5 +++++
 src/interp/lisp-backend.boot | 30 ++++++++++++++++++++++++++++++
 src/interp/vmlisp.lisp       | 37 ++-----------------------------------
 3 files changed, 37 insertions(+), 35 deletions(-)

diff --git a/src/ChangeLog b/src/ChangeLog
index dcdab929..38491339 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,8 @@
+2012-05-01  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/vmlisp.lisp (COMPILE1): Move to lisp-backend.boot.
+	($lamName): Rename from *LAM-NAME*.
+
 2012-05-01  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* interp/vmlisp.lisp (REMOVE-FLUIDS): Move to lisp-backend.boot.
diff --git a/src/interp/lisp-backend.boot b/src/interp/lisp-backend.boot
index 79677e07..2b739af8 100644
--- a/src/interp/lisp-backend.boot
+++ b/src/interp/lisp-backend.boot
@@ -781,3 +781,33 @@ removeFluids args ==
     $Vars := [v,:$Vars]
     v
   [removeFluids first args,:removeFluids rest args]
+
+COMPILE1 fun ==
+  $Vars: local := nil
+  $Decls: local := nil
+  [name,lambda] := fun
+  [type,args,:body] := lambda
+  if type is 'LAM then
+    lambda := f(name,lambda) where
+      f(n,x) ==
+        $lamName: local := makeSymbol strconc(n,'",LAM")
+        EVAL x
+    [type,args,:body] := lambda
+  if body is [['DECLARE,['SPECIAL,:xs]],:body'] then
+    $Decls := xs
+    body := body'
+  args := removeFluids args
+  newArgs :=
+    type is 'LAMBDA and simpleParameterList? args => args
+    args' := gensym()
+    body := [['DSETQ,args,args'],:body]
+    type is 'LAMBDA => ["&REST",args',"&AUX",:$Vars]
+    type is 'MLAMBDA => ["&WHOLE",args',"&REST",gensym(),"&AUX",:$Vars]
+    coreError '"bad function type"
+  if $Decls ~= nil then
+    body := [['DECLARE,['SPECIAL,:$Decls]],:body]
+  body :=
+    type is 'LAMBDA => ['DEFUN,name,newArgs,:body]
+    ['DEFMACRO,name,newArgs,:body]
+  compileLispDefinition(name,body)
+  body
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index a4d5e01f..4c35ef41 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -57,7 +57,7 @@
 
 (defvar *fileactq-apply* nil "function to apply in fileactq")
 
-(defvar *lam-name* nil "name to be used by lam macro if non-nil")
+(defvar |$lamName| nil "name to be used by lam macro if non-nil")
 
 (defvar macerrorcount 0  "Put some documentation in here someday")
 
@@ -293,7 +293,7 @@
                  (CONTROL (QUOTESOF (first BODY)))
                  (BODY (cdr BODY))
                  (ARGS (GENSYM))
-                 (INNER-FUNC (or *lam-name* (gentemp))))
+                 (INNER-FUNC (or |$lamName| (gentemp))))
             (COMP370 (LIST INNER-FUNC `(LAMBDA ,BV . ,BODY)))
             `(MLAMBDA ,ARGS
                       (CONS (QUOTE ,INNER-FUNC)
@@ -343,39 +343,6 @@
  (declare (ignore sd))
   (macroexpand `(,arg ,item)))
 
-; 8.1 Definition and Transformation Operations
-
-(defun COMPILE1 (fn)
-  (let* (nargs
-         (fname (car fn))
-         (lamda (cadr fn))
-         (ltype (car lamda))
-         |$Vars| |$Decls| args
-         (body (cddr lamda)))
-    (declare (special |$Vars| |$Decls|))
-    (if (eq ltype 'LAM)
-        (let ((*lam-name* (intern (concat fname "\,LAM"))))
-          (setq lamda (eval lamda) ltype (car lamda) body (cddr lamda))))
-    (let ((dectest (car body)))
-      (if (and (eqcar dectest 'declare) (eqcar (cadr dectest) 'special))
-          (setq |$Decls| (cdr (cadr dectest)) body (cdr body))))
-    (setq args (|removeFluids| (cadr lamda)))
-    (cond ((and (eq ltype 'lambda) (|simpleParameterList?| args))
-	   (setq nargs args))
-          (t (setq nargs (gensym))
-             (setq body `((dsetq ,args  ,nargs) ,@body))
-             (cond ((eq ltype 'lambda) (setq nargs `(&rest ,nargs &aux ,@ |$Vars|)))
-                   ((eq ltype 'mlambda)
-                    (setq nargs `(&whole ,nargs &rest ,(gensym) &aux ,@ |$Vars|)))
-                   (t (error "bad function type")))))
-    (cond (|$Decls| (setq body (cons `(declare (special ,@ |$Decls|)) body))))
-    (setq body
-          (cond ((eq ltype 'lambda) `(defun ,fname ,nargs . ,body))
-                ((eq ltype 'mlambda) `(defmacro ,fname ,nargs . ,body))))
-    (|compileLispDefinition| fname body)
-
-    body))
-
 ; 9.4 Vectors and Bpis
 
 (defun IVECP (x) (and (vectorp x) (subtypep (array-element-type x) 'integer)))
-- 
cgit v1.2.3