suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
original commit: b75e804dc857cff4005edda0028fcc21e879e134
This commit is contained in:
Scott Owens 2003-03-20 09:15:29 +00:00
parent c6dfa79587
commit 85f33639f9
2 changed files with 8 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/mzlib/private/structure-helper.ss
View File

@ -17,6 +17,12 @@
(let ((r (reverse path)))
(values (reverse (cdr r)) (car r))))
(define (get-renames id err)
(let ((x (syntax-local-value id (err id))))
(unless (str? x)
((err id)))
(str-renames x)))
(define (open path type)
(unless (identifier? (car path))
(raise-syntax-error type "Path component must be an identifier" (car path)))
@ -24,9 +30,7 @@
(lambda ()
(raise-syntax-error type "Unknown structure" name)))))
(let loop ((path (cdr path))
(env (str-renames (syntax-local-value
(car path)
(err (car path))))))
(env (get-renames (car path) err)))
(cond
((null? path) env)
(else
@ -35,10 +39,7 @@
(let ((bind (assq (syntax-object->datum (car path)) env)))
(unless bind
((err (car path))))
(let ((new-env
(str-renames
(syntax-local-value (cdr bind) (err (cdr bind))))))
(loop (cdr path) new-env))))))))
(loop (cdr path) (get-renames (cdr bind) err))))))))
(define (open-as-helper path field)
(unless (identifier? field)

52
collects/sml/private/structure-helper.ss
View File

@ -1,52 +0,0 @@
(module structure-helper mzscheme
(require (lib "stx.ss" "syntax"))
(provide str str? str-renames make-str remove-dups split open open-as-helper)
(define-struct str (renames))
(define (remove-dups l)
(let ((ht (make-hash-table)))
(let loop ((l l))
(cond
((null? l) null)
((hash-table-get ht (caar l) (lambda () #f)) (loop (cdr l)))
(else
(hash-table-put! ht (caar l) #t)
(cons (car l) (loop (cdr l))))))))
(define (split path)
(let ((r (reverse path)))
(values (reverse (cdr r)) (car r))))
(define (open path type)
(unless (identifier? (car path))
(raise-syntax-error type "Path component must be an identifier" (car path)))
(let ((err (lambda (name)
(lambda ()
(raise-syntax-error type "Unknown structure" name)))))
(let loop ((path (cdr path))
(env (str-renames (syntax-local-value
(car path)
(err (car path))))))
(cond
((null? path) env)
(else
(unless (identifier? (car path))
(raise-syntax-error type "Path component must be an identifier" (car path)))
(let ((bind (assq (syntax-object->datum (car path)) env)))
(unless bind
((err (car path))))
(let ((new-env
(str-renames
(syntax-local-value (cdr bind) (err (cdr bind))))))
(loop (cdr path) new-env))))))))
(define (open-as-helper path field)
(unless (identifier? field)
(raise-syntax-error 'open-as "Field to open must be an identifier" field))
(let ((hid (assq (syntax-object->datum field )
(open (stx->list path) 'open-as))))
(unless hid
(raise-syntax-error 'open-as "Unknown field" field))
(make-rename-transformer (cdr hid))))
)