- movitz-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp
by Frode Vatvedt Fjeld 10 Nov '04

10 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22736 Modified Files: memref.lisp Log Message: Remove explicit alignment test. Date: Wed Nov 10 16:30:53 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.36 movitz/losp/muerte/memref.lisp:1.37 --- movitz/losp/muerte/memref.lisp:1.36 Thu Oct 21 22:47:26 2004 +++ movitz/losp/muerte/memref.lisp Wed Nov 10 16:30:53 2004 @@ -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.36 2004/10/21 20:47:26 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.37 2004/11/10 15:30:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -793,9 +793,9 @@ (:shll 2 :ecx) (:addl :ebx :eax) (:into) - (:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1) - :al) - (:jnz '(:sub-program () (:int 63))) +;;; (:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1) +;;; :al) +;;; (:jnz '(:sub-program () (:int 63))) (:addl :eax :ecx) (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address (,prefixes :movl (:ecx) :ecx)))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp
by Frode Vatvedt Fjeld 07 Nov '04

07 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22579 Modified Files: format.lisp Log Message: Prefer reverse over nreverse in this particular case. Date: Sun Nov 7 22:10:05 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.8 movitz/losp/muerte/format.lisp:1.9 --- movitz/losp/muerte/format.lisp:1.8 Tue Oct 12 16:42:41 2004 +++ movitz/losp/muerte/format.lisp Sun Nov 7 22:10:03 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.8 2004/10/12 14:42:41 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.9 2004/11/07 21:10:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -160,13 +160,13 @@ (write (pop args) :level nil :length nil)) (t (write (pop args))))) (#\B (format-integer (pop args) 2 at-sign-p colon-p - (nreverse prefix-parameters))) + (reverse prefix-parameters))) (#\O (format-integer (pop args) 8 at-sign-p colon-p - (nreverse prefix-parameters))) + (reverse prefix-parameters))) (#\D (format-integer (pop args) 10 at-sign-p colon-p - (nreverse prefix-parameters))) + (reverse prefix-parameters))) (#\X (format-integer (pop args) 16 at-sign-p colon-p - (nreverse prefix-parameters))) + (reverse prefix-parameters))) (#\F (apply 'format-float (pop args) at-sign-p colon-p (nreverse prefix-parameters))) (#\C (if colon-p (let ((c (pop args)))

1 0

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

07 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22469 Modified Files: arrays.lisp Log Message: Fixed svref and (setf svref) to actually enforce the index range. Also, use (movitz-type-slot-offset ..) rather than hard-coded constants a few places. Date: Sun Nov 7 22:07:59 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.46 movitz/losp/muerte/arrays.lisp:1.47 --- movitz/losp/muerte/arrays.lisp:1.46 Thu Oct 21 22:30:07 2004 +++ movitz/losp/muerte/arrays.lisp Sun Nov 7 22:07:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.46 2004/10/21 20:30:07 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.47 2004/11/07 21:07:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -445,10 +445,12 @@ ;;; simple-vector accessors (define-compiler-macro svref%unsafe (simple-vector index) - `(memref ,simple-vector 2 :index ,index)) + `(memref ,simple-vector (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index ,index)) (define-compiler-macro (setf svref%unsafe) (value simple-vector index) - `(setf (memref ,simple-vector 2 :index ,index) ,value)) + `(setf (memref ,simple-vector (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index ,index) ,value)) (defun svref%unsafe (simple-vector index) ;; (compiler-macro-call svref%unsafe simple-vector index)) @@ -460,83 +462,90 @@ (setf (svref%unsafe simple-vector index) value)) (defun svref (simple-vector index) - (etypecase simple-vector - (simple-vector - (macrolet - ((do-it () - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) simple-vector index) - (:leal (:eax ,(- (movitz::tag :other))) :ecx) - (:testb 7 :cl) - (:jne '(:sub-program (not-basic-simple-vector) - (:compile-form (:result-mode :ignore) - (error "Not a simple-vector: ~S." simple-vector)))) - (:movl (:eax ,movitz:+other-type-offset+) :ecx) - (:testb ,movitz:+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program (illegal-index) - (:compile-form (:result-mode :ignore) - (error "Illegal index: ~S." index)))) - (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx) - (:jne 'not-basic-simple-vector) - (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)) - :eax) - ))) - (do-it))))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) simple-vector index) + (:leal (:eax ,(- (movitz::tag :other))) :ecx) + (:testb 7 :cl) + (:jne '(:sub-program (not-basic-simple-vector) + (:compile-form (:result-mode :ignore) + (error "Not a simple-vector: ~S." simple-vector)))) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx) + (:jne 'not-basic-simple-vector) + (:cmpl :ebx (:eax (:offset movitz-basic-vector num-elements))) + (:jbe 'illegal-index) + (:movl (:eax :ebx (:offset movitz-basic-vector data)) :eax) + ))) + (do-it))) (defun (setf svref) (value simple-vector index) - (etypecase simple-vector - (simple-vector - (macrolet - ((do-it () - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :edx) simple-vector index) - (:leal (:ebx ,(- (movitz::tag :other))) :ecx) - (:testb 7 :cl) - (:jne '(:sub-program (not-basic-simple-vector) - (:compile-form (:result-mode :ignore) - (error "Not a simple-vector: ~S." simple-vector)))) - (:movl (:ebx ,movitz:+other-type-offset+) :ecx) - (:testb ,movitz:+movitz-fixnum-zmask+ :dl) - (:jnz '(:sub-program (illegal-index) - (:compile-form (:result-mode :ignore) - (error "Illegal index: ~S." index)))) - (:compile-form (:result-mode :eax) value) - (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx) - (:jne 'not-basic-simple-vector) - (:movl :eax - (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))))) - (do-it))))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :edx) simple-vector index) + (:leal (:ebx ,(- (movitz::tag :other))) :ecx) + (:testb 7 :cl) + (:jne '(:sub-program (not-basic-simple-vector) + (:compile-form (:result-mode :ignore) + (error "Not a simple-vector: ~S." simple-vector)))) + (:movl (:ebx ,movitz:+other-type-offset+) :ecx) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:compile-form (:result-mode :eax) value) + (:cmpw ,(movitz:basic-vector-type-tag :any-t) :cx) + (:jne 'not-basic-simple-vector) + (:cmpl :edx (:ebx (:offset movitz-basic-vector num-elements))) + (:jbe 'illegal-index) + (:movl :eax + (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))))) + (do-it))) ;;; string accessors (defun char (string index) (check-type string string) (assert (below index (array-dimension string 0))) - (memref string 2 :index index :type :character)) + (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index index :type :character)) (defun (setf char) (value string index) (assert (below index (array-dimension string 0))) - (setf (memref string 2 :index index :type :character) value)) + (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index index :type :character) value)) (defun schar (string index) (check-type string string) (assert (below index (length string))) - (memref string 2 :index index :type :character)) + (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index index + :type :character)) (defun (setf schar) (value string index) (check-type string string) (assert (below index (length string))) - (setf (aref string index) value)) + (setf (memref string (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index index :type :character) + value)) (define-compiler-macro char%unsafe (string index) - `(memref ,string 2 :index ,index :type :character)) + `(memref ,string (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index ,index :type :character)) (defun char%unsafe (string index) (char%unsafe string index)) (define-compiler-macro (setf char%unsafe) (value string index) - `(setf (memref ,string 2 :index ,index :type :character) ,value)) + `(setf (memref ,string (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index ,index :type :character) ,value)) (defun (setf char%unsafe) (value string index) (setf (char%unsafe string index) value)) @@ -544,13 +553,15 @@ ;;; u8 accessors (define-compiler-macro u8ref%unsafe (vector index) - `(memref ,vector 2 :index ,index :type :unsigned-byte8)) + `(memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index ,index :type :unsigned-byte8)) (defun u8ref%unsafe (vector index) (u8ref%unsafe vector index)) (define-compiler-macro (setf u8ref%unsafe) (value vector index) - `(setf (memref ,vector 2 :index ,index :type :unsigned-byte8) ,value)) + `(setf (memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index ,index :type :unsigned-byte8) ,value)) (defun (setf u8ref%unsafe) (value vector index) (setf (u8ref%unsafe vector index) value)) @@ -558,7 +569,8 @@ ;;; u32 accessors (define-compiler-macro u32ref%unsafe (vector index) - `(memref ,vector 2 :index ,index :type :unsigned-byte32)) + `(memref ,vector (movitz-type-slot-offset 'movitz-basic-vector 'data) + :index ,index :type :unsigned-byte32)) (defun u32ref%unsafe (vector index) (compiler-macro-call u32ref%unsafe vector index))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 02 Nov '04

02 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4705 Modified Files: image.lisp Log Message: Improved support for changing image's ds-segment-base etc. There were some bugs in offset calculations etc. Date: Tue Nov 2 16:53:31 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.72 movitz/image.lisp:1.73 --- movitz/image.lisp:1.72 Thu Oct 21 22:40:32 2004 +++ movitz/image.lisp Tue Nov 2 16:53:30 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.72 2004/10/21 20:40:32 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.73 2004/11/02 15:53:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -430,28 +430,31 @@ (segment-descriptor-global-data ; 2: true flat data segment :binary-type segment-descriptor :initform (make-segment-descriptor :base 0 :limit #xfffff ; data segment - :type 2 :dpl 0 + :type 2 :dpl 3 :flags '(s p d/b g))) (segment-descriptor-shifted-code ; 3: 1 MB shifted flat code segment :binary-type segment-descriptor - :initform (make-segment-descriptor :base (image-start-address *image*) + :initform (make-segment-descriptor :base (image-cs-segment-base *image*) :limit #xfff00 :type 10 :dpl 0 :flags '(s p d/b g))) (segment-descriptor-shifted-data ; 4: 1 MB shifted flat data segment :binary-type segment-descriptor - :initform (make-segment-descriptor :base (image-start-address *image*) + :initform (make-segment-descriptor :base (image-ds-segment-base *image*) :limit #xfff00 ; data segment - :type 2 :dpl 0 + :type 2 :dpl 3 :flags '(s p d/b g))) (segment-descriptor-thread-context ; 5: same as normal shifted-data for initial context. :binary-type segment-descriptor - :initform (make-segment-descriptor :base (image-start-address *image*) + :initform (make-segment-descriptor :base (image-ds-segment-base *image*) :limit #xfff00 ; data segment :type 2 :dpl 0 :flags '(s p d/b g))) - (segment-descriptor-6 + (segment-descriptor-stack ; 6: same as normal shifted-data, DPL=0 :binary-type segment-descriptor - :initform (make-segment-descriptor)) + :initform (make-segment-descriptor :base (image-ds-segment-base *image*) + :limit #xfff00 ; data segment + :type 2 :dpl 0 + :flags '(s p d/b g))) (segment-descriptor-7 :binary-type segment-descriptor :initform (make-segment-descriptor)) @@ -520,9 +523,11 @@ (defclass movitz-image () ((ds-segment-base + :initarg :ds-segment-base :initform #x100000 :accessor image-ds-segment-base) (cs-segment-base + :initarg :cs-segment-base :initform #x100000 :accessor image-cs-segment-base))) @@ -776,18 +781,21 @@ x) y)) -(defun make-movitz-image (start-address) - (let ((*image* (make-instance 'symbolic-image - :nil-object (make-movitz-nil) - :start-address start-address - :movitz-features '(:movitz) - :function-code-sizes - (if (boundp '*image*) - (copy-hash-table (function-code-sizes *image*)) - (make-hash-table :test #'equal))))) +(defun make-movitz-image (&rest init-args &key start-address &allow-other-keys) + (let ((*image* (apply #'make-instance 'symbolic-image + :nil-object (make-movitz-nil) + :start-address start-address + :movitz-features '(:movitz) + :function-code-sizes + (if (boundp '*image*) + (copy-hash-table (function-code-sizes *image*)) + (make-hash-table :test #'equal)) + init-args))) (setf (image-nil-word *image*) (+ 5 (- (slot-offset 'movitz-run-time-context 'null-symbol) - (slot-offset 'movitz-run-time-context 'run-time-context-start)))) + (slot-offset 'movitz-run-time-context 'run-time-context-start)) + (- start-address + (image-ds-segment-base *image*)))) (format t "~&;; NIL value: #x~X.~%" (image-nil-word *image*)) (assert (eq :null (extract-tag (image-nil-word *image*))) () "NIL value #x~X has tag ~D, but it must be ~D." @@ -817,9 +825,13 @@ (check-type code-vector movitz-basic-vector) code-vector)) -(defun create-image (&key (init-file *default-image-init-file*) - (start-address #x100000)) - (psetq *image* (let ((*image* (make-movitz-image start-address))) +(defun create-image (&rest init-args + &key (init-file *default-image-init-file*) + ;; (start-address #x100000) + &allow-other-keys) + (psetq *image* (let ((*image* (apply #'make-movitz-image + :start-address #x100000 + init-args))) (when init-file (movitz-compile-file init-file)) *image*) @@ -1048,12 +1060,16 @@ summing (let ((obj (image-memref image p nil))) (cond - ((not obj) 0) + ((not obj) 0) ; (+ 1mb (- 1mb)) vs. (+ 0 (- 1mb 1mb)) (t (let ((new-pos (+ p file-start-position - (- (image-start-address image) - (image-ds-segment-base image))))) - (incf pad-size (- new-pos (file-position stream))) - (file-position stream new-pos)) + (- (image-ds-segment-base image) + (image-start-address image))))) + (let ((pad-delta (- new-pos (file-position stream)))) + (with-simple-restart (continue "Never mind.") + (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))) ;; (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))) @@ -1590,11 +1606,12 @@ (:movw ,(* 4 8) :cx) (:movw :cx :ds) (:movw :cx :es) - (:movw :cx :ss) (:movw ,(* 2 8) :cx) (:movw :cx :gs) ; global context segment (:movw ,(* 5 8) :cx) (:movw :cx :fs) ; thread context segment + (:movw ,(* 6 8) :cx) + (:movw :cx :ss) ; stack segment (:movl ,(image-nil-word *image*) :edi) (:globally (:movl (:edi (:edi-offset stack-top)) :esp))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp
by Frode Vatvedt Fjeld 02 Nov '04

02 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4672 Modified Files: conditions.lisp Log Message: For "unseen throw tag" condition, print tag by ~S rather than ~Z. Date: Tue Nov 2 16:52:21 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.12 movitz/losp/muerte/conditions.lisp:1.13 --- movitz/losp/muerte/conditions.lisp:1.12 Mon Aug 23 15:58:19 2004 +++ movitz/losp/muerte/conditions.lisp Tue Nov 2 16:52:21 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.12 2004/08/23 13:58:19 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.13 2004/11/02 15:52:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -117,7 +117,7 @@ :initarg :tag :reader throw-error-tag)) (:report (lambda (c s) - (format s "Cannot throw to tag ~Z." (throw-error-tag c))))) + (format s "Cannot throw to tag `~S'." (throw-error-tag c))))) (define-condition wrong-argument-count (program-error) ((function

1 0

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

22 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3953 Modified Files: eval.lisp Log Message: Added interpretation of the catch special operator. Date: Fri Oct 22 14:33:28 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.13 movitz/losp/muerte/eval.lisp:1.14 --- movitz/losp/muerte/eval.lisp:1.13 Fri Oct 22 14:31:34 2004 +++ movitz/losp/muerte/eval.lisp Fri Oct 22 14:33:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.13 2004/10/22 12:31:34 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.14 2004/10/22 12:33:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -99,6 +99,9 @@ (make-destructuring-env (cadr form) (eval-form (caddr form) env) env))) + ((catch) + (catch (eval-form (second form) env) + (eval-progn (cddr form) env))) ((throw) (throw (eval-form (second form) env) (eval-form (third form) env)))

1 0

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

22 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3927 Modified Files: eval.lisp Log Message: Added parse-docstring-declarations-and-body, and made the parsing of lambda-forms use it, so that e.g. (lambda (..) "docstring" (declare ..) ..) should now work in eval. Date: Fri Oct 22 14:31:34 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.12 movitz/losp/muerte/eval.lisp:1.13 --- movitz/losp/muerte/eval.lisp:1.12 Thu Oct 21 22:45:48 2004 +++ movitz/losp/muerte/eval.lisp Fri Oct 22 14:31:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.12 2004/10/21 20:45:48 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.13 2004/10/22 12:31:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -152,6 +152,16 @@ (dolist (d (cdar p)) (push d declarations)))) +(defun parse-docstring-declarations-and-body (forms) + "From the list of FORMS, return first the list of non-declaration forms, ~ +second the list of declaration-specifiers, third any docstring." + (if (or (not (cdr forms)) + (not (stringp (car forms)))) + (parse-declarations-and-body forms) + (multiple-value-call #'values + (parse-declarations-and-body (cdr forms)) + (car forms)))) + (defun declared-special-p (var declarations) (dolist (d declarations nil) (when (and (consp d) @@ -315,7 +325,7 @@ (symbol-function (lookup-setf-function (second function-name)))) ((lambda) (let ((lambda-list (cadr function-name)) - (lambda-body (cddr function-name))) + (lambda-body (parse-docstring-declarations-and-body (cddr function-name)))) (install-funobj-name :anonymous-lambda (lambda (&rest args) (declare (dynamic-extent args))

1 0

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

22 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17455 Modified Files: scavenge.lisp Log Message: Remove the *scan* variable that was used for debugging before. Also improve detection of non-pointers in the scanner. Date: Fri Oct 22 09:57:25 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.33 movitz/losp/muerte/scavenge.lisp:1.34 --- movitz/losp/muerte/scavenge.lisp:1.33 Mon Oct 11 15:53:25 2004 +++ movitz/losp/muerte/scavenge.lisp Fri Oct 22 09:57:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.33 2004/10/11 13:53:25 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.34 2004/10/22 07:57:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -48,12 +48,13 @@ ((>= scan end-location)) (with-simple-restart (continue-map-heap-words "Continue map-heap-words at location ~S." (1+ scan)) - (let ((*scan* scan) - (x (memref scan 0 :type :unsigned-byte16))) - (declare (special *scan*)) + (let ((x (memref scan 0 :type :unsigned-byte16)) + (x2 (memref scan 1 :type :unsigned-byte16))) (when verbose (format *terminal-io* " [at ~S: ~S]" scan x)) (cond + ((or (and (= 0 x2) (= 2 x)) + (and (= #xffff x2) (= #xfffe x)))) ((let ((tag (ldb (byte 3 0) x))) (or (= tag #.(movitz:tag :null)) (= tag #.(movitz:tag :even-fixnum))

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp
by Frode Vatvedt Fjeld 21 Oct '04

21 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv4654 Modified Files: ip4.lisp Log Message: *** empty log message *** Date: Thu Oct 21 22:52:11 2004 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.6 movitz/losp/lib/net/ip4.lisp:1.7 --- movitz/losp/lib/net/ip4.lisp:1.6 Thu Apr 1 19:29:44 2004 +++ movitz/losp/lib/net/ip4.lisp Thu Oct 21 22:52:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.6 2004/04/01 17:29:44 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.7 2004/10/21 20:52:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -252,10 +252,27 @@ ;;;; UDP +(defun udp-src-port (packet &optional (start 34)) + (bvref-u16 packet start 0)) + +(defun (setf udp-src-port) (value packet &optional (start 34)) + (setf (bvref-u16 packet start 0) value)) + +(defun udp-dst-port (packet &optional (start 34)) + (bvref-u16 packet start 2)) + +(defun udp-length (packet &optional (start 34)) + (bvref-u16 packet start 4)) + +(defun udp-checksum (packet &optional (start 34)) + (bvref-u16 packet start 6)) + + (defmethod udp-input ((stack ip4-stack) packet ip-start udp-start) (warn "Got UDP packet of length ~D from ~@v/ip4:pprint-ip4/." (- (length packet) udp-start) ip-start packet)) + ;;;; TCP

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp
by Frode Vatvedt Fjeld 21 Oct '04

21 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4631 Modified Files: segments.lisp Log Message: Add operator control-register to read the x86 CPU's control registers. Date: Thu Oct 21 22:51:13 2004 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.3 movitz/losp/muerte/segments.lisp:1.4 --- movitz/losp/muerte/segments.lisp:1.3 Tue Apr 6 16:32:00 2004 +++ movitz/losp/muerte/segments.lisp Thu Oct 21 22:51:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.3 2004/04/06 14:32:00 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.4 2004/10/21 20:51:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -90,6 +90,16 @@ (:lgdt (:ecx)))) ;;; + +(defun control-register (name) + (macrolet ((creg (reg) + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:movcr ,reg :ecx)))) + (ecase name + (:cr0 (creg :cr0)) + (:cr2 (creg :cr2)) + (:cr3 (creg :cr3)) + (:cr4 (creg :cr4))))) (defun control-register-lo12 (name) "Return the low 12 bits of an x86 control register, such as :cr0 or :cr1."

1 0