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

rico

Browse Source 
svn: r18733

original commit: fdba97b1c0
This commit is contained in:
Matthew Flatt 2010-04-04 15:08:35 +00:00
parent 9136b6b85d
commit 3832a4ae1a
8 changed files with 362 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/compiler/commands/decompile.ss Normal file
View File

@ -0,0 +1,25 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
compiler/zo-parse
compiler/decompile
scheme/pretty)
(define source-files
(command-line
#:program (short-program+command-name)
#:args source-or-bytecode-file
source-or-bytecode-file))
(for ([zo-file source-files])
(let ([zo-file (path->complete-path zo-file)])
(let-values ([(base name dir?) (split-path zo-file)])
(let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))])
(parameterize ([current-load-relative-directory base]
[print-graph #t])
(pretty-print
(decompile
(call-with-input-file*
(if (file-exists? alt-file) alt-file zo-file)
(lambda (in)
(zo-parse in))))))))))

31
collects/compiler/commands/exe-dir.ss Normal file
View File

@ -0,0 +1,31 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
compiler/distribute)
(define verbose (make-parameter #f))
(define exe-embedded-collects-path (make-parameter #f))
(define exe-dir-add-collects-dirs (make-parameter null))
(define-values (dest-dir source-files)
(command-line
#:program (short-program+command-name)
#:once-each
[("--collects-path") path "Set <path> as main collects for executables"
(exe-embedded-collects-path path)]
#:multi
[("++collects-copy") dir "Add collects in <dir> to directory"
(exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list dir)))]
#:once-each
[("-v") "Verbose mode"
(verbose #t)]
#:args (dest-dir . executable)
(values dest-dir executable)))
(assemble-distribution
dest-dir
source-files
#:collects-path (exe-embedded-collects-path)
#:copy-collects (exe-dir-add-collects-dirs))
(when (verbose)
(printf " [output to \"~a\"]\n" dest-dir))

90
collects/compiler/commands/exe.ss Normal file
View File

@ -0,0 +1,90 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
compiler/private/embed
dynext/file)
(define verbose (make-parameter #f))
(define very-verbose (make-parameter #f))
(define gui (make-parameter #f))
(define 3m (make-parameter #t))
(define exe-output (make-parameter #f))
(define exe-embedded-flags (make-parameter '("-U" "--")))
(define exe-embedded-libraries (make-parameter null))
(define exe-aux (make-parameter null))
(define exe-embedded-collects-path (make-parameter #f))
(define exe-embedded-collects-dest (make-parameter #f))
(define source-file
(command-line
#:program (short-program+command-name)
#:once-each
[("-o") file "Write executable as <file>"
(exe-output file)]
[("--gui") "Geneate GUI executable"
(gui #t)]
[("--collects-path") path "Set <path> as main collects for executable"
(exe-embedded-collects-path path)]
[("--collects-dest") dir "Write collection code to <dir>"
(exe-embedded-collects-dest dir)]
[("--ico") .ico-file "Set Windows icon for executable"
(exe-aux (cons (cons 'ico .ico-file) (exe-aux)))]
[("--icns") .icns-file "Set Mac OS X icon for executable"
(exe-aux (cons (cons 'icns .icns-file) (exe-aux)))]
[("--orig-exe") "Use original executable instead of stub"
(exe-aux (cons (cons 'original-exe? #t) (exe-aux)))]
[("--3m") "Generate using 3m variant"
(3m #t)]
[("--cgc") "Generate using CGC variant"
(3m #f)]
#:multi
[("++lib") lib "Embed <lib> in executable"
(exe-embedded-libraries (append (exe-embedded-libraries) (list lib)))]
[("++exf") flag "Add flag to embed in executable"
(exe-embedded-flags (append (exe-embedded-flags) (list flag)))]
[("--exf") flag "Remove flag to embed in executable"
(exe-embedded-flags (remove flag (exe-embedded-flags)))]
[("--exf-clear") "Clear flags to embed in executable"
(exe-embedded-flags null)]
[("--exf-show") "Show flags to embed in executable"
(printf "Flags to embed: ~s\n" (exe-embedded-flags))]
#:once-each
[("-v") "Verbose mode"
(verbose #t)]
[("--vv") "Very verbose mode"
(verbose #t)
(very-verbose #t)]
#:args (source-file)
source-file))
(let ([dest (mzc:embedding-executable-add-suffix
(or (exe-output)
(extract-base-filename/ss source-file
(string->symbol (short-program+command-name))))
(gui))])
(mzc:create-embedding-executable
dest
#:mred? (gui)
#:variant (if (3m) '3m 'cgc)
#:verbose? (very-verbose)
#:modules (cons `(#%mzc: (file ,source-file))
(map (lambda (l) `(#t (lib ,l)))
(exe-embedded-libraries)))
#:configure-via-first-module? #t
#:literal-expression
(parameterize ([current-namespace (make-base-namespace)])
(compile
`(namespace-require
'',(string->symbol
(format "#%mzc:~a"
(let-values ([(base name dir?)
(split-path source-file)])
(path->bytes (path-replace-suffix name #""))))))))
#:cmdline (exe-embedded-flags)
#:collects-path (exe-embedded-collects-path)
#:collects-dest (exe-embedded-collects-dest)
#:aux (exe-aux))
(when (verbose)
(printf " [output to \"~a\"]\n" dest)))

26
collects/compiler/commands/expand.ss Normal file
View File

@ -0,0 +1,26 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
scheme/pretty)
(define source-files
(command-line
#:program (short-program+command-name)
#:args source-file
source-file))
(for ([src-file source-files])
(let ([src-file (path->complete-path src-file)])
(let-values ([(base name dir?) (split-path src-file)])
(parameterize ([current-load-relative-directory base]
[current-namespace (make-base-namespace)]
[read-accept-reader #t])
(call-with-input-file*
src-file
(lambda (in)
(port-count-lines! in)
(let loop ()
(let ([e (read-syntax src-file in)])
(unless (eof-object? e)
(pretty-print (syntax->datum (expand e)))
(loop))))))))))

10
collects/compiler/commands/info.ss Normal file
View File

@ -0,0 +1,10 @@
#lang setup/infotab
(define rico
'(("make" compiler/commands/make "compile source to bytecode" 100)
("exe" compiler/commands/exe "create executable" 20)
("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10)
("decompile" compiler/commands/decompile "decompile bytecode" #f)
("expand" compiler/commands/expand "macro-expand source" #f)
("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
("c-ext" compiler/commands/c-ext "compile and link C-based extensions" #f)))

79
collects/compiler/commands/make.ss Normal file
View File

@ -0,0 +1,79 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
compiler/cm
"../compiler.ss"
dynext/file)
(define verbose (make-parameter #f))
(define very-verbose (make-parameter #f))
(define disable-inlining (make-parameter #f))
(define disable-deps (make-parameter #f))
(define prefixes (make-parameter null))
(define assume-primitives (make-parameter #t))
(define source-files
(command-line
#:program (short-program+command-name)
#:once-each
[("--disable-inline") "Disable procedure inlining during compilation"
(disable-inlining #t)]
[("--no-deps") "Compile immediate files without updating depdencies"
(disable-deps #t)]
[("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps"
(prefixes (append (prefixes) (list file)))]
[("--no-prim") "Do not assume `scheme' bindings at top level for --no-deps"
(assume-primitives #f)]
[("-v") "Verbose mode"
(verbose #t)]
[("--vv") "Very verbose mode"
(verbose #t)
(very-verbose #t)]
#:args file file))
(if (disable-deps)
;; Just compile one file:
(let ([prefix
`(begin
(require scheme)
,(if (assume-primitives)
'(void)
'(namespace-require/copy 'scheme))
(require compiler/cffi)
,@(map (lambda (s) `(load ,s)) (prefixes))
(void))])
((compile-zos prefix #:verbose? (verbose))
source-files
'auto))
;; Normal make:
(let ([n (make-base-empty-namespace)]
[did-one? #f])
(parameterize ([current-namespace n]
[manager-trace-handler
(lambda (p)
(when (very-verbose)
(printf " ~a\n" p)))]
[manager-compile-notify-handler
(lambda (p)
(set! did-one? #t)
(when (verbose)
(printf " making ~s\n" (path->string p))))])
(for ([file source-files])
(unless (file-exists? file)
(error 'mzc "file does not exist: ~a" file))
(set! did-one? #f)
(let ([name (extract-base-filename/ss file 'mzc)])
(when (verbose)
(printf "\"~a\":\n" file))
(parameterize ([compile-context-preservation-enabled
(disable-inlining)])
(managed-compile-zo file))
(let ([dest (append-zo-suffix
(let-values ([(base name dir?) (split-path file)])
(build-path (if (symbol? base) 'same base)
"compiled" name)))])
(when (verbose)
(printf " [~a \"~a\"]\n"
(if did-one? "output to" "already up-to-date at")
dest))))))))

99
collects/compiler/commands/pack.ss Normal file
View File

@ -0,0 +1,99 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
setup/pack
setup/getinfo
compiler/distribute)
(define verbose (make-parameter #f))
(define collection? (make-parameter #f))
(define default-plt-name "archive")
(define plt-name (make-parameter default-plt-name))
(define plt-files-replace (make-parameter #f))
(define plt-files-plt-relative? (make-parameter #f))
(define plt-files-plt-home-relative? (make-parameter #f))
(define plt-force-install-dir? (make-parameter #f))
(define plt-setup-collections (make-parameter null))
(define plt-include-compiled (make-parameter #f))
(define-values (plt-output source-files)
(command-line
#:program (short-program+command-name)
#:once-each
[("--collect") "Pack collections instead of files and directories"
(collection? #t)]
[("--plt-name") name "Set the printed <name> describing the archive"
(plt-name name)]
[("--replace") "Files in archive replace existing files when unpacked"
(plt-files-replace #t)]
[("--at-plt") "Files/dirs in archive are relative to user's add-ons directory"
(plt-files-plt-relative? #t)]
#:once-any
[("--all-users") "Files/dirs in archive go to PLT installation if writable"
(plt-files-plt-home-relative? #t)]
[("--force-all-users") "Files/dirs forced to PLT installation"
(plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)]
#:once-each
[("--include-compiled") "Include \"compiled\" subdirectories in the archive"
(plt-include-compiled #t)]
#:multi
[("++setup") collect "Setup <collect> after the archive is unpacked"
(plt-setup-collections (append (plt-setup-collections) (list collect)))]
#:once-each
[("-v") "Verbose mode"
(verbose #t)]
#:args (dest-file . file)
(values dest-file file)))
(if (not (collection?))
;; Files and directories
(begin
(for ([fd source-files])
(unless (relative-path? fd)
(error 'mzc
"file/directory is not relative to the current directory: \"~a\""
fd)))
(pack-plt plt-output
(plt-name)
source-files
#:collections (map list (plt-setup-collections))
#:file-mode (if (plt-files-replace) 'file-replace 'file)
#:plt-relative? (or (plt-files-plt-relative?)
(plt-files-plt-home-relative?))
#:at-plt-home? (plt-files-plt-home-relative?)
#:test-plt-dirs (if (or (plt-force-install-dir?)
(not (plt-files-plt-home-relative?)))
#f
'("collects" "doc" "include" "lib"))
#:requires
;; Get current version of mzscheme for require:
(let* ([i (get-info '("mzscheme"))]
[v (and i (i 'version (lambda () #f)))])
(list (list '("mzscheme") v))))
(when (verbose)
(printf " [output to \"~a\"]\n" plt-output)))
;; Collection
(begin
(pack-collections-plt
plt-output
(if (eq? default-plt-name (plt-name)) #f (plt-name))
(map (lambda (sf)
(let loop ([sf sf])
(let ([m (regexp-match "^([^/]*)/(.*)$" sf)])
(if m (cons (cadr m) (loop (caddr m))) (list sf)))))
source-files)
#:replace? (plt-files-replace)
#:extra-setup-collections (map list (plt-setup-collections))
#:file-filter (if (plt-include-compiled)
(lambda (path)
(or (regexp-match #rx#"compiled$" (path->bytes path))
(std-filter path)))
std-filter)
#:at-plt-home? (plt-files-plt-home-relative?)
#:test-plt-collects? (not (plt-force-install-dir?)))
(when (verbose)
(printf " [output to \"~a\"]\n" plt-output))))

3
collects/setup/option-sig.ss
View File

@ -5,7 +5,8 @@
(provide setup-option^)
(define-signature setup-option^
(verbose
(setup-program-name
verbose
make-verbose
compiler-verbose
clean