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

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

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10917 Modified Files: memref.lisp Log Message: Various improvements to memref and (setf memref). Date: Tue Apr 6 10:25:44 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.9 movitz/losp/muerte/memref.lisp:1.10 --- movitz/losp/muerte/memref.lisp:1.9 Wed Mar 31 21:13:27 2004 +++ movitz/losp/muerte/memref.lisp Tue Apr 6 10:25:44 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.9 2004/04/01 02:13:27 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.10 2004/04/06 14:25:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,30 +21,40 @@ (define-compiler-macro memref (&whole form object offset index type &environment env) (if (not (movitz:movitz-constantp type env)) form - (labels ((extract-constant-delta (form) - "Try to extract at compile-time an integer offset from form." - (cond - ((movitz:movitz-constantp form env) - (let ((x (movitz:movitz-eval form env))) - (check-type x integer) - (values x 0))) - ((not (consp form)) - (values 0 form)) - (t (case (car form) - (1+ (values 1 (second form))) - (1- (values -1 (second form))) - (+ (case (length form) - (1 (values 0 0)) - (2 (values 0 (second form))) - (t (loop with x = 0 and f = nil for sub-form in (cdr form) - as sub-value = (when (movitz:movitz-constantp sub-form env) - (movitz:movitz-eval sub-form env)) - do (if (integerp sub-value) - (incf x sub-value) - (push sub-form f)) - finally (return (values x (cons '+ (nreverse f)))))))) - (t #+ignore (warn "extract from: ~S" form) - (values 0 form))))))) + (labels ((sub-extract-constant-delta (form) + "Try to extract at compile-time an integer offset from form." + (cond + ((movitz:movitz-constantp form env) + (let ((x (movitz:movitz-eval form env))) + (check-type x integer) + (values x 0))) + ((not (consp form)) + (values 0 form)) + (t (case (car form) + (1+ (values 1 (second form))) + (1- (values -1 (second form))) + (+ (case (length form) + (1 (values 0 0)) + (2 (values 0 (second form))) + (t (loop with x = 0 and f = nil for sub-form in (cdr form) + as sub-value = (when (movitz:movitz-constantp sub-form env) + (movitz:movitz-eval sub-form env)) + do (if (integerp sub-value) + (incf x sub-value) + (push sub-form f)) + finally (return (values x (cons '+ (nreverse f)))))))) + (t #+ignore (warn "extract from: ~S" form) + (values 0 form)))))) + (extract-constant-delta (form) + "Try to extract at compile-time an integer offset from form, repeatedly." + (multiple-value-bind (constant-term variable-term) + (sub-extract-constant-delta form) + (if (= 0 constant-term) + (values 0 variable-term) + (multiple-value-bind (sub-constant-term sub-variable-term) + (extract-constant-delta variable-term) + (values (+ constant-term sub-constant-term) + sub-variable-term)))))) (multiple-value-bind (constant-index index) (extract-constant-delta index) (multiple-value-bind (constant-offset offset) @@ -189,7 +199,7 @@ `(let ((,object-var ,object)) (with-inline-assembly (:returns :eax) (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) @@ -259,7 +269,7 @@ (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ebx) ,object) (:movl ,value (:ebx ,(+ (movitz:movitz-eval offset env) - (* 2 (movitz:movitz-eval index env)))))) + (* 4 (movitz:movitz-eval index env)))))) ,value))) ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) @@ -321,7 +331,7 @@ `(progn (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ecx :ebx) ,index ,object) - (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) ,value))) ((movitz:movitz-constantp offset env) @@ -331,13 +341,13 @@ (with-inline-assembly (:returns :untagged-fixnum-eax) (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) - (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) `(let ((,value-var ,value)) (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :eax) - (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env))) (:andl #xff0000 :eax) @@ -397,7 +407,7 @@ `(progn (with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-two-forms (:eax :ecx) ,object ,index) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:movb ,value (:eax :ecx ,(movitz:movitz-eval offset env)))) value))) ((movitz:movitz-constantp offset env) @@ -406,7 +416,7 @@ (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :eax) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) ; value into :AH (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env)))) ,value-var)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20256 Modified Files: more-macros.lisp Log Message: Moved condition-related macros from conditions.lisp to more-macros.lisp. Date: Tue Apr 6 10:05:23 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.4 movitz/losp/muerte/more-macros.lisp:1.5 --- movitz/losp/muerte/more-macros.lisp:1.4 Thu Mar 25 20:50:32 2004 +++ movitz/losp/muerte/more-macros.lisp Tue Apr 6 10:05:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.4 2004/03/26 01:50:32 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.5 2004/04/06 14:05:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -216,3 +216,79 @@ + +(defmacro handler-bind (bindings &body forms) + (if (null bindings) + `(progn ,@forms) + (labels ((make-handler (binding) + (destructuring-bind (type handler) + binding + (cond + #+ignore + ((and (listp handler) + (eq 'lambda (first handler)) + (= 1 (length (second handler)))) + `(cons t (lambda (x) + (when (typep x ',type) + (let ((,(first (second handler)) x)) + ,@(cddr handler))) + nil))) + #+ignore + ((and (listp handler) + (eq 'function (first handler)) + (listp (second handler)) + (eq 'lambda (first (second handler))) + (= 1 (length (second (second handler))))) + (make-handler (list type (second handler)))) + (t `(cons ',type ,handler)))))) + `(let ((*active-condition-handlers* + (cons (list ,@(mapcar #'make-handler #+ignore (lambda (binding) + `(cons ',(first binding) + ,(second binding))) + bindings)) + *active-condition-handlers*))) + ,@forms)))) + +(defmacro handler-case (expression &rest clauses) + (multiple-value-bind (normal-clauses no-error-clauses) + (loop for clause in clauses + if (eq :no-error (car clause)) + collect clause into no-error-clauses + else collect clause into normal-clauses + finally (return (values normal-clauses no-error-clauses))) + (case (length no-error-clauses) + (0 (let ((block-name (gensym "handler-case-block-")) + (var-name (gensym "handler-case-var-")) + (temp-name (gensym "handler-case-temp-var-")) + (specs (mapcar (lambda (clause) + (list clause (gensym "handler-case-clause-tag-"))) + normal-clauses))) + `(block ,block-name + (let (,var-name) + (tagbody + (handler-bind ,(mapcar (lambda (clause-spec) + (let* ((clause (first clause-spec)) + (go-tag (second clause-spec)) + (typespec (first clause))) + `(,typespec (lambda (,temp-name) + (setq ,var-name ,temp-name) + (go ,go-tag))))) + specs) + (return-from ,block-name ,expression)) + ,@(mapcan (lambda (clause-spec) + (let* ((clause (first clause-spec)) + (go-tag (second clause-spec)) + (var (first (second clause))) + (body (cddr clause))) + (if (not var) + `(,go-tag (return-from ,block-name + (let () ,@body))) + `(,go-tag (return-from ,block-name + (let ((,var ,var-name)) + ,@body)))))) + specs)))))) + (t (error "Too many no-error clauses."))))) + +(defmacro ignore-errors (&body body) + `(handler-case (progn ,@body) + (error (c) (values nil c))))

1 0

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

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6786 Modified Files: conditions.lisp Log Message: Moved condition-related macros from conditions.lisp to more-macros.lisp. Date: Tue Apr 6 10:05:18 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.3 movitz/losp/muerte/conditions.lisp:1.4 --- movitz/losp/muerte/conditions.lisp:1.3 Fri Mar 12 06:47:41 2004 +++ movitz/losp/muerte/conditions.lisp Tue Apr 6 10:05:18 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.3 2004/03/12 11:47:41 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.4 2004/04/06 14:05:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,7 +19,6 @@ (in-package muerte) -(defvar *active-condition-handlers* nil) (defparameter *break-on-signals* nil) (defparameter *debugger-function* nil) @@ -134,81 +133,6 @@ (declare (dynamic-extent slot-initializations)) (apply 'make-instance type slot-initializations)) -(defmacro handler-bind (bindings &body forms) - (if (null bindings) - `(progn ,@forms) - (labels ((make-handler (binding) - (destructuring-bind (type handler) - binding - (cond - #+ignore - ((and (listp handler) - (eq 'lambda (first handler)) - (= 1 (length (second handler)))) - `(cons t (lambda (x) - (when (typep x ',type) - (let ((,(first (second handler)) x)) - ,@(cddr handler))) - nil))) - #+ignore - ((and (listp handler) - (eq 'function (first handler)) - (listp (second handler)) - (eq 'lambda (first (second handler))) - (= 1 (length (second (second handler))))) - (make-handler (list type (second handler)))) - (t `(cons ',type ,handler)))))) - `(let ((*active-condition-handlers* - (cons (list ,@(mapcar #'make-handler #+ignore (lambda (binding) - `(cons ',(first binding) - ,(second binding))) - bindings)) - *active-condition-handlers*))) - ,@forms)))) - -(defmacro handler-case (expression &rest clauses) - (multiple-value-bind (normal-clauses no-error-clauses) - (loop for clause in clauses - if (eq :no-error (car clause)) - collect clause into no-error-clauses - else collect clause into normal-clauses - finally (return (values normal-clauses no-error-clauses))) - (case (length no-error-clauses) - (0 (let ((block-name (gensym "handler-case-block-")) - (var-name (gensym "handler-case-var-")) - (temp-name (gensym "handler-case-temp-var-")) - (specs (mapcar (lambda (clause) - (list clause (gensym "handler-case-clause-tag-"))) - normal-clauses))) - `(block ,block-name - (let (,var-name) - (tagbody - (handler-bind ,(mapcar (lambda (clause-spec) - (let* ((clause (first clause-spec)) - (go-tag (second clause-spec)) - (typespec (first clause))) - `(,typespec (lambda (,temp-name) - (setq ,var-name ,temp-name) - (go ,go-tag))))) - specs) - (return-from ,block-name ,expression)) - ,@(mapcan (lambda (clause-spec) - (let* ((clause (first clause-spec)) - (go-tag (second clause-spec)) - (var (first (second clause))) - (body (cddr clause))) - (if (not var) - `(,go-tag (return-from ,block-name - (let () ,@body))) - `(,go-tag (return-from ,block-name - (let ((,var ,var-name)) - ,@body)))))) - specs)))))) - (t (error "Too many no-error clauses."))))) - -(defmacro ignore-errors (&body body) - `(handler-case (progn ,@body) - (error (c) (values nil c)))) (defun warn (datum &rest arguments) (declare (dynamic-extent arguments))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24165 Modified Files: basic-macros.lisp Log Message: Improved parsing in the do and do* compiler-macro, which puked at some quite legal forms. Date: Tue Apr 6 09:39:47 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.5 movitz/losp/muerte/basic-macros.lisp:1.6 --- movitz/losp/muerte/basic-macros.lisp:1.5 Wed Mar 24 19:55:12 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Apr 6 09:39:47 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.5 2004/03/25 00:55:12 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.6 2004/04/06 13:39:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -189,7 +189,12 @@ (define-compiler-macro do (var-specs (end-test-form &rest result-forms) &body declarations-and-body) (flet ((var-spec-let-spec (var-spec) - (if (symbolp var-spec) var-spec (subseq var-spec 0 2))) + (cond + ((symbolp var-spec) + var-spec) + ((cddr var-spec) + (subseq var-spec 0 2)) + (t var-spec))) (var-spec-var (var-spec) (if (symbolp var-spec) var-spec (car var-spec))) (var-spec-step-form (var-spec) @@ -220,7 +225,12 @@ (defmacro do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) (flet ((var-spec-let-spec (var-spec) - (if (symbolp var-spec) var-spec (subseq var-spec 0 2))) + (cond + ((symbolp var-spec) + var-spec) + ((cddr var-spec) + (subseq var-spec 0 2)) + (t var-spec))) (var-spec-var (var-spec) (if (symbolp var-spec) var-spec (car var-spec))) (var-spec-step-form (var-spec)

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv22591 Modified Files: los0-gc.lisp Log Message: Minor edits (?), need the muerte package qualifier here and there. Date: Tue Apr 6 09:38:21 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.2 movitz/losp/los0-gc.lisp:1.3 --- movitz/losp/los0-gc.lisp:1.2 Wed Mar 31 11:36:29 2004 +++ movitz/losp/los0-gc.lisp Tue Apr 6 09:38:21 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.2 2004/03/31 16:36:29 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.3 2004/04/06 13:38:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -110,7 +110,7 @@ (allocate-duo-space)) (let ((conser (symbol-value 'new-fast-cons))) (check-type conser vector) - (setf (%run-time-context-slot 'fast-cons) + (setf (%run-time-context-slot 'muerte::fast-cons) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps) @@ -120,9 +120,9 @@ (values)) (defun install-old-consing () - (let ((conser (symbol-value 'fast-cons))) + (let ((conser (symbol-value 'muerte::fast-cons))) (check-type conser vector) - (setf (%run-time-context-slot 'fast-cons) + (setf (%run-time-context-slot 'muerte::fast-cons) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps)

1 0

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

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv14476 Modified Files: los0.lisp Log Message: Safeifyed the los0-debugger a bit. Date: Tue Apr 6 09:36:42 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.9 movitz/losp/los0.lisp:1.10 --- movitz/losp/los0.lisp:1.9 Wed Mar 31 11:37:13 2004 +++ movitz/losp/los0.lisp Tue Apr 6 09:36:42 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.9 2004/03/31 16:37:13 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.10 2004/04/06 13:36:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -821,7 +821,8 @@ (*repl-prompt-context* #\d) (*repl-readline-context* (or *repl-readline-context* (make-readline-context :history-size 16)))) - (invoke-toplevel-command :error) + (let ((*print-safely* t)) + (invoke-toplevel-command :error)) (loop (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) (read-eval-print))))) @@ -838,7 +839,7 @@ ;;; (loop for i from #x40600 below #x80000 ;;; do (setf (memref i 0 0 :unsigned-byte32) #xababe13)) - + (install-los0-consing) (let ((*repl-readline-context* (make-readline-context :history-size 16))

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17668 Modified Files: compiler-types.lisp Log Message: A hack to teach the compiler that fixnum == integer (for now). Date: Tue Apr 6 09:35:41 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.9 movitz/compiler-types.lisp:1.10 --- movitz/compiler-types.lisp:1.9 Thu Apr 1 12:26:04 2004 +++ movitz/compiler-types.lisp Tue Apr 6 09:35:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.9 2004/04/01 17:26:04 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.10 2004/04/06 13:35:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -423,6 +423,8 @@ (cond ((atom type-specifier) (case type-specifier + (fixnum + (type-values 'integer)) ((t nil cons symbol keyword function array vector integer hash-table character) (type-values type-specifier)) (null

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp
by Frode Vatvedt Fjeld 06 Apr '04

06 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv8009 Modified Files: interrupt.lisp Log Message: Added functions cli and sti, and minor edits. Date: Tue Apr 6 06:37:52 2004 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.6 movitz/losp/x86-pc/interrupt.lisp:1.7 --- movitz/losp/x86-pc/interrupt.lisp:1.6 Sun Mar 28 08:35:45 2004 +++ movitz/losp/x86-pc/interrupt.lisp Tue Apr 6 06:37:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.6 2004/03/28 13:35:45 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.7 2004/04/06 10:37:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,7 +53,7 @@ (setf (memref frame (* 4 (int-frame-index reg)) 0 type) x)) (define-primitive-function muerte::default-interrupt-trampoline () - "Default interrupt handler." + "Default first-stage interrupt handler." #.(cl:list* 'with-inline-assembly '(:returns :nothing) (cl:loop :for i :from 0 :to movitz::+idt-size+ :append (cl:if (cl:member i '(8 10 11 12 13 14 17)) @@ -80,7 +80,7 @@ ;; 8: ebp ;; 4: esi ;; 0: edi - + (:pushl (:esp 48)) ; EFLAGS (:pushl :cs) ; push CS (:call (:pc+ 0)) ; push EIP. @@ -241,6 +241,8 @@ ;; (print-dynamic-context); what's this? (throw :debugger nil)) (112 + (setf (%run-time-context-slot 'nursery-space) + (memref (%run-time-context-slot 'nursery-space) -6 3 :lisp)) (error "Out of memory. Please take out the garbage.")) (t (funcall (if (< 16 number 50) #'warn #'error) "Exception occurred: ~D, EIP: ~@Z, EAX: ~@Z, ECX: ~@Z, ESI: ~@Z" @@ -267,6 +269,13 @@ (setf (pic8259-irq-mask) #xfffe) (with-inline-assembly (:returns :nothing) (:sti))) +(defun cli () + (with-inline-assembly (:returns :nothing) + (:cli))) + +(defun sti () + (with-inline-assembly (:returns :nothing) + (:sti))) (defun interrupt-handler (n) (let ((vector (load-global-constant interrupt-handlers)))

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20384 Modified Files: eval.lisp Log Message: Added defvar as a special-operator. ..Why not? Date: Thu Apr 1 15:25:07 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.4 movitz/losp/muerte/eval.lisp:1.5 --- movitz/losp/muerte/eval.lisp:1.4 Thu Apr 1 11:07:37 2004 +++ movitz/losp/muerte/eval.lisp Thu Apr 1 15:25:07 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.4 2004/04/01 16:07:37 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.5 2004/04/01 20:25:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,6 +54,19 @@ (or (and binding (cdr binding)) (symbol-value form))))) +;;; block let* return-from +;;; catch load-time-value setq +;;; eval-when locally symbol-macrolet +;;; flet macrolet tagbody +;;; function multiple-value-call the +;;; go multiple-value-prog1 throw +;;; if progn unwind-protect +;;; labels progv +;;; let quote +;;; +;;;Figure 3-2. Common Lisp Special Operators + + (defun eval-cons (form env) "3.1.2.1.2 Conses as Forms" (case (car form) @@ -69,6 +82,7 @@ (go (eval-go form env)) (setq (eval-setq form env)) (setf (eval-setf form env)) + ((defvar) (eval-defvar form env)) (let (eval-let (cadr form) (cddr form) env)) (time (eval-time (cadr form) env)) ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) @@ -389,6 +403,15 @@ (eval-form value-form env) place-subvalues))))))) +(defun eval-defvar (form env) + (let ((name (second form))) + (check-type name symbol "variable name") + (setf (symbol-special-variable-p name) t) + (when (and (cddr form) (not (boundp name))) + (setf (symbol-value name) + (eval-form (third form) env))) + name)) + (defun compile (name &optional definition) "=> function, warnings-p, failure-p" (let ((function (eval (or definition (symbol-function name))))) @@ -397,4 +420,5 @@ (values (if (not name) function (setf (symbol-function name) function)) - t nil))) \ No newline at end of file + t nil))) +

1 0

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

01 Apr '04

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv17687 Modified Files: ip4.lisp Log Message: Minor edits. Date: Thu Apr 1 12:29:44 2004 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.5 movitz/losp/lib/net/ip4.lisp:1.6 --- movitz/losp/lib/net/ip4.lisp:1.5 Thu Feb 26 06:26:24 2004 +++ movitz/losp/lib/net/ip4.lisp Thu Apr 1 12:29:44 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.5 2004/02/26 11:26:24 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.6 2004/04/01 17:29:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -91,8 +91,12 @@ (loop for x from y below (min (length packet) (+ y 16)) as c = (code-char (aref packet x)) do (write-char (if (alphanumericp c) c #\.))))) - ((mismatch packet (address stack) :start1 (+ start +ip-header-destination+) :end1 (+ start +ip-header-destination+ 4)) - #+ignore (warn "IPv4 Packet from ~@/ip4:pprint-ip4/ not for me, but for ~:/ip4:pprint-ip4/." packet packet)) + ((mismatch packet (address stack) + :start1 (+ start +ip-header-destination+) + :end1 (+ start +ip-header-destination+ 4)) + #+ignore + (warn "IPv4 Packet from ~@/ip4:pprint-ip4/ not for me, but for ~:/ip4:pprint-ip4/." + packet packet)) (t (named-integer-case ip-protocol (ip-protocol packet start) (icmp (icmp-input stack packet start (+ start header-size))) @@ -244,7 +248,7 @@ (+ (ldb (byte 16 0) new-checksum) (ash new-checksum -16)))) (transmit (interface stack) packet) - (write-char #\.))))) + #+ignore (write-char #\.))))) ;;;; UDP

1 0