movitz-cvs April 2008

movitz-cvs@common-lisp.net

1 participants
115 discussions

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

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 ,@ignore-env)) - ,docstring - (block ,block-name - (verify-macroexpand-call edx ',name) - (let ((,(second whole-var) ,form-var)) - (declare ,@declarations) - ,@real-body)) - :type :macro-function)) - (t `(make-named-function ,name - (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) - ((ignore ,ignore-var ,@ignore-env)) - ,docstring - (block ,block-name - (verify-macroexpand-call edx ',name) - (destructuring-bind ,(append whole-var destructuring-lambda-list) - ,form-var - (declare (ignore ,operator-var) ,@declarations) - ,@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 ,@ignore-env)) + ,docstring + (block ,block-name + (numargs-case + (2 (&edx edx &optional ,form-var ,env-var) + (verify-macroexpand-call edx ',name) + (let () + (declare ,@declarations) + ,@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 ,@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 ,@ignore-operator) ,@declarations) + ,@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)))))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

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 <frodef(a)acm.org> ;;;; 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) ())

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

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)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

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 <frodef(a)acm.org> ;;;; 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)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

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 <frodef(a)acm.org> ;;;; 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)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

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 <frodef(a)acm.org> ;;;; 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)) ,@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)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 21 Apr '08

21 Apr '08

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 <frodef(a)acm.org> ;;;; 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) ,@forms0) (progn ,@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 ,@args) + ,',notter))) + ,@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]

1 0

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

19 Apr '08

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 <frodef(a)acm.org> ;;;; 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)

1 0

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

19 Apr '08

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 <frodef(a)acm.org> ;;;; 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))

1 0

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

19 Apr '08

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 <frodef(a)acm.org> ;;;; 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))

1 0

← Newer
1
2
3
4
5
6
7
8
9
...
12
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs April 2008