[movitz-cvs] CVS movitz/losp
ffjeld
ffjeld at common-lisp.net
Sat Feb 23 22:28:55 UTC 2008
Update of /project/movitz/cvsroot/movitz/losp
In directory clnet:/tmp/cvs-serv5997
Modified Files:
scratch.lisp
Log Message:
Remove DOS EOL.
--- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/04 21:04:51 1.2
+++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/23 22:28:55 1.3
@@ -1,1164 +1,1164 @@
-;;;;------------------ -*- movitz-mode: t -*--------------------------
-;;;;
-;;;; Copyright (C) 2007, Frode Vatvedt Fjeld
-;;;;
-;;;; Filename: scratch.lisp
-;;;; Description: Misc. testing code etc.
-;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
-;;;; Distribution: See the accompanying file COPYING.
-;;;;
-;;;; $Id: scratch.lisp,v 1.2 2008/02/04 21:04:51 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 setfint (x o)
- (setf (memref x o :type :unsigned-byte32) 0))
-
-(defun fint (x)
- (memref-int x :type :unsigned-byte32 :physicalp t))
-
-(defun good ()
- (with-inline-assembly (:returns :untagged-fixnum-ecx)
- ((:gs-override) :movl (#x1000000) :ecx)))
-
-(defun (setf good) (x)
- (with-inline-assembly (:returns :untagged-fixnum-ecx)
- (:compile-form (:result-mode :untagged-fixnum-ecx) x)
- ((:gs-override) :movl :ecx (#x1000000))))
-
-(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))
-
[1931 lines skipped]
More information about the Movitz-cvs
mailing list