[movitz-cvs] CVS movitz/losp - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

23 Feb 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@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 ,@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]

    