From ffjeld at common-lisp.net Wed Dec 8 23:39:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 00:39:52 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: <20041208233952.EC651885F3@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv19409 Modified Files: los0-gc.lisp Log Message: Say #\escape rather than #\esc, since that seems to be more generally acceptable. Date: Thu Dec 9 00:39:51 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.44 movitz/losp/los0-gc.lisp:1.45 --- movitz/losp/los0-gc.lisp:1.44 Fri Nov 26 15:59:18 2004 +++ movitz/losp/los0-gc.lisp Thu Dec 9 00:39:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.44 2004/11/26 14:59:18 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.45 2004/12/08 23:39:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -234,7 +234,7 @@ (break "GC break.") (loop ; This is a nice opportunity to poll the keyboard.. (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) + ((#\escape) (break "Los0 GC keyboard poll.")) ((nil) (return))))))))) @@ -310,8 +310,8 @@ (values)))) -(defparameter *x* #4000()) ; Have this in static space. -(defparameter *xx* #4000()) ; Have this in static space. +(defparameter *x* #4000(nil)) ; Have this in static space. +(defparameter *xx* #4000(nil)) ; Have this in static space. (defun stop-and-copy (&optional evacuator) From ffjeld at common-lisp.net Wed Dec 8 23:40:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 00:40:04 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp Message-ID: <20041208234004.B1C8D885F3@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv19437 Modified Files: ip4.lisp Log Message: Say #\escape rather than #\esc, since that seems to be more generally acceptable. Date: Thu Dec 9 00:40:03 2004 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.15 movitz/losp/lib/net/ip4.lisp:1.16 --- movitz/losp/lib/net/ip4.lisp:1.15 Thu Nov 25 16:06:02 2004 +++ movitz/losp/lib/net/ip4.lisp Thu Dec 9 00:40:03 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.15 2004/11/25 15:06:02 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.16 2004/12/08 23:40:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -493,7 +493,7 @@ (setf *ip4-router* (ip4-address :129.242.16.1))) ;; This is to announce our presence on the LAN.. (assert (polling-arp *ip4-router* (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char)))) + (eql #\space (muerte.x86-pc.keyboard:poll-char)))) () "Unable to resolve ~/ip4:pprint-ip4/ by ARP." *ip4-router*) (values *ip4-nic* *ip4-ip*)) @@ -508,11 +508,11 @@ *ip4-router* (polling-arp *ip4-router* (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char)))))) + (eql #\space (muerte.x86-pc.keyboard:poll-char)))))) (loop (case (muerte.x86-pc.keyboard:poll-char) ((nil)) - ((#\esc) (break "You broke ip4!")) + ((#\space) (break "You broke ip4!")) (t (return (values)))) (let ((packet (and (packet-available-p ethernet) (receive ethernet)))) From ffjeld at common-lisp.net Wed Dec 8 23:40:17 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 00:40:17 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/tftp.lisp Message-ID: <20041208234017.10C5D885F3@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv19455 Modified Files: tftp.lisp Log Message: Say #\escape rather than #\esc, since that seems to be more generally acceptable. Date: Thu Dec 9 00:40:15 2004 Author: ffjeld Index: movitz/losp/lib/net/tftp.lisp diff -u movitz/losp/lib/net/tftp.lisp:1.3 movitz/losp/lib/net/tftp.lisp:1.4 --- movitz/losp/lib/net/tftp.lisp:1.3 Thu Nov 25 03:09:55 2004 +++ movitz/losp/lib/net/tftp.lisp Thu Dec 9 00:40:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Oct 6 12:42:51 2004 ;;;; -;;;; $Id: tftp.lisp,v 1.3 2004/11/25 02:09:55 ffjeld Exp $ +;;;; $Id: tftp.lisp,v 1.4 2004/12/08 23:40:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,14 +56,14 @@ (tftp/ethernet-write :129.242.16.151 file-name data :mac (polling-arp :129.242.16.1 (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char))))))) + (eql #\space (muerte.x86-pc.keyboard:poll-char))))))) (defun tftp/ethernet-write (ip file-name data-vector &key (mode "octet") mac quiet (timeout 2) (data-length (length data-vector)) (breaker (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char))))) + (eql #\space (muerte.x86-pc.keyboard:poll-char))))) "TFTP write data-vector to file-name on host ip using *ip4-nic*. The host's MAC is looked up by ARP unless provided." (let ((speak (if quiet nil *query-io*)) From ffjeld at common-lisp.net Wed Dec 8 23:40:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 00:40:25 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/keyboard.lisp Message-ID: <20041208234025.C1F1D885F3@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv19471 Modified Files: keyboard.lisp Log Message: Say #\escape rather than #\esc, since that seems to be more generally acceptable. Date: Thu Dec 9 00:40:24 2004 Author: ffjeld Index: movitz/losp/x86-pc/keyboard.lisp diff -u movitz/losp/x86-pc/keyboard.lisp:1.4 movitz/losp/x86-pc/keyboard.lisp:1.5 --- movitz/losp/x86-pc/keyboard.lisp:1.4 Wed Nov 24 17:20:14 2004 +++ movitz/losp/x86-pc/keyboard.lisp Thu Dec 9 00:40:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 24 16:04:12 2001 ;;;; -;;;; $Id: keyboard.lisp,v 1.4 2004/11/24 16:20:14 ffjeld Exp $ +;;;; $Id: keyboard.lisp,v 1.5 2004/12/08 23:40:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,14 +42,14 @@ nil nil nil nil nil :pause nil nil)) ; #x40 (defparameter *scan-codes* - #(#\null #\esc #\1 #\2 #\3 #\4 #\5 #\6 ; #x00 + #(#\null #\escape #\1 #\2 #\3 #\4 #\5 #\6 ; #x00 #\7 #\8 #\9 #\0 #\- #\= #\backspace #\tab ; #x08 #\q #\w #\e #\r #\t #\y #\u #\i ; #x10 #\o #\p #\[ #\] #\newline :ctrl-left #\a #\s ; #x18 #\d #\f #\g #\h #\j #\k #\l #\; ; #x20 #\' #\` :shift-left #\\ #\z #\x #\c #\v ; #x28 - #\b #\n #\m #\, #\. #\/ :shift-right #\esc ; #x30 + #\b #\n #\m #\, #\. #\/ :shift-right #\escape ; #x30 :alt-left #\space :caps-lock :f1 :f2 :f3 :f4 :f5 ; #x38 :f6 :f7 :f8 :f9 :f10 :break :scroll-lock nil ; #x40 @@ -74,7 +74,7 @@ nil nil nil nil nil nil nil :home ; #xc0 :up :page-up nil :left nil :right nil :end ; #xc8 - :down :page-down :insert #\delete nil nil nil nil ; #xd0 + :down :page-down :insert nil #+ignore #\delete nil nil nil nil nil ; #xd0 :alt-right nil nil nil :win :menu nil nil)) ; #xd8 (defun lowlevel-event-p () From ffjeld at common-lisp.net Thu Dec 9 13:27:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 14:27:31 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/eval.lisp Message-ID: <20041209132731.EB7B2885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27587 Modified Files: eval.lisp Log Message: Add rule for evaluation of keywords. Date: Thu Dec 9 14:27:29 2004 Author: ffjeld Index: movitz/eval.lisp diff -u movitz/eval.lisp:1.8 movitz/eval.lisp:1.9 --- movitz/eval.lisp:1.8 Mon Oct 11 15:46:56 2004 +++ movitz/eval.lisp Thu Dec 9 14:27:28 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.8 2004/10/11 13:46:56 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.9 2004/12/09 13:27:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -111,6 +111,8 @@ "3.1.2.1.1 Symbols as Forms" (declare (ignore top-level-p)) (cond + ((keywordp form) + (eval-self-evaluating form env top-level-p)) ((typep (movitz-binding form env) 'constant-object-binding) (translate-program (movitz-print (constant-object (movitz-binding form env))) :cl :muerte.cl)) From ffjeld at common-lisp.net Thu Dec 9 13:36:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 14:36:52 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20041209133652.C5474885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28313 Modified Files: compiler.lisp Log Message: Added *compiler-verbose-p* Date: Thu Dec 9 14:36:47 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.117 movitz/compiler.lisp:1.118 --- movitz/compiler.lisp:1.117 Wed Nov 24 11:02:42 2004 +++ movitz/compiler.lisp Thu Dec 9 14:36:46 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.117 2004/11/24 10:02:42 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.118 2004/12/09 13:36:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,6 +17,8 @@ (defvar *warn-function-change-p* t "Emit a warning whenever a named function's code-vector changes size.") +(defvar *compiler-verbose-p* nil) + (defvar *compiler-do-optimize* t "Apply the peephole optimizer to function code.") @@ -1334,7 +1336,7 @@ :declaration-context :funobj)) (file-code (with-compilation-unit () - (add-bindings-from-lambda-list () function-env) + (add-bindings-from-lambda-list () function-env) (with-open-file (stream path :direction :input) (setf (funobj-env funobj) funobj-env) (loop for form = (with-movitz-syntax () @@ -1346,7 +1348,12 @@ (cond ((symbolp form) form) ((symbolp (car form)) (car form)))) - #+lispworks-personal-edition (hcl:mark-and-sweep 2) + (when *compiler-verbose-p* + (format *query-io* "~&Movitz Compiling ~S..~%" + (cond + ((symbolp form) form) + ((symbolp (car form)) + (xsubseq form 0 2))))) (compiler-call #'compile-form :form form :funobj funobj From ffjeld at common-lisp.net Thu Dec 9 14:03:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:03:31 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/environment.lisp Message-ID: <20041209140331.016CA885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29741 Modified Files: environment.lisp Log Message: minor edits. Date: Thu Dec 9 15:03:30 2004 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.9 movitz/environment.lisp:1.10 --- movitz/environment.lisp:1.9 Mon Oct 11 15:46:25 2004 +++ movitz/environment.lisp Thu Dec 9 15:03:28 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.9 2004/10/11 13:46:25 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.10 2004/12/09 14:03:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -248,10 +248,10 @@ ;;; (warn "..with body ~W" macro-function) (let ((expansion (funcall macro-function form environment))) (cond - #+ignore ((member (if (atom form) form (car form)) - '(<= <=%2op <=%3op) :test #'string=) - (warn "Expanded ~S to ~S" form expansion) - expansion) +;; ((member (if (atom form) form (car form)) +;; '(do) :test #'string=) +;; (warn "Expanded ~S to ~S" form expansion) +;; expansion) (t ;; (warn "Expanded macro named ~A." (if (atom form) form (car form))) expansion))))) @@ -424,7 +424,7 @@ (environment nil) (recurse-p t)) (loop for env = (or environment *movitz-global-environment*) - then (and recurse-p (movitz-environment-uplink env)) + then (when recurse-p (movitz-environment-uplink env)) for plist = (and env (getf (movitz-environment-plists env) symbol)) while env do (let ((val (getf plist indicator '#0=#:not-found))) From ffjeld at common-lisp.net Thu Dec 9 14:04:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:04:59 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20041209140459.6E914885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29777 Modified Files: image.lisp Log Message: Added function set-file-position that tolerats the behavior of CLisp's file-position (on windows). Date: Thu Dec 9 15:04:55 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.83 movitz/image.lisp:1.84 --- movitz/image.lisp:1.83 Thu Nov 25 19:05:17 2004 +++ movitz/image.lisp Thu Dec 9 15:04:54 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.83 2004/11/25 18:05:17 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.84 2004/12/09 14:04:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -846,6 +846,16 @@ *i* (when (boundp '*image*) *image*)) *image*) +(defun set-file-position (stream position &optional who) + (or (ignore-errors (file-position stream position)) + (let* ((end (file-position stream :end)) + (diff (- position end))) + (assert (< 0 diff 10000)) + (dotimes (i diff) + (write-byte 0 stream)) + (assert (= position (file-position stream))))) + (values)) + (defun dump-image (&key (path *default-image-file*) ((:image *image*) *image*) (multiboot-p t) ignore-dump-count) "When is true, include a MultiBoot-compliant header in the image." @@ -959,8 +969,7 @@ :direction :output :if-exists :supersede :if-does-not-exist :create) - (assert (file-position stream 512) () ; leave room for bootblock. - "Couldn't set file-position for ~W." (pathname stream)) + (set-file-position stream 512) ; leave room for bootblock. (let* ((stack-vector (make-instance 'movitz-basic-vector :num-elements #x3ffe :fill-pointer 0 @@ -978,12 +987,12 @@ (kernel-size (- image-end image-start))) (format t "~&;; Kernel size: ~D octets.~%" kernel-size) (unless (zerop (mod image-end 512)) ; Ensure image is multiple of 512 octets - (file-position stream (+ image-end (- 511 (mod image-end 512)))) + (set-file-position stream (+ image-end (- 511 (mod image-end 512))) 'pad-image-tail) (write-byte #x0 stream)) (format t "~&;; Image file size: ~D octets.~%" image-end) ;; Write simple stage1 bootblock into sector 0.. (format t "~&;; Dump count: ~D." (incf (dump-count *image*))) - (assert (file-position stream 0)) + (set-file-position stream 0) (flet ((global-slot-position (slot-name) (+ 512 (image-nil-word *image*) @@ -1004,13 +1013,12 @@ #+ignore(warn "stack-v-pos: ~S => ~S" stack-vector-position stack-vector-word) - (assert (file-position stream (global-slot-position 'stack-vector) - #+ignore stack-vector-position)) + (set-file-position stream (global-slot-position 'stack-vector) 'stack-vector) (write-binary 'word stream stack-vector-word) - (assert (file-position stream (global-slot-position 'stack-bottom))) + (set-file-position stream (global-slot-position 'stack-bottom) 'stack-bottom) (write-binary 'lu32 stream (+ 8 (* 4 4096) ; cushion (- stack-vector-word (tag :other)))) - (assert (file-position stream (global-slot-position 'stack-top))) + (set-file-position stream (global-slot-position 'stack-top) 'stack-top) (write-binary 'lu32 stream (+ 8 (- stack-vector-word (tag :other)) (* 4 (movitz-vector-num-elements stack-vector))))) (if (not multiboot-p) @@ -1030,10 +1038,7 @@ (warn "Multiboot header at position ~D is above the 8KB mark, ~ this image will not be Multiboot compatible." (+ mb-file-position (sizeof mb)))) - (assert (file-position stream mb-file-position) () - "Couldn't set file-position for ~W to ~W." - (pathname stream) - mb-file-position) + (set-file-position stream mb-file-position 'multiboot-header) ;; (format t "~&;; Multiboot load-address: #x~X." load-address) (setf (header-address mb) mb-address (load-address mb) load-address @@ -1077,7 +1082,7 @@ (assert (<= 0 pad-delta 31) () "pad-delta ~S for ~S, p: ~S, new-pos: ~S" pad-delta obj p new-pos)) (incf pad-size pad-delta)) - (assert (file-position stream new-pos))) + (set-file-position stream new-pos obj)) ;; (warn "Dump at address #x~X, filepos #x~X: ~A" p (file-position stream) obj) (let ((old-pos (file-position stream)) (write-size (write-binary-record obj stream))) @@ -1109,10 +1114,10 @@ (sum (+ symbols-size conses-size funobjs-size strings-size simple-vectors-size code-vectors-size pad-size))) (format t "~&;;~%;; ~D symbols (~D gensyms) (~,1F KB ~~ ~,1F%), ~D conses (~,1F KB ~~ ~,1F%), -;; ~D funobjs (~,1F KB ~~ ~,1F%), ~D strings (~,1F KB ~~ ~,1F%), -;; ~D simple-vectors (~,1F KB ~~ ~,1F%), ~D code-vectors (~,1F KB ~~ ~,1F%). -;; ~,1F KB (~,1F%) of padding. -;; In sum this accounts for ~,1F%, or ~D bytes.~%;;~%" +~D funobjs (~,1F KB ~~ ~,1F%), ~D strings (~,1F KB ~~ ~,1F%), +~D simple-vectors (~,1F KB ~~ ~,1F%), ~D code-vectors (~,1F KB ~~ ~,1F%). +~,1F KB (~,1F%) of padding. +In sum this accounts for ~,1F%, or ~D bytes.~%;;~%" symbols-numof gensyms-numof (/ symbols-size 1024) (/ (* symbols-size 100) total-size) conses-numof (/ conses-size 1024) (/ (* conses-size 100) total-size) @@ -1160,13 +1165,13 @@ (t #+ignore (warn "Package ~S ~@[for symbol ~S ~]is not a Movitz package." name symbol) name))) - (ensure-package (package-name lisp-package) + (ensure-package (package-name lisp-package &optional context) (assert (not (member (package-name lisp-package) #+allegro '(excl common-lisp sys aclmop) #-allegro '(common-lisp) :test #'string=)) () - "I don't think you really want to dump the package ~A with Movitz." - lisp-package) + "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz." + lisp-package context) (setf (gethash lisp-package lisp-to-movitz-package) (or (gethash package-name packages-hash nil) (let ((p (funcall 'muerte::make-package-object @@ -1175,7 +1180,8 @@ :external-symbols (make-hash-table :test #'equal) :internal-symbols (make-hash-table :test #'equal) :use-list (mapcar #'(lambda (up) - (ensure-package (movitz-package-name (package-name up)) up)) + (ensure-package (movitz-package-name (package-name up)) + up context)) (package-use-list lisp-package))))) (setf (gethash package-name packages-hash) p) p))))) @@ -1188,7 +1194,7 @@ as package-name = (and lisp-package (movitz-package-name (package-name lisp-package) symbol)) when package-name - do (let* ((movitz-package (ensure-package package-name lisp-package))) + do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) (multiple-value-bind (symbol status) (find-symbol (symbol-name symbol) (symbol-package symbol)) (ecase status @@ -1219,7 +1225,7 @@ ;;; do (when (string= symbol :method) ;;; (warn "XXXX ~S ~S ~S" symbol lisp-package package-name)) when package-name - do (let* ((movitz-package (ensure-package package-name lisp-package))) + do (let* ((movitz-package (ensure-package package-name lisp-package symbol))) (setf (movitz-symbol-package (movitz-read symbol)) (movitz-read movitz-package)))) movitz-packages)))) From ffjeld at common-lisp.net Thu Dec 9 14:05:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:05:56 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/load.lisp Message-ID: <20041209140556.9B64C885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29803 Modified Files: load.lisp Log Message: Recent CLisp fixed this bug. Date: Thu Dec 9 15:05:54 2004 Author: ffjeld Index: movitz/load.lisp diff -u movitz/load.lisp:1.10 movitz/load.lisp:1.11 --- movitz/load.lisp:1.10 Wed Feb 18 15:42:59 2004 +++ movitz/load.lisp Thu Dec 9 15:05:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; -;;;; $Id: load.lisp,v 1.10 2004/02/18 14:42:59 ffjeld Exp $ +;;;; $Id: load.lisp,v 1.11 2004/12/09 14:05:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -48,20 +48,21 @@ (setf (system::gsgc-parameter :generation-spread) 12) (sys:resize-areas :new (* 64 1024 1024))) -#+clisp (load "packages") -#+clisp (defconstant movitz::&all 'movitz::&all) ; CLisp has this wonderful bug.. -#+clisp (defconstant movitz::&code 'movitz::&code) -#+clisp (defconstant movitz::&form 'movitz::&form) -#+clisp (defconstant movitz::&returns 'movitz::&returns) -#+clisp (defconstant movitz::&functional-p 'movitz::&functional-p) -#+clisp (defconstant movitz::&modifies 'movitz::&modifies) -#+clisp (defconstant movitz::&type 'movitz::&type) -#+clisp (defconstant movitz::&final-form 'movitz::&final-form) -#+clisp (defconstant movitz::&funobj 'movitz::&funobj) -#+clisp (defconstant movitz::&top-level-p 'movitz::&top-level-p) -#+clisp (defconstant movitz::&result-mode 'movitz::&result-mode) -#+clisp (defconstant movitz::&env 'movitz::&env) -#+clisp (defconstant movitz::&producer 'movitz::&producer) +#+clisp-older-than-2.33-or-so +(progn (load "packages") + (defconstant movitz::&all 'movitz::&all) ; CLisp has this wonderful bug.. + (defconstant movitz::&code 'movitz::&code) + (defconstant movitz::&form 'movitz::&form) + (defconstant movitz::&returns 'movitz::&returns) + (defconstant movitz::&functional-p 'movitz::&functional-p) + (defconstant movitz::&modifies 'movitz::&modifies) + (defconstant movitz::&type 'movitz::&type) + (defconstant movitz::&final-form 'movitz::&final-form) + (defconstant movitz::&funobj 'movitz::&funobj) + (defconstant movitz::&top-level-p 'movitz::&top-level-p) + (defconstant movitz::&result-mode 'movitz::&result-mode) + (defconstant movitz::&env 'movitz::&env) + (defconstant movitz::&producer 'movitz::&producer)) #-allegro (do () (nil) From ffjeld at common-lisp.net Thu Dec 9 14:10:00 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:10:00 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/parse.lisp Message-ID: <20041209141000.3E8D5885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29832 Modified Files: parse.lisp Log Message: Cleaned up parsing functions and translate-program a bit, so it should now work more reliably, also on CLisp. Date: Thu Dec 9 15:09:59 2004 Author: ffjeld Index: movitz/parse.lisp diff -u movitz/parse.lisp:1.4 movitz/parse.lisp:1.5 --- movitz/parse.lisp:1.4 Wed Nov 24 11:02:59 2004 +++ movitz/parse.lisp Thu Dec 9 15:09:58 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:49:17 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: parse.lisp,v 1.4 2004/11/24 10:02:59 ffjeld Exp $ +;;;; $Id: parse.lisp,v 1.5 2004/12/09 14:09:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,24 +23,20 @@ (defun parse-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) "From the list of FORMS, return first the list of non-declaration forms, ~ second the list of declaration-specifiers." - (loop for form on forms - while (declare-form-p (car form) declare-symbol) - append (cdar form) into declarations - finally (return (values form declarations)))) + (loop for declaration-form = (when (declare-form-p (car forms) declare-symbol) + (pop forms)) + while declaration-form + append (cdr declaration-form) into declarations + finally (return (values forms declarations)))) (defun parse-docstring-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare)) "From the list of FORMS, return first the non-declarations forms, second the declarations, ~ and third the documentation string." - (loop for rest-forms on forms - with docstring = nil - if (declare-form-p (first rest-forms) declare-symbol) - append (cdar rest-forms) into declarations - else if (and (null docstring) - (not (endp (rest rest-forms))) - (stringp (first rest-forms))) - do (setf docstring (first rest-forms)) - else do (loop-finish) - finally (return (values rest-forms declarations docstring)))) + (let ((docstring (when (and (cdr forms) (stringp (car forms))) + (pop forms)))) + (multiple-value-bind (body declarations) + (parse-declarations-and-body forms declare-symbol) + (values body declarations docstring)))) (defun unfold-circular-list (list) "If LIST is circular (through cdr), return (a copy of) the non-circular portion of LIST, and the index (in LIST) of the cons-cell pointed to by (cdr (last LIST))." @@ -54,11 +50,7 @@ cdr-index))))) (defun symbol-package-fix-cl (symbol) - *package* - #+ignore - (if (eq (find-package :cl) (symbol-package symbol)) - (find-package :muerte.cl) - (symbol-package symbol))) + *package*) (eval-when (:execute :compile-toplevel :load-toplevel) (defun muerte::translate-program @@ -71,12 +63,18 @@ (setf from-package (find-package from-package)) (setf to-package (find-package to-package)) (flet ((translate-symbol (s) - (multiple-value-bind (symbol status) - (find-symbol (symbol-name s) to-package) - (if (eq :external status) symbol s)))) + (if (not (eq s (find-symbol (symbol-name s) from-package))) + s + (multiple-value-bind (symbol status) + (find-symbol (symbol-name s) to-package) + (when (or (and (find-symbol (symbol-name s) to-package) + (not (find-symbol (symbol-name s) from-package))) + (and (find-symbol (symbol-name s) from-package) + (not (find-symbol (symbol-name s) to-package)))) + (error "blurgh ~S" s)) + (or symbol s) #+ignore (if (eq :external status) symbol s))))) (cond - ((and (symbolp program) ; single symbol? - (eq (symbol-package program) from-package)) + ((symbolp program) ; single symbol? (translate-symbol program)) ((simple-vector-p program) (map 'vector @@ -96,22 +94,6 @@ (setf (cdr (last translated-program)) (nthcdr cdr-index translated-program)) translated-program))) - #+ignore ((and (eq quote-symbol (car program)) ; triple-quote? - (consp (cadr program)) - (eq quote-symbol (caadr program)) - (consp (cadadr program)) - (eq quote-symbol (car (cadadr program)))) - (cons (translate-symbol (car program)) - (muerte::translate-program (rest program) from-package to-package - :when when - :remove-double-quotes-p remove-double-quotes-p - :quote-symbol quote-symbol))) - #+ignore ((and (eq quote-symbol (car program)) ; double-quote? - (consp (cadr program)) - (eq quote-symbol (caadr program))) - (if remove-double-quotes-p - (cadadr program) - program)) ; .. then don't mess with it. ((and (eq :translate-when (first program)) (or (string= t (second program)) (and when (eq when (second program))))) @@ -119,8 +101,7 @@ ((and (eq :translate-when (first program)) (eq nil (second program))) (third program)) - ((and (symbolp (car program)) - (eq (symbol-package (car program)) from-package)) + ((symbolp (car program)) (cons (translate-symbol (car program)) (muerte::translate-program (cdr program) from-package to-package :when when @@ -139,7 +120,11 @@ (muerte::translate-program (cdr program) from-package to-package :when when :remove-double-quotes-p remove-double-quotes-p - :quote-symbol quote-symbol))))))) + :quote-symbol quote-symbol)))))) + (defun muerte::movitz-program (program) + (translate-program program :common-lisp :muerte.cl)) + (defun muerte::host-program (program) + (translate-program program :muerte.cl :common-lisp))) (defun decode-normal-lambda-list (lambda-list &optional host-symbols-p) "3.4.1 Ordinary Lambda Lists. From ffjeld at common-lisp.net Thu Dec 9 14:12:43 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:12:43 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/lib/named-integers.lisp Message-ID: <20041209141243.BE4D5885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv29887 Modified Files: named-integers.lisp Log Message: *** empty log message *** Date: Thu Dec 9 15:12:42 2004 Author: ffjeld Index: movitz/losp/lib/named-integers.lisp diff -u movitz/losp/lib/named-integers.lisp:1.4 movitz/losp/lib/named-integers.lisp:1.5 --- movitz/losp/lib/named-integers.lisp:1.4 Wed May 5 10:24:21 2004 +++ movitz/losp/lib/named-integers.lisp Thu Dec 9 15:12:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jan 4 16:13:46 2002 ;;;; -;;;; $Id: named-integers.lisp,v 1.4 2004/05/05 08:24:21 ffjeld Exp $ +;;;; $Id: named-integers.lisp,v 1.5 2004/12/09 14:12:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -85,6 +85,7 @@ ',integer-list ',name-list)))) (eval-when (:compile-toplevel) + , at constant-declarations (export ',constant-exports)) , at constant-declarations ',type-name)))) From ffjeld at common-lisp.net Thu Dec 9 14:16:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:16:18 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/lib/readline.lisp Message-ID: <20041209141618.1F71D885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv30352 Modified Files: readline.lisp Log Message: Use #\Rubout rrather than #\delete. Date: Thu Dec 9 15:16:14 2004 Author: ffjeld Index: movitz/losp/lib/readline.lisp diff -u movitz/losp/lib/readline.lisp:1.6 movitz/losp/lib/readline.lisp:1.7 --- movitz/losp/lib/readline.lisp:1.6 Wed Nov 24 17:23:45 2004 +++ movitz/losp/lib/readline.lisp Thu Dec 9 15:16:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 2 13:58:58 2001 ;;;; -;;;; $Id: readline.lisp,v 1.6 2004/11/24 16:23:45 ffjeld Exp $ +;;;; $Id: readline.lisp,v 1.7 2004/12/09 14:16:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -219,7 +219,7 @@ (write-char #\space)) (setf (cursor-x console) x end pos))) - ((#\delete #\^d) + ((#\Rubout #\^d) (when (< pos end) (dotimes (i (- end pos)) (setf (char buffer (+ pos i)) From ffjeld at common-lisp.net Thu Dec 9 14:18:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:18:40 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ethernet.lisp Message-ID: <20041209141840.1E099885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv30634 Modified Files: ethernet.lisp Log Message: Cleaned up constants a bit. Date: Thu Dec 9 15:18:37 2004 Author: ffjeld Index: movitz/losp/lib/net/ethernet.lisp diff -u movitz/losp/lib/net/ethernet.lisp:1.6 movitz/losp/lib/net/ethernet.lisp:1.7 --- movitz/losp/lib/net/ethernet.lisp:1.6 Wed Nov 24 11:07:11 2004 +++ movitz/losp/lib/net/ethernet.lisp Thu Dec 9 15:18:37 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 17 15:25:31 2002 ;;;; -;;;; $Id: ethernet.lisp,v 1.6 2004/11/24 10:07:11 ffjeld Exp $ +;;;; $Id: ethernet.lisp,v 1.7 2004/12/09 14:18:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -47,7 +47,20 @@ #:+destination-mac+ #:+max-ethernet-frame-size+ #:+min-ethernet-frame-size+ - #:+broadcast-address+)) + #:+broadcast-address+ + + #:+ether-type-ip4+ + #:+ether-type-chaosnet+ + #:+ether-type-arp+ + #:+ether-type-symbolics+ + #:+ether-type-rarp+ + #:+ether-type-snmp+ + #:+ether-type-ip6+ + #:+ether-type-ppp+ + #:+ether-type-mswin-heartbeat+ + #:+ether-type-loopback+ + + )) (in-package muerte.ethernet) @@ -114,20 +127,18 @@ ;;; -(define-named-integer ether-type (:export-constants t) - ;; http://www.iana.org/assignments/ethernet-numbers - ;; These are just a random selection, really. - (#x0800 ip4) - (#x0804 chaosnet) - (#x0806 arp) - (#x081c symbolics) - (#x0835 rarp) - (#x814c snmp) - (#x86dd ip6) - (#x880b ppp) - ;; http://www.microsoft.com/technet/treeview/default.asp?url=/TechNet/prodtechnol/windows2000serv/deploy/confeat/nlbovw.asp - (#x886f mswin-heartbeat) - (#x9000 loopback)) +(defconstant +ether-type-ip4+ #x0800) +(defconstant +ether-type-chaosnet+ #x0804) +(defconstant +ether-type-arp+ #x0806) +(defconstant +ether-type-symbolics+ #x081c) +(defconstant +ether-type-rarp+ #x0835) +(defconstant +ether-type-snmp+ #x814c) +(defconstant +ether-type-ip6+ #x86dd) +(defconstant +ether-type-ppp+ #x880b) +;; http://www.microsoft.com/technet/treeview/default.asp? +;; url=/TechNet/prodtechnol/windows2000serv/deploy/confeat/nlbovw.asp +(defconstant +ether-type-mswin-heartbeat+ #x886f) +(defconstant +ether-type-loopback+ #x9000) ;;; From ffjeld at common-lisp.net Thu Dec 9 14:20:15 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:20:15 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: <20041209142015.37D4D885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30671 Modified Files: basic-macros.lisp Log Message: Fixed defpackage macro a bit, for CLisp compatibility. Date: Thu Dec 9 15:20:14 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.52 movitz/losp/muerte/basic-macros.lisp:1.53 --- movitz/losp/muerte/basic-macros.lisp:1.52 Thu Nov 25 19:05:32 2004 +++ movitz/losp/muerte/basic-macros.lisp Thu Dec 9 15:20:14 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.52 2004/11/25 18:05:32 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.53 2004/12/09 14:20:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -70,14 +70,16 @@ ,(cons 'cl:progn body))) (defmacro defpackage (package-name &rest options) - (let ((uses (if (not (assoc :use options)) - (list 'muerte.cl) - (cdr (assoc :use options))))) + (let ((uses (union (if (not (assoc :use options)) + (list 'muerte.cl) + (cdr (assoc :use options))) + (when (find-package package-name) + (mapcar #'package-name (package-use-list package-name)))))) (setf uses (mapcar (lambda (use) (if (member use (cons :common-lisp (package-nicknames :common-lisp)) :test #'string=) :muerte.cl - use)) + use)) uses)) (when (or (member :muerte.cl uses :test #'string=) (member :muerte.common-lisp uses :test #'string=)) @@ -85,7 +87,7 @@ (let ((movitz-options (cons (cons :use uses) (remove :use options :key #'car)))) `(eval-when (:compile-toplevel) - (defpackage ,package-name , at movitz-options))))) + (defpackage ,package-name , at movitz-options))))) (defmacro cond (&rest clauses) (if (null clauses) @@ -873,16 +875,19 @@ (if (not (movitz:movitz-constantp symbol env)) form (let* ((type (movitz:movitz-eval symbol env)) - (cl-type (movitz::translate-program type :muerte.cl :cl))) + (movitz-type (movitz-program type)) + (cl-type (host-program type))) (cond ((eq t cl-type) `(load-global-constant the-class-t)) - ((member type (movitz::image-classes-map movitz:*image*)) + ((member movitz-type (movitz::image-classes-map movitz:*image*)) `(with-inline-assembly (:returns :register) (:globally (:movl (:edi (:edi-offset classes)) (:result-register))) - (:movl ((:result-register) ,(movitz::class-object-offset type)) + (:movl ((:result-register) ,(movitz::class-object-offset movitz-type)) (:result-register)))) - (t (warn "unknown find-class: ~A" cl-type) + (t (warn "unknown find-class: ~S [~S] [~S]" cl-type + (and (symbolp cl-type) (symbol-package cl-type)) + (and (symbolp movitz-type) (symbol-package movitz-type))) form)) #+ignore (case cl-type From ffjeld at common-lisp.net Thu Dec 9 14:20:44 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 15:20:44 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: <20041209142044.8372D885F1@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30693 Modified Files: more-macros.lisp Log Message: *** empty log message *** Date: Thu Dec 9 15:20:43 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.21 movitz/losp/muerte/more-macros.lisp:1.22 --- movitz/losp/muerte/more-macros.lisp:1.21 Sat Nov 20 18:36:07 2004 +++ movitz/losp/muerte/more-macros.lisp Thu Dec 9 15:20:43 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.21 2004/11/20 17:36:07 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.22 2004/12/09 14:20:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -380,7 +380,7 @@ (defmacro without-interrupts (&body body) (let ((var (gensym "interrupts-enabled-p-"))) - `(let ((,var (logbitp ,(position :if +eflags-map+) (eflags)))) + `(let ((,var (logbitp ,(position :if (symbol-value '+eflags-map+)) (eflags)))) (unwind-protect (progn (cli) , at body) (when ,var (sti)))))) From ffjeld at common-lisp.net Thu Dec 9 22:45:41 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 9 Dec 2004 23:45:41 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: <20041209224541.287A288509@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23840 Modified Files: special-operators-cl.lisp Log Message: *** empty log message *** Date: Thu Dec 9 23:45:37 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.38 movitz/special-operators-cl.lisp:1.39 --- movitz/special-operators-cl.lisp:1.38 Tue Nov 23 17:12:25 2004 +++ movitz/special-operators-cl.lisp Thu Dec 9 23:45:36 2004 @@ -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.38 2004/11/23 16:12:25 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.39 2004/12/09 22:45:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -313,7 +313,7 @@ `((:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context 'dynamic-variable-install)))) (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) - (if (not recompile-body-p) + (if (or nil (not recompile-body-p)) body-code (progn #+ignore (warn "recompile..") ; XXX (compile-body))) @@ -659,7 +659,6 @@ (lexical-catch-tag-variable (gensym "tagbody-lexical-catch-tag-")) (label-set-name (gensym "label-set-")) (tagbody-env (make-instance 'tagbody-env - :label-set-name label-set-name :uplink env :funobj funobj :save-esp-variable save-esp-variable From ffjeld at common-lisp.net Fri Dec 10 12:46:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 10 Dec 2004 13:46:35 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20041210124635.4B0CA884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1616 Modified Files: compiler.lisp Log Message: Just some testing stuff. Date: Fri Dec 10 13:46:31 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.118 movitz/compiler.lisp:1.119 --- movitz/compiler.lisp:1.118 Thu Dec 9 14:36:46 2004 +++ movitz/compiler.lisp Fri Dec 10 13:46:30 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.118 2004/12/09 13:36:46 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.119 2004/12/10 12:46:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -965,6 +965,17 @@ (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." x (movitz-funobj-name funobj))))) + (let* ((a (or (cdr (assoc 'entry%1op code-symtab)) 0)) + (b (or (cdr (assoc 'entry%2op code-symtab)) a)) + (c (or (cdr (assoc 'entry%3op code-symtab)) b))) + (unless (<= a b c) + (warn "Weird code-entries: ~D, ~D, ~D." a b c)) + (unless (<= 0 a 255) + (break "entry%1: ~D" a)) + (unless (<= 0 b 2047) + (break "entry%2: ~D" b)) + (unless (<= 0 c 4095) + (break "entry%3: ~D" c))) (loop for ((entry-label slot-name)) on '((entry%1op code-vector%1op) (entry%2op code-vector%2op) (entry%3op code-vector%3op)) From ffjeld at common-lisp.net Fri Dec 10 12:46:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 10 Dec 2004 13:46:55 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: <20041210124655.72374884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1643 Modified Files: storage-types.lisp Log Message: Starting to add movitz-code-vector. Date: Fri Dec 10 13:46:54 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.44 movitz/storage-types.lisp:1.45 --- movitz/storage-types.lisp:1.44 Wed Nov 10 16:35:32 2004 +++ movitz/storage-types.lisp Fri Dec 10 13:46:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.44 2004/11/10 15:35:32 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.45 2004/12/10 12:46:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -69,7 +69,7 @@ :other 6 :symbol 7 - :old-vector #x1a + :code-vector #x1a :basic-vector #x22 :defstruct #x2a :funobj #x3a @@ -80,7 +80,6 @@ :run-time-context #x50 :illegal #x13 :infant-object #x23 - :basic-restart #x32 ) @@ -330,6 +329,27 @@ (setf (movitz-last-cdr (movitz-cdr movitz-list)) value))) ;;; movitz-vectors + +(define-binary-class movitz-code-vector (movitz-heap-object-other) + ((type + :binary-type other-type-byte + :reader movitz-vector-type + :initform :code-vector) + (blurg) + (num-elements + :binary-type word + :initarg :num-elements + :reader movitz-vector-num-elements + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word-and-print) + (data + :binary-lisp-type :label) ; data follows physically here + (symbolic-data + :initarg :symbolic-data + :initform nil + :accessor movitz-vector-symbolic-data)) + (:slot-align type #.+other-type-offset+)) + (define-binary-class movitz-basic-vector (movitz-heap-object-other) ((type From ffjeld at common-lisp.net Fri Dec 10 12:47:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 10 Dec 2004 13:47:24 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/lib/named-integers.lisp Message-ID: <20041210124724.A97BA884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv1661 Modified Files: named-integers.lisp Log Message: *** empty log message *** Date: Fri Dec 10 13:47:23 2004 Author: ffjeld Index: movitz/losp/lib/named-integers.lisp diff -u movitz/losp/lib/named-integers.lisp:1.5 movitz/losp/lib/named-integers.lisp:1.6 --- movitz/losp/lib/named-integers.lisp:1.5 Thu Dec 9 15:12:41 2004 +++ movitz/losp/lib/named-integers.lisp Fri Dec 10 13:47:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jan 4 16:13:46 2002 ;;;; -;;;; $Id: named-integers.lisp,v 1.5 2004/12/09 14:12:41 ffjeld Exp $ +;;;; $Id: named-integers.lisp,v 1.6 2004/12/10 12:47:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -85,7 +85,7 @@ ',integer-list ',name-list)))) (eval-when (:compile-toplevel) - , at constant-declarations +;;; , at constant-declarations (export ',constant-exports)) , at constant-declarations ',type-name)))) From ffjeld at common-lisp.net Fri Dec 10 12:47:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 10 Dec 2004 13:47:40 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20041210124740.7FF46884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1677 Modified Files: scavenge.lisp Log Message: Forget about old-vectors. Date: Fri Dec 10 13:47:39 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.36 movitz/losp/muerte/scavenge.lisp:1.37 --- movitz/losp/muerte/scavenge.lisp:1.36 Fri Nov 26 15:59:31 2004 +++ movitz/losp/muerte/scavenge.lisp Fri Dec 10 13:47:37 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.36 2004/11/26 14:59:31 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.37 2004/12/10 12:47:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -139,8 +139,6 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t)) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan))) - ((scavenge-typep x :old-vector) - (error "Scanned old-vector ~Z at address #x~X." x scan)) ((eq x 3) (setf *scan-last* scan) (incf scan) From ffjeld at common-lisp.net Fri Dec 10 12:48:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 10 Dec 2004 13:48:35 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/keyboard.lisp Message-ID: <20041210124835.7A630884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv1703 Modified Files: keyboard.lisp Log Message: Avoid the named-integer cruft. Date: Fri Dec 10 13:48:34 2004 Author: ffjeld Index: movitz/losp/x86-pc/keyboard.lisp diff -u movitz/losp/x86-pc/keyboard.lisp:1.5 movitz/losp/x86-pc/keyboard.lisp:1.6 --- movitz/losp/x86-pc/keyboard.lisp:1.5 Thu Dec 9 00:40:24 2004 +++ movitz/losp/x86-pc/keyboard.lisp Fri Dec 10 13:48:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 24 16:04:12 2001 ;;;; -;;;; $Id: keyboard.lisp,v 1.5 2004/12/08 23:40:24 ffjeld Exp $ +;;;; $Id: keyboard.lisp,v 1.6 2004/12/10 12:48:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -115,10 +115,9 @@ (t (values (ldb (byte 7 0) first-code) (logbitp 7 first-code)))))) -(define-named-integer qualifier (:only-constants t) - (0 shift) - (1 ctrl) - (2 alt)) +(defconstant +qualifier-shift+ 0) +(defconstant +qualifier-ctrl+ 1) +(defconstant +qualifier-alt+ 2) (defvar *qualifier-state* 0) From ffjeld at common-lisp.net Sun Dec 12 12:38:44 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 12 Dec 2004 13:38:44 +0100 (CET) Subject: [movitz-cvs] CVS update: public_html/index.html Message-ID: <20041212123844.4E4F7880A8@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv19926 Modified Files: index.html Log Message: *** empty log message *** Date: Sun Dec 12 13:38:42 2004 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.20 public_html/index.html:1.21 --- public_html/index.html:1.20 Wed Aug 18 11:27:57 2004 +++ public_html/index.html Sun Dec 12 13:38:40 2004 @@ -15,22 +15,20 @@

Most recent news

+

December 12, 2004: Various bits and pieces have been + cleaned up so that recent (2.33) CLisp can now compile Movitz kernels + just fine (mostly to do with CLisp having CL symbols with e.g. CLOS + as home package). + +

QEMU's NE2000 device seems to work ok with Movitz, both in ISA + and PCI modes. +

August 18, 2004: Movitz finally runs in QEMU, which is a very nice x86 emulator. It uses some sort of JIT technique, so it's much faster than Bochs. There was a bug in QEMU's (version 0.6.0) emulation of the x86 bounds instruction, which didn't agree with Movitz, and which is now fixed in QEMU's CVS. - -

July 8, 2004: The data-structure for vectors has been - changed. The vectors length is now represented by a fixnum, - increasing the maximum length from #xffff to - most-positive-fixnum. - -

The example GC system is changed to reflect the new vector - data-structure, so that the hard 256 KB limit on newspaces is no - more. The default size is set to 2 MB, and this newspace size is used - in the new los0.img.

For more news, see the ChangeLog. From ffjeld at common-lisp.net Mon Dec 13 11:21:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 13 Dec 2004 12:21:50 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20041213112150.C66BA884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24615 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Mon Dec 13 12:21:49 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.119 movitz/compiler.lisp:1.120 --- movitz/compiler.lisp:1.119 Fri Dec 10 13:46:30 2004 +++ movitz/compiler.lisp Mon Dec 13 12:21:48 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.119 2004/12/10 12:46:30 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.120 2004/12/13 11:21:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -86,7 +86,7 @@ (defvar *compiler-trust-user-type-declarations-p* t) -(defvar *compiling-function-name*) +(defvar *compiling-function-name* nil) (defvar muerte.cl:*compile-file-pathname* nil) (defvar *extended-code-expanders* @@ -933,8 +933,7 @@ (let ((ia-x86:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 - (ia-x86:read-proglist (append combined-code - #+ignore `((% bytes 8 0 0 0)))) + (ia-x86:read-proglist combined-code) :symtab-lookup (lambda (label) (case label @@ -951,8 +950,6 @@ (* 4 pos))))))))) (setf (movitz-funobj-symtab funobj) code-symtab) (let ((code-length (- (length code-vector) 3 -3))) -;;; (assert (not (mismatch #(0 0 0) code-vector :start2 code-length)) () -;;; "No space in code-vector was allocated for entry-points.") (setf (fill-pointer code-vector) code-length) ;; debug info (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) @@ -991,11 +988,15 @@ (mapcar #'car rest)) (vector-push 0 code-vector)))) (setf (movitz-funobj-code-vector funobj) - (make-movitz-vector (length code-vector) - :fill-pointer code-length - :element-type 'code - :initial-contents code-vector - )))) + (make-movitz-vector (length code-vector) + :fill-pointer code-length + :element-type 'code + :initial-contents code-vector) + #+ignore + (make-movitz-code-vector code-vector + (car (slot-value funobj 'code-vector%1op)) + (car (slot-value funobj 'code-vector%2op)) + (car (slot-value funobj 'code-vector%3op)))))) funobj) #+ignore @@ -2809,8 +2810,7 @@ (and (not (instruction-is i :init-lexvar)) (member binding (find-read-bindings i) :test #'binding-eql))) - (cdr init-pc) - #-sbcl :end #-sbcl 15)) + (cdr init-pc))) (binding-destination (third load-instruction)) (distance (position load-instruction (cdr init-pc)))) (multiple-value-bind (free-registers more-later-p) @@ -3020,8 +3020,7 @@ (truncate (or (position-if (lambda (i) (member b (find-read-bindings i))) - (cdr init-pc) - #-sbcl :end #-sbcl 10) + (cdr init-pc)) 15) count))))))))) ;; First, make several passes while trying to locate bindings From ffjeld at common-lisp.net Mon Dec 13 11:22:51 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 13 Dec 2004 12:22:51 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20041213112251.A0DD6884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24645 Modified Files: image.lisp Log Message: Fixed some unbound stuff. Date: Mon Dec 13 12:22:50 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.84 movitz/image.lisp:1.85 --- movitz/image.lisp:1.84 Thu Dec 9 15:04:54 2004 +++ movitz/image.lisp Mon Dec 13 12:22:50 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.84 2004/12/09 14:04:54 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.85 2004/12/13 11:22:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -824,7 +824,7 @@ that function's code-vector." (let ((code-vector (movitz-symbol-value (movitz-read name)))) - (unless (and code-vector (not (eq 'muerte::unbound code-vector))) + (unless (and code-vector (not (eq 'unbound code-vector))) (cerror "Install an empty vector instead." "Global constant primitive function ~S is not defined!" name) (setf code-vector @@ -922,7 +922,7 @@ (setf (slot-value run-time-context gcf-name) 0) (cond ((or (not gcf-funobj) - (eq 'muerte::unbound gcf-funobj)) + (eq 'unbound gcf-funobj)) (warn "Global constant function ~S is not defined!" gcf-name)) (t (check-type gcf-funobj movitz-funobj) (setf (slot-value run-time-context gcf-name) From ffjeld at common-lisp.net Mon Dec 13 11:24:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 13 Dec 2004 12:24:14 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: <20041213112414.540F8884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24668 Modified Files: storage-types.lisp Log Message: Fixed unbound. Date: Mon Dec 13 12:24:10 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.45 movitz/storage-types.lisp:1.46 --- movitz/storage-types.lisp:1.45 Fri Dec 10 13:46:52 2004 +++ movitz/storage-types.lisp Mon Dec 13 12:24:09 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.45 2004/12/10 12:46:52 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.46 2004/12/13 11:24:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -151,9 +151,12 @@ (defun movitz-read-and-intern (expr type) (ecase type (word - (if (typep expr 'movitz-object) - (movitz-intern expr) - (movitz-intern (movitz-read expr)))) + (cond + ((eq expr 'unbound) + (slot-value (image-run-time-context *image*) 'new-unbound-value)) + ((typep expr 'movitz-object) + (movitz-intern expr)) + (t (movitz-intern (movitz-read expr))))) (code-vector-word (movitz-intern-code-vector expr)))) @@ -335,13 +338,27 @@ :binary-type other-type-byte :reader movitz-vector-type :initform :code-vector) - (blurg) + (entry1 + :binary-type u8 + :initarg :entry1) (num-elements - :binary-type word + :binary-type lu16 :initarg :num-elements - :reader movitz-vector-num-elements - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed 'movitz-word-and-print) + :reader movitz-vector-num-elements) + (entry2 + :binary-type lu16 + :initarg :num-elements + :map-binary-write (lambda (x &optional type) + (declare (ignore type)) + (check-type x (unsigned-byte 14)) + (* x 4)) + :map-binary-read (lambda (x &optional type) + (declare (ignore type)) + (assert (zerop (mod x 4))) + (truncate x 4))) + (entry3 + :binary-type lu16 + :initarg :num-elements) (data :binary-lisp-type :label) ; data follows physically here (symbolic-data @@ -537,11 +554,23 @@ fill-pointer size)))) +(defun make-movitz-code-vector (code entry1 entry2 entry3) + (make-instance 'movitz-code-vector + :symbolic-data code + :num-elements (1- (ceiling (length code) 8)) + :entry1 entry1 + :entry2 entry2 + :entry3 entry3)) + +(defmethod write-binary-record ((obj movitz-code-vector) stream) + (+ (call-next-method) ; header + (loop for data across (movitz-vector-symbolic-data obj) + summing (write-binary 'u8 stream data)))) + (defun make-movitz-string (string) (make-movitz-vector (length string) :element-type 'character :initial-contents (map 'list #'identity string))) -;; (map 'list #'make-movitz-character string))) (defun movitz-stringp (x) (and (typep x '(or movitz-basic-vector)) @@ -565,7 +594,7 @@ :binary-type word :map-binary-write 'movitz-read-and-intern :map-binary-read-delayed 'movitz-word - :initform 'muerte::unbound ; + :initform 'unbound :accessor movitz-symbol-value :initarg :value) (plist @@ -883,7 +912,7 @@ (standard-gf-function ; a movitz-funobj which is called by dispatcher (in code-vector) :accessor standard-gf-function :initarg :function - :initform 'muerte::unbound + :initform 'muerte::unbound-function :binary-type word :map-binary-write 'movitz-read-and-intern-function-value) (num-required-arguments @@ -922,7 +951,7 @@ nil) (defun make-standard-gf (class slots &key lambda-list (name "unnamed") - (function 'muerte::unbound) + (function 'muerte::unbound-function) num-required-arguments classes-to-emf-table) (make-instance 'movitz-funobj-standard-gf From ffjeld at common-lisp.net Mon Dec 13 11:25:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 13 Dec 2004 12:25:46 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: <20041213112546.CC615884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24697 Modified Files: typep.lisp Log Message: Fixed deftype expander vs. CL package. Date: Mon Dec 13 12:25:44 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.39 movitz/losp/muerte/typep.lisp:1.40 --- movitz/losp/muerte/typep.lisp:1.39 Wed Nov 24 11:08:28 2004 +++ movitz/losp/muerte/typep.lisp Mon Dec 13 12:25:41 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.39 2004/11/24 10:08:28 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.40 2004/12/13 11:25:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -436,8 +436,9 @@ (format nil "~A-~A" 'deftype name))))) `(progn (eval-when (:compile-toplevel) - (unless (eq (symbol-package (cadr ',form)) (find-package :common-lisp)) - ,form) + (unless (find-symbol (symbol-name (cadr ',form)) :common-lisp) + #+ignore (eq (symbol-package (cadr ',form)) (find-package :common-lisp)) + (eval ',form)) (setf (gethash (translate-program ',name :cl :muerte.cl) *compiler-derived-typespecs*) (lambda ,lambda , at body)) From ffjeld at common-lisp.net Mon Dec 13 11:28:00 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 13 Dec 2004 12:28:00 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: <20041213112800.8B4C4884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv24723 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Mon Dec 13 12:27:59 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.33 movitz/losp/los0.lisp:1.34 --- movitz/losp/los0.lisp:1.33 Fri Nov 26 15:59:59 2004 +++ movitz/losp/los0.lisp Mon Dec 13 12:27:58 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.33 2004/11/26 14:59:59 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.34 2004/12/13 11:27:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,7 +23,7 @@ (require :lib/readline) (require :lib/toplevel) -(require :lib/net/ip6) +;; (require :lib/net/ip6) (require :lib/net/ip4) (require :lib/repl) @@ -37,7 +37,7 @@ #:muerte.readline #:muerte.toplevel #:muerte.ethernet - #:muerte.ip6 +;; #:muerte.ip6 #:muerte.ip4 #:muerte.mop #+ignore muerte.x86-pc.serial)) @@ -624,7 +624,7 @@ -s#+ignore +#+ignore (defun test-ncase (x y z) (numargs-case (1 (x) (values x 'one)) @@ -931,7 +931,7 @@ (prog () loop (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) + ((#\escape) (break "Console pager")) ((#\n #\N) ; No more (return-from paging (values))) @@ -1151,7 +1151,7 @@ (defparameter *timer-stack* nil) (defparameter *timer-prevstack* nil) (defparameter *timer-esi* nil) -(defparameter *timer-frame* #100()) +(defparameter *timer-frame* #100(nil)) (defparameter *timer-base* 2) (defparameter *timer-variation* 1000) @@ -1281,7 +1281,7 @@ :quiet t :mac (muerte.ip4::polling-arp :129.242.16.1 (lambda () - (eql #\esc (muerte.x86-pc.keyboard:poll-char))))))) + (eql #\escape (muerte.x86-pc.keyboard:poll-char))))))) (defun mumbojumbo (x) (with-inline-assembly (:returns :eax) @@ -1436,7 +1436,7 @@ (when (receive outside buffer) (transmit inside buffer)) (case (muerte.x86-pc.keyboard:poll-char) - (#\esc (break "Under the bridge.")) + (#\escape (break "Under the bridge.")) (#\e (error "this is an error!")))))))) From ffjeld at common-lisp.net Mon Dec 13 17:10:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 13 Dec 2004 18:10:37 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20041213171037.32FB2884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9675 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Mon Dec 13 18:10:33 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.120 movitz/compiler.lisp:1.121 --- movitz/compiler.lisp:1.120 Mon Dec 13 12:21:48 2004 +++ movitz/compiler.lisp Mon Dec 13 18:10:32 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.120 2004/12/13 11:21:48 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.121 2004/12/13 17:10:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -988,15 +988,15 @@ (mapcar #'car rest)) (vector-push 0 code-vector)))) (setf (movitz-funobj-code-vector funobj) + #+ignore (make-movitz-vector (length code-vector) :fill-pointer code-length :element-type 'code :initial-contents code-vector) - #+ignore (make-movitz-code-vector code-vector - (car (slot-value funobj 'code-vector%1op)) - (car (slot-value funobj 'code-vector%2op)) - (car (slot-value funobj 'code-vector%3op)))))) + (slot-value funobj 'code-vector%1op) + (slot-value funobj 'code-vector%2op) + (slot-value funobj 'code-vector%3op))))) funobj) #+ignore From ffjeld at common-lisp.net Tue Dec 14 16:21:03 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 14 Dec 2004 17:21:03 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: <20041214162103.342C5885E4@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16137 Modified Files: functions.lisp Log Message: *** empty log message *** Date: Tue Dec 14 17:20:57 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.24 movitz/losp/muerte/functions.lisp:1.25 --- movitz/losp/muerte/functions.lisp:1.24 Thu Oct 21 22:34:04 2004 +++ movitz/losp/muerte/functions.lisp Tue Dec 14 17:20:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.24 2004/10/21 20:34:04 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.25 2004/12/14 16:20:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,7 +18,7 @@ (require :muerte/setf) (provide :muerte/functions) -(In-package muerte) +(in-package muerte) (defun identity (x) x) From ffjeld at common-lisp.net Tue Dec 14 16:22:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 14 Dec 2004 17:22:14 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: <20041214162214.255E2885E4@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16187 Modified Files: primitive-functions.lisp Log Message: *** empty log message *** Date: Tue Dec 14 17:22:10 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.57 movitz/losp/muerte/primitive-functions.lisp:1.58 --- movitz/losp/muerte/primitive-functions.lisp:1.57 Thu Nov 25 19:06:02 2004 +++ movitz/losp/muerte/primitive-functions.lisp Tue Dec 14 17:22:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.57 2004/11/25 18:06:02 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.58 2004/12/14 16:22:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,6 +18,18 @@ (provide :muerte/primitive-functions) (in-package muerte) + +(defconstant +funobj-trampoline-table+ + #(trampoline-funcall%1op + trampoline-funcall%2op + trampoline-funcall%3op + trampoline-cl-dispatch-1or2 + assert-1arg + assert-2args + assert-3args + decode-args-1or2)) + +(defconstant +funobj-trampoline-table-size+ 16) (define-primitive-function trampoline-funcall%1op () "Call a function with 1 argument" From ffjeld at common-lisp.net Wed Dec 15 13:58:05 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 15 Dec 2004 14:58:05 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20041215135805.EE76F88649@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14262 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Wed Dec 15 14:58:04 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.121 movitz/compiler.lisp:1.122 --- movitz/compiler.lisp:1.121 Mon Dec 13 18:10:32 2004 +++ movitz/compiler.lisp Wed Dec 15 14:58:04 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.121 2004/12/13 17:10:32 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.122 2004/12/15 13:58:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -988,11 +988,11 @@ (mapcar #'car rest)) (vector-push 0 code-vector)))) (setf (movitz-funobj-code-vector funobj) - #+ignore (make-movitz-vector (length code-vector) :fill-pointer code-length :element-type 'code :initial-contents code-vector) + #+ignore (make-movitz-code-vector code-vector (slot-value funobj 'code-vector%1op) (slot-value funobj 'code-vector%2op) From ffjeld at common-lisp.net Wed Dec 15 13:58:20 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 15 Dec 2004 14:58:20 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20041215135820.7C22C88649@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14281 Modified Files: image.lisp Log Message: *** empty log message *** Date: Wed Dec 15 14:58:15 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.85 movitz/image.lisp:1.86 --- movitz/image.lisp:1.85 Mon Dec 13 12:22:50 2004 +++ movitz/image.lisp Wed Dec 15 14:58:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.85 2004/12/13 11:22:50 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.86 2004/12/15 13:58:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -847,6 +847,7 @@ *image*) (defun set-file-position (stream position &optional who) + (declare (ignore who)) (or (ignore-errors (file-position stream position)) (let* ((end (file-position stream :end)) (diff (- position end))) From ffjeld at common-lisp.net Wed Dec 15 13:58:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 15 Dec 2004 14:58:29 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: <20041215135829.202E588649@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv14307 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Wed Dec 15 14:58:27 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.34 movitz/losp/los0.lisp:1.35 --- movitz/losp/los0.lisp:1.34 Mon Dec 13 12:27:58 2004 +++ movitz/losp/los0.lisp Wed Dec 15 14:58:26 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.34 2004/12/13 11:27:58 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.35 2004/12/15 13:58:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1187,6 +1187,8 @@ ;;; (vector-push code-vector ts)))) ;; (muerte::cli) (pic8259-end-of-interrupt 0) + (when (eql #\esc (muerte.x86-pc.keyboard:poll-char)) + (break "Test-timer keyboard break.")) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) From ffjeld at common-lisp.net Wed Dec 15 13:58:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 15 Dec 2004 14:58:35 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: <20041215135835.AAFFD8864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14326 Modified Files: sequences.lisp Log Message: *** empty log message *** Date: Wed Dec 15 14:58:34 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.18 movitz/losp/muerte/sequences.lisp:1.19 --- movitz/losp/muerte/sequences.lisp:1.18 Thu Sep 2 11:44:15 2004 +++ movitz/losp/muerte/sequences.lisp Wed Dec 15 14:58:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.18 2004/09/02 09:44:15 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.19 2004/12/15 13:58:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -684,12 +684,24 @@ (defun fill (sequence item &key (start 0) end) "=> sequence" - (sequence-dispatch sequence + (etypecase sequence (list (do ((p (nthcdr start sequence) (cdr p)) (i start (1+ i))) ((or (null p) (and end (>= i end)))) (setf (car p) item))) + ((simple-array (unsigned-byte 32) 1) + (let* ((length (array-dimension sequence 0)) + (end (or end length))) + (unless (<= 0 end length) + (error 'index-out-of-range :index end :range length)) + (do ((i start (1+ i))) + ((>= i end)) + (declare (type index i)) + (setf (memref sequence (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index i + :type :unsigned-byte32) + item)))) (vector (let ((end (or end (length sequence)))) (with-subvector-accessor (sequence-ref sequence start end) From ffjeld at common-lisp.net Mon Dec 20 10:51:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 20 Dec 2004 11:51:54 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp Message-ID: <20041220105154.CCE3B884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11821 Modified Files: basic-functions.lisp Log Message: Removed dead code. Date: Mon Dec 20 11:51:53 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.14 movitz/losp/muerte/basic-functions.lisp:1.15 --- movitz/losp/muerte/basic-functions.lisp:1.14 Fri Nov 12 15:51:56 2004 +++ movitz/losp/muerte/basic-functions.lisp Mon Dec 20 11:51:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.14 2004/11/12 14:51:56 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.15 2004/12/20 10:51:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,29 +68,6 @@ (:xorl :ecx :ecx) (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector))))) -#+ignore -(defun funcall%1ops (function-name arg0) - (funcall%1ops function-name arg0) ; compiler-macro - #+ignore (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :esi) (etypecase function-name - (symbol (symbol-function function-name)) - (compiled-function function-name))) - (:compile-form (:result-mode :edx) function-name) - (:compile-form (:result-mode :eax) arg0) - (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) - -#+ignore -(defun funcall%2ops (function arg0 arg1) - (funcall%2ops function arg0 arg1) ; compiler-macro. - #+ignore (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :esi) (etypecase function - (symbol (symbol-function function)) - (compiled-function function))) - (:compile-form (:result-mode :edx) function) - (:compile-form (:result-mode :eax) arg0) - (:compile-form (:result-mode :ebx) arg1) - (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))))) - (defun funcall (function-or-name &rest args) (numargs-case (1 (function-or-name) From ffjeld at common-lisp.net Mon Dec 20 10:53:49 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 20 Dec 2004 11:53:49 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: <20041220105349.A2989884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11859 Modified Files: storage-types.lisp Log Message: *** empty log message *** Date: Mon Dec 20 11:53:47 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.46 movitz/storage-types.lisp:1.47 --- movitz/storage-types.lisp:1.46 Mon Dec 13 12:24:09 2004 +++ movitz/storage-types.lisp Mon Dec 20 11:53:47 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.46 2004/12/13 11:24:09 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.47 2004/12/20 10:53:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -69,7 +69,6 @@ :other 6 :symbol 7 - :code-vector #x1a :basic-vector #x22 :defstruct #x2a :funobj #x3a @@ -333,41 +332,6 @@ ;;; movitz-vectors -(define-binary-class movitz-code-vector (movitz-heap-object-other) - ((type - :binary-type other-type-byte - :reader movitz-vector-type - :initform :code-vector) - (entry1 - :binary-type u8 - :initarg :entry1) - (num-elements - :binary-type lu16 - :initarg :num-elements - :reader movitz-vector-num-elements) - (entry2 - :binary-type lu16 - :initarg :num-elements - :map-binary-write (lambda (x &optional type) - (declare (ignore type)) - (check-type x (unsigned-byte 14)) - (* x 4)) - :map-binary-read (lambda (x &optional type) - (declare (ignore type)) - (assert (zerop (mod x 4))) - (truncate x 4))) - (entry3 - :binary-type lu16 - :initarg :num-elements) - (data - :binary-lisp-type :label) ; data follows physically here - (symbolic-data - :initarg :symbolic-data - :initform nil - :accessor movitz-vector-symbolic-data)) - (:slot-align type #.+other-type-offset+)) - - (define-binary-class movitz-basic-vector (movitz-heap-object-other) ((type :binary-type other-type-byte @@ -553,19 +517,6 @@ :fill-pointer (if (integerp fill-pointer) fill-pointer size)))) - -(defun make-movitz-code-vector (code entry1 entry2 entry3) - (make-instance 'movitz-code-vector - :symbolic-data code - :num-elements (1- (ceiling (length code) 8)) - :entry1 entry1 - :entry2 entry2 - :entry3 entry3)) - -(defmethod write-binary-record ((obj movitz-code-vector) stream) - (+ (call-next-method) ; header - (loop for data across (movitz-vector-symbolic-data obj) - summing (write-binary 'u8 stream data)))) (defun make-movitz-string (string) (make-movitz-vector (length string) From ffjeld at common-lisp.net Mon Dec 20 13:42:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 20 Dec 2004 14:42:52 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20041220134252.08C9F884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20219 Modified Files: los-closette.lisp Log Message: Fixed typo in "bootstrap". Date: Mon Dec 20 14:42:51 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.23 movitz/losp/muerte/los-closette.lisp:1.24 --- movitz/losp/muerte/los-closette.lisp:1.23 Tue Nov 23 17:06:37 2004 +++ movitz/losp/muerte/los-closette.lisp Mon Dec 20 14:42:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.23 2004/11/23 16:06:37 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.24 2004/12/20 13:42:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -786,8 +786,8 @@ (let ((x (std-gf-classes-to-emf-table gf))) (cond ((not x) - (unless (get 'clos-bootsrap 'breaking-on-auto-bootstrap) - (setf (get 'clos-bootsrap 'breaking-on-auto-bootstrap) t) + (unless (get 'clos-bootstrap 'breaking-on-auto-bootstrap) + (setf (get 'clos-bootstrap 'breaking-on-auto-bootstrap) t) (break "Auto-bootstrapping CLOS.")) (clos-bootstrap) (unless (get 'clos-bootstrap 'have-bootstrapped) From ffjeld at common-lisp.net Tue Dec 21 14:23:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 21 Dec 2004 15:23:50 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20041221142350.03808884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30619 Modified Files: compiler.lisp Log Message: Add a check for whether (middle-of) code-vectors can look like code-vector headers. Date: Tue Dec 21 15:23:50 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.122 movitz/compiler.lisp:1.123 --- movitz/compiler.lisp:1.122 Wed Dec 15 14:58:04 2004 +++ movitz/compiler.lisp Tue Dec 21 15:23:49 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.122 2004/12/15 13:58:04 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.123 2004/12/21 14:23:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -987,6 +987,7 @@ ((some (lambda (label) (assoc label code-symtab)) (mapcar #'car rest)) (vector-push 0 code-vector)))) + (check-locate-concistency code-vector) (setf (movitz-funobj-code-vector funobj) (make-movitz-vector (length code-vector) :fill-pointer code-length @@ -998,6 +999,13 @@ (slot-value funobj 'code-vector%2op) (slot-value funobj 'code-vector%3op))))) funobj) + +(defun check-locate-concistency (code-vector) + (loop for x from 0 below (length code-vector) by 8 + do (when (and (= (tag :basic-vector) (aref code-vector x)) + (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x)))) + (break "Code-vector can break %find-code-vector at offset ~D." x))) + (values)) #+ignore (defun make-compiled-function-body-default (form funobj env top-level-p) From ffjeld at common-lisp.net Tue Dec 21 14:27:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 21 Dec 2004 15:27:10 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: <20041221142710.8B794884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30652 Modified Files: inspect.lisp Log Message: Added %find-code-vector. Date: Tue Dec 21 15:27:09 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.44 movitz/losp/muerte/inspect.lisp:1.45 --- movitz/losp/muerte/inspect.lisp:1.44 Tue Nov 23 17:03:35 2004 +++ movitz/losp/muerte/inspect.lisp Tue Dec 21 15:27:09 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.44 2004/11/23 16:03:35 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.45 2004/12/21 14:27:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -163,6 +163,37 @@ (when (member :catch types) (format t "~&catch: ~Z: ~S" tag tag)))))) +(define-compiler-macro %location-object (&environment env location tag) + (assert (movitz:movitz-constantp tag env)) + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,location) + (:addl ,tag :eax))) + +(defun %find-code-vector (location &optional (stop-location (if (< location #x2000) + 0 + (- location #x2000)))) + "Find the code-vector that holds a location by searching for a code-vector object header." + (do ((l (logand location -2) (- l 2))) + ((< l stop-location) + (error "Unable to find code-vector for location ~S." location)) + (multiple-value-bind (upper30 lower2) + (memref l 0 :type :signed-byte30+2) + (when (and (= 2 lower2) + (= #.(movitz:basic-vector-type-tag :code)) + ;; If the vector has a fill-pointer, it should be equal to the length. + (multiple-value-bind (len len-tag) + (memref l 4 :type :signed-byte30+2) + (and (= 0 len-tag) + (typecase len + ((integer 0 #x3fff) + (= len (memref l 2 :type :unsigned-byte14))) + (positive-fixnum t) + (t nil))))) + (let ((code-vector (%location-object l 6))) + (check-type code-vector code-vector) + (assert (location-in-object-p code-vector location)) + (return code-vector)))))) + (defun %shallow-copy-object (object word-count) "Copy any object with size word-count." (check-type word-count (integer 2 *)) @@ -373,9 +404,10 @@ (do ((frame start-frame)) ((eq 0 frame)) (let ((uplink (stack-frame-uplink nil frame))) - (setf (stack-frame-ref copy 0 (- frame start-frame) :lisp) - (if (eql 0 uplink) - 0 - (- uplink start-frame))) + (unless (= 0 uplink) + (setf (stack-frame-ref copy 0 (- frame start-frame) :lisp) + (- uplink start-frame)) + + ) (setf frame uplink))) copy)) From ffjeld at common-lisp.net Tue Dec 21 14:28:03 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 21 Dec 2004 15:28:03 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: <20041221142803.849FD884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30735 Modified Files: memref.lisp Log Message: Fixed (memref :signed-byte30+2) Date: Tue Dec 21 15:28:02 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.39 movitz/losp/muerte/memref.lisp:1.40 --- movitz/losp/muerte/memref.lisp:1.39 Tue Nov 23 17:07:37 2004 +++ movitz/losp/muerte/memref.lisp Tue Dec 21 15:28:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.39 2004/11/23 16:07:37 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.40 2004/12/21 14:28:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -205,6 +205,33 @@ ;; Two values: the 30 upper bits as signed integer, ;; and secondly the lower 2 bits as unsigned. (assert (= 2 movitz::+movitz-fixnum-shift+)) + (let ((fix-ecx `((:leal ((:ecx 4)) :ebx) + (:andl -4 :ecx) + (:andl #b1100 :ebx) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc)))) + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :eax) ,object) + (:movl (:eax ,(offset-by 4)) :ecx) + , at fix-ecx)) + ((eq 0 offset) + `(with-inline-assembly (:returns :multiple-values) + (:compile-two-forms (:eax :ecx) ,object ,index) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + , at fix-ecx)) + (t (let ((object-var (gensym "memref-object-"))) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :ecx :type (unsigned-byte 29)) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :ecx) + , at fix-ecx)))))) + #+ignore `(with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :push) ,object) (:compile-two-forms (:ecx :ebx) ,offset ,index) @@ -242,18 +269,18 @@ (assert (= 4 movitz::+movitz-fixnum-factor+)) (cond ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :ecx :type (unsigned-byte 29)) + `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) (:compile-form (:result-mode :eax) ,object) (:movl (:eax ,(offset-by 4)) :ecx) (:andl -4 :ecx))) ((eq 0 offset) - `(with-inline-assembly (:returns :ecx :type (unsigned-byte 29)) + `(with-inline-assembly (:returns :ecx :type (signed-byte 30)) (:compile-two-forms (:eax :ecx) ,object ,index) (:movl (:eax :ecx ,(offset-by 4)) :ecx) (:andl -4 :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) - (with-inline-assembly (:returns :ecx :type (unsigned-byte 29)) + (with-inline-assembly (:returns :ecx :type (signed-byte 30)) (:compile-two-forms (:ecx :ebx) ,offset ,index) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax)