boot2

122-deep-copy.scm (5107B)

---

 ; Generic deep-copy: structural clone of pairs / bytevectors / records,
 ; with identity preservation across shared substructure and cycle
 ; tolerance via an eager stand-in registered before slot fill. Used by
 ; cc.scm to promote scratch-allocated parse output into main; mirror
 ; here in scheme1 itself to lock down the contract. See
 ; docs/DEEP-COPY.md.
 ;
 ; By design, deep-copy short-circuits when an object is already in the
 ; current heap (so re-promotion is O(1)). The structural tests below
 ; therefore allocate sources in scratch and copy with main current.
 
 (define-record-type cell
   (mk-cell head tail)
   cell?
   (head cell-head cell-head-set!)
   (tail cell-tail cell-tail-set!))
 
 ;; ---- Already-in-target short-circuit returns the same object ----
 (define m-pair (cons 1 2))
 (define ctx0 (make-deep-copy-context))
 (if (eq? m-pair (deep-copy ctx0 m-pair)) 0 (sys-exit 1))
 
 ;; ---- Symbols pass through untouched (interned) ----
 (if (eq? 'foo (deep-copy ctx0 'foo))     0 (sys-exit 2))
 
 ;; ---- Fixnums / immediates pass through ----
 (if (= 42 (deep-copy ctx0 42))           0 (sys-exit 3))
 (if (eq? #t (deep-copy ctx0 #t))         0 (sys-exit 4))
 (if (eq? '() (deep-copy ctx0 '()))       0 (sys-exit 5))
 
 ;; ---- Pair deep-copy from scratch -> main ----
 (use-scratch-heap!)
 (define s-list (cons 1 (cons 2 (cons 3 '()))))
 (use-main-heap!)
 (define ctx1 (make-deep-copy-context))
 (define m-list (deep-copy ctx1 s-list))
 (if (equal? s-list m-list)               0 (sys-exit 10))
 (if (not (eq? s-list m-list))            0 (sys-exit 11))
 (if (heap-in-main? m-list)               0 (sys-exit 12))
 (if (heap-in-main? (cdr m-list))         0 (sys-exit 13))
 (reset-scratch-heap!)
 ;; m-list survives scratch reset
 (if (equal? m-list (cons 1 (cons 2 (cons 3 '())))) 0 (sys-exit 14))
 
 ;; ---- Bytevector deep-copy from scratch -> main ----
 (use-scratch-heap!)
 (define s-bv (bytevector 1 2 3 4 5))
 (use-main-heap!)
 (define ctx2 (make-deep-copy-context))
 (define m-bv (deep-copy ctx2 s-bv))
 (if (bytevector=? s-bv m-bv)             0 (sys-exit 20))
 (if (not (eq? s-bv m-bv))                0 (sys-exit 21))
 (if (heap-in-main? m-bv)                 0 (sys-exit 22))
 (reset-scratch-heap!)
 ;; main-heap copy survives scratch reset
 (if (= 5 (bytevector-length m-bv))       0 (sys-exit 23))
 (if (= 1 (bytevector-u8-ref m-bv 0))     0 (sys-exit 24))
 (if (= 5 (bytevector-u8-ref m-bv 4))     0 (sys-exit 25))
 
 ;; ---- Record deep-copy from scratch -> main ----
 (use-scratch-heap!)
 (define s-cell (mk-cell 10 20))
 (use-main-heap!)
 (define ctx3 (make-deep-copy-context))
 (define m-cell (deep-copy ctx3 s-cell))
 (if (cell? m-cell)                       0 (sys-exit 30))
 (if (not (eq? s-cell m-cell))            0 (sys-exit 31))
 (if (= 10 (cell-head m-cell))            0 (sys-exit 32))
 (if (= 20 (cell-tail m-cell))            0 (sys-exit 33))
 ;; Same TD: TDs are persistent and not copied
 (if (eq? (record-td s-cell) (record-td m-cell)) 0 (sys-exit 34))
 (if (heap-in-main? m-cell)               0 (sys-exit 35))
 (reset-scratch-heap!)
 (if (= 10 (cell-head m-cell))            0 (sys-exit 36))
 
 ;; ---- Identity preservation across shared subobjects ----
 (use-scratch-heap!)
 (define s-shared (cons 'a 'b))
 (define s-x (cons s-shared s-shared))
 (use-main-heap!)
 (define ctx4 (make-deep-copy-context))
 (define m-x (deep-copy ctx4 s-x))
 ;; Both halves of the result reference one fresh shared cons in main.
 (if (eq? (car m-x) (cdr m-x))            0 (sys-exit 40))
 (if (not (eq? (car m-x) s-shared))       0 (sys-exit 41))
 (if (eq? 'a (car (car m-x)))             0 (sys-exit 42))
 (if (eq? 'b (cdr (car m-x)))             0 (sys-exit 43))
 (reset-scratch-heap!)
 
 ;; ---- Cycle handling (record points to itself) ----
 (use-scratch-heap!)
 (define s-cyc (mk-cell 1 #f))
 (cell-tail-set! s-cyc s-cyc)
 (use-main-heap!)
 (define ctx5 (make-deep-copy-context))
 (define m-cyc (deep-copy ctx5 s-cyc))
 (if (not (eq? s-cyc m-cyc))              0 (sys-exit 50))
 (if (= 1 (cell-head m-cyc))              0 (sys-exit 51))
 (if (eq? m-cyc (cell-tail m-cyc))        0 (sys-exit 52))
 (reset-scratch-heap!)
 ;; m-cyc still its own tail after scratch reset
 (if (eq? m-cyc (cell-tail m-cyc))        0 (sys-exit 53))
 
 ;; ---- Mixed pair-of-record graph ----
 (use-scratch-heap!)
 (define s-rec (mk-cell 9 (cons 1 (cons 2 '()))))
 (use-main-heap!)
 (define ctx6 (make-deep-copy-context))
 (define m-rec (deep-copy ctx6 s-rec))
 (if (not (eq? s-rec m-rec))              0 (sys-exit 60))
 (if (= 9 (cell-head m-rec))              0 (sys-exit 61))
 (if (equal? (cell-tail m-rec) '(1 2))    0 (sys-exit 62))
 (if (heap-in-main? m-rec)                0 (sys-exit 63))
 (if (heap-in-main? (cell-tail m-rec))    0 (sys-exit 64))
 (reset-scratch-heap!)
 (if (equal? (cell-tail m-rec) '(1 2))    0 (sys-exit 65))
 
 ;; ---- ctx reuse: second pass over the same already-copied root is O(1)
 ;; via heap-in-current?, returning the main-heap object directly.
 (define ctx7 (make-deep-copy-context))
 (define copy-once (deep-copy ctx7 (cons 'a (cons 'b '()))))
 (define copy-again (deep-copy ctx7 copy-once))
 (if (eq? copy-once copy-again)           0 (sys-exit 70))
 
 (sys-exit 42)