Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv4903

Added Files: scratch.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/scratch.lisp 2007/04/09 17:30:22 NONE +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2007/04/09 17:30:22 1.1 ;;;;------------------ -*- movitz-mode: t -*-------------------------- ;;;; ;;;; Copyright (C) 2007, Frode Vatvedt Fjeld ;;;; ;;;; Filename: scratch.lisp ;;;; Description: Misc. testing code etc. ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: scratch.lisp,v 1.1 2007/04/09 17:30:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

(provide :scratch)

(in-package los0)

#+ignore (defun set.2 () (let ((*var-used-in-set-tests* 'a) (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values (let ((*var-used-in-set-tests* 'c)) (list (set var 'b) *var-used-in-set-tests* (symbol-value var))) *var-used-in-set-tests*))) ;; (b c b) ;; b)

#+ignore (defun test-lend-constant () (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) (table (make-hash-table :test #'eq))) (loop for sym in symbols for i from 1 do (setf (gethash sym table) i)) (let ((sum 0)) (values (maphash #'(lambda (k v) (assert (eq (elt symbols (1- v)) k)) (incf sum v)) table) sum))))

#+ignore (defun test-aux (x y &aux (sum (+ x y))) sum)

#+ignore (defun mapc.error.3 () (mapc #'append))

#+ignore (defun with-hash-table-iterator.12 () (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-hash-table-iterator (m (return-from done x)) (declare (special x)))))) :good)

#+ignore (defun string.15 () (when (> char-code-limit 65536) (loop for i = (random char-code-limit) for c = (code-char i) for s = (and c (string c)) repeat 2000 when (and c (or (not (stringp s)) (not (= (length s) 1)) (not (eql c (char s 0))))) collect (list i c s))) nil)

(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 ,@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)

[749 lines skipped]