losp/scratch.lisp

   1 ;;;;------------------ -*- movitz-mode: t -*--------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2007, Frode Vatvedt Fjeld
   4 ;;;;
   5 ;;;; Filename:      scratch.lisp
   6 ;;;; Description:   Misc. testing code etc.
   7 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   8 ;;;; Distribution:  See the accompanying file COPYING.
   9 ;;;;
  10 ;;;; $Id: scratch.lisp,v 1.3 2008/02/23 22:28:55 ffjeld Exp $
  11 ;;;;
  12 ;;;;------------------------------------------------------------------
  13
  14 (provide :scratch)
  15
  16 (in-package los0)
  17
  18 #+ignore
  19 (defun set.2 ()
  20   (let ((*var-used-in-set-tests* 'a)
  21         (var '*var-used-in-set-tests*))
  22     (declare (special *var-used-in-set-tests*))
  23     (values
  24      (let ((*var-used-in-set-tests* 'c))
  25        (list (set var 'b) *var-used-in-set-tests* (symbol-value var)))
  26      *var-used-in-set-tests*)))
  27 ;;   (b c b)
  28 ;;   b)
  29
  30 #+ignore
  31 (defun test-lend-constant ()
  32   (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))
  33         (table (make-hash-table :test #'eq)))
  34     (loop for sym in symbols
  35           for i from 1
  36           do (setf (gethash sym table) i))
  37     (let ((sum 0))
  38       (values (maphash #'(lambda (k v)
  39                            (assert (eq (elt symbols (1- v)) k))
  40                            (incf sum v))
  41                        table)
  42               sum))))
  43
  44 #+ignore
  45 (defun test-aux (x y &aux (sum (+ x y)))
  46   sum)
  47
  48 #+ignore
  49 (defun mapc.error.3 ()
  50   (mapc #'append))
  51
  52 #+ignore
  53 (defun with-hash-table-iterator.12 ()
  54   (block done
  55     (let ((x :bad))
  56       (declare (special x))
  57       (let ((x :good))
  58         (with-hash-table-iterator (m (return-from done x))
  59           (declare (special x))))))
  60   :good)
  61
  62 #+ignore
  63 (defun string.15 ()
  64   (when (> char-code-limit 65536)
  65     (loop for i = (random char-code-limit)
  66         for c = (code-char i)
  67         for s = (and c (string c))
  68         repeat 2000
  69         when (and c
  70                   (or (not (stringp s))
  71                       (not (= (length s) 1))
  72                       (not (eql c (char s 0)))))
  73         collect (list i c s)))
  74   nil)
  75
  76 (defun x (bios32)
  77   (warn "X: ~S" (memref-int bios32))
  78   (warn "X: ~S" (= (memref-int bios32) #x5f32335f)))
  79
  80 (defun setfint (x o)
  81   (setf (memref x o :type :unsigned-byte32) 0))
  82
  83 (defun fint (x)
  84   (memref-int x :type :unsigned-byte32 :physicalp t))
  85
  86 (defun good ()
  87   (with-inline-assembly (:returns :untagged-fixnum-ecx)
  88     ((:gs-override) :movl (#x1000000) :ecx)))
  89
  90 (defun (setf good) (x)
  91   (with-inline-assembly (:returns :untagged-fixnum-ecx)
  92     (:compile-form (:result-mode :untagged-fixnum-ecx) x)
  93     ((:gs-override) :movl :ecx (#x1000000))))
  94
  95 (defun test2 ()
  96   (funcall
  97    (compile
  98     nil
  99     '(lambda (a) (declare (notinline > *))
 100       (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3)))
 101       (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0))))))
 102    5445205692802))
 103
 104 (defun test3 ()
 105   (loop for x below 2 count (not (not (typep x t)))))
 106
 107 (defun test4 ()
 108   (let ((aa 1)) (if (not (/= aa 0)) aa 0)))
 109
 110
 111 (defun test-floppy ()
 112   (muerte.x86-pc::fd-start-disk)        ; to initialize the controller and spin the drive up.
 113   (muerte.x86-pc::fd-cmd-seek 70)       ; to seek to track 70.
 114   (setf (muerte.x86-pc::fd-motor) nil)) ; to turn the drive and controller off.
 115
 116
 117 (defun alist-get-expand (alist key)
 118   (let (cons)
 119     (tagbody
 120      loop
 121        (setq cons (car alist))
 122        (cond ((eq alist nil) (go end))
 123              ((eq cons nil))
 124              ((eq key (car cons)) (go end)))
 125        (setq alist (cdr alist))
 126        (go loop)
 127      end)
 128     (cdr cons)))
 129
 130 ;;;(defun test-irq ()
 131 ;;;  (with-inline-assembly (:returns :multiple-values)
 132 ;;;    (:compile-form (:result-mode :multiple-values) (values 0 1 2 3 4 5))
 133 ;;;    (:int 42)))
 134 ;;;
 135 ;;;(defun koo ()
 136 ;;;  (prog1 (make-values)
 137 ;;;    (format t "hello: ~S" (values 'a 'b 'c 'd))))
 138 ;;;
 139 ;;;(defun test-complement (&rest args)
 140 ;;;  (declare (dynamic-extent args))
 141 ;;;  (apply (complement #'symbolp) args))
 142 ;;;
 143 ;;;(defun test-constantly (&rest args)
 144 ;;;  (declare (dynamic-extent args))
 145 ;;;  (apply (constantly 'test-value) args))
 146
 147 (defun test-closure (x z)
 148   (flet ((closure (y) (= x (1+ y))))
 149     (declare (dynamic-extent (function closure)))
 150     (closure z)
 151     #+ignore (funcall (lambda (y) (= x (1+ y)))
 152                       z)))
 153
 154 (defun test-stack-cons (x y)
 155   (muerte::with-dynamic-extent-scope (zap)
 156     (let ((foo (muerte::with-dynamic-extent-allocation (zap)
 157                  (cons x (lambda () y)))))
 158       (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo))))))
 159
 160 (defun test-handler (x)
 161   (let ((foo x))
 162     (handler-bind
 163         ((error (lambda (c)
 164                   (format t "error: ~S ~S" c x))))
 165       (error "This is an error. ~S" foo))))
 166
 167
 168 (defun fooo (v w)
 169   (tagbody
 170     (print (block blurgh
 171              (progv (list v) (list w)
 172                (format t "Uh: ~S" (symbol-value v))
 173                (if (symbol-value v)
 174                    (return-from blurgh 1)
 175                  (go zap)))))
 176    zap)
 177   t)
 178
 179
 180 (defun test-break ()
 181   (with-inline-assembly (:returns :multiple-values)
 182     (:movl 10 :ecx)
 183     (:movl :esi :eax)                   ; This function should return itself!
 184     (:clc)
 185     (:break)))
 186
 187 (defun test-upload (x)
 188   ;; (warn "Test-upload blab la bla!!")
 189   (setf x (cdr x))
 190   x)
 191
 192 ;;;(defun zzz (x)
 193 ;;;  (multiple-value-bind (symbol status)
 194 ;;;      (values-list x)
 195 ;;;    (warn "sym: ~S, stat: ~S" symbol status)))
 196 ;;;
 197
 198 #+ignore
 199 (defun test-loop (x)
 200   (format t "test-loop: ~S~%"
 201           (loop for i from 0 to 10 collect x)))
 202
 203 #+ignore
 204 (defun delay (time)
 205   (dotimes (i time)
 206     (with-inline-assembly (:returns :nothing)
 207       (:nop)
 208       (:nop))))
 209 ;;;
 210 ;;;(defun test-consp (x)
 211 ;;;  (with-inline-assembly (:returns :boolean-cf=1)
 212 ;;;    (:compile-form (:result-mode :ecx) x)
 213 ;;;    (:leal (:edi -4) :eax)
 214 ;;;    (:rorb :cl :al)))
 215
 216
 217 #+ignore
 218 (defun test-block (x)
 219   (block nil
 220     (let ((*print-base* (if x (return 3) 8)))
 221       (jumbo 2 2 (and x 2) (+ 3 3 (or x 4)) (if x 2 (return nil)))))
 222   #+ignore (+ x 2))
 223
 224 #+ignore
 225 (defun jumbo (a b c &rest x)
 226   (declare (dynamic-extent x))
 227   (print a) (print b) (print c)
 228   (print x)
 229   'jumbo)
 230
 231 (defun jumbo2 (a b &rest x)
 232   (declare (dynamic-extent x))
 233   (print a) (print b)
 234   (print x)
 235   'jumbo)
 236
 237 (defun jumbo3 (a &rest x)
 238   (declare (dynamic-extent x))
 239   (print a)
 240   (print x)
 241   'jumbo)
 242
 243 (defun jumbo4 (&rest x)
 244   (declare (dynamic-extent x))
 245   (print x)
 246   'jumbo)
 247
 248 #+ignore
 249 (defun tagbodyxx (x)
 250   (tagbody
 251     (print 'hello)
 252    haha
 253     (unwind-protect
 254         (when x (go hoho))
 255       (warn "unwind.."))
 256     (print 'world)
 257    hoho
 258     (print 'blrugh)))
 259
 260 #+ignore
 261 (defun tagbodyxx (x)
 262   (tagbody
 263     (print 'hello)
 264    haha
 265     (unwind-protect
 266         (funcall (lambda ()
 267                    (when x (go hoho))))
 268       (warn "unwind.."))
 269     (print 'world)
 270    hoho
 271     (print 'blrugh)))
 272
 273 #+ignore
 274 (defun kumbo (&key a b (c (jumbo 1 2 3)) d)
 275   (print a)
 276   (print b)
 277   (print c)
 278   (print d))
 279
 280 #+ignore
 281 (defun lumbo (a &optional (b 'zap))
 282   (print a)
 283   (print b))
 284
 285 (defmacro do-check-esp (&body body)
 286   `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax))))
 287      (with-inline-assembly (:returns :nothing)
 288        (:compile-form (:result-mode :multiple-values) (progn ,@body)))
 289      (unless (eq before
 290                  (with-inline-assembly (:returns :eax) (:movl :esp :eax)))
 291        (error "ESP before body: ~S, after: ~S"
 292               (with-inline-assembly (:returns :eax) (:movl :esp :eax))))))
 293
 294 #+ignore
 295 (defun test-m-v-call ()
 296   (do-check-esp
 297       (multiple-value-call #'format t "~@{ ~D~}~%"
 298                            'a (values) 'b (test-loop 1) (make-values)
 299                            'c 'd  'e (make-no-values) 'f)))
 300
 301 (defun test-m-v-call2 ()
 302   (multiple-value-call #'format t "~@{ ~D~}~%"
 303                        'a 'b (values 1 2 3) 'c 'd 'e 'f))
 304
 305 (defun make-values ()
 306   (values 0 1 2 3 4 5))
 307
 308 (defun xfuncall (&rest args)
 309   (declare (dynamic-extent args))
 310   (break "xfuncall:~{ ~S~^,~}" args)
 311   (values))
 312
 313 (defun xfoo (f)
 314   (do-check-esp
 315       (multiple-value-bind (a b c d)
 316           (multiple-value-prog1 (make-values)
 317             (format t "hello world"))
 318         (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f))))
 319
 320
 321 #+ignore
 322 (defun make-no-values ()
 323   (values))
 324
 325 #+ignore
 326 (defun test-nth-values ()
 327   (nth-value 2 (make-values)))
 328
 329 #+ignore
 330 (defun test-values2 ()
 331   (multiple-value-bind (a b c d e f g h)
 332       (make-values)
 333     (format t "test-values2: A: ~S, B: ~S, C: ~S, D: ~S, E: ~S, F: ~S G: ~S, H: ~S~%"
 334             a b c d e f g h)))
 335
 336 #+ignore
 337 (defun test-flet (zap)
 338   (flet ((pingo (z y x)
 339            (declare (ignore y z))
 340            (format t "This is pingo: ~S with zap: ~W~%" x  zap)))
 341     ;; (declare (dynamic-extent pingo))
 342     (pingo 100 200 300)))
 343
 344 #+ignore
 345 (defun test-flet2 (zap)
 346   (flet ((pingo (z y x)
 347            (declare (ignore y z))
 348            (format t "This is pingo: ~S with zap: ~W~%" x  zap)))
 349     ;; (declare (dynamic-extent pingo))
 350     (lambda (x)
 351       (pingo 100 200 300))))
 352
 353 (defun test-boo ()
 354   (let ((real-cmuc #'test-flet2))
 355     (let ((plongo (lambda (x)
 356                     (warn "~S real-cmuc: ~S" x real-cmuc)
 357                     (funcall real-cmuc x))))
 358       (funcall plongo 'zooom))))
 359
 360 (defun test-labels ()
 361   (labels ((pingo (x)
 362              (format t "~&This is pingo: ~S~%" x)
 363              (when (plusp x)
 364                (pingo (1- x)))))
 365     (pingo 5)))
 366
 367 #+ignore
 368 (defun foo-type (length start1 sequence-1)
 369   (do* ((i 0 #+ignore (+ start1 length -1) (1- i)))
 370       ((< i start1) sequence-1)
 371     (declare (type muerte::index i length))
 372     (setf (sequence-1-ref i)
 373       'foo)))
 374
 375
 376 #+ignore
 377 (defun test-values ()
 378   (multiple-value-bind (a b c d e f g h i j)
 379       (multiple-value-prog1
 380           (make-values)
 381 ;;;         (format t "this is the resulting form.~%")
 382         (format t "this is the first ignorable form.~%" 1 2 3)
 383         (format t "this is the second ignorable form.~%"))
 384 ;;;    (format t "test-values num: ~D~%" (capture-reg8 :cl))
 385     (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)))
 386
 387
 388 #+ignore
 389 (defun test-keywords (&key a b (c 100) ((:d x) 5 x-p))
 390   (format t "test-keywords: a: ~S, b: ~S, c: ~S, x: ~S, x-p: ~S~%"
 391           a b c x x-p))
 392
 393 #+ignore
 394 (defun test-k1 (a b &key x)
 395   (declare (ignore a b))
 396   (warn "x: ~S" x))
 397
 398 (defun test-funcall (&rest args)
 399   (declare (dynamic-extent args))
 400   (format t "~&test-funcall args: ~S~%" args))
 401
 402 #+ignore
 403 (defun test-rest (&optional (a0 nil a0-p) a1 a3 &rest args)
 404   (declare (dynamic-extent args))
 405   (when a0-p
 406     (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args)))
 407
 408
 409 (defun test-return ()
 410   (print (block nil
 411            (values 'x 'y (if (foo) (return 'foo) (return-from test-return 'not-foo)) 'bar)))
 412   5)
 413
 414 #+ignore
 415 (defun test-lexthrow (x)
 416   (apply (lambda (a b)
 417            (unwind-protect
 418                (if (plusp a) 0 (return-from test-lexthrow (+ a b)))
 419              (warn "To serve and protect!")))
 420          x))
 421
 422 #+ignore
 423 (defun test-lexgo (x)
 424   (let ((*print-base* 2))
 425     (return-from test-lexgo (print 123))))
 426
 427 #+ignore
 428 (defun test-xgo (c x)
 429   (tagbody
 430    loop
 431     (warn "c: ~S" c)
 432     (apply (lambda (a)
 433              (decf c)
 434              (if (plusp a) (go exit) (go loop))
 435              (warn "juhu, a or x: ~S, c: ~S" a c))
 436            x)
 437    exit
 438     (warn "exited: ~S" c)))
 439
 440
 441 (defun test-bignum ()
 442   123456789123456)
 443
 444 (defun fe32 ()
 445   #xfffffffe)
 446
 447 (defun fe64 ()
 448   #xfffffffffffffffe)
 449
 450 (defun fe96 ()
 451   #xfffffffffffffffffffffffe)
 452
 453 (defun one32 ()
 454   #x100000000)
 455
 456 (defun z (op x y)
 457   (let ((foo (cons 1 2))
 458         (result (funcall op x y))
 459         (bar (cons 3 4)))
 460     (if (not (typep result 'pointer))
 461         (warn "foo: ~Z result: ~Z, bar: ~Z, diff foo-bar: ~D."
 462               foo result bar
 463               (- (object-location bar) (object-location foo)))
 464       (warn "foo: ~Z result: ~Z, bar: ~Z, diff: ~D, ~D."
 465             foo result bar
 466             (- (object-location result) (object-location foo))
 467             (- (object-location bar) (object-location result))))
 468     (values foo result bar)))
 469
 470 (defun modx (x)
 471   (lambda ()
 472     (print x)))
 473
 474 (defun mod30 (x)
 475   (ldb (Byte 30 0) x))
 476
 477 (defun mod32-4 (x)
 478   (ldb (byte 28 4) x))
 479
 480 (defun mod24-4 (x)
 481   (ldb (Byte 24 4) x))
 482
 483 (defun zz (op x y)
 484   (let ((foo (vector 1 2))
 485         (result (funcall op x y))
 486         (bar (vector 3 4)))
 487     (if (not (typep result 'pointer))
 488         (warn "foo: ~Z result: ~Z, bar: ~Z, diff foo-bar: ~D."
 489               foo result bar
 490               (- (object-location bar) (object-location foo)))
 491       (warn "foo: ~Z result: ~Z, bar: ~Z, diff: ~D, ~D."
 492             foo result bar
 493             (- (object-location result) (object-location foo))
 494             (- (object-location bar) (object-location result))))
 495     (values foo result bar)))
 496
 497 (defun testb ()
 498   #(1 2 3 4))
 499
 500 (defun gt5 (x)
 501   (<= x 5))
 502
 503 (defun xplus (x)
 504   (typep x '(integer 0 *)))
 505
 506 (defstruct (xxx :constructor (:constructor boa-make-xxx (x y z)))
 507   x y (z 'init-z))
 508
 509 (defun test-struct ()
 510   (format t "make-xxx: ~S~%" (let ((s (make-xxx))) s))
 511   (format t "make-xxx: ~S~%" (xxx-z (make-xxx))))
 512
 513 (defun test-dynamic ()
 514   #+ignore
 515   (let ((x 100))
 516     (let ((y x))
 517       (let ((z y))
 518         (format t "y: ~S, x: ~S, z: ~S~%" y x z))))
 519   #+ignore
 520   (format t "~D ~D ~D~%" 0 1
 521           (let ((*x* 100))
 522             (declare (special *x*))
 523             (format t "*x*: ~S~%" *x*)
 524             (symbol-value '*x*)))
 525   #+ignore
 526   (format t "~D ~D ~D~%" 0 1
 527           (progv '(*x*) '(101)
 528             (format t "*x*: ~S~%" (symbol-value '*x*))
 529             (symbol-value '*x*)))
 530   (let ((*x* 200))
 531     (declare (special *x*))
 532     (format t "*x*: ~S~%" *x*)
 533     #+ignore
 534     (let ((*x* 300))
 535       (declare (special *x*))
 536       (format t "*x*: ~S~%" *x*))
 537     *x*))
 538
 539 #+ignore
 540 (defun test-dynamic-formal (*print-base*)
 541   (print *print-base*))
 542
 543 #+ignore
 544 (defun verify-throw ()
 545   "CLHS speaketh:
 546 The following prints ``The inner catch returns :SECOND-THROW'' and then returns :outer-catch."
 547   (catch 'foo
 548     (format t "The inner catch returns ~s.~%"
 549             (catch 'foo
 550               (unwind-protect (throw 'foo :first-throw)
 551                 (throw 'foo :second-throw))))
 552     :outer-catch))
 553
 554 #+ignore
 555 (defun do-throw ()
 556   (unwind-protect (print 'hello)
 557     (throw 'foo :second-throw)))
 558
 559
 560 #+ignore
 561 (defun bloo (x)
 562   #'bloo
 563   (multiple-value-prog1
 564       (sloo x (1+ x))
 565     (print 'hello)))
 566
 567 #+ignore
 568 (defun sloo (&rest x)
 569   (declare (dynamic-extent x))
 570   (let ((y (car x)))
 571     (sloo y)))
 572
 573 #+ignore
 574 (defun test-throw (tag)
 575   (unwind-protect
 576       (warn "throw: ~Z" (throw tag (values 'throw1 (make-values) 'throw2)))
 577     (warn "Something happened: ~W" (make-values))
 578     #+ignore (return-from test-throw 'interrupted-value))
 579   (error "Huh?"))
 580
 581 #+ignore
 582 (defun test-catch (x)
 583   (catch 'test-tag
 584     (test-throw x 'test-tag)
 585     (format t "Hello world")))
 586
 587 (defun test-throw (x tag)
 588   (when x
 589     (warn "Throwing ~S.." tag)
 590     (throw tag (values-list x))))
 591
 592 #+ignore
 593 (defun test-up-catch ()
 594   (catch 'test-tag
 595     (test-up 'test-tag)
 596     (format t "Hello world")))
 597
 598 #+ignore
 599 (defun test-up (tag)
 600  (unwind-protect
 601       (test-throw tag)
 602    (print 'hello-cleanup)))
 603
 604 (defun test-cons (x)
 605   (let ((cc (cons x x)))
 606     (cdr cc)))
 607
 608 (defun xx (x)
 609   (eql nil x))
 610
 611 (defun test-fixed (x y z)
 612   (warn "x: ~W, y: ~W, z: ~W" x y z))
 613
 614 (defun test-let-closure ()
 615   (tagbody
 616     (let ((*print-base* 10)
 617           (x (go zz))
 618           (*print-radix* nil))
 619       (warn "lending x: ~W" x)
 620       (values (lambda ()
 621                 (warn "borrowed x: ~W" x)
 622                 (* x 2))
 623               #+ignore
 624               (lambda (y)
 625                 (setf x y))))
 626    zz
 627     (warn "zz")))
 628
 629 (defun test-not (x)
 630   (if (not x) 0 100))
 631
 632 (defun test-pingo (z)
 633   (block zzz
 634     (warn "hello world")
 635     (let ((zingo (+ z 23)))
 636       (return-from zzz
 637         (let ((x (* z zingo)))
 638           (print (* x 2)))))
 639     (warn "not this")))
 640
 641 (defun display-hash (x)
 642   (loop for k being the hash-keys of x using (hash-value v)
 643       do (format t "~&~S => ~S" k v))
 644   (values))
 645
 646 ;;;(defclass test-class ()
 647 ;;;  (s1 s2))
 648 ;;;
 649 (defun show-hash (x)
 650   (loop for y being the hash-keys of x
 651       do (format t "~&key: ~W [~W]" y (symbol-package y)))
 652   (values))
 653 ;;;
 654 ;;;
 655 ;;;(defclass c () (s1 s2))
 656 ;;;
 657 ;;;(defgeneric m (x))
 658 ;;;(defmethod m ((x c))
 659 ;;;  (declare (ignore x))
 660 ;;;  (warn "more m's: ~{~W~}" (when (next-method-p)
 661 ;;;                          (list (call-next-method))))
 662 ;;;  #'call-next-method)
 663 ;;;
 664 ;;;(defmethod m ((x standard-object))
 665 ;;;  (declare (ignore x))
 666 ;;;  'this-is-m-on-standard-object)
 667 ;;;
 668 ;;;(defmethod m ((x fixnum))
 669 ;;;  (declare (ignore x))
 670 ;;;  'this-is-m-on-fixnum)
 671
 672 (defun test-nested-extent ()
 673   ;; Check that the compiler doesn't suffer from the let nested-extent problem.
 674   ;; identity is used so the compiler won't shortcut the bindings.
 675   (let ((foo (identity 'foo-value))
 676         (bar (let ((zot (identity 'test-nested-extent)))
 677                (setq zot 'zot-value)
 678                (identity zot))))
 679     (if (eq foo 'foo-value)
 680         (format t "~&Success: foo is ~W, bar is ~W" foo bar)
 681       (format t "~&Failure! foo is ~W, bar is ~W" foo bar))))
 682
 683 (defun bar (x)
 684   (multiple-value-prog1
 685       (values 0 1 2)
 686     (format t "blungolo: ~S" x)))
 687
 688
 689
 690 #+ignore
 691 (defun test-ncase (x y z)
 692   (numargs-case
 693    (1 (x) (values x 'one))
 694    (2 (x y) (values (+ x y) 'one 'two))
 695    (3 (x y z) (values (+ x y z) 'one 'two 'three))
 696    (t (args) (declare (ignore args)) 27)))
 697
 698 #+ignore
 699 (defun xbar ()
 700   (print-dynamic-context :terse t)
 701   (block handler-case-block
 702     (let (handler-case-var)
 703       (tagbody
 704         (handler-bind
 705             ((error (lambda (handler-case-temp-var)
 706                       (setq handler-case-var handler-case-temp-var)
 707                       (go handler-case-clause-tag))))
 708             (print-dynamic-context :terse t)
 709             (return-from handler-case-block
 710               (signal "hello world")))
 711        handler-case-clause-tag
 712         (return-from handler-case-block
 713           (let ((|c| handler-case-var))
 714             (format t "got an error: ~s" |c|))))))
 715   (print-dynamic-context :terse t))
 716
 717 #+ignore
 718 (defun plingu (&optional v)
 719   (let ((x (1+ *print-base*)))
 720     (print "foo")
 721     (print "foo")
 722     (print x)
 723     (print v)))
 724
 725 #+ignore
 726 (defun (setf dingu) (x y)
 727   (when (> x y)
 728     (return-from dingu 'fooob))
 729   (+ x y))
 730
 731
 732 (defun foo (&edx edx x &optional (y nil yp))
 733   (format t "~@{ ~A~}" x y yp edx))
 734
 735 (defun wefwe (&rest args)
 736   (declare (dynamic-extent args))
 737   (do ((p args (cdr p)))
 738       ((endp p))
 739     (let ((x (car p)))
 740       (print x))))
 741
 742 (defun mubmo ()
 743   (let ((x (muerte::copy-funobj #'format))
 744         (y (cons 1 2)))
 745     (warn "x: ~Z, y: ~Z" x y)))
 746
 747 ;;;;;
 748
 749 (defclass food () ())
 750
 751 (defgeneric cook (food))
 752
 753 ;;;(defmethod cook :before ((f food))
 754 ;;;  (declare (ignore f))
 755 ;;;  (print "A food is about to be cooked."))
 756 ;;;
 757 ;;;(defmethod cook :after ((f food))
 758 ;;;  (declare (ignore f))
 759 ;;;  (print "A food has been cooked."))
 760
 761 (defmethod cook :after ((f food))
 762   (declare (ignore f))
 763   (print "Cooking some food."))
 764
 765 (defun test-pie (n pie)
 766   (dotimes (i n)
 767     (pie-filling pie)))
 768
 769 (defun test-inc (n)
 770   (dotimes (i n)
 771     (warn "foo: ~S" (lambda ()
 772                       (setf i 5)))))
 773
 774 (defun test-id (n x)
 775   (dotimes (i n)
 776     (identity x)))
 777
 778 (defun test-inc2 (x)
 779   (print (prog1 x (incf x)))
 780   (print x))
 781
 782 (defclass pie (food)
 783   ((filling :accessor pie-filling
 784             :initarg :filling
 785             :initform 'apple))
 786   #+ignore (:default-initargs :filling (if (foo) 'apple 'banana)))
 787
 788 (defclass pie2 (food)
 789   ((filling :accessor pie-filling
 790             :initarg :filling
 791             )))
 792
 793 (defmethod cook ((p (eql 'pie)))
 794   (warn "Won't really cook a symbolic pie!")
 795   (values))
 796
 797 (defmethod cook ((p (eql 'pudding)))
 798   'cooked-pudding)
 799
 800 (defmethod slot-value-using-class :after (class (pie pie2) slot)
 801   (warn "HEy, don't poke inside my pie2!"))
 802
 803 (defmethod cook :after ((p symbol))
 804   (warn "A symbol may or may not have been cooked."))
 805
 806 (defmethod cook ((p pie))
 807   (cond
 808    ((eq 'banana (pie-filling p))
 809     (print "Won't cook a banana-pie, trying next.")
 810     (call-next-method))
 811    (t (print "Cooking a pie.")
 812       (setf (pie-filling p) (list 'cooked (pie-filling p))))))
 813
 814 (defmethod cook :before ((p pie))
 815   (declare (ignore p))
 816   (print "A pie is about to be cooked."))
 817
 818 (defmethod cook :after ((p pie))
 819   (declare (ignore p))
 820   (print "A pie has been cooked."))
 821
 822 (defun xwrite (object)
 823   (with-inline-assembly (:returns :nothing)
 824     (:locally (:movl (:edi (:edi-offset muerte::dynamic-env)) :eax))
 825     (:movl :eax (#x1000000))
 826     (:movl :ebp (#x1000004))
 827     (:movl :esi (#x1000008)))
 828   (block handler-case-block-1431896
 829     (let (handler-case-var-1431897)
 830       (tagbody
 831         (handler-bind
 832             ((serious-condition
 833               (lambda (handler-case-temp-var-1431898)
 834                 (setq handler-case-var-1431897 handler-case-temp-var-1431898)
 835                 (go handler-case-clause-tag-1431899))))
 836           (return-from handler-case-block-1431896
 837             (muerte::internal-write object)))
 838        handler-case-clause-tag-1431899
 839         (return-from handler-case-block-1431896
 840           (let ((c handler-case-var-1431897))
 841             (print-unreadable-object (c *standard-output* :type t :identity t)
 842               (format t " while printing ~z" object))))))))
 843
 844 (defun ub (x)
 845   `(hello world ,x or . what))
 846
 847 (define-primitive-function test-irq-pf ()
 848   ""
 849   (with-inline-assembly (:returns :nothing)
 850     (:int 113)
 851     (:ret)))
 852
 853 (defun test-irq (&optional eax ebx ecx edx)
 854   (multiple-value-bind (p1 p2)
 855       (with-inline-assembly (:returns :multiple-values)
 856         (:load-lexical (:lexical-binding eax) :eax)
 857         (:load-lexical (:lexical-binding ebx) :ebx)
 858         (:load-lexical (:lexical-binding ecx) :ecx)
 859         (:load-lexical (:lexical-binding edx) :edx)
 860         (:pushl :eax)
 861         (:pushl :ebx)
 862         (:jecxz 'dont-call)
 863         (:globally (:call (:edi (:edi-offset values) 80)))
 864        dont-call
 865         (:store-lexical (:lexical-binding eax) :eax :type t)
 866         (:store-lexical (:lexical-binding ebx) :ebx :type t)
 867         (:store-lexical (:lexical-binding ecx) :ecx :type t)
 868         (:store-lexical (:lexical-binding edx) :edx :type t)
 869         (:popl :ebx)
 870         (:popl :eax)
 871         (:movl 2 :ecx)
 872         (:stc))
 873     (values eax ebx ecx edx p1 p2)))
 874
 875 (defun null-primitive-function (x)
 876   "This function is just like identity, except it also calls a null primitive function.
 877 Can be used to measure the overhead of primitive function."
 878   (with-inline-assembly (:returns :eax)
 879     (:load-lexical (:lexical-binding x) :eax)
 880     (:% :bytes 8 #xff #x97)             ; (:call-local-pf ret-trampoline)
 881     (:% :bytes 32 #.(bt:slot-offset 'movitz::movitz-run-time-context 'movitz::ret-trampoline))))
 882
 883 (defun my-test-labels (x)
 884   (labels (#+ignore (p () (print x))
 885                     (q (y) (list x y)))
 886     (declare (ignore q))
 887     (1+ x)))
 888
 889 (defparameter *timer-stack* nil)
 890 (defparameter *timer-prevstack* nil)
 891 (defparameter *timer-esi* nil)
 892 (defparameter *timer-frame* #100(nil))
 893 (defparameter *timer-base* 2)
 894 (defparameter *timer-variation* 1000)
 895
 896 (defun test-format (&optional timeout (x #xab))
 897   (let ((fasit (format nil "~2,'0X" x)))
 898     (test-timer timeout)
 899     (format t "~&Fasit: ~S" fasit)
 900     (loop
 901       (let ((x (format nil "~2,'0X" x)))
 902         (assert (string= fasit x) ()
 903           "Failed tesT. Fasit: ~S, X: ~S" fasit x)))))
 904
 905 (defun test-clc (&optional (timeout #xfffe) no-timer)
 906   (unless no-timer
 907     (test-timer timeout))
 908   (loop
 909     (funcall (find-symbol (string :test-clc) :clc))))
 910
 911 (defun test-timer (function
 912                    &key (base *timer-base*)
 913                    (variation *timer-variation*)
 914                    (timeout (+ base (random variation))))
 915   (setf (exception-handler 32)
 916         (lambda (exception-vector exception-frame)
 917           (declare (ignore exception-vector exception-frame))
 918 ;;;      (loop with f = *timer-frame*
 919 ;;;       for o from 20 downto -36 by 4 as i upfrom 0
 920 ;;;       do (setf (aref f i) (memref exception-frame o 0 :lisp)))
 921 ;;;      (let ((ts *timer-stack*))
 922 ;;;     (setf (fill-pointer ts) 0)
 923 ;;;     (loop for stack-frame = exception-frame then (stack-frame-uplink stack-frame)
 924 ;;;         while (plusp stack-frame)
 925 ;;;         do (multiple-value-bind (offset code-vector funobj)
 926 ;;;                (stack-frame-call-site stack-frame)
 927 ;;;              (vector-push funobj ts)
 928 ;;;              (vector-push offset ts)
 929 ;;;              (vector-push code-vector ts))))
 930 ;;;      (muerte::cli)
 931           (when (eql #\esc (muerte.x86-pc.keyboard:poll-char))
 932             (break "Test-timer keyboard break."))
 933           (with-inline-assembly (:returns :nothing)
 934             (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
 935             (:shrl 2 :ecx)
 936             ((:gs-override) :addb 1 (:ecx 158))
 937             ((:gs-override) :movb #x40 (:ecx 159)))
 938           (do ((frame (muerte::stack-frame-uplink nil (muerte::current-stack-frame))
 939                       (muerte::stack-frame-uplink nil frame)))
 940               ((plusp frame))
 941             (when (eq (with-inline-assembly (:returns :eax) (:movl :esi :eax))
 942                       (muerte::stack-frame-funobj nil frame))
 943               (error "Double interrupt.")))
 944 ;;;      (dolist (range muerte::%memory-map-roots%)
 945 ;;;     (map-header-vals (lambda (x type)
 946 ;;;                        (declare (ignore type))
 947 ;;;                        x)
 948 ;;;                      (car range) (cdr range)))
 949           (map-stack-vector #'muerte::identity* nil (muerte::current-stack-frame))
 950           (with-inline-assembly (:returns :nothing)
 951             (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
 952             (:shrl 2 :ecx)
 953             ((:gs-override) :movb #x20 (:ecx 159)))
 954           #+ignore (setf *timer-prevstack* *timer-stack*
 955                          *timer-stack* (muerte::copy-current-control-stack))
 956           (pic8259-end-of-interrupt 0)
 957           (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+
 958                 (pit8253-timer-count 0) (or timeout (+ base (random variation))))
 959 ;;;      (muerte::sti)
 960           ))
 961   (with-inline-assembly (:returns :nothing)
 962     (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*)
 963     (:shrl 2 :ecx)
 964     ((:gs-override) :movw #x4646 (:ecx 158)))
 965   (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+
 966         (pit8253-timer-count 0) (or timeout (+ base (random variation))))
 967   (setf (pic8259-irq-mask) #xfffe)
 968   (pic8259-end-of-interrupt 0)
 969   (with-inline-assembly (:returns :nothing) (:sti))
 970   (unwind-protect
 971        (when function
 972          (funcall function))
 973     (muerte::cli)
 974     (setf (pic8259-irq-mask) #xffff)))
 975
 976 (defun wetweg (x)
 977   (memref-int (memref x 2 :type :unsigned-byte32) :physicalp nil :type :unsigned-byte8))
 978
 979 (defun test-throwing (&optional (x #xffff))
 980   (when x
 981     (test-timer x))
 982   (loop
 983     (catch 'foo
 984       (unwind-protect
 985           (funcall (lambda ()
 986                      (unwind-protect
 987                          (progn
 988 ;;;                        (unless (logbitp 9 (eflags))
 989 ;;;                          (break "Someone switched off interrupts!"))
 990 ;;;                        (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16))
 991                            (throw 'foo 'inner-peace))
 992                        (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16)))))
 993         (incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16))))))
 994
 995 #+ignore
 996 (defun fvf-textmode-screendump ()
 997   (muerte.ip4::ip4-init)
 998   (let* ((w muerte.x86-pc::*screen-width*)
 999          (h muerte.x86-pc::*screen-height*)
1000          (data (make-array (* w h)
1001                            :element-type 'character
1002                            :fill-pointer 0)))
1003     (loop for y below h
1004         do (loop for x below w
1005                do (vector-push (code-char
1006                                 (ldb (byte 8 0)
1007                                      (memref-int muerte.x86-pc::*screen*
1008                                                  :index (+ x (* y muerte.x86-pc::*screen-stride*))
1009                                                  :type :unsigned-byte16)))
1010                                data)))
1011     (muerte.ip4:tftp/ethernet-write :129.242.19.132 "movitz-screendump.txt" data
1012                                     :quiet t
1013                                     :mac (muerte.ip4::polling-arp
1014                                           muerte.ip4::*ip4-router*
1015                                           (lambda ()
1016                                             (eql #\escape (muerte.x86-pc.keyboard:poll-char)))))))
1017
1018
1019 (defun memdump (start length)
1020   (loop for addr upfrom start repeat length
1021       collect (memref-int addr :type :unsigned-byte8)))
1022
1023 (defun plus (a b)
1024   (+ (muerte::check-the fixnum a)
1025      (muerte::check-the fixnum b)))
1026
1027 (defun vector-non-dups (vector)
1028   "Count the number of unique elements in vector."
1029   (loop for i from 1 to (length vector)
1030       for x across vector
1031       count (not (find x vector :start i))))
1032
1033 (defun blit (buffer)
1034   (loop for i from 0 below 16000
1035       do (setf (memref-int #xa0000 :index i :type :unsigned-byte32)
1036                (memref buffer 2 :index i :type :unsigned-byte32))))
1037
1038 #+ignore
1039 (defun ztstring (physical-address)
1040   (let ((s (make-string (loop for i upfrom 0
1041                             until (= 0 (memref-int physical-address :index i :type :unsigned-byte8))
1042                             finally (return i)))))
1043     (loop for i from 0 below (length s)
1044         do (setf (char s i)
1045              (code-char (memref-int physical-address :index i :type :unsigned-byte8))))
1046     s))
1047
1048 (defmacro do-default ((var &rest error-spec) &body init-forms)
1049   `(or (and (boundp ',var)
1050             (symbol-value ',var))
1051        (setf (symbol-value ',var)
1052          (progn ,@init-forms))
1053        ,(when error-spec
1054           `(error ,@error-spec))))
1055
1056 #+ignore
1057 (defun bridge (&optional (inside (do-default (*inside* "No inside NIC.")
1058                                    (muerte.x86-pc.ne2k:ne2k-probe #x300)))
1059                          (outside (do-default (*outside* "No outside NIC.")
1060                                     (muerte.x86-pc.ne2k:ne2k-probe #x280))))
1061   (let ((buffer (make-array +max-ethernet-frame-size+
1062                             :element-type '(unsigned-byte 8)
1063                             :fill-pointer t)))
1064     (loop
1065       (ignore-errors
1066        (reset-device inside)
1067        (reset-device outside)
1068        (setf (promiscuous-p inside) t
1069              (promiscuous-p outside) t)
1070        (loop
1071          (when (receive inside buffer)
1072            (transmit outside buffer))
1073          (when (receive outside buffer)
1074            (transmit inside buffer))
1075          (case (muerte.x86-pc.keyboard:poll-char)
1076            (#\escape (break "Under the bridge."))
1077            (#\e (error "this is an error!"))))))))
1078
1079
1080 (defparameter *write-barrier* nil)
1081
1082 (defun show-writes ()
1083   (loop with num = (length *write-barrier*)
1084       for i from 0 below num by 4
1085       initially (format t "~&Number of writes: ~D" (truncate num 4))
1086       do (format t "~&~D ~S: [~Z] Write to ~S: ~S."
1087                  i (aref *write-barrier* (+ i 3))
1088                  (aref *write-barrier* i)
1089                  (aref *write-barrier* i) (aref *write-barrier* (+ i 2))))
1090   (values))
1091
1092 (defun es-test (&optional (barrier-size 1000))
1093   (setf *write-barrier* (or *write-barrier*
1094                             (make-array (* 4 barrier-size) :fill-pointer 0))
1095         (fill-pointer *write-barrier*) 0
1096         (exception-handler 13) #'general-protection-handler
1097         (segment-register :es) 0)
1098   (values))
1099
1100 (defun general-protection-handler (vector dit-frame)
1101   (assert (= vector 13))
1102   (let ((eip (dit-frame-ref nil dit-frame :eip :unsigned-byte32)))
1103     (assert (= #x26 (memref-int eip :offset 0 :type :unsigned-byte8 :physicalp nil))) ; ES override prefix?
1104     (let ((opcode (memref-int eip :offset 1 :type :unsigned-byte8 :physicalp nil))
1105           (mod/rm (memref-int eip :offset 2 :type :unsigned-byte8 :physicalp nil)))
1106       (if (not (= #x89 opcode))
1107           (interrupt-default-handler vector dit-frame)
1108         (let ((value (ecase (ldb (byte 3 3) mod/rm)
1109                        (0 (dit-frame-ref nil dit-frame :eax :lisp))
1110                        (3 (dit-frame-ref nil dit-frame :ebx :lisp)))))
1111           ;; If we return, don't execute with the ES override prefix:
1112           (setf (dit-frame-ref nil dit-frame :eip :unsigned-byte32) (1+ eip))
1113           ;; If value isn't a pointer, we don't care..
1114           (when (typep value 'pointer)
1115             (multiple-value-bind (object offset)
1116                 (case (logand mod/rm #xc7)
1117                   (#x40                 ; (:movl <value> (:eax <disp8>))
1118                    (values (dit-frame-ref nil dit-frame :eax)
1119                            (memref-int eip :offset 3 :type :signed-byte8 :physicalp nil)))
1120                   (#x43                 ; (:movl <value> (:ebx <disp8>))
1121                    (values (dit-frame-ref nil dit-frame :ebx)
1122                            (memref-int eip :offset 3 :type :signed-byte8 :physicalp nil)))
1123                   (#x44                 ; the disp8/SIB case
1124                    (let ((sib (memref-int eip :offset 3 :type :unsigned-byte8 :physicalp nil)))
1125                      (case sib
1126                        ((#x19 #x0b)
1127                         (values (dit-frame-ref nil dit-frame :ebx)
1128                                 (+ (dit-frame-ref nil dit-frame :ecx :unsigned-byte8)
1129                                    (memref-int eip :offset 4 :type :signed-byte8 :physicalp nil))))
1130                        ((#x1a)
1131                         (values (dit-frame-ref nil dit-frame :ebx)
1132                                 (+ (dit-frame-ref nil dit-frame :edx :unsigned-byte8)
1133                                    (memref-int eip :offset 4 :type :signed-byte8 :physicalp nil))))))))
1134               (when (not object)
1135                 (setf (segment-register :es) (segment-register :ds))
1136                 (break "[~S] With value ~S, unknown movl at ~S: ~S ~S ~S ~S"
1137                        dit-frame value eip
1138                        (memref-int eip :offset 1 :type :unsigned-byte8 :physicalp nil)
1139                        (memref-int eip :offset 2 :type :unsigned-byte8 :physicalp nil)
1140                        (memref-int eip :offset 3 :type :unsigned-byte8 :physicalp nil)
1141                        (memref-int eip :offset 4 :type :unsigned-byte8 :physicalp nil)))
1142               (check-type object pointer)
1143               (check-type offset fixnum)
1144               (let ((write-barrier *write-barrier*)
1145                     (location (object-location object)))
1146                 (assert (not (location-in-object-p
1147                               (los0::space-other (%run-time-context-slot nil 'nursery-space))
1148                               location)) ()
1149                   "Write ~S to old-space at ~S." value location)
1150                 (unless (or (eq object write-barrier)
1151                             #+ignore
1152                             (location-in-object-p (%run-time-context-slot nil 'nursery-space)
1153                                                   location)
1154                             (location-in-object-p (%run-time-context-slot nil 'stack-vector)
1155                                                   location))
1156                   (if (location-in-object-p (%run-time-context-slot nil 'nursery-space)
1157                                             location)
1158                       (vector-push 'stack-actually write-barrier)
1159                     (vector-push object write-barrier))
1160                   (vector-push offset write-barrier)
1161                   (vector-push value write-barrier)
1162                   (unless (vector-push eip write-barrier)
1163                     (setf (segment-register :es) (segment-register :ds))
1164                     (break "Write-barrier is full: ~D" (length write-barrier))))))))))))