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

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

16 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6674 Modified Files: basic-macros.lisp Log Message: Working on making macros work. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/15 20:57:16 1.71 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/16 22:28:07 1.72 @@ -9,68 +9,14 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.71 2008/03/15 20:57:16 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.72 2008/03/16 22:28:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :muerte/basic-macros) -;; First of all we must define DEFMACRO.. -(muerte::defmacro-compile-time muerte.cl:defmacro (name lambda-list &body macro-body) - (`(muerte.cl:progn - (muerte::defmacro-compile-time ,name ,lambda-list ,macro-body) - ',name))) - -(muerte.cl:defmacro muerte.cl:in-package (name) - `(progn - (eval-when (:compile-toplevel) - (in-package ,(movitz::movitzify-package-name name))))) - (in-package muerte) -(defmacro defmacro/cross-compilation (name lambda-list &body body) - `(progn - (defmacro-compile-time ,name ,lambda-list ,body) - ',name)) - -(defmacro defmacro (name lambda-list &body body) - `(defmacro/cross-compilation ,name ,lambda-list ,@body)) - -(defmacro defmacro/runtime (name lambda-list &body body) - (multiple-value-bind (real-body declarations docstring) - (movitz::parse-docstring-declarations-and-body body 'cl:declare) - (let* ((block-name (compute-function-block-name name)) - (ignore-var (gensym)) - (form-var (gensym "form-")) - (env-var nil) - (operator-var (gensym)) - (destructuring-lambda-list - (do ((l lambda-list) - (r nil)) - ((atom l) - (cons operator-var - (nreconc r l))) - (let ((x (pop l))) - (if (eq x '&environment) - (setf env-var (pop l)) - (push x r)))))) - (multiple-value-bind (env-var ignore-env) - (if env-var - (values env-var nil) - (let ((e (gensym))) - (values e (list e)))) - `(make-named-function ,name - (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) - ((ignore ,ignore-var ,@ignore-env)) - ,docstring - (block ,block-name - (verify-macroexpand-call edx ',name) - (destructuring-bind ,destructuring-lambda-list - ,form-var - (declare (ignore ,operator-var) ,@declarations) - ,@real-body)) - :type :macro-function))))) - (defmacro defun (function-name lambda-list &body body) "Define a function." (multiple-value-bind (real-body declarations docstring)

1 0

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

16 Mar '08

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv6583 Modified Files: compiler.lisp Log Message: Make code-uses-binding-p not barf on certain labels forms. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/15 00:21:38 1.195 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/16 22:27:54 1.196 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.195 2008/03/15 00:21:38 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.196 2008/03/16 22:27:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3160,16 +3160,37 @@ (defun code-uses-binding-p (code binding &key (load t) store call) "Does extended <code> potentially read/write/call <binding>?" - (labels ((search-funobj (funobj binding load store call) + (labels ((search-funobj (funobj binding load store call path) ;; If this is a recursive lexical call (i.e. labels), ;; the function-envs might not be bound, but then this ;; code is searched already. - (when (slot-boundp funobj 'function-envs) - (some (lambda (function-env-spec) - (code-search (extended-code (cdr function-env-spec)) binding - load store call)) - (function-envs funobj)))) - (code-search (code binding load store call) + (if (member funobj path) + nil + (when (slot-boundp funobj 'function-envs) + (some (lambda (function-env-spec) + (or (not (slot-boundp (cdr function-env-spec) 'extended-code)) ; Don't know yet, assume yes. + (code-search (extended-code (cdr function-env-spec)) binding + load store call + (cons funobj path)))) + (function-envs funobj)))) + #+ignore + (if (member funobj path) + nil + (let* ((memo (assoc funobj memos)) + (x (cdr (or memo + (car (push (cons funobj + (when (slot-boundp funobj 'function-envs) + (some (lambda (function-env-spec) + (or (not (slot-boundp (cdr function-env-spec) 'extended-code)) ; Don't know yet, assume yes. + (code-search (extended-code (cdr function-env-spec)) + binding + load store call + (cons funobj path)))) + (function-envs funobj)))) + memos)))))) + (warn "search ~S ~S: ~S" funobj binding x) + x))) + (code-search (code binding load store call path) (dolist (instruction code) (when (consp instruction) (let ((x (or (when load @@ -3183,7 +3204,9 @@ (case (car instruction) (:local-function-init (search-funobj (function-binding-funobj (second instruction)) - binding load store call)) + binding + load store call + path)) (:load-lambda (or (when load (binding-eql binding (second instruction))) @@ -3193,16 +3216,22 @@ (typep allocation 'with-dynamic-extent-scope-env)) (binding-eql binding (base-binding allocation)))) (search-funobj (function-binding-funobj (second instruction)) - binding load store call))) + binding + load store call + path))) (:call-lexical (or (when call (binding-eql binding (second instruction))) (search-funobj (function-binding-funobj (second instruction)) - binding load store call)))) + binding + load store call + path)))) (code-search (instruction-sub-program instruction) - binding load store call)))) + binding + load store call + path)))) (when x (return t))))))) - (code-search code binding load store call))) + (code-search code binding load store call nil))) (defun bindingp (x) (typep x 'binding))

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 15 Mar '08

15 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv3749 Modified Files: textmode.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2007/04/09 16:05:25 1.17 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2008/03/15 20:58:30 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.17 2007/04/09 16:05:25 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.18 2008/03/15 20:58:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -196,7 +196,7 @@ (defun write-word-bottom3 (word) (write-word-lowlevel word #.(cl:+ 140 #xb8000 (cl:* 24 160)))) -(defmacro write-word-lowlevel-macro (word dest) +(define-compiler-macro write-word-lowlevel-macro (word dest) (let ((loop-label (make-symbol "write-word-loop")) (l1 (make-symbol "write-word-l1")) (l2 (make-symbol "write-word-l2"))

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3653 Modified Files: typep.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2006/05/06 20:29:10 1.54 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/03/15 20:58:24 1.55 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.54 2006/05/06 20:29:10 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.55 2008/03/15 20:58:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -265,6 +265,8 @@ (std-instance (make-other-typep :std-instance) #+ignore (make-tag-typep :std-instance)) + (macro-function + (make-function-typep :macro-function)) (standard-gf-instance (make-function-typep :generic-function)) (list @@ -648,6 +650,9 @@ (define-simple-typep (function functionp) (x) (typep x 'function)) +(define-simple-typep (macro-function macro-function-p) (x) + (typep x 'macro-function)) + (define-simple-typep (hash-table hash-table-p)) (define-simple-typep (package packagep))

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3615 Modified Files: simple-streams.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/simple-streams.lisp 2005/06/10 18:35:44 1.8 +++ /project/movitz/cvsroot/movitz/losp/muerte/simple-streams.lisp 2008/03/15 20:58:20 1.9 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 29 13:39:43 2003 ;;;; -;;;; $Id: simple-streams.lisp,v 1.8 2005/06/10 18:35:44 ffjeld Exp $ +;;;; $Id: simple-streams.lisp,v 1.9 2008/03/15 20:58:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,7 +60,7 @@ ,@(cdr dual-clause)) (t ,@(cdr string-clause)))))))) -(defmacro with-stream-class ((class-name &optional stream) &body body) +(defmacro/cross-compilation with-stream-class ((class-name &optional stream) &body body) (if stream (let ((stream-var (gensym "stream-")) (slots-var (gensym "stream-slots-")))

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3576 Modified Files: sequences.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 20:14:45 1.37 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/03/15 20:58:17 1.38 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.37 2007/04/07 20:14:45 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.38 2008/03/15 20:58:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -46,11 +46,13 @@ (defmacro sequence-double-dispatch ((seq0 seq1) &rest clauses) `(case (logior (if (typep ,seq0 'list) 2 0) (if (typep ,seq1 'list) 1 0)) - ,@(loop for ((type0 type1) . forms) in clauses - as index = (logior (ecase type0 (list 2) (vector 0)) - (ecase type1 (list 1) (vector 0))) - collect - `(,index ,@forms)) + ,@(mapcar (lambda (clause) + (destructuring-bind ((type0 type1) . forms) + clause + (list* (logior (ecase type0 (list 2) (vector 0)) + (ecase type1 (list 1) (vector 0))) + forms))) + clauses) (t (sequence-double-dispatch-error ,seq0 ,seq1)))) (defun length (sequence)

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3550 Modified Files: print.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2006/05/02 20:04:15 1.23 +++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2008/03/15 20:58:15 1.24 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.23 2006/05/02 20:04:15 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.24 2008/03/15 20:58:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -230,29 +230,31 @@ ((or cons tag5) (let ((level *print-level*)) (cond - ((and level (minusp level)) - (write-char #\# stream)) - ((and (eq 'quote (car object)) - (not (cddr object))) - (write-char #\' stream) - (write (cadr object))) - (t (labels ((write-cons (c stream length) - (cond - ((and length (= 0 length)) - (write-string "...)")) - (t (write (car c)) - (typecase (cdr c) - (null - (write-char #\) stream)) - (cons - (write-char #\space stream) - (write-cons (cdr c) stream (minus-if length 1))) - (t - (write-string " . " stream) - (write (cdr c)) - (write-char #\) stream))))))) - (write-char #$ stream) - (write-cons object stream *print-length*)))))) + ((and (not do-escape-p) + level + (minusp level)) + (write-char #\# stream)) + ((and (eq 'quote (car object)) + (not (cddr object))) + (write-char #\' stream) + (write (cadr object))) + (t (labels ((write-cons (c stream length) + (cond + ((and length (= 0 length)) + (write-string "...)")) + (t (write (car c)) + (typecase (cdr c) + (null + (write-char #$ stream)) + (cons + (write-char #\space stream) + (write-cons (cdr c) stream (minus-if length 1))) + (t + (write-string " . " stream) + (write (cdr c)) + (write-char #\) stream))))))) + (write-char #\( stream) + (write-cons object stream *print-length*)))))) (integer (write-integer object stream *print-base* *print-radix*)) (string @@ -326,6 +328,9 @@ (standard-gf-instance (print-unreadable-object (object stream) (format stream "gf ~S" (funobj-name object)))) + (macro-function + (print-unreadable-object (object stream) + (format stream "macro-function ~S" (funobj-name object)))) (compiled-function (print-unreadable-object (object stream) (format stream "function ~S" (funobj-name object))))

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3459 Modified Files: primitive-functions.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2007/02/19 21:58:27 1.69 +++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2008/03/15 20:58:08 1.70 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.69 2007/02/19 21:58:27 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.70 2008/03/15 20:58:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,11 +72,9 @@ ,docstring (with-inline-assembly (:returns :nothing) (:movl :esi :edx) ; parameter for standard-gf-function. - (:movl (:esi ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf - (intern (symbol-name to) :movitz))) + (:movl (:esi (:offset movitz-funobj-standard-gf ,to)) :esi) - (:jmp (:esi ,(bt:slot-offset 'movitz::movitz-funobj - (intern (symbol-name forward) :movitz))))))) + (:jmp (:esi (:offset movitz-funobj ,forward)))))) (define-gf-dispatcher standard-gf-dispatcher () "The code-vector of standard-gf instances." code-vector standard-gf-function) @@ -582,6 +580,8 @@ (find-class 'function)) (structure-object (structure-object-class object)) + (macro-function + (find-class 'macro-function)) (character (find-class 'character)) (null

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3408 Modified Files: more-macros.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/08 14:03:35 1.39 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/15 20:58:06 1.40 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.39 2008/03/08 14:03:35 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.40 2008/03/15 20:58:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -171,6 +171,8 @@ ((or (pop-match '&rest sub-lambda-list) (pop-match '&body sub-lambda-list)) (gen-restvar var sub-lambda-list)) + ((pop-match '&key sub-lambda-list) + (gen-keyvars var sub-lambda-list)) ((pop-match '&aux sub-lambda-list) (dolist (b sub-lambda-list) (push b bindings))) @@ -294,47 +296,6 @@ (return p)))) (t form)))) -(defmacro letf* (bindings &body body &environment env) - "Does what one might expect, saving the old values and setting the generalized - variables to the new values in sequence. Unwind-protects and get-setf-method - are used to preserve the semantics one might expect in analogy to let*, - and the once-only evaluation of subforms." - (labels ((do-bindings - (bindings) - (cond ((null bindings) body) - (t (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion (caar bindings) env) - (let ((save (gensym))) - `((let* (,@(mapcar #'list dummies vals) - (,(car newval) ,(cadar bindings)) - (,save ,getter)) - (unwind-protect - (progn ,setter - ,@(do-bindings (cdr bindings))) - (setq ,(car newval) ,save) - ,setter))))))))) - (car (do-bindings bindings)))) - -(defmacro with-letf (clauses &body body) - "Each clause is (<place> &optional <value-form> <prev-var>). -Execute <body> with alternative values for each <place>. -Note that this scheme does not work well with respect to multiple threads. -XXX This should actually be using get-setf-expansion etc. to deal with -proper evaluation of the places' subforms." - (let ((place-value-save (loop for (place . value-save) in clauses - if value-save - collect (list place `(progn ,(first value-save)) - (or (second value-save) (gensym))) - else collect (list place nil (gensym))))) - `(let (,@(loop for (place nil save-var) in place-value-save - collect `(,save-var ,place))) - (unwind-protect - (progn (setf ,@(loop for (place value) in place-value-save - append `(,place ,value))) - ,@body) - (setf ,@(loop for (place nil save) in place-value-save - append `(,place ,save))))))) - (defmacro with-alternative-fdefinitions (clauses &body body) "Each clause is (<name> <definition>). Execute <body> with alternative fdefinitions for each <name>. Note that this scheme does not work well with

1 0

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

15 Mar '08

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3329 Modified Files: los-closette.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2007/03/11 22:43:14 1.37 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2008/03/15 20:57:57 1.38 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.37 2007/03/11 22:43:14 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.38 2008/03/15 20:57:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -873,7 +873,7 @@ (equal '(:around) (method-qualifiers method))) -(defmacro define-effective-slot-reader (name location) +(defmacro/cross-compilation define-effective-slot-reader (name location) (if movitz::*compiler-use-into-unbound-protocol* `(defun ,name (instance) (with-inline-assembly (:returns :multiple-values) @@ -1002,6 +1002,7 @@ (defclass funcallable-standard-class (std-slotted-class) ()) (defclass function (t) () (:metaclass built-in-class)) +(defclass macro-function (function) () (:metaclass built-in-class)) (defclass funcallable-standard-object (standard-object function) ()) (defclass generic-function (metaobject funcallable-standard-object) ()) (defclass standard-generic-function (generic-function)

1 0