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

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

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

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

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

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

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-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."

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-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 <frodef(a)acm.org> ;;;; 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 ,@lambda-list) - ',form - (declare (ignore ignore-operator)) - ,@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 ,@ignore-env)) + (destructuring-bind ,destructuring-lambda-list + ,form-var + (declare (ignore ,@ignore-operator) + ,@declarations) + ,@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)

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

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

1 0

← Newer
1
2
3
4
5
6
7
8
...
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