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

require in the HtDP languages

Browse Source 
svn: r6116
This commit is contained in:
Matthew Flatt 2007-05-02 01:18:57 +00:00
parent 0cba826ae5
commit 60cb899ba1
9 changed files with 122 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/lang/htdp-advanced.ss
View File

@ -9,8 +9,6 @@
(lib "docprovide.ss" "syntax")
"posn.ss")
(provide require)
;; syntax:
(provide (rename advanced-define define)
(rename advanced-define-struct define-struct)
@ -27,6 +25,7 @@
(rename beginner-if if)
(rename beginner-and and)
(rename beginner-or or)
(rename beginner-require require)
(rename intermediate-quote quote)
(rename intermediate-quasiquote quasiquote)
(rename intermediate-unquote unquote)

3
collects/lang/htdp-beginner-abbr.ss
View File

@ -5,8 +5,6 @@
(lib "math.ss")
(lib "docprovide.ss" "syntax"))
(provide require)
;; Implements the forms:
(require "private/teach.ss"
"private/contract-forms.ss"
@ -23,6 +21,7 @@
(rename beginner-if if)
(rename beginner-and and)
(rename beginner-or or)
(rename beginner-require require)
;; (rename beginner-contract contract)
;; (rename beginner-define-data define-data)
(rename intermediate-quote quote)

3
collects/lang/htdp-beginner.ss
View File

@ -8,8 +8,6 @@
(lib "list.ss")
(lib "docprovide.ss" "syntax"))
(provide require)
;; Implements the forms:
(require "private/teach.ss"
"private/contract-forms.ss")
@ -27,6 +25,7 @@
(rename beginner-or or)
(rename beginner-quote quote)
(rename beginner-module-begin #%module-begin)
(rename beginner-require require)
; (rename beginner-contract contract)
; (rename beginner-define-data define-data)
#%datum

3
collects/lang/htdp-intermediate-lambda.ss
View File

@ -6,8 +6,6 @@
(lib "list.ss")
(lib "docprovide.ss" "syntax"))
(provide require)
;; syntax:
(provide (rename intermediate-define define)
(rename intermediate-define-struct define-struct)
@ -24,6 +22,7 @@
(rename beginner-if if)
(rename beginner-and and)
(rename beginner-or or)
(rename beginner-require require)
(rename intermediate-quote quote)
(rename intermediate-quasiquote quasiquote)
(rename intermediate-unquote unquote)

3
collects/lang/htdp-intermediate.ss
View File

@ -7,8 +7,6 @@
(lib "list.ss")
(lib "docprovide.ss" "syntax"))
(provide require)
;; syntax:
(provide (rename intermediate-define define)
(rename intermediate-define-struct define-struct)
@ -25,6 +23,7 @@
(rename beginner-if if)
(rename beginner-and and)
(rename beginner-or or)
(rename beginner-require require)
(rename intermediate-quote quote)
(rename intermediate-quasiquote quasiquote)
(rename intermediate-unquote unquote)

98
collects/lang/private/teach.ss
View File

@ -137,6 +137,7 @@
beginner-and
beginner-or
beginner-quote
beginner-require
intermediate-define
intermediate-define-struct
@ -1113,6 +1114,103 @@
(syntax/loc stx (quote expr)))]
[_else (bad-use-error 'quote stx)]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; require
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (check-string-form stx s)
(unless (regexp-match #rx#"^[-a-zA-Z0-9_. ]+(/+[-a-zA-Z0-9_. ]+)*$" (syntax-e s))
(teach-syntax-error
'require
stx
s
(cond
[(string=? "" (syntax-e s))
"a module-naming string cannot be empty"]
[(regexp-match #rx"^/" (syntax-e s))
"a module-naming string cannot start with a slash"]
[(regexp-match #rx"/$" (syntax-e s))
"a module-naming string cannot end with a slash"]
[else
"a module-naming string can contain only a-z, A-Z, 0-9, -, _, ., space, and slash"]))))
(define (version-number? n)
(and (number? n) (exact? n) (integer? n) (n . >= . 0)))
(define (beginner-require/proc stx)
(when (identifier? stx)
(bad-use-error 'require stx))
(unless (memq (syntax-local-context) '(top-level module module-begin))
(teach-syntax-error
'define
stx
#f
"found a module require that is not at the top level"))
(syntax-case stx (lib planet)
[(_ s)
(string? (syntax-e #'s))
(begin
(check-string-form stx #'s)
#'(require s))]
[(_ (lib . rest))
(let ([s (syntax->list #'rest)])
(unless ((length s) . >= . 2)
(teach-syntax-error
'require
stx
#f
"expected at least two strings with lib, found only ~a parts"
(length s)))
(for-each (lambda (v)
(unless (string? (syntax-e v))
(teach-syntax-error
'require
stx
v
"expected a string for a lib path, found ~a"
(something-else v)))
(check-string-form stx v))
s)
#'(require (lib . rest)))]
[(_ (planet . rest))
(syntax-case stx (planet)
[(_ (planet s1 (s2 s3 n1 n2)))
(and (string? (syntax-e #'s1))
(string? (syntax-e #'s2))
(string? (syntax-e #'s3))
(version-number? (syntax-e #'n1))
(version-number? (syntax-e #'n2)))
(begin
(check-string-form stx #'s1)
(check-string-form stx #'s2)
(check-string-form stx #'s3)
#'(require (planet . rest)))]
[_else
(teach-syntax-error
'require
stx
#f
"not a valid planet path; should be: (require (planet STRING (STRING STRING NUMBER NUMBER)))")])]
[(_ thing)
(teach-syntax-error
'require
stx
#'thing
"expected a module name as a string, a `lib' form, or a `planet' form, found ~a"
(something-else #'thing))]
[(_)
(teach-syntax-error
'require
stx
#f
"expected a module name after `require', but found nothing")]
[(_ . rest)
(teach-syntax-error
'require
stx
#f
"expected a single module name after `require', but found ~a parts"
(length (syntax->list #'rest)))]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; local

2
collects/tests/mzscheme/advanced.ss
View File

@ -206,7 +206,7 @@
(define x 10)
(define (f y) f)
(define-struct s (x y)))
(require my-advanced-module)
(mz-require my-advanced-module)
(parameterize ([current-namespace (module->namespace 'my-advanced-module)])
(eval #'(set! x 12))
(eval #'(set! f 12))

14
collects/tests/mzscheme/beg-adv.ss
View File

@ -228,3 +228,17 @@
(htdp-syntax-test #'(define (my-x h) 12) #rx"cannot be re-defined")
(htdp-top-pop 1)
(htdp-top-pop 1)
(htdp-syntax-test #'define #rx"does not follow")
(htdp-syntax-test #'(require) #rx"found nothing")
(htdp-syntax-test #'(require a) #rx"expected a module name as a")
(htdp-syntax-test #'(require "a" "b") #rx"a single module name")
(htdp-syntax-test #'(require "") #rx"empty")
(htdp-syntax-test #'(require "/a") #rx"start with a slash")
(htdp-syntax-test #'(require "a/") #rx"end with a slash")
(htdp-syntax-test #'(require "a%&#^%") #rx"string can contain only")
(htdp-syntax-test #'(require (lib)) #rx"expected at least two strings")
(htdp-syntax-test #'(require (lib "a")) #rx"expected at least two strings")
(htdp-syntax-test #'(require (lib "a" "b/")) #rx"end with a slash")
(htdp-syntax-test #'(require (lib "a" 2)) #rx"string for a lib path")
(htdp-syntax-test #'(require (planet "a" 2)) #rx"not a valid planet path")

7
collects/tests/mzscheme/htdp-test.ss
View File

@ -64,7 +64,8 @@
(and (exn:fail:syntax? x)
(regexp-match rx (exn-message x)))))]))
(require (rename mzscheme mz-let let))
(require (rename mzscheme mz-let let)
(rename mzscheme mz-require require))
(define-syntax (htdp-test stx)
(syntax-case stx ()
@ -133,8 +134,8 @@
#,(strip-context stx)))
(unless stx-err?
(if exn?
(err/rt-test (eval #`(require #,name)) exn?)
(eval #`(require #,name))))))
(err/rt-test (eval #`(mz-require #,name)) exn?)
(eval #`(mz-require #,name))))))
(define-syntax (htdp-eval stx)
(syntax-case stx ()