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

16
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,16 +78,20 @@
(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
(define (bound-transformer stx)
(and (stx-pair? stx)
(identifier? (stx-car stx)) (identifier? (stx-car stx))
(let ([v (syntax-local-value (stx-car stx) (lambda () #f))]) (let ([v (syntax-local-value (stx-car stx) (lambda () #f))])
(and (honu-transformer? v) v))) (and (honu-transformer? v) v))))
(define (special-transformer stx)
(and (stx-pair? stx) (and (stx-pair? stx)
(let ([first (stx-car stx)]) (let ([first (stx-car stx)])
(cond (cond
@ -108,7 +116,9 @@
(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