b4f010c6d5
- fix check for lazy-wrap property - supply hash procedures for records defined with `define-record-type' (needed by the stepper)
92 lines
2.7 KiB
Scheme
92 lines
2.7 KiB
Scheme
; I HATE DEFINE-STRUCT!
|
|
(define-struct/properties :empty-list ()
|
|
((prop:custom-write
|
|
(lambda (r port write?)
|
|
(write-string "#<empty-list>" port))))
|
|
(make-inspector))
|
|
|
|
;; essentially copied from define-record-procedures.scm
|
|
(define (write-list l port write?)
|
|
(let ((pp? (and (pretty-printing)
|
|
(number? (pretty-print-columns)))))
|
|
|
|
(write-string "#<" port)
|
|
(write-string "list" port)
|
|
|
|
(let-values (((ref-line ref-column ref-pos)
|
|
(if pp?
|
|
(port-next-location port)
|
|
(values 0 -1 0)))) ; to compensate for space
|
|
(let ((do-element
|
|
(if pp?
|
|
(lambda (element)
|
|
(let* ((max-column (- (pretty-print-columns) 1)) ; > terminator
|
|
(tentative
|
|
(make-tentative-pretty-print-output-port
|
|
port
|
|
max-column
|
|
void)))
|
|
(display " " tentative)
|
|
((if write? write display) element tentative)
|
|
(let-values (((line column pos) (port-next-location tentative)))
|
|
(if (< column max-column)
|
|
(tentative-pretty-print-port-transfer tentative port)
|
|
(begin
|
|
(tentative-pretty-print-port-cancel tentative)
|
|
(let ((count (pretty-print-newline port max-column)))
|
|
(write-string (make-string (max 0 (- (+ ref-column 1) count)) #\space)
|
|
port)
|
|
((if write? write display) element port)))))))
|
|
(lambda (element)
|
|
(display " " port)
|
|
((if write? write display) element port)))))
|
|
(let loop ((elements (:list-elements l)))
|
|
(cond
|
|
((pair? elements)
|
|
(do-element (car elements))
|
|
(loop (cdr elements)))
|
|
((not (null? elements))
|
|
(write-string " ." port)
|
|
(do-element elements))))))
|
|
|
|
(write-string ">" port)))
|
|
|
|
;; might be improper
|
|
(define-struct/properties :list (elements)
|
|
((prop:custom-write write-list))
|
|
(make-inspector))
|
|
|
|
(define (convert-explicit v)
|
|
(let ((hash (make-hasheq)))
|
|
(let recur ((v v))
|
|
(cond
|
|
((null? v) (make-:empty-list)) ; prevent silly printing of sharing
|
|
((pair? v)
|
|
(make-:list
|
|
(let list-recur ((v v))
|
|
(cond
|
|
((null? v)
|
|
v)
|
|
((not (pair? v))
|
|
(recur v))
|
|
(else
|
|
(cons (recur (car v))
|
|
(list-recur (cdr v))))))))
|
|
((struct? v)
|
|
(or (hash-ref hash v #f)
|
|
(let-values (((ty skipped?) (struct-info v)))
|
|
(cond
|
|
((and ty (lazy-wrap? ty))
|
|
(let ((lazy-wrap-info (lazy-wrap-ref ty)))
|
|
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
|
|
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)))
|
|
(let ((val (apply constructor (map (lambda (raw-accessor)
|
|
(recur (raw-accessor v)))
|
|
raw-accessors))))
|
|
(hash-set! hash v val)
|
|
val))))
|
|
(else v)))))
|
|
(else
|
|
v)))))
|
|
|