April 2007 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 28 Apr '07

28 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv23233 Added Files: pcnet.lisp Log Message: The beginnings of a pcnet driver. --- /project/movitz/cvsroot/movitz/losp/x86-pc/pcnet.lisp 2007/04/28 16:29:18 NONE +++ /project/movitz/cvsroot/movitz/losp/x86-pc/pcnet.lisp 2007/04/28 16:29:18 1.1 ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2003, 2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: pcnet.lisp ;;;; Description: ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 12 23:39:20 2005 ;;;; ;;;; $Id: pcnet.lisp,v 1.1 2007/04/28 16:29:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :x86-pc/pcnet) (in-package muerte.x86-pc) (defmacro select (keyform &rest clauses) (let* ((select-var (gensym "select-key-")) (cc (loop for (key . consequents) in clauses collecting (cond ((member key '(t otherwise)) (cons t consequents)) (t (cons `(eql ,key ,select-var) consequents)))))) `(let ((,select-var ,keyform)) (cond ,@cc)))) (defmacro $am7990 (reg &optional sub-reg) (or (cond ((integerp reg) reg) ((not sub-reg) (case reg (:csr0 0) (:csr1 1) (:csr2 2) (:csr3 3) (:csr88 88) (:csr89 89) (:bcr49 49) (:bcr32 32) (:bcr33 33) (bcr34 34))) (t (if (integerp sub-reg) sub-reg (case reg (:csr0 (case sub-reg (:err #x8000) (:babl #x4000) (:cerr #x2000) (:miss #x1000) (:merr #x0800) (:rint #x0400) (:tint #x0200) (:idon #x0100) (:intr #x0080) (:inea #x0040) (:rxon #x0020) (:txon #x0010) (:tdmd #x0008) (:stop #x0004) (:strt #x0002) (:init #x0001))) (:csr88 (case sub-reg (:AMD-MASK #x003) (:PART-MASK #xffff) (:|Am79C960| #x0003) (:|Am79C961| #x2260) (:|Am79C961A| #x2261) (:|Am79C965| #x2430) (:|Am79C970| #x0242) (:|Am79C970A| #x2621) (:|Am79C971| #x2623) (:|Am79C972| #x2624) (:|Am79C973| #x2625) (:|Am79C978| #x2626) )))))) (error "Unknown Am7990 register: ~S~@[ ~S~]" reg sub-reg))) (defmacro $pcnet (reg) "PCNet is one Am7990 implementation." (or (cond ((integerp reg) reg) (t (case reg (:rdp #x10) (:rap #x12) (:reset #x14) (:bdp #x16) (:vsw #x18)))) `($am7990 ,reg))) (defmacro with-am7990 ((name io-base regdef) &body body) (let ((pcnet-io (gensym "pcnet-io-"))) `(with-io-register-syntax (,pcnet-io ,io-base) (macrolet ((,name (op &optional reg) (ecase op (:rdp `(,',pcnet-io (,',regdef :rdp) :unsigned-byte16)) (:csr `(,',pcnet-io (progn (setf (,',pcnet-io (,',regdef :rap) :unsigned-byte16) (,',regdef ,reg)) (,',regdef :rdp)) :unsigned-byte16)) ))) ,@body)))) (defmacro with-am7990-ports ((name rap rdp bdp) &body body) `(macrolet ((,name (reg) (case reg (:rap ',rap) (:rdp ',rdp) (:bdp ',bdp) (t `($am7990 ,reg))))) ,@body)) (defun lance-probe (io-base rap rdp bdp) (declare (ignorable bdp)) (with-am7990-ports ($lance rap rdp bdp) (with-am7990 (pcnet io-base $lance) (setf (pcnet :csr :csr0) ($am7990 :csr0 :stop)) (when (and (/= 0 (logand (pcnet :rdp) ($am7990 :csr0 :stop))) (= 0 (pcnet :csr :csr3))) (setf (pcnet :csr :csr0) ($am7990 :csr0 :inea)) (if (/= 0 (logand (pcnet :csr :csr0) ($am7990 :csr0 :inea))) 'c-lance 'lance))))) (defun am7990-probe (io-base rap rdp bdp) (let ((type (lance-probe io-base rap rdp bdp))) (when type (with-am7990-ports ($ports rap rdp bdp) (with-am7990 (pcnet io-base $ports) (let ((chip-id (dpb (pcnet :csr :csr89) (byte 16 16) (pcnet :csr :csr88)))) (when (/= 0 (logand chip-id ($am7990 :csr88 :amd-mask))) (select (ldb (byte 16 12) chip-id) (($am7990 :csr88 :|Am79C960|) 'PCnet-ISA) (($am7990 :csr88 :|Am79C961|) 'PCnet-ISAplus) (($am7990 :csr88 :|Am79C961A|) 'PCnet-ISA-II) (($am7990 :csr88 :|Am79C965|) (values 'PCnet-32 t)) (($am7990 :csr88 :|Am79C970|) (vaues 'PCnet-PCI t)) (($am7990 :csr88 :|Am79C970A|) (values 'PCnet-PCI-II t)) (($am7990 :csr88 :|Am79C971|) (values 'PCnet-FAST t)) (($am7990 :csr88 :|Am79C972|) (values 'PCnet-FASTplus t)) (($am7990 :csr88 :|Am79C973|) (values 'PCnet-FASTplus t)) (($am7990 :csr88 :|Am79C978|) (values 'PCnet-Home t)) (t type))))))))) (defclass ne2100-pci (muerte.ethernet:ethernet-device) ()) (defun pcnet-probe-pci () (multiple-value-bind (bus device function) (find-pci-device #x1022 #x2000) (apply #'attach-ne2100-pci (pci-device-address-maps bus device function)))) (defun attach-ne2100-pci (&key io &allow-other-keys) (check-type io (unsigned-byte 16) "an I/O port") (multiple-value-bind (ic 32bit-p) (am7990-probe io ($pcnet :rap) ($pcnet :rdp) ($pcnet :bdp)) (when 32bit-p (make-instance 'ne2100-pci :mac-address (coerce (loop for i from 0 below 6 collect (io-port (+ io i) :unsigned-byte8)) 'muerte.ethernet:mac-address)))))

1 0

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

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14541 Modified Files: setf.lisp Log Message: Add (a hackish) support for (setf the). --- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2007/03/02 22:01:33 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2007/04/13 23:29:31 1.6 @@ -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.5 2007/03/02 22:01:33 ffjeld Exp $ +;;;; $Id: setf.lisp,v 1.6 2007/04/13 23:29:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,32 +33,32 @@ (expander (and name (movitz::movitz-env-get name 'setf-expander nil environment)))) (if expander (funcall expander place environment) - (multiple-value-bind (expansion expanded-p) - (movitz::movitz-macroexpand-1 place environment) - (cond - (expanded-p - (when (eq expansion place) - (warn "exp place are eq! ~S" place)) - (get-setf-expansion expansion environment)) - ((symbolp place) - (let ((store-var (gensym "store-var-"))) - (values nil nil (list store-var) `(setq ,place ,store-var) place))) - ((assert (consp place))) - (t (multiple-value-bind (tmp-vars tmp-var-init-forms arglist) - (loop for sub-form in (cdr place) - as tmp-var = (gensym "tmp-var-") - if (movitz:movitz-constantp sub-form environment) - collect sub-form into arglist - else collect tmp-var into tmp-vars - and collect sub-form into tmp-var-init-forms - and collect tmp-var into arglist - finally (return (values tmp-vars tmp-var-init-forms arglist))) - (let ((store-var (gensym "store-var-"))) - (values tmp-vars - tmp-var-init-forms - (list store-var) - `(funcall #'(setf ,(car place)) ,store-var ,@arglist) - (list* (car place) arglist))))))))))) + (multiple-value-bind (expansion expanded-p) + (movitz::movitz-macroexpand-1 place environment) + (cond + (expanded-p + (when (eq expansion place) + (warn "exp place are eq! ~S" place)) + (get-setf-expansion expansion environment)) + ((symbolp place) + (let ((store-var (gensym "store-var-"))) + (values nil nil (list store-var) `(setq ,place ,store-var) place))) + ((assert (consp place))) + (t (multiple-value-bind (tmp-vars tmp-var-init-forms arglist) + (loop for sub-form in (cdr place) + as tmp-var = (gensym "tmp-var-") + if (movitz:movitz-constantp sub-form environment) + collect sub-form into arglist + else collect tmp-var into tmp-vars + and collect sub-form into tmp-var-init-forms + and collect tmp-var into arglist + finally (return (values tmp-vars tmp-var-init-forms arglist))) + (let ((store-var (gensym "store-var-"))) + (values tmp-vars + tmp-var-init-forms + (list store-var) + `(funcall #'(setf ,(car place)) ,store-var ,@arglist) + (list* (car place) arglist))))))))))) ;;;(defsetf subseq (sequence start &optional end) (new-sequence) @@ -87,53 +87,53 @@ (defmacro defsetf (access-fn &rest more-args) (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)))))))))))))) + ((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) @@ -147,8 +147,8 @@ (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) (get-setf-expansion place env) (assert (= 1 (length store-vars)) () - "Don't know how to modify a place with ~D cells." - (length store-vars)) + "Don't know how to modify a place with ~D cells." + (length store-vars)) `(let ,(mapcar #'list tmp-vars tmp-var-init-forms) ;; We love backquote.. (let ((,(first store-vars) (,',function @@ -163,36 +163,37 @@ (defmacro setf (&environment env &rest pairs) (let ((num-pairs (length pairs))) (cond - ((= 2 num-pairs) - (destructuring-bind (place new-value-form) - pairs - ;; 5.1.2 Kinds of Places - (cond - ((symbolp place) ; 5.1.2.1 Variable Names as Places - (multiple-value-bind (expansion expanded-p) - (movitz::movitz-macroexpand-1 place env) - (if expanded-p - `(setf ,expansion ,new-value-form) - `(setq ,place ,new-value-form)))) - (t (multiple-value-bind (tmp-vars tmp-forms store-vars setter-form) - (get-setf-expansion place env) - (case (length store-vars) - (0 `(progn ,@tmp-forms ,new-value-form nil)) - (1 `(let (,@(loop for tmp-var in tmp-vars - for tmp-form in tmp-forms - collect `(,tmp-var ,tmp-form)) - (,(first store-vars) ,new-value-form)) - (declare (ignorable ,@tmp-vars)) - ,setter-form)) - (t `(let ,(loop for tmp-var in tmp-vars - for tmp-form in tmp-forms - collect `(,tmp-var ,tmp-form)) - (multiple-value-bind ,store-vars - ,new-value-form - ,setter-form))))))))) - ((evenp num-pairs) - (cons 'progn - (loop for (place newvalue) on pairs by #'cddr - collect `(setf ,place ,newvalue)))) - (t (error "Odd number of arguments to SETF."))))) - + ((= 2 num-pairs) + (destructuring-bind (place new-value-form) + pairs + ;; 5.1.2 Kinds of Places + (typecase place + (symbol ; 5.1.2.1 Variable Names as Places + (multiple-value-bind (expansion expanded-p) + (movitz::movitz-macroexpand-1 place env) + (if expanded-p + `(setf ,expansion ,new-value-form) + `(setq ,place ,new-value-form)))) + ((cons (eql the)) + `(setf ,(third place) (the ,(second place) ,new-value-form))) + (t (multiple-value-bind (tmp-vars tmp-forms store-vars setter-form) + (get-setf-expansion place env) + (case (length store-vars) + (0 `(progn ,@tmp-forms ,new-value-form nil)) + (1 `(let (,@(loop for tmp-var in tmp-vars + for tmp-form in tmp-forms + collect `(,tmp-var ,tmp-form)) + (,(first store-vars) ,new-value-form)) + (declare (ignorable ,@tmp-vars)) + ,setter-form)) + (t `(let ,(loop for tmp-var in tmp-vars + for tmp-form in tmp-forms + collect `(,tmp-var ,tmp-form)) + (multiple-value-bind ,store-vars + ,new-value-form + ,setter-form))))))))) + ((evenp num-pairs) + (cons 'progn + (loop for (place newvalue) on pairs by #'cddr + collect `(setf ,place ,newvalue)))) + (t (error "Odd number of arguments to SETF.")))))

1 0

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

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv11775 Modified Files: memref.lisp Log Message: Improve (setf memref-int) somewhat. --- /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2005/08/24 07:30:14 1.48 +++ /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2007/04/13 23:19:57 1.49 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.48 2005/08/24 07:30:14 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.49 2007/04/13 23:19:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1043,19 +1043,22 @@ (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) (,prefixes :movl :eax (:ecx :ebx)))) (:unsigned-byte8 - `(with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :push) ,address) - (:compile-form (:result-mode :push) ,index) - (:compile-form (:result-mode :push) ,offset) - (:compile-form (:result-mode :eax) ,value) - (:popl :edx) ; offset - (:popl :ebx) ; index - (:popl :ecx) ; address - (:shll ,(- 8 movitz::+movitz-fixnum-shift+) :eax) - (:addl :ebx :ecx) - (:addl :edx :ecx) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - (,prefixes :movb :ah (:ecx)))) + (let ((address-var (gensym "memref-int-address-")) + (index-var (gensym "memref-int-index-var-")) + (offset-var (gensym "memref-int-offset-var-")) + (value-var (gensym "memref-int-value-var-"))) + `(let ((,value-var ,value) + (,address-var ,address) + (,offset-var (+ ,index ,offset))) + (with-inline-assembly (:returns :nothing) + (:load-lexical (:lexical-binding ,address-var) :ecx) + (:load-lexical (:lexical-binding ,offset-var) :edx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:shll ,(- 8 movitz::+movitz-fixnum-shift+) :eax) + (:addl :edx :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (,prefixes :movb :ah (:ecx))) + ,value-var))) (:unsigned-byte16 (cond ((eq 0 offset) @@ -1102,22 +1105,28 @@ (defun (setf memref-int) (value address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t)) (cond - (physicalp - (ecase type - (:unsigned-byte8 - (setf (memref-int address :offset offset :index index :type :unsigned-byte8) - value)) - (:unsigned-byte16 - (setf (memref-int address :offset offset :index index :type :unsigned-byte16) - value)))) - ((not physicalp) - (ecase type - (:unsigned-byte8 - (setf (memref-int address :offset offset :index index :type :unsigned-byte8 :physicalp nil) - value)) - (:unsigned-byte16 - (setf (memref-int address :offset offset :index index :type :unsigned-byte16 :physicalp nil) - value)))))) + (physicalp + (ecase type + (:unsigned-byte8 + (setf (memref-int address :offset offset :index index :type :unsigned-byte8) + value)) + (:unsigned-byte16 + (setf (memref-int address :offset offset :index index :type :unsigned-byte16) + value)) + (:unsigned-byte32 + (setf (memref-int address :offset offset :index index :type :unsigned-byte32) + value)))) + ((not physicalp) + (ecase type + (:unsigned-byte8 + (setf (memref-int address :offset offset :index index :type :unsigned-byte8 :physicalp nil) + value)) + (:unsigned-byte16 + (setf (memref-int address :offset offset :index index :type :unsigned-byte16 :physicalp nil) + value)) + (:unsigned-byte32 + (setf (memref-int address :offset offset :index index :type :unsigned-byte32 :physicalp nil) + value)))))) (defun memcopy (object-1 object-2 offset index-1 index-2 count type) (ecase type

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 13 Apr '07

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv7718 Modified Files: vga.lisp Log Message: Tweaked (setf pixel). --- /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/04/07 08:04:51 1.13 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/04/13 22:59:26 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 25 14:08:20 2001 ;;;; -;;;; $Id: vga.lisp,v 1.13 2007/04/07 08:04:51 ffjeld Exp $ +;;;; $Id: vga.lisp,v 1.14 2007/04/13 22:59:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1131,20 +1131,23 @@ ;; set a pixel to a colour of our choice ;; write to the NEXT page -(defun (setf pixel) (col x y) - (cond ((< x (nth 0 (viewport))) (return-from pixel nil)) - ((> x (nth 1 (viewport))) (return-from pixel nil)) - ((< y (nth 2 (viewport))) (return-from pixel nil)) - ((> y (nth 3 (viewport))) (return-from pixel nil)) - (t (set-plane (logand x 3)) - (setf (memref-int (vga-memory-map) - :index (+ (* (truncate *vga-width* 4) y) ; pixel - (truncate x 4) - (* (truncate *vga-width* 2) ; page - *vga-height* - *vga-current-page*)) - :type :unsigned-byte8) - col)))) +(defun (setf pixel) (color x y) + (cond + ((< x (nth 0 (viewport)))) + ((>= x (nth 1 (viewport)))) + ((< y (nth 2 (viewport)))) + ((>= y (nth 3 (viewport)))) + (t (set-plane (logand x 3)) + (setf (memref-int (vga-memory-map) + :index (+ (* (truncate *vga-width* 4) y) ; pixel + (truncate x 4) + (* (truncate *vga-width* 2) ; page + *vga-height* + *vga-current-page*)) + :type :unsigned-byte8) + color))) + color) + ; return the current viewport as a list

1 0

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

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4950 Modified Files: segments.lisp Log Message: In (setf segment-descriptor-limit), prefer (setf ldb) over logior etc. --- /project/movitz/cvsroot/movitz/losp/muerte/segments.lisp 2007/04/13 22:37:04 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/segments.lisp 2007/04/13 22:41:05 1.19 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.18 2007/04/13 22:37:04 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.19 2007/04/13 22:41:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -228,9 +228,8 @@ (check-type table (and vector (not simple-vector))) (let ((offset (+ (logand #xfff8 selector) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) - (setf (memref table (+ 6 offset) :type :unsigned-byte8) - (logior (ldb (byte 4 16) limit) - (ash (segment-descriptor-avl-x-db-g table selector) 4))) + (setf (ldb (byte 4 0) (memref table (+ 6 offset) :type :unsigned-byte8)) + (ldb (byte 4 16) limit)) (setf (memref table (+ 0 offset) :type :unsigned-byte16) (ldb (byte 16 0) limit)) limit))

1 0

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

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2950 Modified Files: segments.lisp Log Message: Fix (setf segment-descriptor-limit). Patch from Paavo. --- /project/movitz/cvsroot/movitz/losp/muerte/segments.lisp 2007/03/21 20:20:12 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/segments.lisp 2007/04/13 22:37:04 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.17 2007/03/21 20:20:12 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.18 2007/04/13 22:37:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -229,9 +229,10 @@ (let ((offset (+ (logand #xfff8 selector) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (setf (memref table (+ 6 offset) :type :unsigned-byte8) - (ldb (byte 4 16) limit)) - (setf (memref table (+ 0 offset) :type :unsigned-byte8) - (ldb (byte 16 0) limit)) + (logior (ldb (byte 4 16) limit) + (ash (segment-descriptor-avl-x-db-g table selector) 4))) + (setf (memref table (+ 0 offset) :type :unsigned-byte16) + (ldb (byte 16 0) limit)) limit)) (defun segment-descriptor-type-s-dpl-p (table selector)

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 12 Apr '07

12 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv9942 Modified Files: debugger.lisp Log Message: Remove dead code. --- /project/movitz/cvsroot/movitz/losp/x86-pc/debugger.lisp 2006/03/21 20:13:12 1.42 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/debugger.lisp 2007/04/12 16:11:15 1.43 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.42 2006/03/21 20:13:12 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.43 2007/04/12 16:11:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,7 +53,7 @@ (defvar *backtrace-stack-frame-barrier* nil) (defvar *backtrace-do-fresh-lines* t) (defvar *backtrace-print-length* 3) -(defvar *backtrace-print-level* 2) +(defvar *backtrace-print-level* 3) (defvar *backtrace-print-frames* nil) (defun pointer-in-range (x) @@ -72,31 +72,6 @@ (when (<= 0 delta (length code-vector)) delta)))) - -#+ignore -(defun print-dynamic-context (&key terse symbol) - (loop for dynamic-context = (current-dynamic-context) - then (dynamic-context-uplink dynamic-context) - while (stack-ref-p dynamic-context) - do (let ((tag (dynamic-context-tag dynamic-context))) - (cond - ((eq tag (load-global-constant unbound-value)) - (let ((name (stack-ref dynamic-context 0 0 :lisp))) - (when (or (not symbol) (eq symbol name)) - (format t (if terse - "| #x~X: n: ~S, v: ~Z. |" - "~&#x~X: name: ~A~% value: ~A") - dynamic-context name - (stack-ref dynamic-context 8 0 :lisp))))) - ((not symbol) - (format t (if terse - "| #x~X: t: ~Z. |" - "~&#x~X: tag: ~S") - dynamic-context - tag)))) - finally (format t "~&Last uplink: #x~X~%" dynamic-context) - (return (values)))) - (defun funobj-name-or-nil (x) (typecase x (compiled-function

1 0

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

12 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9876 Modified Files: inspect.lisp Log Message: Improve print-dynamic-context & friends. --- /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/07 08:01:41 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/12 16:10:47 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.59 2007/04/07 08:01:41 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.60 2007/04/12 16:10:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,6 +38,11 @@ (declare (without-check-stack-limit)) ; we do it explicitly.. (check-stack-limit)) +(defun protect-unbound (x) + (if (not (eq x (%run-time-context-slot nil 'new-unbound-value))) + x + (format nil "#<unbound #x~X>" (%object-lispval x)))) + (defun stack-frame-funobj (stack frame) (stack-frame-ref stack frame -1)) @@ -113,6 +118,13 @@ (defun dynamic-context-tag (dynamic-context) (stack-frame-ref nil dynamic-context 1 :lisp)) +(defun stack-index-frame (stack index start-frame) + "Find the frame in which index is included." + (do ((frame start-frame (stack-frame-uplink stack frame))) + ((eq 0 frame) nil) + (when (< index frame) + (return frame)))) + (defmacro with-each-dynamic-context ((&optional start-context result) &rest clauses) "Only use this if you know what you're doing. See run-time.lisp." (let ((context (gensym "dynamic-context-")) @@ -120,6 +132,7 @@ (name (gensym "dynamic-name-")) (bind-clause (find :binding clauses :key #'caar)) (catch-clause (find :catch clauses :key #'caar)) + (lcatch-clause (find :lexical-catch clauses :key #'caar)) (up-clause (find :unwind-protect clauses :key #'caar)) (basic-restart-clause (find :basic-restart clauses :key #'caar))) `(do ((,context ,(if start-context start-context '(current-dynamic-context)) @@ -134,7 +147,8 @@ (multiple-value-bind ,(cdar bind-clause) (values ,context (stack-frame-ref nil ,context 0 :lisp) - (stack-frame-ref nil ,context 2 :lisp)) + (stack-frame-ref nil ,context 2 :lisp) + (stack-frame-ref nil ,context 1 :lisp)) ,@(rest bind-clause))))) ,@(when up-clause `(((eq ,tag (load-global-constant unwind-protect-tag)) @@ -153,29 +167,48 @@ (stack-frame-ref nil ,context -1 :lisp)) ; name 0 (length (cdar basic-restart-clause)))) ,@(rest basic-restart-clause)))))) + ,@(when lcatch-clause + `(((eq ,tag (load-global-constant unbound-function)) + (multiple-value-bind ,(cdar lcatch-clause) + (values ,context) + ,@(rest lcatch-clause))))) ,@(when catch-clause `((t (multiple-value-bind ,(cdar catch-clause) (values ,context ,tag) ,@(rest catch-clause)))))))))) -(defun pdc (&rest types) - (declare (dynamic-extent types)) - (let ((types (or types '(:restarts :bindings :catch)))) - (with-each-dynamic-context () - ((:basic-restart context name) - (when (member :restarts types) - (format t "~&restart: ~S fmt: ~S/~S [#x~X]" name - (rc-format context) - (rc-args context) - context))) - ((:binding context name value) - (declare (ignore context)) - (when (member :bindings types) - (format t "~&bind: ~S => ~Z" name value))) - ((:catch context tag) - (declare (ignore context)) - (when (member :catch types) - (format t "~&catch: ~Z: ~S" tag tag)))))) + +(defun print-dynamic-context (&key + (types '(:restart :binding :catch :unwind-protect :lexical-catch) types-p) + variables (spartan t) (show-functions t)) + (when (and variables (not types-p)) + (setf types '(:binding))) + (let ((format-values (if spartan "~Z" "~S")) + (last-frame nil)) + (flet ((info (context type format &rest args) + (when (member type types) + (let ((frame (stack-index-frame nil context (current-stack-frame)))) + (when (and show-functions frame (not (eq frame last-frame))) + (setf last-frame frame) + (format t "~& [[[in ~A]]]~%" (stack-frame-funobj nil frame)))) + (format t "~&[~8,'0X] " context) + (apply #'format t format args)))) + (with-each-dynamic-context () + ((:basic-restart context name) + (info context :basic-restart + "restart: ~S fmt: ~S/~S [#x~X]" + name (rc-format context) (rc-args context) context)) + ((:binding context name value scratch) + (when (or (null variables) + (member name variables)) + (info context :binding "bind: ~S => ~@? [scratch: ~@?]" + name format-values value format-values scratch))) + ((:unwind-protect context) + (info context :unwind-protect "unwind-protect")) + ((:lexical-catch context tag) + (info context :lexical-catch "lexical-catch" tag tag)) + ((:catch context tag) + (info context :catch "catch: ~Z: ~S" tag tag)))))) (define-compiler-macro %location-object (&environment env location tag) (assert (movitz:movitz-constantp tag env))

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 12 Apr '07

12 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv9643 Modified Files: shallow-binding.lisp Log Message: Rename package to lib.shallow-binding. --- /project/movitz/cvsroot/movitz/losp/lib/shallow-binding.lisp 2007/04/09 17:30:30 1.1 +++ /project/movitz/cvsroot/movitz/losp/lib/shallow-binding.lisp 2007/04/12 16:09:27 1.2 @@ -7,18 +7,18 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: shallow-binding.lisp,v 1.1 2007/04/09 17:30:30 ffjeld Exp $ +;;;; $Id: shallow-binding.lisp,v 1.2 2007/04/12 16:09:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(defpackage los0.shallow-binding +(defpackage lib.shallow-binding (:use common-lisp muerte) (:export #:install-shallow-binding #:deinstall-shallow-binding)) (provide :lib/shallow-binding) -(in-package los0.shallow-binding) +(in-package lib.shallow-binding) (define-primitive-function dynamic-variable-install-shallow () "Install each dynamic binding entry between that in ESP @@ -103,6 +103,7 @@ (:movl (:ecx) :eax) ; symbol? (:testb 3 :al) ; (:jz 'not-variable-binding) ; not symbol? + (:movl :ebx (:eax (:offset movitz-symbol value))) ; uninstall. not-variable-binding (:movl (:ecx 12) :ecx) ; proceed search

1 0

[movitz-cvs] CVS movitz
by ffjeld 11 Apr '07

11 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7978 Modified Files: special-operators-cl.lisp Log Message: Fix unwind-protect compiler: do dynamic-unwind-next _after_ the cleanup-forms have executed (ticket #6). --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/02 20:54:34 1.52 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/11 22:09:39 1.53 @@ -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.52 2007/04/02 20:54:34 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.53 2007/04/11 22:09:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1338,12 +1338,15 @@ :form `(muerte::with-cloak (:multiple-values) ;; Inside here we don't have to mind current-values. (muerte::with-inline-assembly (:returns :nothing) - ;; First, find next-continuation-step.. - (:locally (:movl (:edi (:edi-offset raw-scratch0)) :eax)) ; final-cont.. + ;; First, save final-continuation across cleanup-forms. + (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) + ,@cleanup-forms + (muerte::with-inline-assembly (:returns :nothing) + ;; Now, find next-continuation-step.. + (:popl :eax) ; final-continuation (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) - (:store-lexical ,next-continuation-step-binding :eax :type t)) - ,@cleanup-forms)) + (:store-lexical ,next-continuation-step-binding :eax :type t)))) `((:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation (:load-lexical ,next-continuation-step-binding :edx) (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))

1 0

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

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27301 Modified Files: format.lisp Log Message: Add support for format "~@?". --- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/04/08 13:14:58 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/04/09 21:10:48 1.17 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.16 2007/04/08 13:14:58 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.17 2007/04/09 21:10:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -315,11 +315,13 @@ (#\( (multiple-value-setq (i args) (format-by-string control-string (1+ i) loop-limit args (cond - ((and colon-p at-sign-p) :upcase) + ((and colon-p at-sign-p) :upcase) (colon-p :capitalize) (at-sign-p :capitalize-first) (t :downcase))))) - (#\? (format-by-string (pop args) 0 0 (pop args))) + (#\? (if (not at-sign-p) + (format-by-string (pop args) 0 0 (pop args)) + (setf args (nth-value 1 (format-by-string (pop args) 0 0 args))))) (#\: (setf colon-p t) (go proceed)) (#\@ (setf at-sign-p t)

1 0

[movitz-cvs] CVS movitz/grub-bootloader
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/grub-bootloader In directory clnet:/tmp/cvs-serv16701 Modified Files: grub-bootloader.img Log Message: New bootloader Binary files /project/movitz/cvsroot/movitz/grub-bootloader/grub-bootloader.img 2004/01/13 11:05:04 1.1.1.1 and /project/movitz/cvsroot/movitz/grub-bootloader/grub-bootloader.img 2007/04/09 18:02:16 1.2 differ

1 0

[movitz-cvs] CVS movitz/grub-bootloader
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/grub-bootloader In directory clnet:/tmp/cvs-serv13449 Modified Files: menu.txt Log Message: New menu --- /project/movitz/cvsroot/movitz/grub-bootloader/menu.txt 2004/01/13 11:05:04 1.1.1.1 +++ /project/movitz/cvsroot/movitz/grub-bootloader/menu.txt 2007/04/09 17:50:39 1.2 @@ -2,7 +2,7 @@ timeout 5 title Movitz/Los0 -kernel 250+2630 +kernel 200+20000 title Harddisk root (hd0,0)

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv4941 Added Files: shallow-binding.lisp Log Message: Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp file such that most of the cruft is moved into scratch.lisp, the shallow-binding stuff is moved into lib/shallow-binding.lisp, and what remains in los0.lisp is just the core mechanisms for the los0 kernel application. --- /project/movitz/cvsroot/movitz/losp/lib/shallow-binding.lisp 2007/04/09 17:30:31 NONE +++ /project/movitz/cvsroot/movitz/losp/lib/shallow-binding.lisp 2007/04/09 17:30:31 1.1 ;;;;------------------ -*- movitz-mode: t -*-------------------------- ;;;; ;;;; Copyright (C) 2007, Frode Vatvedt Fjeld ;;;; ;;;; Filename: shallow-binding.lisp ;;;; Description: An implementation of shallow binding. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: shallow-binding.lisp,v 1.1 2007/04/09 17:30:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (defpackage los0.shallow-binding (:use common-lisp muerte) (:export #:install-shallow-binding #:deinstall-shallow-binding)) (provide :lib/shallow-binding) (in-package los0.shallow-binding) (define-primitive-function dynamic-variable-install-shallow () "Install each dynamic binding entry between that in ESP (offset by 4 due to the call to this primitive-function!) and current dynamic-env. Preserve EDX." (with-inline-assembly (:returns :nothing) (:leal (:esp 4) :ecx) ; first entry install-loop (:locally (:cmpl :ecx (:edi (:edi-offset dynamic-env)))) (:je 'install-completed) (:movl (:ecx 0) :eax) ; binding's name (:movl (:eax (:offset movitz-symbol value)) :ebx) ; old value into EBX (:movl :ebx (:ecx 4)) ; save old value in scratch (:movl (:ecx 8) :ebx) ; new value.. (:movl :ebx ; ..into symbol's value slot (:eax (:offset movitz-symbol value))) (:movl (:ecx 12) :ecx) ; iterate next binding (:jmp 'install-loop) install-completed (:ret))) (define-primitive-function dynamic-variable-uninstall-shallow (dynamic-env) "Uninstall each dynamic binding between 'here' (i.e. the current dynamic environment pointer) and the dynamic-env pointer provided in EDX. This must be done without affecting 'current values'! (i.e. eax, ebx, ecx, or CF), and also EDX must be preserved." (with-inline-assembly (:returns :nothing) (:jc 'ecx-ok) (:movl 1 :ecx) ecx-ok (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:locally (:movl :eax (:edi (:edi-offset scratch1)))) (:locally (:movl :ebx (:edi (:edi-offset scratch2)))) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) uninstall-loop (:cmpl :edx :ecx) (:je 'uninstall-completed) (:movl (:ecx 0) :eax) ; symbol (:movl (:ecx 4) :ebx) ; old value (:movl :ebx (:eax (:offset movitz-symbol value))) ; reload old value (:movl (:ecx 12) :ecx) (:jmp 'uninstall-loop) uninstall-completed (:locally (:movl (:edi (:edi-offset raw-scratch0)) :ecx)) (:locally (:movl (:edi (:edi-offset scratch1)) :eax)) (:locally (:movl (:edi (:edi-offset scratch2)) :ebx)) (:stc) (:ret))) (define-primitive-function dynamic-unwind-next-shallow (dynamic-env) "Locate the next unwind-protect entry between here and dynamic-env/EAX. If no such entry is found, return (same) dynamic-env in EAX and CF=0. Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX. Point is: Return the 'next step' in unwinding towards dynamic-env. Note that it's an error if dynamic-env isn't in the current dynamic environment, it's supposed to have been found by e.g. dynamic-locate-catch-tag." ;; XXX: Not really sure if there's any point in the CF return value, ;; because I don't think there's ever any need to know whether ;; the returned entry is an unwind-protect or the actual target. (with-inline-assembly (:returns :nothing) (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) (:locally (:movl :eax (:edi (:edi-offset scratch2)))) ; Free up EAX ;; (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :ebx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) search-loop (:jecxz '(:sub-program () (:int 63))) (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:locally (:cmpl :ecx (:edi (:edi-offset scratch2)))) (:je 'found-dynamic-env) (:movl (:ecx 4) :ebx) (:globally (:cmpl :ebx (:edi (:edi-offset unwind-protect-tag)))) (:je 'found-unwind-protect) ;; If this entry is a dynamic variable binding, uninstall it. (:movl (:ecx) :eax) ; symbol? (:testb 3 :al) ; (:jz 'not-variable-binding) ; not symbol? (:movl :ebx (:eax (:offset movitz-symbol value))) ; uninstall. not-variable-binding (:movl (:ecx 12) :ecx) ; proceed search (:jmp 'search-loop) found-unwind-protect (:stc) found-dynamic-env (:movl :ecx :eax) (:ret))) (define-primitive-function dynamic-variable-lookup-shallow (symbol) "Load the dynamic value of SYMBOL into EAX." (with-inline-assembly (:returns :multiple-values) (:movl (:ebx (:offset movitz-symbol value)) :eax) (:ret))) (define-primitive-function dynamic-variable-store-shallow (symbol value) "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax). Preserves EBX and EAX." (with-inline-assembly (:returns :multiple-values) (:movl :ebx (:eax (:offset movitz-symbol value))) (:ret))) (defun install-shallow-binding (&key quiet) (unless quiet (warn "Installing shallow-binding strategy..")) (without-interrupts (macrolet ((install (slot function) `(setf (%run-time-context-slot nil ',slot) (symbol-value ',function)))) (install muerte:dynamic-variable-install dynamic-variable-install-shallow) (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow) (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow) (install muerte::dynamic-variable-store dynamic-variable-store-shallow) (install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow)) (labels ((install-shallow-env (env) "We use this local function in order to install dynamic-env slots in reverse order, by depth-first recursion." (unless (eq 0 env) (install-shallow-env (memref env 12)) (let ((name (memref env 0))) (when (symbolp name) (setf (memref env 4) (%symbol-global-value name)) (setf (%symbol-global-value name) (memref env 8))))))) (install-shallow-env (%run-time-context-slot nil 'muerte::dynamic-env)))) (values)) (defun deinstall-shallow-binding (&key quiet) (unless quiet (warn "Deinstalling shallow-binding strategy..")) (without-interrupts (macrolet ((install (slot) `(setf (%run-time-context-slot nil ',slot) (symbol-value ',slot)))) (install muerte:dynamic-variable-install) (install muerte:dynamic-variable-uninstall) (install muerte::dynamic-unwind-next) (install muerte::dynamic-variable-store) (install muerte::dynamic-variable-lookup)) (loop for env = (%run-time-context-slot nil 'muerte::dynamic-env) then (memref env 12) while (plusp env) do (let ((name (memref env 0))) (when (symbolp name) (setf (%symbol-global-value name) (memref env 4))))) (values)))

1 0

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

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv4903 Added Files: scratch.lisp Log Message: Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp file such that most of the cruft is moved into scratch.lisp, the shallow-binding stuff is moved into lib/shallow-binding.lisp, and what remains in los0.lisp is just the core mechanisms for the los0 kernel application. --- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2007/04/09 17:30:22 NONE +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2007/04/09 17:30:22 1.1 ;;;;------------------ -*- movitz-mode: t -*-------------------------- ;;;; ;;;; Copyright (C) 2007, Frode Vatvedt Fjeld ;;;; ;;;; Filename: scratch.lisp ;;;; Description: Misc. testing code etc. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: scratch.lisp,v 1.1 2007/04/09 17:30:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :scratch) (in-package los0) #+ignore (defun set.2 () (let ((*var-used-in-set-tests* 'a) (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values (let ((*var-used-in-set-tests* 'c)) (list (set var 'b) *var-used-in-set-tests* (symbol-value var))) *var-used-in-set-tests*))) ;; (b c b) ;; b) #+ignore (defun test-lend-constant () (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) (table (make-hash-table :test #'eq))) (loop for sym in symbols for i from 1 do (setf (gethash sym table) i)) (let ((sum 0)) (values (maphash #'(lambda (k v) (assert (eq (elt symbols (1- v)) k)) (incf sum v)) table) sum)))) #+ignore (defun test-aux (x y &aux (sum (+ x y))) sum) #+ignore (defun mapc.error.3 () (mapc #'append)) #+ignore (defun with-hash-table-iterator.12 () (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-hash-table-iterator (m (return-from done x)) (declare (special x)))))) :good) #+ignore (defun string.15 () (when (> char-code-limit 65536) (loop for i = (random char-code-limit) for c = (code-char i) for s = (and c (string c)) repeat 2000 when (and c (or (not (stringp s)) (not (= (length s) 1)) (not (eql c (char s 0))))) collect (list i c s))) nil) (defun x (bios32) (warn "X: ~S" (memref-int bios32)) (warn "X: ~S" (= (memref-int bios32) #x5f32335f))) (defun test2 () (funcall (compile nil '(lambda (a) (declare (notinline > *)) (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) 5445205692802)) (defun test3 () (loop for x below 2 count (not (not (typep x t))))) (defun test4 () (let ((aa 1)) (if (not (/= aa 0)) aa 0))) (defun test-floppy () (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up. (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70. (setf (muerte.x86-pc::fd-motor) nil)) ; to turn the drive and controller off. (defun alist-get-expand (alist key) (let (cons) (tagbody loop (setq cons (car alist)) (cond ((eq alist nil) (go end)) ((eq cons nil)) ((eq key (car cons)) (go end))) (setq alist (cdr alist)) (go loop) end) (cdr cons))) ;;;(defun test-irq () ;;; (with-inline-assembly (:returns :multiple-values) ;;; (:compile-form (:result-mode :multiple-values) (values 0 1 2 3 4 5)) ;;; (:int 42))) ;;; ;;;(defun koo () ;;; (prog1 (make-values) ;;; (format t "hello: ~S" (values 'a 'b 'c 'd)))) ;;; ;;;(defun test-complement (&rest args) ;;; (declare (dynamic-extent args)) ;;; (apply (complement #'symbolp) args)) ;;; ;;;(defun test-constantly (&rest args) ;;; (declare (dynamic-extent args)) ;;; (apply (constantly 'test-value) args)) (defun test-closure (x z) (flet ((closure (y) (= x (1+ y)))) (declare (dynamic-extent (function closure))) (closure z) #+ignore (funcall (lambda (y) (= x (1+ y))) z))) (defun test-stack-cons (x y) (muerte::with-dynamic-extent-scope (zap) (let ((foo (muerte::with-dynamic-extent-allocation (zap) (cons x (lambda () y))))) (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo)))))) (defun test-handler (x) (let ((foo x)) (handler-bind ((error (lambda (c) (format t "error: ~S ~S" c x)))) (error "This is an error. ~S" foo)))) (defun fooo (v w) (tagbody (print (block blurgh (progv (list v) (list w) (format t "Uh: ~S" (symbol-value v)) (if (symbol-value v) (return-from blurgh 1) (go zap))))) zap) t) (defun test-break () (with-inline-assembly (:returns :multiple-values) (:movl 10 :ecx) (:movl :esi :eax) ; This function should return itself! (:clc) (:break))) (defun test-upload (x) ;; (warn "Test-upload blab la bla!!") (setf x (cdr x)) x) ;;;(defun zzz (x) ;;; (multiple-value-bind (symbol status) ;;; (values-list x) ;;; (warn "sym: ~S, stat: ~S" symbol status))) ;;; #+ignore (defun test-loop (x) (format t "test-loop: ~S~%" (loop for i from 0 to 10 collect x))) #+ignore (defun delay (time) (dotimes (i time) (with-inline-assembly (:returns :nothing) (:nop) (:nop)))) ;;; ;;;(defun test-consp (x) ;;; (with-inline-assembly (:returns :boolean-cf=1) ;;; (:compile-form (:result-mode :ecx) x) ;;; (:leal (:edi -4) :eax) ;;; (:rorb :cl :al))) #+ignore (defun test-block (x) (block nil (let ((*print-base* (if x (return 3) 8))) (jumbo 2 2 (and x 2) (+ 3 3 (or x 4)) (if x 2 (return nil))))) #+ignore (+ x 2)) #+ignore (defun jumbo (a b c &rest x) (declare (dynamic-extent x)) (print a) (print b) (print c) (print x) 'jumbo) (defun jumbo2 (a b &rest x) (declare (dynamic-extent x)) (print a) (print b) (print x) 'jumbo) (defun jumbo3 (a &rest x) (declare (dynamic-extent x)) (print a) (print x) 'jumbo) (defun jumbo4 (&rest x) (declare (dynamic-extent x)) (print x) 'jumbo) #+ignore (defun tagbodyxx (x) (tagbody (print 'hello) haha (unwind-protect (when x (go hoho)) (warn "unwind..")) (print 'world) hoho (print 'blrugh))) #+ignore (defun tagbodyxx (x) (tagbody (print 'hello) haha (unwind-protect (funcall (lambda () (when x (go hoho)))) (warn "unwind..")) (print 'world) hoho (print 'blrugh))) #+ignore (defun kumbo (&key a b (c (jumbo 1 2 3)) d) (print a) (print b) (print c) (print d)) #+ignore (defun lumbo (a &optional (b 'zap)) (print a) (print b)) (defmacro do-check-esp (&body body) `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax)))) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :multiple-values) (progn ,@body))) (unless (eq before (with-inline-assembly (:returns :eax) (:movl :esp :eax))) (error "ESP before body: ~S, after: ~S" (with-inline-assembly (:returns :eax) (:movl :esp :eax)))))) #+ignore (defun test-m-v-call () (do-check-esp (multiple-value-call #'format t "~@{ ~D~}~%" 'a (values) 'b (test-loop 1) (make-values) 'c 'd 'e (make-no-values) 'f))) (defun test-m-v-call2 () (multiple-value-call #'format t "~@{ ~D~}~%" 'a 'b (values 1 2 3) 'c 'd 'e 'f)) (defun make-values () (values 0 1 2 3 4 5)) (defun xfuncall (&rest args) (declare (dynamic-extent args)) (break "xfuncall:~{ ~S~^,~}" args) (values)) (defun xfoo (f) (do-check-esp (multiple-value-bind (a b c d) (multiple-value-prog1 (make-values) (format t "hello world")) (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f)))) #+ignore (defun make-no-values () (values)) #+ignore (defun test-nth-values () (nth-value 2 (make-values))) #+ignore (defun test-values2 () (multiple-value-bind (a b c d e f g h) (make-values) (format t "test-values2: A: ~S, B: ~S, C: ~S, D: ~S, E: ~S, F: ~S G: ~S, H: ~S~%" a b c d e f g h))) #+ignore (defun test-flet (zap) (flet ((pingo (z y x) (declare (ignore y z)) (format t "This is pingo: ~S with zap: ~W~%" x zap))) ;; (declare (dynamic-extent pingo)) (pingo 100 200 300))) #+ignore (defun test-flet2 (zap) (flet ((pingo (z y x) (declare (ignore y z)) (format t "This is pingo: ~S with zap: ~W~%" x zap))) ;; (declare (dynamic-extent pingo)) (lambda (x) (pingo 100 200 300)))) (defun test-boo () (let ((real-cmuc #'test-flet2)) (let ((plongo (lambda (x) (warn "~S real-cmuc: ~S" x real-cmuc) (funcall real-cmuc x)))) (funcall plongo 'zooom)))) (defun test-labels () (labels ((pingo (x) (format t "~&This is pingo: ~S~%" x) (when (plusp x) (pingo (1- x))))) (pingo 5))) #+ignore (defun foo-type (length start1 sequence-1) (do* ((i 0 #+ignore (+ start1 length -1) (1- i))) ((< i start1) sequence-1) (declare (type muerte::index i length)) (setf (sequence-1-ref i) 'foo))) #+ignore (defun test-values () (multiple-value-bind (a b c d e f g h i j) (multiple-value-prog1 (make-values) ;;; (format t "this is the resulting form.~%") (format t "this is the first ignorable form.~%" 1 2 3) (format t "this is the second ignorable form.~%")) ;;; (format t "test-values num: ~D~%" (capture-reg8 :cl)) (format t "test-values: A: ~Z, B: ~Z, C: ~Z, D: ~Z ~Z ~Z ~Z ~Z ~Z ~Z~%" a b c d e f g h i j))) #+ignore (defun test-keywords (&key a b (c 100) ((:d x) 5 x-p)) (format t "test-keywords: a: ~S, b: ~S, c: ~S, x: ~S, x-p: ~S~%" a b c x x-p)) #+ignore (defun test-k1 (a b &key x) (declare (ignore a b)) (warn "x: ~S" x)) (defun test-funcall (&rest args) (declare (dynamic-extent args)) (format t "~&test-funcall args: ~S~%" args)) #+ignore (defun test-rest (&optional (a0 nil a0-p) a1 a3 &rest args) (declare (dynamic-extent args)) (when a0-p (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args))) (defun test-return () (print (block nil (values 'x 'y (if (foo) (return 'foo) (return-from test-return 'not-foo)) 'bar))) 5) #+ignore (defun test-lexthrow (x) [749 lines skipped]

1 0

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

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv4851 Modified Files: los0.lisp Log Message: Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp file such that most of the cruft is moved into scratch.lisp, the shallow-binding stuff is moved into lib/shallow-binding.lisp, and what remains in los0.lisp is just the core mechanisms for the los0 kernel application. --- /project/movitz/cvsroot/movitz/losp/los0.lisp 2005/10/31 09:18:08 1.50 +++ /project/movitz/cvsroot/movitz/losp/los0.lisp 2007/04/09 17:30:15 1.51 @@ -1,4 +1,4 @@ -;;;;------------------------------------------------------------------ +;;;;------------------ -*- movitz-mode: t -*-------------------------- ;;;; ;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.50 2005/10/31 09:18:08 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.51 2007/04/09 17:30:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,8 +33,7 @@ ;; (require :lice-0.1/all) -(defpackage muerte.init - (:nicknames #:los0) +(defpackage los0 (:use #:common-lisp #:muerte #:muerte.lib @@ -49,742 +48,15 @@ #:muerte.x86-pc.serial #:threading)) +(require :lib/shallow-binding) (require :los0-gc) ; Must come after defpackage. +;; (require :asteroids) +(require :scratch) -(in-package muerte.init) - -(defun test0 () - (ash 1 -1000000000000)) - -(defun test1 () - (unwind-protect 0 (the integer 1))) - -(defun x (bios32) - (warn "X: ~S" (memref-int bios32)) - (warn "X: ~S" (= (memref-int bios32) #x5f32335f))) - -(defun test2 () - (funcall - (compile - nil - '(lambda (a) (declare (notinline > *)) - (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) - (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) - 5445205692802)) - -(defun test3 () - (loop for x below 2 count (not (not (typep x t))))) - -(defun test4 () - (let ((aa 1)) (if (not (/= aa 0)) aa 0))) - - -(defun test-floppy () - (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up. - (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70. - (setf (muerte.x86-pc::fd-motor) nil)) ; to turn the drive and controller off. - - -(defun alist-get-expand (alist key) - (let (cons) - (tagbody - loop - (setq cons (car alist)) - (cond ((eq alist nil) (go end)) - ((eq cons nil)) - ((eq key (car cons)) (go end))) - (setq alist (cdr alist)) - (go loop) - end) - (cdr cons))) - -;;;(defun test-irq () -;;; (with-inline-assembly (:returns :multiple-values) -;;; (:compile-form (:result-mode :multiple-values) (values 0 1 2 3 4 5)) -;;; (:int 42))) -;;; -;;;(defun koo () -;;; (prog1 (make-values) -;;; (format t "hello: ~S" (values 'a 'b 'c 'd)))) -;;; -;;;(defun test-complement (&rest args) -;;; (declare (dynamic-extent args)) -;;; (apply (complement #'symbolp) args)) -;;; -;;;(defun test-constantly (&rest args) -;;; (declare (dynamic-extent args)) -;;; (apply (constantly 'test-value) args)) - -(defun test-closure (x z) - (flet ((closure (y) (= x (1+ y)))) - (declare (dynamic-extent (function closure))) - (closure z) - #+ignore (funcall (lambda (y) (= x (1+ y))) - z))) - -(defun test-stack-cons (x y) - (muerte::with-dynamic-extent-scope (zap) - (let ((foo (muerte::with-dynamic-extent-allocation (zap) - (cons x (lambda () y))))) - (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo)))))) - -(defun test-handler (x) - (let ((foo x)) - (handler-bind - ((error (lambda (c) - (format t "error: ~S ~S" c x)))) - (error "This is an error. ~S" foo)))) - - -(defun fooo (v w) - (tagbody - (print (block blurgh - (progv (list v) (list w) - (format t "Uh: ~S" (symbol-value v)) - (if (symbol-value v) - (return-from blurgh 1) - (go zap))))) - zap) - t) - - -(defun test-break () - (with-inline-assembly (:returns :multiple-values) - (:movl 10 :ecx) - (:movl :esi :eax) ; This function should return itself! - (:clc) - (:break))) - -(defun test-upload (x) - ;; (warn "Test-upload blab la bla!!") - (setf x (cdr x)) - x) - -;;;(defun zzz (x) -;;; (multiple-value-bind (symbol status) -;;; (values-list x) -;;; (warn "sym: ~S, stat: ~S" symbol status))) -;;; - -#+ignore -(defun test-loop (x) - (format t "test-loop: ~S~%" - (loop for i from 0 to 10 collect x))) - -#+ignore -(defun delay (time) - (dotimes (i time) - (with-inline-assembly (:returns :nothing) - (:nop) - (:nop)))) -;;; -;;;(defun test-consp (x) -;;; (with-inline-assembly (:returns :boolean-cf=1) -;;; (:compile-form (:result-mode :ecx) x) -;;; (:leal (:edi -4) :eax) -;;; (:rorb :cl :al))) - - -#+ignore -(defun test-block (x) - (block nil - (let ((*print-base* (if x (return 3) 8))) - (jumbo 2 2 (and x 2) (+ 3 3 (or x 4)) (if x 2 (return nil))))) - #+ignore (+ x 2)) - -#+ignore -(defun jumbo (a b c &rest x) - (declare (dynamic-extent x)) - (print a) (print b) (print c) - (print x) - 'jumbo) - -(defun jumbo2 (a b &rest x) - (declare (dynamic-extent x)) - (print a) (print b) - (print x) - 'jumbo) - -(defun jumbo3 (a &rest x) - (declare (dynamic-extent x)) - (print a) - (print x) - 'jumbo) - -(defun jumbo4 (&rest x) - (declare (dynamic-extent x)) - (print x) - 'jumbo) - -#+ignore -(defun tagbodyxx (x) - (tagbody - (print 'hello) - haha - (unwind-protect - (when x (go hoho)) - (warn "unwind..")) - (print 'world) - hoho - (print 'blrugh))) - -#+ignore -(defun tagbodyxx (x) - (tagbody - (print 'hello) - haha - (unwind-protect - (funcall (lambda () - (when x (go hoho)))) - (warn "unwind..")) - (print 'world) - hoho - (print 'blrugh))) - -#+ignore -(defun kumbo (&key a b (c (jumbo 1 2 3)) d) - (print a) - (print b) - (print c) - (print d)) - -#+ignore -(defun lumbo (a &optional (b 'zap)) - (print a) - (print b)) - -(defmacro do-check-esp (&body body) - `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax)))) - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :multiple-values) (progn ,@body))) - (unless (eq before - (with-inline-assembly (:returns :eax) (:movl :esp :eax))) - (error "ESP before body: ~S, after: ~S" - (with-inline-assembly (:returns :eax) (:movl :esp :eax)))))) - -#+ignore -(defun test-m-v-call () - (do-check-esp - (multiple-value-call #'format t "~@{ ~D~}~%" - 'a (values) 'b (test-loop 1) (make-values) - 'c 'd 'e (make-no-values) 'f))) - -(defun test-m-v-call2 () - (multiple-value-call #'format t "~@{ ~D~}~%" - 'a 'b (values 1 2 3) 'c 'd 'e 'f)) - -(defun make-values () - (values 0 1 2 3 4 5)) - -(defun xfuncall (&rest args) - (declare (dynamic-extent args)) - (break "xfuncall:~{ ~S~^,~}" args) - (values)) - -(defun xfoo (f) - (do-check-esp - (multiple-value-bind (a b c d) - (multiple-value-prog1 (make-values) - (format t "hello world")) - (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f)))) - - -#+ignore -(defun make-no-values () - (values)) - -#+ignore -(defun test-nth-values () - (nth-value 2 (make-values))) - -#+ignore -(defun test-values2 () - (multiple-value-bind (a b c d e f g h) - (make-values) - (format t "test-values2: A: ~S, B: ~S, C: ~S, D: ~S, E: ~S, F: ~S G: ~S, H: ~S~%" - a b c d e f g h))) - -#+ignore -(defun test-flet (zap) - (flet ((pingo (z y x) - (declare (ignore y z)) - (format t "This is pingo: ~S with zap: ~W~%" x zap))) - ;; (declare (dynamic-extent pingo)) - (pingo 100 200 300))) - -#+ignore -(defun test-flet2 (zap) - (flet ((pingo (z y x) - (declare (ignore y z)) - (format t "This is pingo: ~S with zap: ~W~%" x zap))) - ;; (declare (dynamic-extent pingo)) - (lambda (x) - (pingo 100 200 300)))) - -(defun test-boo () - (let ((real-cmuc #'test-flet2)) - (let ((plongo (lambda (x) - (warn "~S real-cmuc: ~S" x real-cmuc) - (funcall real-cmuc x)))) - (funcall plongo 'zooom)))) - -(defun test-labels () - (labels ((pingo (x) - (format t "~&This is pingo: ~S~%" x) - (when (plusp x) - (pingo (1- x))))) - (pingo 5))) - -#+ignore -(defun foo-type (length start1 sequence-1) - (do* ((i 0 #+ignore (+ start1 length -1) (1- i))) - ((< i start1) sequence-1) - (declare (type muerte::index i length)) - (setf (sequence-1-ref i) - 'foo))) - - -#+ignore -(defun test-values () - (multiple-value-bind (a b c d e f g h i j) - (multiple-value-prog1 - (make-values) -;;; (format t "this is the resulting form.~%") - (format t "this is the first ignorable form.~%" 1 2 3) - (format t "this is the second ignorable form.~%")) -;;; (format t "test-values num: ~D~%" (capture-reg8 :cl)) - (format t "test-values: A: ~Z, B: ~Z, C: ~Z, D: ~Z ~Z ~Z ~Z ~Z ~Z ~Z~%" a b c d e f g h i j))) - - -#+ignore -(defun test-keywords (&key a b (c 100) ((:d x) 5 x-p)) - (format t "test-keywords: a: ~S, b: ~S, c: ~S, x: ~S, x-p: ~S~%" - a b c x x-p)) - -#+ignore -(defun test-k1 (a b &key x) - (declare (ignore a b)) - (warn "x: ~S" x)) - -(defun test-funcall (&rest args) - (declare (dynamic-extent args)) - (format t "~&test-funcall args: ~S~%" args)) - -#+ignore -(defun test-rest (&optional (a0 nil a0-p) a1 a3 &rest args) - (declare (dynamic-extent args)) - (when a0-p - (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args))) - - -(defun test-return () - (print (block nil - (values 'x 'y (if (foo) (return 'foo) (return-from test-return 'not-foo)) 'bar))) - 5) - -#+ignore -(defun test-lexthrow (x) - (apply (lambda (a b) - (unwind-protect - (if (plusp a) 0 (return-from test-lexthrow (+ a b))) - (warn "To serve and protect!"))) - x)) - -#+ignore -(defun test-lexgo (x) - (let ((*print-base* 2)) - (return-from test-lexgo (print 123)))) - -#+ignore -(defun test-xgo (c x) - (tagbody - loop - (warn "c: ~S" c) - (apply (lambda (a) - (decf c) - (if (plusp a) (go exit) (go loop)) - (warn "juhu, a or x: ~S, c: ~S" a c)) - x) - exit - (warn "exited: ~S" c))) - - -(defun test-bignum () - 123456789123456) - -(defun fe32 () - #xfffffffe) - [1005 lines skipped]

1 0

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

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv4744 Modified Files: los0-gc.lisp Log Message: Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp file such that most of the cruft is moved into scratch.lisp, the shallow-binding stuff is moved into lib/shallow-binding.lisp, and what remains in los0.lisp is just the core mechanisms for the los0 kernel application. --- /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2006/10/27 06:23:32 1.61 +++ /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2007/04/09 17:30:09 1.62 @@ -10,13 +10,13 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.61 2006/10/27 06:23:32 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.62 2007/04/09 17:30:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :los0-gc) -(in-package muerte.init) +(in-package los0) (defvar *gc-quiet* nil) (defvar *gc-running* nil) @@ -91,10 +91,22 @@ ((do-it () `(with-inline-assembly (:returns :eax) retry-cons - ;; Set up thread-atomical execution + +;; (:locally (:cmpl #xabbabee0 (:edi (:edi-offset values) ,(* 4 #x30)))) +;; (:je 'no-check) +;; (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) +;; (:movl (:edx 6) :edx); other +;; (:cmpl 8 (:edx 2)) +;; (:jne '(:sub-program () +;; (:locally (:movl #xabbabee0 (:edi (:edi-offset values) ,(* 4 #x30)))) +;; (:break))) +;; no-check + + ;; Set up thread-atomical execution (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'fast-cons) (:edi (:edi-offset atomically-continuation)))) - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) :ecx) @@ -230,6 +242,18 @@ (defvar *gc-stack* nil) (defvar *gc-stack2* nil) +(defmacro with-hack-space ((&key (size 409600)) &body body) + `(let* ((id (with-inline-assembly (:returns :eax) (:movl :esp :eax))) + (save-space (%run-time-context-slot nil 'muerte::nursery-space)) + (hack-space (make-duo-space (duo-space-end-location save-space) ,size))) + (warn "[~A] hack-space ~Z from ~Z/~Z: ~A" id hack-space save-space (space-other save-space) ',body) + (unwind-protect + (progn + (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space) + ,@body) + (warn "[~A] hack-space done." id) + (setf (%run-time-context-slot nil 'muerte::nursery-space) save-space)))) + (defun install-los0-consing (&key (context (current-run-time-context)) (kb-size 1024) duo-space) @@ -240,26 +264,40 @@ (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) (without-interrupts - (let ((*standard-output* *terminal-io*)) - (cond - (*gc-running* - (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space)) - (hack-space (make-duo-space (duo-space-end-location full-space) 102400))) - (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space) - (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z" - full-space hack-space))) - (t (let ((*gc-running* t)) - (unless *gc-quiet* - (format t "~&;; GC.. ")) - (stop-and-copy)))) + (let ((muerte::*active-condition-handlers* nil) + (*debugger-hook* nil) + (*standard-output* *terminal-io*)) + (cond + (*gc-running* + (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space)) + (hack-space (make-duo-space (duo-space-end-location full-space) 102400))) + (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space) + (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z" + full-space hack-space))) + (t (let ((*gc-running* t)) + (unless *gc-quiet* + (format t "~&;; GC ~Z.." (%run-time-context-slot nil 'muerte::nursery-space))) + (let* ((space0 (%run-time-context-slot nil 'nursery-space)) + (space1 (space-other space0))) + (unless (= 2 (space-fresh-pointer space1)) + (with-hack-space () + (error "PRE space-other is not initialized: ~S" (space-fresh-pointer space1))))) + (unwind-protect + (stop-and-copy) + (let* ((space0 (%run-time-context-slot nil 'nursery-space)) + (space1 (space-other space0))) + (unless (= 2 (space-fresh-pointer space1)) + (with-hack-space () + (error "UP space-other is not initialized: ~S" (space-fresh-pointer space1)))) + ))))) (if *gc-break* (break "GC break.") - (loop ; This is a nice opportunity to poll the keyboard.. - (case (muerte.x86-pc.keyboard:poll-char) - ((#\escape) - (break "Los0 GC keyboard poll.")) - ((nil) - (return))))))))) + (loop ; This is a nice opportunity to poll the keyboard.. + (case (muerte.x86-pc.keyboard:poll-char) + ((#\escape) + (break "Los0 GC keyboard poll.")) + ((nil) + (return))))))))) (let* ((actual-duo-space (or duo-space (allocate-duo-space (* kb-size #x100)))) (last-location (object-location (cons 1 2)))) @@ -332,9 +370,12 @@ (values)))) -(defparameter *x* #4000(nil)) ; Have this in static space. +(defparameter *x* (make-array #x1000 :fill-pointer 0)) ; Have this in static space. ;;;(defparameter *xx* #4000(nil)) ; Have this in static space. +(defvar *gc-x1* nil) +(defvar *gc-x2* nil) + (defparameter *code-vector-foo* 0) (defvar *old-code-vectors* #250(nil)) (defvar *new-code-vectors* #250(nil)) @@ -349,7 +390,10 @@ (check-type space0 (simple-array (unsigned-byte 32) 1)) (check-type space1 (simple-array (unsigned-byte 32) 1)) (assert (eq space0 (space-other space1))) - (assert (= 2 (space-fresh-pointer space1))) + (unless (= 2 (space-fresh-pointer space1)) + (with-hack-space () + (error "space1 is not initialized: ~S" (space-fresh-pointer space1)) + nil)) (setf (%run-time-context-slot nil 'nursery-space) space1) (values space1 space0))) ;; Evacuate-oldspace is to be mapped over every potential pointer. @@ -364,31 +408,29 @@ nil) ((object-in-space-p newspace x) x) - #+ignore - ((and (typep x 'code-vector) - (not (object-in-space-p oldspace x)) - (not (object-in-space-p newspace x)) - (= (ldb (byte 12 0) (object-location x)) - (ldb (byte 12 0) *code-vector-foo*)) - (not (eq x (funobj-code-vector #'stop-and-copy))) - (not (eq x (symbol-value 'muerte::default-interrupt-trampoline))) -;;; (not (eq x (symbol-value 'muerte::ret-trampoline))) - (not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x)))) - (let ((p (position (object-location x) *old-code-vectors*))) - (if p - (aref *new-code-vectors* p) - (setf (aref *new-code-vectors* - (vector-push (object-location x) *old-code-vectors*)) - (let ((new (shallow-copy x))) - (warn "[~S] Migrating ~@[~S ~]~Z => ~Z." - location - (muerte::locate-function (object-location x)) - x new) - new))))) + #+ignore ((and (typep x 'code-vector) + (not (object-in-space-p oldspace x)) + (not (object-in-space-p newspace x)) + (= (ldb (byte 12 0) (object-location x)) + (ldb (byte 12 0) *code-vector-foo*)) + (not (eq x (funobj-code-vector #'stop-and-copy))) + (not (eq x (symbol-value 'muerte::default-interrupt-trampoline))) + (not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x)))) + (let ((p (position (object-location x) *old-code-vectors*))) + (if p + (aref *new-code-vectors* p) + (setf (aref *new-code-vectors* + (vector-push (object-location x) *old-code-vectors*)) + (let ((new (shallow-copy x))) + (warn "[~S] Migrating ~@[~S ~]~Z => ~Z." + location + (muerte::locate-function (object-location x)) + x new) + new))))) ((not (object-in-space-p oldspace x)) x) - ((when (typep x 'run-time-context) - (warn "Scavenging ~S" 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))) @@ -415,10 +457,12 @@ with scan-pointer of-type index = 2 as fresh-pointer of-type index = (space-fresh-pointer newspace) while (< scan-pointer fresh-pointer) - do (map-header-vals evacuator - (+ newspace-location scan-pointer) - (+ newspace-location (space-fresh-pointer newspace))) - (setf scan-pointer fresh-pointer)) + do (let ((start (+ newspace-location scan-pointer)) + (end (+ newspace-location (space-fresh-pointer newspace)))) + (map-header-vals evacuator start end) + (setf *gc-x1* start) + (setf *gc-x2* end)) + (setf scan-pointer fresh-pointer)) (when *gc-consistency-check* ;; Consistency check.. (map-stack-vector (lambda (x foo) @@ -426,7 +470,7 @@ x) nil (current-stack-frame)) - (with-simple-restart (continue "Ignore failed GC consistency check.") + (with-simple-restart (continue "Skip GC consistency check.") (without-interrupts (let ((a *x*)) ;; First, restore the state of old-space

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv17892 Modified Files: textmode.lisp Log Message: Add a trivial e9-output "steam" function. --- /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2007/03/26 21:43:21 1.16 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2007/04/09 16:05:25 1.17 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.16 2007/03/26 21:43:21 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.17 2007/04/09 16:05:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -240,6 +240,17 @@ (defun write-word-lowlevel (word dest) (write-word-lowlevel-macro word dest)) +(defun e9-output (op &rest args) + (declare (dynamic-extent args)) + (ecase op + (muerte::stream-write-char + (setf (io-port #xe9 :unsigned-byte8) (char-code (car args)))) + (muerte::stream-fresh-line + (e9-output 'muerte::stream-write-char #\Newline) + t) + (local-echo-p + nil))) + (defun textmode-console (op &rest args) "This function can act as *terminal-io* without/before CLOS support." (declare (dynamic-extent args))

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv17076 Modified Files: malloc-init.lisp Log Message: Compute available memory correctly in initial allocator. --- /project/movitz/cvsroot/movitz/losp/lib/malloc-init.lisp 2005/05/05 20:52:40 1.7 +++ /project/movitz/cvsroot/movitz/losp/lib/malloc-init.lisp 2007/04/09 16:01:53 1.8 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Jan 9 15:57:22 2002 ;;;; -;;;; $Id: malloc-init.lisp,v 1.7 2005/05/05 20:52:40 ffjeld Exp $ +;;;; $Id: malloc-init.lisp,v 1.8 2007/04/09 16:01:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,7 +28,7 @@ (start-location (logand (+ kernel-end-location (1- 4096/4)) -4096/4)) ;; End-location is the end of the memory. (end-location (* (1- memsize-mb) 1024 1024/4))) - (muerte:malloc-initialize start-location end-location) + (muerte:malloc-initialize start-location (- end-location start-location)) (setf (cdar muerte::%memory-map%) end-location) (loop for x from kernel-end-location below start-location do (setf (memref x 0 :type :unsigned-byte32) 0))

1 0

[movitz-cvs] CVS movitz/ide
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/ide In directory clnet:/tmp/cvs-serv15038 Modified Files: movitz-slime.el Log Message: Add movitz-disassemble-primitive. --- /project/movitz/cvsroot/movitz/ide/movitz-slime.el 2007/03/13 20:42:13 1.5 +++ /project/movitz/cvsroot/movitz/ide/movitz-slime.el 2007/04/09 16:00:00 1.6 @@ -45,7 +45,7 @@ ((slime-eval '(cl:and (cl:find-package :movitz.ide) t))) ((not (slime-eval '(cl:and (cl:find-package :movitz) t))) (message "Movitz-mode: The Movitz package is not loaded.")) - (t (slime-eval-async + (t (slime-eval `(cl:progn (cl:load (cl:compile-file ,(concat movitz-slime-path "ide.lisp"))) nil))))) @@ -161,27 +161,23 @@ (options options)) (cond ((string= "function" defun-type) - (message "Movitz disassembling %s %s..." defun-type defun-name) + (message "Movitz disassembling %s '%s'..." defun-type defun-name) (slime-eval-async `(movitz.ide:movitz-disassemble ,defun-name ,package-name) (lambda (result) (slime-show-description result package-name) - (message "Movitz disassembling %s %s...done." defun-type defun-name)))) + (message "Movitz disassembling %s '%s'...done." defun-type defun-name)))) ((string= "method" defun-type) (message "Movitz disassembling %s '%s %s'..." defun-type defun-name lambda-list) (slime-eval-async `(movitz.ide:movitz-disassemble-method ,defun-name ,lambda-list ',options ,package-name) (lambda (result) (slime-show-description result package-name) (message "Movitz disassembling %s '%s %s'...done." defun-type defun-name lambda-list)))) - ;; ((string= "primitive-function" defun-type) - ;; (message "Movitz disassembling %s %s..." defun-type defun-name) - ;; (fi:eval-in-lisp - ;; "(cl:let ((defun-name (cl:let ((cl:*package* (cl:find-package :%s))) - ;; (cl:read-from-string \"%s\"))) - ;; (cl:*print-base* 16)) - ;; (movitz::movitz-disassemble-primitive defun-name))" - ;; fi:package defun-name) - ;; (switch-to-buffer "*common-lisp*") - ;; (message "Movitz disassembling %s %s...done." defun-type defun-name)) + ((string= "primitive-function" defun-type) + (message "Movitz disassembling %s '%s'..." defun-type defun-name) + (slime-eval-async `(movitz.ide:movitz-disassemble-primitive ,defun-name ,package-name) + (lambda (result) + (slime-show-description result package-name) + (message "Movitz disassembling %s '%s'...done." defun-type defun-name)))) (t (message "Don't know how to Movitz disassemble %s '%s'." defun-type defun-name)))))) (defun movitz-arglist (string)

1 0

[movitz-cvs] CVS movitz/ide
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/ide In directory clnet:/tmp/cvs-serv14958 Modified Files: ide.lisp Log Message: Add movitz-disassemble-primitive. --- /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/03/13 20:42:11 1.6 +++ /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/04/09 15:59:43 1.7 @@ -13,6 +13,7 @@ #:compile-defun #:dump-image #:movitz-disassemble + #:movitz-disassemble-primitive #:movitz-disassemble-method #:movitz-arglist #:movitz-macroexpand)) @@ -49,6 +50,13 @@ (movitz:movitz-disassemble (get-sexpr printname (get-package package-printname)))))) +(defun movitz-disassemble-primitive (printname package-printname) + "Return the disassembly of SYMBOL-NAME's function as a string." + (with-image () + (with-output-to-string (*standard-output*) + (movitz::movitz-disassemble-primitive (get-sexpr printname + (get-package package-printname)))))) + (defun movitz-disassemble-method (gf-name lambda-list qualifiers package-name) (with-image () (let ((package (get-package package-name)))

1 0

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

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19367 Modified Files: arrays.lisp Log Message: Remove lingering debug statement. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 15:52:33 1.63 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 16:03:53 1.64 @@ -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.63 2007/04/08 15:52:33 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.64 2007/04/08 16:03:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1100,7 +1100,6 @@ (do-it)))) (cond ((integerp fill-pointer) - (warn "sfp len: ~s" (array-dimension array 0)) (setf (fill-pointer array) fill-pointer)) ((or (eq t fill-pointer) (array-has-fill-pointer-p array))

1 0

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

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16794 Modified Files: arrays.lisp Log Message: Fixed a stupid bug in (setf fill-pointer) which made make-array fail on vectors of length between #x1000 and #x4000. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/07 20:18:20 1.62 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 15:52:33 1.63 @@ -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.62 2007/04/07 20:18:20 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.63 2007/04/08 15:52:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -157,7 +157,7 @@ "Does the basic-vector have a fill-pointer?" `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,vector) - (:testl ,(logxor #xffffffff (1- (expt 2 14))) + (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14)))) (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))))) (define-compiler-macro %basic-vector-fill-pointer (vector) @@ -232,7 +232,8 @@ (:jnz 'illegal-fill-pointer) (:movl (:ebx (:offset movitz-basic-vector num-elements)) :ecx) - (:testl ,(logxor #xffffffff (1- (expt 2 14))) :ecx) + (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14)))) + :ecx) (:jnz '(:sub-program () (:compile-form (:result-mode :ignore) (error "Vector has no fill-pointer.")))) @@ -1099,6 +1100,7 @@ (do-it)))) (cond ((integerp fill-pointer) + (warn "sfp len: ~s" (array-dimension array 0)) (setf (fill-pointer array) fill-pointer)) ((or (eq t fill-pointer) (array-has-fill-pointer-p array))

1 0

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

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27055 Modified Files: ratios.lisp Log Message: Add some silly and slow cos and sin functions. --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/03/16 19:49:24 1.9 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/04/08 13:44:44 1.10 @@ -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.9 2007/03/16 19:49:24 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.10 2007/04/08 13:44:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,9 +76,28 @@ (integer 1) (ratio (%ratio-denominator x)))) -(defconstant pi #xea7632a/4aa1a8b) - (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) + +;;; + +(defconstant pi #xea7632a/4aa1a8b) + +(defvar long-float-epsilon 1/10000) + +(defun cos (x) + "http://mathworld.wolfram.com/Cosine.html" + (do* ((rad (mod x 44/7)) + (n2 0 (+ n2 2)) + (sign 1 (- sign)) + (denominator 1 (* denominator (1- n2) n2)) + (term 1 (/ (expt rad n2) + denominator)) + (sum 1 (+ sum (* sign term)))) + ((<= term long-float-epsilon) + sum))) + +(defun sin (x) + (cos (- x (/ pi 2))))

1 0

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

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22352 Modified Files: format.lisp Log Message: Format-float was completely broken: It tried to round off when printing the last digit, but that must be done initially, in case of "overflow". --- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/02/11 21:57:14 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/04/08 13:14:58 1.16 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.15 2007/02/11 21:57:14 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.16 2007/04/08 13:14:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,24 +68,22 @@ ((minusp x) (write-char #\-) (format-float (- x) at-sign-p colon-p w d k overflowchar padchar)) - (t (multiple-value-bind (integer-part decimal-part) - (truncate x) - (write-integer integer-part *standard-output* 10 nil) - (dotimes (i k) - (write-char #\0)) - (write-char #\.) - (do ((remainder decimal-part) - (last-i (if d (1- d) 15)) - (i 0 (1+ i))) - ((or (and (not d) (plusp i) (zerop remainder)) - (> i last-i))) - (declare (index i)) - (multiple-value-bind (next-digit next-remainder) - (if (= i last-i) - (floor (+ 1/2 (* 10 remainder))) - (truncate (* 10 remainder))) - (setf remainder next-remainder) - (write-digit next-digit *standard-output*))))))) + (t (let ((decimals (if d (1- d) 15))) + (multiple-value-bind (integer-part decimal-part) + (truncate (+ x (* 1/20 (expt 1/10 decimals)))) + (write-integer integer-part *standard-output* 10 nil) + (dotimes (i k) + (write-char #\0)) + (write-char #\.) + (do ((remainder decimal-part) + (i 0 (1+ i))) + ((or (and (not d) (plusp i) (zerop remainder)) + (> i decimals))) + (declare (index i)) + (multiple-value-bind (next-digit next-remainder) + (truncate (* 10 remainder)) + (setf remainder next-remainder) + (write-digit next-digit *standard-output*)))))))) (defun find-directive (string i directive &optional recursive-skip-start (recursive-skip-end directive))

1 0