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

Converting utils.ss and checker.ss to scheme/base.

Browse Source 
svn: r11633
This commit is contained in:
Stevie Strickland 2008-09-10 17:59:24 +00:00
parent a115dc3d8b
commit 12bcac14d3
2 changed files with 174 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/handin-server/checker.ss
View File

@ -1,16 +1,17 @@
#lang mzscheme
#lang scheme/base
(require "utils.ss" mzlib/file mzlib/list mzlib/class mred)
(require (for-syntax scheme/base) "utils.ss" scheme/file scheme/list scheme/class mred)
(provide (all-from-except mzscheme #%module-begin) (all-from "utils.ss"))
(provide (except-out (all-from-out scheme/base) #%module-begin)
(all-from-out "utils.ss"))
(provide (rename module-begin~ #%module-begin))
(provide (rename-out [module-begin~ #%module-begin]))
(define-syntax (module-begin~ stx)
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
(if (pair? e)
(with-syntax ([user-pre (datum->syntax-object stx 'user-pre stx)]
[user-post (datum->syntax-object stx 'user-post stx)])
(datum->syntax-object
(with-syntax ([user-pre (datum->syntax stx 'user-pre stx)]
[user-post (datum->syntax stx 'user-post stx)])
(datum->syntax
(quote-syntax here)
(list* (quote-syntax #%plain-module-begin)
#'(define user-pre #f)
@ -104,7 +105,7 @@
(format "~a" (or (send x get-text 0 (send x get-count) #t) x))]
[(special-comment? x)
(format "#| ~a |#" (special-comment-value x))]
[(syntax? x) (syntax-object->datum x)]
[(syntax? x) (syntax->datum x)]
[else x]))
(let-values ([(filter) (if (pair? filter) (car filter) item->text)]
[(in out) (make-pipe 4096)])
@ -317,7 +318,7 @@
(define submission-eval (make-parameter #f))
;; without this the primitive eval is not available
(provide (rename eval prim-eval))
(provide (rename-out [eval prim-eval]))
;; for adding lines in the checker
(define added-lines (make-thread-cell #f))
@ -344,7 +345,7 @@
(provide check:)
(define-syntax (check: stx)
(define (id s) (datum->syntax-object stx s stx))
(define (id s) (datum->syntax stx s stx))
(let loop ([stx (syntax-case stx () [(_ x ...) #'(x ...)])]
[keyvals '()]
[got null])
@ -473,7 +474,7 @@
(prefix-line (subst str generic-substs)))
(define (write-text)
(set-run-status "creating text file")
(with-output-to-file text-file
(with-output-to-file text-file #:exists 'truncate
(lambda ()
(for-each (lambda (user)
(prefix-line
@ -482,8 +483,7 @@
(for-each prefix-line/substs extra-lines)
(for-each prefix-line/substs
(or (thread-cell-ref added-lines) '()))
(display submission-text))
'truncate))
(display submission-text))))
(define submission-text
(and create-text?
(begin (set-run-status "reading submission")
@ -557,7 +557,7 @@
[(_ get (var ...) body ...)
(with-syntax ([(>var ...)
(map (lambda (v)
(datum->syntax-object
(datum->syntax
v
(string->symbol
(string-append
@ -572,7 +572,7 @@
(let ([make-pre/post:
(lambda (what)
(lambda (stx)
(define (id s) (datum->syntax-object stx s stx))
(define (id s) (datum->syntax stx s stx))
(syntax-case stx ()
[(_ body ...)
(with-syntax ([users (id 'users)]

17
collects/handin-server/utils.ss
View File

@ -1,17 +1,18 @@
(module utils mzscheme
(require mzlib/list
mzlib/class
#lang scheme/base
(require scheme/list
scheme/class
mred
lang/posn
(prefix pc: mzlib/pconvert)
mzlib/pretty
(only "main.ss" timeout-control)
(prefix-in pc: mzlib/pconvert)
scheme/pretty
(only-in "main.ss" timeout-control)
"private/run-status.ss"
"private/config.ss"
"private/logger.ss"
"sandbox.ss")
(provide (all-from "sandbox.ss")
(provide (all-from-out "sandbox.ss")
get-conf
log-line
@ -183,5 +184,3 @@
(define (call-with-evaluator/submission lang teachpacks str go)
(let-values ([(defs interacts) (unpack-submission str)])
(call-with-evaluator lang teachpacks (open-input-text-editor defs) go)))
)