From ffjeld at common-lisp.net  Wed Jul  9 19:54:56 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  9 Jul 2008 15:54:56 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080709195456.DE0E030AF@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv15867

Modified Files:
	image.lisp 
Log Message:
Improved paranoia in intern-movitz-symbol.


--- /project/movitz/cvsroot/movitz/image.lisp	2008/04/27 19:18:16	1.124
+++ /project/movitz/cvsroot/movitz/image.lisp	2008/07/09 19:54:56	1.125
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.124 2008/04/27 19:18:16 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.125 2008/07/09 19:54:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1139,7 +1139,13 @@
 		    sum)))))
 
 (defun intern-movitz-symbol (name)
-  (assert (not (eq (symbol-package name) (find-package :common-lisp)))
+  (assert (not (member (symbol-package name)
+		       '(:common-lisp :movitz)
+		       :key #'find-package))
+      (name)
+    "Trying to movitz-intern a symbol in the ~A package: ~S" (symbol-package name) name)
+  (assert (not (eq (symbol-package name)
+		   (find-package :movitz)))
       (name)
     "Trying to movitz-intern a symbol in the Common-Lisp package: ~S" name)
   (or (gethash name (image-oblist *image*))



From ffjeld at common-lisp.net  Wed Jul  9 19:57:02 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  9 Jul 2008 15:57:02 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080709195702.C84D75F05E@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv16675

Modified Files:
	special-operators-cl.lisp 
Log Message:
Indent.


--- /project/movitz/cvsroot/movitz/special-operators-cl.lisp	2008/04/27 19:23:14	1.54
+++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp	2008/07/09 19:57:02	1.55
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:31:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: special-operators-cl.lisp,v 1.54 2008/04/27 19:23:14 ffjeld Exp $
+;;;; $Id: special-operators-cl.lisp,v 1.55 2008/07/09 19:57:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -641,54 +641,54 @@
     (let* ((last-returns :nothing)
 	   (bindings ())
 	   (code (loop
-		     for (var value-form) on pairs by #'cddr
-		     as binding = (movitz-binding var env)
-		     as pos downfrom (- (length pairs) 2) by 2
-		     as sub-result-mode = (if (zerop pos) result-mode :ignore)
-		     do (pushnew binding bindings)
-		     append
-		       (typecase binding
-			 (symbol-macro-binding
-			  (compiler-values-bind (&code code &returns returns)
-			      (compiler-call #'compile-form-unprotected 
-				:defaults forward
-				:result-mode sub-result-mode
-				:form `(muerte.cl:setf ,var ,value-form))
-			    (setf last-returns returns)
-			    code))
-			 (lexical-binding
-			  (case (operator sub-result-mode)
-			    (t ;; :ignore
-			     ;; (setf last-returns :nothing)
-			     (compiler-values-bind (&code sub-code &returns sub-returns)
-				 (compiler-call #'compile-form
-				   :defaults forward
-				   :form value-form
-				   :result-mode binding)
-			       (setf last-returns sub-returns)
-			       ;; (warn "sub-returns: ~S" sub-returns)
-			       sub-code))
-			    #+ignore
-			    (t (let ((register (accept-register-mode sub-result-mode)))
-				 (compiler-values-bind (&code code &type type)
-				     (compiler-call #'compile-form
-				       :defaults forward
-				       :form value-form
-				       :result-mode register)
-				   (setf last-returns register)
-				   (append code
-					   `((:store-lexical ,binding ,register
-							     :type ,(type-specifier-primary type)))))))))
-			 (t (unless (movitz-env-get var 'special nil env)
-			      (warn "Assuming destination variable ~S with binding ~S is special."
-				    var binding))
-			    (setf last-returns :ebx)
-			    (append (compiler-call #'compile-form
-				      :defaults forward
-				      :form value-form
-				      :result-mode :ebx)
-				    `((:load-constant ,var :eax)
-				      (:locally (:call (:edi (:edi-offset dynamic-variable-store)))))))))))
+		    for (var value-form) on pairs by #'cddr
+		    as binding = (movitz-binding var env)
+		    as pos downfrom (- (length pairs) 2) by 2
+		    as sub-result-mode = (if (zerop pos) result-mode :ignore)
+		    do (pushnew binding bindings)
+		    append
+		    (typecase binding
+		      (symbol-macro-binding
+		       (compiler-values-bind (&code code &returns returns)
+			   (compiler-call #'compile-form-unprotected 
+					  :defaults forward
+					  :result-mode sub-result-mode
+					  :form `(muerte.cl:setf ,var ,value-form))
+			 (setf last-returns returns)
+			 code))
+		      (lexical-binding
+		       (case (operator sub-result-mode)
+			 (t  ;; :ignore
+			  ;; (setf last-returns :nothing)
+			  (compiler-values-bind (&code sub-code &returns sub-returns)
+			      (compiler-call #'compile-form
+					     :defaults forward
+					     :form value-form
+					     :result-mode binding)
+			    (setf last-returns sub-returns)
+			    ;; (warn "sub-returns: ~S" sub-returns)
+			    sub-code))
+			 #+ignore
+			 (t (let ((register (accept-register-mode sub-result-mode)))
+			      (compiler-values-bind (&code code &type type)
+				  (compiler-call #'compile-form
+						 :defaults forward
+						 :form value-form
+						 :result-mode register)
+				(setf last-returns register)
+				(append code
+					`((:store-lexical ,binding ,register
+							  :type ,(type-specifier-primary type)))))))))
+		      (t (unless (movitz-env-get var 'special nil env)
+			   (warn "Assuming destination variable ~S with binding ~S is special."
+				 var binding))
+			 (setf last-returns :ebx)
+			 (append (compiler-call #'compile-form
+						:defaults forward
+						:form value-form
+						:result-mode :ebx)
+				 `((:load-constant ,var :eax)
+				   (:locally (:call (:edi (:edi-offset dynamic-variable-store)))))))))))
       (compiler-values ()
 	:code code
 	:returns last-returns



From ffjeld at common-lisp.net  Wed Jul  9 20:00:37 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  9 Jul 2008 16:00:37 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20080709200037.5C0FB3F027@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv18517

Modified Files:
	variables.lisp 
Log Message:
Add read-suppress.

--- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp	2008/04/27 08:34:48	1.14
+++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp	2008/07/09 20:00:37	1.15
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Nov  5 21:53:34 2003
 ;;;;                
-;;;; $Id: variables.lisp,v 1.14 2008/04/27 08:34:48 ffjeld Exp $
+;;;; $Id: variables.lisp,v 1.15 2008/07/09 20:00:37 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -37,6 +37,7 @@
 
 (defvar *read-base* 10)
 (defvar *read-eval* t)
+(defvar *read-suppress* nil)
 (defvar *package* nil)
 
 (defvar *macroexpand-hook* 'funcall)



From ffjeld at common-lisp.net  Wed Jul  9 20:05:36 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  9 Jul 2008 16:05:36 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20080709200536.AAE1464000@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv20879

Modified Files:
	ratios.lisp 
Log Message:
Tweak cos.

--- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp	2008/04/21 19:42:43	1.13
+++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp	2008/07/09 20:05:36	1.14
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 20 00:39:59 2004
 ;;;;                
-;;;; $Id: ratios.lisp,v 1.13 2008/04/21 19:42:43 ffjeld Exp $
+;;;; $Id: ratios.lisp,v 1.14 2008/07/09 20:05:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -117,11 +117,12 @@
 
 (defun cos (x)
   "http://mathworld.wolfram.com/Cosine.html"
-  (do* ((rad (mod x 44/7))
-        (n2 0 (+ n2 2))
+  (do* ((rad2 (expt (mod x 44/7) 2))
+	(n2 0 (+ n2 2))
+	(rad-n2 1 (* rad-n2 rad2))
         (sign 1 (- sign))
         (denominator 1 (* denominator (1- n2) n2))
-        (term 1 (/ (expt rad n2)
+        (term 1 (/ rad-n2
                    denominator))
         (sum 1 (+ sum (* sign term))))
        ((<= term 1/100)



From ffjeld at common-lisp.net  Wed Jul  9 20:08:52 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  9 Jul 2008 16:08:52 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20080709200852.DE7862400D@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv21493

Modified Files:
	basic-macros.lisp 
Log Message:
throw is just compiled.

--- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2008/04/09 18:01:34	1.76
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp	2008/07/09 20:08:52	1.77
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: basic-macros.lisp,v 1.76 2008/04/09 18:01:34 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.77 2008/07/09 20:08:52 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -90,7 +90,7 @@
       `(compiled-cond (,test-form ,then-form) (t ,else-form))
     `(compiled-cond (,test-form ,then-form))))
 
-(defmacro throw (tag result-form)
+(defmacro/cross-compilation throw (tag result-form)
   (let ((tag-var (gensym "throw-tag-")))
     `(let ((,tag-var ,tag))
        (exact-throw (find-catch-tag ,tag-var)



From ffjeld at common-lisp.net  Wed Jul  9 20:11:23 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  9 Jul 2008 16:11:23 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20080709201123.87B6223301@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv22261

Modified Files:
	eval.lisp 
Log Message:
Add and employ define-eval-special-operator.

--- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2008/04/27 16:14:10	1.34
+++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2008/07/09 20:11:23	1.35
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.34 2008/04/27 16:14:10 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.35 2008/07/09 20:11:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,6 +19,23 @@
 
 (in-package muerte)
 
+(define-compile-time-variable *eval-special-operators*
+    (make-hash-table :test #'eq))
+
+(defmacro define-eval-special-operator (operator lambda-list &body body)
+  (let ((name (intern (format nil "~A-~A" 'eval-special-operator operator))))
+    `(progn
+       (eval-when (:compile-toplevel)
+	 (setf (gethash (find-symbol ,(symbol-name operator))
+			*eval-special-operators*)
+	       ',name))
+       (defun ,name ,lambda-list , at body))))
+
+(defun special-operator-p (symbol)
+  (if (gethash symbol *eval-special-operators*)
+      t
+      nil))
+
 (defun eval (form)
   (eval-form form nil))
 
@@ -77,6 +94,130 @@
 ;;;
 ;;;Figure 3-2. Common Lisp Special Operators
 
+(define-eval-special-operator quote (form env)
+  (declare (ignore env))
+  (cadr form))
+
+(define-eval-special-operator progn (form env)
+  (eval-progn (cdr form) env))
+
+(define-eval-special-operator if (form env)
+  (if (eval-form (second form) env)
+      (eval-form (third form) env)
+      (eval-form (fourth form) env)))
+
+(define-eval-special-operator block (form env)
+  (catch form
+    (eval-progn (cddr form)
+		(cons (list* +eval-binding-type-block+
+			     (cadr form)
+			     form)
+		      env))))
+
+(define-eval-special-operator return-from (form env)
+  (let ((b (cdr (op-env-binding env (cadr form) +eval-binding-type-block+))))
+    (unless b (error "Block ~S is not visible." (cadr form)))
+    (throw (cdr b)
+      (eval-form (caddr form) env))))
+
+(define-eval-special-operator macrolet (form env)
+  (dolist (macrolet (cadr form))
+    (destructuring-bind (name lambda &body body)
+	macrolet
+      (check-type name symbol)
+      (check-type lambda list)
+      (push (list* +eval-binding-type-macrolet+
+		   name
+		   (cdr macrolet))
+	    env)))
+  (eval-progn (cddr form)
+	      env))
+
+(define-eval-special-operator let (form env)
+  (let ((var-specs (cadr form))
+	(declarations-and-body (cddr form)))
+    (let (special-vars
+	  special-values
+	  (local-env env))
+      (multiple-value-bind (body declarations)
+	  (parse-declarations-and-body declarations-and-body)
+	(dolist (var-spec var-specs)
+	  (multiple-value-bind (var init-form)
+	      (if (atom var-spec)
+		  (values var-spec nil)
+		  (values (car var-spec) (cadr var-spec)))
+	    (cond
+	      ((or (symbol-special-variable-p var)
+		   (declared-special-p var declarations))
+	       ;; special
+	       (push var special-vars)
+	       (push (eval-form init-form env) special-values))
+	      (t ;; lexical
+	       (push (cons var (eval-form init-form env))
+		     local-env)))))
+	(if (null special-vars)
+	    (eval-progn body local-env)
+	    (progv special-vars special-values
+	      (eval-progn body local-env)))))))
+
+(define-eval-special-operator let* (form env)
+  (let ((var-specs (cadr form))~)
+    (if (null var-specs)
+	(eval-progn body env)
+	(multiple-value-bind (body declarations)
+	    (parse-declarations-and-body (cddr form))
+	  (multiple-value-bind (var init-form)
+	      (let ((var-spec (pop var-specs)))
+		(if (atom var-spec)
+		    (values var-spec nil)
+		    (destructuring-bind (var init-form)
+			var-spec
+		      (values var init-form))))
+	    (if (or (symbol-special-variable-p var)
+		    (declared-special-p var declarations))
+		(progv (list var) (list (eval-form init-form env))
+		  (eval-let* var-specs
+			     declarations
+			     body
+			     env))
+		(eval-let* var-specs
+			   declarations
+			   body
+			   (cons (cons var
+				       (eval-form init-form env))
+				 env))))))))
+
+(define-eval-special-operator multiple-value-call (form env)
+  (apply (eval-form (cadr form) env)
+	 (mapcan (lambda (args-form)
+		   (multiple-value-list (eval-form args-form env)))
+		 (cddr form))))
+
+(define-eval-special-operator catch (form env)
+  (catch (eval-form (second form) env)
+    (eval-progn (cddr form) env)))
+
+(define-eval-special-operator throw (form env)
+  (throw (eval-form (second form) env)
+    (eval-form (third form) env)))
+
+(define-eval-special-operator unwind-protect (form env)
+  (unwind-protect
+       (eval-form (second form) env)
+    (eval-progn (cddr form) env)))
+
+(define-eval-special-operator the (form env)
+  (destructuring-bind (value-type form)
+      (cdr form)
+    (declare (ignore value-type))
+    (eval-form form env)))
+
+(define-eval-special-operator multiple-value-prog1 (form env)
+  (multiple-value-prog1 (eval-form (cadr form) env)
+    (eval-progn (cddr form) env)))
+
+(define-eval-special-operator symbol-macrolet (form env)
+  (error "Special operator ~S not implemented in ~S." (car form) 'eval))
 
 (defun eval-cons (form env)
   "3.1.2.1.2 Conses as Forms"
@@ -93,80 +234,16 @@
 								  :whole-p nil))))
 			  (cdr form))
 		    env)
-      (case (car form)
-	(quote (cadr form))
-	(function (eval-function (second form) env))
-	(if (if (eval-form (second form) env)
-		(eval-form (third form) env)
-		(eval-form (fourth form) env)))
-	(progn (eval-progn (cdr form) env))
-	(prog1 (prog1 (eval-form (cadr form) env)
-		 (eval-progn (cddr form) env)))
-	(tagbody (eval-tagbody form env))
-	((block)
-	 (catch form
-	   (eval-progn (cddr form)
-		       (cons (list* +eval-binding-type-block+
-				    (cadr form)
-				    form)
-			     env))))
-	((macrolet)
-	 (dolist (macrolet (cadr form))
-	   (destructuring-bind (name lambda &body body)
-	       macrolet
-	     (check-type name symbol)
-	     (check-type lambda list)
-	     (push (list* +eval-binding-type-macrolet+
-			  name
-			  (cdr macrolet))
-		   env)))
-	 (eval-progn (cddr form)
-		     env))
-	((return-from)
-	 (let ((b (cdr (op-env-binding env (cadr form) +eval-binding-type-block+))))
-	   (unless b (error "Block ~S is not visible." (cadr form)))
-	   (throw (cdr b)
-	     (eval-form (caddr form) env))))
-	(go (eval-go form env))
-	(setq (eval-setq form env))
-	(setf (eval-setf form env))
-	((defvar) (eval-defvar form env))
-	((let)
-	 (eval-let (cadr form) (cddr form) env))
-	((let*)
-	 (multiple-value-bind (body declarations)
-	     (parse-declarations-and-body (cddr form))
-	   (eval-let* (cadr form) declarations body env)))
-	((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env))
-	;; ((lambda) (eval-function form env)) ; the lambda macro..
-	((multiple-value-call)
-	 (apply (eval-form (cadr form) env)
-		(mapcan (lambda (args-form)
-			  (multiple-value-list (eval-form args-form env)))
-			(cddr form))))
-	((multiple-value-bind)
-	 (eval-m-v-bind form env))
-	((multiple-value-prog1)
-	 (multiple-value-prog1 (eval-form (cadr form) env)
-	   (eval-progn (cddr form) env)))
-	((catch)
-	 (catch (eval-form (second form) env)
-	   (eval-progn (cddr form) env)))
-	((throw)
-	 (throw (eval-form (second form) env)
-	   (eval-form (third form) env)))
-	((unwind-protect)
-	 (unwind-protect
-	      (eval-form (second form) env)
-	   (eval-progn (cddr form) env)))
-	((symbol-macrolet)
-	 (error "Special operator ~S not implemented in ~S." (car form) 'eval))
-	((the)
-	 (destructuring-bind (value-type form)
-	     (cdr form)
-	   (declare (ignore value-type))
-	   (eval-form form env)))
-	(t (eval-funcall form env)))))
+      (let ((special-operator (gethash (car form) *eval-special-operators*)))
+	(if special-operator
+	    (funcall special-operator form env)
+	    (case (car form)
+	      (setq (eval-setq form env))
+	      (setf (eval-setf form env))
+;; 	      ((defvar) (eval-defvar form env))
+	      ((multiple-value-bind)
+	       (eval-m-v-bind form env))
+	      (t (eval-funcall form env)))))))
 
 (defun eval-progn (forms env)
   (do ((p forms (cdr p)))
@@ -249,17 +326,6 @@
 			   declarations
 			   docstring)))))))
 
-(defun parse-docstring-declarations-and-body (forms &optional (declare 'declare))
-  "From the list of FORMS, return first the list of non-declaration forms, ~
-second the list of declaration-specifiers, third any docstring."
-  (assert (eq declare 'declare))
-  (if (or (not (cdr forms))
-	  (not (stringp (car forms))))
-      (parse-declarations-and-body forms)
-      (multiple-value-call #'values
-	(parse-declarations-and-body (cdr forms))
-	(car forms))))
-
 (defun compute-function-block-name (function-name)
   (cond
    ((symbolp function-name) function-name)
@@ -275,22 +341,6 @@
 	       (member var (cdr d)))
       (return t))))
 
-(defun eval-defun (name lambda-list body env)
-  (with-simple-restart (continue "Defun ~S anyway." name)
-    (assert (not (eq (symbol-package name)
-		     (find-package 'common-lisp)))
-	() "Won't allow defun of the Common Lisp symbol ~S." name))
-  (setf (symbol-function name)
-    (install-funobj-name name
-			 (lambda (&rest args)
-			   (declare (dynamic-extent args))
-			   (eval-progn body (make-destructuring-env
-					     lambda-list args env
-					     :environment-p nil
-					     :recursive-p nil
-					     :whole-p nil)))))
-  name)
-
 (defun decode-optional-formal (formal)
   "3.4.1.2 Specifiers for optional parameters.
 Parse {var | (var [init-form [supplied-p-parameter]])}
@@ -405,31 +455,6 @@
 	      env)
 	env)))
 
-(defun eval-let (var-specs declarations-and-body env)
-  (let (special-vars
-	special-values
-	(local-env env))
-    (multiple-value-bind (body declarations)
-	(parse-declarations-and-body declarations-and-body)
-      (dolist (var-spec var-specs)
-	(multiple-value-bind (var init-form)
-	    (if (atom var-spec)
-		(values var-spec nil)
-	      (values (car var-spec) (cadr var-spec)))
-	  (cond
-	   ((or (symbol-special-variable-p var)
-		(declared-special-p var declarations))
-	    ;; special
-	    (push var special-vars)
-	    (push (eval-form init-form env) special-values))
-	   (t ;; lexical
-	    (push (cons var (eval-form init-form env))
-		  local-env)))))
-      (if (null special-vars)
-	  (eval-progn body local-env)
-	(progv special-vars special-values
-	  (eval-progn body local-env))))))
-
 (defun eval-let* (var-specs declarations body env)
   (if (null var-specs)
       (eval-progn body env)
@@ -475,27 +500,28 @@
 		     env)))))
 	(eval-progn body env)))))
 
-(defun eval-function (function-name env)
-  (etypecase function-name
-    (symbol
-     (let ((binding (cdr (op-env-binding env function-name +eval-binding-type-flet+))))
-       (or (and binding (cdr binding))
-	   (symbol-function function-name))))
-    (list
-     (ecase (car function-name)
-       ((setf)
-	(symbol-function (lookup-setf-function (second function-name))))
-       ((lambda)
-	(let ((lambda-list (cadr function-name))
-	      (lambda-body (parse-docstring-declarations-and-body (cddr function-name))))
-	  (install-funobj-name :anonymous-lambda
-			       (lambda (&rest args)
-				 (declare (dynamic-extent args))
-				 (eval-progn lambda-body
-					     (make-destructuring-env lambda-list args env
-								     :environment-p nil
-								     :recursive-p nil
-								     :whole-p nil))))))))))
+(define-eval-special-operator function (form env)
+  (let ((function-name (second form)))
+    (etypecase function-name
+      (symbol
+       (let ((binding (cdr (op-env-binding env function-name +eval-binding-type-flet+))))
+	 (or (and binding (cdr binding))
+	     (symbol-function function-name))))
+      (list
+       (ecase (car function-name)
+	 ((setf)
+	  (symbol-function (lookup-setf-function (second function-name))))
+	 ((lambda)
+	  (let ((lambda-list (cadr function-name))
+		(lambda-body (parse-docstring-declarations-and-body (cddr function-name))))
+	    (install-funobj-name :anonymous-lambda
+				 (lambda (&rest args)
+				   (declare (dynamic-extent args))
+				   (eval-progn lambda-body
+					       (make-destructuring-env lambda-list args env
+								       :environment-p nil
+								       :recursive-p nil
+								       :whole-p nil)))))))))))
 
 (defun lookup-setf-function (name)
   (let ((setf-name (gethash name *setf-namespace*)))
@@ -515,28 +541,27 @@
     (cons (eval-form (car list) env)
 	  (eval-arglist (cdr list) env))))
 
-(defun eval-tagbody (form env)
+(define-eval-special-operator tagbody (form env)
   ;; build the..
   (do* ((pc (cdr form) (cdr pc))
 	(instruction (car pc) (car pc)))
-      ((endp pc))
+       ((endp pc))
     (when (typep instruction '(or integer symbol))
       (push (list* +eval-binding-type-go-tag+ instruction form)
 	    env)))
   ;; execute body..
   (prog ((pc (cdr form)))
    start
-    (let ((tag (catch form
-		 (do () ((endp pc) (go end))
-		   (let ((instruction (pop pc)))

[19 lines skipped]



From ffjeld at common-lisp.net  Wed Jul  9 20:17:46 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  9 Jul 2008 16:17:46 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20080709201746.CA28483160@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv23523

Modified Files:
	complexes.lisp 
Log Message:
complexp

--- /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp	2008/04/21 19:31:32	1.2
+++ /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp	2008/07/09 20:17:46	1.3
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: complexes.lisp,v 1.2 2008/04/21 19:31:32 ffjeld Exp $
+;;;; $Id: complexes.lisp,v 1.3 2008/07/09 20:17:46 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -18,7 +18,8 @@
 (provide :muerte/complexes)
 
 (defstruct (complex (:constructor make-complex-number)
-		    (:conc-name #:||))
+		    (:conc-name #:||)
+		    (:predicate complexp))
   realpart
   imagpart)
 



From ffjeld at common-lisp.net  Wed Jul  9 20:20:04 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Wed,  9 Jul 2008 16:20:04 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz/losp/muerte
Message-ID: <20080709202004.C0CCB2E2D6@common-lisp.net>

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24152

Modified Files:
	more-macros.lisp 
Log Message:
run-time defun

--- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2008/04/27 19:43:18	1.46
+++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp	2008/07/09 20:20:04	1.47
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Jun  7 15:05:57 2002
 ;;;;                
-;;;; $Id: more-macros.lisp,v 1.46 2008/04/27 19:43:18 ffjeld Exp $
+;;;; $Id: more-macros.lisp,v 1.47 2008/07/09 20:20:04 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -586,3 +586,8 @@
 
 (defmacro movitz-macroexpand-1 (&rest args)
   `(macroexpand-1 , at args))
+
+(defmacro/run-time defun (name lambda-list &body body)
+  `(setf (symbol-function ',name)
+	 (install-funobj-name ',name
+			      (lambda ,lambda-list , at body))))



From ffjeld at common-lisp.net  Fri Jul 18 13:15:40 2008
From: ffjeld at common-lisp.net (ffjeld)
Date: Fri, 18 Jul 2008 09:15:40 -0400 (EDT)
Subject: [movitz-cvs] CVS movitz
Message-ID: <20080718131540.A59865002A@common-lisp.net>

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv3039

Modified Files:
	image.lisp 
Log Message:
Have dump-image be more resilient against cyclic structures.


--- /project/movitz/cvsroot/movitz/image.lisp	2008/07/09 19:54:56	1.125
+++ /project/movitz/cvsroot/movitz/image.lisp	2008/07/18 13:15:40	1.126
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: image.lisp,v 1.125 2008/07/09 19:54:56 ffjeld Exp $
+;;;; $Id: image.lisp,v 1.126 2008/07/18 13:15:40 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1645,79 +1645,83 @@
   (with-movitz-read-context ()
     (when (typep expr 'movitz-object)
       (return-from movitz-read expr))
-    (or (and (not re-read)
-	     (let ((old-object (image-lisp-to-movitz-object *image* expr)))
-	       (when (and old-object (not (gethash old-object *movitz-reader-clean-map*)))
-		 (update-movitz-object old-object expr)
-		 (setf (gethash old-object *movitz-reader-clean-map*) t))
-	       old-object))
+    (or (unless re-read
+	  (let ((old-object (image-lisp-to-movitz-object *image* expr)))
+	    (when (and old-object
+		       (not (gethash old-object *movitz-reader-clean-map*)))
+	      (setf (gethash old-object *movitz-reader-clean-map*) t)
+	      (update-movitz-object old-object expr))
+	    old-object))
 	(setf (image-lisp-to-movitz-object *image* expr)
-	  (etypecase expr
-	    (null *movitz-nil*)
-	    ((member t) (movitz-read 'muerte.cl:t))
-	    ((eql unbound) (make-instance 'movitz-unbound-value))
-	    (symbol (intern-movitz-symbol expr))
-	    (integer (make-movitz-integer expr))
-	    (character (make-movitz-character expr))
-	    (string (or (gethash expr (image-string-constants *image*))
-			(setf (gethash expr (image-string-constants *image*))
-			  (make-movitz-string expr))))
-	    (vector (make-movitz-vector (length expr)
-					:element-type (array-element-type expr)
-					:initial-contents expr))
-	    (cons
-	     (or (let ((old-cons (gethash expr (image-cons-constants *image*))))
-		   (when old-cons
-		     (update-movitz-object old-cons expr)
-		     old-cons))
-		 (setf (gethash expr (image-cons-constants *image*))
-		   (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#)))
-		       (multiple-value-bind (unfolded-expr cdr-index)
-			   (unfold-circular-list expr)
-			 (let ((result (movitz-read unfolded-expr)))
-			   (setf (movitz-last-cdr result)
-			     (movitz-nthcdr cdr-index result))
-			   result))
-		     (make-movitz-cons (movitz-read (car expr))
-				       (movitz-read (cdr expr)))))))
-	    (hash-table
-	     (make-movitz-hash-table expr))
-	    (pathname
-	     (make-instance 'movitz-struct
-			    :class (muerte::movitz-find-class 'muerte::pathname)
-			    :length 1
-			    :slot-values (list (movitz-read (namestring expr)))))
-	    (complex
-	     (make-instance 'movitz-struct
-			    :class (muerte::movitz-find-class 'muerte::complex)
-			    :length 2
-			    :slot-values (list (movitz-read (realpart expr))
-					       (movitz-read (imagpart expr)))))
-	    (ratio
-	     (make-instance 'movitz-ratio
-	       :value expr))
-	    (structure-object
-	     (let ((slot-descriptions (gethash (type-of expr)
-					       (image-struct-slot-descriptions *image*)
-					       nil)))
-	       (unless slot-descriptions
-		 (error "Don't know how to movitz-read struct: ~S" expr))
-	       (let ((movitz-object (make-instance 'movitz-struct
-				      :class (muerte::movitz-find-class (type-of expr))
-				      :length (length slot-descriptions))))
-		 (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
-		 (setf (slot-value movitz-object 'slot-values)
-		   (mapcar #'(lambda (slot)
-			       (movitz-read (slot-value expr (if (consp slot) (car slot) slot))))
-			   slot-descriptions))
-		 movitz-object)))
-	    (float			; XXX
-	     (movitz-read (rationalize expr)))
-	    (class
-	     (muerte::movitz-find-class (translate-program (class-name expr)
-							   :cl :muerte.cl)))
-	    (array ; XXX
-	     (movitz-read nil)))))))
+	      (etypecase expr
+		(null *movitz-nil*)
+		((member t) (movitz-read 'muerte.cl:t))
+		((eql unbound) (make-instance 'movitz-unbound-value))
+		(symbol (intern-movitz-symbol expr))
+		(integer (make-movitz-integer expr))
+		(character (make-movitz-character expr))
+		(string (or (gethash expr (image-string-constants *image*))
+			    (setf (gethash expr (image-string-constants *image*))
+				  (make-movitz-string expr))))
+		(vector (make-movitz-vector (length expr)
+					    :element-type (array-element-type expr)
+					    :initial-contents expr))
+		(cons
+		 (or (let ((old-cons (gethash expr (image-cons-constants *image*))))
+		       (when old-cons
+			 (update-movitz-object old-cons expr)
+			 old-cons))
+		     (setf (gethash expr (image-cons-constants *image*))
+			   (if (eq '#0=#:error
+				   (ignore-errors
+				     (when (not (list-length expr))
+				       '#0#)))
+			       (multiple-value-bind (unfolded-expr cdr-index)
+				   (unfold-circular-list expr)
+				 (let ((result (movitz-read unfolded-expr)))
+				   (setf (movitz-last-cdr result)
+					 (movitz-nthcdr cdr-index result))
+				   result))
+			       (make-movitz-cons (movitz-read (car expr))
+						 (movitz-read (cdr expr)))))))
+		(hash-table
+		 (make-movitz-hash-table expr))
+		(pathname
+		 (make-instance 'movitz-struct
+				:class (muerte::movitz-find-class 'muerte::pathname)
+				:length 1
+				:slot-values (list (movitz-read (namestring expr)))))
+		(complex
+		 (make-instance 'movitz-struct
+				:class (muerte::movitz-find-class 'muerte::complex)
+				:length 2
+				:slot-values (list (movitz-read (realpart expr))
+						   (movitz-read (imagpart expr)))))
+		(ratio
+		 (make-instance 'movitz-ratio
+				:value expr))
+		(structure-object
+		 (let ((slot-descriptions (gethash (type-of expr)
+						   (image-struct-slot-descriptions *image*)
+						   nil)))
+		   (unless slot-descriptions
+		     (error "Don't know how to movitz-read struct: ~S" expr))
+		   (let ((movitz-object (make-instance 'movitz-struct
+						       :class (muerte::movitz-find-class (type-of expr))
+						       :length (length slot-descriptions))))
+		     (setf (image-lisp-to-movitz-object *image* expr) movitz-object)
+		     (setf (slot-value movitz-object 'slot-values)
+			   (mapcar #'(lambda (slot)
+				       (movitz-read (slot-value expr (if (consp slot) (car slot) slot))))
+				   slot-descriptions))
+		     movitz-object)))
+		(float			; XXX
+		 (movitz-read (rationalize expr)))
+		(class
+		 (muerte::movitz-find-class (translate-program (class-name expr)
+							       :cl :muerte.cl)))
+		(array			; XXX
+		 (movitz-read nil)))))))
 
 ;;;