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

,

Browse Source 
svn: r719
This commit is contained in:
Robby Findler 2005-08-31 12:35:35 +00:00
parent f35acf442c
commit f0707745e6
1 changed files with 28 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/framework/private/encode-decode.ss
View File

@ -1,6 +1,7 @@
(module encode-decode mzscheme (module encode-decode mzscheme
(require (lib "deflate.ss") (require (lib "deflate.ss")
(lib "match.ss")) (lib "match.ss")
(lib "pretty.ss"))
(require-for-syntax (lib "inflate.ss") (require-for-syntax (lib "inflate.ss")
(lib "string.ss")) (lib "string.ss"))
@ -18,13 +19,27 @@
[`(module ,m mzscheme ,@(bodies ...)) [`(module ,m mzscheme ,@(bodies ...))
(call-with-output-file out-filename (call-with-output-file out-filename
(λ (oport) (λ (oport)
(write `(module ,m mzscheme (let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
(require (lib "encode-decode.ss" "framework" "private")) (fprintf oport "(module ~a mzscheme\n" m)
(decode ,(encode-sexp `(begin ,@bodies)))) (fprintf oport " (require (lib \"encode-decode.ss\" \"framework\" \"private\"))\n")
oport)) (fprintf oport " (decode ~a" (car chopped))
(for-each (lambda (chopped)
(fprintf oport "\n ~a" chopped))
(cdr chopped))
(fprintf oport "))\n")))
'truncate 'text)] 'truncate 'text)]
[else (error 'encode-module "cannot parse module")]))))) [else (error 'encode-module "cannot parse module")])))))
(define (chop-up sym)
(let ([chopping-point 50])
(let loop ([str (symbol->string sym)])
(cond
[(<= (string-length str) chopping-point)
(list (string->symbol str))]
[else
(cons (string->symbol (substring str 0 chopping-point))
(loop (substring str chopping-point (string-length str))))]))))
(define (encode-sexp sexp) (define (encode-sexp sexp)
(define (str->sym string) (define (str->sym string)
(string->symbol (string->symbol
@ -81,11 +96,11 @@
(+ 10 (- (char->integer char) (+ 10 (- (char->integer char)
(char->integer #\a)))])) (char->integer #\a)))]))
(datum->syntax-object (define decoded
stx (decode-sexp
(decode-sexp (apply
(apply string-append
string-append (map (λ (x) (symbol->string (syntax-e x)))
(map (λ (x) (symbol->string (syntax-e x))) (syntax->list (syntax (arg ...)))))))
(syntax->list (syntax (arg ...))))))
stx))]))) (datum->syntax-object stx decoded stx))])))