From ffjeld at common-lisp.net Wed Apr 2 20:47:10 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 2 Apr 2008 15:47:10 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080402204710.1C2BD2413B@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv16740 Modified Files: storage-types.lisp Log Message: Set an appropriate value (i.e. scannable) for the :run-time-context tag. --- /project/movitz/cvsroot/movitz/storage-types.lisp 2008/03/23 12:19:19 1.62 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2008/04/02 20:47:09 1.63 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.62 2008/03/23 12:19:19 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.63 2008/04/02 20:47:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,7 +68,8 @@ :null 5 :other 6 :symbol 7 - + + ;; The lower 3 bits of these are significant in mysterious ways. :basic-vector #x22 :defstruct #x2a :funobj #x3a @@ -76,7 +77,7 @@ :ratio #x52 :complex #x5a :std-instance #x40 - :run-time-context #x50 + :run-time-context #x62 :illegal #x13 :infant-object #x23 :basic-restart #x32 @@ -342,9 +343,10 @@ :u8 2 :u16 3 :u32 4 - :bit 5 - :code 6 - :indirects 7) + :stack 5 + :bit 6 + :code 7 + :indirects 8) :initarg :element-type :reader movitz-vector-element-type) (fill-pointer @@ -396,7 +398,7 @@ (defun movitz-vector-element-type-size (element-type) (ecase element-type - ((:any-t :u32) 32) + ((:any-t :u32 :stack) 32) ((:character :u8 :code) 8) (:u16 16) (:bit 1))) From ffjeld at common-lisp.net Wed Apr 2 20:49:30 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 2 Apr 2008 15:49:30 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080402204930.313C46923E@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv17424 Modified Files: image.lisp Log Message: Add the stack-vector type, because we need to be able to recognize a stack at GC-time. --- /project/movitz/cvsroot/movitz/image.lisp 2008/03/20 22:24:06 1.118 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/02 20:49:30 1.119 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.118 2008/03/20 22:24:06 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.119 2008/04/02 20:49:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -957,7 +957,7 @@ :num-elements #x3ffe :fill-pointer 0 :symbolic-data nil - :element-type :u32)) + :element-type :stack)) (image-start (file-position stream))) (dump-image-core *image* stream) ; dump the kernel proper. ;; make a stack-vector for the root run-time-context From ffjeld at common-lisp.net Wed Apr 2 20:49:33 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 2 Apr 2008 15:49:33 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080402204933.C8F174E030@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv17461 Modified Files: packages.lisp Log Message: Add the stack-vector type, because we need to be able to recognize a stack at GC-time. --- /project/movitz/cvsroot/movitz/packages.lisp 2008/03/20 22:23:28 1.58 +++ /project/movitz/cvsroot/movitz/packages.lisp 2008/04/02 20:49:33 1.59 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.58 2008/03/20 22:23:28 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.59 2008/04/02 20:49:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1105,6 +1105,8 @@ #:newline #:check-the #:index + #:make-stack-vector + #:stack-vector #:defmacro/cross-compilation From ffjeld at common-lisp.net Wed Apr 2 20:49:35 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 2 Apr 2008 15:49:35 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/lib Message-ID: <20080402204935.3D0884E026@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv17518 Modified Files: threading.lisp Log Message: Add the stack-vector type, because we need to be able to recognize a stack at GC-time. --- /project/movitz/cvsroot/movitz/losp/lib/threading.lisp 2007/03/12 22:50:34 1.9 +++ /project/movitz/cvsroot/movitz/losp/lib/threading.lisp 2008/04/02 20:49:35 1.10 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Apr 28 08:30:01 2005 ;;;; -;;;; $Id: threading.lisp,v 1.9 2007/03/12 22:50:34 ffjeld Exp $ +;;;; $Id: threading.lisp,v 1.10 2008/04/02 20:49:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -89,8 +89,7 @@ (setf (segment-descriptor-base-location (segment-descriptor-table *segment-descriptor-table-manager*) segment-selector) (+ (object-location thread) (location-physical-offset))) - (let ((stack (control-stack-init-for-yield (make-array stack-size - :element-type '(unsigned-byte 32)) + (let ((stack (control-stack-init-for-yield (make-stack-vector stack-size) function args))) (multiple-value-bind (ebp esp) (control-stack-fixate stack) From ffjeld at common-lisp.net Wed Apr 2 20:49:42 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 2 Apr 2008 15:49:42 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080402204942.4AEB0111DC@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv17546 Modified Files: arrays.lisp Log Message: Add the stack-vector type, because we need to be able to recognize a stack at GC-time. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/03/15 20:57:12 1.65 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/04/02 20:49:37 1.66 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.65 2008/03/15 20:57:12 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.66 2008/04/02 20:49:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -194,11 +194,12 @@ ((#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) #.(bt:enum-value 'movitz::movitz-vector-element-type :indirects)) (%shallow-copy-object vector (+ 2 length))) - ((#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)) + ((#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) + #.(bt:enum-value 'movitz::movitz-vector-element-type :stack)) (%shallow-copy-non-pointer-object vector (+ 2 length))) ((#.(bt:enum-value 'movitz::movitz-vector-element-type :character) - #.(bt:enum-value 'movitz::movitz-vector-element-type :u8) - #.(bt:enum-value 'movitz::movitz-vector-element-type :code)) + #.(bt:enum-value 'movitz::movitz-vector-element-type :u8) + #.(bt:enum-value 'movitz::movitz-vector-element-type :code)) (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 3 length) 4)))) ((#.(bt:enum-value 'movitz::movitz-vector-element-type :u16)) (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 1 length) 2)))) @@ -321,9 +322,9 @@ `(with-inline-assembly (:returns :eax) (:declare-label-set basic-vector-dispatcher - ,(loop with x = (make-list 8 :initial-element 'unknown) - for et in '(:any-t :character :u8 :u32 :code :bit) - do (setf (elt x (bt:enum-value + ,(loop with x = (make-list 9 :initial-element 'unknown) + for et in '(:any-t :character :u8 :u32 :stack :code :bit) + do (setf (elt x (bt:enum-value 'movitz::movitz-vector-element-type et)) et) @@ -350,6 +351,7 @@ (:jnever '(:sub-program (unknown) (:int 100))) :u32 + :stack (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) :ecx) (:call-local-pf box-u32-ecx) @@ -949,13 +951,23 @@ (setf (fill-pointer array) length))) (cond (initial-element - ;; (check-type initial-element (unsigned-byte 32)) + (check-type initial-element (unsigned-byte 32)) (dotimes (i length) (setf (u32ref%unsafe array i) initial-element))) (initial-contents (replace array initial-contents))) array)) +(defun make-stack-vector (length) + (let ((vector (make-basic-vector%u32 length nil nil nil))) + (with-inline-assembly (:returns :nothing) + (:load-lexical (:lexical-binding vector) :eax) + (:movl #.(movitz:basic-vector-type-tag :stack) + (:eax (:offset movitz-basic-vector type)))) + (when (%basic-vector-has-fill-pointer-p vector) + (setf (fill-pointer vector) length)) + vector)) + (defun make-basic-vector%u8 (length fill-pointer initial-element initial-contents) (check-type length (and fixnum (integer 0 *))) (let* ((words (+ 2 (truncate (+ length 3) 4))) From ffjeld at common-lisp.net Wed Apr 2 20:49:45 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 2 Apr 2008 15:49:45 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080402204945.7DF467C072@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv17688 Modified Files: inspect.lisp Log Message: Add the stack-vector type, because we need to be able to recognize a stack at GC-time. --- /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/12 16:10:47 1.60 +++ /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2008/04/02 20:49:44 1.61 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.60 2007/04/12 16:10:47 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.61 2008/04/02 20:49:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -91,7 +91,7 @@ Otherwise, stack-frame is an absolute location." (cond ((not (null stack)) - (check-type stack (simple-array (unsigned-byte 32) 1)) + (check-type stack stack-vector) (let ((pos (+ frame index))) (assert (< -1 pos (length stack)) () "Index ~S, pos ~S, len ~S" index pos (length stack)) @@ -101,7 +101,7 @@ (defun (setf stack-frame-ref) (value stack frame index &optional (type ':lisp)) (cond ((not (eq nil stack)) - (check-type stack (simple-array (unsigned-byte 32) 1)) + (check-type stack stack-vector) (let ((pos (+ frame index))) (assert (< -1 pos (length stack)) () "Index ~S, pos ~S, len ~S" index pos (length stack)) @@ -420,7 +420,9 @@ (+ -1 object-location (movitz-type-word-size :movitz-funobj) (funobj-num-constants object)))) - ((or string code-vector (simple-array (unsigned-byte 8) 1)) + ((or string + code-vector + (simple-array (unsigned-byte 8) 1)) (<= object-location location (+ -1 object-location @@ -432,7 +434,9 @@ (+ -1 object-location (movitz-type-word-size 'movitz-basic-vector) (* 2 (truncate (+ (array-dimension object 0) 3) 4))))) - ((or simple-vector (simple-array (unsigned-byte 32) 1)) + ((or simple-vector + (simple-array (unsigned-byte 32) 1) + stack-vector) (<= object-location location (+ -1 object-location From ffjeld at common-lisp.net Wed Apr 2 20:49:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 2 Apr 2008 15:49:48 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080402204948.2BAB27514D@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv17763 Modified Files: typep.lisp Log Message: Add the stack-vector type, because we need to be able to recognize a stack at GC-time. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/03/20 22:22:40 1.56 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/02 20:49:47 1.57 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.56 2008/03/20 22:22:40 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.57 2008/04/02 20:49:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -287,6 +287,8 @@ (make-other-typep :funobj)) ((vector) (make-other-typep :basic-vector)) + (stack-vector + (make-basic-vector-typep :stack)) (indirect-vector (make-basic-vector-typep :indirects)) (simple-vector From ffjeld at common-lisp.net Tue Apr 8 20:20:07 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 8 Apr 2008 16:20:07 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080408202007.E36253001B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12013 Modified Files: sequences.lisp Log Message: Fix typo in find-if-not. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/03/21 22:17:06 1.39 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/08 20:20:07 1.40 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.39 2008/03/21 22:17:06 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.40 2008/04/08 20:20:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1013,7 +1013,7 @@ (defun find-if-not (predicate sequence &rest key-args) (declare (dynamic-extent key-args)) - (apply (complement predicate) sequence key-args)) + (apply #'find-if (complement predicate) sequence key-args)) (defun count (item sequence &key (start 0) end (test 'eql) (key 'identity) test-not from-end) (declare (ignore test-not)) From ffjeld at common-lisp.net Tue Apr 8 21:39:52 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 8 Apr 2008 17:39:52 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080408213952.B3F5A2B063@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3556 Modified Files: eval.lisp Log Message: In eval, support lambda-forms, and &aux bindings. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/21 22:27:17 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/08 21:39:52 1.29 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.28 2008/03/21 22:27:17 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.29 2008/04/08 21:39:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,6 +54,7 @@ (defconstant +eval-binding-type-go-tag+ 1) (defconstant +eval-binding-type-block+ 2) (defconstant +eval-binding-type-macrolet+ 3) +(defconstant +eval-binding-type-declaration+ 4) (defun eval-symbol (form env) "3.1.2.1.1 Symbols as Forms" @@ -79,80 +80,98 @@ (defun eval-cons (form env) "3.1.2.1.2 Conses as Forms" - (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))) - ((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))) - ((symbol-macrolet let*) - (error "Special operator ~S not implemented in ~S." (car form) 'eval)) - (t (eval-funcall form env)))) + (if (and (consp (car form)) + (eq 'lambda (caar form))) + (eval-funcall (cons (let ((lambda-list (cadar form)) + (lambda-body (parse-docstring-declarations-and-body (cddar form)))) + (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)))) + (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))) + ((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))) + ((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))))) (defun eval-progn (forms env) (do ((p forms (cdr p))) @@ -165,17 +184,17 @@ a0 a1) (if (null form) (funcall f) - (if (null (progn (setf a0 (eval-form (pop form) env)) form)) - (funcall f a0) - (if (null (progn (setf a1 (eval-form (pop form) env)) form)) - (funcall f a0 a1) - (apply (lambda (f env a0 a1 &rest args) - (declare (dynamic-extent args)) - (let ((evaluated-args (do ((p args (cdr p))) - ((endp p) args) - (setf (car p) (eval-form (car p) env))))) - (apply f a0 a1 evaluated-args))) - f env a0 a1 form)))))) + (if (null (progn (setf a0 (eval-form (pop form) env)) form)) + (funcall f a0) + (if (null (progn (setf a1 (eval-form (pop form) env)) form)) + (funcall f a0 a1) + (apply (lambda (f env a0 a1 &rest args) + (declare (dynamic-extent args)) + (let ((evaluated-args (do ((p args (cdr p))) + ((endp p) args) + (setf (car p) (eval-form (car p) env))))) + (apply f a0 a1 evaluated-args))) + f env a0 a1 form)))))) (defun parse-declarations-and-body (forms) "From the list of FORMS, return first the list of non-declaration forms, ~ @@ -259,7 +278,7 @@ (eq '&environment (car pattern))) (setf env-var (cadr pattern) pattern (cddr pattern))) - (loop with next-states = '(&optional &rest &key) + (loop with next-states = '(&optional &rest &key &aux) with state = 'requireds for pp on pattern as p = (car pp) if (member p next-states) @@ -313,7 +332,14 @@ present-p) env)) (push (cons var value) - env)))))) + env)))) + (&aux + (multiple-value-bind (var init-form) + (if (consp p) + (values (car p) (cadr p)) + (values p nil)) + (push (cons var (eval-form init-form env)) + env))))) (t (error "Illegal destructuring pattern: ~S" pattern))) (when (not (listp (cdr pp))) (push (cons (cdr pp) values) @@ -519,25 +545,26 @@ (defun macroexpand-1 (form &optional env) (if (atom form) (values form nil) ; no symbol-macros yet - (let* ((operator (car form)) - (macrolet-binding (op-env-binding env operator +eval-binding-type-macrolet+))) - (if macrolet-binding - (destructuring-bind (lambda-list &body body) - (cddr macrolet-binding) - (let ((expander (lambda (form env) - (eval-form `(destructuring-bind (ignore-operator , at lambda-list) - ',form - (declare (ignore ignore-operator)) - , at body) - env)))) - (values (funcall *macroexpand-hook* expander form env) - t))) - (let ((macro-function (macro-function operator))) - (if macro-function - (values (funcall *macroexpand-hook* macro-function form env) - t) - (values form - nil))))))) + (let ((operator (car form))) + (when (symbolp operator) + (let ((macrolet-binding (op-env-binding env operator +eval-binding-type-macrolet+))) + (if macrolet-binding + (destructuring-bind (lambda-list &body body) + (cddr macrolet-binding) + (let ((expander (lambda (form env) + (eval-form `(destructuring-bind (ignore-operator , at lambda-list) + ',form + (declare (ignore ignore-operator)) + , at body) + env)))) + (values (funcall *macroexpand-hook* expander form env) + t))) + (let ((macro-function (macro-function operator))) + (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) From ffjeld at common-lisp.net Tue Apr 8 21:40:33 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 8 Apr 2008 17:40:33 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080408214033.D353F620A3@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5309 Modified Files: basic-functions.lisp Log Message: error -> program-error (as per ANSI). --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/03/15 20:57:14 1.24 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/04/08 21:40:33 1.25 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.24 2008/03/15 20:57:14 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.25 2008/04/08 21:40:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -287,7 +287,8 @@ ;; spread out args. (cond ((null args) - (error "Too few arguments to APPLY.")) + (error 'program-error + :format-control "Too few arguments to APPLY.")) ((null (cdr args)) (apply function (car args))) (t (let* ((second-last-cons (last args 2)) From ffjeld at common-lisp.net Tue Apr 8 21:42:08 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 8 Apr 2008 17:42:08 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080408214208.2380E1B017@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6242 Modified Files: conditions.lisp Log Message: Add conditions package-error and file-error. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2007/03/12 21:53:40 1.24 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2008/04/08 21:42:08 1.25 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.24 2007/03/12 21:53:40 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.25 2008/04/08 21:42:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -188,6 +188,18 @@ (declare (ignore c)) (format s "Division by zero.")))) +(define-condition package-error (error) + ((package + :initarg :package + :initform nil + :reader package-error-package))) + +(define-condition file-error (error) + ((pathname + :initarg :pathname + :initform nil + :reader file-error-pathname))) + (defun make-condition (type &rest slot-initializations) (declare (dynamic-extent slot-initializations)) (apply 'make-instance type slot-initializations)) From ffjeld at common-lisp.net Wed Apr 9 18:00:57 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 9 Apr 2008 14:00:57 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080409180057.390657E011@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7047 Modified Files: image.lisp Log Message: A bit bigger stack cushion by default. --- /project/movitz/cvsroot/movitz/image.lisp 2008/04/02 20:49:30 1.119 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/09 18:00:56 1.120 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.119 2008/04/02 20:49:30 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.120 2008/04/09 18:00:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1015,7 +1015,7 @@ (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector) (write-binary 'word stream stack-vector-word) (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom) - (write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion + (write-binary 'lu32 stream (+ 8 (* 6 4096) ; cushion (- stack-vector-word (tag :other)))) (set-file-position stream (global-slot-position 'stack-top) 'stack-top) (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other)) From ffjeld at common-lisp.net Wed Apr 9 18:01:34 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 9 Apr 2008 14:01:34 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080409180134.D9CC51206F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv7674 Modified Files: basic-macros.lisp Log Message: Somewhat improved ecase (signal a type-error). --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/20 22:50:01 1.75 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/04/09 18:01:34 1.76 @@ -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.75 2008/03/20 22:50:01 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.76 2008/04/09 18:01:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -375,10 +375,17 @@ (t `(compiled-case ,keyform , at clauses)))) (defmacro ecase (keyform &rest clauses) - ;; "Not quite implemented.." - `(case ,keyform , at clauses (t (error "~S fell through an ecase where the legal cases were ~S" - ,keyform - ',(mapcar #'first clauses))))) + (let ((ecase-var (gensym))) + `(let ((,ecase-var ,keyform)) + (case ,ecase-var + , at clauses + (t (ecase-error ,ecase-var + ',(mapcan (lambda (clause) + (let ((x (car clause))) + (if (atom x) + (list x) + (copy-list x)))) + clauses))))))) (define-compiler-macro asm-register (register-name) (if (member register-name '(:eax :ebx :ecx :untagged-fixnum-ecx :edx)) @@ -1117,11 +1124,17 @@ (define-compiler-macro boundp (symbol) `(with-inline-assembly-case () - (do-case (t :boolean-zf=0 :labels (boundp-done)) + (do-case (t :boolean-zf=0 :labels (boundp-done boundp-restart)) (:compile-form (:result-mode :ebx) ,symbol) + boundp-restart (:leal (:ebx ,(- (movitz:tag :null))) :ecx) (:testb 5 :cl) - (:jne '(:sub-program () (:int 66))) + (:jne '(:sub-program () + (:movl :ebx :eax) + (:load-constant symbol :edx) + (:int 60) + (:movl :eax :ebx) + (:jmp 'boundp-restart))) (:call-local-pf dynamic-variable-lookup) (:globally (:cmpl (:edi (:edi-offset new-unbound-value)) :eax))))) From ffjeld at common-lisp.net Wed Apr 9 18:01:37 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 9 Apr 2008 14:01:37 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080409180137.8C5387E01E@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv7715 Modified Files: conditions.lisp Log Message: Somewhat improved ecase (signal a type-error). --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2008/04/08 21:42:08 1.25 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2008/04/09 18:01:36 1.26 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.25 2008/04/08 21:42:08 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.26 2008/04/09 18:01:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -127,6 +127,18 @@ :datum datum :expected-type (cons 'or expecteds))) +(define-condition ecase-error (type-error) + () + (:report (lambda (c s) + (format s "The object '~S' fell through an ecase where the legal cases were ~S." + (type-error-datum c) + (type-error-expected-type c))))) + +(defun ecase-error (datum expecteds) + (error 'ecase-error + :datum datum + :expected-type (cons 'member expecteds))) + (define-condition control-error (error) ()) (define-condition throw-error (control-error) From ffjeld at common-lisp.net Wed Apr 9 18:02:04 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 9 Apr 2008 14:02:04 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080409180204.CC7627C071@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8133 Modified Files: interrupt.lisp Log Message: Error rather than break upon stack-exhaustion. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2008/02/18 22:31:13 1.57 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2008/04/09 18:02:04 1.58 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.57 2008/02/18 22:31:13 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.58 2008/04/09 18:02:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -381,7 +381,7 @@ (- old-bottom new-bottom) new-bottom) (backtrace :length 5 :spartan t) - (break "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X." + (error "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X." vector $eip (dit-frame-esp nil dit-frame) old-bottom From ffjeld at common-lisp.net Wed Apr 9 18:02:32 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 9 Apr 2008 14:02:32 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080409180232.8B75F7E021@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8362 Modified Files: symbols.lisp Log Message: Fix buggy copy-symbol. --- /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2007/04/07 08:02:35 1.29 +++ /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2008/04/09 18:02:31 1.30 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.29 2007/04/07 08:02:35 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.30 2008/04/09 18:02:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -139,10 +139,10 @@ (load-global-constant movitz::unbound-function)))) (defun %create-symbol (name &optional (package nil) - (plist nil) - (value (load-global-constant new-unbound-value)) - (function (load-global-constant movitz::unbound-function)) - (flags 0)) + (value (load-global-constant new-unbound-value)) + (flags 0) + (plist nil) + (function (load-global-constant movitz::unbound-function))) (eval-when (:compile-toplevel) (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other))))) (let ((sxhash (sxhash name))) @@ -179,31 +179,29 @@ "copy-symbol returns a fresh, uninterned symbol, the name of which is string= to and possibly the same as the name of the given symbol." - (if (or (eq nil symbol) - (not copy-properties)) - (%create-symbol (symbol-name symbol)) - (with-non-header-allocation-assembly - (6 :object-register :eax :fixed-size-p t) - (:addl 1 :eax) - (:load-lexical (:lexical-binding symbol) :ebx) - ;; 0 - (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 0) :ecx) - (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 0)) - ;; 1 - (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 4) :ecx) - (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 4)) - ;; 2 - (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 8) :ecx) - (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 8)) - ;; 3 - (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 12) :ecx) - (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 12)) - ;; 4 - (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 16) :ecx) - (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 16)) - ;; 5 - (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 20) :ecx) - (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 20))))) + (cond + ((not copy-properties) + (%create-symbol (symbol-name symbol))) + ((eq symbol nil) + (%create-symbol (symbol-name symbol) + nil + nil + (symbol-flags nil))) + (t (with-non-header-allocation-assembly + (6 :object-register :eax :fixed-size-p t) + (:addl 1 :eax) + (:load-lexical (:lexical-binding symbol) :ebx) + (:movl (:ebx (:offset movitz-symbol function-value)) :ecx) + (:movl :ecx (:eax (:offset movitz-symbol function-value) 0)) + (:movl (:ebx (:offset movitz-symbol value)) :ecx) + (:movl :ecx (:eax (:offset movitz-symbol value))) + (:movl (:ebx (:offset movitz-symbol plist)) :ecx) + (:movl :ecx (:eax (:offset movitz-symbol plist))) + (:movl (:ebx (:offset movitz-symbol name)) :ecx) + (:movl :ecx (:eax (:offset movitz-symbol name))) + (:movl :edi (:eax (:offset movitz-symbol package))) ; no package + (:movl (:ebx (:offset movitz-symbol flags)) :ecx) + (:movl :ecx (:eax (:offset movitz-symbol flags))))))) (defun symbol-flags (symbol) (etypecase symbol From ffjeld at common-lisp.net Wed Apr 9 18:02:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 9 Apr 2008 14:02:48 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080409180248.CB1CA44065@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8438 Modified Files: typep.lisp Log Message: Add compiled-function-p. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/02 20:49:47 1.57 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/09 18:02:47 1.58 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.57 2008/04/02 20:49:47 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.58 2008/04/09 18:02:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -652,6 +652,9 @@ (define-simple-typep (function functionp) (x) (typep x 'function)) +(define-simple-typep (compiled-function compiled-function-p) (x) + (typep x 'compiled-function)) + (define-simple-typep (macro-function macro-function-p) (x) (typep x 'macro-function)) From ffjeld at common-lisp.net Wed Apr 9 18:33:41 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 9 Apr 2008 14:33:41 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080409183341.3A72944061@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv15504 Modified Files: more-macros.lisp Log Message: For destructuring-bind, fix parsing of &key bindings (sometimes init-form and supplied-p were ignored). --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/16 22:28:18 1.41 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/09 18:33:41 1.42 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.41 2008/03/16 22:28:18 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.42 2008/04/09 18:33:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -248,7 +248,10 @@ ((atom b) (values b (intern (string b) :keyword) nil nil)) ((atom (car b)) - (values (car b) (intern (string (car b)) :keyword) nil nil)) + (values (car b) + (intern (string (pop b)) :keyword) + (pop b) + (pop b))) (t (let ((bn (pop b))) (values (cadr bn) (car bn) (pop b) (pop b)))))) (when supplied-var @@ -543,7 +546,9 @@ (defmacro/cross-compilation load (filespec &key verbose print if-does-not-exist external-format) "hm..." (warn "load-compile: ~S" filespec) - `(funcall ',(movitz:movitz-compile-file (format nil "losp/ansi-tests/~A" filespec)))) + `(progn + (format t "~&Loading ~S.." ',filespec) + (funcall ',(movitz:movitz-compile-file (format nil "losp/ansi-tests/~A" filespec))))) (defmacro locally (&body body) `(let () , at body)) @@ -571,3 +576,6 @@ (*read-suppress* nil) #+ignore (*readtable* nil)) , at body)) + +(defmacro/run-time loop (&rest clauses) + (error "Loop not implemented.")) From ffjeld at common-lisp.net Sat Apr 12 16:23:26 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:23:26 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080412162326.9569381015@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29597 Modified Files: special-operators.lisp Log Message: Rename to defmacro/run-time and defmacro/compile-time --- /project/movitz/cvsroot/movitz/special-operators.lisp 2008/03/15 20:57:03 1.57 +++ /project/movitz/cvsroot/movitz/special-operators.lisp 2008/04/12 16:23:26 1.58 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.57 2008/03/15 20:57:03 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.58 2008/04/12 16:23:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -348,7 +348,7 @@ (movitz-macro-expander-make-function expander :type :setf :name access-fn))))))) (compiler-values ())) -(define-special-operator muerte::defmacro-compile-time (&form form) +(define-special-operator muerte::defmacro/compile-time (&form form) (destructuring-bind (name lambda-list macro-body) (cdr form) (check-type name symbol "a macro name") From ffjeld at common-lisp.net Sat Apr 12 16:23:29 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:23:29 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080412162329.0093E81029@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29617 Modified Files: defmacro-bootstrap.lisp Log Message: Rename to defmacro/run-time and defmacro/compile-time --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/03/17 08:00:21 1.1 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/12 16:23:28 1.2 @@ -7,14 +7,14 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defmacro-bootstrap.lisp,v 1.1 2008/03/17 08:00:21 ffjeld Exp $ +;;;; $Id: defmacro-bootstrap.lisp,v 1.2 2008/04/12 16:23:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :muerte/defmacro-bootstrap) -(muerte::defmacro-compile-time muerte.cl:defmacro (name lambda-list &body macro-body) - (`(muerte::defmacro-compile-time ,name ,lambda-list ,macro-body))) +(muerte::defmacro/compile-time muerte.cl:defmacro (name lambda-list &body macro-body) + (`(muerte::defmacro/compile-time ,name ,lambda-list ,macro-body))) (muerte.cl:defmacro muerte.cl:in-package (name) `(progn @@ -25,13 +25,13 @@ (defmacro defmacro/cross-compilation (name lambda-list &body body) `(progn - (defmacro-compile-time ,name ,lambda-list ,body) + (defmacro/compile-time ,name ,lambda-list ,body) ',name)) (defmacro defmacro (name lambda-list &body body) `(defmacro/cross-compilation ,name ,lambda-list , at body)) -(defmacro defmacro/runtime (name lambda-list &body body) +(defmacro defmacro/run-time (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)) From ffjeld at common-lisp.net Sat Apr 12 16:23:32 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:23:32 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080412162332.7F9EC3A002@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29667 Modified Files: defmacro-runtime.lisp Log Message: Rename to defmacro/run-time and defmacro/compile-time --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/03/19 15:00:13 1.2 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/04/12 16:23:31 1.3 @@ -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.2 2008/03/19 15:00:13 ffjeld Exp $ +;;;; $Id: defmacro-runtime.lisp,v 1.3 2008/04/12 16:23:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,6 +17,6 @@ (defmacro defmacro (name lambda-list &body macro-body) `(progn - (defmacro/runtime ,name ,lambda-list , at macro-body) - (defmacro-compile-time ,name ,lambda-list ,macro-body) + (defmacro/run-time ,name ,lambda-list , at macro-body) + (defmacro/compile-time ,name ,lambda-list ,macro-body) ',name)) From ffjeld at common-lisp.net Sat Apr 12 16:26:58 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:26:58 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080412162658.7467D81015@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv30230 Modified Files: storage-types.lisp Log Message: A bit of commenting. --- /project/movitz/cvsroot/movitz/storage-types.lisp 2008/04/02 20:47:09 1.63 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2008/04/12 16:26:56 1.64 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.63 2008/04/02 20:47:09 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.64 2008/04/12 16:26:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -69,9 +69,13 @@ :other 6 :symbol 7 - ;; The lower 3 bits of these are significant in mysterious ways. + ;; The lower 2 bits of these are significant in mysterious ways. + ;; 10: Requires GC parsing. + ;; 00: Requires no GC parsing (all GC-safe lisp-vals). + ;; 11: Illegal/special values :basic-vector #x22 :defstruct #x2a + :basic-restart #x32 :funobj #x3a :bignum #x4a :ratio #x52 @@ -79,9 +83,7 @@ :std-instance #x40 :run-time-context #x62 :illegal #x13 - :infant-object #x23 - :basic-restart #x32 - ) + :infant-object #x23) (defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum)) (defparameter +scan-skip-word+ #x00000003) From ffjeld at common-lisp.net Sat Apr 12 16:43:50 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:43:50 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080412164350.02E5A4E03C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv3258 Modified Files: image.lisp Log Message: Fix a buglet in comment-instruction. --- /project/movitz/cvsroot/movitz/image.lisp 2008/04/09 18:00:56 1.120 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/12 16:43:49 1.121 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.120 2008/04/09 18:00:56 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.121 2008/04/12 16:43:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1287,6 +1287,7 @@ when (and funobj (typep operand 'asm:indirect-operand) (member :esi operand) + (= 2 (length operand)) (<= 12 (asm:indirect-operand-offset operand))) collect (format nil "~A" (nth (truncate (- (+ (asm:indirect-operand-offset operand) @@ -1703,7 +1704,9 @@ (movitz-read (rationalize expr))) (class (muerte::movitz-find-class (translate-program (class-name expr) - :cl :muerte.cl)))))))) + :cl :muerte.cl))) + (array ; XXX + (movitz-read nil))))))) ;;; From ffjeld at common-lisp.net Sat Apr 12 16:46:05 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:46:05 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080412164605.CEB423A005@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv3703 Modified Files: compiler.lisp Log Message: Fix the %find-code-vector problem by adding NOP-prefixes in assemble-funobj. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/21 22:29:57 1.199 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/12 16:46:05 1.200 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.199 2008/03/21 22:29:57 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.200 2008/04/12 16:46:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1004,11 +1004,12 @@ (assemble-funobj funobj combined-code)))) funobj) -(defun assemble-funobj (funobj combined-code) - (multiple-value-bind (code-vector code-symtab) +(defun assemble-funobj (funobj combined-code &key extra-prefix-computers) + (multiple-value-bind (code code-symtab) (let ((asm-x86:*cpu-mode* :32-bit) (asm:*instruction-compute-extra-prefix-map* - '((:call . compute-call-extra-prefix)))) + (append extra-prefix-computers + '((:call . compute-call-extra-prefix))))) (asm:assemble-proglist combined-code :symtab (list* (cons :nil-value (image-nil-word *image*)) (loop for (label . set) in (movitz-funobj-jumpers-map funobj) @@ -1016,50 +1017,66 @@ (* 4 (or (search set (movitz-funobj-const-list funobj) :end2 (movitz-funobj-num-jumpers funobj)) (error "Jumper for ~S missing." label)))))))) - (setf (movitz-funobj-symtab funobj) code-symtab) - (let* ((code-length (- (length code-vector) 3 -3)) - (code-vector (make-array code-length - :initial-contents code-vector - :fill-pointer t))) - (setf (fill-pointer code-vector) code-length) - ;; debug info - (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) - 1 #+ignore (if use-stack-frame-p 1 0)) - (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab)))) - (cond - ((not x) - #+ignore (warn "No start-stack-frame-setup label for ~S." name)) - ((<= 0 x 30) - (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) - (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." - x (movitz-funobj-name funobj))))) - (let* ((a (or (cdr (assoc 'entry%1op code-symtab)) 0)) - (b (or (cdr (assoc 'entry%2op code-symtab)) a)) - (c (or (cdr (assoc 'entry%3op code-symtab)) b))) - (unless (<= a b c) - (warn "Weird code-entries: ~D, ~D, ~D." a b c)) - (unless (<= 0 a 255) - (break "entry%1: ~D" a)) - (unless (<= 0 b 2047) - (break "entry%2: ~D" b)) - (unless (<= 0 c 4095) - (break "entry%3: ~D" c))) - (loop for (entry-label slot-name) in '((entry%1op code-vector%1op) - (entry%2op code-vector%2op) - (entry%3op code-vector%3op)) - do (when (assoc entry-label code-symtab) - (let ((offset (cdr (assoc entry-label code-symtab)))) - (setf (slot-value funobj slot-name) - (cons offset funobj))))) - (check-locate-concistency code-vector) - (setf (movitz-funobj-code-vector funobj) - (make-movitz-vector (length code-vector) - :fill-pointer code-length - :element-type 'code - :initial-contents code-vector)))) + (let ((code-length (- (length code) 3 -3))) + (let ((locate-inconsistencies (check-locate-concistency code code-length))) + (when locate-inconsistencies + (when (rassoc 'compute-extra-prefix-locate-inconsistencies + extra-prefix-computers) + (error "~S failed to fix locate-inconsistencies. This should not happen." + 'compute-extra-prefix-locate-inconsistencies)) + (return-from assemble-funobj + (assemble-funobj funobj combined-code + :extra-prefix-computers (list (cons t (lambda (pc size) + (loop for bad-pc in locate-inconsistencies + when (<= pc bad-pc (+ pc size)) + return '(#x90))))))) + + (break "locate-inconsistencies: ~S" locate-inconsistencies))) + (setf (movitz-funobj-symtab funobj) code-symtab) + (let ((code-vector (make-array code-length + :initial-contents code + :fill-pointer t))) + (setf (fill-pointer code-vector) code-length) + ;; debug info + (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) + 1 #+ignore (if use-stack-frame-p 1 0)) + (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab)))) + (cond + ((not x) + #+ignore (warn "No start-stack-frame-setup label for ~S." name)) + ((<= 0 x 30) + (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) + (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." + x (movitz-funobj-name funobj))))) + (let* ((a (or (cdr (assoc 'entry%1op code-symtab)) 0)) + (b (or (cdr (assoc 'entry%2op code-symtab)) a)) + (c (or (cdr (assoc 'entry%3op code-symtab)) b))) + (unless (<= a b c) + (warn "Weird code-entries: ~D, ~D, ~D." a b c)) + (unless (<= 0 a 255) + (break "entry%1: ~D" a)) + (unless (<= 0 b 2047) + (break "entry%2: ~D" b)) + (unless (<= 0 c 4095) + (break "entry%3: ~D" c))) + (loop for (entry-label slot-name) in '((entry%1op code-vector%1op) + (entry%2op code-vector%2op) + (entry%3op code-vector%3op)) + do (when (assoc entry-label code-symtab) + (let ((offset (cdr (assoc entry-label code-symtab)))) + (setf (slot-value funobj slot-name) + (cons offset funobj))))) + (setf (movitz-funobj-code-vector funobj) + (make-movitz-vector (length code-vector) + :fill-pointer code-length + :element-type 'code + :initial-contents code-vector))))) funobj) (defun check-locate-concistency (code-vector) + "The run-time function muerte::%find-code-vector sometimes needs to find a code-vector by +searching through the machine-code for an object header signature. This function is to +make sure that no machine code accidentally forms such a header signature." (loop for x from 0 below (length code-vector) by 8 do (when (and (= (tag :basic-vector) (aref code-vector x)) (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x))) @@ -1068,7 +1085,7 @@ (aref code-vector (+ x 2))) (= (ldb (byte 8 8) (length code-vector)) (aref code-vector (+ x 3)))))) - (break "Code-vector (length #x~X) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X." + (break "Code-vector (length ~D) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X." (length code-vector) x (aref code-vector (+ x 0)) (aref code-vector (+ x 1)) @@ -1076,6 +1093,22 @@ (aref code-vector (+ x 3))))) (values)) +(defun check-locate-concistency (code code-vector-length) + "The run-time function muerte::%find-code-vector sometimes needs to find a code-vector by +searching through the machine-code for an object header signature. This function is to +make sure that no machine code accidentally forms such a header signature." + (loop for (x0 x1 x2 x3) on code by (lambda (l) (nthcdr 8 l)) + for pc upfrom 0 by 8 + when (and (= x0 (tag :basic-vector)) + (= x1 (enum-value 'movitz-vector-element-type :code)) + (or (<= #x4000 code-vector-length) + (and (= x2 (ldb (byte 8 0) code-vector-length)) + (= x3 (ldb (byte 8 8) code-vector-length))))) + collect pc + and do (warn "Code-vector (length ~D) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X." + code-vector-length + pc x0 x1 x2 x3))) + (defun make-2req (binding0 binding1 frame-map) (let ((location-0 (new-binding-location binding0 frame-map)) @@ -2730,9 +2763,9 @@ init-pc) (assert (instruction-is (first init-pc) :init-lexvar)) (destructuring-bind (init-binding &key init-with-register init-with-type - protect-registers protect-carry) + protect-registers protect-carry shared-reference-p) (cdr (first init-pc)) - (declare (ignore protect-registers protect-carry init-with-type)) + (declare (ignore protect-registers protect-carry init-with-type shared-reference-p)) (assert (eq binding init-binding)) (multiple-value-bind (load-instruction binding-destination distance) (loop for i in (cdr init-pc) as distance upfrom 0 @@ -3372,7 +3405,7 @@ 'integer)) (warn "ecx from ~S" binding))) (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) - (break "The variable ~S is used even if it was declared ignored." + (warn "The variable ~S is used even if it was declared ignored." (binding-name binding))) (let ((binding (ensure-local-binding binding funobj)) (protect-registers (cons :edx protect-registers))) @@ -5938,7 +5971,8 @@ (cond ((not binding) (unless (movitz-env-get form 'special nil env) - (cerror "Compile like a special." "Undeclared variable: ~S." form)) + #+ignore (cerror "Compile like a special." "Undeclared variable: ~S." form) + (warn "Undeclared variable: ~S." form)) (compiler-values () :returns :eax :functional-p t From ffjeld at common-lisp.net Sat Apr 12 16:46:49 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:46:49 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080412164649.47B424E049@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv3853 Modified Files: asm-x86.lisp Log Message: Allow t as a "catch all" operator for *instruction-compute-extra-prefix-map*. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/03/06 19:14:39 1.37 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/04/12 16:46:48 1.38 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.37 2008/03/06 19:14:39 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.38 2008/04/12 16:46:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1050,9 +1050,11 @@ (defun compute-extra-prefixes (operator pc size) - (let ((ff (assoc operator *instruction-compute-extra-prefix-map*))) - (when ff - (funcall (cdr ff) pc size)))) + (loop for (pattern . function) in *instruction-compute-extra-prefix-map* + when (or (eq pattern t) + (eq pattern operator)) + return (funcall function pc size))) + (defun encode-pc-rel (operator legacy-prefixes opcode operand type &rest extras) (when (typep operand '(or pc-relative-operand symbol-reference)) From ffjeld at common-lisp.net Sat Apr 12 16:47:18 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:47:18 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080412164718.6DA804E049@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3964 Modified Files: los-closette-compiler.lisp Log Message: Allow :method options to defgeneric. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp 2007/03/13 20:42:42 1.21 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp 2008/04/12 16:47:18 1.22 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.21 2007/03/13 20:42:42 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.22 2008/04/12 16:47:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1009,6 +1009,7 @@ (:method-class (list ':method-class `(movitz-find-class ',(cadr option)))) + (:method nil) (t (list `',(car option) `',(cadr option))))) ;;; ensure-generic-function From ffjeld at common-lisp.net Sat Apr 12 16:47:25 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 12:47:25 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080412164725.78E9A751B2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3986 Modified Files: los-closette.lisp Log Message: Allow :method options to defgeneric. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2008/03/15 20:57:57 1.38 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2008/04/12 16:47:21 1.39 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.38 2008/03/15 20:57:57 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.39 2008/04/12 16:47:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -32,10 +32,15 @@ ,@(canonicalize-defclass-options options env name))))) (defmacro defgeneric (function-name lambda-list &rest options) - `(eval-when (:compile-toplevel) - (movitz-ensure-generic-function ',function-name - :lambda-list ',lambda-list - ,@(canonicalize-defgeneric-options options)))) + `(progn + (eval-when (:compile-toplevel) + (movitz-ensure-generic-function ',function-name + :lambda-list ',lambda-list + ,@(canonicalize-defgeneric-options options))) + ,@(mapcan (lambda (option) + (when (eq :method (car option)) + (list `(defmethod ,function-name ,@(cdr option))))) + options))) (defmacro defmethod (&rest args &environment env) (multiple-value-bind (name qualifiers lambda-list specializers body declarations documentation) From ffjeld at common-lisp.net Sat Apr 12 17:11:23 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 12 Apr 2008 13:11:23 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080412171123.B63C5B067@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9517 Modified Files: defmacro-bootstrap.lisp Log Message: Fix handling of &whole in defmacro/run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/12 16:23:28 1.2 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/12 17:11:23 1.3 @@ -7,7 +7,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defmacro-bootstrap.lisp,v 1.2 2008/04/12 16:23:28 ffjeld Exp $ +;;;; $Id: defmacro-bootstrap.lisp,v 1.3 2008/04/12 17:11:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -36,6 +36,9 @@ (movitz::parse-docstring-declarations-and-body body 'cl:declare) (let* ((block-name (compute-function-block-name name)) (ignore-var (gensym)) + (whole-var (when (eq '&whole (car lambda-list)) + (list (pop lambda-list) + (pop lambda-list)))) (form-var (gensym "form-")) (env-var nil) (operator-var (gensym)) @@ -54,14 +57,27 @@ (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 , at ignore-env)) - ,docstring - (block ,block-name - (verify-macroexpand-call edx ',name) - (destructuring-bind ,destructuring-lambda-list - ,form-var - (declare (ignore ,operator-var) , at declarations) - , at real-body)) - :type :macro-function))))) + (cond + ((and whole-var + (null lambda-list)) + `(make-named-function ,name + (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) + ((ignore ,ignore-var , at ignore-env)) + ,docstring + (block ,block-name + (verify-macroexpand-call edx ',name) + (let ((,(second whole-var) ,form-var)) + (declare , at declarations) + , at real-body)) + :type :macro-function)) + (t `(make-named-function ,name + (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) + ((ignore ,ignore-var , at ignore-env)) + ,docstring + (block ,block-name + (verify-macroexpand-call edx ',name) + (destructuring-bind ,(append whole-var destructuring-lambda-list) + ,form-var + (declare (ignore ,operator-var) , at declarations) + , at real-body)) + :type :macro-function))))))) From ffjeld at common-lisp.net Sun Apr 13 08:21:40 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 13 Apr 2008 04:21:40 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080413082140.D192975165@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5960 Modified Files: integers.lisp Log Message: Implement boole and friends. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/02/04 10:08:18 1.124 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/13 08:21:40 1.125 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.124 2008/02/04 10:08:18 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.125 2008/04/13 08:21:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2248,8 +2248,7 @@ (numerator power-number))))) (defun floatp (x) - (declare (ignore x)) - nil) + (typep x 'real)) (defun realpart (number) number) @@ -2263,3 +2262,73 @@ (defun realp (x) (typep x 'real)) + +(defconstant boole-clr 'boole-clr) +(defconstant boole-1 'boole-1) +(defconstant boole-2 'boole-2) +(defconstant boole-c1 'boole-c1) +(defconstant boole-c2 'boole-c2) +(defconstant boole-eqv 'logeqv) +(defconstant boole-and 'logand) +(defconstant boole-nand 'lognand) +(defconstant boole-andc1 'logandc1) +(defconstant boole-andc2 'logandc2) +(defconstant boole-ior 'logior) +(defconstant boole-nor 'lognor) +(defconstant boole-orc1 'logorc1) +(defconstant boole-orc2 'logorc2) +(defconstant boole-xor 'logxor) +(defconstant boole-set 'boole-set) + +(defun boole (op integer-1 integer-2) + "=> result-integer" + (funcall op integer-1 integer-2)) + +(defun boole-clr (integer-1 integer-2) + (declare (ignore integer-1 integer-2)) + 0) + +(defun boole-set (integer-1 integer-2) + (declare (ignore integer-1 integer-2)) + -1) + +(defun boole-1 (integer-1 integer-2) + (declare (ignore integer-2)) + integer-1) + +(defun boole-2 (integer-1 integer-2) + (declare (ignore integer-1)) + integer-2) + +(defun logandc1 (integer-1 integer-2) + (logand (lognot integer-1) + integer-2)) + +(defun logandc2 (integer-1 integer-2) + (logand integer-1 + (lognot integer-2))) + +(defun boole-c1 (integer-1 integer-2) + (declare (ignore integer-2)) + (lognot integer-1)) + +(defun boole-c2 (integer-1 integer-2) + (declare (ignore integer-1)) + (lognot integer-2)) + +(defun logeqv (integer-1 integer-2) + (lognot (logxor integer-1 integer-2))) + +(defun lognand (integer-1 integer-2) + (lognot (logand integer-1 integer-2))) + +(defun lognor (integer-1 integer-2) + (lognot (logior integer-1 integer-2))) + +(defun logorc1 (integer-1 integer-2) + (logior (lognot integer-1) + integer-2)) + +(defun logorc2 (integer-1 integer-2) + (logior integer-1 + (lognot integer-2))) From ffjeld at common-lisp.net Sun Apr 13 20:12:37 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 13 Apr 2008 16:12:37 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080413201237.94A9E2B06B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10793 Modified Files: eval.lisp Log Message: For make-destructuring-env, throw program-error when too few or too many values are provided. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/08 21:39:52 1.29 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/13 20:12:37 1.30 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.29 2008/04/08 21:39:52 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.30 2008/04/13 20:12:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -279,17 +279,17 @@ (setf env-var (cadr pattern) pattern (cddr pattern))) (loop with next-states = '(&optional &rest &key &aux) - with state = 'requireds - for pp on pattern as p = (car pp) - if (member p next-states) - do (setf next-states (member p next-states) - state p) - else do (cond + with state = 'requireds + for pp on pattern as p = (car pp) + if (member p next-states) + do (setf next-states (member p next-states) + state p) + else do (cond ((and (eq state 'requireds) recursive-p (consp p)) (unless (listp (car values)) - (error "Pattern mismatch.")) + (simple-program-error "Lambda-list pattern mismatch.")) (setf env (make-destructuring-env p (pop values) env :recursive-p nil :environment-p nil))) @@ -302,7 +302,8 @@ (case state (requireds (when (null values) - (error "Too few values provided. [~S:~S:~S]" state next-states env)) + (simple-program-error "Too few values provided. [~S:~S:~S]" + state next-states env)) (push (cons p (pop values)) env)) (&optional @@ -314,7 +315,7 @@ env)) (push (cons var (if values (pop values) - (eval-form init-form env))) + (eval-form init-form env))) env))) (&rest (push (cons p values) @@ -326,7 +327,7 @@ (present-p (not (null x))) (value (if present-p (cadr x) - (eval-form init-form env)))) + (eval-form init-form env)))) (when supplied-p-parameter (push (cons supplied-p-parameter present-p) @@ -341,9 +342,12 @@ (push (cons var (eval-form init-form env)) env))))) (t (error "Illegal destructuring pattern: ~S" pattern))) - (when (not (listp (cdr pp))) - (push (cons (cdr pp) values) - env))) + (when (not (listp (cdr pp))) + (push (cons (cdr pp) values) + env)) + finally + (when (and values (member state '(requireds optionals))) + (simple-program-error "Too many arguments."))) (if (and environment-p env-var) (cons (cons env-var env) env) From ffjeld at common-lisp.net Mon Apr 14 20:39:42 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 14 Apr 2008 16:39:42 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080414203942.F36161F00C@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv12646 Modified Files: compiler.lisp Log Message: Fix a compiler bug where the compiler would barf on e.g. (flet ((foo ..)) (lambda () #'foo)). --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/12 16:46:05 1.200 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/14 20:39:42 1.201 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.200 2008/04/12 16:46:05 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.201 2008/04/14 20:39:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -6377,7 +6377,7 @@ (defun ensure-local-binding (binding funobj) "When referencing binding in funobj, ensure we have the binding local to funobj." - (if (typep binding '(or (not binding) constant-object-binding)) + (if (typep binding '(or (not binding) constant-object-binding funobj-binding)) binding ; Never mind if "binding" isn't a binding, or is a constant-binding. (let ((target-binding (binding-target binding))) (cond @@ -7145,7 +7145,9 @@ but it's requested to be in ~S." destreg) (let ((srcloc (new-binding-location (binding-target src) frame-map))) - (unless (eql srcloc loc1) (break)) + (unless (eql srcloc loc1) + #+ignore (break) + (warn "add srcloc: ~S, loc1: ~S" srcloc loc1)) (if (integerp srcloc) `((:addl (:ebp ,(stack-frame-offset srcloc)) ,destreg) From ffjeld at common-lisp.net Mon Apr 14 21:06:47 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 14 Apr 2008 17:06:47 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080414210647.E980475150@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21646 Modified Files: lists.lisp Log Message: Added revappend. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/20 22:21:31 1.25 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/14 21:06:47 1.26 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.25 2008/03/20 22:21:31 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.26 2008/04/14 21:06:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -197,6 +197,13 @@ (unless copied-result (setf copied-result copy)))))))) +(defun revappend (list tail) + "=> result-list" + (do () ((null list) + tail) + (push (pop list) + tail))) + (defun copy-list (list) (if (null list) nil From ffjeld at common-lisp.net Tue Apr 15 23:04:39 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 15 Apr 2008 19:04:39 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080415230439.A213C31035@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv8001 Modified Files: compiler.lisp Log Message: Fix a rather nasty compiler bug that would cause :store-lexical to generate GC-unsafe code (i.e. store pointers in ECX). --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/14 20:39:42 1.201 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/15 23:04:39 1.202 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.201 2008/04/14 20:39:42 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.202 2008/04/15 23:04:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3639,168 +3639,171 @@ (install-for-single-value binding binding-location :eax nil))) ))))))))) + (defun make-store-lexical (binding source shared-reference-p funobj frame-map &key protect-registers) (let ((binding (ensure-local-binding binding funobj))) (assert (not (and shared-reference-p (not (binding-lended-p binding)))) - (binding) - "funny binding: ~W" binding) + (binding) + "funny binding: ~W" binding) (if (and nil (typep source 'constant-object-binding)) (make-load-constant (constant-object source) binding funobj frame-map) - (let ((protect-registers (cons source protect-registers))) - (cond - ((eq :untagged-fixnum-ecx source) - (if (eq :untagged-fixnum-ecx - (new-binding-location binding frame-map)) - nil - (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx) - (make-store-lexical binding :ecx shared-reference-p funobj frame-map - :protect-registers protect-registers)))) - ((typep binding 'borrowed-binding) - (let ((slot (borrowed-binding-reference-slot binding))) - (if (not shared-reference-p) - (let ((tmp-reg (chose-free-register protect-registers) - #+ignore(if (eq source :eax) :ebx :eax))) - (when (eq :ecx source) - (break "loading a word from ECX?")) - `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))) - ,tmp-reg) - (:movl ,source (-1 ,tmp-reg)))) - `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))))))) - ((typep binding 'forwarding-binding) - (assert (not (binding-lended-p binding)) (binding)) - (make-store-lexical (forwarding-binding-target binding) - source shared-reference-p funobj frame-map)) - ((not (new-binding-located-p binding frame-map)) - ;; (warn "Can't store to unlocated binding ~S." binding) - nil) - ((and (binding-lended-p binding) - (not shared-reference-p)) - (let ((tmp-reg (chose-free-register protect-registers) - #+ignore (if (eq source :eax) :ebx :eax)) - (location (new-binding-location binding frame-map))) - (if (integerp location) - `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg) - (:movl ,source (,tmp-reg -1))) - (ecase (operator location) - (:argument-stack - (assert (<= 2 (function-argument-argnum binding)) () - "store-lexical argnum can't be ~A." (function-argument-argnum binding)) - `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg) - (:movl ,source (,tmp-reg -1)))))))) - (t (let ((location (new-binding-location binding frame-map))) - (cond - ((member source '(:eax :ebx :ecx :edx :edi :esp)) - (if (integerp location) - `((:movl ,source (:ebp ,(stack-frame-offset location)))) - (ecase (operator location) - ((:push) - `((:pushl ,source))) - ((:eax :ebx :ecx :edx) - (unless (eq source location) - `((:movl ,source ,location)))) - (:argument-stack - (assert (<= 2 (function-argument-argnum binding)) () - "store-lexical argnum can't be ~A." (function-argument-argnum binding)) - `((:movl ,source (:ebp ,(argument-stack-offset binding))))) - (:untagged-fixnum-ecx - (assert (not (eq source :edi))) - (cond - ((eq source :untagged-fixnum-ecx) - nil) - ((eq source :eax) - `((,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset 'unbox-u32))))) - (t `((:movl ,source :eax) - (,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset 'unbox-u32)))))))))) - ((eq source :boolean-cf=1) - (let ((tmp (chose-free-register protect-registers))) - `((:sbbl :ecx :ecx) - (,*compiler-local-segment-prefix* - :movl (:edi (:ecx 4) ,(global-constant-offset 'not-not-nil)) ,tmp) - ,@(make-store-lexical binding tmp shared-reference-p funobj frame-map - :protect-registers protect-registers)))) - ((eq source :boolean-cf=0) - (let ((tmp (chose-free-register protect-registers))) - `((:sbbl :ecx :ecx) - (,*compiler-local-segment-prefix* - :movl (:edi (:ecx 4) ,(global-constant-offset 'boolean-zero)) ,tmp) - ,@(make-store-lexical binding tmp shared-reference-p funobj frame-map - :protect-registers protect-registers)))) - ((and *compiler-use-cmov-p* - (member source +boolean-modes+)) - (let ((tmp (chose-free-register protect-registers))) - (append `((:movl :edi ,tmp)) - (list (cons *compiler-local-segment-prefix* - (make-cmov-on-boolean source - `(:edi ,(global-constant-offset 't-symbol)) - tmp))) - (make-store-lexical binding tmp shared-reference-p funobj frame-map + (let ((protect-registers (list* source protect-registers))) + (unless (or (eq source :untagged-fixnum-ecx)) ; test binding type! + (push :ecx protect-registers)) + (cond + ((eq :untagged-fixnum-ecx source) + (if (eq :untagged-fixnum-ecx + (new-binding-location binding frame-map)) + nil + (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx) + (make-store-lexical binding :ecx shared-reference-p funobj frame-map + :protect-registers protect-registers)))) + ((typep binding 'borrowed-binding) + (let ((slot (borrowed-binding-reference-slot binding))) + (if (not shared-reference-p) + (let ((tmp-reg (chose-free-register protect-registers) + #+ignore(if (eq source :eax) :ebx :eax))) + (when (eq :ecx source) + (break "loading a word from ECX?")) + `((:movl (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot))) + ,tmp-reg) + (:movl ,source (-1 ,tmp-reg)))) + `((:movl ,source (:esi ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 slot)))))))) + ((typep binding 'forwarding-binding) + (assert (not (binding-lended-p binding)) (binding)) + (make-store-lexical (forwarding-binding-target binding) + source shared-reference-p funobj frame-map)) + ((not (new-binding-located-p binding frame-map)) + ;; (warn "Can't store to unlocated binding ~S." binding) + nil) + ((and (binding-lended-p binding) + (not shared-reference-p)) + (let ((tmp-reg (chose-free-register protect-registers) + #+ignore (if (eq source :eax) :ebx :eax)) + (location (new-binding-location binding frame-map))) + (if (integerp location) + `((:movl (:ebp ,(stack-frame-offset location)) ,tmp-reg) + (:movl ,source (,tmp-reg -1))) + (ecase (operator location) + (:argument-stack + (assert (<= 2 (function-argument-argnum binding)) () + "store-lexical argnum can't be ~A." (function-argument-argnum binding)) + `((:movl (:ebp ,(argument-stack-offset binding)) ,tmp-reg) + (:movl ,source (,tmp-reg -1)))))))) + (t (let ((location (new-binding-location binding frame-map))) + (cond + ((member source '(:eax :ebx :ecx :edx :edi :esp)) + (if (integerp location) + `((:movl ,source (:ebp ,(stack-frame-offset location)))) + (ecase (operator location) + ((:push) + `((:pushl ,source))) + ((:eax :ebx :ecx :edx) + (unless (eq source location) + `((:movl ,source ,location)))) + (:argument-stack + (assert (<= 2 (function-argument-argnum binding)) () + "store-lexical argnum can't be ~A." (function-argument-argnum binding)) + `((:movl ,source (:ebp ,(argument-stack-offset binding))))) + (:untagged-fixnum-ecx + (assert (not (eq source :edi))) + (cond + ((eq source :untagged-fixnum-ecx) + nil) + ((eq source :eax) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32))))) + (t `((:movl ,source :eax) + (,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset 'unbox-u32)))))))))) + ((eq source :boolean-cf=1) + (let ((tmp (chose-free-register protect-registers))) + `((:sbbl :ecx :ecx) + (,*compiler-local-segment-prefix* + :movl (:edi (:ecx 4) ,(global-constant-offset 'not-not-nil)) ,tmp) + ,@(make-store-lexical binding tmp shared-reference-p funobj frame-map :protect-registers protect-registers)))) - ((member source +boolean-modes+) - (let ((tmp (chose-free-register protect-registers)) - (label (gensym "store-lexical-bool-"))) - (append `((:movl :edi ,tmp)) - (list (make-branch-on-boolean source label :invert t)) - `((,*compiler-local-segment-prefix* - :movl (:edi ,(global-constant-offset 't-symbol)) ,tmp)) - (list label) - (make-store-lexical binding tmp shared-reference-p funobj frame-map + ((eq source :boolean-cf=0) + (let ((tmp (chose-free-register protect-registers))) + `((:sbbl :ecx :ecx) + (,*compiler-local-segment-prefix* + :movl (:edi (:ecx 4) ,(global-constant-offset 'boolean-zero)) ,tmp) + ,@(make-store-lexical binding tmp shared-reference-p funobj frame-map :protect-registers protect-registers)))) - ((not (bindingp source)) - (error "Unknown source for store-lexical: ~S" source)) - ((binding-singleton source) - (assert (not shared-reference-p)) - (let ((value (car (binding-singleton source)))) - (etypecase value - (movitz-fixnum - (let ((immediate (movitz-immediate-value value))) - (if (integerp location) - (let ((tmp (chose-free-register protect-registers))) - (append (make-immediate-move immediate tmp) - `((:movl ,tmp (:ebp ,(stack-frame-offset location)))))) - #+ignore (if (= 0 immediate) - (let ((tmp (chose-free-register protect-registers))) - `((:xorl ,tmp ,tmp) - (:movl ,tmp (:ebp ,(stack-frame-offset location))))) - `((:movl ,immediate (:ebp ,(stack-frame-offset location))))) - (ecase (operator location) - ((:argument-stack) - `((:movl ,immediate (:ebp ,(argument-stack-offset binding))))) - ((:eax :ebx :ecx :edx) - (make-immediate-move immediate location)) - ((:untagged-fixnum-ecx) - (make-immediate-move (movitz-fixnum-value value) :ecx)))))) - (movitz-character - (let ((immediate (movitz-immediate-value value))) - (if (integerp location) - (let ((tmp (chose-free-register protect-registers))) - (append (make-immediate-move immediate tmp) - `((:movl ,tmp (:ebp ,(stack-frame-offset location)))))) - (ecase (operator location) - ((:argument-stack) - `((:movl ,immediate (:ebp ,(argument-stack-offset binding))))) - ((:eax :ebx :ecx :edx) - (make-immediate-move immediate location)))))) - (movitz-heap-object - (etypecase location - ((member :eax :ebx :edx) - (make-load-constant value location funobj frame-map)) - (integer - (let ((tmp (chose-free-register protect-registers))) - (append (make-load-constant value tmp funobj frame-map) - (make-store-lexical binding tmp shared-reference-p - funobj frame-map - :protect-registers protect-registers)))) - ((eql :untagged-fixnum-ecx) - (check-type value movitz-bignum) - (let ((immediate (movitz-bignum-value value))) - (check-type immediate (unsigned-byte 32)) - (make-immediate-move immediate :ecx))) - ))))) - (t (error "Generalized lexb source for store-lexical not implemented: ~S" source)))))))))) + ((and *compiler-use-cmov-p* + (member source +boolean-modes+)) + (let ((tmp (chose-free-register protect-registers))) + (append `((:movl :edi ,tmp)) + (list (cons *compiler-local-segment-prefix* + (make-cmov-on-boolean source + `(:edi ,(global-constant-offset 't-symbol)) + tmp))) + (make-store-lexical binding tmp shared-reference-p funobj frame-map + :protect-registers protect-registers)))) + ((member source +boolean-modes+) + (let ((tmp (chose-free-register protect-registers)) + (label (gensym "store-lexical-bool-"))) + (append `((:movl :edi ,tmp)) + (list (make-branch-on-boolean source label :invert t)) + `((,*compiler-local-segment-prefix* + :movl (:edi ,(global-constant-offset 't-symbol)) ,tmp)) + (list label) + (make-store-lexical binding tmp shared-reference-p funobj frame-map + :protect-registers protect-registers)))) + ((not (bindingp source)) + (error "Unknown source for store-lexical: ~S" source)) + ((binding-singleton source) + (assert (not shared-reference-p)) + (let ((value (car (binding-singleton source)))) + (etypecase value + (movitz-fixnum + (let ((immediate (movitz-immediate-value value))) + (if (integerp location) + (let ((tmp (chose-free-register protect-registers))) + (append (make-immediate-move immediate tmp) + `((:movl ,tmp (:ebp ,(stack-frame-offset location)))))) + #+ignore (if (= 0 immediate) + (let ((tmp (chose-free-register protect-registers))) + `((:xorl ,tmp ,tmp) + (:movl ,tmp (:ebp ,(stack-frame-offset location))))) + `((:movl ,immediate (:ebp ,(stack-frame-offset location))))) + (ecase (operator location) + ((:argument-stack) + `((:movl ,immediate (:ebp ,(argument-stack-offset binding))))) + ((:eax :ebx :ecx :edx) + (make-immediate-move immediate location)) + ((:untagged-fixnum-ecx) + (make-immediate-move (movitz-fixnum-value value) :ecx)))))) + (movitz-character + (let ((immediate (movitz-immediate-value value))) + (if (integerp location) + (let ((tmp (chose-free-register protect-registers))) + (append (make-immediate-move immediate tmp) + `((:movl ,tmp (:ebp ,(stack-frame-offset location)))))) + (ecase (operator location) + ((:argument-stack) + `((:movl ,immediate (:ebp ,(argument-stack-offset binding))))) + ((:eax :ebx :ecx :edx) + (make-immediate-move immediate location)))))) + (movitz-heap-object + (etypecase location + ((member :eax :ebx :edx) + (make-load-constant value location funobj frame-map)) + (integer + (let ((tmp (chose-free-register protect-registers))) + (append (make-load-constant value tmp funobj frame-map) + (make-store-lexical binding tmp shared-reference-p + funobj frame-map + :protect-registers protect-registers)))) + ((eql :untagged-fixnum-ecx) + (check-type value movitz-bignum) + (let ((immediate (movitz-bignum-value value))) + (check-type immediate (unsigned-byte 32)) + (make-immediate-move immediate :ecx))) + ))))) + (t (error "Generalized lexb source for store-lexical not implemented: ~S" source)))))))))) (defun finalize-code (code funobj frame-map) ;; (print-code 'to-be-finalized code) From ffjeld at common-lisp.net Tue Apr 15 23:06:47 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 15 Apr 2008 19:06:47 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080415230647.7FB1731035@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv8203 Modified Files: more-macros.lisp Log Message: Fix compiler-macro pop that would cause serious compilation mistakes. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/09 18:33:41 1.42 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/15 23:06:47 1.43 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.42 2008/04/09 18:33:41 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.43 2008/04/15 23:06:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,10 +38,7 @@ `(with-inline-assembly (:returns :ebx) (:compile-form (:result-mode :eax) ,place) (:globally (:call (:edi (:edi-offset fast-cdr-car)))) - (:lexical-store ,place :eax)) - #+ignore - `(prog1 (car ,place) - (setq ,place (cdr ,place))) + (:lexical-store ,place :eax :protect-registers (:ebx))) form)) (defmacro push (&environment env item place) @@ -56,13 +53,6 @@ (let ((,store-var (cons ,item-var ,getter-form))) ,setter-form))))) -#+ignore -(define-compiler-macro push (&whole form &environment env item place) - (if (and (symbolp place) - (not (typep (movitz::movitz-binding place env) 'movitz::symbol-macro-binding))) - `(setq ,place (cons ,item ,place)) - form)) - (defmacro pushnew (&environment env item place &rest key-test-args) (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) (get-setf-expansion place env) @@ -333,6 +323,14 @@ (error 'end-of-file :stream ,stream) ,eof-value)) +(defmacro/run-time with-dynamic-extent-scope ((tag) &body body) + (declare (ignore tag)) + `(progn , at body)) + +(defmacro/run-time with-dynamic-extent-allocation ((tag) &body body) + (declare (ignore tag)) + `(progn , at body)) + (defmacro handler-bind (bindings &body forms) (if (null bindings) `(progn , at forms) @@ -542,6 +540,7 @@ (define-unimplemented-macro with-open-file) (define-unimplemented-macro restart-case) +(define-unimplemented-macro with-condition-restarts) (defmacro/cross-compilation load (filespec &key verbose print if-does-not-exist external-format) "hm..." From ffjeld at common-lisp.net Thu Apr 17 19:09:29 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:09:29 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080417190929.A2D314F016@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv9168 Modified Files: compiler.lisp Log Message: Remove some dead code. Be more precise about when ECX can be used for temporary storage. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/15 23:04:39 1.202 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/17 19:09:28 1.203 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.202 2008/04/15 23:04:39 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.203 2008/04/17 19:09:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1073,26 +1073,6 @@ :initial-contents code-vector))))) funobj) -(defun check-locate-concistency (code-vector) - "The run-time function muerte::%find-code-vector sometimes needs to find a code-vector by -searching through the machine-code for an object header signature. This function is to -make sure that no machine code accidentally forms such a header signature." - (loop for x from 0 below (length code-vector) by 8 - do (when (and (= (tag :basic-vector) (aref code-vector x)) - (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x))) - (or (<= #x4000 (length code-vector)) - (and (= (ldb (byte 8 0) (length code-vector)) - (aref code-vector (+ x 2))) - (= (ldb (byte 8 8) (length code-vector)) - (aref code-vector (+ x 3)))))) - (break "Code-vector (length ~D) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X." - (length code-vector) x - (aref code-vector (+ x 0)) - (aref code-vector (+ x 1)) - (aref code-vector (+ x 2)) - (aref code-vector (+ x 3))))) - (values)) - (defun check-locate-concistency (code code-vector-length) "The run-time function muerte::%find-code-vector sometimes needs to find a code-vector by searching through the machine-code for an object header signature. This function is to @@ -3650,7 +3630,11 @@ (if (and nil (typep source 'constant-object-binding)) (make-load-constant (constant-object source) binding funobj frame-map) (let ((protect-registers (list* source protect-registers))) - (unless (or (eq source :untagged-fixnum-ecx)) ; test binding type! + (unless (or (eq source :untagged-fixnum-ecx) + (and (binding-store-type binding) + (multiple-value-call #'encoded-subtypep + (values-list (binding-store-type binding)) + (type-specifier-encode '(or integer character))))) (push :ecx protect-registers)) (cond ((eq :untagged-fixnum-ecx source) From ffjeld at common-lisp.net Thu Apr 17 19:27:43 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:27:43 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080417192743.7BBFA2001B@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13631 Modified Files: image.lisp Log Message: Tweak dump-image wrt. qemu-align. --- /project/movitz/cvsroot/movitz/image.lisp 2008/04/12 16:43:49 1.121 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/17 19:27:43 1.122 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.121 2008/04/12 16:43:49 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.122 2008/04/17 19:27:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -839,14 +839,15 @@ (values)) (defun dump-image (&key (path *default-image-file*) ((:image *image*) *image*) - (multiboot-p t) ignore-dump-count (qemu-align-p t)) + (multiboot-p t) ignore-dump-count (qemu-align :floppy)) "When is true, include a MultiBoot-compliant header in the image." (when (and (not ignore-dump-count) (= 0 (dump-count *image*))) ;; This is a hack to deal with the fact that the first dump won't work ;; because the packages aren't properly set up. (format t "~&;; Doing initiating dump..") - (dump-image :path path :multiboot-p multiboot-p :ignore-dump-count t) + (dump-image :path path :multiboot-p multiboot-p :ignore-dump-count t + :qemu-align nil) (assert (plusp (dump-count *image*)))) (setf (movitz-symbol-value (movitz-read 'muerte:*build-number*)) (1+ *bootblock-build*)) @@ -969,8 +970,8 @@ (image-end (file-position stream)) (kernel-size (- image-end image-start))) (format t "~&;; Kernel size: ~D octets.~%" kernel-size) - (cond - (qemu-align-p + (ecase qemu-align + (:floppy ;; QEMU is rather stupid about "auto-detecting" floppy geometries. (loop for qemu-geo in '(320 360 640 720 720 820 840 1440 1440 1600 1640 1660 1760 2080 2240 2400 2880 2952 2988 3200 3200 3360 3444 3486 3520 3680 3840 5760 6240 6400 7040 7680) @@ -980,13 +981,19 @@ (write-byte #x0 stream) (return)) finally - (cerror "Never mind, dump the image." - "No matching QEMU floppy geometry for size ~,2F MB." (/ image-end (* 1024 1024))))) - (t (let ((align-image-size 512)) ; Ensure image is multiple of x octets - (unless (zerop (mod image-end align-image-size)) - (set-file-position stream (+ image-end (- (1- align-image-size) (mod image-end 512))) - 'pad-image-tail) - (write-byte #x0 stream))))) + (cerror "Never mind, dump the image without any QEMU geometry alignment." + "No matching QEMU floppy geometry for size ~,2F MB." + (/ image-end (* 1024 1024))))) + (:hd (let ((align-image-size (* 512 16 63))) ; Ensure image is multiple of x octets + (unless (zerop (mod image-end align-image-size)) + (set-file-position stream (+ image-end (- (1- align-image-size) (mod image-end 512))) + 'pad-image-tail) + (write-byte #x0 stream)))) + ((nil) (let ((align-image-size (* 512 1))) ; Ensure image is multiple of x octets + (unless (zerop (mod image-end align-image-size)) + (set-file-position stream (+ image-end (- (1- align-image-size) (mod image-end 512))) + 'pad-image-tail) + (write-byte #x0 stream))))) (format t "~&;; Image file size: ~D octets.~%" image-end) ;; Write simple stage1 bootblock into sector 0.. (format t "~&;; Dump count: ~D." (incf (dump-count *image*))) From ffjeld at common-lisp.net Thu Apr 17 19:28:38 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:28:38 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080417192838.4B110450B5@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13777 Modified Files: special-operators.lisp Log Message: Tweak assembly-macro :lexical-store. --- /project/movitz/cvsroot/movitz/special-operators.lisp 2008/04/12 16:23:26 1.58 +++ /project/movitz/cvsroot/movitz/special-operators.lisp 2008/04/17 19:28:37 1.59 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.58 2008/04/12 16:23:26 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.59 2008/04/17 19:28:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -564,9 +564,11 @@ nil)) (setf (assembly-macro-expander :lexical-store amenv) (lambda (expr) - (destructuring-bind (var reg &key (type t)) + (destructuring-bind (var reg &key (type t) protect-registers) (cdr expr) - `((:store-lexical ,(movitz-binding var env) ,reg :type ,type))))) + `((:store-lexical ,(movitz-binding var env) ,reg + :type ,type + :protect-registers ,protect-registers))))) (setf (assembly-macro-expander :lexical-binding amenv) (lambda (expr) (destructuring-bind (var) From ffjeld at common-lisp.net Thu Apr 17 19:30:46 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:30:46 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193046.3720A1B01A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14102 Modified Files: loop.lisp Log Message: Make loop work at run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp 2008/03/15 20:57:44 1.8 +++ /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp 2008/04/17 19:30:43 1.9 @@ -64,8 +64,19 @@ ;;;(in-package :ansi-loop) -(provide :muerte/loop :load-priority 0) +(provide :muerte/loop :load-priority 1) +#+movitz +(progn + (defmacro movitz-macroexpand (&rest args) + `(macroexpand , at args)) + (defmacro movitz-macroexpand-1 (&rest args) + `(macroexpand-1 , at args)) + (eval-when (:compile-toplevel) + (defmacro movitz-macroexpand (&rest args) + `(movitz::movitz-macroexpand , at args)) + (defmacro movitz-macroexpand-1 (&rest args) + `(movitz::movitz-macroexpand-1 , at args)))) ;;;This is the "current" loop context in use when we are expanding a ;;;loop. It gets bound on each invocation of LOOP. @@ -76,7 +87,7 @@ ;;@@@@Explorer?? #-Genera `(copy-list ,l)) -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :load-toplevel :execute) (defvar *loop-real-data-type* 'real) (defvar *loop-universe*) @@ -256,12 +267,11 @@ , at body))) -(defmacro/cross-compilation loop-collect-rplacd (&environment env +(defmacro loop-collect-rplacd (&environment env (head-var tail-var &optional user-head-var) form) (declare - #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail. - ) - (setq form (movitz::movitz-macroexpand form env)) + #+LISPM (ignore head-var user-head-var)) ;use locatives, unconditionally update through the tail. + (setq form (movitz-macroexpand form env)) (flet ((cdr-wrap (form n) (declare (fixnum n)) (do () ((<= n 4) (setq form `(,(case n @@ -364,7 +374,7 @@ ;;;; Maximization Technology -(eval-when (:compile-toplevel :execute) +(eval-when (:compile-toplevel :load-toplevel :execute) #| The basic idea of all this minimax randomness here is that we have to @@ -494,7 +504,7 @@ ;;;; Token Hackery -(eval-when (:compile-toplevel #+movitz-loop :load-toplevel) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, @@ -712,7 +722,7 @@ -(eval-when (:compile-toplevel #+movitz-loop :load-toplevel) +(eval-when (:compile-toplevel :load-toplevel :execute) ;;;; Code Analysis Stuff @@ -812,8 +822,10 @@ (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) ;;@@@@ ???? (declare (function list-size (list) fixnum)) (cond ((constantp x #+Genera env) 1) - ((symbolp x) (multiple-value-bind (new-form expanded-p) (movitz::movitz-macroexpand-1 x env) - (if expanded-p (estimate-code-size-1 new-form env) 1))) + ((symbolp x) + (multiple-value-bind (new-form expanded-p) + (movitz-macroexpand-1 x env) + (if expanded-p (estimate-code-size-1 new-form env) 1))) ((atom x) 1) ;??? self-evaluating??? ((symbolp (car x)) (let ((fn (car x)) (tem nil) (n 0)) @@ -848,7 +860,8 @@ ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) (throw 'estimate-code-size nil)) - (t (multiple-value-bind (new-form expanded-p) (movitz::movitz-macroexpand-1 x env) + (t (multiple-value-bind (new-form expanded-p) + (movitz-macroexpand-1 x env) (if expanded-p (estimate-code-size-1 new-form env) (f 3)))))))) @@ -864,14 +877,12 @@ (defun loop-error (format-string &rest format-args) - #+movitz (declare (dynamic-extent format-args)) #+(or Genera CLOE) (declare (dbg:error-reporter)) #+Genera (setq format-args (copy-list format-args)) ;Don't ask. (error "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) (defun loop-warn (format-string &rest format-args) - #+movitz (declare (dynamic-extent format-args)) (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) @@ -919,11 +930,11 @@ (loop-iteration-driver) (loop-bind-block) (let ((answer `(loop-body - ,(nreverse *loop-prologue*) - ,(nreverse *loop-before-loop*) - ,(nreverse *loop-body*) - ,(nreverse *loop-after-body*) - ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) + ,(reverse *loop-prologue*) + ,(reverse *loop-before-loop*) + ,(reverse *loop-body*) + ,(reverse *loop-after-body*) + ,(revappend *loop-epilogue* (reverse *loop-after-epilogue*))))) (do () (nil) (setq answer `(block ,(pop *loop-names*) ,answer)) (unless *loop-names* (return nil))) @@ -1234,7 +1245,7 @@ -(eval-when (:compile-toplevel #+movitz-loop :load-toplevel) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun loop-get-collection-info (collector class default-type) (let ((form (loop-get-form)) @@ -2037,10 +2048,6 @@ w)) -(defparameter *loop-ansi-universe* - (make-ansi-loop-universe nil)) - - (defun loop-standard-expansion (keywords-and-forms environment universe) (if (and keywords-and-forms (symbolp (car keywords-and-forms))) (loop-translate keywords-and-forms environment universe) @@ -2049,14 +2056,21 @@ ) +(eval-when (:compile-toplevel) + (defvar *loop-ansi-universe* + (make-ansi-loop-universe nil))) + +(eval-when (:load-toplevel :execute) + (defvar *loop-ansi-universe* nil)) + ;;;INTERFACE: ANSI -(defmacro/cross-compilation loop (&rest keywords-and-forms) +(defmacro loop (&rest keywords-and-forms) #+Genera (declare (compiler:do-not-record-macroexpansions) (zwei:indentation . zwei:indent-loop)) (loop-standard-expansion keywords-and-forms nil *loop-ansi-universe*)) ;;;INTERFACE: Traditional, ANSI, Lucid. -(defmacro/cross-compilation loop-finish () +(defmacro loop-finish () "Causes the iteration to terminate \"normally\", the same as implicit termination by an iteration driving clause, or by use of WHILE or UNTIL -- the epilogue code (if any) will be run, and any implicitly @@ -2064,12 +2078,12 @@ '(go end-loop)) -(defmacro/cross-compilation loop-body (prologue - before-loop - main-body - after-loop - epilogue - &aux (env nil) rbefore rafter flagvar) +(defmacro loop-body (prologue + before-loop + main-body + after-loop + epilogue + &aux (env nil) rbefore rafter flagvar) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists.")) ;;All our work is done from these copies, working backwards from the end: @@ -2141,7 +2155,7 @@ (return))))))) -(defmacro/cross-compilation loop-really-desetq (&rest var-val-pairs &aux (env nil)) +(defmacro loop-really-desetq (&rest var-val-pairs &aux (env nil)) (labels ((find-non-null (var) ;; see if there's any non-null thing here ;; recurse if the list element is itself a list @@ -2161,7 +2175,7 @@ (and (consp x) (or (not (eq (car x) 'car)) (not (symbolp (cadr x))) - (not (symbolp (setq x (movitz::movitz-macroexpand x env))))) + (not (symbolp (setq x (movitz-macroexpand x env))))) (cons x nil))) (cdr val)) `(,val)))) From ffjeld at common-lisp.net Thu Apr 17 19:31:13 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:31:13 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp Message-ID: <20080417193113.84D70281F2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv14218 Modified Files: los0.lisp Log Message: Initialize loop macroexpander at startup. --- /project/movitz/cvsroot/movitz/losp/los0.lisp 2007/04/09 17:30:15 1.51 +++ /project/movitz/cvsroot/movitz/losp/los0.lisp 2008/04/17 19:31:13 1.52 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.51 2007/04/09 17:30:15 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.52 2008/04/17 19:31:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,7 +56,7 @@ (in-package los0) ;; (defun load-ansi-tests () -;; (load "../ansi-tests.lisp")) +;; (load "ansi-tests.lisp")) (defun assess-cpu-frequency () "Assess the CPU's frequency in units of 1024 Hz." @@ -470,7 +470,9 @@ *standard-input* s *terminal-io* s *debug-io* s))) - + (when (fboundp 'muerte::make-ansi-loop-universe) + (setf muerte::*loop-ansi-universe* + (muerte::make-ansi-loop-universe nil))) (setf threading:*segment-descriptor-table-manager* (make-instance 'threading:segment-descriptor-table-manager)) From ffjeld at common-lisp.net Thu Apr 17 19:32:27 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:32:27 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193227.EB1E9450B5@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14362 Modified Files: conditions.lisp Log Message: Add defun simple-program-error. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2008/04/09 18:01:36 1.26 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2008/04/17 19:32:27 1.27 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.26 2008/04/09 18:01:36 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.27 2008/04/17 19:32:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -102,6 +102,11 @@ (define-condition program-error (error) ()) +(defun simple-program-error (format-control &rest format-arguments) + (error 'program-error + :format-control format-control + :format-argumetns format-arguments)) + (define-condition type-error (error) ((expected-type :initarg :expected-type From ffjeld at common-lisp.net Thu Apr 17 19:33:11 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:33:11 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193311.D0F5E64049@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14469 Modified Files: defstruct.lisp Log Message: Fix a bug where the :copier and :constructor options were mixed up. --- /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2008/03/15 20:57:34 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2008/04/17 19:33:11 1.19 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.18 2008/03/15 20:57:34 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.19 2008/04/17 19:33:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -168,7 +168,7 @@ (:conc-name (push (string (or parameter "")) (getf collector :conc-name))) (:constructor (push parameter (getf collector :constructor))) - (:copier (push parameter (getf collector :constructor))) + (:copier (push parameter (getf collector :copier))) (:predicate (push parameter (getf collector :predicate))) (:type (push parameter (getf collector :type))) (:initial-offset (push parameter (getf collector :initial-offset))) From ffjeld at common-lisp.net Thu Apr 17 19:33:28 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:33:28 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193328.194CC1A0A3@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14536 Modified Files: environment.lisp Log Message: Fresh-lines in trace output. --- /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2006/04/07 21:53:47 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2008/04/17 19:33:27 1.16 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.15 2006/04/07 21:53:47 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.16 2008/04/17 19:33:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -86,7 +86,7 @@ (fresh-line *trace-output*) (dotimes (i *trace-level*) (write-string " " *trace-output*)) - (format *trace-output* "~D: (~S~{ ~S~})~%" + (format *trace-output* "~&~D: (~S~{ ~S~})~%" *trace-level* function-name args)) (multiple-value-call (lambda (&rest results) @@ -95,7 +95,7 @@ (fresh-line *trace-output*) (dotimes (i (min *trace-level* 10)) (write-string " " *trace-output*)) - (format *trace-output* "~D: =>~{ ~W~^,~}.~%" + (format *trace-output* "~&~D: =>~{ ~W~^,~}.~%" *trace-level* results) (values-list results))) (let ((*trace-level* (1+ *trace-level*)) From ffjeld at common-lisp.net Thu Apr 17 19:33:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:33:48 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193348.1FFA73611A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14612 Modified Files: eval.lisp Log Message: Prefer assert over unless .. error. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/13 20:12:37 1.30 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/17 19:33:48 1.31 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.30 2008/04/13 20:12:37 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.31 2008/04/17 19:33:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -487,7 +487,7 @@ (declare (ignore)) (let* ((tag (cadr form)) (b (cdr (op-env-binding env tag +eval-binding-type-go-tag+)))) - (unless b (error "Go-tag ~S is not visible." tag)) + (assert b () "Go-tag ~S is not visible." tag) (throw (cdr b) (values tag)))) (defun eval-set-variable (variable-name value env) From ffjeld at common-lisp.net Thu Apr 17 19:34:08 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:34:08 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193408.CEA9646181@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14683 Modified Files: hash-tables.lisp Log Message: Fix the utterly broken remhash. --- /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp 2007/02/06 20:03:57 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp 2008/04/17 19:34:08 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.13 2007/02/06 20:03:57 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.14 2008/04/17 19:34:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -246,8 +246,9 @@ ((>= i bucket-length) nil) (declare ((index 2) i index2)) (let ((x (svref bucket index2))) - (when (or (eq x '--no-hash-key--) - (funcall (hash-table-test hash-table) x key)) + (when (eq x '--no-hash-key--) + (return nil)) + (when (funcall (hash-table-test hash-table) x key) (setf (svref bucket index2) '--no-hash-key--) (decf (hash-table-count hash-table)) ;; Now we must rehash any entries that might have been @@ -257,10 +258,11 @@ ((= i index2)) (declare ((index 2) i)) (let ((k (svref bucket i))) - (when (eq x '--no-hash-key--) + (when (eq k '--no-hash-key--) (return)) (let ((v (svref bucket (1+ i)))) (setf (svref bucket i) '--no-hash-key--) ; remove + (decf (hash-table-count hash-table)) (setf (gethash k hash-table) v)))) ; insert (hopefully this is safe..) (return t))))) @@ -282,5 +284,5 @@ (get-next-entry) (if (not entry-p) (return nil) - (map key value))))))) + (map key value))))))) From ffjeld at common-lisp.net Thu Apr 17 19:34:39 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:34:39 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193439.BB0D666008@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14769 Modified Files: integers.lisp Log Message: Remove superfluous logandc1 and logandc2. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/13 08:21:40 1.125 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/17 19:34:39 1.126 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.125 2008/04/13 08:21:40 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.126 2008/04/17 19:34:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2300,14 +2300,6 @@ (declare (ignore integer-1)) integer-2) -(defun logandc1 (integer-1 integer-2) - (logand (lognot integer-1) - integer-2)) - -(defun logandc2 (integer-1 integer-2) - (logand integer-1 - (lognot integer-2))) - (defun boole-c1 (integer-1 integer-2) (declare (ignore integer-2)) (lognot integer-1)) From ffjeld at common-lisp.net Thu Apr 17 19:35:05 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:35:05 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193505.4CF4670DF@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14911 Modified Files: more-macros.lisp Log Message: Remove bogous loop macro placeholder. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/15 23:06:47 1.43 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/17 19:35:05 1.44 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.43 2008/04/15 23:06:47 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.44 2008/04/17 19:35:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -575,6 +575,3 @@ (*read-suppress* nil) #+ignore (*readtable* nil)) , at body)) - -(defmacro/run-time loop (&rest clauses) - (error "Loop not implemented.")) From ffjeld at common-lisp.net Thu Apr 17 19:35:20 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:35:20 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193520.7BEB43001B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14977 Modified Files: ratios.lisp Log Message: More float "emulation". --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/04/08 13:44:44 1.10 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2008/04/17 19:35:20 1.11 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.10 2007/04/08 13:44:44 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.11 2008/04/17 19:35:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,10 +76,17 @@ (integer 1) (ratio (%ratio-denominator x)))) -(defconstant least-positive-short-float 1/1000) -(defconstant least-positive-single-float 1/1000) -(defconstant least-positive-double-float 1/1000) -(defconstant least-positive-long-float 1/1000) +;;; "Floats" + +(defconstant most-negative-short-float most-negative-fixnum) +(defconstant most-negative-single-float most-negative-fixnum) +(defconstant most-negative-long-float most-negative-fixnum) +(defconstant most-negative-double-float most-negative-fixnum) + +(defconstant least-positive-short-float 1/100000) +(defconstant least-positive-single-float 1/100000) +(defconstant least-positive-double-float 1/100000) +(defconstant least-positive-long-float 1/100000) ;;; @@ -87,6 +94,40 @@ (defvar long-float-epsilon 1/10000) +(defun float (x &optional proto) + (declare (ignore proto)) + (check-type x float) + x) + +(defun float-radix (x) + (if (integerp x) + 2 + (denominator x))) + +(defun integer-decode-float (x) + (if (integerp x) + (if (minusp x) + (values x 0 -1) + (values x 0 1)) + (let ((n (numerator x))) + (if (minusp x) + (values n -1 -1) + (values n -1 1))))) + +(defun decode-float (x) + (multiple-value-bind (n sign) + (let ((n (numerator x))) + (if (minusp n) + (values (- n) -1) + (values n 1))) + (let* ((r (float-radix x)) + (d (denominator x)) + (e (if (= 1 d) 0 -1))) + (do () ((< n 1) + (values n e sign)) + (setf n (/ n r)) + (incf e))))) + (defun cos (x) "http://mathworld.wolfram.com/Cosine.html" (do* ((rad (mod x 44/7)) From ffjeld at common-lisp.net Thu Apr 17 19:35:49 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:35:49 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193549.27A7E5001A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv15052 Modified Files: scavenge.lisp Log Message: Tweak map-header-vals. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/07 20:50:38 1.61 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2008/04/17 19:35:49 1.62 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.61 2007/04/07 20:50:38 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.62 2008/04/17 19:35:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,11 +56,17 @@ (byte 8 8) (movitz:tag primary)))) `(= ,code ,x))) - (record-scan (x) + (record-scan (&optional (tag :other)) (declare (ignorable x)) - #+ignore `(setf *scan-last* ,x))) + `(let ((x (%word-offset scan ,(movitz:tag tag)))) + #+ignore (when (and (los0::object-in-space-p (%run-time-context-slot nil 'nursery-space) x) + (not (typep x 'vector)) + (not (typep x 'function))) + (format t "~&Scan: ~S: ~Z ~A~%" scan x (type-of x))) + ;; `(format t "~&Scan: ~S: ~Z" scan x) + (setf *scan-last* x)))) (do ((verbose *map-header-vals-verbose*) - #+ignore (*scan-last* nil) ; Last scanned object, for debugging. + #+ignore (*scan-last* nil) ; Last scanned object, for debugging. (scan start-location (1+ scan))) ((>= scan end-location)) (declare (fixnum scan)) @@ -74,41 +80,53 @@ (= tag #.(movitz:tag :even-fixnum)) (= tag #.(movitz:tag :odd-fixnum)) (scavenge-typep x :character)))) - ((or (and (= 0 x2) (= 2 x)) - (and (= #xffff x2) (= #xfffe x)) - (and (= #x7fff x2) (= #xffff x)))) + ((or (and (= 0 x2) + (= 2 x)) + (and (= #xffff x2) + (= #xfffe x)) + (and (= #x7fff x2) + (= #xffff x)))) ((scavenge-typep x :illegal) (error "Illegal word #x~4,'0X at #x~X." x scan)) ((scavenge-typep x :bignum) (assert (evenp scan) () "Scanned bignum-header #x~4,'0X at odd location #x~X." x scan) ;; Just skip the bigits + (record-scan :other) (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) (delta (logior bigits 1))) - (record-scan (%word-offset scan #.(movitz:tag :other))) (incf scan delta))) ((scavenge-typep x :defstruct) (assert (evenp scan) () "Scanned struct-header #x~4,'0X at odd location #x~X." x scan) - (record-scan (%word-offset scan #.(movitz:tag :other)))) + (record-scan :other)) ((scavenge-typep x :run-time-context) (assert (evenp scan) () "Scanned run-time-context-header #x~4,'0X at odd location #x~X." (memref scan 0 :type :unsigned-byte32) scan) - (incf scan) - (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context - 'movitz::pointer-start) - (movitz::image-nil-word movitz:*image*)) - 4)) - (end (+ scan #.(movitz::movitz-type-word-size 'movitz::movitz-run-time-context)))) - (incf scan non-lispvals) - (map-lisp-vals function scan (1+ end)) - (setf scan end))) + (record-scan :other) + (let ((rtc (%word-offset scan #.(movitz:tag :other)))) + (incf scan) + (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context + 'movitz::pointer-start) + (movitz::image-nil-word movitz:*image*)) + 4)) + (end (+ scan #.(movitz::movitz-type-word-size 'movitz::movitz-run-time-context)))) + (incf scan non-lispvals) + (check-type rtc run-time-context) + (let ((old-stack (%run-time-context-slot rtc 'stack-vector))) + ;; (warn "old-stack: ~Z" old-stack) + (map-lisp-vals function scan (1+ end)) + (let ((new-stack (%run-time-context-slot rtc 'stack-vector))) + ;; (warn "new-stack: ~Z" new-stack) + (when (not (eq old-stack new-stack)) + (error "Stack-vector for ~S moved from ~Z to ~Z." rtc old-stack new-stack)))) + (setf scan end)))) ((scavenge-typep x :funobj) (assert (evenp scan) () "Scanned funobj-header #x~4,'0X at odd location #x~X." (memref scan 0 :type :unsigned-byte32) scan) - (record-scan (%word-offset scan #.(movitz:tag :other))) + (record-scan :other) ;; Process code-vector pointers specially.. (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) (new-code-vector (if (eq 0 old-code-vector) @@ -170,34 +188,37 @@ (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) (let ((len (memref scan 4))) - (record-scan (%word-offset scan #.(movitz:tag :other))) + (record-scan :other) (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) (let ((len (memref scan 0 :index 1))) - (record-scan (%word-offset scan #.(movitz:tag :other))) + (record-scan :other) (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) - ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) + ((or (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :stack))) (let ((len (memref scan 4))) - (record-scan (%word-offset scan #.(movitz:tag :other))) + (record-scan :other) (incf scan (1+ (logand (1+ len) -2))))) ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :bit)) (let ((len (memref scan 4))) - (record-scan (%word-offset scan #.(movitz:tag :other))) + (record-scan :other) (incf scan (1+ (* 2 (truncate (+ 63 len) 64)))))) ((or (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type - :any-t)) + :any-t)) (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type - :indirects))) - (record-scan (%word-offset scan #.(movitz:tag :other)))) + :indirects))) + (record-scan :other)) (t (error "Scanned unknown basic-vector-header #x~4,'0X at location #x~X." x scan)))) ((and (eq x 3) (eq x2 0)) - (record-scan scan) + ;; (record-scan scan) (incf scan) (let ((delta (memref scan 0))) (check-type delta positive-fixnum) - ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) + (format t "at ~S skipping ~S to ~S." scan delta (+ scan delta)) (incf scan delta))) (t ;; (typep x 'pointer) (let* ((old (memref scan 0)) @@ -439,5 +460,3 @@ (* location-offset 4) lowbits)))) new-code-vector))) - - From ffjeld at common-lisp.net Thu Apr 17 19:36:09 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:36:09 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080417193609.782871B017@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv15213 Modified Files: strings.lisp Log Message: Add string< and friends. --- /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2005/06/12 20:01:49 1.3 +++ /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/17 19:36:09 1.4 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 17:05:25 2001 ;;;; -;;;; $Id: strings.lisp,v 1.3 2005/06/12 20:01:49 ffjeld Exp $ +;;;; $Id: strings.lisp,v 1.4 2008/04/17 19:36:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -99,5 +99,97 @@ (t (setf between-words-p (not (char-alpha-p c))) (char-downcase c)))))))) - - +(defun string%<= (string1 string2 result= start1 end1 start2 end2) + (let ((mismatch (mismatch string1 string2 + :start1 start1 + :end1 end1 + :start2 start2 + :end2 end2 + :test #'char=))) + (cond + ((not mismatch) + (when result= + (or end1 (length string1)))) + ((>= mismatch (or end1 (length string1))) + mismatch) + ((>= mismatch (or end2 (length string2))) + nil) + (t (when (char< (char string1 mismatch) + (char string2 mismatch)) + mismatch))))) + +(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2) + "=> mismatch-index" + (let ((mismatch (mismatch string1 string2 + :start1 start1 + :end1 end1 + :start2 start2 + :end2 end2 + :test #'char=))) + (cond + ((not mismatch) + nil) + ((>= mismatch (or end1 (length string1))) + mismatch) + ((>= mismatch (or end2 (length string2))) + nil) + (t (when (char< (char string1 mismatch) + (char string2 mismatch)) + mismatch))))) + +(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2) + "=> mismatch-index" + (let ((mismatch (mismatch string1 string2 + :start1 start1 + :end1 end1 + :start2 start2 + :end2 end2 + :test #'char=))) + (cond + ((not mismatch) + (or end1 (length string1))) + ((>= mismatch (or end1 (length string1))) + mismatch) + ((>= mismatch (or end2 (length string2))) + nil) + (t (when (char<= (char string1 mismatch) + (char string2 mismatch)) + mismatch))))) + +(defun string> (string1 string2 result= start1 end1 start2 end2) + "=> mismatch-index" + (let ((mismatch (mismatch string1 string2 + :start1 start1 + :end1 end1 + :start2 start2 + :end2 end2 + :test #'char=))) + (cond + ((not mismatch) + nil) + ((>= mismatch (or end1 (length string1))) + mismatch) + ((>= mismatch (or end2 (length string2))) + nil) + (t (when (char> (char string1 mismatch) + (char string2 mismatch)) + mismatch))))) + +(defun string>= (string1 string2 result= start1 end1 start2 end2) + "=> mismatch-index" + (let ((mismatch (mismatch string1 string2 + :start1 start1 + :end1 end1 + :start2 start2 + :end2 end2 + :test #'char=))) + (cond + ((not mismatch) + (or end1 (length string1))) + ((>= mismatch (or end1 (length string1))) + mismatch) + ((>= mismatch (or end2 (length string2))) + nil) + (t (when (char>= (char string1 mismatch) + (char string2 mismatch)) + mismatch))))) From ffjeld at common-lisp.net Thu Apr 17 19:37:01 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 17 Apr 2008 15:37:01 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp Message-ID: <20080417193701.D25CA3611A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv15613 Modified Files: los0-gc.lisp Log Message: Break if GC doesn't free anything. It usually means we're dead. --- /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2007/04/09 17:30:09 1.62 +++ /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2008/04/17 19:37:01 1.63 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.62 2007/04/09 17:30:09 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.63 2008/04/17 19:37:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -429,8 +429,6 @@ new))))) ((not (object-in-space-p oldspace x)) x) - #+ignore ((when (typep x 'run-time-context) - (warn "Scavenging ~S" x))) (t (or (and (eq (object-tag x) (ldb (byte 3 0) (memref (object-location x) 0 :type :unsigned-byte8))) @@ -438,6 +436,8 @@ (and (object-in-space-p newspace forwarded-x) forwarded-x))) (let ((forward-x (shallow-copy x))) + (when (typep x 'run-time-context) + (break "Evac RTC ~Z -> ~Z" x forward-x)) (when (and *gc-consistency-check* (typep x 'muerte::pointer)) (let ((a *x*)) @@ -533,6 +533,8 @@ (unless *gc-quiet* (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) + (when (= old-size new-size) + (break "No memory freed by GC.")) (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" old-size new-size (- old-size new-size)))) From ffjeld at common-lisp.net Fri Apr 18 09:55:13 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 18 Apr 2008 05:55:13 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080418095513.C5CB83611A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv32636 Modified Files: arrays.lisp Log Message: Stupid hack to make ansi-tests load. Will return nil for non-vector arrays. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/04/02 20:49:37 1.66 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/04/18 09:55:13 1.67 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.66 2008/04/02 20:49:37 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.67 2008/04/18 09:55:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1169,8 +1169,8 @@ dimensions) ((and (consp dimensions) (null (cdr dimensions))) (car dimensions)) - (t - (error "Multi-dimensional arrays not supported."))))) + (t (warn "Array of rank ~D not supported." (length dimensions)) + (return-from make-array nil))))) ; XXX (cond (displaced-to (make-indirect-vector displaced-to displaced-index-offset fill-pointer size)) From ffjeld at common-lisp.net Sat Apr 19 12:42:56 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 19 Apr 2008 08:42:56 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080419124256.4AB965909A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9679 Modified Files: basic-functions.lisp Log Message: Remove dead code. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/04/08 21:40:33 1.25 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/04/19 12:42:56 1.26 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.25 2008/04/08 21:40:33 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.26 2008/04/19 12:42:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -466,36 +466,3 @@ (setf (memref object offset :index i :type :character) (char value j)))))))) value) - - - -(define-primitive-function blah () - "foo" - (with-inline-assembly (:returns :multiple-values) - ;; EAX: (presumed) keyword - (:globally (:cmpl :eax (:edi (:edi-offset allow-other-keys-symbol)))) - (:je '(:sub-program (found-allow-other-keys) - ; XXX - (:ret))) - (:leal (:ebx -7) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program () - (:xorl :ecx :ecx) ; hash of nil is 0 - (:cmpl :edi :ebx) - (:je 'proceed-with-nil-key) - (:movl :ebx :eax) - (:movb 0 :cl) - (:int 72))) - (:xorl :ecx :ecx) - (:movw (:eax (:offset movitz-symbol hash-key)) :cx) - proceed-with-nil-key - ;; We now have symbol's basic sxhash in CX. - (:xorl :edx :edx) - (:leal ((:ecx 4) :edx) :edx) - (:andl (:esi (:offset movitz-funobj constant0)) - :edx) - - (:ret) - - )) - From ffjeld at common-lisp.net Sat Apr 19 12:43:52 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 19 Apr 2008 08:43:52 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080419124352.DD37B301F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9932 Modified Files: defstruct.lisp Log Message: Add a run-time defstruct placeholder. --- /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2008/04/17 19:33:11 1.19 +++ /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2008/04/19 12:43:50 1.20 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.19 2008/04/17 19:33:11 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.20 2008/04/19 12:43:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -334,3 +334,7 @@ (slot-number ,slot-number))) ',struct-name)) )))))) + +(defmacro/run-time defstruct (&rest ignore) + (identity 'structure); just to reference the symbol. + (error "Defstruct not implemented.")) From ffjeld at common-lisp.net Sat Apr 19 12:44:02 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 19 Apr 2008 08:44:02 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080419124402.1EF6D42032@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10010 Modified Files: lists.lisp Log Message: Add mapl. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/14 21:06:47 1.26 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/19 12:44:02 1.27 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.26 2008/04/14 21:06:47 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.27 2008/04/19 12:44:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -321,6 +321,7 @@ (map-into more-lists #'cdr more-lists)))))) + (defun mapcan (function first-list &rest more-lists) (numargs-case (2 (function first-list) @@ -427,6 +428,29 @@ (setf first-list (cdr first-list) more-lists (map-into more-lists #'cdr more-lists)))))) +(defun mapl (function first-list &rest more-lists) + (numargs-case + (2 (function first-list) + (do ((p first-list (cdr p))) + ((endp p) + first-list) + (funcall function p))) + (3 (function first-list second-list) + (do ((p1 first-list (cdr p1)) + (p2 second-list (cdr p2))) + ((or (endp p1) (endp p2)) + first-list) + (funcall function p1 p2))) + (t (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (do () + ((or (endp first-list) + (some #'endp more-lists)) + first-list) + (apply function first-list more-lists) + (setf first-list (cdr first-list) + more-lists (map-into more-lists #'cdr more-lists)))))) + (defun nbutlast (list &optional (n 1)) (let ((start-right (nthcdr n list))) (if (endp start-right) From ffjeld at common-lisp.net Sat Apr 19 12:44:40 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 19 Apr 2008 08:44:40 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080419124440.D117067096@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10152 Modified Files: more-macros.lisp Log Message: Add a run-time define-compiler-macro placeholder. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/17 19:35:05 1.44 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/19 12:44:40 1.45 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.44 2008/04/17 19:35:05 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.45 2008/04/19 12:44:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -575,3 +575,9 @@ (*read-suppress* nil) #+ignore (*readtable* nil)) , at body)) + +(defmacro/run-time define-compiler-macro (name &rest ignore) + (declare (ignore ignore)) + 'compiler-macro + name) + \ No newline at end of file From ffjeld at common-lisp.net Sat Apr 19 12:45:03 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 19 Apr 2008 08:45:03 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080419124503.216182105F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10353 Modified Files: packages.lisp Log Message: Tweak intern slightly for speed. --- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2006/04/28 21:19:08 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/19 12:45:03 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.13 2006/04/28 21:19:08 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.14 2008/04/19 12:45:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -100,7 +100,7 @@ (when (eq package (find-package :keyword)) (setf (symbol-flags symbol) #.(bt:enum-value 'movitz::movitz-symbol-flags '(:constant-variable))) - (setf (symbol-value symbol) + (setf (%symbol-global-value symbol) symbol)))) (unless (symbol-package symbol) (setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'package)) package)) From ffjeld at common-lisp.net Sat Apr 19 12:45:14 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 19 Apr 2008 08:45:14 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080419124514.8016263089@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10561 Modified Files: ratios.lisp Log Message: More float emulation. --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2008/04/17 19:35:20 1.11 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2008/04/19 12:45:14 1.12 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.11 2008/04/17 19:35:20 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.12 2008/04/19 12:45:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -142,3 +142,15 @@ (defun sin (x) (cos (- x (/ pi 2)))) + +(defun ffloor (number &optional (divisor 1)) + (floor number divisor)) + +(defun ftruncate (number &optional (divisor 1)) + (truncate number divisor)) + +(defun fround (number &optional (divisor 1)) + (round number divisor)) + +(defun fceiling (number &optional (divisor 1)) + (ceiling number divisor)) From ffjeld at common-lisp.net Sat Apr 19 15:21:58 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 19 Apr 2008 11:21:58 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080419152158.6E2444C005@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv17110 Modified Files: print.lisp Log Message: Add *print-lines* and *print-miser-width*. --- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2008/03/21 22:31:07 1.25 +++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2008/04/19 15:21:57 1.26 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.25 2008/03/21 22:31:07 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.26 2008/04/19 15:21:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,6 +33,8 @@ (defvar *print-pretty* t) (defvar *print-circle* nil) (defvar *print-case* :upcase) +(defvar *print-lines* nil) +(defvar *print-miser-width* nil) (defvar *print-safely* nil) From ffjeld at common-lisp.net Mon Apr 21 19:28:46 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:28:46 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421192846.9900339171@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21673 Modified Files: sequences.lisp Log Message: Handle :test-not args more consistently. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/08 20:20:07 1.40 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/21 19:28:46 1.41 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.40 2008/04/08 20:20:07 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.41 2008/04/21 19:28:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,7 +23,7 @@ (or (typep x 'vector) (typep x 'cons))) -(defmacro sequence-dispatch (sequence-var (type0 &body forms0) (type1 &body forms1)) +(defmacro do-sequence-dispatch (sequence-var (type0 &body forms0) (type1 &body forms1)) (cond ((and (eq 'list type0) (eq 'vector type1)) `(if (typep ,sequence-var 'list) @@ -35,9 +35,33 @@ (progn (check-type ,sequence-var vector) , at forms0) (progn , at forms1))) - (t (error "sequence-dispatch only understands list and vector types, not ~W and ~W." + (t (error "do-sequence-dispatch only understands list and vector types, not ~W and ~W." type0 type1)))) +(defmacro with-tester ((test test-not) &body body) + (let ((function (gensym "with-test-")) + (notter (gensym "with-test-notter-"))) + `(multiple-value-bind (,function ,notter) + (progn ;; the (values function boolean) + (ensure-tester ,test ,test-not)) + (macrolet ((,test (&rest args) + `(xor (funcall%unsafe ,',function , at args) + ,',notter))) + , at body)))) + +(defun ensure-tester (test test-not) + (cond + (test-not + (when test + (error "Both test and test-not specified.")) + (values (ensure-funcallable test-not) + t)) + (test + (values (ensure-funcallable test) + nil)) + (t (values #'eql + nil)))) + (defun sequence-double-dispatch-error (seq0 seq1) (error "The type-set (~A, ~A) has not been implemented in this sequence-double-dispatch." (type-of seq0) @@ -86,12 +110,12 @@ (declare (type index length)))) (defun elt (sequence index) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (vector (aref sequence index)) (list (nth index sequence)))) (defun (setf elt) (value sequence index) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (vector (setf (aref sequence index) value)) (list (setf (nth index sequence) value)))) @@ -101,7 +125,7 @@ (numargs-case (2 (function sequence) (with-funcallable (funcall-function function) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (list (cond ((null sequence) @@ -131,7 +155,7 @@ (let ((start (check-the index start))) (with-funcallable (funcall-function function) (with-funcallable (key) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (list (let ((list (nthcdr start sequence))) (cond @@ -197,7 +221,7 @@ (declare (index index))))))))))))))) (defun subseq (sequence start &optional end) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (vector (unless end (setf end (length sequence))) @@ -236,10 +260,10 @@ (defun copy-seq (sequence) (subseq sequence 0)) -(defun position (item sequence &key from-end (test #'eql) test-not (start 0) end (key 'identity)) +(defun position (item sequence &key from-end test test-not (start 0) end (key 'identity)) (numargs-case (2 (item sequence) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (vector (with-subvector-accessor (sequence-ref sequence) (do ((end (length sequence)) @@ -254,10 +278,10 @@ (declare (index i)) (when (eql (pop sequence) item) (return i)))))) - (t (item sequence &key from-end (test #'eql) test-not (start 0) end (key 'identity)) + (t (item sequence &key from-end test test-not (start 0) end (key 'identity)) (with-funcallable (key) - (with-funcallable (test) - (sequence-dispatch sequence + (with-tester (test test-not) + (do-sequence-dispatch sequence (vector (unless end (setf end (length sequence))) @@ -301,7 +325,7 @@ (numargs-case (2 (predicate sequence) (with-funcallable (predicate) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (vector (with-subvector-accessor (sequence-ref sequence) (do ((end (length sequence)) @@ -320,7 +344,7 @@ (t (predicate sequence &key (start 0) end (key 'identity) from-end) (with-funcallable (predicate) (with-funcallable (key) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (vector (setf end (or end (length sequence))) (with-subvector-accessor (sequence-ref sequence start end) @@ -362,7 +386,7 @@ (apply #'position-if (complement predicate) sequence key-args)) (defun nreverse (sequence) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (list (do ((prev-cons nil current-cons) (next-cons (cdr sequence) (cdr next-cons)) @@ -381,7 +405,7 @@ sequence))) (defun reverse (sequence) - (sequence-dispatch sequence + (do-sequence-dispatch sequence (list (let ((result nil)) (dolist (x sequence) @@ -391,11 +415,11 @@ (nreverse (copy-seq sequence))))) (defun mismatch-eql-identity (sequence-1 sequence-2 start1 start2 end1 end2) - (sequence-dispatch sequence-1 + (do-sequence-dispatch sequence-1 (vector (unless end1 (setf end1 (length sequence-1))) (with-subvector-accessor (seq1-ref sequence-1 start1 end1) - (sequence-dispatch sequence-2 + (do-sequence-dispatch sequence-2 (vector (unless end2 (setf end2 (length sequence-2))) (with-subvector-accessor (seq2-ref sequence-2 start2 end2) @@ -457,7 +481,7 @@ (unless (eql (seq1-ref i1) (car p2)) (return i1)))))))))) (list - (sequence-dispatch sequence-2 + (do-sequence-dispatch sequence-2 (vector (let ((mismatch-2 (mismatch-eql-identity sequence-2 sequence-1 start2 start1 end2 end1))) (if (not mismatch-2) @@ -499,21 +523,21 @@ (t form))) (defun mismatch (sequence-1 sequence-2 &key (start1 0) (start2 0) end1 end2 - (test 'eql) (key 'identity) from-end) + test test-not (key 'identity) from-end) (numargs-case (2 (s1 s2) (mismatch-eql-identity s1 s2 0 0 nil nil)) (t (sequence-1 sequence-2 &key (start1 0) (start2 0) end1 end2 - (test 'eql) (key 'identity) from-end) + test test-not (key 'identity) from-end) (assert (not from-end) () - "Mismatch :from-end not implemented.") - (with-funcallable (test) + "Mismatch :from-end not implemented.") + (with-tester (test test-not) (with-funcallable (key) - (sequence-dispatch sequence-1 + (do-sequence-dispatch sequence-1 (vector (unless end1 (setf end1 (length sequence-1))) (with-subvector-accessor (sequence-1-ref sequence-1 start1 end1) - (sequence-dispatch sequence-2 + (do-sequence-dispatch sequence-2 (vector (let ((end2 (check-the index (or end2 (length sequence-2))))) (with-subvector-accessor (sequence-2-ref sequence-2 start2 end2) @@ -524,88 +548,88 @@ (let ((length1 (- end1 start1)) (length2 (- end2 start2))) (cond - ((< length1 length2) - (dotimes (i length1) - (declare (index i)) - (test-return (+ start1 i) (+ start2 i))) - end1) - ((> length1 length2) - (dotimes (i length2) - (declare (index i)) - (test-return (+ start1 i) (+ start2 i))) - (+ start1 length2)) - (t (dotimes (i length1) - (declare (index i)) - (test-return (+ start1 i) (+ start2 i))) - nil))))))) + ((< length1 length2) + (dotimes (i length1) + (declare (index i)) + (test-return (+ start1 i) (+ start2 i))) + end1) + ((> length1 length2) + (dotimes (i length2) + (declare (index i)) + (test-return (+ start1 i) (+ start2 i))) + (+ start1 length2)) + (t (dotimes (i length1) + (declare (index i)) + (test-return (+ start1 i) (+ start2 i))) + nil))))))) (list (let ((length1 (- end1 start1)) (start-cons2 (nthcdr start2 sequence-2))) (cond - ((and (zerop length1) (null start-cons2)) - (if (and end2 (> end2 start2)) start1 nil)) - ((not end2) - (do ((i1 start1 (1+ i1)) - (p2 start-cons2 (cdr p2))) - ((>= i1 end1) (if (null p2) nil i1)) - (declare (index i1)) - (unless (and p2 (test (key (sequence-1-ref i1)) (key (car p2)))) - (return-from mismatch i1)))) - ((< length1 (- end2 start2)) - (do ((i1 start1 (1+ i1)) - (p2 start-cons2 (cdr p2))) - ((>= i1 end1) end1) - (declare (index i1)) - (unless (test (key (sequence-1-ref i1)) (key (car p2))) - (return-from mismatch i1)))) - ((> length1 (- end2 start2)) - (do ((i1 start1 (1+ i1)) - (p2 start-cons2 (cdr p2))) - ((null p2) end1) - (declare (index i1)) - (unless (test (key (sequence-1-ref i1)) (key (car p2))) - (return-from mismatch i1)))) - (t (do ((i1 start1 (1+ i1)) - (p2 start-cons2 (cdr p2))) - ((null p2) nil) - (declare (index i1)) - (unless (test (key (sequence-1-ref i1)) (key (car p2))) - (return-from mismatch i1)))))))))) + ((and (zerop length1) (null start-cons2)) + (if (and end2 (> end2 start2)) start1 nil)) + ((not end2) + (do ((i1 start1 (1+ i1)) + (p2 start-cons2 (cdr p2))) + ((>= i1 end1) (if (null p2) nil i1)) + (declare (index i1)) + (unless (and p2 (test (key (sequence-1-ref i1)) (key (car p2)))) + (return-from mismatch i1)))) + ((< length1 (- end2 start2)) + (do ((i1 start1 (1+ i1)) + (p2 start-cons2 (cdr p2))) + ((>= i1 end1) end1) + (declare (index i1)) + (unless (test (key (sequence-1-ref i1)) (key (car p2))) + (return-from mismatch i1)))) + ((> length1 (- end2 start2)) + (do ((i1 start1 (1+ i1)) + (p2 start-cons2 (cdr p2))) + ((null p2) end1) + (declare (index i1)) + (unless (test (key (sequence-1-ref i1)) (key (car p2))) + (return-from mismatch i1)))) + (t (do ((i1 start1 (1+ i1)) + (p2 start-cons2 (cdr p2))) + ((null p2) nil) + (declare (index i1)) + (unless (test (key (sequence-1-ref i1)) (key (car p2))) + (return-from mismatch i1)))))))))) (list - (sequence-dispatch sequence-2 + (do-sequence-dispatch sequence-2 (vector (let ((mismatch-2 (mismatch sequence-2 sequence-1 :from-end from-end :test test :key key - :start1 start2 :end1 end2 :start2 start1 :end2 end1))) + :start1 start2 :end1 end2 :start2 start1 :end2 end1))) (if (not mismatch-2) nil - (+ start1 (- mismatch-2 start2))))) + (+ start1 (- mismatch-2 start2))))) (list (let ((start-cons1 (nthcdr start1 sequence-1)) (start-cons2 (nthcdr start2 sequence-2))) (assert (and start-cons1 start-cons2) (start1 start2) "Illegal bounding indexes.") (cond - ((and (not end1) (not end2)) - (do ((p1 start-cons1 (cdr p1)) - (p2 start-cons2 (cdr p2)) - (i1 start1 (1+ i1))) - ((null p1) (if (null p2) nil i1)) - (declare (index i1)) - (unless (and p2 (test (key (car p1)) (key (car p2)))) - (return i1)))) - (t (do ((p1 start-cons1 (cdr p1)) - (p2 start-cons2 (cdr p2)) - (i1 start1 (1+ i1)) - (i2 start2 (1+ i2))) - ((if end1 (>= i1 end1) (null p1)) - (if (if end2 (>= i2 end2) (null p2)) nil i1)) - (declare (index i1 i2)) - (unless p2 - (if end2 - (error "Illegal end2 bounding index.") - (return i1))) - (unless (and (or (not end2) (< i1 end2)) - (test (key (car p1)) (key (car p2)))) - (return i1))))))))))))))) + ((and (not end1) (not end2)) + (do ((p1 start-cons1 (cdr p1)) + (p2 start-cons2 (cdr p2)) + (i1 start1 (1+ i1))) + ((null p1) (if (null p2) nil i1)) + (declare (index i1)) + (unless (and p2 (test (key (car p1)) (key (car p2)))) + (return i1)))) + (t (do ((p1 start-cons1 (cdr p1)) + (p2 start-cons2 (cdr p2)) + (i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((if end1 (>= i1 end1) (null p1)) + (if (if end2 (>= i2 end2) (null p2)) nil i1)) + (declare (index i1 i2)) + (unless p2 + (if end2 + (error "Illegal end2 bounding index.") + (return i1))) + (unless (and (or (not end2) (< i1 end2)) + (test (key (car p1)) (key (car p2)))) + (return i1))))))))))))))) (defun map-into (result-sequence function first-sequence &rest more-sequences) (declare (dynamic-extent more-sequences)) @@ -648,7 +672,7 @@ (numargs-case (2 (function first-sequence) (with-funcallable (mapf function) - (sequence-dispatch first-sequence + (do-sequence-dispatch first-sequence (list (dolist (x first-sequence) (mapf x))) @@ -684,7 +708,7 @@ (numargs-case (2 (function first-sequence) (with-funcallable (mapf function) - (sequence-dispatch first-sequence + (do-sequence-dispatch first-sequence (list (mapcar function first-sequence)) (vector @@ -746,7 +770,7 @@ (numargs-case (3 (result function first-sequence) (with-funcallable (mapf function) - (sequence-dispatch first-sequence + (do-sequence-dispatch first-sequence (vector (do ((i 0 (1+ i))) ((>= i (length result)) result) @@ -820,7 +844,7 @@ (if (= start1 start2) sequence-1 ; no need to copy anything ;; must copy in reverse direction - (sequence-dispatch sequence-1 [430 lines skipped] From ffjeld at common-lisp.net Mon Apr 21 19:29:17 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:29:17 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421192917.AE12063089@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21807 Modified Files: arithmetic-macros.lisp Log Message: Add number-double-dispatch-error. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2008/03/17 17:24:42 1.21 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2008/04/21 19:29:17 1.22 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.21 2008/03/17 17:24:42 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.22 2008/04/21 19:29:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,6 +22,17 @@ ;;; +(defun number-double-dispatch-error (x y) + (when (not (typep x 'number)) + (error 'type-error + :datum x + :expected-type 'number)) + (when (not (typep y 'number)) + (error 'type-error + :datum y + :expected-type 'number)) + (error "Operation not implemented for numbers ~S and ~S." x y)) + (defmacro number-double-dispatch ((x y) &rest clauses) `(let ((x ,x) (y ,y)) (cond ,@(mapcar (lambda (clause) @@ -30,7 +41,7 @@ `((and (typep x ',x-type) (typep y ',y-type)) , at then-body))) clauses) - (t (error "Not numbers or not implemented: ~S or ~S." x y))))) + (t (number-double-dispatch-error x y))))) (define-compiler-macro evenp (x) From ffjeld at common-lisp.net Mon Apr 21 19:30:40 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:30:40 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421193040.7010021069@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22228 Modified Files: arrays.lisp Log Message: Change upgraded-array-element-type for type NIL. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/04/18 09:55:13 1.67 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/04/21 19:30:40 1.68 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.67 2008/04/18 09:55:13 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.68 2008/04/21 19:30:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,6 +21,10 @@ (in-package muerte) +(defconstant array-total-size-limit most-positive-fixnum) +(defconstant array-dimension-limit most-positive-fixnum) +(defconstant array-rank-limit 1024) + (defmacro/cross-compilation vector-double-dispatch ((s1 s2) &rest clauses) (flet ((make-double-dispatch-value (et1 et2) (+ (* #x100 (bt:enum-value 'movitz::movitz-vector-element-type et1)) @@ -85,42 +89,42 @@ "=> upgraded-type-specifier" ;; We're in dire need of subtypep.. (cond - ((symbolp type-specifier) - (case type-specifier - ((character base-char standard-char) - 'character) - ((code) - 'code) - (t (let ((deriver (gethash type-specifier *derived-typespecs*))) - (if (not deriver) - t - (upgraded-array-element-type (funcall deriver))))))) - ((null type-specifier) - t) - ((consp type-specifier) - (case (car type-specifier) - ((integer) - (let* ((q (cdr type-specifier)) - (min (if q (pop q) '*)) - (max (if q (pop q) '*))) - (let ((min (if (consp min) (1+ (car min)) min)) - (max (if (consp max) (1- (car max)) max))) - (cond - ((or (eq min '*) (eq max '*)) - t) - ((<= 0 min max 1) - 'bit) - ((<= 0 min max #xff) - '(unsigned-byte 8)) - ((<= 0 min max #xffff) - '(unsigned-byte 16)) - ((<= 0 min max #xffffffff) - '(unsigned-byte 32)))))) - (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*))) - (if (not deriver) - t - (upgraded-array-element-type (apply deriver (cdr type-specifier)) environment)))))) - (t t))) + ((symbolp type-specifier) + (case type-specifier + ((nil character base-char standard-char) + 'character) + ((code) + 'code) + (t (let ((deriver (gethash type-specifier *derived-typespecs*))) + (if (not deriver) + t + (upgraded-array-element-type (funcall deriver))))))) + ((null type-specifier) + t) + ((consp type-specifier) + (case (car type-specifier) + ((integer) + (let* ((q (cdr type-specifier)) + (min (if q (pop q) '*)) + (max (if q (pop q) '*))) + (let ((min (if (consp min) (1+ (car min)) min)) + (max (if (consp max) (1- (car max)) max))) + (cond + ((or (eq min '*) (eq max '*)) + t) + ((<= 0 min max 1) + 'bit) + ((<= 0 min max #xff) + '(unsigned-byte 8)) + ((<= 0 min max #xffff) + '(unsigned-byte 16)) + ((<= 0 min max #xffffffff) + '(unsigned-byte 32)))))) + (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*))) + (if (not deriver) + t + (upgraded-array-element-type (apply deriver (cdr type-specifier)) environment)))))) + (t t))) (defun array-dimension (array axis-number) @@ -407,14 +411,16 @@ (:compile-form (:result-mode :edx) index) (:testb 7 :cl) (:jnz '(:sub-program (not-a-vector) - (:compile-form (:result-mode :ignore) - (error "Not a vector: ~S." vector)))) + (:movl :ebx :eax) + (:load-constant vector :edx) + (:int 59))) (:movl (:ebx ,movitz:+other-type-offset+) :ecx) (:andl #xffff :ecx) (:testb ,movitz:+movitz-fixnum-zmask+ :dl) (:jnz '(:sub-program (not-an-index) - (:compile-form (:result-mode :ignore) - (error "Not a vector index: ~S." index)))) + (:movl :edx :eax) + (:load-constant index :edx) + (:int 59))) (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) :edx) (:jnc '(:sub-program (illegal-index) @@ -434,8 +440,8 @@ (:jne 'not-character-vector) (:cmpb ,(movitz:tag :character) :al) (:jne '(:sub-program (not-a-character) - (:compile-form (:result-mode :ignore) - (error "Not a character: ~S" value)))) + (:load-constant character :edx) + (:int 59))) (:movl :edx :ecx) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) @@ -1163,7 +1169,7 @@ (make-basic-vector%code size fill-pointer initial-element initial-contents)) (t (make-basic-vector%t size fill-pointer initial-element initial-contents))))) -(defun make-array (dimensions &key element-type initial-element initial-contents adjustable +(defun make-array (dimensions &key (element-type t) initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset) (let ((size (cond ((integerp dimensions) dimensions) From ffjeld at common-lisp.net Mon Apr 21 19:31:10 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:31:10 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421193110.2E4833A01C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22426 Modified Files: basic-functions.lisp Log Message: Tweak verify-macroexpand-call. Add defun xor. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/04/19 12:42:56 1.26 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/04/21 19:31:10 1.27 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.26 2008/04/19 12:42:56 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.27 2008/04/21 19:31:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -75,13 +75,17 @@ (return list)) (setf list (cdr list)))) -(defun verify-macroexpand-call (key name) +(defun verify-macroexpand-call (key name &optional extras-p) "Used by macro-expander functions to separate bona fide macro-expansions from regular function-calls." (when (eq key name) (error 'undefined-function-call :name name - :arguments :unknown))) + :arguments :unknown)) + (when extras-p + (error 'wrong-argument-count + :function (symbol-function name) + :argument-count nil))) (defun call-macroexpander (form env expander) "Call a macro-expander for a bona fide macro-expansion." @@ -466,3 +470,11 @@ (setf (memref object offset :index i :type :character) (char value j)))))))) value) + +(defun xor (a b) + "Iff b is true, complement a." + (if b (not a) a)) + +(define-compiler-macro xor (a b) + `(let ((a ,a)) + (if ,b (not a) a))) From ffjeld at common-lisp.net Mon Apr 21 19:31:32 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:31:32 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421193132.8AC37601A8@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22550 Modified Files: complexes.lisp Log Message: Add defun complex. --- /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp 2008/03/20 22:21:01 1.1 +++ /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp 2008/04/21 19:31:32 1.2 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: complexes.lisp,v 1.1 2008/03/20 22:21:01 ffjeld Exp $ +;;;; $Id: complexes.lisp,v 1.2 2008/04/21 19:31:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,6 +18,14 @@ (provide :muerte/complexes) (defstruct (complex (:constructor make-complex-number) - (:conc-name "")) + (:conc-name #:||)) realpart imagpart) + +(defun complex (realpart &optional (imagpart 0)) + (check-type realpart real) + (check-type imagpart real) + (if (= 0 imagpart) + realpart + (make-complex-number :realpart realpart + :imagpart imagpart))) From ffjeld at common-lisp.net Mon Apr 21 19:31:54 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:31:54 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421193154.5125C1D145@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22643 Modified Files: conditions.lisp Log Message: Add various standard conditions. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2008/04/17 19:32:27 1.27 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2008/04/21 19:31:54 1.28 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.27 2008/04/17 19:32:27 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.28 2008/04/21 19:31:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,10 +38,6 @@ condition)))) ',name)) -#+ignore -(defmethod print-object ((c condition) s) - foo) - (define-condition condition (standard-object) ((format-control :initarg :format-control @@ -66,10 +62,12 @@ :reader simple-condition-format-arguments))) (define-condition serious-condition () ()) (define-condition error (serious-condition) ()) +(define-condition storage-condition (serious-condition) ()) (define-condition warning () ()) (define-condition style-warning () ()) (define-condition simple-error (simple-condition error) ()) (define-condition simple-warning (simple-condition warning) ()) +(define-condition parse-error (error) ()) (define-condition cell-error (error) ((name @@ -100,6 +98,24 @@ (format s "Unbound variable ~S." (cell-error-name c))))) +(define-condition unbound-slot (cell-error) + ((instance + :initarg :instance + :reader unbound-slot-instance)) + (:report (lambda (c s) + (format s "The slot ~S is unbound in the object ~S." + (cell-error-name c) + (unbound-slot-instance c))))) + + +(define-condition print-not-readable (error) + ((object + :initarg :object + :reader print-not-readable-object)) + (:report (lambda (c s) + (format s "Cannot print ~S readably." + (print-not-readable-object c))))) + (define-condition program-error (error) ()) (defun simple-program-error (format-control &rest format-arguments) @@ -120,6 +136,8 @@ (type-error-datum c) (type-error-expected-type c))))) +(define-condition simple-type-error (simple-condition type-error) ()) + (define-condition etypecase-error (type-error) () (:report (lambda (c s) @@ -183,6 +201,8 @@ :initarg :stream :reader stream-error-stream))) +(define-condition reader-error (parse-error stream-error) ()) + (define-condition end-of-file (stream-error) () (:report (lambda (c s) @@ -328,7 +348,7 @@ (cond ((not *debugger-function*) (let ((*never-use-print-object* t)) - (backtrace :spartan t)) + (backtrace :spartan t :conflate nil)) (format t "~&No debugger in *debugger-function*...") (dotimes (i 100000) (write-string "")) @@ -371,3 +391,8 @@ nil) (define-condition newline () ()) + +(define-condition floating-point-inexact (arithmetic-error) ()) +(define-condition floating-point-invalid-operation (arithmetic-error) ()) +(define-condition floating-point-overflow (arithmetic-error) ()) +(define-condition floating-point-underflow (arithmetic-error) ()) From ffjeld at common-lisp.net Mon Apr 21 19:38:51 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:38:51 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421193851.6D9083C005@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv23749 Modified Files: defmacro-bootstrap.lisp Log Message: Factor out parse-macro-lambda-list from the macroexpander. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/12 17:11:23 1.3 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/21 19:38:48 1.4 @@ -7,7 +7,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defmacro-bootstrap.lisp,v 1.3 2008/04/12 17:11:23 ffjeld Exp $ +;;;; $Id: defmacro-bootstrap.lisp,v 1.4 2008/04/21 19:38:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,51 +33,44 @@ (defmacro defmacro/run-time (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)) - (whole-var (when (eq '&whole (car lambda-list)) - (list (pop lambda-list) - (pop lambda-list)))) - (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)))) - (cond - ((and whole-var - (null lambda-list)) - `(make-named-function ,name - (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) - ((ignore ,ignore-var , at ignore-env)) - ,docstring - (block ,block-name - (verify-macroexpand-call edx ',name) - (let ((,(second whole-var) ,form-var)) - (declare , at declarations) - , at real-body)) - :type :macro-function)) - (t `(make-named-function ,name - (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) - ((ignore ,ignore-var , at ignore-env)) - ,docstring - (block ,block-name - (verify-macroexpand-call edx ',name) - (destructuring-bind ,(append whole-var destructuring-lambda-list) - ,form-var - (declare (ignore ,operator-var) , at declarations) - , at real-body)) - :type :macro-function))))))) + (parse-docstring-declarations-and-body body 'cl:declare) + (multiple-value-bind (destructuring-lambda-list whole-var env-var ignore-env ignore-operator) + (parse-macro-lambda-list lambda-list) + (let* ((block-name (compute-function-block-name name)) + (extras (gensym)) + (form-var (or whole-var + (gensym "form-")))) + (cond + ((and (eq whole-var form-var) + (null (cdr destructuring-lambda-list))) + `(make-named-function ,name + (&edx edx &optional ,form-var ,env-var &rest ,extras) + ((ignore , at ignore-env)) + ,docstring + (block ,block-name + (numargs-case + (2 (&edx edx &optional ,form-var ,env-var) + (verify-macroexpand-call edx ',name) + (let () + (declare , at declarations) + , at real-body)) + (t (&edx edx &optional ,form-var ,env-var &rest ,extras) + (declare (ignore ,form-var ,extras)) + (verify-macroexpand-call edx ',name t)))) + :type :macro-function)) + (t `(make-named-function ,name + (&edx edx &optional ,form-var ,env-var &rest ,extras) + ((ignore , at ignore-env ,extras)) + ,docstring + (block ,block-name + (numargs-case + (2 (&edx edx ,form-var ,env-var) + (verify-macroexpand-call edx ',name) + (destructuring-bind ,destructuring-lambda-list + ,form-var + (declare (ignore , at ignore-operator) , at declarations) + , at real-body)) + (t (&edx edx &optional ,form-var ,env-var &rest ,extras) + (declare (ignore ,form-var ,extras)) + (verify-macroexpand-call edx ',name t)))) + :type :macro-function))))))) From ffjeld at common-lisp.net Mon Apr 21 19:39:09 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:39:09 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421193909.176974D052@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv23870 Modified Files: defstruct.lisp Log Message: Better errors from struct accessors. --- /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2008/04/19 12:43:50 1.20 +++ /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2008/04/21 19:39:08 1.21 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.20 2008/04/19 12:43:50 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.21 2008/04/21 19:39:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -95,10 +95,12 @@ (:compile-form (:result-mode :eax) object) (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 66))) + (:jne '(:sub-program (type-error) + (:load-constant struct-name :edx) + (:int 59))) (:cmpb #.(movitz:tag :defstruct) (:eax #.movitz:+other-type-offset+)) - (:jne '(:sub-program (type-error) (:int 66))) - (:load-constant struct-name :ebx) + (:jne 'type-error) +;; (:load-constant struct-name :ebx) ;;; (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) ;;; (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, read slot @@ -115,12 +117,14 @@ ;; type test (:leal (:ebx #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program (type-error) (:int 66))) + (:jnz '(:sub-program (type-error) + (:load-constant struct-name :edx) + (:movl :ebx :eax) + (:int 59))) (:cmpb #.(movitz:tag :defstruct) (:ebx #.movitz:+other-type-offset+)) - (:jne '(:sub-program (type-error) (:int 66))) - (:load-constant struct-name :ecx) -;;; (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) -;;; (:jne '(:sub-program (type-error) (:int 66))) + (:jne 'type-error) +;; (:cmpl :edx (:ebx (:offset movitz-struct name))) +;; (:jne 'type-error) ;; type test passed, write slot (:load-constant slot-number :ecx) ;;; (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) @@ -173,7 +177,8 @@ (:type (push parameter (getf collector :type))) (:initial-offset (push parameter (getf collector :initial-offset))) (:print-object (push parameter (getf collector :print-object))) - (:print-function (push parameter (getf collector :print-function)))))) + (:print-function (push parameter (getf collector :print-function))) + (:include (push (cdr option) (getf collector :include)))))) ((cons symbol (cons * cons)) (ecase (car option) (:include (push (cdr option) (getf collector :include))) From ffjeld at common-lisp.net Mon Apr 21 19:39:24 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:39:24 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421193924.86F961C0CE@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv23949 Modified Files: environment.lisp Log Message: Struct pathname. --- /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2008/04/17 19:33:27 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2008/04/21 19:39:24 1.17 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.16 2008/04/17 19:33:27 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.17 2008/04/21 19:39:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -169,4 +169,5 @@ (error "There is no default implementation of sleep.")) (defstruct random-state state) -(defstruct pathname name) + + From ffjeld at common-lisp.net Mon Apr 21 19:40:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:40:06 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194006.665A93E053@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24272 Modified Files: eval.lisp Log Message: Add parse-macro-lambda-list, and have (eval interpreted) macrolet use it. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/17 19:33:48 1.31 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/21 19:40:05 1.32 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.31 2008/04/17 19:33:48 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.32 2008/04/21 19:40:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -196,9 +196,37 @@ (apply f a0 a1 evaluated-args))) f env a0 a1 form)))))) -(defun parse-declarations-and-body (forms) +(defun parse-macro-lambda-list (lambda-list) + (let* ((whole-var (when (eq '&whole (car lambda-list)) + (pop lambda-list) + (pop lambda-list))) + (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))))) + (ignore-env-var + (when (not env-var) + (gensym)))) + (values destructuring-lambda-list + whole-var + (or env-var + ignore-env-var) + (when ignore-env-var + (list ignore-env-var)) + (list operator-var)))) + +(defun parse-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." + (assert (eq declare 'declare)) (do (declarations (p forms (cdr p))) ((not (and (consp (car p)) (eq 'declare (caar p)))) @@ -206,9 +234,10 @@ (dolist (d (cdar p)) (push d declarations)))) -(defun parse-docstring-declarations-and-body (forms) +(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) @@ -216,6 +245,14 @@ (parse-declarations-and-body (cdr forms)) (car forms)))) +(defun compute-function-block-name (function-name) + (cond + ((symbolp function-name) function-name) + ((and (consp function-name) + (symbolp (cadr function-name))) + (cadr function-name)) + (t (error "Unknown kind of function-name: ~S" function-name)))) + (defun declared-special-p (var declarations) (dolist (d declarations nil) (when (and (consp d) @@ -552,23 +589,32 @@ (let ((operator (car form))) (when (symbolp operator) (let ((macrolet-binding (op-env-binding env operator +eval-binding-type-macrolet+))) - (if macrolet-binding - (destructuring-bind (lambda-list &body body) - (cddr macrolet-binding) - (let ((expander (lambda (form env) - (eval-form `(destructuring-bind (ignore-operator , at lambda-list) - ',form - (declare (ignore ignore-operator)) - , at body) - env)))) - (values (funcall *macroexpand-hook* expander form env) - t))) + (if (not macrolet-binding) (let ((macro-function (macro-function operator))) (if macro-function (values (funcall *macroexpand-hook* macro-function form env) t) (values form - nil))))))))) + nil))) + (let ((lambda-list (caddr macrolet-binding))) + (multiple-value-bind (body declarations docstring) + (parse-docstring-declarations-and-body (cdddr macrolet-binding)) + (declare (ignore docstring)) + (multiple-value-bind (destructuring-lambda-list whole-var env-var ignore-env ignore-operator) + (parse-macro-lambda-list lambda-list) + (let* ((form-var (or whole-var (gensym))) + (expander (lambda (form env) + (eval-form `(let ((,form-var ',form) + (,env-var ',env)) + (declare (ignore , at ignore-env)) + (destructuring-bind ,destructuring-lambda-list + ,form-var + (declare (ignore , at ignore-operator) + , at declarations) + , at body)) + env)))) + (values (funcall *macroexpand-hook* expander form env) + t))))))))))) (defun macroexpand (form &optional env) (do ((expanded-at-all-p nil)) (nil) @@ -589,8 +635,10 @@ (typecase form (boolean t) (keyword t) - (symbol nil) - (cons (eq 'quote (car form))) + (symbol + (symbol-constant-variable-p form)) + (cons + (eq 'quote (car form))) (t t))) (defun macro-function (symbol &optional environment) From ffjeld at common-lisp.net Mon Apr 21 19:40:32 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:40:32 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194032.73634601A8@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25150 Modified Files: integers.lisp Log Message: Ensure (lcm) => 1. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/17 19:34:39 1.126 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/21 19:40:32 1.127 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.126 2008/04/17 19:34:39 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.127 2008/04/21 19:40:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2170,7 +2170,8 @@ (abs (* (truncate (max n m) (gcd n m)) (min n m)))) (t (&rest numbers) (declare (dynamic-extent numbers)) - (reduce #'lcm numbers)))) + (reduce #'lcm numbers + :initial-value 1)))) (defun floor (n &optional (divisor 1)) "This is floor written in terms of truncate." From ffjeld at common-lisp.net Mon Apr 21 19:41:03 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:41:03 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194103.DD3F4702F9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26170 Modified Files: interrupt.lisp Log Message: Fix store-value restart for unbound variable reads. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2008/04/09 18:02:04 1.58 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2008/04/21 19:41:03 1.59 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.58 2008/04/09 18:02:04 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.59 2008/04/21 19:41:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -294,10 +294,11 @@ ((eq (load-global-constant new-unbound-value) (dereference $eax)) (let ((name (dereference $ebx))) - (with-simple-restart (new-value "Set the value of ~S." name) + (with-simple-restart (store-value "Set the value of ~S." name) (error 'unbound-variable :name name)) (format *query-io* "~&Enter a value for ~S: " name) - (setf (dereference $eax) (read *query-io*)))) + (setf (symbol-value name) + (setf (dereference $eax) (read *query-io*))))) ((typep (dereference $eax) 'fixnum) (let ((eax (dereference $eax))) (setf (dereference $eax) @@ -308,17 +309,22 @@ 1 (- eax most-negative-fixnum)))) (warn "Overflow: ~S -> ~S" eax (dereference $eax)))) (t (error "Primitive overflow assertion failed.")))) - (6 (error "Illegal instruction at ~@Z." $eip)) + (6 (error "Illegal CPU instruction at ~@Z." $eip)) (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" $eip (dit-frame-ref nil dit-frame :error-code :unsigned-byte32) $eax $ebx $ecx)) - ((60) + ((59) + ;; EAX failed type in EDX. May not be restarted. + (error 'type-error + :datum (dereference $eax) + :expected-type (dereference $edx))) + ((60) ;; EAX failed type in EDX. May be restarted by returning with a new value in EAX. (with-simple-restart (continue "Retry with a different value.") (error 'type-error - :datum (dereference $eax) - :expected-type (dereference $edx))) + :datum (dereference $eax) + :expected-type (dereference $edx))) (format *query-io* "Enter a new value: ") (setf (dereference $eax) (read *query-io*))) (61 (error 'type-error @@ -380,7 +386,7 @@ (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ES.~%" (- old-bottom new-bottom) new-bottom) - (backtrace :length 5 :spartan t) + (backtrace :length 10 :spartan t :conflate nil) (error "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X." vector $eip (dit-frame-esp nil dit-frame) From ffjeld at common-lisp.net Mon Apr 21 19:41:15 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:41:15 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194115.B18AE32043@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26329 Modified Files: los-closette.lisp Log Message: Class readtable. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2008/04/12 16:47:21 1.39 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2008/04/21 19:41:15 1.40 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.39 2008/04/12 16:47:21 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.40 2008/04/21 19:41:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -986,6 +986,7 @@ (defclass unbound-value (t) () (:metaclass built-in-class)) (defclass stream () ()) +(defclass readtable () ()) ;;; From ffjeld at common-lisp.net Mon Apr 21 19:41:52 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:41:52 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194152.E86A1450C8@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26432 Modified Files: packages.lisp Log Message: Add make-package and delete-package. --- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/19 12:45:03 1.14 +++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/21 19:41:52 1.15 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.14 2008/04/19 12:45:03 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.15 2008/04/21 19:41:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,14 +25,50 @@ (:constructor make-package-object) (:conc-name package-object-)) name - external-symbols - internal-symbols + (external-symbols (make-hash-table :test #'equal)) + (internal-symbols (make-hash-table :test #'equal)) shadowing-symbols-list use-list nicknames) (defvar *packages*) ; Set by dump-image. +(deftype package-designator () + '(or package string-designator)) + +(defun make-package (name &key nicknames use) + (let ((name* (string name)) + (nicknames* (mapcar #'string nicknames)) + (use* (mapcar #'find-package use))) + (when (some #'null use*) + (warn "Cannot use nonexisting package ~S." + (find-if-not #'find-package use)) + (setf use* (remove nil use*))) + (let ((existing-packages (remove-if-not #'find-package (cons name* nicknames*)))) + (when existing-packages + (cerror "Create the package anyway." + "There already exist package~P by the name~:P ~{~A~^ ~}." + (length existing-packages) + existing-packages))) + (let ((package (make-package-object :name name* + :use-list use* + :nicknames nicknames*))) + (dolist (nickname nicknames*) + (setf (gethash nickname *packages*) package)) + (setf (gethash name* *packages*) package)))) + +(defun delete-package (package) + (let ((package (find-package package))) + (when (and (package-name package) + (eq package (find-package (package-name package)))) + (dolist (nickname (package-nicknames package)) + (when (eq package (gethash nickname *packages*)) + (setf (gethash nickname *packages*) nil))) + (setf (gethash (package-name package) *packages*) + nil) + (setf (package-object-name package) nil) + t))) + (defun package-name (object) (package-object-name (find-package object))) @@ -45,9 +81,13 @@ (defun find-package (name) (typecase name (package name) - (null (find-package 'common-lisp)) ; This can be practical.. - ((or symbol string) (find-package-string (string name))) - (t (error "Not a package name: ~S" name)))) + (null + (find-package 'common-lisp)) ; This can be practical.. + (string-designator + (find-package-string (string name))) + (t (error 'type-error + :datum name + :expected-type 'package-designator)))) (defun find-package-string (name &optional (start 0) (end (length name)) (key 'identity)) (values (gethash-string name start end *packages* nil key))) From ffjeld at common-lisp.net Mon Apr 21 19:42:08 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:42:08 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194208.5E47A31036@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26499 Modified Files: pathnames.lisp Log Message: Class pathname and logical-pathname. --- /project/movitz/cvsroot/movitz/losp/muerte/pathnames.lisp 2008/03/20 22:21:05 1.1 +++ /project/movitz/cvsroot/movitz/losp/muerte/pathnames.lisp 2008/04/21 19:42:06 1.2 @@ -6,16 +6,19 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: pathnames.lisp,v 1.1 2008/03/20 22:21:05 ffjeld Exp $ +;;;; $Id: pathnames.lisp,v 1.2 2008/04/21 19:42:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (require :muerte/basic-macros) -(require :muerte/defstruct) +(require :muerte/los-closette) (in-package muerte) (provide :muerte/pathnames) -(defstruct (pathname (:constructor make-pathname-object)) - name) +(defclass pathname () + ((name))) + +(defclass logical-pathname (pathname) + ()) From ffjeld at common-lisp.net Mon Apr 21 19:42:26 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:42:26 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194226.614C221069@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26569 Modified Files: print.lisp Log Message: Printing of various quote syntaxes. --- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2008/04/19 15:21:57 1.26 +++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2008/04/21 19:42:26 1.27 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.26 2008/04/19 15:21:57 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.27 2008/04/21 19:42:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -242,6 +242,19 @@ (not (cddr object))) (write-char #\' stream) (write (cadr object))) + ((and (eq 'backquote (car object)) + (not (cddr object))) + (write-char #\` stream) + (write (cadr object))) + ((and (eq 'backquote-comma (car object)) + (not (cddr object))) + (write-char #\, stream) + (write (cadr object))) + ((and (eq 'function (car object)) + (not (cddr object))) + (write-char #\# stream) + (write-char #\' stream) + (write (cadr object))) (t (labels ((write-cons (c stream length) (cond ((and length (= 0 length)) From ffjeld at common-lisp.net Mon Apr 21 19:42:43 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:42:43 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194243.C37003E053@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26648 Modified Files: ratios.lisp Log Message: Minor tweaks. --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2008/04/19 12:45:14 1.12 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2008/04/21 19:42:43 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.12 2008/04/19 12:45:14 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.13 2008/04/21 19:42:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,7 +59,8 @@ ((minusp denominator) (make-rational (- numerator) (- denominator))) ((= 0 denominator) - (error 'division-by-zero)) + (error 'division-by-zero + :operands (list numerator denominator))) (t (let ((gcd (gcd numerator denominator))) (if (= denominator gcd) (values (truncate numerator denominator)) @@ -78,22 +79,8 @@ ;;; "Floats" -(defconstant most-negative-short-float most-negative-fixnum) -(defconstant most-negative-single-float most-negative-fixnum) -(defconstant most-negative-long-float most-negative-fixnum) -(defconstant most-negative-double-float most-negative-fixnum) - -(defconstant least-positive-short-float 1/100000) -(defconstant least-positive-single-float 1/100000) -(defconstant least-positive-double-float 1/100000) -(defconstant least-positive-long-float 1/100000) - -;;; - (defconstant pi #xea7632a/4aa1a8b) -(defvar long-float-epsilon 1/10000) - (defun float (x &optional proto) (declare (ignore proto)) (check-type x float) @@ -137,7 +124,7 @@ (term 1 (/ (expt rad n2) denominator)) (sum 1 (+ sum (* sign term)))) - ((<= term long-float-epsilon) + ((<= term 1/100) sum))) (defun sin (x) From ffjeld at common-lisp.net Mon Apr 21 19:42:57 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:42:57 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194257.AAD2467096@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26713 Modified Files: streams.lisp Log Message: Various stream classes. --- /project/movitz/cvsroot/movitz/losp/muerte/streams.lisp 2006/04/10 11:57:24 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/streams.lisp 2008/04/21 19:42:57 1.6 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Jun 30 14:33:15 2003 ;;;; -;;;; $Id: streams.lisp,v 1.5 2006/04/10 11:57:24 ffjeld Exp $ +;;;; $Id: streams.lisp,v 1.6 2008/04/21 19:42:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -129,3 +129,46 @@ (simple-stream (%finish-output stream))))) +(defclass string-stream (stream) ()) + +(defun make-string-input-stream (string &optional (start 0) (end nil)) + ) + +(defun make-string-output-stream ()) + + +(defclass broadcast-stream (stream) + ((streams + :reader concatenated-stream-streams + :initarg :streams))) + +(defclass concatenated-stream (stream) + ((streams + :reader concatenated-stream-streams + :initarg :streams))) + +(defclass echo-stream (stream) + ((input-stream + :reader echo-stream-input-stream + :initarg :input-stream) + (output-stream + :reader echo-stream-output-stream + :initarg :output-stream))) + +(defclass file-stream (stream) + ()) + +(defclass synonym-stream (stream) + ((symbol + :initarg :symbol + :reader synonym-stream-symbol))) + +(defclass two-way-stream (stream) + ((input + :initarg :input + :reader two-way-stream-input-stream) + (output + :initarg :output + :reader two-way-stream-output-stream))) + + From ffjeld at common-lisp.net Mon Apr 21 19:43:30 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:43:30 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194330.BC82B1A0E5@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26807 Modified Files: strings.lisp Log Message: Add deftype string-designator. --- /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/17 19:36:09 1.4 +++ /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/21 19:43:30 1.5 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 17:05:25 2001 ;;;; -;;;; $Id: strings.lisp,v 1.4 2008/04/17 19:36:09 ffjeld Exp $ +;;;; $Id: strings.lisp,v 1.5 2008/04/21 19:43:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,6 +21,9 @@ (in-package muerte) +(deftype string-designator () + '(or string symbol character)) + (defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2) (setf string1 (string string1) end1 (or end1 (length string1)) @@ -56,7 +59,9 @@ (string name) (symbol (symbol-name name)) (character (make-string 1 :initial-element name)) - (t (error "Not a string designator: ~S" name)))) + (t (error 'type-error + :datum name + :expected-type 'string-designator)))) (defun make-string (size &key initial-element (element-type 'character)) (if (not initial-element) From ffjeld at common-lisp.net Mon Apr 21 19:43:47 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:43:47 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194347.A52E73307E@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26874 Modified Files: symbols.lisp Log Message: Check-type in gentemp. --- /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2008/04/09 18:02:31 1.30 +++ /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2008/04/21 19:43:47 1.31 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.30 2008/04/09 18:02:31 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.31 2008/04/21 19:43:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -247,6 +247,7 @@ (defvar *gentemp-counter* 0) (defun gentemp (&optional (prefix "T") (package *package*)) + (check-type prefix string) (intern (do ((name #0=(format nil "~A~D" prefix *gentemp-counter*) #0#)) ((not (find-symbol name package)) name) (incf *gentemp-counter*)) From ffjeld at common-lisp.net Mon Apr 21 19:43:57 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:43:57 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194357.B7F9C7E09C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26953 Modified Files: typep.lisp Log Message: Misc. types. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/09 18:02:47 1.58 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/21 19:43:57 1.59 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.58 2008/04/09 18:02:47 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.59 2008/04/21 19:43:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -601,7 +601,9 @@ (or (eq xdim '*) (eql xdim adim))) dimension-spec (array-dimensions x))))))) - + +(defun arrayp (x) + (typep x 'array)) (define-simple-typep (atom atom) (x) (typep x 'atom)) @@ -706,6 +708,18 @@ (deftype float () 'real) +(deftype short-float () + 'real) + +(deftype long-float () + 'real) + +(deftype single-float () + 'real) + +(deftype double-float () + 'real) + (defun type-of (x) (class-name (class-of x))) From ffjeld at common-lisp.net Mon Apr 21 19:44:14 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:44:14 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080421194414.0BD8C66008@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27017 Modified Files: variables.lisp Log Message: Add misc. standard variables. --- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/03/21 22:30:40 1.12 +++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/04/21 19:44:13 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.12 2008/03/21 22:30:40 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.13 2008/04/21 19:44:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,6 +35,7 @@ (defvar +++ nil) (defvar *read-base* 10) +(defvar *read-eval* t) (defvar *package* nil) (defvar *macroexpand-hook* 'funcall) @@ -63,11 +64,38 @@ (defvar single-float-negative-epsilon -1/1000) (defvar double-float-negative-epsilon -1/1000) (defvar long-float-negative-epsilon -1/1000) +(defvar long-float-epsilon 1/10000) +(defconstant most-negative-short-float most-negative-fixnum) +(defconstant most-negative-single-float most-negative-fixnum) +(defconstant most-negative-long-float most-negative-fixnum) +(defconstant most-negative-double-float most-negative-fixnum) + +(defconstant least-positive-short-float 1/100000) +(defconstant least-positive-single-float 1/100000) +(defconstant least-positive-double-float 1/100000) +(defconstant least-positive-long-float 1/100000) + +(defconstant least-negative-short-float -1/100000) +(defconstant least-negative-single-float -1/100000) +(defconstant least-negative-double-float -1/100000) +(defconstant least-negative-long-float -1/100000) (defconstant call-arguments-limit 512) (defconstant lambda-parameters-limit 512) ; ? (defvar *print-pprint-dispatch* nil) -(declaim (special *build-number*)) +(defvar *build-number*) ; set at bootup + +(defvar *features* '(:movitz)) +(defvar *modules* nil) + +(defvar *compile-file-pathname* nil) +(defvar *compile-file-truename* nil) +(defvar *compile-print* nil) +(defvar *compile-verbose* nil) +(defvar *load-print* nil) +(defvar *load-verbose* nil) +(defvar *load-truename* nil) +(defvar *default-pathname-defaults* #p"") From ffjeld at common-lisp.net Mon Apr 21 19:45:37 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:45:37 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080421194537.16BB131036@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27251 Modified Files: compiler.lisp Log Message: Don't break on constant EQL. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/17 19:09:28 1.203 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/21 19:45:36 1.204 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.203 2008/04/17 19:09:28 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.204 2008/04/21 19:45:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -7248,7 +7248,7 @@ (:boolean-branch-on-false (when (not eql) `((:jmp ',(operands return-mode))))) - (t (break "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))))) + (t (warn "Constant EQL: ~S ~S" (car x-singleton) (car y-singleton)))))) ((and x-singleton (eq :untagged-fixnum-ecx y-loc)) (let ((value (etypecase (car x-singleton) From ffjeld at common-lisp.net Mon Apr 21 19:45:51 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:45:51 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080421194551.96E823C00F@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27310 Modified Files: image.lisp Log Message: Tweak stack cushion. --- /project/movitz/cvsroot/movitz/image.lisp 2008/04/17 19:27:43 1.122 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/21 19:45:51 1.123 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.122 2008/04/17 19:27:43 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.123 2008/04/21 19:45:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1022,7 +1022,7 @@ (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector) (write-binary 'word stream stack-vector-word) (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom) - (write-binary 'lu32 stream (+ 8 (* 6 4096) ; cushion + (write-binary 'lu32 stream (+ 8 (* 8 4096) ; cushion (- stack-vector-word (tag :other)))) (set-file-position stream (global-slot-position 'stack-top) 'stack-top) (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other)) From ffjeld at common-lisp.net Mon Apr 21 19:46:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:46:06 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080421194606.0CF354C00A@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27370 Modified Files: packages.lisp Log Message: parse-macro-lambda-list. --- /project/movitz/cvsroot/movitz/packages.lisp 2008/04/02 20:49:33 1.59 +++ /project/movitz/cvsroot/movitz/packages.lisp 2008/04/21 19:46:02 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.59 2008/04/02 20:49:33 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.60 2008/04/21 19:46:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1234,6 +1234,7 @@ #:decode-keyword-formal #:parse-declarations-and-body #:parse-docstring-declarations-and-body + #:parse-macro-lambda-list #:compute-function-block-name #:movitz-accessor @@ -1391,6 +1392,7 @@ muerte::decode-keyword-formal muerte::parse-declarations-and-body muerte::parse-docstring-declarations-and-body + muerte::parse-macro-lambda-list muerte::unfold-circular-list muerte::compute-function-block-name )) From ffjeld at common-lisp.net Mon Apr 21 19:46:12 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 15:46:12 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080421194612.3ECFF1C0CE@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27432 Modified Files: parse.lisp Log Message: parse-macro-lambda-list. --- /project/movitz/cvsroot/movitz/parse.lisp 2007/02/01 19:37:41 1.7 +++ /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 19:46:12 1.8 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.7 2007/02/01 19:37:41 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.8 2008/04/21 19:46:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,6 +38,33 @@ (parse-declarations-and-body forms declare-symbol) (values body declarations docstring)))) +(defun parse-macro-lambda-list (lambda-list) + (let* ((whole-var (when (eq '&whole (car lambda-list)) + (pop lambda-list) + (pop lambda-list))) + (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))))) + (ignore-env-var + (when (not env-var) + (gensym)))) + (values destructuring-lambda-list + whole-var + (or env-var + ignore-env-var) + (when ignore-env-var + (list ignore-env-var)) + (list operator-var)))) + (defun unfold-circular-list (list) "If LIST is circular (through cdr), return (a copy of) the non-circular portion of LIST, and the index (in LIST) of the cons-cell pointed to by (cdr (last LIST))." (flet ((find-cdr (l c end) From ffjeld at common-lisp.net Mon Apr 21 21:09:47 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 21 Apr 2008 17:09:47 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080421210947.AAE90D006@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv18477 Modified Files: parse.lisp Log Message: Have decode-normal-lambda-list return unlimited maxargs (nil) when &key is present (because there can always be :allow-other-keys t). --- /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 19:46:12 1.8 +++ /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 21:09:47 1.9 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.8 2008/04/21 19:46:12 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.9 2008/04/21 21:09:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,18 +25,20 @@ second the list of declaration-specifiers." (loop for declaration-form = (when (declare-form-p (car forms) declare-symbol) (pop forms)) - while declaration-form - append (cdr declaration-form) into declarations - finally (return (values forms declarations)))) + if (declare-form-p (car forms) declare-symbol) + append (cdr (pop forms)) into declarations + else return (values forms declarations))) (defun parse-docstring-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) "From the list of FORMS, return first the non-declarations forms, second the declarations, ~ and third the documentation string." - (let ((docstring (when (and (cdr forms) (stringp (car forms))) - (pop forms)))) - (multiple-value-bind (body declarations) - (parse-declarations-and-body forms declare-symbol) - (values body declarations docstring)))) + (loop with docstring = nil + if (declare-form-p (car forms) declare-symbol) + append (cdr (pop forms)) into declarations + else if (and (stringp (car forms)) + (cdr forms)) + do (setf docstring (pop forms)) + else return (values forms declarations docstring))) (defun parse-macro-lambda-list (lambda-list) (let* ((whole-var (when (eq '&whole (car lambda-list)) @@ -153,6 +155,7 @@ (defun muerte::host-program (program) (translate-program program :muerte.cl :common-lisp))) + (defun decode-normal-lambda-list (lambda-list &optional host-symbols-p) "3.4.1 Ordinary Lambda Lists. Returns the requireds, &optionals, &rests, &keys, and &aux formal variables, @@ -210,7 +213,9 @@ (not allow-other-keys-p) (+ (length requireds) (length optionals)))) - (minargs (length requireds))) + (minargs (length requireds)) + (keys-p (not (eq :missing + (getf results (key) :missing))))) (return (values requireds optionals (first rests) @@ -218,7 +223,8 @@ auxes allow-other-keys-p minargs - maxargs + (unless keys-p + maxargs) edx-var (cond ((or (eql maxargs minargs) @@ -228,8 +234,7 @@ ((evenp (+ (length requireds) (length optionals))) :even) (t :odd)) - (not (eq :missing - (getf results (key) :missing))))))))))) + keys-p)))))))) (defun decode-optional-formal (formal) "3.4.1.2 Specifiers for optional parameters. From ffjeld at common-lisp.net Wed Apr 23 18:47:46 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 23 Apr 2008 14:47:46 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080423184746.F3F121B017@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2540 Modified Files: packages.lisp Log Message: do-symbols &co have implicit tagbodys, not implicit progns. --- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/21 19:41:52 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/23 18:47:46 1.16 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.15 2008/04/21 19:41:52 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.16 2008/04/23 18:47:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -173,31 +173,33 @@ (return ,result-form)) (let ((,package-hash-var (package-object-external-symbols ,package-var))) (tagbody ,loop-tag - (with-hash-table-iterator (,next-symbol ,package-hash-var) - (tagbody ,loop-tag - (multiple-value-bind (,more-symbols-var ,dummy ,symbol-var) - (,next-symbol) - (declare (ignore ,dummy)) - (unless ,more-symbols-var (go ,end-tag)) - (let ((,var ,symbol-var)) - , at declarations-and-body)) - (go ,loop-tag) - ,end-tag)) - (let ((internals (package-object-internal-symbols ,package-var))) - (unless (eq ,package-hash-var internals) - (setf ,package-hash-var internals) - (go ,loop-tag)))))))))) + (with-hash-table-iterator (,next-symbol ,package-hash-var) + (tagbody ,loop-tag + (multiple-value-bind (,more-symbols-var ,dummy ,symbol-var) + (,next-symbol) + (declare (ignore ,dummy)) + (unless ,more-symbols-var (go ,end-tag)) + (prog ((,var ,symbol-var)) + , at declarations-and-body)) + (go ,loop-tag) + ,end-tag)) + (let ((internals (package-object-internal-symbols ,package-var))) + (unless (eq ,package-hash-var internals) + (setf ,package-hash-var internals) + (go ,loop-tag)))))))))) (defmacro do-external-symbols - ((var &optional (package *package*) result-form) &body declarations-and-body) + ((var &optional (package '*package*) result-form) &body declarations-and-body) (let ((next-var (gensym)) (more-var (gensym)) (key-var (gensym))) `(with-hash-table-iterator (,next-var (package-object-external-symbols (assert-package ,package))) (do () (nil) (multiple-value-bind (,more-var ,key-var ,var) (,next-var) - (unless ,more-var (return ,result-form)) - (let () , at declarations-and-body)))))) + (unless ,more-var + (return ,result-form)) + (prog () + , at declarations-and-body)))))) (defmacro do-symbols ((var &optional (package '*package*) result-form) &body declarations-and-body) (let ((state-var (gensym)) @@ -215,35 +217,40 @@ (1 (package-object-internal-symbols ,package-object-var)) (t (let ((x (pop ,use-list-var))) (and x (package-object-external-symbols x))))))) - ((not ,hash-table-var) ,result-form) + ((not ,hash-table-var) ,result-form) (declare (index ,state-var)) (with-hash-table-iterator (,next-var ,hash-table-var) (do () (nil) (multiple-value-bind (,more-var ,key-var ,var) (,next-var) (declare (ignore ,key-var)) (if ,more-var - (let () , at declarations-and-body) - (return)))))))) + (prog () + , at declarations-and-body) + (return)))))))) (defun apropos (string &optional package) (flet ((apropos-symbol (symbol string) (when (search string (symbol-name symbol) :test #'char-equal) (cond - ((keywordp symbol) - (format t "~&~W == keyword~%" symbol)) - ((fboundp symbol) - (format t "~&~W == function ~:A~%" - symbol (funobj-lambda-list (symbol-function symbol)))) - ((boundp symbol) - (format t "~&~W == variable ~S~%" - symbol (symbol-value symbol))) - (t (format t "~&~W~%" symbol)))))) + ((keywordp symbol) + (format t "~&~W == keyword~%" symbol)) + ((fboundp symbol) + (format t "~&~W == function ~:A~%" + symbol (funobj-lambda-list (symbol-function symbol)))) + ((boundp symbol) + (format t "~&~W == variable ~S~%" + symbol (symbol-value symbol))) + (t (format t "~&~W~%" symbol)))))) (let ((string (string string))) (if package (do-symbols (symbol package) (apropos-symbol symbol string)) - (do-all-symbols (symbol) - (apropos-symbol symbol string))))) + (do-all-symbols (symbol) + (apropos-symbol symbol string))))) (values)) - +(defmacro with-package-iterator ((name package-list-form &rest symbol-types) &body body) + `(macrolet ((,name () + '(warn "with-package-iterator not implemented." + (values nil nil nil nil)))) + , at body)) \ No newline at end of file From ffjeld at common-lisp.net Sun Apr 27 08:34:46 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 04:34:46 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/lib Message-ID: <20080427083446.1F8917A042@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv2734 Modified Files: repl.lisp Log Message: Add the - variable. --- /project/movitz/cvsroot/movitz/losp/lib/repl.lisp 2005/10/31 09:19:15 1.17 +++ /project/movitz/cvsroot/movitz/losp/lib/repl.lisp 2008/04/27 08:34:46 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Mar 19 14:58:12 2003 ;;;; -;;;; $Id: repl.lisp,v 1.17 2005/10/31 09:19:15 ffjeld Exp $ +;;;; $Id: repl.lisp,v 1.18 2008/04/27 08:34:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -98,8 +98,9 @@ (restart (invoke-restart-interactively restart)) ((not (keywordp form)) - (multiple-value-call #'process-expresion - form previous-package t (eval form))) + (let ((- form)) + (multiple-value-call #'process-expresion + form previous-package t (eval form)))) (t (multiple-value-call #'process-expresion form previous-package nil (apply 'muerte.toplevel:invoke-toplevel-command From ffjeld at common-lisp.net Sun Apr 27 08:34:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 04:34:48 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427083448.73A1F7A042@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2766 Modified Files: variables.lisp Log Message: Add the - variable. --- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/04/21 19:44:13 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/04/27 08:34:48 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.13 2008/04/21 19:44:13 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.14 2008/04/27 08:34:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,6 +30,7 @@ (defvar // nil) (defvar /// nil) +(defvar - nil) (defvar + nil) (defvar ++ nil) (defvar +++ nil) From ffjeld at common-lisp.net Sun Apr 27 08:38:01 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 04:38:01 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427083801.9B8031A0EC@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3266 Modified Files: eval.lisp Log Message: Rename parse-foo-formal to decode-foo-formal. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/21 19:40:05 1.32 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/27 08:38:01 1.33 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.32 2008/04/21 19:40:05 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.33 2008/04/27 08:38:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -214,7 +214,7 @@ (push x r))))) (ignore-env-var (when (not env-var) - (gensym)))) + (gensym "ignore-env-")))) (values destructuring-lambda-list whole-var (or env-var @@ -276,9 +276,7 @@ :whole-p nil))))) name) - - -(defun parse-optional-formal (formal) +(defun decode-optional-formal (formal) "3.4.1.2 Specifiers for optional parameters. Parse {var | (var [init-form [supplied-p-parameter]])} Return the variable, init-form, and suplied-p-parameter." @@ -286,7 +284,7 @@ (symbol (values formal nil nil)) (cons (values (first formal) (second formal) (third formal))))) -(defun parse-keyword-formal (formal) +(defun decode-keyword-formal (formal) "3.4.1.4 Specifiers for keyword parameters. Parse {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])} Return the variable, keyword, init-fom, and supplied-p-parameter." @@ -345,7 +343,7 @@ env)) (&optional (multiple-value-bind (var init-form supplied-p-parameter) - (parse-optional-formal p) + (decode-optional-formal p) (when supplied-p-parameter (push (cons supplied-p-parameter (not (null values))) @@ -359,7 +357,7 @@ env)) (&key (multiple-value-bind (var key init-form supplied-p-parameter) - (parse-keyword-formal p) + (decode-keyword-formal p) (let* ((x (member key values :test #'eq)) (present-p (not (null x))) (value (if present-p From ffjeld at common-lisp.net Sun Apr 27 09:10:05 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 05:10:05 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427091005.C949A5D088@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv10677 Modified Files: hash-tables.lisp Log Message: Add hash-table-size. --- /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp 2008/04/17 19:34:08 1.14 +++ /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp 2008/04/27 09:10:04 1.15 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.14 2008/04/17 19:34:08 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.15 2008/04/27 09:10:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -50,6 +50,10 @@ :sxhash sxhash :count 0))) +(defun hash-table-size (hash-table) + (values (truncate (length (hash-table-bucket hash-table)) + 2))) + (defun hash-table-iterator (bucket index) (when index (let ((index (check-the (index 2) index))) From ffjeld at common-lisp.net Sun Apr 27 09:28:41 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 05:28:41 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427092841.081A83F014@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14216 Modified Files: lists.lisp Log Message: Fix assoc-if, add rassoc-if, member-if, and mapcon. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/19 12:44:02 1.27 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/27 09:28:40 1.28 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.27 2008/04/19 12:44:02 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.28 2008/04/27 09:28:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -82,6 +82,40 @@ (when (test item (key (car a))) (return a)))))))) +(defun assoc-if (predicate alist &key (key 'identity)) + "=> entry" + (numargs-case + (2 (predicate alist) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (predicate (car a)) + (return a)))))) + (t (predicate alist &key (key 'identity)) + (with-funcallable (key) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (predicate (key (car a))) + (return a))))))))) + +(defun assoc-if-not (predicate alist &key (key 'identity)) + "=> entry" + (numargs-case + (2 (predicate alist) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (not (predicate (car a))) + (return a)))))) + (t (predicate alist &key (key 'identity)) + (with-funcallable (key) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (not (predicate (key (car a)))) + (return a))))))))) + (defun rassoc (item alist &key (test 'eql) (key 'identity)) (numargs-case (2 (item alist) @@ -95,6 +129,24 @@ (when (test item (key (cdr a))) (return a)))))))) +(defun rassoc-if (predicate alist &key (key 'identity)) + "=> entry" + (numargs-case + (2 (predicate alist) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (predicate (cdr a)) + (return a)))))) + (t (predicate alist &key (key 'identity)) + (with-funcallable (key) + (with-funcallable (predicate) + (dolist (a alist) + (when a + (when (predicate (key (cdr a))) + (return a))))))))) + + (defun list-length (x) (do ((n 0 (+ n 2)) ;Counter. (fast x (cddr fast)) ;Fast pointer: leaps by 2. @@ -128,6 +180,38 @@ (when (test (key item) (key (car p))) (return p))))))))) +(defun member-if (predicate list &key key) + (numargs-case + (2 (predicate list) + (with-funcallable (predicate) + (do ((p list (cdr p))) + ((endp p) nil) + (when (predicate (car p)) + (return p))))) + (t (predicate list &key (key 'identity)) + (with-funcallable (predicate) + (with-funcallable (key) + (do ((p list (cdr p))) + ((endp p) nil) + (when (predicate (key (car p))) + (return p)))))))) + +(defun member-if-not (predicate list &key key) + (numargs-case + (2 (predicate list) + (with-funcallable (predicate) + (do ((p list (cdr p))) + ((endp p) nil) + (when (not (predicate (car p))) + (return p))))) + (t (predicate list &key (key 'identity)) + (with-funcallable (predicate) + (with-funcallable (key) + (do ((p list (cdr p))) + ((endp p) nil) + (when (not (predicate (key (car p)))) + (return p)))))))) + (defun last (list &optional (n 1)) ;; from the hyperspec.. (check-type n integer) ; (integer 0)) @@ -320,8 +404,6 @@ (setf more-lists (map-into more-lists #'cdr more-lists)))))) - - (defun mapcan (function first-list &rest more-lists) (numargs-case (2 (function first-list) @@ -362,6 +444,48 @@ (setf more-lists (map-into more-lists #'cdr more-lists)))))) +(defun mapcon (function first-list &rest more-lists) + (numargs-case + (2 (function first-list) + (do ((result nil) + (tail nil) + (p first-list (cdr p))) + ((endp p) result) + (let ((m (funcall function 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 p 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 first-list more-lists))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))) + (setf first-list + (cdr first-list)) + (setf more-lists + (map-into more-lists #'cdr more-lists)))))) + (defun mapc (function first-list &rest more-lists) (numargs-case (2 (function first-list) From ffjeld at common-lisp.net Sun Apr 27 09:36:39 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 05:36:39 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427093639.061FC12063@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14842 Modified Files: lists.lisp Log Message: add set-exclusive-or --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/27 09:28:40 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/04/27 09:36:39 1.29 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.28 2008/04/27 09:28:40 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.29 2008/04/27 09:36:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -659,6 +659,33 @@ :test (if test-not (complement test-not) test))) + +(defun set-exclusive-or (list-1 list-2 &key (key 'identity) (test 'eql) test-not) + (union (set-difference list-1 list-2 + :key key + :test test + :test-not test-not) + (set-difference list-2 list-1 + :key key + :test test + :test-not test-not) + :key key + :test test + :test-not test-not)) + +(defun nset-exclusive-or (list-1 list-2 &key (key 'identity) (test 'eql) test-not) + (nunion (nset-difference list-1 list-2 + :key key + :test test + :test-not test-not) + (nset-difference list-2 list-1 + :key key + :test test + :test-not test-not) + :key key + :test test + :test-not test-not)) + (defun subsetp (list-1 list-2 &key (key 'identity) (test 'eql) test-not) "=> generalized-boolean" From ffjeld at common-lisp.net Sun Apr 27 16:14:10 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 12:14:10 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427161410.D1E873F026@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv18531 Modified Files: eval.lisp Log Message: Fix parse-docstring-declarations-and-body. Fix bug in decode-keyword-formal. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/27 08:38:01 1.33 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/04/27 16:14:10 1.34 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.33 2008/04/27 08:38:01 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.34 2008/04/27 16:14:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -149,11 +149,6 @@ ((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))) @@ -234,6 +229,26 @@ (dolist (d (cdar p)) (push d declarations)))) +(defun parse-docstring-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) + "From the list of FORMS, return first the non-declarations forms, second the declarations, ~ + and third the documentation string." + (let ((docstring nil)) + (do (declarations docstring) + ((endp forms) + (values nil + declarations + docstring)) + (cond + ((typep (car forms) + '(cons (eql declare))) + (setf declarations (append declarations (cdr (pop forms))))) + ((and (stringp (car forms)) + (cdr forms)) + (setf docstring (pop forms))) + (t (return (values forms + 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." @@ -241,9 +256,9 @@ (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)))) + (multiple-value-call #'values + (parse-declarations-and-body (cdr forms)) + (car forms)))) (defun compute-function-block-name (function-name) (cond @@ -290,7 +305,9 @@ Return the variable, keyword, init-fom, and supplied-p-parameter." (cond ((symbolp formal) - (values formal formal nil nil)) + (values formal + (intern (symbol-name formal) :keyword) + nil nil)) ((symbolp (car formal)) (values (car formal) (intern (symbol-name (car formal)) :keyword) @@ -302,8 +319,8 @@ (caddr formal))))) (defun make-destructuring-env (pattern values env &key (recursive-p t) - (environment-p nil) - (whole-p t)) + (environment-p nil) + (whole-p t)) (let (env-var) (when (and whole-p (eq '&whole (car pattern))) (push (cons (cadr pattern) values) @@ -381,12 +398,12 @@ (push (cons (cdr pp) values) env)) finally - (when (and values (member state '(requireds optionals))) - (simple-program-error "Too many arguments."))) + (when (and values (member state '(requireds optionals))) + (simple-program-error "Too many arguments."))) (if (and environment-p env-var) (cons (cons env-var env) env) - env))) + env))) (defun eval-let (var-specs declarations-and-body env) (let (special-vars @@ -579,7 +596,8 @@ (values (if (not name) function (setf (symbol-function name) function)) - t nil))) + nil + nil))) (defun macroexpand-1 (form &optional env) (if (atom form) From ffjeld at common-lisp.net Sun Apr 27 19:07:33 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:07:33 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427190733.BD79B240D3@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27877 Modified Files: compiler.lisp Log Message: Remove bad peephole optimized heuristic. Improved movitz-eql. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/21 19:45:36 1.204 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/27 19:07:33 1.205 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.204 2008/04/21 19:45:36 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.205 2008/04/27 19:07:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -236,28 +236,32 @@ ;; The ability to provide funobj's identity is important when a ;; function must be referenced before it can be compiled, e.g. for ;; mutually recursive (lexically bound) functions. - (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name) - ;; First-pass is mostly functional, so it can safely be restarted. - (multiple-value-bind (required-vars optional-vars rest-var key-vars aux-vars allow-p min max edx-var) - (decode-normal-lambda-list lambda-list) - (declare (ignore aux-vars allow-p min max)) - ;; There are several main branches through the function - ;; compiler, and this is where we decide which one to take. - (funcall (cond - ((let ((sub-form (cddr form))) - (and (consp (car sub-form)) - (eq 'muerte::numargs-case (caar sub-form)))) - 'make-compiled-function-pass1-numarg-case) - ((and (= 1 (length required-vars)) ; (x &optional y) - (= 1 (length optional-vars)) - (movitz-constantp (nth-value 1 (decode-optional-formal (first optional-vars))) - env) - (null key-vars) - (not rest-var) - (not edx-var)) - 'make-compiled-function-pass1-1req1opt) - (t 'make-compiled-function-pass1)) - name lambda-list declarations form env top-level-p funobj)))) + (multiple-value-bind (required-vars optional-vars rest-var key-vars aux-vars allow-p min max edx-var) + (decode-normal-lambda-list lambda-list) + (declare (ignore aux-vars allow-p min max)) + ;; There are several main branches through the function + ;; compiler, and this is where we decide which one to take. + (funcall (cond + ((let ((sub-form (cddr form))) + (and (consp (car sub-form)) + (eq 'muerte::numargs-case (caar sub-form)))) + 'make-compiled-function-pass1-numarg-case) + ((and (= 1 (length required-vars)) ; (x &optional y) + (= 1 (length optional-vars)) + (movitz-constantp (nth-value 1 (decode-optional-formal (first optional-vars))) + env) + (null key-vars) + (not rest-var) + (not edx-var)) + 'make-compiled-function-pass1-1req1opt) + (t 'make-compiled-function-pass1)) + name + lambda-list + declarations + form + env + top-level-p + funobj))) (defun ensure-pass1-funobj (funobj class &rest init-args) "If funobj is nil, return a fresh funobj of class. @@ -1880,14 +1884,14 @@ (case (instruction-is next-load) (:movl (let ((pos (position next-load pc))) - (setq p (nconc (subseq pc 0 pos) - (if (or (eq register (twop-dst next-load)) - (find-if (lambda (m) - (and (eq (twop-dst next-load) (cdr m)) - (= (car m) (stack-frame-operand place)))) - map)) - nil - (list `(:movl ,register ,(twop-dst next-load))))) + (setq p (append (subseq pc 0 pos) + (if (or (eq register (twop-dst next-load)) + (find-if (lambda (m) + (and (eq (twop-dst next-load) (cdr m)) + (= (car m) (stack-frame-operand place)))) + map)) + nil + (list `(:movl ,register ,(twop-dst next-load))))) next-pc (nthcdr (1+ pos) pc)) (explain nil "preserved load/store .. load ~S of place ~S because ~S." next-load place reason))) @@ -2141,14 +2145,6 @@ (setq p `((:call (:edi ,(global-constant-offset newf)))) next-pc (nthcdr 2 pc)) (explain nil "Changed [~S ~S] to ~S" i i2 newf))) - ((and (equal i '(:movl :eax :ebx)) - (global-funcall-p i2 '(fast-car-ebx fast-cdr-ebx))) - (let ((newf (ecase (global-funcall-p i2 '(fast-car-ebx fast-cdr-ebx)) - (fast-car-ebx 'fast-car) - (fast-cdr-ebx 'fast-cdr)))) - (setq p `((:call (:edi ,(global-constant-offset newf)))) - next-pc (nthcdr 2 pc)) - (explain nil "Changed [~S ~S] to ~S" i i2 newf))) #+ignore ((and (global-funcall-p i '(fast-cdr)) (global-funcall-p i2 '(fast-cdr)) @@ -4426,6 +4422,10 @@ ((eql 1 location-1) (decf stack-setup-size) '((:pushl :ebx))) + ((eql 2 location-1) + (decf stack-setup-size 2) + `((:pushl :edi) + (:pushl :ebx))) (t (ecase location-1 ((nil :ebx) nil) (:edx '((:movl :ebx :edx))) @@ -4490,7 +4490,7 @@ (append (cond ;; normalize arg-count in ecx.. ((and max-args (= min-args max-args)) - (error "huh?")) + (error "huh? max: ~S, min: ~S" max-args min-args)) ((and max-args (<= 0 min-args max-args #x7f)) `((:andl #x7f :ecx))) ((>= min-args #x80) @@ -6967,7 +6967,9 @@ (make-store-lexical destination loc0 nil funobj frame-map)) ((integerp loc0) (make-load-lexical term0 destination funobj nil frame-map)) - (t (break "Unknown Y zero-add: ~S" instruction)))) + ((type-specifier-singleton type0) + (make-load-lexical term0 destination funobj nil frame-map)) + (t (break "Unknown Y zero-add: ~S for ~S/~S => ~S" instruction term0 loc0 destination)))) ((and (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum) (movitz-subtypep result-type 'fixnum)) @@ -7203,6 +7205,29 @@ ;;;;;;; +(defun movitz-eql (x y) + "Emulate EQL on movitz-objects." + (etypecase x + (movitz-immediate-object + (and (typep y 'movitz-immediate-object) + (eql (movitz-immediate-value x) + (movitz-immediate-value y)))) + ((or movitz-symbol movitz-null movitz-cons movitz-basic-vector) + (eq x y)) + (movitz-struct + (cond + ((not (typep y 'movitz-struct)) + nil) + ((eq (movitz-struct-class x) + (muerte::movitz-find-class 'muerte.cl:complex)) + (and (eq (movitz-struct-class x) + (muerte::movitz-find-class 'muerte.cl:complex)) + (movitz-eql (first (movitz-struct-slot-values x)) + (first (movitz-struct-slot-values y))) + (movitz-eql (second (movitz-struct-slot-values x)) + (second (movitz-struct-slot-values y))))) + (t (error "movitz-eql unknown movitz-struct: ~S" x)))))) + (define-find-read-bindings :eql (x y mode) (declare (ignore mode)) (list x y)) @@ -7239,11 +7264,8 @@ (make-load-lexical y :ebx funobj nil frame-map))))) (cond ((and x-singleton y-singleton) - (let ((eql (etypecase (car x-singleton) - (movitz-immediate-object - (and (typep (car y-singleton) 'movitz-immediate-object) - (eql (movitz-immediate-value (car x-singleton)) - (movitz-immediate-value (car y-singleton)))))))) + (let ((eql (movitz-eql (car x-singleton) + (car y-singleton)))) (case (operator return-mode) (:boolean-branch-on-false (when (not eql) From ffjeld at common-lisp.net Sun Apr 27 19:14:54 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:14:54 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427191454.8A0742E217@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29457 Modified Files: compiler-types.lisp Log Message: Complex type. --- /project/movitz/cvsroot/movitz/compiler-types.lisp 2006/11/08 08:57:05 1.26 +++ /project/movitz/cvsroot/movitz/compiler-types.lisp 2008/04/27 19:14:54 1.27 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.26 2006/11/08 08:57:05 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.27 2008/04/27 19:14:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -233,15 +233,19 @@ ;;; (defparameter *tb-bitmap* - '(hash-table character function cons keyword symbol vector array integer ratio :tail) + '(hash-table character function cons keyword symbol vector array integer ratio complex :tail) "The union of these types must be t.") (defun basic-typep (x type) (ecase type (hash-table (and (typep x 'movitz-struct) - (eq (movitz-read 'muerte.cl:hash-table) - (slot-value x 'name)))) + (eq (muerte::movitz-find-class 'muerte.cl:hash-table) + (slot-value x 'class)))) + (complex + (and (typep x 'movitz-struct) + (eq (muerte::movitz-find-class 'muerte.cl:complex) + (slot-value x 'class)))) (character (typep x 'movitz-character)) (function @@ -366,7 +370,7 @@ (or (type-code-p 'integer code) (and integer-range (numscope-memberp integer-range (movitz-bignum-value x))))) - (t (dolist (bt '(symbol character function cons hash-table vector ratio) + (t (dolist (bt '(symbol character function cons hash-table vector ratio complex) (error "Cant decide typep for ~S." x)) (when (basic-typep x bt) (return (type-code-p bt code)))))) From ffjeld at common-lisp.net Sun Apr 27 19:16:16 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:16:16 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427191616.B725A830B3@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29743 Modified Files: environment.lisp Log Message: indent. --- /project/movitz/cvsroot/movitz/environment.lisp 2008/03/15 20:44:53 1.23 +++ /project/movitz/cvsroot/movitz/environment.lisp 2008/04/27 19:16:16 1.24 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.23 2008/03/15 20:44:53 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.24 2008/04/27 19:16:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -332,28 +332,28 @@ (let ((expander (movitz-macro-function (car movitz-form) env))) (if (not expander) (values movitz-form nil) - (values (translate-program (funcall *movitz-macroexpand-hook* expander movitz-form env) - :muerte.cl :cl) - t)))) + (values (translate-program (funcall *movitz-macroexpand-hook* expander movitz-form env) + :muerte.cl :cl) + t)))) (symbol (let ((binding (movitz-binding movitz-form env))) (if (not (typep binding 'symbol-macro-binding)) (values movitz-form nil) - (values (translate-program (funcall *movitz-macroexpand-hook* - (macro-binding-expander binding) - movitz-form env) - :muerte.cl :cl) - t)))) + (values (translate-program (funcall *movitz-macroexpand-hook* + (macro-binding-expander binding) + movitz-form env) + :muerte.cl :cl) + t)))) (t (values movitz-form nil))))) (defun movitz-macroexpand (form &optional env) (let ((global-expanded-p nil)) (loop while - (multiple-value-bind (expansion expanded-p) - (movitz-macroexpand-1 form env) - (when expanded-p - (setf form expansion) - (setf global-expanded-p expanded-p)))) + (multiple-value-bind (expansion expanded-p) + (movitz-macroexpand-1 form env) + (when expanded-p + (setf form expansion) + (setf global-expanded-p expanded-p)))) (values form global-expanded-p))) (define-symbol-macro *movitz-global-environment* From ffjeld at common-lisp.net Sun Apr 27 19:17:17 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:17:17 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427191717.4FF5F12064@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29953 Modified Files: eval.lisp Log Message: Don't coerce to function. --- /project/movitz/cvsroot/movitz/eval.lisp 2007/03/11 21:18:40 1.12 +++ /project/movitz/cvsroot/movitz/eval.lisp 2008/04/27 19:17:17 1.13 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.12 2007/03/11 21:18:40 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.13 2008/04/27 19:17:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,10 +76,17 @@ ((muerte.cl:quote) t) ((muerte.cl:not) (movitz-constantp (second form))) - ((muerte.cl:+ muerte.cl:- muerte.cl:* muerte.cl:coerce) + ((muerte.cl:+ muerte.cl:- muerte.cl:*) (every (lambda (sub-form) (movitz-constantp sub-form env)) - (cdr form))))) + (cdr form))) + ((muerte.cl:coerce) + (and (= 3 (length form)) + (every (lambda (sub-form) + (movitz-constantp sub-form env)) + (cdr form)) + (not (member (movitz-eval (third form) env) + '(muerte.cl:function))))))) (and compiler-macro-function (not (movitz-env-get (car form) 'notinline nil env)) (not (eq form compiler-macro-expansion)) From ffjeld at common-lisp.net Sun Apr 27 19:18:16 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:18:16 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427191816.A122439179@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv30109 Modified Files: image.lisp Log Message: indent. --- /project/movitz/cvsroot/movitz/image.lisp 2008/04/21 19:45:51 1.123 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/04/27 19:18:16 1.124 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.123 2008/04/21 19:45:51 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.124 2008/04/27 19:18:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1240,15 +1240,13 @@ 'package) (movitz-read (ensure-package (string :common-lisp) :muerte.common-lisp))) (loop for symbol being the hash-key of (image-oblist *image*) - as lisp-package = (symbol-package symbol) - as package-name = (and lisp-package - (movitz-package-name (package-name lisp-package) symbol)) -;;; do (when (string= symbol :method) -;;; (warn "XXXX ~S ~S ~S" symbol lisp-package package-name)) - when package-name - do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) - (setf (movitz-symbol-package (movitz-read symbol)) - (movitz-read movitz-package)))) + as lisp-package = (symbol-package symbol) + as package-name = (and lisp-package + (movitz-package-name (package-name lisp-package) symbol)) + when package-name + do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) + (setf (movitz-symbol-package (movitz-read symbol)) + (movitz-read movitz-package)))) movitz-packages)))) From ffjeld at common-lisp.net Sun Apr 27 19:20:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:20:06 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427192006.403B548151@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv30486 Modified Files: packages.lisp Log Message: more muerte symbols. --- /project/movitz/cvsroot/movitz/packages.lisp 2008/04/21 19:46:02 1.60 +++ /project/movitz/cvsroot/movitz/packages.lisp 2008/04/27 19:20:06 1.61 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.60 2008/04/21 19:46:02 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.61 2008/04/27 19:20:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1236,6 +1236,10 @@ #:parse-docstring-declarations-and-body #:parse-macro-lambda-list #:compute-function-block-name + #:movitz-macroexpand + #:movitz-macroexpand-1 + #:decode-optional-formal + #:decode-keyword-formal #:movitz-accessor #:%object-lispval @@ -1395,6 +1399,10 @@ muerte::parse-macro-lambda-list muerte::unfold-circular-list muerte::compute-function-block-name + muerte::movitz-macroexpand + muerte::movitz-macroexpand-1 + muerte::decode-optional-formal + muerte::decode-keyword-formal )) From ffjeld at common-lisp.net Sun Apr 27 19:22:42 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:22:42 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427192242.C0B1172091@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32667 Modified Files: parse.lisp Log Message: Fix bug in decode-normal-lambda-list. --- /project/movitz/cvsroot/movitz/parse.lisp 2008/04/21 21:09:47 1.9 +++ /project/movitz/cvsroot/movitz/parse.lisp 2008/04/27 19:22:42 1.10 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.9 2008/04/21 21:09:47 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.10 2008/04/27 19:22:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,9 +23,7 @@ (defun parse-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) "From the list of FORMS, return first the list of non-declaration forms, ~ second the list of declaration-specifiers." - (loop for declaration-form = (when (declare-form-p (car forms) declare-symbol) - (pop forms)) - if (declare-form-p (car forms) declare-symbol) + (loop if (declare-form-p (car forms) declare-symbol) append (cdr (pop forms)) into declarations else return (values forms declarations))) @@ -45,7 +43,7 @@ (pop lambda-list) (pop lambda-list))) (env-var nil) - (operator-var (gensym)) + (operator-var (gensym "operator-")) (destructuring-lambda-list (do ((l lambda-list) (r nil)) @@ -58,7 +56,7 @@ (push x r))))) (ignore-env-var (when (not env-var) - (gensym)))) + (gensym "ignore-env-")))) (values destructuring-lambda-list whole-var (or env-var @@ -208,14 +206,14 @@ (auxes (nreverse (getf results (aux))))) (when (> (length rests) 1) (error "There can only be one &REST formal parameter.")) - (let ((maxargs (and (null rests) ; max num. of arguments, or nil. - (null keys) - (not allow-other-keys-p) - (+ (length requireds) - (length optionals)))) - (minargs (length requireds)) - (keys-p (not (eq :missing - (getf results (key) :missing))))) + (let* ((keys-p (not (eq :missing ; &key present? + (getf results (key) :missing)))) + (maxargs (and (null rests) ; max num. of arguments, or nil. + (not keys-p) + (not allow-other-keys-p) + (+ (length requireds) + (length optionals)))) + (minargs (length requireds))) (return (values requireds optionals (first rests) @@ -223,14 +221,14 @@ auxes allow-other-keys-p minargs - (unless keys-p - maxargs) + maxargs edx-var (cond - ((or (eql maxargs minargs) - (eq :no-key (getf results (key) :no-key))) + ((or (not keys-p) + (eql maxargs minargs)) nil) - ((assert (not maxargs))) + ((assert (not maxargs) () + "Weird maxargs ~S for ~S." maxargs lambda-list)) ((evenp (+ (length requireds) (length optionals))) :even) (t :odd)) From ffjeld at common-lisp.net Sun Apr 27 19:23:14 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:23:14 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427192314.9EBFC340C9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv576 Modified Files: special-operators-cl.lisp Log Message: Fix eval-when for :compile-toplevel, must actually be top-level. --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/11 22:09:39 1.53 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2008/04/27 19:23:14 1.54 @@ -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.53 2007/04/11 22:09:39 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.54 2008/04/27 19:23:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -992,7 +992,8 @@ :top-level-p top-level-p :form body) (compiler-values ())) - (when (member :compile-toplevel situations) + (when (and (member :compile-toplevel situations) + top-level-p) (with-compilation-unit () (dolist (toplevel-form (translate-program body :muerte.cl :cl :when :eval From ffjeld at common-lisp.net Sun Apr 27 19:23:25 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:23:25 -0400 (EDT) Subject: [movitz-cvs] CVS movitz Message-ID: <20080427192325.1E7BE7C04F@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv659 Modified Files: storage-types.lisp Log Message: Remove old movitz-eql. --- /project/movitz/cvsroot/movitz/storage-types.lisp 2008/04/12 16:26:56 1.64 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2008/04/27 19:23:25 1.65 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.64 2008/04/12 16:26:56 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.65 2008/04/27 19:23:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -237,13 +237,6 @@ (print-unreadable-object (x stream) (format stream "MOVITZ-CHARACTER: ~S" (movitz-char x)))) -(defun movitz-eql (x y) - (if (and (typep x 'movitz-immediate-object) - (typep y 'movitz-immediate-object)) - (= (movitz-immediate-value x) - (movitz-immediate-value y)) - (eq x y))) - ;;; Code element (define-binary-class movitz-code (movitz-immediate-object) From ffjeld at common-lisp.net Sun Apr 27 19:26:14 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:26:14 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427192614.27EDE12063@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv1287 Modified Files: arithmetic-macros.lisp Log Message: Fix constant-folding for logand. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2008/04/21 19:29:17 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2008/04/27 19:26:14 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.22 2008/04/21 19:29:17 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.23 2008/04/27 19:26:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -305,22 +305,28 @@ finally (return (if (= -1 folded-constant) non-constants (cons folded-constant non-constants)))))) - (case (length constant-folded-integers) - (0 0) - (1 (first constant-folded-integers)) - (2 (cond - ((typep (first constant-folded-integers) - '(unsigned-byte 32)) - (let ((x (first constant-folded-integers))) - `(with-inline-assembly (:returns :untagged-fixnum-ecx - :type (unsigned-byte ,(integer-length x))) - (:compile-form (:result-mode :untagged-fixnum-ecx) - ,(second constant-folded-integers)) - (:andl ,x :ecx)))) - (t `(no-macro-call logand - ,(first constant-folded-integers) - ,(second constant-folded-integers))))) - (t `(logand (logand ,(first constant-folded-integers) ,(second constant-folded-integers)) + (cond + ((null constant-folded-integers) + 0) + ((null (rest constant-folded-integers)) + (first constant-folded-integers)) + ((eql 0 (first constant-folded-integers)) + `(progn ,@(rest constant-folded-integers) 0)) + ((null (cddr constant-folded-integers)) + (cond + ((typep (first constant-folded-integers) + '(unsigned-byte 32)) + (let ((x (first constant-folded-integers))) + `(with-inline-assembly (:returns :untagged-fixnum-ecx + :type (unsigned-byte ,(integer-length x))) + (:compile-form (:result-mode :untagged-fixnum-ecx) + ,(second constant-folded-integers)) + (:andl ,x :ecx)))) + (t `(no-macro-call logand + ,(first constant-folded-integers) + ,(second constant-folded-integers))))) + (t `(logand (logand ,(first constant-folded-integers) + ,(second constant-folded-integers)) ,@(cddr constant-folded-integers)))))) (define-compiler-macro logior (&whole form &rest integers &environment env) @@ -410,7 +416,7 @@ (t form))) (define-compiler-macro ldb (&whole form &environment env bytespec integer) - (let ((bytespec (movitz::movitz-macroexpand bytespec env))) + (let ((bytespec (movitz-macroexpand bytespec env))) (if (not (and (consp bytespec) (eq 'byte (car bytespec)))) form `(ldb%byte ,(second bytespec) ,(third bytespec) ,integer)))) From ffjeld at common-lisp.net Sun Apr 27 19:30:13 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:30:13 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427193013.97478830B7@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv1813 Modified Files: characters.lisp Log Message: Add some missing char-foo functions. --- /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp 2008/03/15 20:57:27 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp 2008/04/27 19:30:12 1.6 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Feb 5 19:05:01 2001 ;;;; -;;;; $Id: characters.lisp,v 1.5 2008/03/15 20:57:27 ffjeld Exp $ +;;;; $Id: characters.lisp,v 1.6 2008/04/27 19:30:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,6 +29,9 @@ (:jne '(:sub-program (not-a-character) (:int 66))) (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) :eax))) +(defun char-int (c) + (char-code c)) + (defun code-char (code) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) code) @@ -138,7 +141,9 @@ (defun char-equal (first-character &rest more-characters) (numargs-case - (1 (x) (declare (ignore x)) t) + (1 (x) + (declare (ignore x)) + t) (2 (x y) (char= (char-upcase x) (char-upcase y))) (t (first-character &rest more-characters) @@ -148,6 +153,71 @@ (unless (char= f (char-upcase c)) (return nil))))))) +(defun char-not-equal (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (not (char= (char-upcase x) (char-upcase y)))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (not (apply #'char-equal first-character more-characters))))) + +(defun char-lessp (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (char< (char-upcase x) + (char-upcase y))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (let ((x (char-upcase first-character))) + (dolist (y more-characters t) + (unless (char< x (setf x (char-upcase y))) + (return nil))))))) + +(defun char-not-lessp (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (not (char< (char-upcase x) + (char-upcase y)))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (not (apply #'char-lessp first-character more-characters))))) + +(defun char-greaterp (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (char> (char-upcase x) + (char-upcase y))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (let ((x (char-upcase first-character))) + (dolist (y more-characters t) + (unless (char> x (setf x (char-upcase y))) + (return nil))))))) + +(defun char-not-greaterp (first-character &rest more-characters) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (not (char> (char-upcase x) + (char-upcase y)))) + (t (first-character &rest more-characters) + (declare (dynamic-extent more-characters)) + (not (apply #'char-greaterp first-character more-characters))))) + (defun standard-char-p (c) "CLHS 2.1.3 Standard Characters" (or (char<= #\A (char-upcase c) #\Z) @@ -217,3 +287,13 @@ (char= character #\Return) (char= character #\Tab) (char= character #\Linefeed))) + +(defun character (c) + (etypecase c + (character c) + ((string 1) + (char c 0)) + (symbol + (character (symbol-name c))))) + + From ffjeld at common-lisp.net Sun Apr 27 19:30:28 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:30:28 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427193028.0FFF412064@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv1906 Modified Files: cons.lisp Log Message: Tiny comment tweak. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2007/02/22 21:23:04 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2008/04/27 19:30:27 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.17 2007/02/22 21:23:04 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.18 2008/04/27 19:30:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -80,7 +80,7 @@ (define-primitive-function fast-cdr-ebx () "This is the actual CDR code. -Cons cell is in EBX, which is preserved." +Cons cell is in EBX, which is preserved. Result in EAX." (with-inline-assembly (:returns :eax) (:leal (:ebx -1) :ecx) (:testb 3 :cl) From ffjeld at common-lisp.net Sun Apr 27 19:37:08 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:37:08 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427193708.5C15572091@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2754 Modified Files: defmacro-bootstrap.lisp Log Message: improved defmacro. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/21 19:38:48 1.4 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/04/27 19:37:08 1.5 @@ -7,7 +7,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defmacro-bootstrap.lisp,v 1.4 2008/04/21 19:38:48 ffjeld Exp $ +;;;; $Id: defmacro-bootstrap.lisp,v 1.5 2008/04/27 19:37:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,9 +17,12 @@ (`(muerte::defmacro/compile-time ,name ,lambda-list ,macro-body))) (muerte.cl:defmacro muerte.cl:in-package (name) - `(progn - (eval-when (:compile-toplevel) - (in-package ,(movitz::movitzify-package-name name))))) + (let ((movitz-package-name (movitz::movitzify-package-name name))) + `(progn + (eval-when (:compile-toplevel) + (in-package ,movitz-package-name)) + (eval-when (:execute) + (set '*package* (find-package ',movitz-package-name)))))) (in-package #:muerte) @@ -37,7 +40,7 @@ (multiple-value-bind (destructuring-lambda-list whole-var env-var ignore-env ignore-operator) (parse-macro-lambda-list lambda-list) (let* ((block-name (compute-function-block-name name)) - (extras (gensym)) + (extras (gensym "extras-")) (form-var (or whole-var (gensym "form-")))) (cond @@ -50,12 +53,13 @@ (block ,block-name (numargs-case (2 (&edx edx &optional ,form-var ,env-var) + (declare (ignore , at ignore-env)) (verify-macroexpand-call edx ',name) (let () (declare , at declarations) , at real-body)) (t (&edx edx &optional ,form-var ,env-var &rest ,extras) - (declare (ignore ,form-var ,extras)) + (declare (ignore ,form-var ,extras , at ignore-env)) (verify-macroexpand-call edx ',name t)))) :type :macro-function)) (t `(make-named-function ,name @@ -65,12 +69,13 @@ (block ,block-name (numargs-case (2 (&edx edx ,form-var ,env-var) + (declare (ignore , at ignore-env)) (verify-macroexpand-call edx ',name) (destructuring-bind ,destructuring-lambda-list ,form-var (declare (ignore , at ignore-operator) , at declarations) , at real-body)) (t (&edx edx &optional ,form-var ,env-var &rest ,extras) - (declare (ignore ,form-var ,extras)) + (declare (ignore ,form-var ,extras , at ignore-env)) (verify-macroexpand-call edx ',name t)))) :type :macro-function))))))) From ffjeld at common-lisp.net Sun Apr 27 19:40:25 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:40:25 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194025.CA5824084@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3529 Modified Files: environment.lisp Log Message: Trace and untrace macros. --- /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2008/04/21 19:39:24 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/environment.lisp 2008/04/27 19:40:25 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.17 2008/04/21 19:39:24 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.18 2008/04/27 19:40:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -108,6 +108,15 @@ wrapper))) (values)) +(defmacro trace (&rest names) + (if (null names) + `(mapcar #'car *trace-map*) + `(progn + ,@(mapcar (lambda (name) + `(do-trace ',name)) + names) + (values)))) + (defun do-untrace (name) (let ((map (assoc name *trace-map*))) (assert map () "~S is not traced." name) @@ -119,6 +128,16 @@ (delete name *trace-map* :key 'car)))) (values)) +(defmacro untrace (&rest names) + (if (null names) + '(do () ((null muerte::*trace-map*)) + (do-untrace (caar muerte::*trace-map*))) + `(progn + ,@(mapcar (lambda (name) + `(do-untrace ',name)) + names) + (values)))) + (defun time-skew-measure (mem x-lo x-hi) (declare (ignore mem)) (multiple-value-bind (y-lo y-hi) From ffjeld at common-lisp.net Sun Apr 27 19:41:18 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:41:18 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194118.17A087E0B7@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4943 Modified Files: integers.lisp Log Message: Improved /=. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/21 19:40:32 1.127 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2008/04/27 19:41:10 1.128 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.127 2008/04/21 19:40:32 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.128 2008/04/27 19:41:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -309,14 +309,23 @@ (define-number-relational /= /=%2op nil :defun-p nil) -(defun /= (&rest numbers) - (declare (dynamic-extent numbers)) - (do ((p (cdr numbers) (cdr p))) - ((null p) t) - (do ((v numbers (cdr v))) - ((eq p v)) - (when (= (car p) (car v)) - (return-from /= nil))))) +(defun /= (first-number &rest more-numbers) + (numargs-case + (1 (x) + (declare (ignore x)) + t) + (2 (x y) + (/=%2op x y)) + (t (first-number &rest more-numbers) + (declare (dynamic-extent more-numbers)) + (dolist (y more-numbers) + (when (= first-number y) + (return nil))) + (do ((p more-numbers (cdr p))) + ((null p) t) + (dolist (q (cdr p)) + (when (= (car p) q) + (return nil))))))) ;;;; From ffjeld at common-lisp.net Sun Apr 27 19:41:43 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:41:43 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194143.92DA04095@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5415 Modified Files: loop.lisp Log Message: Get loop working in run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp 2008/04/17 19:30:43 1.9 +++ /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp 2008/04/27 19:41:42 1.10 @@ -66,17 +66,17 @@ (provide :muerte/loop :load-priority 1) -#+movitz -(progn - (defmacro movitz-macroexpand (&rest args) - `(macroexpand , at args)) - (defmacro movitz-macroexpand-1 (&rest args) - `(macroexpand-1 , at args)) - (eval-when (:compile-toplevel) - (defmacro movitz-macroexpand (&rest args) - `(movitz::movitz-macroexpand , at args)) - (defmacro movitz-macroexpand-1 (&rest args) - `(movitz::movitz-macroexpand-1 , at args)))) +;; #+movitz +;; (progn +;; (defmacro movitz-macroexpand (&rest args) +;; `(macroexpand , at args)) +;; (defmacro movitz-macroexpand-1 (&rest args) +;; `(macroexpand-1 , at args)) +;; (eval-when (:compile-toplevel) +;; (defmacro movitz-macroexpand (&rest args) +;; `(movitz::movitz-macroexpand , at args)) +;; (defmacro movitz-macroexpand-1 (&rest args) +;; `(movitz::movitz-macroexpand-1 , at args)))) ;;;This is the "current" loop context in use when we are expanding a ;;;loop. It gets bound on each invocation of LOOP. @@ -271,48 +271,48 @@ (head-var tail-var &optional user-head-var) form) (declare #+LISPM (ignore head-var user-head-var)) ;use locatives, unconditionally update through the tail. - (setq form (movitz-macroexpand form env)) - (flet ((cdr-wrap (form n) - (declare (fixnum n)) - (do () ((<= n 4) (setq form `(,(case n - (1 'cdr) - (2 'cddr) - (3 'cdddr) - (4 'cddddr)) - ,form))) - (setq form `(cddddr ,form) n (- n 4))))) - (let ((tail-form form) (ncdrs nil)) - ;;Determine if the form being constructed is a list of known length. - (when (consp form) - (cond ((eq (car form) 'list) - (setq ncdrs (1- (length (cdr form)))) - ;;@@@@ Because the last element is going to be RPLACDed, - ;; we don't want the cdr-coded implementations to use - ;; cdr-nil at the end (which would just force copying - ;; the whole list again). - #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) - ((member (car form) '(list* cons)) - (when (and (cddr form) (member (car (last form)) '(nil 'nil))) - (setq ncdrs (- (length (cdr form)) 2)))))) - (let ((answer - (cond ((null ncdrs) - `(when (setf (cdr ,tail-var) ,tail-form) - (setq ,tail-var (last (cdr ,tail-var))))) - ((< ncdrs 0) (return-from loop-collect-rplacd nil)) - ((= ncdrs 0) - ;;@@@@ Here we have a choice of two idioms: - ;; (rplacd tail (setq tail tail-form)) - ;; (setq tail (setf (cdr tail) tail-form)). - ;;Genera and most others I have seen do better with the former. - `(rplacd ,tail-var (setq ,tail-var ,tail-form))) - (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) - ncdrs)))))) - ;;If not using locatives or something similar to update the user's - ;; head variable, we've got to set it... It's harmless to repeatedly set it - ;; unconditionally, and probably faster than checking. - #-LISPM (when user-head-var - (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) - answer)))) + (let ((form (movitz-macroexpand form env))) + (flet ((cdr-wrap (form n) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) + (let ((tail-form form) (ncdrs nil)) + ;;Determine if the form being constructed is a list of known length. + (when (consp form) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form)))) + ;;@@@@ Because the last element is going to be RPLACDed, + ;; we don't want the cdr-coded implementations to use + ;; cdr-nil at the end (which would just force copying + ;; the whole list again). + #+LISPM (setq tail-form `(list* ,@(cdr form) nil))) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) + (let ((answer + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;;@@@@ Here we have a choice of two idioms: + ;; (rplacd tail (setq tail tail-form)) + ;; (setq tail (setf (cdr tail) tail-form)). + ;;Genera and most others I have seen do better with the former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) + ncdrs)))))) + ;;If not using locatives or something similar to update the user's + ;; head variable, we've got to set it... It's harmless to repeatedly set it + ;; unconditionally, and probably faster than checking. + #-LISPM (when user-head-var + (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) + answer))))) (defmacro loop-collect-answer (head-var &optional user-head-var) From ffjeld at common-lisp.net Sun Apr 27 19:42:26 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:42:26 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194226.B05C73A023@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5697 Modified Files: los-closette-compiler.lisp Log Message: Remember to decode lambda formals. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp 2008/04/12 16:47:18 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette-compiler.lisp 2008/04/27 19:42:26 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.22 2008/04/12 16:47:18 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.23 2008/04/27 19:42:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1003,6 +1003,7 @@ (defun canonicalize-defgeneric-option (option) (case (car option) + (declare nil) (:generic-function-class (list ':generic-function-class `(movitz-find-class ',(cadr option)))) @@ -1507,7 +1508,7 @@ (defun compute-primary-emfun (methods) (if (null methods) nil - (let ((next-emfun (compute-primary-emfun (cdr methods)))) + (let ((next-emfun (compute-primary-emfun (cdr methods)))) '(lambda (args) (funcall (method-function (car methods)) args next-emfun))))) @@ -1526,8 +1527,10 @@ (let* ((block-name (compute-function-block-name name)) (analysis (analyze-lambda-list lambda-list)) (lambda-variables (append (getf analysis :required-args) - (getf analysis :optional-args) - (getf analysis :key-args) + (mapcar #'decode-optional-formal + (getf analysis :optional-args)) + (mapcar #'decode-keyword-formal + (getf analysis :key-args)) (when (getf analysis :rest-var) (list (getf analysis :rest-var))))) (required-variables (subseq lambda-variables From ffjeld at common-lisp.net Sun Apr 27 19:43:19 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:43:19 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194319.0816A671CD@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5879 Modified Files: more-macros.lisp Log Message: Add movitz-macroexpand/-1 as macros. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/19 12:44:40 1.45 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/04/27 19:43:18 1.46 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.45 2008/04/19 12:44:40 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.46 2008/04/27 19:43:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -580,4 +580,9 @@ (declare (ignore ignore)) 'compiler-macro name) - \ No newline at end of file + +(defmacro movitz-macroexpand (&rest args) + `(macroexpand , at args)) + +(defmacro movitz-macroexpand-1 (&rest args) + `(macroexpand-1 , at args)) From ffjeld at common-lisp.net Sun Apr 27 19:43:37 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:43:37 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194337.C232C240D3@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv5962 Modified Files: packages.lisp Log Message: Add package-used-by-list. --- /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/23 18:47:46 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/packages.lisp 2008/04/27 19:43:37 1.17 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.16 2008/04/23 18:47:46 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.17 2008/04/27 19:43:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -249,8 +249,32 @@ (apropos-symbol symbol string))))) (values)) +(defun package-used-by-list (package) + "Return a list of all packages that use package." + (let ((package (find-package package))) + (let ((used-by-list nil)) + (maphash (lambda (name other-package) + (declare (ignore name)) + (when (member package + (package-object-use-list other-package) + :test #'eq) + (pushnew other-package used-by-list))) + *packages*) + used-by-list))) + +(defun list-all-packages () + (with-hash-table-iterator (p *packages*) + (do (packages) (nil) + (multiple-value-bind (more k v) + (p) + (declare (ignore k)) + (when (not more) + (return packages)) + (push v packages))))) + + (defmacro with-package-iterator ((name package-list-form &rest symbol-types) &body body) `(macrolet ((,name () '(warn "with-package-iterator not implemented." (values nil nil nil nil)))) - , at body)) \ No newline at end of file + , at body)) From ffjeld at common-lisp.net Sun Apr 27 19:44:55 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:44:55 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194455.9168747186@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6179 Modified Files: sequences.lisp Log Message: Add various foo-if and foo-if-not operators. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/21 19:28:46 1.41 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/27 19:44:55 1.42 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.41 2008/04/21 19:28:46 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.42 2008/04/27 19:44:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1078,7 +1078,7 @@ (when (test item (key (car p))) (incf n))))))))))) -(defun count-if (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end) +(defun count-if (predicate sequence &key (start 0) end (key 'identity) from-end) (numargs-case (2 (predicate sequence) (with-funcallable (predicate) @@ -1098,7 +1098,9 @@ (when (predicate (sequence-ref i)) (incf count))) count)))))) - (t (predicate sequence &key (start 0) end (key 'identity) #+ignore from-end) + (t (predicate sequence &key (start 0) end (key 'identity) from-end) + (when from-end + (error "count-if from-end not implemented.")) (let ((start (check-the index start))) (with-funcallable (predicate) (with-funcallable (key) @@ -1122,6 +1124,32 @@ (vector (error "vector count-if not implemented."))))))))) +(defun count-if-not (predicate sequence &key (start 0) end (key 'identity) from-end) + (numargs-case + (2 (predicate sequence) + (with-funcallable (predicate) + (do-sequence-dispatch sequence + (list + (let ((count 0)) + (declare (index count)) + (dolist (x sequence) + (when (not (predicate x)) + (incf count))) + count)) + (vector + (with-subvector-accessor (sequence-ref sequence) + (let ((count 0)) + (declare (index count)) + (dotimes (i (length sequence)) + (when (not (predicate (sequence-ref i))) + (incf count))) + count)))))) + (t (predicate sequence &rest keys) + (apply #'count-if + (complement predicate) + sequence + keys)))) + (macrolet ((every-some-body () "This function body is shared between every and some." @@ -2009,6 +2037,10 @@ (return sequence))))) ((error 'program-error)))))))))) +(defun substitute-if-not (newitem predicate sequence &rest keyargs) + (declare (dynamic-extent keyargs)) + (apply #'substitute-if newitem (complement predicate) sequence keyargs)) + (defun nsubstitute-if-not (newitem predicate sequence &rest keyargs) (declare (dynamic-extent keyargs)) (apply #'nsubstitute-if newitem (complement predicate) sequence keyargs)) From ffjeld at common-lisp.net Sun Apr 27 19:45:34 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:45:34 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194534.08DC313017@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6366 Modified Files: strings.lisp Log Message: Fix bug in string> & friends. --- /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/21 19:43:30 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/strings.lisp 2008/04/27 19:45:33 1.6 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 17:05:25 2001 ;;;; -;;;; $Id: strings.lisp,v 1.5 2008/04/21 19:43:30 ffjeld Exp $ +;;;; $Id: strings.lisp,v 1.6 2008/04/27 19:45:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -52,7 +52,11 @@ (return nil))))) (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) - (not (string-equal string1 string2 :start1 start1 :end1 end1 :start2 start2 :end2 end2))) + (not (string-equal string1 string2 + :start1 start1 + :end1 end1 + :start2 start2 + :end2 end2))) (defun string (name) (typecase name @@ -104,25 +108,6 @@ (t (setf between-words-p (not (char-alpha-p c))) (char-downcase c)))))))) -(defun string%<= (string1 string2 result= start1 end1 start2 end2) - (let ((mismatch (mismatch string1 string2 - :start1 start1 - :end1 end1 - :start2 start2 - :end2 end2 - :test #'char=))) - (cond - ((not mismatch) - (when result= - (or end1 (length string1)))) - ((>= mismatch (or end1 (length string1))) - mismatch) - ((>= mismatch (or end2 (length string2))) - nil) - (t (when (char< (char string1 mismatch) - (char string2 mismatch)) - mismatch))))) - (defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2) "=> mismatch-index" (let ((mismatch (mismatch string1 string2 @@ -134,12 +119,14 @@ (cond ((not mismatch) nil) - ((>= mismatch (or end1 (length string1))) + ((>= mismatch + (or end1 (length string1))) mismatch) - ((>= mismatch (or end2 (length string2))) + ((>= (+ start2 mismatch) + (or end2 (length string2))) nil) (t (when (char< (char string1 mismatch) - (char string2 mismatch)) + (char string2 (+ start2 mismatch))) mismatch))))) (defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2) @@ -153,12 +140,14 @@ (cond ((not mismatch) (or end1 (length string1))) - ((>= mismatch (or end1 (length string1))) + ((>= mismatch + (or end1 (length string1))) mismatch) - ((>= mismatch (or end2 (length string2))) + ((>= (+ start2 mismatch) + (or end2 (length string2))) nil) (t (when (char<= (char string1 mismatch) - (char string2 mismatch)) + (char string2 (+ start2 mismatch))) mismatch))))) (defun string> (string1 string2 result= start1 end1 start2 end2) @@ -172,12 +161,14 @@ (cond ((not mismatch) nil) - ((>= mismatch (or end1 (length string1))) + ((>= mismatch + (or end1 (length string1))) mismatch) - ((>= mismatch (or end2 (length string2))) + ((>= (+ start2 mismatch) + (or end2 (length string2))) nil) (t (when (char> (char string1 mismatch) - (char string2 mismatch)) + (char string2 (+ start2 mismatch))) mismatch))))) (defun string>= (string1 string2 result= start1 end1 start2 end2) @@ -191,10 +182,12 @@ (cond ((not mismatch) (or end1 (length string1))) - ((>= mismatch (or end1 (length string1))) + ((>= mismatch + (or end1 (length string1))) mismatch) - ((>= mismatch (or end2 (length string2))) + ((>= (+ start2 mismatch) + (or end2 (length string2))) nil) (t (when (char>= (char string1 mismatch) - (char string2 mismatch)) + (char string2 (+ start2 mismatch))) mismatch))))) From ffjeld at common-lisp.net Sun Apr 27 19:45:43 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 27 Apr 2008 15:45:43 -0400 (EDT) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080427194543.2E2353700E@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6432 Modified Files: typep.lisp Log Message: Add bit-vector-p. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/21 19:43:57 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/04/27 19:45:43 1.60 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.59 2008/04/21 19:43:57 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.60 2008/04/27 19:45:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -601,6 +601,8 @@ (or (eq xdim '*) (eql xdim adim))) dimension-spec (array-dimensions x))))))) +(defun bit-vector-p (x) + (typep x 'bit-vector)) (defun arrayp (x) (typep x 'array))