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

[honu] refactor dot into syntax classes

Browse Source
This commit is contained in:
Jon Rafkind 2011-12-09 16:03:45 -07:00
parent 13abcf91fb
commit ec02c2f83a
1 changed files with 32 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/honu/core/private/honu2.rkt
View File

@ -181,28 +181,38 @@
(provide honu-dot) (provide honu-dot)
(define-honu-fixture honu-dot (define-honu-fixture honu-dot
(lambda (left rest) (lambda (left rest)
(syntax-parse rest #:literal-sets (cruft)
;; v.x = 5
(define-syntax-class assign #:literal-sets (cruft)
#:literals (honu-assignment) #:literals (honu-assignment)
[(_ name:identifier honu-assignment argument:honu-expression . more) [pattern (_ name:identifier honu-assignment argument:honu-expression . more)
(with-syntax ([left left]) #:with result (with-syntax ([left left])
(values #'(%racket #'(%racket
(let ([left* left]) (let ([left* left])
(cond (cond
[(honu-struct? left*) [(honu-struct? left*)
(honu-struct-set! left* 'name argument.result)] (honu-struct-set! left* 'name argument.result)]
[(object? left*) (error 'set "implement set for objects")]))) [(object? left*) (error 'set "implement set for objects")]))))
#'more))] #:with rest #'more])
[(_ name:identifier . more)
(with-syntax ([left left]) ;; v.x
(values #'(%racket (define-syntax-class plain #:literal-sets (cruft)
#:literals (honu-assignment)
[pattern (_ name:identifier . more)
#:with result (with-syntax ([left left])
#'(%racket
(let ([left* left]) (let ([left* left])
(cond (cond
[(honu-struct? left*) (let ([use (honu-struct-get left*)]) [(honu-struct? left*) (let ([use (honu-struct-get left*)])
(use left* 'name))] (use left* 'name))]
[(object? left*) (get-field name left*)] [(object? left*) (get-field name left*)]
;; possibly handle other types of data ;; possibly handle other types of data
[else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))) [else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))))
#'more))]))) #:with rest #'more])
(syntax-parse rest
[stuff:assign (values #'stuff.result #'stuff.rest)]
[stuff:plain (values #'stuff.result #'stuff.rest)])))
#; #;
(define-honu-operator/syntax honu-dot 10000 'left (define-honu-operator/syntax honu-dot 10000 'left
(lambda (left right) (lambda (left right)