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

pulling when and unless from the original definitions

Browse Source
This commit is contained in:
Danny Yoo 2011-09-30 16:52:04 -04:00
parent 6d7970f097
commit 40957f141f
3 changed files with 65 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
cs019/cs019-pre-base.rkt
View File

@ -1,9 +1,11 @@
#lang s-exp "../lang/base.rkt"
(require (for-syntax "teach.rkt"))
(require (for-syntax "teach.rkt")
(for-syntax racket/base))
(provide cs019-lambda)
(define-syntax cs019-lambda advanced-lambda/proc)
(define-syntax cs019-lambda advanced-lambda/proc)
(define-syntaxes (cs019-when cs019-unless) (values advanced-when/proc advanced-unless/proc))

90
cs019/cs019.rkt
View File

@ -9,7 +9,9 @@
(require "cs019-pre-base.rkt")
(provide (rename-out [cs019-lambda lambda]))
(provide (rename-out [cs019-lambda lambda]
[cs019-when when]
[cs019-unless unless]))
(require (prefix-in whalesong: "../lang/whalesong.rkt"))
@ -24,8 +26,6 @@
if
cond
case
when
unless
member
lambda)
@ -385,90 +385,6 @@
#;(define-for-syntax (make-when-unless who target-stx)
(lambda (stx)
(syntax-case stx ()
[(_ q expr ...)
(let ([exprs (syntax->list (syntax (expr ...)))])
(check-single-expression who
(format "for the answer in `~a'"
who)
stx
exprs
null)
)]
[(_)
(teach-syntax-error
who
stx
#f
"expected a question expression after `~a', but nothing's there"
who)]
[_else
(bad-use-error who stx)])))
;; FIXME: I'm seeing a bad error message when trying to use the functional
;; abstraction in teach.rkt to define the -when and -unless macros.
;;
;; The error message is: module-path-index-resolve: "self" index has
;; no resolution: #<module-path-index>
;; As soon as the bug's resolved, refactor this back.
(define-syntax (-when stx)
(syntax-case stx ()
[(_ q expr ...)
(let ([exprs (syntax->list (syntax (expr ...)))])
(check-single-expression #'when
(format "for the answer in `~a'"
#'when)
stx
exprs
null)
(with-syntax ([new-test (verify-boolean #'q 'when)])
(let ([result
(syntax/loc stx
(when new-test expr ...))])
result)))]
[(_)
(teach-syntax-error
#'when
stx
#f
"expected a question expression after `~a', but nothing's there"
#'when)]
[_else
(bad-use-error #'when stx)]))
(define-syntax (-unless stx)
(syntax-case stx ()
[(_ q expr ...)
(let ([exprs (syntax->list (syntax (expr ...)))])
(check-single-expression #'unless
(format "for the answer in `~a'"
#'unless)
stx
exprs
null)
(with-syntax ([new-test (verify-boolean #'q 'when)])
(let ([result
(syntax/loc stx
(unless new-test expr ...))])
result)))]
[(_)
(teach-syntax-error
#'unless
stx
#f
"expected a question expression after `~a', but nothing's there"
#'unless)]
[_else
(bad-use-error #'unless stx)]))
(provide (rename-out [-when when]
[-unless unless]))
(define 1-LET "1-letter string")

59
cs019/teach.rkt
View File

@ -5,7 +5,9 @@
racket/list)
(provide advanced-lambda/proc)
(provide advanced-lambda/proc
advanced-when/proc
advanced-unless/proc)
@ -18,6 +20,17 @@
(raise-syntax-error form msg stx))))
(define (teach-syntax-error* form stx details msg . args)
(let ([exn (with-handlers ([exn:fail:syntax?
(lambda (x) x)])
(apply teach-syntax-error form stx #f msg args))])
(raise
(make-exn:fail:syntax
(exn-message exn)
(exn-continuation-marks exn)
details))))
(define (ensure-expression stx k)
(if (memq (syntax-local-context) '(expression))
@ -137,3 +150,47 @@
"expected at least one variable (in parentheses) after lambda, but nothing's there")]
[_else
(bad-use-error 'lambda stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; when and unless (advanced)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-values (advanced-when/proc advanced-unless/proc)
(let ([mk
(lambda (who target-stx)
(lambda (stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx ()
[(_)
(teach-syntax-error
who
stx
#f
"expected a question and an answer, but nothing's there")]
[(_ q)
(teach-syntax-error
who
stx
#'q
"expected a question and an answer, but found only one part")]
[(_ q a)
(with-syntax ([who who]
[target target-stx])
(syntax/loc stx (target (verify-boolean q 'who) a)))]
[(_ . parts)
(teach-syntax-error*
who
stx
(syntax->list #'parts)
"expected a question and an answer, but found ~a parts" (length (syntax->list #'parts)))]
[_else
(bad-use-error who stx)])))))])
(values (mk 'when (quote-syntax when))
(mk 'unless (quote-syntax unless)))))