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

[honu] add operator which creates simple lambdas

Browse Source
This commit is contained in:
Jon Rafkind 2012-11-07 11:19:00 -07:00
parent 5d1bb74b42
commit 943ac799d8
3 changed files with 15 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/honu/core/main.rkt
View File

@ -63,6 +63,7 @@
[honu-> >] [honu-< <] [honu-> >] [honu-< <]
[honu->= >=] [honu->= >=]
[honu-<= <=] [honu-<= <=]
[honu-=> =>]
;; [honu-equal =] ;; [honu-equal =]
;; [honu-assignment :=] ;; [honu-assignment :=]
[honu-map map] [honu-map map]

10
collects/honu/core/private/macro2.rkt
View File

@ -156,7 +156,7 @@
;; foo_a temp_a ;; foo_a temp_a
;; (foo_b ...) (temp_b ...) ;; (foo_b ...) (temp_b ...)
(define (bind-attributes variable new-name) (define (bind-attributes variable new-name)
(debug "Syntax class of ~a is ~a at ~a\n" (debug 2 "Syntax class of ~a is ~a at ~a\n"
(pattern-variable-class variable) (pattern-variable-class variable)
(syntax-local-value (pattern-variable-class variable) (lambda () #f)) (syntax-local-value (pattern-variable-class variable) (lambda () #f))
(syntax-local-phase-level)) (syntax-local-phase-level))
@ -170,7 +170,7 @@
#f)))) #f))))
(define (mirror-attribute attribute) (define (mirror-attribute attribute)
(debug "Mirror attribute ~a\n" attribute) (debug 2 "Mirror attribute ~a\n" attribute)
(define-struct-fields attribute pattern-variable (define-struct-fields attribute pattern-variable
(name original depth class)) (name original depth class))
;; create a new pattern variable with a syntax object that uses ;; create a new pattern variable with a syntax object that uses
@ -181,7 +181,7 @@
attribute.original attribute.depth attribute.class))) attribute.original attribute.depth attribute.class)))
(define-struct-fields variable pattern-variable (define-struct-fields variable pattern-variable
(name original depth class)) (name original depth class))
(debug "Bind attributes ~a ~a\n" variable.name attribute.name) (debug 2 "Bind attributes ~a ~a\n" variable.name attribute.name)
(with-syntax ([bind-attribute (with-syntax ([bind-attribute
#; #;
(create name (syntax-e name) name) (create name (syntax-e name) name)
@ -201,7 +201,7 @@
new-name new-name
attribute.name) attribute.name)
attribute.original attribute.depth #f))]) attribute.original attribute.depth #f))])
(debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute) (debug 2 "Bind ~a to ~a\n" #'bind-attribute #'new-attribute)
#'(#:with bind-attribute #'new-attribute))) #'(#:with bind-attribute #'new-attribute)))
(for/set ([attribute attributes]) (for/set ([attribute attributes])
@ -378,7 +378,7 @@
(define mapping (make-hash)) (define mapping (make-hash))
(for ([old variables] (for ([old variables]
[new use]) [new use])
(debug "Update mapping ~a to ~a\n" (syntax-e (pattern-variable-name old)) new) (debug 2 "Update mapping ~a to ~a\n" (syntax-e (pattern-variable-name old)) new)
(hash-set! mapping (hash-set! mapping
(syntax-e (pattern-variable-name old)) (syntax-e (pattern-variable-name old))
(pattern-variable new (pattern-variable new

9
collects/honu/core/private/operator.rkt
View File

@ -131,3 +131,12 @@
(define-binary-operator honu-== 1 'left equal?) (define-binary-operator honu-== 1 'left equal?)
(define-binary-operator honu-not-equal 1 'left (lambda (left right) (define-binary-operator honu-not-equal 1 'left (lambda (left right)
(not (equal? left right)))) (not (equal? left right))))
(define-honu-operator/syntax honu-=> 0.00001 'left
(lambda (left right)
(when (not (identifier? left))
(raise-syntax-error '=> "expected an identifier" left))
(with-syntax ([left left]
[right right])
(racket-syntax (lambda (left)
right)))))