March 2004 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23234 Modified Files: symbols.lisp Log Message: A small change in strategy for allocating memory. Date: Mon Mar 22 11:38:20 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.2 movitz/losp/muerte/symbols.lisp:1.3 --- movitz/losp/muerte/symbols.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/symbols.lisp Mon Mar 22 11:38:20 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.3 2004/03/22 16:38:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -120,8 +120,20 @@ (not (eq (movitz-accessor symbol movitz-symbol function-value) (load-global-constant movitz::unbound-function)))))) +(defun %other-to-symbol (x) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:leal (:eax 2) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Not an other heap-object: ~S" x)) + (:jmp 'continue))) + continue + (:addl 1 :eax))) + (defun make-symbol (name) - (let ((symbol (inline-malloc #.(bt:sizeof 'movitz::movitz-symbol) :tag :symbol))) + (let ((symbol (%other-to-symbol (malloc-clumps 3)))) (setf-movitz-accessor (symbol movitz-symbol package) nil) (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name)) (setf (symbol-flags symbol) 0

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20992 Modified Files: los-closette.lisp Log Message: A small change in strategy for allocating memory. Date: Mon Mar 22 11:38:10 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.5 movitz/losp/muerte/los-closette.lisp:1.6 --- movitz/losp/muerte/los-closette.lisp:1.5 Thu Feb 26 06:40:44 2004 +++ movitz/losp/muerte/los-closette.lisp Mon Mar 22 11:38:10 2004 @@ -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.5 2004/02/26 11:40:44 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.6 2004/03/22 16:38:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -119,7 +119,7 @@ (defun allocate-std-instance (class slots) - (let ((instance (inline-malloc #.(bt:sizeof 'movitz:movitz-std-instance) :tag :other))) + (let ((instance (malloc-clumps 2))) (setf (memref instance #.(bt:slot-offset 'movitz:movitz-struct 'movitz:type) 0 :unsigned-byte8) #.(movitz:tag :std-instance)) @@ -1137,9 +1137,7 @@ (check-type class structure-class) (let* ((slots (structure-slots class)) (num-slots (length slots)) - (struct (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-struct) - (* 4 num-slots) - (if (evenp num-slots) 0 1))))) + (struct (malloc-words num-slots))) (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name) 0 :lisp) (class-name class))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20180 Modified Files: functions.lisp Log Message: A small change in strategy for allocating memory. Date: Mon Mar 22 11:38:05 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.2 movitz/losp/muerte/functions.lisp:1.3 --- movitz/losp/muerte/functions.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/functions.lisp Mon Mar 22 11:38:05 2004 @@ -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.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.3 2004/03/22 16:38:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -265,12 +265,16 @@ (defun funobj-num-jumpers (funobj) (check-type funobj compiled-function) - (movitz-accessor-u16 funobj movitz-funobj num-jumpers)) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) funobj) + (:movzxw (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers)) :eax))) (defun (setf funobj-num-jumpers) (num-jumpers funobj) (check-type funobj compiled-function) - (check-type num-jumpers (unsigned-byte 16)) - (set-movitz-accessor-u16 funobj movitz-funobj num-jumpers num-jumpers)) + (check-type num-jumpers (unsigned-byte 14)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) num-jumpers funobj) + (:movw :ax (:ebx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers))))) (defun funobj-constant-ref (funobj index) (check-type funobj compiled-function) @@ -333,9 +337,10 @@ (make-array (length code-vector) :element-type 'u8 :initial-contents code-vector)))) - (let ((funobj (inline-malloc (+ #.(bt:sizeof 'movitz:movitz-funobj) - (* 4 (length constants))) - :other-tag :funobj))) + (let ((funobj (malloc-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4) + (length constants))))) + (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16) + #.(movitz:tag :funobj)) (setf (funobj-name funobj) name (funobj-code-vector funobj) code-vector ;; revert to default trampolines for now.. @@ -376,9 +381,10 @@ (defun copy-funobj (old-funobj &optional (name (funobj-name old-funobj))) (let* ((num-constants (funobj-num-constants old-funobj)) - (funobj (inline-malloc (+ #.(bt:sizeof 'movitz:movitz-funobj) - (* 4 num-constants)) - :other-tag :funobj))) + (funobj (malloc-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4) + num-constants)))) + (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16) + (memref old-funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16)) (setf (funobj-num-constants funobj) num-constants) (replace-funobj funobj old-funobj name)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16417 Modified Files: defstruct.lisp Log Message: A small change in strategy for allocating memory. Date: Mon Mar 22 11:37:59 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.2 movitz/losp/muerte/defstruct.lisp:1.3 --- movitz/losp/muerte/defstruct.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/defstruct.lisp Mon Mar 22 11:37:59 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.3 2004/03/22 16:37:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -212,8 +212,7 @@ if (and constructor (symbolp constructor)) collect `(defun ,constructor (&key ,@key-lambda) - (let ((s (inline-malloc ,(logand -8 (+ #.(bt:sizeof 'movitz::movitz-struct) - (* 4 (1+ (length slot-names)))))))) + (let ((s (malloc-words ,(length slot-names)))) (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name) 0 :lisp) ',struct-name) @@ -235,8 +234,7 @@ (boa-lambda-list (cdr constructor)) (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list))) `(defun ,boa-constructor ,boa-lambda-list - (let ((s (inline-malloc ,(logand -8 (+ #.(bt:sizeof 'movitz::movitz-struct) - (* 4 (1+ (length slot-names)))))))) + (let ((s (malloc-words ,(length slot-names)))) (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name) 0 :lisp) ',struct-name)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16227 Modified Files: basic-functions.lisp Log Message: A small change in strategy for allocating memory. Date: Mon Mar 22 11:37:51 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.3 movitz/losp/muerte/basic-functions.lisp:1.4 --- movitz/losp/muerte/basic-functions.lisp:1.3 Thu Feb 26 08:44:29 2004 +++ movitz/losp/muerte/basic-functions.lisp Mon Mar 22 11:37:51 2004 @@ -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.3 2004/02/26 13:44:29 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.4 2004/03/22 16:37:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -342,3 +342,17 @@ (defun halt-cpu () (halt-cpu)) + +(defun malloc-words (words) + (malloc-clumps (1+ (truncate (1+ words) 2)))) + +(defun malloc-clumps (clumps) + (let ((x (with-inline-assembly (:returns :eax :side-effects t) + (:compile-form (:result-mode :ebx) clumps) + (:shll 1 :ebx) + (:globally (:call (:edi (:edi-offset malloc)))) + (:addl #.(movitz::tag :other) :eax)))) + (dotimes (i clumps) + (setf (memref x -6 i :lisp) nil + (memref x -2 i :lisp) nil)) + x))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16065 Modified Files: arrays.lisp Log Message: A small change in strategy for allocating memory. Date: Mon Mar 22 11:37:47 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.6 movitz/losp/muerte/arrays.lisp:1.7 --- movitz/losp/muerte/arrays.lisp:1.6 Thu Mar 18 04:19:45 2004 +++ movitz/losp/muerte/arrays.lisp Mon Mar 22 11:37:47 2004 @@ -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.6 2004/03/18 09:19:45 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.7 2004/03/22 16:37:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -549,19 +549,26 @@ (initial-contents (replace a initial-contents))) a)) - (t (let ((a (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) (* 4 dimensions)) - :other-tag :vector - :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type - :any-t)))) - (setf (memref a #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) + (t (let ((array (malloc-words dimensions) + #+ignore + (inline-malloc (+ #.(bt:sizeof 'movitz::movitz-vector) (* 4 dimensions)) + :other-tag :vector + :wide-other-tag #.(bt:enum-value 'movitz::movitz-vector-element-type + :any-t)))) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type) + 0 :unsigned-byte16) + #.(movitz:vector-type-tag :any-t)) + (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements) 0 :unsigned-byte16) dimensions) - (setf (fill-pointer a) fill-pointer) - (if initial-contents - (replace a initial-contents) + (setf (fill-pointer array) fill-pointer) + (cond + (initial-contents + (replace array initial-contents)) + (initial-element (dotimes (i dimensions) - (setf (svref%unsafe a i) initial-element))) - a)))))) + (setf (svref%unsafe array i) initial-element)))) + array)))))) (defun vector (&rest objects) "=> vector"

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16332 Modified Files: cons.lisp Log Message: Removed some dead code. Date: Mon Mar 22 09:42:32 2004 Author: ffjeld Index: movitz/losp/muerte/cons.lisp diff -u movitz/losp/muerte/cons.lisp:1.2 movitz/losp/muerte/cons.lisp:1.3 --- movitz/losp/muerte/cons.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/cons.lisp Mon Mar 22 09:42:31 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.3 2004/03/22 14:42:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -215,10 +215,3 @@ (:compile-form (:result-mode :eax) car) (:compile-form (:result-mode :ebx) cdr) (:call-global-constant fast-cons))) - -#+ignore -(defun cons (car cdr) - (let ((cell (inline-malloc 8 :tag :cons))) - (setf (car cell) car - (cdr cell) cdr) - cell))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3394 Modified Files: print.lisp Log Message: Fixed :gensym argument to write. Date: Mon Mar 22 09:38:13 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.2 movitz/losp/muerte/print.lisp:1.3 --- movitz/losp/muerte/print.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/print.lisp Mon Mar 22 09:38:13 2004 @@ -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.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.3 2004/03/22 14:38:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -150,7 +150,7 @@ (defun write (object &key stream case circle (array *print-array*) (base *print-base*) ((:escape *print-escape*) *print-escape*) - ((:gensym *print-gensym*) *print-readably*) + ((:gensym *print-gensym*) *print-gensym*) (length *print-length*) (level *print-level*) lines miser-width pprint-dispatch (pretty *print-pretty*) (radix *print-radix*)

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by Frode Vatvedt Fjeld 22 Mar '04

22 Mar '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv24697 Modified Files: los0.lisp Log Message: Bind *, **, etc. around the top-level REPL. Also several minor edits. Date: Mon Mar 22 04:49:11 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.3 movitz/losp/los0.lisp:1.4 --- movitz/losp/los0.lisp:1.3 Tue Feb 10 18:38:20 2004 +++ movitz/losp/los0.lisp Mon Mar 22 04:49:11 2004 @@ -9,17 +9,18 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.3 2004/02/10 23:38:20 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.4 2004/03/22 09:49:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :los0 :load-priority 0) (require :common-lisp) +(require :x86-pc/interrupt) (require :x86-pc/all) (require :x86-pc/io-space) (require :x86-pc/ne2k) -;; (require :x86-pc/floppy) +(require :x86-pc/floppy) (require :lib/readline) (require :lib/toplevel) @@ -28,7 +29,10 @@ (require :lib/repl) (defpackage muerte.init - (:use muerte.cl muerte muerte.lib muerte.x86-pc muerte.readline muerte.toplevel + (:use muerte.cl muerte muerte.lib + muerte.x86-pc + muerte.readline + muerte.toplevel muerte.ethernet muerte.ip6 muerte.ip4 @@ -225,9 +229,10 @@ (format t "~&test-funcall args: ~S~%" args)) #+ignore -(defun test-rest (&optional a0 a1 a3 &rest args) +(defun test-rest (&optional (a0 nil a0-p) a1 a3 &rest args) (declare (dynamic-extent args)) - (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args)) + (when a0-p + (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args))) (defun test-return () @@ -316,8 +321,10 @@ (print 'hello))) #+ignore -(defun sloo (x y) - 'sllooo) +(defun sloo (&rest x) + (declare (dynamic-extent x)) + (let ((y (car x))) + (sloo y))) #+ignore (defun test-throw (tag) @@ -343,7 +350,11 @@ (defun test-up (tag) (unwind-protect (test-throw tag) - (print 'hello-cleanup))) + (print 'hello-cleanup))) + +(defun test-cons (x) + (let ((c (cons x x))) + (cdr c))) (defun test-fixed (x y z) (warn "x: ~W, y: ~W, z: ~W" x y z)) @@ -469,6 +480,17 @@ (return-from dingu 'fooob)) (+ x y)) + +(defun foo (&edx edx x &optional (y nil yp)) + (format t "~@{ ~A~}" x y yp edx)) + +(defun wefwe (&rest args) + (declare (dynamic-extent args)) + (do ((p args (cdr p))) + ((endp p)) + (let ((x (car p))) + (print x)))) + ;;;;; (defclass food () ()) @@ -487,53 +509,62 @@ (declare (ignore f)) (print "Cooking some food.")) -(defun foo (x &optional (y nil yp)) - (format t "~@{ ~A~}" yp)) - (defun test-pie (n pie) (dotimes (i n) (pie-filling pie))) +(defun test-inc (n) + (dotimes (i n) + (warn "foo: ~S" (lambda () + (setf i 5))))) + +(defun test-id (n x) + (dotimes (i n) + (identity x))) + +(defun test-inc2 (x) + (print (prog1 x (incf x))) + (print x)) + (defclass pie (food) ((filling :accessor pie-filling :initarg :filling :initform 'apple)) #+ignore (:default-initargs :filling (if (foo) 'apple 'banana))) -#+ignore (defclass pie2 (food) ((filling :accessor pie-filling :initarg :filling :initform nil))) -;;;(defmethod cook ((p (eql 'pie))) -;;; (warn "Won't really cook a symbolic pie!") -;;; (values)) -;;; -;;;(defmethod cook ((p (eql 'pudding))) -;;; 'cooked-pudding) - -;;;(defmethod slot-value-using-class :after (class (pie pie2) slot) -;;; (warn "HEy, don't poke inside my pie2!")) - -;;;(defmethod cook :after ((p symbol)) -;;; (warn "A symbol may or may not have been cooked.")) - -;;;(defmethod cook ((p pie)) -;;; (cond -;;; ((eq 'banana (pie-filling p)) -;;; (print "Won't cook a banana-pie, trying next.") -;;; (call-next-method)) -;;; (t (print "Cooking a pie.") -;;; (setf (pie-filling p) (list 'cooked (pie-filling p)))))) - -;;;(defmethod cook :before ((p pie)) -;;; (declare (ignore p)) -;;; (print "A pie is about to be cooked.")) -;;; -;;;(defmethod cook :after ((p pie)) -;;; (declare (ignore p)) -;;; (print "A pie has been cooked.")) +(defmethod cook ((p (eql 'pie))) + (warn "Won't really cook a symbolic pie!") + (values)) + +(defmethod cook ((p (eql 'pudding))) + 'cooked-pudding) + +(defmethod slot-value-using-class :after (class (pie pie2) slot) + (warn "HEy, don't poke inside my pie2!")) + +(defmethod cook :after ((p symbol)) + (warn "A symbol may or may not have been cooked.")) + +(defmethod cook ((p pie)) + (cond + ((eq 'banana (pie-filling p)) + (print "Won't cook a banana-pie, trying next.") + (call-next-method)) + (t (print "Cooking a pie.") + (setf (pie-filling p) (list 'cooked (pie-filling p)))))) + +(defmethod cook :before ((p pie)) + (declare (ignore p)) + (print "A pie is about to be cooked.")) + +(defmethod cook :after ((p pie)) + (declare (ignore p)) + (print "A pie has been cooked.")) (defun assess-cpu-frequency () "Assess the CPU's frequency in units of 1024 Hz." @@ -828,10 +859,13 @@ *standard-input* s *terminal-io* s *debug-io* s))) - (loop - (catch 'top-level-repl ; If restarts don't work, you can throw this.. - (with-simple-restart (abort "Abort to the top command level.") - (read-eval-print))))) + (let ((* nil) (** nil) (*** nil) + (/ nil) (// nil) (/// nil) + (+ nil) (++ nil) (+++ nil)) + (loop + (catch :top-level-repl ; If restarts don't work, you can throw this.. + (with-simple-restart (abort "Abort to the top command level.") + (read-eval-print)))))) (error "What's up? [~S]" 'hey)) @@ -884,6 +918,7 @@ ,(when error-spec `(error ,@error-spec)))) +#+ignore (defun bridge (&optional (inside (do-default (*inside* "No inside NIC.") (muerte.x86-pc.ne2k:ne2k-probe #x300))) (outside (do-default (*outside* "No outside NIC.")

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 19 Mar '04

19 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24680 Modified Files: storage-types.lisp Log Message: Some not-too-big changes of certain symbolic constants in preparation of supporting GC scanning. Date: Fri Mar 19 05:49:40 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.10 movitz/storage-types.lisp:1.11 --- movitz/storage-types.lisp:1.10 Thu Mar 18 04:16:38 2004 +++ movitz/storage-types.lisp Fri Mar 19 05:49:39 2004 @@ -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.10 2004/03/18 09:16:38 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.11 2004/03/19 10:49:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -67,13 +67,13 @@ :other 6 :symbol 7 - :vector #x08 - :defstruct #x09 - :funobj #x10 - :std-instance #x14 - :run-time-context #x15 + :vector #x10 + :defstruct #x20 + :funobj #x30 + :std-instance #x40 + :run-time-context #x50 - :simple-vector #x20 + ;; :simple-vector #x20 ;; :character-vector :basic-restart #x32 @@ -326,9 +326,9 @@ :initarg :flags :initform nil :binary-type (define-bitfield movitz-vector-flags (u8) - (((:bits) :fill-pointer-p 0 - :code-vector-p 1 - :std-instance-slots-p 2)))) + (((:bits) :fill-pointer-p 2 + :code-vector-p 3 + :std-instance-slots-p 4)))) (alignment-power :binary-lisp-type u8 ; align to 2^(high-nibble+3) + low-nibble :initform 0 @@ -585,18 +585,18 @@ :map-binary-read-delayed 'movitz-word :initform *movitz-nil* :accessor movitz-symbol-package) - (hash-key - :binary-lisp-type lu16 - :reader movitz-symbol-hash-key - :initarg :hash-key) (flags :binary-type (define-bitfield movitz-symbol-flags (lu16) (((:bits) - :special-variable 0 - :constant-variable 1 - :setf-placeholder 4))) + :special-variable 3 + :constant-variable 4 + :setf-placeholder 5))) :accessor movitz-symbol-flags :initform nil) + (hash-key + :binary-lisp-type lu16 + :reader movitz-symbol-hash-key + :initarg :hash-key) (lisp-symbol :initform nil :initarg :lisp-symbol)) @@ -793,10 +793,18 @@ :accessor movitz-funobj-name :initarg :name) (num-jumpers ; how many of the first constants are jumpers. - :binary-type lu16 - :initform 0 + :binary-type lu16 ; 14 bits, the lower 16 bits of a fixnum. + :initform 0 ; This, in order to see this as a fixnum while + :accessor movitz-funobj-num-jumpers ; GC scanning. :initarg :num-jumpers - :accessor movitz-funobj-num-jumpers) + :map-binary-write (lambda (x &optional type) + (declare (ignore type)) + (check-type x (unsigned-byte 14)) + (* x +movitz-fixnum-factor+)) + :map-binary-read (lambda (x &optional type) + (declare (ignore type)) + (assert (zerop (ldb (byte 2 0) x))) + (/ x +movitz-fixnum-factor+))) (num-constants :binary-type lu16 :initform 0 @@ -932,8 +940,13 @@ (num-jumpers :binary-type lu16 :initform 0 - :initarg :num-constants - :accessor movitz-funobj-num-jumpers) + :accessor movitz-funobj-num-jumpers + :map-binary-write (lambda (x &optional type) + (declare (ignore typE)) + (* x +movitz-fixnum-factor+)) + :map-binary-read (lambda (x &optional type) + (declare (ignore typE)) + (/ x +movitz-fixnum-factor+))) (num-constants :binary-type lu16 :initform (/ (- (sizeof 'movitz-funobj-standard-gf)

1 0