March 2008 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 20 Mar '08

20 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27582 Modified Files: common-lisp.lisp Log Message: Add trivial implementations of complexes and pathnames. --- /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/17 17:24:52 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/20 22:21:00 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.17 2008/03/17 17:24:52 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.18 2008/03/20 22:21:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,6 +44,8 @@ (require :muerte/run-time-context) (require :muerte/defstruct) (require :muerte/hash-tables) +(require :muerte/pathnames) +(require :muerte/complexes) (require :muerte/ratios) (require :muerte/packages) (require :muerte/format)

1 0

[movitz-cvs] CVS movitz
by ffjeld 19 Mar '08

19 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32262 Modified Files: compiler.lisp Log Message: Fix (again) the borrowing/lending of function-bindings. The compiler would get confused when local functions called eachother. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/17 23:23:30 1.197 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/19 15:06:10 1.198 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.197 2008/03/17 23:23:30 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.198 2008/03/19 15:06:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,13 +611,14 @@ (check-type toplevel-funobj movitz-funobj) (let ((function-binding-usage ())) (labels ((process-binding (funobj binding usages) + (when (typep binding 'function-binding) + (dolist (usage usages) + (pushnew usage + (getf (sub-function-binding-usage (function-binding-parent binding)) + binding)) + (pushnew usage (getf function-binding-usage binding)))) (cond ((typep binding 'constant-object-binding)) - ((and (typep binding 'function-binding) - (equal usages '(:call))) - (pushnew :call (getf (sub-function-binding-usage (function-binding-parent binding)) - binding)) - (pushnew :call (getf function-binding-usage binding))) ((not (eq funobj (binding-funobj binding))) (let ((borrowing-binding (or (find binding (borrowed-bindings funobj) @@ -643,17 +644,7 @@ (t ; Binding is local to this funobj (typecase binding (forwarding-binding - (process-binding funobj (forwarding-binding-target binding) usages) - #+ignore - (setf (forwarding-binding-target binding) - (process-binding funobj (forwarding-binding-target binding) usages))) - (function-binding - (dolist (usage usages) - (pushnew usage - (getf (sub-function-binding-usage (function-binding-parent binding)) - binding)) - (pushnew usage (getf function-binding-usage binding))) - binding) + (process-binding funobj (forwarding-binding-target binding) usages)) (t binding))))) (resolve-sub-funobj (funobj sub-funobj) (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj))) @@ -760,6 +751,22 @@ (t (change-class function-binding 'closure-binding) (setf (movitz-funobj-extent sub-funobj) :indefinite-extent)))))) + ;; Each time we change a function-binding to funobj-binding, that binding + ;; no longer needs to be borrowed (because it doesn't share lexical bindings), + ;; and therefore should be removed from any borrowed-binding list, which in + ;; turn can cause the borrowing funobj to become a funobj-binding, and so on. + (loop for modified-p = nil + do (loop for function-binding in function-binding-usage by #'cddr + do (let ((sub-funobj (function-binding-funobj function-binding))) + (when (not (null (borrowed-bindings sub-funobj))) + (check-type function-binding closure-binding) + (when (null (setf (borrowed-bindings sub-funobj) + (delete-if (lambda (b) + (when (typep (borrowed-binding-target b) 'funobj-binding) + (setf modified-p t))) + (borrowed-bindings sub-funobj)))) + (change-class function-binding 'funobj-binding))))) + while modified-p) (loop for function-binding in function-binding-usage by #'cddr do (finalize-funobj (function-binding-funobj function-binding))) (finalize-funobj toplevel-funobj)) @@ -2526,7 +2533,7 @@ (incf (getf constants funobj 0)))) (closure-binding) (function-binding - (warn "No function-binding now..: ~S" binding)))) + (error "No function-binding now..: ~S" binding)))) (process (sub-code) "This local function side-effects the variables jumper-sets and constants." (loop for instruction in sub-code @@ -3791,8 +3798,9 @@ (mapcar #'binding-funobj (getf (binding-lending lended-binding) :lended-to)))) (when (typep lended-binding 'funobj-binding) - (break "Lending ~S ?" lended-binding)) - (append (unless (or (typep lended-binding 'borrowed-binding) + (break "Lending ~S from ~S: ~S" lended-binding funobj (binding-lending lended-binding))) + (append (make-load-lexical lended-binding :eax funobj t frame-map) + (unless (or (typep lended-binding 'borrowed-binding) (getf (binding-lending lended-binding) :dynamic-extent-p) (every (lambda (borrower) (member (movitz-funobj-extent (binding-funobj borrower)) @@ -3811,7 +3819,7 @@ binding (or (find binding (borrowed-bindings funobj) :key #'borrowed-binding-target) - (error "Can't install non-local binding ~W." binding))))) + (error "Can't install non-local binding ~S for ~S." binding funobj))))) (labels ((fix-edi-offset (tree) (cond ((atom tree) @@ -3896,14 +3904,15 @@ no-alignment-needed) (make-load-constant sub-funobj :eax funobj frame-map) ))) - (t (assert (not (null (borrowed-bindings sub-funobj)))) + (t (assert (not (null (borrowed-bindings sub-funobj))) () + "Binding ~S with ~S borrows no nothing, which makes no sense." function-binding sub-funobj) (append (make-load-constant sub-funobj :eax funobj frame-map) `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) (:movl :eax :edx)) (make-store-lexical function-binding :eax nil funobj frame-map) (loop for bb in (borrowed-bindings sub-funobj) - append (make-lend-lexical bb :edx nil)))))) + append (make-lend-lexical bb :edx nil)))))) funobj frame-map))) (:load-lambda (destructuring-bind (function-binding register capture-env) @@ -3912,7 +3921,7 @@ (finalize-code (let* ((sub-funobj (function-binding-funobj function-binding)) (lend-code (loop for bb in (borrowed-bindings sub-funobj) - appending + appending (make-lend-lexical bb :edx nil)))) (cond ((null lend-code)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Mar '08

19 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30223 Modified Files: eval.lisp Log Message: No let* yet. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/19 12:37:22 1.23 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/19 15:00:31 1.24 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.23 2008/03/19 12:37:22 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.24 2008/03/19 15:00:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -123,7 +123,7 @@ (unwind-protect (eval-form (second form) env) (eval-progn (cddr form) env))) - ((macrolet symbol-macrolet) + ((macrolet symbol-macrolet let*) (error "Special operator ~S not implemented in ~S." (car form) 'eval)) (t (eval-funcall form env))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Mar '08

19 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29610 Modified Files: defmacro-runtime.lisp Log Message: Remove noise. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/03/17 08:01:03 1.1 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/03/19 15:00:13 1.2 @@ -7,7 +7,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defmacro-runtime.lisp,v 1.1 2008/03/17 08:01:03 ffjeld Exp $ +;;;; $Id: defmacro-runtime.lisp,v 1.2 2008/03/19 15:00:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -16,7 +16,6 @@ (provide :muerte/defmacro-runtime) (defmacro defmacro (name lambda-list &body macro-body) - (warn "rmacro: ~S" name) `(progn (defmacro/runtime ,name ,lambda-list ,@macro-body) (defmacro-compile-time ,name ,lambda-list ,macro-body)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Mar '08

19 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19487 Modified Files: variables.lisp Log Message: Add macroexpand, macroexpand-1, and *macroexpand-hook*. --- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2006/04/10 11:58:27 1.10 +++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/03/19 12:37:29 1.11 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.10 2006/04/10 11:58:27 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.11 2008/03/19 12:37:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -37,6 +37,7 @@ (defvar *read-base* 10) (defvar *package* nil) +(defvar *macroexpand-hook* 'funcall) (defparameter *debugger-hook* nil) (defvar *active-condition-handlers* nil) (defvar *multiboot-data* nil)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 19 Mar '08

19 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19458 Modified Files: eval.lisp Log Message: Add macroexpand, macroexpand-1, and *macroexpand-hook*. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/18 16:24:30 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/19 12:37:22 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.22 2008/03/18 16:24:30 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.23 2008/03/19 12:37:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,11 +25,15 @@ (defun eval-form (form env) "3.1.2.1 Form Evaluation." (check-stack-limit) - (typecase form - (null nil) - (symbol (eval-symbol form env)) - (cons (eval-cons form env)) - (t form))) + (multiple-value-bind (macro-expansion expanded-p) + (macroexpand form env) + (if expanded-p + (eval-form macro-expansion env) + (typecase form + (null nil) + (symbol (eval-symbol form env)) + (cons (eval-cons form env)) + (t form))))) (defun env-binding (env var) ;; (warn "env: ~S in ~S" var env) @@ -70,62 +74,58 @@ (defun eval-cons (form env) "3.1.2.1.2 Conses as Forms" - (let ((macro-function (macro-function (car form)))) - (if macro-function - (eval-form (funcall macro-function form nil) - 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)))) - ((return-from) - (let ((b (op-env-binding +eval-binding-type-block+ env (cadr form)))) - (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)) - ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) - ((lambda) (eval-function form env)) ; the lambda macro.. - ((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))) - ((destructuring-bind) - (eval-progn (cdddr form) - (make-destructuring-env (cadr form) - (eval-form (caddr form) env) - 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) + (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))) - ((macrolet symbol-macrolet) - (error "Special operator ~S not implemented in ~S." (car form) 'eval)) - (t (eval-funcall form env)))))) + (tagbody (eval-tagbody form env)) + ((block) + (catch form + (eval-progn (cddr form) + (cons (list* +eval-binding-type-block+ + (cadr form) + form) + env)))) + ((return-from) + (let ((b (op-env-binding +eval-binding-type-block+ env (cadr form)))) + (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)) + ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) + ((lambda) (eval-function form env)) ; the lambda macro.. + ((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))) + ((destructuring-bind) + (eval-progn (cdddr form) + (make-destructuring-env (cadr form) + (eval-form (caddr form) env) + 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))) + ((macrolet symbol-macrolet) + (error "Special operator ~S not implemented in ~S." (car form) 'eval)) + (t (eval-funcall form env)))) (defun eval-progn (forms env) (do ((p forms (cdr p))) @@ -453,6 +453,24 @@ (setf (symbol-function name) function)) t nil))) +(defun macroexpand-1 (form &optional env) + (if (atom form) + (values form nil) + (let ((macro-function (macro-function (car form)))) + (if macro-function + (values (funcall *macroexpand-hook* macro-function form env) + t) + (values form + nil))))) + +(defun macroexpand (form &optional env) + (do ((expanded-at-all-p nil)) (nil) + (multiple-value-bind (expansion expanded-p) + (macroexpand-1 form env) + (when (not expanded-p) + (return (values expansion expanded-at-all-p))) + (setf form expansion + expanded-at-all-p t)))) (defun proclaim (declaration) ;; What do do?

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 18 Mar '08

18 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv32184 Modified Files: lists.lisp Log Message: Improve mapcar and mapcan. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/17 23:25:05 1.23 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/18 16:24:49 1.24 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.23 2008/03/17 23:25:05 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.24 2008/03/18 16:24:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -284,45 +284,73 @@ (return (values (car p) (cadr p) p))))) (defun mapcar (function first-list &rest more-lists) - (declare (dynamic-extent more-lists)) - (cond - ((null more-lists) - ;; 1 list - (do ((result nil) - (p first-list (cdr p))) - ((endp p) (nreverse result)) - (push (funcall function (car p)) - result))) - ((null (cdr more-lists)) - ;; two lists - (do ((result nil) - (p1 first-list (cdr p1)) - (p2 (car more-lists) (cdr p2))) - ((or (endp p1) (endp p2)) (nreverse result)) - (push (funcall function (car p1) (car p2)) - result))) - ((null (cddr more-lists)) - ;; three lists - (do ((result nil) - (p1 first-list (cdr p1)) - (p2 (car more-lists) (cdr p2)) - (p3 (cadr more-lists) (cdr p2))) - ((or (endp p1) (endp p2) (endp p3)) (nreverse result)) - (push (funcall function (car p1) (car p2) (car p3)) - result))) - (t (error "mapcar not fully implemented.")))) + (numargs-case + (2 (function first-list) + (do ((result nil) + (p first-list (cdr p))) + ((endp p) + (nreverse result)) + (push (funcall function (car p)) + result))) + (3 (function first-list second-list) + (do ((result nil) + (p1 first-list (cdr p1)) + (p2 second-list (cdr p2))) + ((or (endp p1) (endp p2)) + (nreverse result)) + (push (funcall function (car p1) (car p2)) + result))) + (t (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (do ((result nil)) + ((or (endp first-list) + (some #'endp more-lists)) + (nreverse result)) + (push (apply function (pop first-list) (mapcar #'car more-lists)) + result) + (setf more-lists + (map-into more-lists #'cdr more-lists)))))) (defun mapcan (function first-list &rest more-lists) - (declare (dynamic-extent more-lists)) - (cond - ((null more-lists) - ;; 1 list - (do ((result nil) - (p first-list (cdr p))) - ((endp p) result) - (setf result (nconc result (funcall function (car p)))))) - (t (error "~S not implemented." 'mapcan)))) + (numargs-case + (2 (function first-list) + (do ((result nil) + (tail nil) + (p first-list (cdr p))) + ((endp p) result) + (let ((m (funcall function (car p)))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))))) + (3 (function first-list second-list) + (do ((result nil) + (tail nil) + (p first-list (cdr p)) + (q second-list (cdr q))) + ((or (endp p) + (endp q)) + result) + (let ((m (funcall function (car p) (car q)))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))))) + (t (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (do ((result nil) + (tail nil)) + ((or (endp first-list) + (some #'endp more-lists)) + result) + (let ((m (apply function (pop first-list) (mapcar #'car more-lists)))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))) + (setf more-lists + (map-into more-lists #'cdr more-lists)))))) (defun mapc (function first-list &rest more-lists) (numargs-case

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 18 Mar '08

18 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv32093 Modified Files: eval.lisp Log Message: Add support for BLOCK in eval. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/17 23:25:26 1.21 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/18 16:24:30 1.22 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.21 2008/03/17 23:25:26 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.22 2008/03/18 16:24:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,6 +45,7 @@ ;; named by integers. (defconstant +eval-binding-type-flet+ 0) (defconstant +eval-binding-type-go-tag+ 1) +(defconstant +eval-binding-type-block+ 2) (defun eval-symbol (form env) "3.1.2.1.1 Symbols as Forms" @@ -76,10 +77,6 @@ (case (car form) (quote (cadr form)) (function (eval-function (second form) env)) - (when (when (eval-form (second form) env) - (eval-progn (cddr form) env))) - (unless (unless (eval-form (second form) env) - (eval-progn (cddr form) env))) (if (if (eval-form (second form) env) (eval-form (third form) env) (eval-form (fourth form) env))) @@ -87,6 +84,18 @@ (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)))) + ((return-from) + (let ((b (op-env-binding +eval-binding-type-block+ env (cadr form)))) + (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)) @@ -111,7 +120,8 @@ (throw (eval-form (second form) env) (eval-form (third form) env))) ((unwind-protect) - (unwind-protect (eval-form (second form) env) + (unwind-protect + (eval-form (second form) env) (eval-progn (cddr form) env))) ((macrolet symbol-macrolet) (error "Special operator ~S not implemented in ~S." (car form) 'eval))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 17 Mar '08

17 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv28118 Modified Files: eval.lisp Log Message: Pass on env when eval macro-forms. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/16 22:28:12 1.20 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/17 23:25:26 1.21 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.20 2008/03/16 22:28:12 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.21 2008/03/17 23:25:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,7 +72,7 @@ (let ((macro-function (macro-function (car form)))) (if macro-function (eval-form (funcall macro-function form nil) - nil) + env) (case (car form) (quote (cadr form)) (function (eval-function (second form) env))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 17 Mar '08

17 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27970 Modified Files: lists.lisp Log Message: Add trivial mapcan. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2007/03/21 20:17:48 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/17 23:25:05 1.23 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.22 2007/03/21 20:17:48 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.23 2008/03/17 23:25:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -312,6 +312,18 @@ result))) (t (error "mapcar not fully implemented.")))) + +(defun mapcan (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (cond + ((null more-lists) + ;; 1 list + (do ((result nil) + (p first-list (cdr p))) + ((endp p) result) + (setf result (nconc result (funcall function (car p)))))) + (t (error "~S not implemented." 'mapcan)))) + (defun mapc (function first-list &rest more-lists) (numargs-case (2 (function first-list)

1 0