Changeset 14398 in project for chicken


Ignore:
Timestamp:
04/23/09 10:22:41 (11 years ago)
Author:
felix winkelmann
Message:

strip-syntax handles circular structures (contributed by Alex Shinn)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/expand.scm

    r14340 r14398  
    9191
    9292(define (##sys#strip-syntax exp #!optional se alias)
    93   ;; if se is given, retain bound vars
    94   (let walk ((x exp))
    95     (cond ((symbol? x)
    96            (let ((x2 (if se
    97                          (lookup x se)
    98                          (get x '##core#macro-alias) ) ) )
    99              (cond ((get x '##core#real-name))
    100                    ((and alias (not (assq x se)))
    101                     (##sys#alias-global-hook x #f))
    102                    ((not x2) x)
    103                    ((pair? x2) x)
    104                    (else x2))))
    105           ((pair? x)
    106            (cons (walk (car x))
    107                  (walk (cdr x))))
    108           ((vector? x)
    109            (list->vector (map walk (vector->list x))))
    110           (else x))))
     93 ;; if se is given, retain bound vars
     94 (let ((seen '()))
     95   (let walk ((x exp))
     96     (cond ((assq x seen) => cdr)
     97           ((symbol? x)
     98            (let ((x2 (if se
     99                          (lookup x se)
     100                          (get x '##core#macro-alias) ) ) )
     101              (cond ((get x '##core#real-name))
     102                    ((and alias (not (assq x se)))
     103                     (##sys#alias-global-hook x #f))
     104                    ((not x2) x)
     105                    ((pair? x2) x)
     106                    (else x2))))
     107           ((pair? x)
     108            (let ((cell (cons #f #f)))
     109              (set! seen (cons (cons x cell) seen))
     110              (set-car! cell (walk (car x)))
     111              (set-cdr! cell (walk (cdr x)))
     112              cell))
     113           ((vector? x)
     114            (let* ((len (##sys#size x))
     115                   (vec (make-vector len)))
     116              (set! seen (cons (cons x vec) seen))
     117              (do ((i 0 (fx+ i 1)))
     118                  ((fx>= i len) vec)
     119                (##sys#setslot vec i (##sys#slot x i)))))
     120           (else x)))))
    111121
    112122(define strip-syntax ##sys#strip-syntax)
Note: See TracChangeset for help on using the changeset viewer.