[movitz-cvs] CVS movitz/losp
ffjeld
ffjeld at common-lisp.net
Mon Apr 9 17:30:18 UTC 2007
Update of /project/movitz/cvsroot/movitz/losp
In directory clnet:/tmp/cvs-serv4851
Modified Files:
los0.lisp
Log Message:
Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp
file such that most of the cruft is moved into scratch.lisp, the
shallow-binding stuff is moved into lib/shallow-binding.lisp, and what
remains in los0.lisp is just the core mechanisms for the los0 kernel
application.
--- /project/movitz/cvsroot/movitz/losp/los0.lisp 2005/10/31 09:18:08 1.50
+++ /project/movitz/cvsroot/movitz/losp/los0.lisp 2007/04/09 17:30:15 1.51
@@ -1,4 +1,4 @@
-;;;;------------------------------------------------------------------
+;;;;------------------ -*- movitz-mode: t -*--------------------------
;;;;
;;;; Copyright (C) 2000-2005,
;;;; Department of Computer Science, University of Tromso, Norway
@@ -9,7 +9,7 @@
;;;; Created at: Fri Dec 1 18:08:32 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: los0.lisp,v 1.50 2005/10/31 09:18:08 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.51 2007/04/09 17:30:15 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -33,8 +33,7 @@
;; (require :lice-0.1/all)
-(defpackage muerte.init
- (:nicknames #:los0)
+(defpackage los0
(:use #:common-lisp
#:muerte
#:muerte.lib
@@ -49,742 +48,15 @@
#:muerte.x86-pc.serial
#:threading))
+(require :lib/shallow-binding)
(require :los0-gc) ; Must come after defpackage.
+;; (require :asteroids)
+(require :scratch)
-(in-package muerte.init)
-
-(defun test0 ()
- (ash 1 -1000000000000))
-
-(defun test1 ()
- (unwind-protect 0 (the integer 1)))
-
-(defun x (bios32)
- (warn "X: ~S" (memref-int bios32))
- (warn "X: ~S" (= (memref-int bios32) #x5f32335f)))
-
-(defun test2 ()
- (funcall
- (compile
- nil
- '(lambda (a) (declare (notinline > *))
- (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3)))
- (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0))))))
- 5445205692802))
-
-(defun test3 ()
- (loop for x below 2 count (not (not (typep x t)))))
-
-(defun test4 ()
- (let ((aa 1)) (if (not (/= aa 0)) aa 0)))
-
-
-(defun test-floppy ()
- (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up.
- (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70.
- (setf (muerte.x86-pc::fd-motor) nil)) ; to turn the drive and controller off.
-
-
-(defun alist-get-expand (alist key)
- (let (cons)
- (tagbody
- loop
- (setq cons (car alist))
- (cond ((eq alist nil) (go end))
- ((eq cons nil))
- ((eq key (car cons)) (go end)))
- (setq alist (cdr alist))
- (go loop)
- end)
- (cdr cons)))
-
-;;;(defun test-irq ()
-;;; (with-inline-assembly (:returns :multiple-values)
-;;; (:compile-form (:result-mode :multiple-values) (values 0 1 2 3 4 5))
-;;; (:int 42)))
-;;;
-;;;(defun koo ()
-;;; (prog1 (make-values)
-;;; (format t "hello: ~S" (values 'a 'b 'c 'd))))
-;;;
-;;;(defun test-complement (&rest args)
-;;; (declare (dynamic-extent args))
-;;; (apply (complement #'symbolp) args))
-;;;
-;;;(defun test-constantly (&rest args)
-;;; (declare (dynamic-extent args))
-;;; (apply (constantly 'test-value) args))
-
-(defun test-closure (x z)
- (flet ((closure (y) (= x (1+ y))))
- (declare (dynamic-extent (function closure)))
- (closure z)
- #+ignore (funcall (lambda (y) (= x (1+ y)))
- z)))
-
-(defun test-stack-cons (x y)
- (muerte::with-dynamic-extent-scope (zap)
- (let ((foo (muerte::with-dynamic-extent-allocation (zap)
- (cons x (lambda () y)))))
- (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo))))))
-
-(defun test-handler (x)
- (let ((foo x))
- (handler-bind
- ((error (lambda (c)
- (format t "error: ~S ~S" c x))))
- (error "This is an error. ~S" foo))))
-
-
-(defun fooo (v w)
- (tagbody
- (print (block blurgh
- (progv (list v) (list w)
- (format t "Uh: ~S" (symbol-value v))
- (if (symbol-value v)
- (return-from blurgh 1)
- (go zap)))))
- zap)
- t)
-
-
-(defun test-break ()
- (with-inline-assembly (:returns :multiple-values)
- (:movl 10 :ecx)
- (:movl :esi :eax) ; This function should return itself!
- (:clc)
- (:break)))
-
-(defun test-upload (x)
- ;; (warn "Test-upload blab la bla!!")
- (setf x (cdr x))
- x)
-
-;;;(defun zzz (x)
-;;; (multiple-value-bind (symbol status)
-;;; (values-list x)
-;;; (warn "sym: ~S, stat: ~S" symbol status)))
-;;;
-
-#+ignore
-(defun test-loop (x)
- (format t "test-loop: ~S~%"
- (loop for i from 0 to 10 collect x)))
-
-#+ignore
-(defun delay (time)
- (dotimes (i time)
- (with-inline-assembly (:returns :nothing)
- (:nop)
- (:nop))))
-;;;
-;;;(defun test-consp (x)
-;;; (with-inline-assembly (:returns :boolean-cf=1)
-;;; (:compile-form (:result-mode :ecx) x)
-;;; (:leal (:edi -4) :eax)
-;;; (:rorb :cl :al)))
-
-
-#+ignore
-(defun test-block (x)
- (block nil
- (let ((*print-base* (if x (return 3) 8)))
- (jumbo 2 2 (and x 2) (+ 3 3 (or x 4)) (if x 2 (return nil)))))
- #+ignore (+ x 2))
-
-#+ignore
-(defun jumbo (a b c &rest x)
- (declare (dynamic-extent x))
- (print a) (print b) (print c)
- (print x)
- 'jumbo)
-
-(defun jumbo2 (a b &rest x)
- (declare (dynamic-extent x))
- (print a) (print b)
- (print x)
- 'jumbo)
-
-(defun jumbo3 (a &rest x)
- (declare (dynamic-extent x))
- (print a)
- (print x)
- 'jumbo)
-
-(defun jumbo4 (&rest x)
- (declare (dynamic-extent x))
- (print x)
- 'jumbo)
-
-#+ignore
-(defun tagbodyxx (x)
- (tagbody
- (print 'hello)
- haha
- (unwind-protect
- (when x (go hoho))
- (warn "unwind.."))
- (print 'world)
- hoho
- (print 'blrugh)))
-
-#+ignore
-(defun tagbodyxx (x)
- (tagbody
- (print 'hello)
- haha
- (unwind-protect
- (funcall (lambda ()
- (when x (go hoho))))
- (warn "unwind.."))
- (print 'world)
- hoho
- (print 'blrugh)))
-
-#+ignore
-(defun kumbo (&key a b (c (jumbo 1 2 3)) d)
- (print a)
- (print b)
- (print c)
- (print d))
-
-#+ignore
-(defun lumbo (a &optional (b 'zap))
- (print a)
- (print b))
-
-(defmacro do-check-esp (&body body)
- `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax))))
- (with-inline-assembly (:returns :nothing)
- (:compile-form (:result-mode :multiple-values) (progn , at body)))
- (unless (eq before
- (with-inline-assembly (:returns :eax) (:movl :esp :eax)))
- (error "ESP before body: ~S, after: ~S"
- (with-inline-assembly (:returns :eax) (:movl :esp :eax))))))
-
-#+ignore
-(defun test-m-v-call ()
- (do-check-esp
- (multiple-value-call #'format t "~@{ ~D~}~%"
- 'a (values) 'b (test-loop 1) (make-values)
- 'c 'd 'e (make-no-values) 'f)))
-
-(defun test-m-v-call2 ()
- (multiple-value-call #'format t "~@{ ~D~}~%"
- 'a 'b (values 1 2 3) 'c 'd 'e 'f))
-
-(defun make-values ()
- (values 0 1 2 3 4 5))
-
-(defun xfuncall (&rest args)
- (declare (dynamic-extent args))
- (break "xfuncall:~{ ~S~^,~}" args)
- (values))
-
-(defun xfoo (f)
- (do-check-esp
- (multiple-value-bind (a b c d)
- (multiple-value-prog1 (make-values)
- (format t "hello world"))
- (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f))))
-
-
-#+ignore
-(defun make-no-values ()
- (values))
-
-#+ignore
-(defun test-nth-values ()
- (nth-value 2 (make-values)))
-
-#+ignore
-(defun test-values2 ()
- (multiple-value-bind (a b c d e f g h)
- (make-values)
- (format t "test-values2: A: ~S, B: ~S, C: ~S, D: ~S, E: ~S, F: ~S G: ~S, H: ~S~%"
- a b c d e f g h)))
-
-#+ignore
-(defun test-flet (zap)
- (flet ((pingo (z y x)
- (declare (ignore y z))
- (format t "This is pingo: ~S with zap: ~W~%" x zap)))
- ;; (declare (dynamic-extent pingo))
- (pingo 100 200 300)))
-
-#+ignore
-(defun test-flet2 (zap)
- (flet ((pingo (z y x)
- (declare (ignore y z))
- (format t "This is pingo: ~S with zap: ~W~%" x zap)))
- ;; (declare (dynamic-extent pingo))
- (lambda (x)
- (pingo 100 200 300))))
-
-(defun test-boo ()
- (let ((real-cmuc #'test-flet2))
- (let ((plongo (lambda (x)
- (warn "~S real-cmuc: ~S" x real-cmuc)
- (funcall real-cmuc x))))
- (funcall plongo 'zooom))))
-
-(defun test-labels ()
- (labels ((pingo (x)
- (format t "~&This is pingo: ~S~%" x)
- (when (plusp x)
- (pingo (1- x)))))
- (pingo 5)))
-
-#+ignore
-(defun foo-type (length start1 sequence-1)
- (do* ((i 0 #+ignore (+ start1 length -1) (1- i)))
- ((< i start1) sequence-1)
- (declare (type muerte::index i length))
- (setf (sequence-1-ref i)
- 'foo)))
-
-
-#+ignore
-(defun test-values ()
- (multiple-value-bind (a b c d e f g h i j)
- (multiple-value-prog1
- (make-values)
-;;; (format t "this is the resulting form.~%")
- (format t "this is the first ignorable form.~%" 1 2 3)
- (format t "this is the second ignorable form.~%"))
-;;; (format t "test-values num: ~D~%" (capture-reg8 :cl))
- (format t "test-values: A: ~Z, B: ~Z, C: ~Z, D: ~Z ~Z ~Z ~Z ~Z ~Z ~Z~%" a b c d e f g h i j)))
-
-
-#+ignore
-(defun test-keywords (&key a b (c 100) ((:d x) 5 x-p))
- (format t "test-keywords: a: ~S, b: ~S, c: ~S, x: ~S, x-p: ~S~%"
- a b c x x-p))
-
-#+ignore
-(defun test-k1 (a b &key x)
- (declare (ignore a b))
- (warn "x: ~S" x))
-
-(defun test-funcall (&rest args)
- (declare (dynamic-extent args))
- (format t "~&test-funcall args: ~S~%" args))
-
-#+ignore
-(defun test-rest (&optional (a0 nil a0-p) a1 a3 &rest args)
- (declare (dynamic-extent args))
- (when a0-p
- (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args)))
-
-
-(defun test-return ()
- (print (block nil
- (values 'x 'y (if (foo) (return 'foo) (return-from test-return 'not-foo)) 'bar)))
- 5)
-
-#+ignore
-(defun test-lexthrow (x)
- (apply (lambda (a b)
- (unwind-protect
- (if (plusp a) 0 (return-from test-lexthrow (+ a b)))
- (warn "To serve and protect!")))
- x))
-
-#+ignore
-(defun test-lexgo (x)
- (let ((*print-base* 2))
- (return-from test-lexgo (print 123))))
-
-#+ignore
-(defun test-xgo (c x)
- (tagbody
- loop
- (warn "c: ~S" c)
- (apply (lambda (a)
- (decf c)
- (if (plusp a) (go exit) (go loop))
- (warn "juhu, a or x: ~S, c: ~S" a c))
- x)
- exit
- (warn "exited: ~S" c)))
-
-
-(defun test-bignum ()
- 123456789123456)
-
-(defun fe32 ()
- #xfffffffe)
-
[1005 lines skipped]
More information about the Movitz-cvs
mailing list