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

cleanup

Browse Source 
svn: r17771
This commit is contained in:
Jon Rafkind 2010-01-22 21:11:26 +00:00
parent 91e3bc001f
commit 3e4221b410
2 changed files with 46 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/honu/private/honu-typed-scheme.ss
View File

@ -6,16 +6,15 @@
syntax/name
syntax/define
syntax/parse
scheme/list
scheme/splicing
"contexts.ss"
"util.ss"
"ops.ss"
)
;; "typed-utils.ss"
)
(require (for-meta 2 scheme/base
scheme/list
))
(require (for-meta 2 scheme/base "util.ss"))
(require (for-meta 3 scheme/base))
(provide (all-defined-out))
@ -364,6 +363,7 @@ x(2)
body.result)])
(define-syntax-class expr
[pattern f])
(define-splicing-syntax-class call
[pattern (~seq e:expr (#%parens arg:expression-1))
#:with call #'(e arg.result)])
@ -372,18 +372,6 @@ x(2)
[pattern (~seq x:number) #:with result #'x]
)
#;
(define-splicing-syntax-class expression-3
[pattern (~seq e:expression-last) #:with result #'e.result])
(define-syntax (syntax-lambda stx)
(syntax-case stx ()
[(_ (arg ...) body ...)
(with-syntax ([(temp ...) (generate-temporaries #'(arg ...))])
#'(lambda (temp ...)
(with-syntax ([arg temp] ...)
body ...)))]))
(define-syntax-rule (define-infix-operator name next [operator reducer] ...)
(define-splicing-syntax-class name
#:literals (operator ...)
@ -394,9 +382,6 @@ x(2)
#:with result #'exp.result]
))
(define (drop-last lst)
(take lst (sub1 (length lst))))
;; TODO: maybe just have a precedence macro that creates all these constructs
;; (infix-operators ([honu-* ...]
;; [honu-- ...])
@ -404,15 +389,6 @@ x(2)
;; [honu-- ...]))
;; Where operators defined higher in the table have higher precedence.
(define-syntax (infix-operators stx)
(define (drop-last lst)
(take lst (sub1 (length lst))))
(define-syntax (syntax-lambda stx)
(syntax-case stx ()
[(_ (arg ...) body ...)
(with-syntax ([(temp ...) (generate-temporaries #'(arg ...))])
#'(lambda (temp ...)
(with-syntax ([arg temp] ...)
body ...)))]))
(define (create-stuff names operator-stuff)
(define make (syntax-lambda (expression next-expression operator-stuff)
#;
@ -434,43 +410,35 @@ x(2)
(syntax->list #'(operator-stuff ...)))])
#'(begin
result ...)))]))
#;
(infix-operators expression-1 expression-last
([honu-+ (syntax-lambda (left right)
#'(+ left right))]
[honu-- (syntax-lambda (left right)
#'(- left right))])
([honu-* (syntax-lambda (left right)
#'(* left right))]
[honu-/ (syntax-lambda (left right)
#'(/ left right))]))
#;
(define-infix-operator expression-2 expression-3
[honu-* (syntax-lambda (left right)
#'(* left right))]
[honu-/ (syntax-lambda (left right)
#'(/ left right))])
#;
(define-infix-operator expression-1 expression-2
[honu-+ (syntax-lambda (left right)
#'(+ left right))]
[honu-- (syntax-lambda (left right)
#'(- left right))])
#;
(define-splicing-syntax-class expression-1
#:literals (honu-+ honu--)
[pattern (~seq exp-left:expression-2 honu-+ exp-right:expression-1)
#:with result #'(+ exp-left.result exp-right.result)]
[pattern (~seq exp-left:expression-2 honu-- exp-right:expression-1)
#:with result #'(- exp-left.result exp-right.result)]
[pattern (~seq exp:expression-2) #:with result #'exp.result])
([honu-+ (syntax-lambda (left right)
#'(+ left right))]
[honu-- (syntax-lambda (left right)
#'(- left right))])
([honu-* (syntax-lambda (left right)
#'(* left right))]
[honu-/ (syntax-lambda (left right)
#'(/ left right))]))
(define-syntax-class expression-top
[pattern (e:expression-1 semicolon . rest)
#:with result #'e.result])
(splicing-let-syntax ([sl (make-rename-transformer #'syntax-lambda)])
(infix-operators expression-1 expression-last
([honu-+ (sl (left right)
#'(+ left right))]
[honu-- (sl (left right)
#'(- left right))])
([honu-* (sl (left right)
#'(* left right))]
[honu-/ (sl (left right)
#'(/ left right))])))
;; (printf "~a\n" (syntax-class-parse function stx))
(syntax-parse stx
[function:function (values #'function.result #'function.rest)]

19
collects/honu/private/util.ss
View File

@ -1,10 +1,14 @@
#lang scheme
(provide (except-out (all-defined-out) test))
#;
(provide delim-identifier=?
extract-until
call-values)
(require syntax/stx)
(require syntax/stx
scheme/list)
(define (delim-identifier=? a b)
(eq? (syntax-e a) (syntax-e b)))
@ -32,6 +36,19 @@
(define-syntax-rule (call-values function values-producing)
(call-with-values (lambda () values-producing) function))
;; shortcut for treating arguments as syntax objects
(define-syntax (syntax-lambda stx)
(syntax-case stx ()
[(_ (arg ...) body ...)
(with-syntax ([(temp ...) (generate-temporaries #'(arg ...))])
#'(lambda (temp ...)
(with-syntax ([arg temp] ...)
body ...)))]))
;; removes the last element of a list
(define (drop-last lst)
(take lst (sub1 (length lst))))
(define (test)
(let* ([original #'(a b c d e)]
[delimiter #'c]