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

some refactorings and comments

Browse Source 
svn: r13381
This commit is contained in:
Jon Rafkind 2009-02-03 17:39:43 +00:00
parent 51839c33a1
commit f0cac461e7
1 changed files with 35 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
collects/honu/main.ss
View File

@ -9,6 +9,7 @@
(begin-for-syntax (begin-for-syntax
;; these definitions are used as stop-lists in local-expand
(define kernel-forms (kernel-form-identifier-list)) (define kernel-forms (kernel-form-identifier-list))
(define prop-expand-stop-forms (list* #'honu-typed (define prop-expand-stop-forms (list* #'honu-typed
#'honu-unparsed-block #'honu-unparsed-block
@ -51,6 +52,8 @@
(define (honu-type-pred-stx v) (honu-type-ref v 2)) (define (honu-type-pred-stx v) (honu-type-ref v 2))
(define (honu-type-protect-stx v) (honu-type-ref v 3)) (define (honu-type-protect-stx v) (honu-type-ref v 3))
;; convert a honu type into a list with nice formatting
;; todo: need example
(define (format-type t) (define (format-type t)
(if (identifier? t) (if (identifier? t)
(syntax-e t) (syntax-e t)
@ -66,6 +69,7 @@
;; -------------------------------------------------------- ;; --------------------------------------------------------
;; Parsing blocks ;; Parsing blocks
;; #t if the syntax object contains an operator
(define operator? (define operator?
(let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")])
(lambda (stx) (lambda (stx)
@ -74,41 +78,47 @@
(and (positive? (string-length str)) (and (positive? (string-length str))
(memq (string-ref str 0) sym-chars))))))) (memq (string-ref str 0) sym-chars)))))))
;; #t if the identifier is not an operator nor a delimiter
(define (honu-identifier? stx) (define (honu-identifier? stx)
(and (identifier? stx) (and (identifier? stx)
(not (ormap (lambda (i) (delim-identifier=? stx i)) (list #'\; #'\,))) (not (ormap (lambda (i) (delim-identifier=? stx i)) (list #'\; #'\,)))
(not (operator? stx)))) (not (operator? stx))))
(define (get-transformer stx) (define (get-transformer stx)
(or (and (stx-pair? stx) ;; if its an identifier and bound to a transformer return it
(identifier? (stx-car stx)) (define (bound-transformer stx)
(let ([v (syntax-local-value (stx-car stx) (lambda () #f))]) (and (stx-pair? stx)
(and (honu-transformer? v) v))) (identifier? (stx-car stx))
(and (stx-pair? stx) (let ([v (syntax-local-value (stx-car stx) (lambda () #f))])
(let ([first (stx-car stx)]) (and (honu-transformer? v) v))))
(cond (define (special-transformer stx)
[(and (stx-pair? first) (and (stx-pair? stx)
(identifier? (stx-car first)) (let ([first (stx-car stx)])
(delim-identifier=? #'#%parens (stx-car first))) (cond
;; If the stx-car is a list with just one operator symbol, [(and (stx-pair? first)
;; try using the operator as a transformer (identifier? (stx-car first))
(let ([l (cdr (stx->list first))]) (delim-identifier=? #'#%parens (stx-car first)))
(let loop ([l l]) ;; If the stx-car is a list with just one operator symbol,
(cond ;; try using the operator as a transformer
(let ([l (cdr (stx->list first))])
(let loop ([l l])
(cond
[(null? l) #f] [(null? l) #f]
[(operator? (car l)) [(operator? (car l))
(if (ormap operator? (cdr l)) (if (ormap operator? (cdr l))
#f #f
(let ([v (syntax-local-value (car l) (lambda () #f))]) (let ([v (syntax-local-value (car l) (lambda () #f))])
(and (honu-transformer? v) (and (honu-transformer? v)
v)))] v)))]
[else (loop (cdr l))])))] [else (loop (cdr l))])))]
[(and (stx-pair? first) [(and (stx-pair? first)
(identifier? (stx-car first)) (identifier? (stx-car first))
(module-identifier=? #'#%angles (stx-car first))) (module-identifier=? #'#%angles (stx-car first)))
(let ([v (syntax-local-value (stx-car first) (lambda () #f))]) (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
(and (honu-transformer? v) v))] (and (honu-transformer? v) v))]
[else #f]))))) [else #f]))))
(or (bound-transformer stx)
(special-transformer stx)))
;; -------------------------------------------------------- ;; --------------------------------------------------------
;; Parsing blocks ;; Parsing blocks