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

[honu] handle unary operators. add some common functions and binary operators

Browse Source
This commit is contained in:
Jon Rafkind 2011-08-15 16:36:52 -06:00
parent 53e80f6f38
commit 85110e177b
8 changed files with 66 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -17,12 +17,16 @@
[honu-+ +] [honu-- -]
[honu-* *] [honu-/ /]
[honu-^ ^]
[honu-> >] [honu-< <]
[honu->= >=] [honu-<= <=]
[honu-flow \|]
[honu-dot |.|]
[honu-cons ::]
[honu-and and] [honu-and &&]
[honu-or or] [honu-or \|\|]
[honu-not not] [honu-not !]
[honu-structure structure]
[honu-structure struct]
[literal:honu-= =]
[literal:semicolon |;|]
[literal:honu-comma |,|]

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

@ -83,10 +83,25 @@
(begin
(provide name)
(define-honu-operator/syntax name precedence associativity
;; binary
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(operator left right))))))
#'(operator left right)))
;; unary
(lambda (argument)
(with-syntax ([argument argument])
#'(operator argument))))))
(define-syntax-rule (define-unary-operator name precedence associativity operator)
(begin
(provide name)
(define-honu-operator/syntax name precedence associativity
#f
;; unary
(lambda (argument)
(with-syntax ([argument argument])
#'(operator argument))))))
(provide honu-dot)
(define-honu-operator/syntax honu-dot 10000 'left
@ -112,6 +127,12 @@
(define-binary-operator honu-* 2 'left *)
(define-binary-operator honu-/ 2 'left /)
(define-binary-operator honu-^ 2 'right expt)
(define-binary-operator honu-< 0.9 'left <)
(define-binary-operator honu-<= 0.9 'left <=)
(define-binary-operator honu-> 0.9 'left >)
(define-binary-operator honu->= 0.9 'left >=)
(define-binary-operator honu-and 0.5 'left and)
(define-binary-operator honu-or 0.5 'left or)
(define-binary-operator honu-cons 0.1 'right cons)
(define-unary-operator honu-not 0.7 'left not)

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

@ -7,5 +7,7 @@
(provide define-honu-operator/syntax)
(define-syntax (define-honu-operator/syntax stx)
(syntax-parse stx
[(_ name precedence associativity function)
#'(define-syntax name (make-honu-operator precedence associativity function))]))
[(_ name precedence associativity binary-function)
#'(define-syntax name (make-honu-operator precedence associativity binary-function #f))]
[(_ name precedence associativity binary-function unary-function)
#'(define-syntax name (make-honu-operator precedence associativity binary-function unary-function))]))

15
collects/honu/core/private/parse2.rkt
View File

@ -175,7 +175,8 @@
[(honu-operator? #'head)
(define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
(define association (transformer:honu-operator-ref (syntax-local-value #'head) 1))
(define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 2))
(define binary-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 2))
(define unary-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 3))
(define higher
(case association
[(left) >]
@ -184,7 +185,13 @@
(if (higher new-precedence precedence)
(do-parse #'(rest ...) new-precedence
(lambda (stuff)
(left (operator-transformer current stuff)))
(if current
(if binary-transformer
(left (binary-transformer current stuff))
(error '#'head "cannot be used as a binary operator"))
(if unary-transformer
(left (unary-transformer stuff))
(error '#'head "cannot be used as a unary operator"))))
#f)
(do-parse #'(head rest ...)
0
@ -250,10 +257,10 @@
(if current
(let ()
(debug "function call ~a\n" left)
(define call (left (with-syntax ([current current]
(define call (with-syntax ([current current]
[(parsed-args ...)
(parse-comma-expression #'(args ...)) ])
#'(current parsed-args ...))))
#'(current parsed-args ...)))
(do-parse #'(rest ...) precedence left call))
(let ()
(debug "inner expression ~a\n" #'(args ...))

18
collects/honu/core/private/transformer.rkt
View File

@ -33,16 +33,22 @@
#;
(provide honu-operator?)
(define-values (struct:honu-operator -make-honu-operator honu-operator? -honu-operator-ref honu-operator-set!)
(make-struct-type 'honu-operator #f 3 0 #f
(make-struct-type 'honu-operator #f 4 0 #f
(list (list prop:honu-operator #t))
(current-inspector) 0))
(define (make-honu-operator precedence associativity proc)
(unless (and (procedure? proc)
(procedure-arity-includes? proc 2))
(define (make-honu-operator precedence associativity binary unary)
(when (and (procedure? binary)
(not (procedure-arity-includes? binary 2)))
(raise-type-error
'define-honu-operator/syntax
"procedure (arity 2)"
proc))
(-make-honu-operator precedence associativity proc))
binary))
(when (and (procedure? unary)
(not (procedure-arity-includes? unary 1)))
(raise-type-error
'define-honu-operator/syntax
"procedure (arity 1)"
unary))
(-make-honu-operator precedence associativity binary unary))

7
collects/honu/core/read.rkt
View File

@ -24,16 +24,17 @@
(define-lex-abbrev digit (:/ #\0 #\9))
(define-lex-abbrev identifier-first-character (:or (:/ #\a #\z)
(:/ #\A #\Z)
":"))
":" "_"))
(define-lex-abbrev identifier-character (:or identifier-first-character
digit))
(define-lex-abbrev identifier (:: identifier-first-character
(:* identifier-character)))
(define-lex-abbrev number (:+ digit))
(define-lex-abbrev number (:: (:+ digit) (:? (:: "." (:+ digit)))))
(define-lex-abbrev string-character (:or (:: #\\ any-char)
(:~ #\")))
(define-lex-abbrev string (:: #\" (:* string-character) #\"))
(define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^" "||" "|" "&&"))
(define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^" "||" "|" "&&" "<="
">=" "<" ">" "!"))
(define-lex-abbrev block-comment (:: "/*"
(complement (:: any-string "*/" any-string))
"*/"))

3
collects/honu/main.rkt
View File

@ -11,7 +11,10 @@
...))
(provide-module "core/main.rkt"
"private/common.rkt"
;;"private/struct.honu"
;;"private/function.honu"
;;"private/common.honu"
)
(provide sqr sqrt sin max)

4
collects/honu/private/common.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/base
(provide sqr)
(define (sqr x) (* x x))