boot2

Playing with the boostrap
git clone https://git.ryansepassi.com/git/boot2.git
Log | Files | Refs | README

121-record-introspection.scm (3024B)

      1 ; Record introspection primitives: record?, record-td, record-ref,
      2 ; record-set!, make-record/td, td-nfields, td-name, heap-in-current?.
      3 ; Backs the generic deep-copy walker (see docs/DEEP-COPY.md).
      4 
      5 (define-record-type point
      6   (mk-point x y)
      7   point?
      8   (x point-x)
      9   (y point-y point-y-set!))
     10 
     11 (define-record-type box
     12   (mk-box val)
     13   box?
     14   (val box-val box-val-set!))
     15 
     16 (define p (mk-point 3 4))
     17 (define b (mk-box 7))
     18 
     19 ;; ---- record? ----
     20 (if (record? p)            0 (sys-exit 1))
     21 (if (record? b)            0 (sys-exit 2))
     22 (if (not (record? 5))      0 (sys-exit 3))
     23 (if (not (record? "bv"))   0 (sys-exit 4))
     24 (if (not (record? '()))    0 (sys-exit 5))
     25 (if (not (record? '(a)))   0 (sys-exit 6))
     26 (if (not (record? 'sym))   0 (sys-exit 7))
     27 (if (not (record? #f))     0 (sys-exit 8))
     28 
     29 ;; ---- record-td: identity for instances of the same type ----
     30 (define td-p (record-td p))
     31 (define p2 (mk-point 9 10))
     32 (if (eq? td-p (record-td p2))  0 (sys-exit 10))
     33 ;; Different types yield different TDs
     34 (if (not (eq? td-p (record-td b))) 0 (sys-exit 11))
     35 
     36 ;; ---- td-nfields ----
     37 (if (= 2 (td-nfields td-p))    0 (sys-exit 20))
     38 (if (= 1 (td-nfields (record-td b))) 0 (sys-exit 21))
     39 
     40 ;; ---- td-name ----
     41 (if (eq? 'point (td-name td-p))    0 (sys-exit 30))
     42 (if (eq? 'box (td-name (record-td b))) 0 (sys-exit 31))
     43 
     44 ;; ---- record-ref reads slots by index ----
     45 (if (= 3 (record-ref p 0))         0 (sys-exit 40))
     46 (if (= 4 (record-ref p 1))         0 (sys-exit 41))
     47 (if (= 7 (record-ref b 0))         0 (sys-exit 42))
     48 
     49 ;; ---- record-set! writes slots by index ----
     50 (record-set! p 1 42)
     51 (if (= 42 (point-y p))             0 (sys-exit 50))
     52 (if (= 42 (record-ref p 1))        0 (sys-exit 51))
     53 (record-set! b 0 'tagged)
     54 (if (eq? 'tagged (box-val b))      0 (sys-exit 52))
     55 
     56 ;; ---- make-record/td: zero-filled to UNSPEC, then fillable ----
     57 (define p3 (make-record/td td-p))
     58 (if (record? p3)                   0 (sys-exit 60))
     59 (if (eq? td-p (record-td p3))      0 (sys-exit 61))
     60 (if (point? p3)                    0 (sys-exit 62))
     61 (record-set! p3 0 100)
     62 (record-set! p3 1 200)
     63 (if (= 100 (point-x p3))           0 (sys-exit 63))
     64 (if (= 200 (point-y p3))           0 (sys-exit 64))
     65 
     66 ;; ---- heap-in-current? generalizes heap-in-main? ----
     67 ;; Default heap is main.
     68 (if (heap-in-current? p)           0 (sys-exit 70))
     69 (if (heap-in-current? "bv-in-main") 0 (sys-exit 71))
     70 ;; Tagged non-pointers are #f.
     71 (if (not (heap-in-current? 5))     0 (sys-exit 72))
     72 (if (not (heap-in-current? 'sym))  0 (sys-exit 73))
     73 (if (not (heap-in-current? #f))    0 (sys-exit 74))
     74 (if (not (heap-in-current? '()))   0 (sys-exit 75))
     75 
     76 ;; Allocate a record in scratch, then in main; each is in-current within
     77 ;; its arena and not in-current after switching.
     78 (use-scratch-heap!)
     79 (define s-rec (mk-point 1 2))
     80 (if (heap-in-current? s-rec)       0 (sys-exit 80))
     81 (if (not (heap-in-main? s-rec))    0 (sys-exit 81))
     82 (use-main-heap!)
     83 (if (not (heap-in-current? s-rec)) 0 (sys-exit 82))
     84 (if (heap-in-current? p)           0 (sys-exit 83))
     85 (reset-scratch-heap!)
     86 
     87 (sys-exit 42)