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

[movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp
by ffjeld＠common-lisp.net 29 May '05

29 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12156 Modified Files: conditions.lisp Log Message: *** empty log message *** Date: Mon May 30 00:03:04 2005 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.15 movitz/losp/muerte/conditions.lisp:1.16 --- movitz/losp/muerte/conditions.lisp:1.15 Sat Apr 30 00:36:23 2005 +++ movitz/losp/muerte/conditions.lisp Mon May 30 00:03:04 2005 @@ -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.15 2005/04/29 22:36:23 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.16 2005/05/29 22:03:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -280,8 +280,9 @@ (setf *debugger-function* #'muerte.init::my-debugger)) (cond ((not *debugger-function*) - (format t "~&No debugger in *debugger-function*. Trying to abort.") - (invoke-restart (or (find-restart 'abort) + (format t "~&No debugger in *debugger-function*. Trying to continue or abort.") + (invoke-restart (or (find-restart 'continue) + (find-restart 'abort) (format t "~%Condition for debugger: ~Z" condition) (format t "~%No abort restart is active. Halting CPU.") (halt-cpu))))

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp
by ffjeld＠common-lisp.net 25 May '05

25 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv15239 Modified Files: ip4.lisp Log Message: *** empty log message *** Date: Wed May 25 21:46:07 2005 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.19 movitz/losp/lib/net/ip4.lisp:1.20 --- movitz/losp/lib/net/ip4.lisp:1.19 Tue May 24 09:14:53 2005 +++ movitz/losp/lib/net/ip4.lisp Wed May 25 21:46:07 2005 @@ -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.19 2005/05/24 07:14:53 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.20 2005/05/25 19:46:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -242,40 +242,42 @@ (ash x -16))))) (defun ip-input (stack packet start) - (let ((header-size (* 4 (ip-header-length packet start)))) - (cond - ((not (checksum-ok (checksum-octets packet start (+ start header-size)))) - (warn "IP4 header checksum failed (from ~@/ip4:pprint-ip4/ to ~:/ip4:pprint-ip4/ proto ~A len ~D)." - packet packet - (integer-name 'ip-protocol (ip-protocol packet start) nil) - (length packet)) - #+ignore - (loop for y from 0 below (length packet) by 16 - do (fresh-line) - (loop for x from y below (min (length packet) (+ y 16)) - when (zerop (rem x 4)) - do (format t " ") - do (format t " ~2,'0X" (aref packet x))) - (write-string " ") - (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)) - (t (named-integer-case ip-protocol (ip-protocol packet start) - (icmp - (icmp-input stack packet start (+ start header-size))) - (udp - (udp-input stack packet start (+ start header-size))) - (tcp - (tcp-input stack packet start (+ start header-size))) - (t (warn "Unknown IPv4 protocol ~A received from ~@/ip4:pprint-ip4/." - (integer-name 'ip-protocol (ip-protocol packet start) nil) - packet))))))) + (with-ip4-header (ip packet :start start) + (let ((header-size (* 4 (ip :ihl)))) + (cond + ((not (or (= 0 (ip :checksum)) + (checksum-ok (checksum-octets packet start (+ start header-size))))) + (warn "IP4 header checksum failed #x~X (from ~@/ip4:pprint-ip4/ to ~:/ip4:pprint-ip4/ proto ~A len ~D)." + (checksum-octets packet start (+ start header-size)) + packet packet + (integer-name 'ip-protocol (ip-protocol packet start) nil) + (length packet)) + (loop for y from 0 below (length packet) by 16 + do (fresh-line) + (loop for x from y below (min (length packet) (+ y 16)) + when (zerop (rem x 4)) + do (format t " ") + do (format t " ~2,'0X" (aref packet x))) + (write-string " ") + (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)) + (t (named-integer-case ip-protocol (ip :protocol) + (icmp + (icmp-input stack packet start (+ start header-size))) + (udp + (udp-input stack packet start (+ start header-size))) + (tcp + (tcp-input stack packet start (+ start header-size))) + (t (warn "Unknown IPv4 protocol ~A received from ~@/ip4:pprint-ip4/." + (integer-name 'ip-protocol (ip :protocol) nil) + packet)))))))) @@ -307,7 +309,7 @@ (= +ether-type-ip4+ (arp-prot-type packet start)) (not (mismatch (address stack) packet :start2 (+ start 24) :end2 (+ start 28)))) - (warn "arp request from ~v/ip4:pprint-ip4/." (+ start 14) packet) + (warn "arp request from ~v/ip4:pprint-ip4/ len ~D." (+ start 14) packet (length packet)) (transmit (interface stack) (format-ethernet-packet (format-arp-request nil +arp-op-reply+ (address stack) @@ -316,12 +318,12 @@ :target-hardware-address packet :target-hardware-address-start (+ start 8)) (mac-address (interface stack)) - packet - muerte.ethernet:+ether-type-arp+ - :destination-start (+ start 8)))) + (ether-source packet) + muerte.ethernet:+ether-type-arp+))) (t (unknown-packet stack packet) - #+ignore (warn "ARP request for not me ~/ip4:pprint-ip4/: ~v/ip4:pprint-ip4/." - (address stack) (+ start 24) packet)))) + #+ignore + (warn "ARP request for not me ~/ip4:pprint-ip4/: ~v/ip4:pprint-ip4/." + (address stack) (+ start 24) packet)))) (#.+arp-op-reply+ (warn "Received an ARP reply: ~v/ip4:pprint-ip4/ is ~v/ethernet:pprint-mac/." (+ start 14) packet

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/dhcp.lisp
by ffjeld＠common-lisp.net 24 May '05

24 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv14520 Modified Files: dhcp.lisp Log Message: *** empty log message *** Date: Tue May 24 09:15:54 2005 Author: ffjeld Index: movitz/losp/lib/net/dhcp.lisp diff -u movitz/losp/lib/net/dhcp.lisp:1.2 movitz/losp/lib/net/dhcp.lisp:1.3 --- movitz/losp/lib/net/dhcp.lisp:1.2 Tue May 24 01:30:38 2005 +++ movitz/losp/lib/net/dhcp.lisp Tue May 24 09:15:54 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri May 13 23:24:01 2005 ;;;; -;;;; $Id: dhcp.lisp,v 1.2 2005/05/23 23:30:38 ffjeld Exp $ +;;;; $Id: dhcp.lisp,v 1.3 2005/05/24 07:15:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,14 +56,15 @@ +---------------------------------------------------------------+ |# -(defmacro with-dhcp-header ((dhcp packet &key (start '(udp :end))) &body body) +(defmacro with-dhcp-header ((dhcp packet &key start) &body body) (let* ((dhcp-ref (gensym "dhcp-ref-")) (start-var (gensym "dhcp-start-")) (packet-var (gensym "dhcp-packet-")) (offset-var (gensym "dhcp-packet-start-"))) - `(let* ((,start-var ,start) - (,packet-var (ensure-data-vector ,packet ,start-var 232)) + `(let* ((,packet-var ,packet) + (,start-var ,(or start `(fill-pointer ,packet-var))) (,offset-var (+ ,start-var (movitz-type-slot-offset 'movitz-basic-vector 'data)))) + (ensure-data-vector ,packet ,start-var 232) (macrolet ((,dhcp-ref (offset type) `(memref ,',packet-var (+ ,',offset-var ,offset) :type ,type :endian :big)) (,dhcp (slot) @@ -77,7 +78,7 @@ (:flags `(,',dhcp-ref 10 :unsigned-byte16)) ((:ciaddr :yiaddr :siaddr :giaddr) - `(,',dhcp-ref ,(+ 12 (position slot '(:ciaddr :yiaddr :siaddr :giaddr))) + `(,',dhcp-ref ,(+ 12 (* 4 (position slot '(:ciaddr :yiaddr :siaddr :giaddr)))) :unsigned-byte32)) (:chaddr `(memrange ,',packet-var 0 (+ ,',offset-var 28) 16 :unsigned-byte8)) @@ -102,7 +103,7 @@ (defun dhcp-push-options (packet &rest options) (declare (dynamic-extent options)) (loop while options - do (ecase (pop options) + do (case (pop options) (:lease-time (vector-push 51 packet) (vector-push 4 packet) @@ -133,16 +134,17 @@ unless (= 0 option) collect (case option - (1 (assert (= 4 (vector-read packet))) + (1 (assert (= 4 (vector-read packet)) () "Wrong length for subnet-mask.") (cons :subnet-mask (subseq packet (fill-pointer packet) (incf (fill-pointer packet) 4)))) (3 (let ((length (vector-read packet))) (cons :routers - (subseq packet - (fill-pointer packet) - (incf (fill-pointer packet) length))))) + (loop repeat (truncate length 4) + collect (subseq packet + (fill-pointer packet) + (incf (fill-pointer packet) 4)))))) (6 (let ((length (vector-read packet))) (cons :dns-servers (subseq packet @@ -160,7 +162,7 @@ (subseq packet (fill-pointer packet) (incf (fill-pointer packet) length)))))) - (28 (assert (= 4 (vector-read packet))) + (28 (assert (= 4 (vector-read packet)) () "Wrong length for broadcast.") (cons :broadcast (subseq packet (fill-pointer packet) @@ -175,7 +177,7 @@ (subseq packet (fill-pointer packet) (incf (fill-pointer packet) length))))) - (51 (assert (= 4 (vector-read packet))) + (51 (assert (= 4 (vector-read packet)) () "Wrong length for lease-time.") (cons :lease-time (loop with time = 0 repeat 4 do (setf time (+ (* 256 time) (vector-read packet))) @@ -205,7 +207,7 @@ (fill-pointer packet) (incf (fill-pointer packet) length))))))))) -(defun format-dhcp-request (nic &rest dhcp-options &key (message-type :dhcpdiscover)) +(defun format-dhcp-request (nic &rest dhcp-options &key (xid 0) (message-type :dhcpdiscover)) (let ((packet (make-ethernet-packet))) (with-ether-header (ether packet) (setf (ether :source) (mac-address nic) @@ -213,7 +215,7 @@ (ether :type) +ether-type-ip4+) (with-ip4-header (ip packet :start (ether :end)) (with-udp-header (udp packet) - (with-dhcp-header (dhcp packet) + (with-dhcp-header (dhcp packet :start (udp :end)) (setf (ip :version) 4 (ip :protocol) 17 (ip :ihl) 5 @@ -226,6 +228,7 @@ (dhcp :hlen ) 6 (dhcp :hops) 0 (dhcp :secs) 0 + (dhcp :xid) xid (dhcp :chaddr) (mac-address nic) (dhcp :magic) +dhcp-magic+) (setf (fill-pointer packet) (dhcp :end)) @@ -241,10 +244,12 @@ (udp :checksum) (udp :compute-checksum ip)) packet)))))) -(defun dhcp-request (&optional (nic (or *ip4-nic* (ip4-init)))) - (loop with packet = (make-ethernet-packet) +(defun dhcp-request (&optional (nic (or *ip4-nic* (ip4-init))) &rest dhcp-options) + (declare (dynamic-extent dhcp-options)) + (loop with packet = (make-ethernet-packet) + with xid = (random 10000) repeat 5 - do (transmit nic (format-dhcp-request nic)) + do (transmit nic (apply #'format-dhcp-request nic :xid xid dhcp-options)) (sleep 1/2) when (loop while (receive nic packet) thereis (with-ether-header (ether packet) @@ -256,15 +261,25 @@ (ip4-address (ip :source))) (with-udp-header (udp packet) (when (= 68 (udp :destination-port)) + (setf (fill-pointer packet) + (udp :end)) (with-dhcp-header (dhcp packet) - (and (= +dhcp-magic+ (dhcp :magic)) - (setf (fill-pointer packet) - (dhcp :end)))))))))) - return (values packet (parse-dhcp-options packet)))) - - - - - - - \ No newline at end of file + (and (= xid (dhcp :xid)) + (= +dhcp-magic+ (dhcp :magic)))))))))) + return packet)) + +(defun dhcp-init () + (let ((packet (dhcp-request))) + (if (not packet) + (warn "DHCP lookup failed.") + (with-dhcp-header (dhcp packet) + (setf (fill-pointer packet) (dhcp :end)) + (let ((options (parse-dhcp-options packet))) + (setf *ip4-ip* (ip4-address (dhcp :yiaddr)) + *ip4-router* (first (cdr (assoc :routers options)))) + (format *terminal-io* "Setting IP ~/ip4:pprint-ip4/ ~@[~A~]~@[.~A~] router ~/ip4:pprint-ip4/." + *ip4-ip* + (cdr (assoc :host-name options)) + (cdr (assoc :domain-name options)) + *ip4-router*))))) + (values))

1 0

[movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp
by ffjeld＠common-lisp.net 24 May '05

24 May '05

Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv13729 Modified Files: ip4.lisp Log Message: *** empty log message *** Date: Tue May 24 09:14:53 2005 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.18 movitz/losp/lib/net/ip4.lisp:1.19 --- movitz/losp/lib/net/ip4.lisp:1.18 Sun May 22 00:36:16 2005 +++ movitz/losp/lib/net/ip4.lisp Tue May 24 09:14:53 2005 @@ -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.18 2005/05/21 22:36:16 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.19 2005/05/24 07:14:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -31,8 +31,8 @@ #:*ip4-nic* #:*ip4-ip* #:*ip4-router* - - #:with-ip4-header)) + #:with-ip4-header + #:dhcp-init)) (in-package muerte.ip4)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by ffjeld＠common-lisp.net 24 May '05

24 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11829 Modified Files: typep.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:47 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.43 movitz/losp/muerte/typep.lisp:1.44 --- movitz/losp/muerte/typep.lisp:1.43 Fri Apr 15 09:00:31 2005 +++ movitz/losp/muerte/typep.lisp Tue May 24 08:33:46 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.43 2005/04/15 07:00:31 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.44 2005/05/24 06:33:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -585,13 +585,6 @@ (typep x 'code-vector)) ;;; - -(define-typep rational (x &optional (lower-limit '*) (upper-limit '*)) - (and (typep x 'rational) - (or (eq lower-limit '*) - (<= lower-limit x)) - (or (eq upper-limit '*) - (<= x upper-limit)))) (define-typep and (x &rest types) (declare (dynamic-extent types))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by ffjeld＠common-lisp.net 24 May '05

24 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11812 Modified Files: more-macros.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:40 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.27 movitz/losp/muerte/more-macros.lisp:1.28 --- movitz/losp/muerte/more-macros.lisp:1.27 Thu May 5 22:52:10 2005 +++ movitz/losp/muerte/more-macros.lisp Tue May 24 08:33:40 2005 @@ -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.27 2005/05/05 20:52:10 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.28 2005/05/24 06:33:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -404,6 +404,22 @@ (when ,var (sti)))))) +(define-compiler-macro dit-frame-ref (&whole form stack frame reg + &optional (type :lisp) + &environment env) + (if (not (and (movitz:movitz-constantp stack env) + (eq nil (movitz:movitz-eval stack env)))) + form + `(memref ,frame (dit-frame-offset ,reg) :type ,type))) + +(define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg + &optional (type :lisp) + &environment env) + (if (not (and (movitz:movitz-constantp stack env) + (eq nil (movitz:movitz-eval stack env)))) + form + `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value))) + ;;; Some macros that aren't implemented, and we want to give compiler errors. (defmacro define-unimplemented-macro (name) @@ -414,3 +430,4 @@ (define-unimplemented-macro with-open-file) (define-unimplemented-macro restart-case) +

1 0

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

24 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11796 Modified Files: memref.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:37 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.46 movitz/losp/muerte/memref.lisp:1.47 --- movitz/losp/muerte/memref.lisp:1.46 Sun May 22 00:37:32 2005 +++ movitz/losp/muerte/memref.lisp Tue May 24 08:33:35 2005 @@ -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.46 2005/05/21 22:37:32 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.47 2005/05/24 06:33:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -563,9 +563,8 @@ (,offset-var ,offset) (,index-var ,index)) (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:load-lexical (:lexical-binding ,value-var) :eax) - (:call-global-pf unbox-u32) (:compile-two-forms (:eax :edx) ,index-var ,offset-var) + (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-ecx) (:load-lexical (:lexical-binding ,object-var) :ebx) ,@(when (eq endian :big) `((:bswap :ecx))) @@ -1202,31 +1201,3 @@ ;; (define-compiler-macro memrange (object )) -(defun memrange (object offset index length type) - (ecase type - (:unsigned-byte8 - (let ((vector (make-array length :element-type '(unsigned-byte 8)))) - (loop for i upfrom index as j upfrom 0 repeat length - do (setf (aref vector j) (memref object offset :index i :type :unsigned-byte8))) - vector)))) - -(defun (setf memrange) (value object offset index length type) - (ecase type - (:unsigned-byte8 - (etypecase value - ((unsigned-byte 8) - (loop for i upfrom index repeat length - do (setf (memref object offset :index i :type :unsigned-byte8) value))) - (vector - (loop for i upfrom index as x across value repeat length - do (setf (memref object offset :index i :type :unsigned-byte8) x))))) - (:character - (etypecase value - (character - (loop for i upfrom index repeat length - do (setf (memref object offset :index i :type :character) value))) - (string - (loop for i upfrom index as x across value repeat length - do (setf (memref object offset :index i :type :character) x)))))) - value) -

1 0

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

24 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11780 Modified Files: interrupt.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:30 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.45 movitz/losp/muerte/interrupt.lisp:1.46 --- movitz/losp/muerte/interrupt.lisp:1.45 Mon May 9 08:20:55 2005 +++ movitz/losp/muerte/interrupt.lisp Tue May 24 08:33:28 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.45 2005/05/09 06:20:55 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.46 2005/05/24 06:33:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -55,24 +55,8 @@ (defun dit-frame-offset (name) (* 4 (dit-frame-index name)))) -(define-compiler-macro dit-frame-ref (&whole form stack frame reg - &optional (type :lisp) - &environment env) - (if (not (and (movitz:movitz-constantp stack env) - (eq nil (movitz:movitz-eval stack env)))) - form - `(memref ,frame (dit-frame-offset ,reg) :type ,type))) - (defun dit-frame-ref (stack frame reg &optional (type :lisp)) (stack-frame-ref stack (+ frame (dit-frame-index reg)) 0 type)) - -(define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg - &optional (type :lisp) - &environment env) - (if (not (and (movitz:movitz-constantp stack env) - (eq nil (movitz:movitz-eval stack env)))) - form - `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value))) (defun (setf dit-frame-ref) (value stack frame reg &optional (type :lisp)) (setf (stack-frame-ref stack (+ frame (dit-frame-index reg)) 0 type)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by ffjeld＠common-lisp.net 24 May '05

24 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11765 Modified Files: integers.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:25 2005 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.105 movitz/losp/muerte/integers.lisp:1.106 --- movitz/losp/muerte/integers.lisp:1.105 Wed Apr 13 09:26:29 2005 +++ movitz/losp/muerte/integers.lisp Tue May 24 08:33:24 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.105 2005/04/13 07:26:29 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.106 2005/05/24 06:33:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -426,6 +426,13 @@ ((typep size '(integer 1 *)) (list 'integer 0 (1- (ash 1 size)))) (t (error "Illegal size for unsigned-byte.")))) + +(define-typep rational (x &optional (lower-limit '*) (upper-limit '*)) + (and (typep x 'rational) + (or (eq lower-limit '*) + (<= lower-limit x)) + (or (eq upper-limit '*) + (<= x upper-limit)))) (deftype real (&optional (lower-limit '*) (upper-limit '*)) `(or (integer ,lower-limit ,upper-limit)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp
by ffjeld＠common-lisp.net 24 May '05

24 May '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11748 Modified Files: basic-functions.lisp Log Message: Moved some code around, to fix compilation order. Date: Tue May 24 08:33:19 2005 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.18 movitz/losp/muerte/basic-functions.lisp:1.19 --- movitz/losp/muerte/basic-functions.lisp:1.18 Thu May 5 15:21:46 2005 +++ movitz/losp/muerte/basic-functions.lisp Tue May 24 08:33:19 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.18 2005/05/05 13:21:46 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.19 2005/05/24 06:33:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -383,4 +383,48 @@ (place-name (error "The value of ~S, ~S, is not of type ~S." place-name value type)) - (t (error "~S is not of type ~S." value type)))) \ No newline at end of file + (t (error "~S is not of type ~S." value type)))) + +(defun memrange (object offset index length type) + (ecase type + (:unsigned-byte8 + (let ((vector (make-array length :element-type '(unsigned-byte 8)))) + (let ((i index)) + (dotimes (j length) + (setf (aref vector j) + (memref object offset :index i :type :unsigned-byte8)) + (incf i))) + vector)))) + +(defun (setf memrange) (value object offset index length type) + (ecase type + (:unsigned-byte8 + (etypecase value + ((unsigned-byte 8) + (do ((end (+ index length)) + (i index (1+ i))) + ((>= i end)) + (setf (memref object offset :index i :type :unsigned-byte8) value))) + (vector + (do ((end (+ index length)) + (i index (1+ i)) + (j 0 (1+ j))) + ((or (>= i end) (>= j (length value)))) + (setf (memref object offset :index i :type :unsigned-byte8) + (aref value j)))))) + (:character + (etypecase value + (character + (do ((end (+ index length)) + (i index (1+ i))) + ((>= i end)) + (setf (memref object offset :index i :type :character) value))) + (string + (do ((end (+ index length)) + (i index (1+ i)) + (j 0 (1+ j))) + ((or (>= i end) (>= j (length value)))) + (setf (memref object offset :index i :type :character) + (char value j))))))) + value) +

1 0