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

parse assignment. add simple struct form that can be accessed by field identifiers

Browse Source
This commit is contained in:
Jon Rafkind 2010-07-14 11:35:34 -06:00
parent a3fefc1c35
commit ebb177f28d
2 changed files with 46 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/honu/main.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base))
(require scheme/class)
(require racket/class)
(require "private/honu-typed-scheme.ss"
;; "private/honu.ss"
@ -34,6 +34,17 @@
(define (sql4) #f)
(define (sql5) #f)
(define-syntax (honu-struct stx)
(syntax-parse stx
[(_ name (my-field ...))
(with-syntax ([new-name (gensym (syntax->datum #'name))])
#'(begin
(define new-name
(class object%
(init-field my-field ...)
(super-new)))
(define name (lambda args (apply make-object new-name args)))))]))
(provide (rename-out (#%dynamic-honu-module-begin #%module-begin)
;; (honu-top #%top)
(semicolon \;
@ -43,6 +54,7 @@
(+ scheme:+)
(honu-/ /)
(honu-- -)
(honu-= =)
(honu-? ?)
(honu-: :)
(honu-comma |,|)
@ -114,12 +126,14 @@
foobar2000
expression
str
define-struct
;; define-struct
#;
(for-template #%parens #%brackets #%braces)
in-range
honu-struct
;; (for-meta 2 (rename-out (honu-syntax syntax)))
(rename-out
(struct scheme-struct)
(syntax real-syntax)
(for scheme-for)
(honu-if if)

37
collects/honu/private/parse.rkt
View File

@ -4,7 +4,8 @@
"util.ss"
(for-template "literals.ss"
"language.ss"
"syntax.ss")
"syntax.ss"
racket/class)
syntax/parse
syntax/parse/experimental/splicing
"syntax.ss"
@ -14,6 +15,7 @@
scheme/splicing
(for-syntax syntax/define)
syntax/name
racket/match
syntax/stx
(for-syntax "util.ss")
(for-syntax syntax/private/stxparse/runtime-prose
@ -327,7 +329,7 @@
([honu-* (sl (left right) #'(* left right))]
[honu-% (sl (left right) #'(modulo left right))]
[honu-/ (sl (left right) #'(/ left right))])
([honu-. (sl (left right) #'(field-access right left))])
([honu-. (sl (left right) #'(get-field right left))])
))
(define-splicing-syntax-class (ternary context)
@ -348,14 +350,33 @@
(printf "Debug parse I got here ~a\n" d)
#t)])
(define (make-assignment left right)
(match (identifier-binding left)
['lexical (with-syntax ([left left] [right right])
#'(set! left right))]
[#f (with-syntax ([left left] [right right])
#'(define left right))]
[(list source-mod source-id nominal-source-mod nominal-source-id source-phase import-phase nominal-export-phase) (with-syntax ([left left] [right right])
#'(set! left right))]
[else (raise-syntax-error 'assignment "failed to assign" left right)]
))
(define-syntax-class (assignment context)
#:literals (semicolon honu-=)
[pattern ((~var left honu-identifier)
honu-=
(~var right (ternary context))
semicolon
. rest)
;; FIXME! 1 isn't the right result
;; either `set!' or `define' the variable
#:with result (make-assignment #'left.result #'right.result)])
(define-syntax-class (expression-top context)
#:literals (semicolon)
[pattern ((~var left honu-identifier)
honu-=
(~var right (ternary context))
semicolon
. rest)
#:with result #'1]
[pattern (~var assignment (assignment context))
#:with result #'assignment.result
#:with rest #'assignment.rest]
[pattern ((~var x0 (debug-here (format "expression top\n")))
(~var e (ternary context))
(~var x1 (debug-here (format "expression top 1 ~a\n" (syntax->datum #'e))))