movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

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

12 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10017 Modified Files: compiler-types.lisp Log Message: Added docstring to member-type-encode. Date: Thu Feb 12 12:51:41 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.4 movitz/compiler-types.lisp:1.5 --- movitz/compiler-types.lisp:1.4 Thu Feb 12 06:32:56 2004 +++ movitz/compiler-types.lisp Thu Feb 12 12:51: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.4 2004/02/12 11:32:56 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.5 2004/02/12 17:51:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -531,6 +531,7 @@ (type-specifier-encode (apply deriver (cdr type-specifier)))))))))) (defun member-type-encode (&rest member-objects) + "Encode a member type-specifier holding member-objects." (declare (dynamic-extent members)) (multiple-value-bind (code integer-range members include complement) (type-specifier-encode nil)

1 0

[movitz-cvs] CVS update: movitz/compiler-protocol.lisp
by Frode Vatvedt Fjeld 12 Feb '04

12 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5151 Modified Files: compiler-protocol.lisp Log Message: Slight change in compiler-values-bind macro so as to set up correctly the scope of an &all binding (i.e. the macrolet). Date: Thu Feb 12 12:51:02 2004 Author: ffjeld Index: movitz/compiler-protocol.lisp diff -u movitz/compiler-protocol.lisp:1.2 movitz/compiler-protocol.lisp:1.3 --- movitz/compiler-protocol.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/compiler-protocol.lisp Thu Feb 12 12:51:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Oct 10 13:02:03 2001 ;;;; -;;;; $Id: compiler-protocol.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: compiler-protocol.lisp,v 1.3 2004/02/12 17:51:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -124,20 +124,20 @@ ,@(unless type-p (list type)) ,@(unless final-form-p (list final-form)))) ,@body) - `(macrolet ((,all (x) - (ecase x - (:code ',code) (:returns ',returns) (:functional-p ',functional-p) - (:producer ',producer) (:modifies ',modifies) (:type ',type) - (:final-form ',final-form)))) - (multiple-value-bind (,code ,returns ,functional-p ,producer ,modifies ,type ,final-form) - ,form - (declare (ignorable ,@(unless code-p (list code)) - ,@(unless returns-p (list returns)) - ,@(unless functional-p-p (list functional-p)) - ,@(unless producer-p (list producer)) - ,@(unless modifies-p (list modifies)) - ,@(unless type-p (list type)) - ,@(unless final-form-p (list final-form)))) + `(multiple-value-bind (,code ,returns ,functional-p ,producer ,modifies ,type ,final-form) + ,form + (declare (ignorable ,@(unless code-p (list code)) + ,@(unless returns-p (list returns)) + ,@(unless functional-p-p (list functional-p)) + ,@(unless producer-p (list producer)) + ,@(unless modifies-p (list modifies)) + ,@(unless type-p (list type)) + ,@(unless final-form-p (list final-form)))) + (macrolet ((,all (x) + (ecase x + (:code ',code) (:returns ',returns) (:functional-p ',functional-p) + (:producer ',producer) (:modifies ',modifies) (:type ',type) + (:final-form ',final-form)))) ,@body)))) (defmacro compiler-values-list (&rest compiler-values-spec)

1 0

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

12 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23043 Modified Files: compiler-types.lisp Log Message: Factored out function member-type-encode, which encodes a member type-specifier from a set of objects. Date: Thu Feb 12 06:32:56 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.3 movitz/compiler-types.lisp:1.4 --- movitz/compiler-types.lisp:1.3 Wed Feb 11 13:01:40 2004 +++ movitz/compiler-types.lisp Thu Feb 12 06:32:56 2004 @@ -6,11 +6,11 @@ ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: compiler-types.lisp -;;;; Description: +;;;; Description: Compile-time type computation and manipulation. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.3 2004/02/11 18:01:40 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.4 2004/02/12 11:32:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -475,15 +475,9 @@ (satisfies (type-values () :include (list type-specifier))) (member - (type-values () :members (cdr type-specifier))) + (apply #'member-type-encode (cdr type-specifier))) (eql - (let ((x (second type-specifier))) - (etypecase x - (movitz-fixnum - (type-values () :integer-range (make-numscope (movitz-fixnum-value x) - (movitz-fixnum-value x)))) - (movitz-object - (type-values () :members (list x)))))) + (member-type-encode (second type-specifier))) (and (if (not (cdr type-specifier)) (type-values t) @@ -535,6 +529,22 @@ (assert deriver (type-specifier) "Unknown type ~S." type-specifier) (type-specifier-encode (apply deriver (cdr type-specifier)))))))))) + +(defun member-type-encode (&rest member-objects) + (declare (dynamic-extent members)) + (multiple-value-bind (code integer-range members include complement) + (type-specifier-encode nil) + (dolist (x member-objects) + (multiple-value-setq (code integer-range members include complement) + (multiple-value-call #'encoded-types-or + code integer-range members include complement + (etypecase x + (movitz-fixnum + (type-values () :integer-range (make-numscope (movitz-fixnum-value x) + (movitz-fixnum-value x)))) + (movitz-object + (type-values () :members (list x))))))) + (values code integer-range members include complement))) (defun encoded-emptyp (code integer-range members include complement) "Return wether we know the encoded type is the empty set.

1 0

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

12 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16225 Modified Files: image.lisp Log Message: Fixed image-memref to work properly. Also, made errorp true by default. Date: Thu Feb 12 06:30:21 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.14 movitz/image.lisp:1.15 --- movitz/image.lisp:1.14 Wed Feb 11 11:22:38 2004 +++ movitz/image.lisp Thu Feb 12 06:30:20 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.14 2004/02/11 16:22:38 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.15 2004/02/12 11:30:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -542,11 +542,14 @@ (image-cons-pointer image) (+ new-ptr size)) new-ptr)))))) -(defmethod image-memref ((image symbolic-image) address &optional (errorp nil)) +(defmethod image-memref ((image symbolic-image) address &optional (errorp t)) (let ((obj (gethash address (image-address-hash image) :nothing))) - (when (and errorp (not (typep obj 'movitz-object))) - (error "Found non-movitz-object at image-address #x~X: ~A" address obj)) - obj)) + (cond + ((not (typep obj 'movitz-object)) + (when errorp + (error "Found non-movitz-object at image-address #x~X: ~A" address obj)) + nil) + (t obj)))) (defmethod search-image ((image symbolic-image) address) (loop for a downfrom (logand address -8) by 8 @@ -902,7 +905,7 @@ (loop for p upfrom (- (image-start-address image) (image-ds-segment-base image)) by 8 until (>= p (image-cons-pointer image)) summing - (let ((obj (image-memref image p))) + (let ((obj (image-memref image p nil))) (cond ((not obj) 0) (t (let ((new-pos (+ p file-start-position

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 12 Feb '04

12 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19297 Modified Files: storage-types.lisp Log Message: Fixed class movitz-struct, which previously declared wrong (host-side) types for some slots (i.e. erroneously used :binary-lisp-type rather than :binary-type). Date: Thu Feb 12 06:28:28 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.5 movitz/storage-types.lisp:1.6 --- movitz/storage-types.lisp:1.5 Thu Feb 5 09:46:19 2004 +++ movitz/storage-types.lisp Thu Feb 12 06:28:28 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.5 2004/02/05 14:46:19 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.6 2004/02/12 11:28:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1023,7 +1023,7 @@ (define-binary-class movitz-struct (movitz-heap-object-other) ((name - :binary-lisp-type word + :binary-type word :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word :reader movitz-struct-name

1 0

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

11 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26136 Modified Files: compiler-types.lisp Log Message: Small fix in encoded-types-or: Remember to return complement-p nil for the normal case when inputs complement0 and complement1 are nil. Date: Wed Feb 11 13:01:40 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.2 movitz/compiler-types.lisp:1.3 --- movitz/compiler-types.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/compiler-types.lisp Wed Feb 11 13:01:40 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.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.3 2004/02/11 18:01:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -442,11 +442,13 @@ (or (encoded-typep nil t x code0 integer-range0 nil include0 nil) (encoded-typep nil t x code1 integer-range1 nil include1 nil))) (union members0 members1 :test #'movitz-eql)) - (union include0 include1 :test #'equal)))) + (union include0 include1 :test #'equal) + nil))) (t (error "Not implemented")))) (defun type-specifier-encode (type-specifier) + "Encode a type-specifier to internal representation." (let ((type-specifier (translate-program type-specifier :muerte.cl :cl))) (cond ((atom type-specifier)

1 0

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

11 Feb '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23329 Modified Files: image.lisp Log Message: Fixed movitz-word-by-image and image-memref. Date: Wed Feb 11 11:22:38 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.13 movitz/image.lisp:1.14 --- movitz/image.lisp:1.13 Tue Feb 10 13:06:13 2004 +++ movitz/image.lisp Wed Feb 11 11:22:38 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.13 2004/02/10 18:06:13 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.14 2004/02/11 16:22:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -543,7 +543,7 @@ new-ptr)))))) (defmethod image-memref ((image symbolic-image) address &optional (errorp nil)) - (let ((obj (gethash address (image-address-hash image)))) + (let ((obj (gethash address (image-address-hash image) :nothing))) (when (and errorp (not (typep obj 'movitz-object))) (error "Found non-movitz-object at image-address #x~X: ~A" address obj)) obj)) @@ -614,7 +614,7 @@ (:character (make-instance 'movitz-character :char (code-char (ldb (byte 8 8) word)))) (:null - (image-memref *image* (+ 3 word) t)) + (image-nil-word image)) (t (image-memref *image* (logand word #xfffffff8) t)))) (defun movitz-intern-code-vector (object &optional (type 'code-vector-word))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/loop.lisp
by Frode Vatvedt Fjeld 11 Feb '04

11 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25313 Modified Files: loop.lisp Log Message: Added to loop expansions some ignorable declarations for hash-table iteration. Date: Wed Feb 11 09:52:51 2004 Author: ffjeld Index: movitz/losp/muerte/loop.lisp diff -u movitz/losp/muerte/loop.lisp:1.4 movitz/losp/muerte/loop.lisp:1.5 --- movitz/losp/muerte/loop.lisp:1.4 Tue Feb 10 18:40:17 2004 +++ movitz/losp/muerte/loop.lisp Wed Feb 11 09:52:51 2004 @@ -47,11 +47,22 @@ ;;;; LOOP Iteration Macro + +;;; Movitz notes: +;;; +;;; - Because much of this file is wrapped in eval-when (:compile-toplevel), +;;; (i.e. the host-side macroexpanders), it's probably best to +;;; recompile/reload this complete file rather than on a per-toplevel +;;; form basis. + +#+movitz +(in-package muerte) + ;;;#+allegro ;;;(in-package :excl) ;;;#-allegro ;;;(in-package :ansi-loop) -(in-package muerte) + (provide :muerte/loop :load-priority 0) @@ -1881,12 +1892,19 @@ dummy-predicate-var (loop-when-it-variable)) (let ((key-var nil) (val-var nil) + (ignore-vars nil) (bindings `((,variable nil ,data-type) (,ht-var ,(cadar prep-phrases)) ,@(and other-p other-var `((,other-var nil)))))) - (if (eq which 'hash-key) - (setq key-var variable val-var (and other-p other-var)) - (setq key-var (and other-p other-var) val-var variable)) + (ecase which + (hash-key + (setq key-var variable val-var (and other-p other-var)) + (when val-var + (pushnew val-var ignore-vars))) + (hash-value ; default? + (setq key-var (and other-p other-var) val-var variable) + (when key-var + (pushnew key-var ignore-vars)))) (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) (when (consp key-var) (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) @@ -1896,6 +1914,11 @@ (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) ,@post-steps)) (push `(,val-var nil) bindings)) + (pushnew dummy-predicate-var ignore-vars) + (when ignore-vars + (pushnew `(ignorable ,@ignore-vars) + *loop-declarations* + :test 'equalp)) `(,bindings ;bindings () ;prologue () ;pre-test

1 0

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

10 Feb '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18912 Modified Files: loop.lisp Log Message: Factored out defstructs so they are not evaluated twice for every compilation of this file. Date: Tue Feb 10 18:40:17 2004 Author: ffjeld Index: movitz/losp/muerte/loop.lisp diff -u movitz/losp/muerte/loop.lisp:1.3 movitz/losp/muerte/loop.lisp:1.4 --- movitz/losp/muerte/loop.lisp:1.3 Wed Jan 21 17:02:09 2004 +++ movitz/losp/muerte/loop.lisp Tue Feb 10 18:40:17 2004 @@ -298,6 +298,53 @@ #-LISPM `(cdr ,head-var)))) +(defstruct (loop-minimax + (:constructor make-loop-minimax-internal) + (:copier nil) + (:predicate nil)) + answer-variable + type + temp-variable + flag-variable + operations + infinity-data) + +(defstruct (loop-universe + (:print-function print-loop-universe) + (:copier nil) + (:predicate nil)) + keywords ;hash table, value = (fn-name . extra-data). + iteration-keywords ;hash table, value = (fn-name . extra-data). + for-keywords ;hash table, value = (fn-name . extra-data). + path-keywords ;hash table, value = (fn-name . extra-data). + type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. + type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. + ansi ;NIL, T, or :EXTENDED. + implicit-for-required ;see loop-hack-iteration + ) + + +(defstruct (loop-collector + (:copier nil) + (:predicate nil)) + name + class + (history nil) + (tempvars nil) + dtype + (data nil)) ;collector-specific data + +(defstruct (loop-path + (:copier nil) + (:predicate nil)) + names + preposition-groups + inclusive-permitted + function + user-data) + + + ;;;; Maximization Technology (eval-when (:compile-toplevel :execute) @@ -317,18 +364,6 @@ |# -(defstruct (loop-minimax - (:constructor make-loop-minimax-internal) - (:copier nil) - (:predicate nil)) - answer-variable - type - temp-variable - flag-variable - operations - infinity-data) - - (defvar *loop-minimax-type-infinities-alist* ;;@@@@ This is the sort of value this should take on for a Lisp that has ;; "eminently usable" infinities. n.b. there are neither constants nor @@ -467,19 +502,7 @@ (defmacro loop-store-table-data (symbol table datum) `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) -(defstruct (loop-universe - (:print-function print-loop-universe) - (:copier nil) - (:predicate nil)) - keywords ;hash table, value = (fn-name . extra-data). - iteration-keywords ;hash table, value = (fn-name . extra-data). - for-keywords ;hash table, value = (fn-name . extra-data). - path-keywords ;hash table, value = (fn-name . extra-data). - type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. - type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. - ansi ;NIL, T, or :EXTENDED. - implicit-for-required ;see loop-hack-iteration - ) + (defun print-loop-universe (u stream level) @@ -1192,15 +1215,6 @@ ;;;; Value Accumulation: List -(defstruct (loop-collector - (:copier nil) - (:predicate nil)) - name - class - (history nil) - (tempvars nil) - dtype - (data nil)) ;collector-specific data (eval-when (:compile-toplevel #+movitz-loop :load-toplevel) @@ -1578,14 +1592,6 @@ ;;;; Iteration Paths -(defstruct (loop-path - (:copier nil) - (:predicate nil)) - names - preposition-groups - inclusive-permitted - function - user-data) (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data)

1 0

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

10 Feb '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv12960 Modified Files: los0.lisp Log Message: sync. Date: Tue Feb 10 18:38:20 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.2 movitz/losp/los0.lisp:1.3 --- movitz/losp/los0.lisp:1.2 Mon Jan 19 06:23:43 2004 +++ movitz/losp/los0.lisp Tue Feb 10 18:38:20 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.2 2004/01/19 11:23:43 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.3 2004/02/10 23:38:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,7 +19,7 @@ (require :x86-pc/all) (require :x86-pc/io-space) (require :x86-pc/ne2k) -(require :x86-pc/floppy) +;; (require :x86-pc/floppy) (require :lib/readline) (require :lib/toplevel) @@ -428,14 +428,13 @@ - -#+ignore +s#+ignore (defun test-ncase (x y z) (numargs-case (1 (x) (values x 'one)) (2 (x y) (values (+ x y) 'one 'two)) (3 (x y z) (values (+ x y z) 'one 'two 'three)) - (t (&rest args) (declare (ignore args)) 27))) + (t (args) (declare (ignore args)) 27))) #+ignore (defun xbar () @@ -488,8 +487,8 @@ (declare (ignore f)) (print "Cooking some food.")) -(defun foo (x) - (funcall (cdr x) 'abba)) +(defun foo (x &optional (y nil yp)) + (format t "~@{ ~A~}" yp)) (defun test-pie (n pie) (dotimes (i n)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs