;;;; cons-unique (aka hashcons) ;;; Apparently invented by Ershov ;;; (see CACM 1, 8, August 1958, pp. 3--6) ;;; Re-introduced by E.Goto in 1974. (declare (usual-integrations)) ;;; Given two arguments cons-unique ;;; returns a pair. If exactly the same ;;; two arguments were previously ;;; combined with cons-unique it returns ;;; the same pair it returned the first ;;; time. (define cons-unique ;; I don't want to cons if unnecessary. (let ((the-pair (cons #f #f))) (define (hashcons x y) (set-car! the-pair x) (set-cdr! the-pair y) (let ((canonical-pair (hash-table/get the-cons-table the-pair #f))) (if canonical-pair (begin (set-car! the-pair #f) (set-cdr! the-pair #f) canonical-pair) (let ((new the-pair)) (hash-table/put! the-cons-table new new) (set! the-pair (cons #f #f)) new)))) hashcons)) ;;; Given a list structure, to get a ;;; canonical copy equal to the given ;;; list structure. Must canonicalize ;;; and share all substructure. (define (canonical-copy x) (if (pair? x) (let ((canonical-pair (hash-table/get the-cons-table x #f))) ;; Perhaps already canonical (or canonical-pair (cons-unique (canonical-copy (car x)) (canonical-copy (cdr x))))) x)) (define (list-unique . lst) (canonical-copy lst)) (define (append-unique l1 l2) (if (null? l1) l2 (cons-unique (car l1) (append-unique (cdr l1) l2)))) (define (map-unique p lst) (if (pair? lst) (cons-unique (p (car lst)) (map-unique p (cdr lst))) lst)) ;;; Support for the hashcons system. (define (pair-eq? u v) (and (eq? (car u) (car v)) (eq? (cdr u) (cdr v)))) (define the-cons-table ((weak-hash-table/constructor equal-hash-mod pair-eq? #t))) #| ;;; For example... (define foo '(define (canonical-copy x) (if (pair? x) (let ((canonical-pair (hash-table/get the-cons-table x #f))) (or canonical-pair (let ((new (cons (canonical-copy (car x)) (canonical-copy (cdr x))))) (hash-table/put! the-cons-table new new) new))) x))) (define bar '(define cons-unique ;; I don't want to cons if unnecessary. (let ((the-pair (cons #f #f))) (define (hashcons x y) (set-car! the-pair x) (set-cdr! the-pair y) (let ((canonical-pair (hash-table/get the-cons-table the-pair #f))) (or canonical-pair (let ((new the-pair)) (hash-table/put! the-cons-table new new) (set! the-pair (cons #f #f)) new)))) hashcons))) (define cfoo (canonical-copy foo)) ;Value: cfoo (eq? cfoo (canonical-copy foo)) ;Value: #t (define cbar (canonical-copy bar)) ;Value: cbar (define baz (caddr (caddr (caddr (caddr (caddr cfoo)))))) ;Value: baz baz ;Value: (hash-table/put! the-cons-table new new) (define mum (caddr (caddr (caddr (car (cddddr (caddr (caddr cbar)))))))) ;Value: mum ;Value: mum ;Value: (hash-table/put! the-cons-table new new) (eq? baz mum) ;Value: #t |#