movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24399 Modified Files: hash-tables.lisp Log Message: Support equalp hashing. --- /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp 2005/08/26 19:38:50 1.11 +++ /project/movitz/cvsroot/movitz/losp/muerte/hash-tables.lisp 2006/04/07 21:52:36 1.12 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.11 2005/08/26 19:38:50 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.12 2006/04/07 21:52:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,7 +42,8 @@ test) (eq (values #'eq #'sxhash-eq)) (eql (values #'eql #'sxhash-eql)) - (equal (values #'equal #'sxhash))) + (equal (values #'equal #'sxhash)) + (equalp (values #'equalp #'sxhash))) (make-hash-table-object :test test :bucket (make-array (* 2 size) :initial-element '--no-hash-key--)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24361 Modified Files: functions.lisp Log Message: Smart up complement somewhat. --- /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp 2005/04/20 06:53:28 1.29 +++ /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp 2006/04/07 21:52:17 1.30 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.29 2005/04/20 06:53:28 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.30 2006/04/07 21:52:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,22 +60,15 @@ (declare (dynamic-extent args)) (not (apply 'function args))) -(define-compiler-macro complement (&whole form function-form) +(define-compiler-macro complement (&whole form function-form &environment env) (cond - ((movitz:movitz-constantp function-form) - (let ((function (movitz:movitz-eval function-form))) - `(make-prototyped-function (complement ,function) - complement-prototype - (function ,function)))) ((and (listp function-form) (eq 'function (first function-form)) - (symbolp (second function-form)) - (typep (movitz:movitz-eval (translate-program function-form :cl :muerte.cl)) + (typep (movitz:movitz-eval (translate-program function-form :cl :muerte.cl) env) 'movitz:movitz-funobj)) - `(make-prototyped-function (complement ,function-form) + `(make-prototyped-function `(complement ,(second function-form)) complement-prototype - (function ,(movitz:movitz-eval (translate-program function-form - :cl :muerte.cl))))) + ,(movitz:movitz-eval (translate-program function-form :cl :muerte.cl)))) (t form))) (defun complement (function)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24315 Modified Files: conditions.lisp Log Message: Add style-warning condition. --- /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2005/08/11 21:34:26 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/conditions.lisp 2006/04/07 21:51:53 1.18 @@ -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.17 2005/08/11 21:34:26 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.18 2006/04/07 21:51:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,6 +63,7 @@ (define-condition serious-condition () ()) (define-condition error (serious-condition) ()) (define-condition warning () ()) +(define-condition style-warning () ()) (define-condition simple-error (simple-condition error) ()) (define-condition simple-warning (simple-condition warning) ()) @@ -282,7 +283,10 @@ ((not *debugger-function*) (let ((*never-use-print-object* t)) (backtrace :spartan t)) - (format t "~&No debugger in *debugger-function*. Trying to continue or abort.") + (format t "~&No debugger in *debugger-function*...") + (dotimes (i 100000) + (write-string "")) + (format t "Trying to continue or abort.") (invoke-restart (or (find-restart 'continue) (find-restart 'abort) (format t "~%Condition for debugger: ~Z" condition)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24273 Modified Files: read.lisp Log Message: Added *readtable* variable and copy-readtable mockup. --- /project/movitz/cvsroot/movitz/losp/muerte/read.lisp 2005/08/26 19:38:35 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/read.lisp 2006/04/07 21:50:37 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Oct 17 21:50:42 2001 ;;;; -;;;; $Id: read.lisp,v 1.13 2005/08/26 19:38:35 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.14 2006/04/07 21:50:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,7 +20,11 @@ (in-package muerte) (defvar *read-suppress*) -(defvar *readtable*) +(defvar *readtable* nil) + +(defun copy-readtable (&optional from-readtable to-readtable) + (declare (ignore from-readtable to-readtable)) + nil) (defun substring (string start end) (if (and (zerop start) (= end (length string)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24161 Modified Files: setf.lisp Log Message: Sort of implemented defsetf short form. --- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2004/02/18 14:38:14 1.3 +++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2006/04/07 21:49:47 1.4 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Feb 8 20:43:20 2001 ;;;; -;;;; $Id: setf.lisp,v 1.3 2004/02/18 14:38:14 ffjeld Exp $ +;;;; $Id: setf.lisp,v 1.4 2006/04/07 21:49:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -86,45 +86,54 @@ ;;; `(subseq ,tmp-sequence ,tmp-start ,tmp-end))))) (defmacro defsetf (access-fn &rest more-args) - ;; long form - (destructuring-bind (lambda-list store-variables &body body) - more-args - (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl))) - (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes) - (movitz::decode-macro-lambda-list movitz-lambda) - (assert (null restvar)) - (assert (null envvars)) - (assert (null wholevars)) - (assert (null auxes)) - (assert (null keys)) - (let* ((req-tmps (mapcar (lambda (x) (list x (gensym))) - reqvars)) - (opt-vars (mapcar #'movitz::decode-optional-formal - optionalvars)) - (opt-tmps (mapcar (lambda (x) (list x (gensym))) - opt-vars)) - (tmp-lets (append (mapcar (lambda (rt) - (list (second rt) '(gensym))) - req-tmps) - (mapcar (lambda (rt) - (list (second rt) '(gensym))) - opt-tmps) - `((init-form (list ,@reqvars ,@opt-vars))) - (mapcar (lambda (rt) - (list rt '(gensym))) - store-variables))) - (lambda-lets (append req-tmps opt-tmps))) - `(define-setf-expander ,access-fn ,movitz-lambda - (let ,tmp-lets - (let ,lambda-lets - (values (list ,@(mapcar #'second req-tmps) - ,@(mapcar #'second opt-tmps)) - init-form - (list ,@store-variables) - (progn ,@body) - (list ',access-fn - ,@(mapcar #'first req-tmps) - ,@(mapcar #'first opt-tmps))))))))))) + (cond + ((symbolp (first more-args)) + ;; short form XXX not really good. + `(defun (setf ,access-fn) (fu foo) + (,(first more-args) fu foo))) + (t ;; long form + (destructuring-bind (lambda-list store-variables &body body-decl-docstring) + more-args + (multiple-value-bind (body declarations docstring) + (movitz::parse-docstring-declarations-and-body body-decl-docstring 'cl:declare) + (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl))) + (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes) + (movitz::decode-macro-lambda-list movitz-lambda) + (assert (null restvar)) + (assert (null envvars)) + (assert (null wholevars)) + (assert (null auxes)) + (assert (null keys)) + (let* ((req-tmps (mapcar (lambda (x) (list x (gensym))) + reqvars)) + (opt-vars (mapcar #'movitz::decode-optional-formal + optionalvars)) + (opt-tmps (mapcar (lambda (x) (list x (gensym))) + opt-vars)) + (tmp-lets (append (mapcar (lambda (rt) + (list (second rt) '(gensym))) + req-tmps) + (mapcar (lambda (rt) + (list (second rt) '(gensym))) + opt-tmps) + `((init-form (list ,@reqvars ,@opt-vars))) + (mapcar (lambda (rt) + (list rt '(gensym))) + store-variables))) + (lambda-lets (append req-tmps opt-tmps))) + `(define-setf-expander ,access-fn ,movitz-lambda + (declare ,@declarations) + ,@(when docstring (list docstring)) + (let ,tmp-lets + (let ,lambda-lets + (values (list ,@(mapcar #'second req-tmps) + ,@(mapcar #'second opt-tmps)) + init-form + (list ,@store-variables) + (progn ,@body) + (list ',access-fn + ,@(mapcar #'first req-tmps) + ,@(mapcar #'first opt-tmps)))))))))))))) (defmacro define-modify-macro (name lambda-list function &optional documentation)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24108 Added Files: subtypep.lisp Log Message: Added very primitive subtypep. --- /project/movitz/cvsroot/movitz/losp/muerte/subtypep.lisp 2006/04/07 21:48:43 NONE +++ /project/movitz/cvsroot/movitz/losp/muerte/subtypep.lisp 2006/04/07 21:48:43 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Copyright (C) 2006, ;; Department of Computer Science, University of Tromso, Norway. ;; ;; For distribution policy, see the accompanying file COPYING. ;; ;; Filename: subtypep.lisp ;; Description: ;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;; Created at: Sun Apr 2 20:47:11 2006 ;; ;; $Id: subtypep.lisp,v 1.1 2006/04/07 21:48:43 ffjeld Exp $ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require :muerte/basic-macros) (provide :muerte/subtypep) (in-package muerte) (defun subtypep (type-1 type-2 &optional environment) "Is type-1 a subtype of type-2? => subtype-p, valid-p" (let ((class-1 (find-class type-1 nil environment)) (class-2 (find-class type-2 nil environment))) (cond ((and class-1 class-2) (values (subclassp class-1 class-2) t)) (class-2 (dolist (c (class-precedence-list class-2) (values nil nil)) (when (member type-1 (getf (class-plist c) :subtypes)) (return (values t t))))) (t (values nil nil)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24089 Modified Files: common-lisp.lisp Log Message: Added very primitive subtypep. --- /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2005/05/03 20:08:14 1.13 +++ /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2006/04/07 21:48:41 1.14 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.13 2005/05/03 20:08:14 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.14 2006/04/07 21:48:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -52,6 +52,7 @@ (require :muerte/interrupt) (require :muerte/scavenge) (require :muerte/simple-streams) +(require :muerte/subtypep) (require :muerte/io-port) (require :muerte/cpu-id)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24041 Modified Files: arrays.lisp Log Message: Improve upgraded-array-element-type slightly. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2005/08/24 07:27:47 1.56 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/04/07 21:47:44 1.57 @@ -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.56 2005/08/24 07:27:47 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.57 2006/04/07 21:47:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -105,17 +105,19 @@ (let* ((q (cdr type-specifier)) (min (if q (pop q) '*)) (max (if q (pop q) '*))) - (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))))) + (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

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21957 Modified Files: integers.lisp Log Message: Added trivial versions of realpart, imagpart, and rational. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/03/31 20:57:48 1.120 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/04/07 21:35:32 1.121 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.120 2006/03/31 20:57:48 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.121 2006/04/07 21:35:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2250,3 +2250,13 @@ (defun floatp (x) (declare (ignore x)) nil) + +(defun realpart (number) + number) + +(defun imagpart (number) + (declare (ignore number)) + 0) + +(defun rational (number) + number)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '06

07 Apr '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv21830 Modified Files: cons.lisp Log Message: Added acons. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2005/06/12 21:27:03 1.11 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/04/07 21:33:54 1.12 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.11 2005/06/12 21:27:03 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.12 2006/04/07 21:33:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -271,3 +271,7 @@ (and (te (car tree-1) (car tree-2) test) (te (cdr tree-1) (cdr tree-2) test)))))) (te tree-1 tree-2 (or test (and test-not (complement test-not)) #'eql)))) + +(defun acons (key datum alist) + "=> new-alist" + (cons (cons key datum) alist))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs