[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Mon Mar 17 17:24:50 UTC 2008
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv17049
Modified Files:
basic-macros.lisp
Log Message:
Make (in principle) all macros compiled into run-time. There are notable exceptions still, which need to be worked on.
--- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/16 22:28:07 1.72
+++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/17 17:24:45 1.73
@@ -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.72 2008/03/16 22:28:07 ffjeld Exp $
+;;;; $Id: basic-macros.lisp,v 1.73 2008/03/17 17:24:45 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -128,7 +128,7 @@
`(declaim (special ,name))
`(defparameter ,name ,value ,documentation)))
-(defmacro define-compile-time-variable (name value)
+(defmacro/cross-compilation define-compile-time-variable (name value)
(let ((the-value (eval value)))
`(progn
(eval-when (:compile-toplevel)
@@ -139,7 +139,7 @@
(eval-when (:load-toplevel :excute)
(defvar ,name 'uninitialized-compile-time-variable)))))
-(defmacro let* (var-list &body declarations-and-body)
+(defmacro/cross-compilation let* (var-list &body declarations-and-body)
(multiple-value-bind (body declarations)
(movitz::parse-declarations-and-body declarations-and-body 'cl:declare)
(labels ((expand (rest-vars body)
@@ -185,15 +185,19 @@
(0 nil)
(2 `(setq ,(first pairs) ,(second pairs)))
(t (multiple-value-bind (setq-specs let-specs)
- (loop for (var form) on pairs by #'cddr
- as temp-var = (gensym)
- collect (list temp-var form) into let-specs
- collect var into setq-specs
- collect temp-var into setq-specs
- finally (return (values setq-specs let-specs)))
- `(let ,(butlast let-specs)
- (setq ,@(last pairs 2) ,@(butlast setq-specs 2)))))))
-
+ (do (ss ls (p pairs))
+ ((endp p)
+ (values (nreverse ss)
+ (nreverse ls)))
+ (let ((var (pop p))
+ (form (pop p))
+ (temp-var (gensym)))
+ (push (list temp-var form) ls)
+ (push var ss)
+ (push temp-var ss)))
+ `(let ,let-specs
+ (setq , at setq-specs))))))
+
(defmacro return (&optional (result-form nil result-form-p))
(if result-form-p
`(return-from nil ,result-form)
@@ -235,7 +239,7 @@
(unless ,end-test-form (go ,loop-tag)))
, at result-forms))))))
-(defmacro do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body)
+(defmacro/cross-compilation do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body)
(flet ((var-spec-let-spec (var-spec)
(cond
((symbolp var-spec)
@@ -300,26 +304,23 @@
(defmacro case (keyform &rest clauses)
- (flet ((otherwise-clause-p (x)
- (member (car x) '(t otherwise))))
- (let ((key-var (make-symbol "case-key-var")))
- `(let ((,key-var ,keyform))
- (cond
- ,@(loop for clause-head on clauses
- as clause = (first clause-head)
- as keys = (first clause)
- as forms = (rest clause)
- ;; do (warn "clause: ~S, op: ~S" clause (otherwise-clause-p clause))
- if (and (endp (rest clause-head)) (otherwise-clause-p clause))
- collect (cons t forms)
- else if (otherwise-clause-p clause)
- do (error "Case's otherwise clause must be the last clause.")
- else if (atom keys)
- collect `((eql ,key-var ',keys) , at forms)
- else collect `((or ,@(mapcar #'(lambda (c)
- `(eql ,key-var ',c))
- keys))
- , at forms)))))))
+ (let ((key-var (make-symbol "case-key-var")))
+ `(let ((,key-var ,keyform))
+ (cond
+ ,@(mapcar (lambda (clause)
+ (destructuring-bind (keys . forms)
+ clause
+ (cond
+ ((or (eq keys 't)
+ (eq keys 'otherwise))
+ `(t , at forms))
+ ((atom keys)
+ `((eql ,key-var ',keys) , at forms))
+ (t `((or ,@(mapcar (lambda (k)
+ `(eql ,key-var ',k))
+ keys))
+ , at forms)))))
+ clauses)))))
(define-compiler-macro case (keyform &rest clauses)
(case (length clauses)
@@ -347,7 +348,7 @@
`(with-inline-assembly (:returns :eax)
(:movl ,register-name :eax))))
-(defmacro movitz-accessor (object-form type slot-name)
+(defmacro/cross-compilation movitz-accessor (object-form type slot-name)
(warn "movitz-accesor deprecated.")
`(with-inline-assembly (:returns :register :side-effects nil)
(:compile-form (:result-mode :eax) ,object-form)
@@ -356,7 +357,7 @@
(find-symbol (string slot-name) :movitz)))
(:result-register))))
-(defmacro setf-movitz-accessor ((object-form type slot-name) value-form)
+(defmacro/cross-compilation setf-movitz-accessor ((object-form type slot-name) value-form)
(warn "setf-movitz-accesor deprecated.")
`(with-inline-assembly (:returns :eax :side-effects t)
(:compile-two-forms (:eax :ebx) ,value-form ,object-form)
@@ -364,23 +365,23 @@
:movl :eax (:ebx ,(bt:slot-offset (find-symbol (string type) :movitz)
(find-symbol (string slot-name) :movitz))))))
-(defmacro movitz-accessor-u16 (object-form type slot-name)
- `(with-inline-assembly (:returns :eax)
- (:compile-form (:result-mode :eax) ,object-form)
- (:movzxw (:eax ,(bt:slot-offset (find-symbol (string type) :movitz)
- (find-symbol (string slot-name) :movitz)))
- :ecx)
- (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*)))
- :eax)))
-
-(defmacro set-movitz-accessor-u16 (object-form type slot-name value)
- `(with-inline-assembly (:returns :eax)
- (:compile-two-forms (:eax :ecx) ,object-form ,value)
- (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
- (:movw :cx (:eax ,(bt:slot-offset (find-symbol (string type) :movitz)
- (find-symbol (string slot-name) :movitz))))
- (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*)))
- :eax)))
+;; (defmacro movitz-accessor-u16 (object-form type slot-name)
+;; `(with-inline-assembly (:returns :eax)
+;; (:compile-form (:result-mode :eax) ,object-form)
+;; (:movzxw (:eax ,(bt:slot-offset (find-symbol (string type) :movitz)
+;; (find-symbol (string slot-name) :movitz)))
+;; :ecx)
+;; (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*)))
+;; :eax)))
+
+;; (defmacro set-movitz-accessor-u16 (object-form type slot-name value)
+;; `(with-inline-assembly (:returns :eax)
+;; (:compile-two-forms (:eax :ecx) ,object-form ,value)
+;; (:shrl ,movitz::+movitz-fixnum-shift+ :ecx)
+;; (:movw :cx (:eax ,(bt:slot-offset (find-symbol (string type) :movitz)
+;; (find-symbol (string slot-name) :movitz))))
+;; (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*)))
+;; :eax)))
(define-compiler-macro movitz-type-word-size (type &environment env)
(if (not (movitz:movitz-constantp type env))
@@ -476,13 +477,12 @@
`(block nil (let* ,variable-list (declare , at declarations) (tagbody , at body)))))
(defmacro multiple-value-setq (vars form)
- (let ((tmp-vars (loop repeat (length vars) collect (gensym))))
+ (let ((tmp-vars (mapcar (lambda (v)
+ (declare (ignore v))
+ (gensym))
+ vars)))
`(multiple-value-bind ,tmp-vars ,form
- (setq ,@(loop for v in vars and tmp in tmp-vars collect v collect tmp)))))
-
-;;;(defmacro declaim (&rest declarations)
-;;; (movitz::movitz-env-load-declarations declarations nil :declaim)
-;;; (values))
+ (setq ,@(mapcan #'list vars tmp-vars)))))
(define-compiler-macro defconstant (name initial-value &optional documentation)
(declare (ignore documentation))
@@ -504,7 +504,7 @@
(symbol-value movitz-name) movitz-value)))
(declaim (muerte::constant-variable ,name))))
-(defmacro define-symbol-macro (symbol expansion)
+(defmacro/cross-compilation define-symbol-macro (symbol expansion)
(check-type symbol symbol "a symbol-macro symbol")
`(progn
(eval-when (:compile-toplevel)
@@ -672,7 +672,7 @@
(t form)))
-(defmacro with-unbound-protect (x &body error-continuation &environment env)
+(defmacro/cross-compilation with-unbound-protect (x &body error-continuation &environment env)
(cond
((movitz:movitz-constantp x env)
`(values ,x))
@@ -877,7 +877,7 @@
(defmacro lambda (&whole form)
`(function ,form))
-(defmacro backquote (form)
+(defmacro/cross-compilation backquote (form)
(typecase form
(list
(if (eq 'backquote-comma (car form))
@@ -937,7 +937,7 @@
(:andl #x7 :ecx)
(:call (:edi (:ecx 4) ,(movitz::global-constant-offset 'fast-class-of)))))
-(defmacro std-instance-reader (slot instance-form)
+(defmacro/cross-compilation std-instance-reader (slot instance-form)
(let ((slot (intern (symbol-name slot) :movitz)))
`(with-inline-assembly-case ()
(do-case (:ecx)
@@ -953,7 +953,7 @@
:movl ((:result-register) ,(bt:slot-offset 'movitz::movitz-std-instance slot))
(:result-register))))))
-(defmacro std-instance-writer (slot value instance-form)
+(defmacro/cross-compilation std-instance-writer (slot value instance-form)
(let ((slot (intern (symbol-name slot) :movitz)))
`(with-inline-assembly-case ()
(do-case (t :eax)
@@ -1016,17 +1016,17 @@
(defmacro spin-wait-pause ())
-(defmacro capture-reg8 (reg)
- `(with-inline-assembly (:returns :eax)
- (:movzxb ,reg :eax)
- (:shll ,movitz::+movitz-fixnum-shift+ :eax)))
+;; (defmacro capture-reg8 (reg)
+;; `(with-inline-assembly (:returns :eax)
+;; (:movzxb ,reg :eax)
+;; (:shll ,movitz::+movitz-fixnum-shift+ :eax)))
-(defmacro asm (&rest prg)
+(define-compiler-macro asm (&rest prg)
"Insert a single assembly instruction that returns noting."
`(with-inline-assembly (:returns :nothing)
,prg))
-(defmacro asm1 (&rest prg)
+(define-compiler-macro asm1 (&rest prg)
"Insert a single assembly instruction that returns a value in eax."
`(with-inline-assembly (:returns :eax)
,prg))
More information about the Movitz-cvs
mailing list