home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / wabbit / test-wabbit.scm < prev    next >
Text File  |  1995-07-14  |  12KB  |  336 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. (DECLARE (USUAL-INTEGRATIONS))    ; MIT Scheme-ism: promise not to redefine prims
  4.  
  5. ;;; $Id: test-wabbit.scm,v 1.1 1995/07/14 04:04:42 ziggy Exp $
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;                                         ;;
  9. ;;  TEST-WABBIT -- Harey test of wabbit hunting / headhunting g.c.         ;;
  10. ;;                                         ;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. #|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|
  14.  |                                          |
  15.  | Uses:                                      |
  16.  |    tons o' stuff not yet documented as dependencies              |
  17.  |                                          |
  18.  |#;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|
  19.  
  20. ;; TODO:
  21. ;;
  22. ;;    - Document dependencies
  23. ;;    - [SCREWS] see last page
  24.  
  25. ;;; $Id: test-wabbit.scm,v 1.1 1995/07/14 04:04:42 ziggy Exp $
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;                                         ;;
  29. ;;  TEST-WABBIT -- Harey test of wabbit hunting / headhunting g.c.         ;;
  30. ;;                                         ;;
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32.  
  33. (define *muobj-wabbit-vector* '--TBA--)
  34.  
  35. (define (muobj-wabbit-vector/install!)
  36.  
  37.   (define muobj-pair           (cons            make-unique-object
  38.                                (make-unique-object)))
  39.   (define muobj-vector         (vector         'make 'nique 'bject
  40.                                 make-unique-object))
  41. #|
  42.   (define muobj-promise        (delay           make-unique-object))
  43. |#
  44.  
  45.   (define-structure (muos (conc-name muos/)
  46.               (constructor make-muos ()))
  47.     (  uobj-slot (make-unique-object))
  48.     ( cuobj-slot (make-unique-object) read-only #T)
  49.     ( muobj-slot  make-unique-object)
  50.     (cmuobj-slot  make-unique-object  read-only #T))
  51.  
  52.   (define muobj-struct1 (make-muos))
  53.   (define muobj-struct2 (make-muos))
  54.  
  55.   (define muobj-cell           (make-cell       make-unique-object))
  56.   (define muobj-weak-pair      (weak-cons      (make-unique-object)
  57.                             make-unique-object ))
  58.  
  59.   (define muobj-weak-car       (weak-car muobj-weak-pair)) ; made UObj
  60.   (define muobj-weak-cdr       (weak-cdr muobj-weak-pair)) ; make-UObj
  61.  
  62.   (define muobj-apply-hook     (make-apply-hook muobj-weak-car
  63.                         make-unique-object))
  64.   (define muobj-entity         (make-entity     muobj-weak-car
  65.                         make-unique-object))
  66.   (define muobj-forced-promise (let ((p  (delay make-unique-object)))
  67.                  (force p)
  68.                  p))
  69.  
  70.   (define muobj-wabbit-vector
  71.     `#(
  72.        ,muobj-weak-car            ; Made UObj
  73.        ,muobj-weak-cdr            ; Make-UObj
  74.  
  75.        ,muobj-pair
  76.        ,muobj-vector
  77. #|
  78.        ,muobj-promise
  79. |#
  80.        ;;
  81.        ;; (define-structure (muos (conc-name muos/)
  82.        ;;                        (constructor make-muos ()))
  83.        ;;  (muobj-slot  (make-unique-object))
  84.        ;;  (cmuobj-slot (make-unique-object) read-only true)
  85.        ;;  (muos-slot   make-unique-object)
  86.        ;;  (cmuso-slot  make-unique-object  read-only true))
  87.        ;;
  88.        ,muobj-struct1
  89.        ,muobj-struct2
  90.  
  91.        ,muobj-cell
  92.        ,muobj-weak-pair
  93.        ,muobj-forced-promise
  94.        ,muobj-apply-hook
  95.        ,muobj-entity
  96.        ))
  97.  
  98.   (set! *muobj-wabbit-vector* muobj-wabbit-vector)
  99.  
  100.   (pp (cons 42 make-unique-object))    ; Random un-named pair for pp hashing
  101.  
  102.   'DONE)
  103.  
  104. (define (forced-promise? x) (and (promise? x) (promise-forced? x)))
  105.  
  106. (define (muobj-wabbit-hunt)
  107.   (wabbit-hunt
  108.    (make-wabbit-descwiptor false             ; hunt    disable flag disabled
  109.                *muobj-wabbit-vector* ; targets of the hunt
  110.                (make-vector 100 #f)   ; wabbit buffer
  111.                false             ; headhunt enable flag disabled
  112.                )
  113.    (named-lambda (exposing-fudd-thunk)
  114.      (let* ((wabbuf (wabbit-descwiptor/wabbit-buffer (get-wabbit-descwiptor)))
  115.         (got-em-all?       (vector-ref wabbuf 0))
  116.         (last-hole-index (vector-ref wabbuf 1)))
  117.        (display "\n; #(")
  118.        (do ((index 2 (1+ index)))
  119.        ((>= index last-hole-index)
  120.         (if got-em-all?
  121.         (display ")\n; Th-th-th-that's all folks!")
  122.         (display ")\n; And many more.... maybe?!?"))
  123.         (newline))
  124.  
  125.      (let ((next-elt (vector-ref wabbuf index)))
  126.        (if (odd? index)
  127.            (write next-elt)        ; write index of non-skipped elt
  128.            (let ()
  129.          (define (space-write-and-skip! object)
  130.            (space-out!) (write object) (skip!))
  131.          (define (space-in-write!       object)
  132.            (space-in!)  (write object)        )
  133.          (define (space-out!)
  134.            (write-char #\Space) (write-char #\=) (write-char #\Space))
  135.          (define (space-in!)
  136.            (write-char #\Space) (write-char #\-) (write-char #\Space))
  137.          (define (skip!)     (set! index (1+ index)))
  138.          (define (offset) (vector-ref wabbuf (1+ index)))
  139.       
  140.          (write-char #\[) (write index) (write-char #\])
  141.          (write-char #\Space)
  142.          (write (microcode-type-name next-elt))
  143.  
  144.          (cond ((pair? next-elt)
  145.             (space-write-and-skip! (if (zero? (offset))
  146.                            (car next-elt)
  147.                            (cdr next-elt))))
  148.                ((vector? next-elt)
  149.             (space-write-and-skip! (vector-ref next-elt 
  150.                                (-1+ (offset)))))
  151.                ((record? next-elt)
  152.             (space-write-and-skip! (%record-ref next-elt
  153.                                 (-1+ (offset)))))
  154.                ;;
  155.                ;; MIT Scheme specific extensions...
  156.                ;;
  157.                ((cell? next-elt)
  158.             (space-write-and-skip! (cell-contents next-elt)))
  159.                ((weak-pair? next-elt)
  160.             (space-write-and-skip! (if (zero? (offset))
  161.                            (weak-car next-elt)
  162.                            (weak-cdr next-elt))))
  163.                ((forced-promise? next-elt)
  164.             (space-write-and-skip! (force next-elt)))
  165.                ((promise? next-elt) ; Must follow forced-promise
  166.             (space-write-and-skip!        next-elt ))
  167.                ((%entity-extra/apply-hook? next-elt)
  168.             (space-write-and-skip! (case (offset)
  169.                          ((0) (system-hunk3-cxr0 next-elt))
  170.                          ((1) (system-hunk3-cxr1 next-elt))
  171.                          ((2) (system-hunk3-cxr2 next-elt)))))
  172.                ((apply-hook?  next-elt)    ; SIGH: hunk3/triple hack uproc
  173.             (space-write-and-skip! (if (zero? (offset))
  174.                            (apply-hook-procedure next-elt)
  175.                            (apply-hook-extra     next-elt))))
  176.                ((entity?      next-elt)
  177.             (space-write-and-skip! (if (zero? (offset))
  178.                            (entity-procedure next-elt)
  179.                            (entity-extra     next-elt))))
  180.                ((environment? next-elt)
  181.             (space-write-and-skip! (system-vector-ref next-elt
  182.                                   (-1+ (offset)))))
  183.                ((and (compiled-code-block?                  next-elt)
  184.                  (compiled-code-block/manifest-closure? next-elt))
  185.             (space-write-and-skip! (system-vector-ref next-elt
  186.                                   (-1+ (offset)))))
  187.                ;;
  188.                ;; Normal compiled code blocks are unsafe since may ref
  189.                ;;     into the R/W/X cache of the linkage section.
  190.                (else        
  191.             (space-in-write! next-elt))))))
  192.      ;(display "\n; #(")    ; From above
  193.      (display  "\n;   ")))))
  194.   )
  195.  
  196. (define (test-wabbit-go-for-it)
  197.   (muobj-wabbit-vector/install!)  
  198.   (muobj-wabbit-hunt)
  199.   )
  200.  
  201. #| Until somebody builds the newest Scheme band...
  202.  
  203. (define   %entity-extra/apply-hook?
  204.   (access %entity-extra/apply-hook? (->environment '(runtime procedure))))
  205. |#
  206.  
  207. (let-syntax ((ucode-type (macro (name) (microcode-type name))))
  208.  
  209.   (define   apply-hook-tag 
  210.     (access apply-hook-tag (->environment '(runtime procedure))))
  211.  
  212.   (define (%entity-extra/apply-hook? extra)
  213.     ;; Ziggy cares about this one.
  214.     (and (object-type? (ucode-type hunk3) extra)
  215.      (eq? apply-hook-tag (system-hunk3-cxr0 extra))))
  216.   )
  217.  
  218.  
  219.  
  220. ;;; fini
  221.  
  222. (provide "Test Wabbit")
  223.  
  224. ;;; Complete dependencies  (desire = run-time require (not load-time require))
  225.  
  226. (begin
  227.  
  228.   (with-working-directory-pathname "Utils/"
  229.     (named-lambda (acknowledge-Utils-desiderata)
  230.       (desire "Unique Objects" "unique-objects")
  231.       ))
  232.  
  233.   (load-option 'wabbit   )
  234.   (load-option 'pc-sample)
  235.  
  236.   (with-working-directory-pathname "../ObjectType/"
  237.     (named-lambda (acknowledge-ObjType-desiderata)
  238.       (desire "Object Structural Types" "objtype")
  239.       ))
  240.   )
  241.  
  242. #| Example run...
  243.  
  244. ;; First time...
  245. (test-wabbit-go-for-it)
  246.  
  247. ;; Thereafter...
  248. (muobj-wabbit-hunt)
  249.  
  250. (42 . #[compiled-closure 31 ("unique-objects") #xD0 #x7B6D24 #x79276C])
  251.  
  252. |#
  253.  
  254. ; #([2] pair = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  255. ;   [4] vector = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  256. ;   [6] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  257. ;   [8] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  258. ;   [10] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  259. ;   [12] record = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  260. ;   [14] cell = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  261. ;   [16] weak-cons = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  262. ;   [18] promise = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  263. ;   [20] entity = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
  264. ;   [22] entity = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  265. ;   [24] compiled-code-block = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
  266. ;   [26] triple = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
  267. ;   [28] triple = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  268. ;   [30] compiled-code-block - #[compiled-code-block 33]
  269. ;   602
  270. ;   [32] quad - #[quad 34]
  271. ;   0
  272. ;   [34] weak-cons = #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  273. ;   [36] weak-cons = #[compiled-closure 32 ("unique-objects") #x1A8 #x145801C #x1457C44]
  274. ;   )
  275. ; Th-th-th-that's all folks!
  276. ;No value
  277.  
  278.  
  279. (begin
  280.   (load "/scheme/700/compiler/etc/disload")
  281.   (load-disassembler))
  282.  
  283. #|
  284. (compiler:disassemble #@33)
  285.  
  286. Disassembly of #[compiled-code-block 33] (Block 2 in /sw/ziggy/Projects/Descartes/Wabbit/test-wabbit.inf):
  287. Code:
  288.  
  289. 14DFD24    8    (ble () (offset 0 4 3))
  290. 14DFD28    C    (ldi () #x1A #x1C)
  291. 14DFD2C    10    (external-label () #x101 (@pco #x14))
  292. 14DFD30    14    (combf (<) #x15 #x14 (@pco #x-14))
  293. .
  294. .
  295. .
  296.  
  297. Constants:
  298.  
  299. 14E0608    8EC    #[LINKAGE-SECTION #x21]
  300. 14E060C    8F0    2 argument procedure cache to #[compiled-entry 35 () #xC #x1501DF0]
  301. 14E0618    8FC    2 argument procedure cache to #[compiled-entry 36 () #xC #x1501E10]
  302. 14E0624    908    3 argument procedure cache to #[compiled-procedure 37 ("uproc" #x1D) #x14 #x392160]
  303. 14E0630    914    3 argument procedure cache to #[compiled-procedure 38 ("uproc" #x24) #x14 #x3923D0]
  304. 14E063C    920    2 argument procedure cache to #[compiled-procedure 39 ("list" #x14) #x14 #x394808]
  305. 14E0648    92C    3 argument procedure cache to #[compiled-procedure 40 ("list" #xF) #x14 #x3945B0]
  306. 14E0654    938    2 argument procedure cache to #[compiled-procedure 41 ("list" #x12) #x14 #x3946E8]
  307. 14E0660    944    2 argument procedure cache to #[compiled-entry 42 () #xC #x1501E28]
  308. 14E066C    950    3 argument procedure cache to #[compiled-entry 43 () #xC #x1501E40]
  309. 14E0678    95C    5 argument procedure cache to #[compiled-entry 44 () #xC #x1501E58]
  310. 14E0684    968    1 argument procedure cache to #[compiled-closure 31 ("unique-objects") #xD0 #x1457F44 #x1457C5C]
  311. 14E0690    974    #[LINKAGE-SECTION #x10001]
  312. 14E0694    978    Reference cache to make-unique-object
  313. 14E0698    97C    #[LINKAGE-SECTION #x20001]
  314. 14E069C    980    Assignment cache to *muobj-wabbit-vector*
  315. 14E06A0    984    #[LINKAGE-SECTION #x30003]
  316. 14E06A4    988    3 argument procedure cache to #[compiled-entry 45 () #xC #x1501E78]
  317. 14E06B0    994    done
  318. 14E06B4    998    "muos"
  319. 14E06B8    99C    (uobj-slot cuobj-slot muobj-slot cmuobj-slot)
  320. 14E06BC    9A0    make
  321. 14E06C0    9A4    nique
  322. 14E06C4    9A8    bject
  323. 14E06C8    9AC    (#[dbg-info 46] "/sw/ziggy/Projects/Descartes/Wabbit/wabbit-
  324. 14E06CC    9B0    #[environment 47]
  325.  
  326. ;No value
  327. |#
  328.  
  329. ;;
  330. ;; [SCREWS]: Environments (system-vector-ref (-1+ index))
  331. ;;         Compiled code blocks -- appear in linkage section. Indir thru env.
  332. ;;         Quads - what a ref trap points to in a linkage section.
  333. ;;           ...don't sweat it... will lexical-assign w/in env.
  334. ;;         Quotations [scode.scm --- %singleton-set-car!]
  335. ;;
  336.