January 2005 - movitz-cvs@common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by ffjeld＠common-lisp.net 17 Jan '05

17 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30777 Modified Files: print.lisp Log Message: *** empty log message *** Date: Mon Jan 17 12:02:30 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.16 movitz/losp/muerte/print.lisp:1.17 --- movitz/losp/muerte/print.lisp:1.16 Mon Jan 17 11:54:38 2005 +++ movitz/losp/muerte/print.lisp Mon Jan 17 12:02:27 2005 @@ -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.16 2005/01/17 10:54:38 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.17 2005/01/17 11:02:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -253,13 +253,15 @@ (let ((name (symbol-name symbol))) (if (and (plusp (length name)) (every (lambda (c) - (and (or (upper-case-p c) - (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& - #\/ #\< #\> #\=)) - (digit-char-p c)) - (not (or (digit-char-p c *read-base*) - (member c '(#\.)))))) - name)) + (or (upper-case-p c) + (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& + #\/ #\< #\> #\=)) + (digit-char-p c))) + name) + (not (every (lambda (c) + (or (digit-char-p c *read-base*) + (member c '(#\.)))) + name))) (write-string name stream) (stream-write-escaped-string stream name #\|))))) (cond

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by ffjeld＠common-lisp.net 17 Jan '05

17 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30160 Modified Files: print.lisp Log Message: Minor edit. Date: Mon Jan 17 11:54:38 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.15 movitz/losp/muerte/print.lisp:1.16 --- movitz/losp/muerte/print.lisp:1.15 Mon Oct 11 15:53:09 2004 +++ movitz/losp/muerte/print.lisp Mon Jan 17 11:54:38 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -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.15 2004/10/11 13:53:09 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.16 2005/01/17 10:54:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -32,6 +32,7 @@ (defvar *print-level* 3) (defvar *print-pretty* t) (defvar *print-circle* nil) +(defvar *print-case* :upcase) (defvar *print-safely* nil) @@ -252,15 +253,13 @@ (let ((name (symbol-name symbol))) (if (and (plusp (length name)) (every (lambda (c) - (or (upper-case-p c) - (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& - #\/ #\< #\> #\=)) - (digit-char-p c))) - name) - (not (every (lambda (c) - (or (digit-char-p c *read-base*) - (member c '(#\.)))) - name))) + (and (or (upper-case-p c) + (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& + #\/ #\< #\> #\=)) + (digit-char-p c)) + (not (or (digit-char-p c *read-base*) + (member c '(#\.)))))) + name)) (write-string name stream) (stream-write-escaped-string stream name #\|))))) (cond

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by ffjeld＠common-lisp.net 17 Jan '05

17 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30135 Modified Files: storage-types.lisp Log Message: *** empty log message *** Date: Mon Jan 17 11:54:22 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.48 movitz/storage-types.lisp:1.49 --- movitz/storage-types.lisp:1.48 Mon Jan 3 12:55:57 2005 +++ movitz/storage-types.lisp Mon Jan 17 11:54:21 2005 @@ -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.48 2005/01/03 11:55:57 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.49 2005/01/17 10:54:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -771,7 +771,10 @@ (entry-protocol :initform :default :initarg :entry-protocol - :reader funobj-entry-protocol)) + :reader funobj-entry-protocol) + (headers-on-stack-frame-p + :initform nil + :accessor headers-on-stack-frame-p)) (:slot-align type #.+other-type-offset+)) (defmethod write-binary-record ((obj movitz-funobj) stream)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by ffjeld＠common-lisp.net 17 Jan '05

17 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30097 Modified Files: interrupt.lisp Log Message: Save the CR2 register in the DIT-frame. It holds the offending address in case of a page-fault. Date: Mon Jan 17 11:51:09 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.34 movitz/losp/muerte/interrupt.lisp:1.35 --- movitz/losp/muerte/interrupt.lisp:1.34 Tue Jan 4 17:54:16 2005 +++ movitz/losp/muerte/interrupt.lisp Mon Jan 17 11:51:09 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.34 2005/01/04 16:54:16 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.35 2005/01/17 10:51:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,8 +27,10 @@ :edi :dynamic-env :atomically-continuation - :raw-scratch0 - :ecx :eax :edx :ebx :esi + :raw-scratch0 + :ecx + :cr2 + :eax :edx :ebx :esi :scratch1 :scratch2 :debug0 :debug1 @@ -124,7 +126,10 @@ (:locally (:pushl (:edi (:edi-offset dynamic-env)))) (:locally (:pushl (:edi (:edi-offset atomically-continuation)))) (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) - ,@(loop for reg in (sort (copy-list '(:eax :ebx :ecx :edx :esi)) + (:locally (:pushl :ecx)) + (:movcr :cr2 :ecx) + (:locally (:pushl :ecx)) + ,@(loop for reg in (sort (copy-list '(:eax :ebx :edx :esi)) #'> :key #'dit-frame-index) collect `(:pushl ,reg))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by ffjeld＠common-lisp.net 10 Jan '05

10 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10749 Modified Files: memref.lisp Log Message: For (setf memref :code-vector) use *compiler-nonlocal-lispval-write-segment-prefix*. Date: Mon Jan 10 15:04:53 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.40 movitz/losp/muerte/memref.lisp:1.41 --- movitz/losp/muerte/memref.lisp:1.40 Tue Dec 21 15:28:02 2004 +++ movitz/losp/muerte/memref.lisp Mon Jan 10 15:04:52 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -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.40 2004/12/21 14:28:02 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.41 2005/01/10 14:04:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -748,40 +748,45 @@ (:load-lexical (:lexical-binding ,object-var) :ebx) (,prefixes :movl :eax (:ebx :ecx))))))))) (:code-vector - (cond - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (:movl ,movitz:+code-vector-word-offset+ - (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))) - (:addl :eax (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) - `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) - (:movl ,movitz:+code-vector-word-offset+ - (:ebx :ecx ,(movitz:movitz-eval offset env))) - (:addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) - (t (error "variable (setf memref) type :code-vector not implemented.") - #+ignore - (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-"))) - `(let ((,value-var ,value) (,object-var ,object)) + (let ((prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))) + (,prefixes + :addl :eax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) (with-inline-assembly (:returns :eax) - (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) - (:addl :ebx :ecx) ; index += offset - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:movl :eax (:ebx :ecx)))))))) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx :ecx ,(movitz:movitz-eval offset env))) + (,prefixes + :addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (error "variable (setf memref) type :code-vector not implemented.") + #+ignore + (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movl :eax (:ebx :ecx))))))))) (t ;; (warn "Can't handle inline MEMREF: ~S" form) form))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by ffjeld＠common-lisp.net 10 Jan '05

10 Jan '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26054 Modified Files: primitive-functions.lisp Log Message: Use copy-funobj-code-vector-slots to initialize stack-allocated funobjs. Date: Mon Jan 10 09:19:08 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.59 movitz/losp/muerte/primitive-functions.lisp:1.60 --- movitz/losp/muerte/primitive-functions.lisp:1.59 Tue Jan 4 17:54:20 2005 +++ movitz/losp/muerte/primitive-functions.lisp Mon Jan 10 09:19:06 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.59 2005/01/04 16:54:20 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.60 2005/01/10 08:19:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -692,3 +692,34 @@ (:movl (:edx -4) :esi) ; get target funobj into ESI (:movl (:esp 8) :edx) ; target jumper number (:jmp (:esi :edx (:offset movitz-funobj constant0))))) + +(define-primitive-function copy-funobj-code-vector-slots () + "Copy the (unsafe) code-vector and jumper slots of the funobj in EAX to that in EBX." + ;; Set up thread-atomical execution + (with-inline-assembly (:returns :eax) + (:locally (:movl #.(movitz::atomically-continuation-simple-pf 'copy-funobj-code-vector-slots) + (:edi (:edi-offset atomically-continuation)))) + (:movl (:eax (:offset movitz-funobj code-vector)) :ecx) + (:movl :ecx (:ebx (:offset movitz-funobj code-vector))) + + (:movl (:eax (:offset movitz-funobj code-vector%1op)) :ecx) + (:movl :ecx (:ebx (:offset movitz-funobj code-vector%1op))) + + (:movl (:eax (:offset movitz-funobj code-vector%2op)) :ecx) + (:movl :ecx (:ebx (:offset movitz-funobj code-vector%2op))) + + (:movl (:eax (:offset movitz-funobj code-vector%3op)) :ecx) + (:movl :ecx (:ebx (:offset movitz-funobj code-vector%3op))) + + (:movl (:eax (:offset movitz-funobj num-jumpers)) :edx) + (:andl #xffff :edx) + (:jnz 'copy-jumpers) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:ret) + copy-jumpers + (:movl (:eax :edx (:offset movitz-funobj constant0 -4)) :ecx) + (:movl :ecx (:ebx :edx (:offset movitz-funobj constant0 -4))) + (:subl 4 :edx) + (:jnz 'copy-jumpers) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:ret)))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by ffjeld＠common-lisp.net 10 Jan '05

10 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26028 Modified Files: image.lisp Log Message: Use copy-funobj-code-vector-slots to initialize stack-allocated funobjs. Date: Mon Jan 10 09:18:59 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.87 movitz/image.lisp:1.88 --- movitz/image.lisp:1.87 Tue Jan 4 17:53:53 2005 +++ movitz/image.lisp Mon Jan 10 09:18:56 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.87 2005/01/04 16:53:53 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.88 2005/01/10 08:18:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -482,6 +482,11 @@ :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) (dynamic-jump-next + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (copy-funobj-code-vector-slots :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 10 Jan '05

10 Jan '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26009 Modified Files: compiler.lisp Log Message: Use copy-funobj-code-vector-slots to initialize stack-allocated funobjs. Date: Mon Jan 10 09:18:49 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.127 movitz/compiler.lisp:1.128 --- movitz/compiler.lisp:1.127 Tue Jan 4 21:21:11 2005 +++ movitz/compiler.lisp Mon Jan 10 09:18:49 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.127 2005/01/04 20:21:11 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.128 2005/01/10 08:18:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,6 +84,10 @@ (defvar *compiler-produce-defensive-code* t "Try to make code be extra cautious.") +(defvar *compiler-relink-recursive-funcall* t + "If true, also recursive function calls look up the function through the function name, +which enables tracing of recursive functions.") + (defvar *compiler-trust-user-type-declarations-p* t) (defvar *compiling-function-name* nil) @@ -5409,8 +5413,9 @@ :functional-p nil :modifies arguments-modifies :code (append arguments-code - (if (eq (movitz-read operator) - (movitz-read (movitz-funobj-name funobj))) ; recursive? + (if (and (not *compiler-relink-recursive-funcall*) + (eq (movitz-read operator) + (movitz-read (movitz-funobj-name funobj)))) ; recursive? (make-compiled-funcall-by-esi (length arg-forms)) (make-compiled-funcall-by-symbol operator (length arg-forms) funobj)) stack-restore-code)))))) @@ -6908,22 +6913,21 @@ collect `(:pushl (:eax ,(slot-offset 'movitz-funobj 'constant0) ,(* 4 i)))) (loop repeat (movitz-funobj-num-jumpers object) - do (error "Can't handle jumpers.") collect `(:pushl 0)) `((:pushl (:eax ,(slot-offset 'movitz-funobj 'num-jumpers))) (:pushl (:eax ,(slot-offset 'movitz-funobj 'name))) (:pushl (:eax ,(slot-offset 'movitz-funobj 'lambda-list))) -;;; (:pushl 0) ; %3op -;;; (:pushl 0) ; %2op -;;; (:pushl 0) ; %1op -;;; (:pushl 0) ; (default) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%3op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%2op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%1op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector))) + (:pushl 0) ; %3op + (:pushl 0) ; %2op + (:pushl 0) ; %1op + (:pushl 0) ; (default) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'type)))))))))))) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'type))) + (:leal (:esp ,(tag :other)) :ebx) + (,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'copy-funobj-code-vector-slots))) + ))))))))) ;;;(define-extended-code-expander :exit-dynamic-scope (instruction funobj frame-map) ;;; nil)

1 0

[movitz-cvs] CVS update: movitz/doc/ChangeLog
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz/doc In directory common-lisp.net:/tmp/cvs-serv13336 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jan 4 21:33:17 2005 Author: ffjeld Index: movitz/doc/ChangeLog diff -u movitz/doc/ChangeLog:1.8 movitz/doc/ChangeLog:1.9 --- movitz/doc/ChangeLog:1.8 Tue Jul 20 11:17:38 2004 +++ movitz/doc/ChangeLog Tue Jan 4 21:33:17 2005 @@ -1,3 +1,10 @@ +2005-01-04 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> + + * Fixed some support for stack-allocating funobjs and cons-cells + of dynamic extent. + + * New years resolution: Update this ChangeLog more often. + 2004-07-19 Frode Vatvedt Fjeld <frodef(a)cs.uit.no> * Bignums are now working to the extent that one can basically

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by ffjeld＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv12613 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Tue Jan 4 21:24:00 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.35 movitz/losp/los0.lisp:1.36 --- movitz/losp/los0.lisp:1.35 Wed Dec 15 14:58:26 2004 +++ movitz/losp/los0.lisp Tue Jan 4 21:24:00 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: los0.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.35 2004/12/15 13:58:26 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.36 2005/01/04 20:24:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -108,6 +108,38 @@ ;;; (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) @@ -544,14 +576,6 @@ (defun test-fixed (x y z) (warn "x: ~W, y: ~W, z: ~W" x y z)) -(defun test-closure (x) - (warn "lending x: ~W" x) - (values (lambda () - (warn "borrowed x: ~W" x) - (* x 2)) - (lambda (y) - (setq x y)))) - (defun test-let-closure () (tagbody (let ((*print-base* 10) @@ -1089,6 +1113,28 @@ (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) (read-eval-print)))))) +(defun xwrite (object) + (with-inline-assembly (:returns :nothing) + (:locally (:movl (:edi (:edi-offset muerte::dynamic-env)) :eax)) + (:movl :eax (#x1000000)) + (:movl :ebp (#x1000004)) + (:movl :esi (#x1000008))) + (block handler-case-block-1431896 + (let (handler-case-var-1431897) + (tagbody + (handler-bind + ((serious-condition + (lambda (handler-case-temp-var-1431898) + (setq handler-case-var-1431897 handler-case-temp-var-1431898) + (go handler-case-clause-tag-1431899)))) + (return-from handler-case-block-1431896 + (muerte::internal-write object))) + handler-case-clause-tag-1431899 + (return-from handler-case-block-1431896 + (let ((c handler-case-var-1431897)) + (print-unreadable-object (c *standard-output* :type t :identity t) + (format t " while printing ~z" object)))))))) + (defun ub (x) `(hello world ,x or . what)) @@ -1185,7 +1231,7 @@ ;;; (vector-push funobj ts) ;;; (vector-push offset ts) ;;; (vector-push code-vector ts)))) - ;; (muerte::cli) + (muerte::cli) (pic8259-end-of-interrupt 0) (when (eql #\esc (muerte.x86-pc.keyboard:poll-char)) (break "Test-timer keyboard break.")) @@ -1219,8 +1265,7 @@ *timer-stack* (muerte::copy-current-control-stack)) (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ (pit8253-timer-count 0) (or timeout (+ base (random variation)))) - - #+ignore (muerte::sti))) + (muerte::sti))) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1259,7 +1304,7 @@ (progn ;;; (unless (logbitp 9 (eflags)) ;;; (break "Someone switched off interrupts!")) - (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16)) +;;; (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16)) (throw 'foo 'inner-peace)) (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16))))) (incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16)))))) @@ -1305,8 +1350,8 @@ (format t "Extended memory: ~D KB~%" extended-memsize) (idt-init) - #+ignore (install-los0-consing :kb-size 500) + #+ignore (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2)))) (setf *debugger-function* #'los0-debugger)

1 0