Changeset 13723 in project


Ignore:
Timestamp:
03/12/09 23:02:19 (11 years ago)
Author:
Kon Lovett
Message:

Fixes for ##sys#syntactic-environment routines.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/expand.scm

    r13713 r13723  
    128128; Workalike of '##sys#environment?' for syntactic environments
    129129(define (##sys#syntactic-environment? obj)
    130   (and (list? obj)
    131        (or (null? obj)
    132            (call-with-current-continuation
    133              (lambda (return)
    134                (##sys#for-each
    135                 (lambda (x)
    136                   (unless (and (pair? x) (= 3 (length x))
    137                                ;key
    138                                (symbol? (car x))
    139                                #;(##sys#syntactic-environment? (cadr x))
    140                                (procedure? (caddr x)) )
    141                     (return #f) ) )
    142                 obj)
     130
     131  (define (simple-environment? obj)
     132    (and (list? obj)
     133         (or (null? obj)
     134             (simple-environment-entry? (car obj))
     135             #; ;enough already
     136             (call-with-current-continuation
     137               (lambda (return)
     138                 (##sys#for-each
     139                  (lambda (x) (unless (simple-environment-entry? x) (return #f) ) )
     140                  obj)
    143141               #t ) ) ) ) )
    144142
     143  (define (simple-environment-entry? obj)
     144    (and (pair? obj)
     145         (symbol? (car obj))
     146         (symbol? (cdr obj)) ) )
     147
     148  (define (macro-environment? obj)
     149    (and (list? obj)
     150         (or (null? obj)
     151             (macro-environment-entry? (car obj))
     152             #; ;enough already
     153             (call-with-current-continuation
     154               (lambda (return)
     155                 (##sys#for-each
     156                  (lambda (x) (unless (macro-environment-entry? x) (return #f) ) )
     157                  obj)
     158               #t ) ) ) ) )
     159
     160  (define (macro-environment-entry? obj)
     161    (and (pair? obj) (= 3 (length obj))
     162         (symbol? (car obj))
     163         (list? (cadr obj))
     164         #;(##sys#syntactic-environment? (cadr x)) ;enough already
     165         (procedure? (caddr obj)) ) )
     166
     167  (or (simple-environment? obj)
     168      (macro-environment? obj) ) )
     169
    145170; Workalike of '##sys#environment-symbols' for syntactic environments
     171; (I think :-)
    146172(define (##sys#syntactic-environment-symbols env pred)
    147   ;I have no effing idea at the moment if this is correct
    148   (define (walk-alias id)
    149     (let loop ((alias (##sys#get id '##core#macro-alias)))
    150       (and alias
    151            (or (##sys#get id '##core#real-name)
    152                (if (symbol? alias) alias
    153                    (and-let* ((env (car alias))
    154                               ((not (null? env))))
    155                      (loop (lookup id env)) ) ) ) ) ) )
     173  (define (try-alias id)
     174    (or (##sys#get id '##core#real-name)
     175        (let ((alias (##sys#get id '##core#macro-alias)))
     176          (cond ((not alias) id)
     177                ((pair? alias) id)
     178                (else alias) ) ) ) )
    156179  (let ((syms '()))
    157180    (##sys#for-each
     
    160183         (cond ((pred id)
    161184                (set! syms (cons id syms)) )
    162                ((walk-alias id) =>
     185               ((try-alias id) =>
    163186                (lambda (name)
    164187                  (when (pred name) (set! syms (cons name syms))) ) ) ) ) )
Note: See TracChangeset for help on using the changeset viewer.