merging in the content from the README

Makefile

@@ -2,6 +2,9 @@
 # 	raco make -v --disable-inline test-analyzer.rkt
 # 	racket test-analyzer.rkt
 
+launcher: whalesong
+	racket make-launcher.rkt
+
 whalesong:
 	raco make -v --disable-inline whalesong.rkt
 
@@ -32,3 +35,8 @@ test-conform:
 	raco make -v --disable-inline tests/test-conform.rkt
 	racket tests/test-conform.rkt
 
+
+
+
+doc:
+	scribble ++xref-in setup/xref load-collections-xref --redirect-main http://docs.racket-lang.org/ --dest generated-docs --dest-name index.html scribblings/manual.scrbl

README

@@ -7,6 +7,17 @@ Danny Yoo (dyoo@cs.wpi.edu)
 ======================================================================
 
 
+See:  http://hashcollision.org/whalesong/index.html for documentation.
+
+The rest of the content in this document will migrate there shortly.
+
+
+======================================================================
+
+
+
+
+
 Prerequisite: Racket 5.1.1.  The majority of the project is written
 Typed Racket, and I highly recommend you use a version of Racket
 that's at least 5.1.1; otherwise, compilation may take an unusual

info.rkt

@@ -0,0 +1,5 @@
+#lang setup/infotab
+
+(define name "Whalesong")
+(define racket-launcher-libraries '("whalesong.rkt"))
+(define racket-launcher-names '("whalesong"))

make-launcher.rkt

@@ -0,0 +1,723 @@
+#lang racket/base
+
+
+;; copy of launcher/launcher since it has a bug.  I'll send a bug patch
+;; upstream.
+
+
+(require scheme/path
+         scheme/file
+         scheme/list
+         scheme/string
+
+         compiler/embed
+         setup/dirs
+         setup/variant
+
+         compiler/private/winutf16)
+
+
+(define current-launcher-variant
+  (make-parameter (system-type 'gc)
+                  (lambda (v)
+                    (unless (memq v '(3m script-3m cgc script-cgc))
+                      (raise-type-error
+                       'current-launcher-variant
+                       "variant symbol"
+                       v))
+                    v)))
+
+(define (variant-available? kind cased-kind-name variant)
+  (cond
+   [(or (eq? 'unix (system-type))
+        (and (eq? 'macosx (system-type))
+             (eq? kind 'mzscheme)))
+    (let ([bin-dir (find-console-bin-dir)])
+      (and bin-dir
+           (file-exists?
+            (build-path bin-dir
+                        (format "~a~a" 
+                                (case kind 
+                                  [(mzscheme) 'racket]
+                                  [(mred) 'gracket])
+                                (variant-suffix variant #f))))))]
+   [(eq? 'macosx (system-type))
+    ;; kind must be mred, because mzscheme case is caught above
+    (directory-exists? (build-path (find-gui-bin-dir)
+                                   (format "~a~a.app"
+                                           cased-kind-name
+                                           (variant-suffix variant #f))))]
+   [(eq? 'windows (system-type))
+    (file-exists?
+     (build-path
+      (if (eq? kind 'mzscheme) (find-console-bin-dir) (find-gui-bin-dir))
+      (format "~a~a.exe" cased-kind-name (variant-suffix variant #t))))]
+   [else (error "unknown system type")]))
+
+(define (available-variants kind)
+  (let* ([cased-kind-name (if (eq? kind 'mzscheme)
+                              "Racket"
+                              "GRacket")]
+         [normal-kind (system-type 'gc)]
+         [alt-kind (if (eq? '3m normal-kind)
+                       'cgc
+                       '3m)]
+         [normal (if (variant-available? kind cased-kind-name normal-kind)
+                     (list normal-kind)
+                     null)]
+         [alt (if (variant-available? kind cased-kind-name alt-kind)
+                  (list alt-kind)
+                  null)]
+         [script (if (and (eq? 'macosx (system-type))
+                          (eq? kind 'mred)
+                          (pair? normal))
+                     (if (eq? normal-kind '3m)
+                         '(script-3m)
+                         '(script-cgc))
+                     null)]
+         [script-alt (if (and (memq alt-kind alt)
+                              (pair? script))
+                         (if (eq? alt-kind '3m)
+                             '(script-3m)
+                             '(script-cgc))
+                         null)])
+    (append normal alt script script-alt)))
+
+(define (available-gracket-variants)
+  (available-variants 'mred))
+(define (available-mred-variants)
+  (available-variants 'mred))
+
+(define (available-racket-variants)
+  (available-variants 'mzscheme))
+(define (available-mzscheme-variants)
+  (available-variants 'mzscheme))
+
+(define (install-template dest kind mz mr)
+  (define src (build-path (collection-path "launcher")
+                          (if (eq? kind 'mzscheme) mz mr)))
+  (when (or (file-exists? dest)
+            (directory-exists? dest)
+            (link-exists? dest))
+    (delete-directory/files dest))
+  (copy-file src dest)
+  ;; Make sure we can write.
+  (file-or-directory-permissions dest
+                                 (bitwise-ior
+                                  (file-or-directory-permissions dest 'bits)
+                                  user-write-bit)))
+
+(define (script-variant? v)
+  (memq v '(script-3m script-cgc)))
+
+(define (add-file-suffix path variant mred?)
+  (let ([s (variant-suffix
+            variant
+            (case (system-type)
+              [(unix) #f]
+              [(windows) #t]
+              [(macosx) (and mred? (not (script-variant? variant)))]))])
+    (if (string=? "" s)
+      path
+      (path-replace-suffix
+       path
+       (string->bytes/utf-8
+        (if (and (eq? 'windows (system-type))
+                 (regexp-match #rx#"[.]exe$" (path->bytes path)))
+          (format "~a.exe" s)
+          s))))))
+
+(define (string-append/spaces f flags)
+  (string-append* (append-map (lambda (x) (list (f x) " ")) flags)))
+
+(define (str-list->sh-str flags)
+  (string-append/spaces
+   (lambda (s)
+     (string-append "'" (regexp-replace* #rx"'" s "'\"'\"'") "'"))
+   flags))
+
+(define (str-list->dos-str flags)
+  (define (trans s)
+    (if (not (regexp-match? #rx"[ \n\t\r\v\"\\]" s))
+      s
+      (list->string
+       (let loop ([l (string->list s)] [slashes '()])
+         (cond [(null? l) '()]
+               [(char-whitespace? (car l))
+                `(,@slashes #\" ,(car l) #\" ,@(loop (cdr l) '()))]
+               [(eq? #\\ (car l))
+                `(#\\ ,@(loop (cdr l) (cons #\\ slashes)))]
+               [(eq? #\" (car l))
+                `(,@slashes #\" #\\ #\" #\" ,@(loop (cdr l) '()))]
+               [else `(,(car l) ,@(loop (cdr l) '()))])))))
+  (string-append/spaces trans flags))
+
+(define one-arg-x-flags '((xa "-display")
+                          (xb "-geometry")
+                          (xc "-bg" "-background")
+                          (xd "-fg" "-foregound")
+                          (xe "-font")
+                          (xf "-name")
+                          (xg "-selectionTimeout")
+                          (xh "-title")
+                          (xi "-xnllanguage")
+                          (xj "-xrm")))
+(define no-arg-x-flags '((xk "-iconic")
+                         (xl "-rv" "-reverse")
+                         (xm "+rv")
+                         (xn "-synchronous")
+                         (xo "-singleInstance")))
+
+(define (skip-x-flags flags)
+  (let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))])
+    (let loop ([f flags])
+      (cond [(null? f) null]
+            [(ormap (xfmem (car f)) one-arg-x-flags)
+             (if (null? (cdr f)) null (loop (cddr f)))]
+            [(ormap (xfmem (car f)) no-arg-x-flags) (loop (cdr f))]
+            [else f]))))
+
+(define (output-x-arg-getter exec args)
+  (let ([or-flags (lambda (l) (string-append* (add-between l " | ")))])
+    (string-append*
+     (append
+      (list "# Find X flags and shift them to the front\n"
+            "findxend() {\n"
+            " oneargflag=''\n"
+            " case \"$1\" in\n")
+      (map
+       (lambda (f)
+         (format (string-append
+                  "  ~a)\n"
+                  "     oneargflag=\"$1\"\n"
+                  "     ~a=\"$2\"\n"
+                  "   ;;\n")
+                 (or-flags (cdr f))
+                 (car f)))
+       one-arg-x-flags)
+      (map
+       (lambda (f)
+         (format "  ~a)\n    ~a=yes\n  ;;\n" (or-flags (cdr f)) (car f)))
+       no-arg-x-flags)
+      (list
+       (format (string-append
+                "  *)\n    ~a~a ~a  ;;\n"
+                " esac\n"
+                " shift\n"
+                " if [ \"$oneargflag\" != '' ] ; then\n"
+                "   if [ \"${1+n}\" != 'n' ] ; then echo $0: missing argument for standard X flag $oneargflag ; exit 1 ; fi\n"
+                "   shift\n"
+                " fi\n"
+                " findxend ${1+\"$@\"}\n"
+                "}\nfindxend ${1+\"$@\"}\n")
+               exec
+               (string-append*
+                (append
+                 (map (lambda (f)
+                        (format " ${~a+\"~a\"} ${~a+\"$~a\"}"
+                                (car f) (cadr f) (car f) (car f)))
+                      one-arg-x-flags)
+                 (map (lambda (f)
+                        (format " ${~a+\"~a\"}" (car f) (cadr f)))
+                      no-arg-x-flags)))
+               args))))))
+
+(define (protect-shell-string s)
+  (regexp-replace*
+   #rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&"))
+
+(define (normalize+explode-path p)
+  (explode-path (normal-case-path (simple-form-path p))))
+
+(define (relativize bindir-explode dest-explode)
+  (let loop ([b bindir-explode] [d dest-explode])
+    (if (and (pair? b) (equal? (car b) (car d)))
+      (loop (cdr b) (cdr d))
+      (let ([p (append (map (lambda (x) 'up) (cdr d)) b)])
+        (if (null? p) #f (apply build-path p))))))
+
+(define (make-relative-path-header dest bindir)
+  ;; rely only on binaries in /usr/bin:/bin
+  (define (has-exe? exe)
+    (or (file-exists? (build-path "/usr/bin" exe))
+        (file-exists? (build-path "/bin" exe))))
+  (let* ([has-readlink?  (and (not (eq? 'macosx (system-type)))
+                              (has-exe? "readlink"))]
+         [dest-explode   (normalize+explode-path dest)]
+         [bindir-explode (normalize+explode-path bindir)])
+    (if (and (has-exe? "dirname") (has-exe? "basename")
+             (or has-readlink? (and (has-exe? "ls") (has-exe? "sed")))
+             (equal? (car dest-explode) (car bindir-explode)))
+        (string-append
+         "# Make this PATH-independent\n"
+         "saveP=\"$PATH\"\n"
+         "PATH=\"/usr/bin:/bin\"\n"
+         "\n"
+         (if has-readlink? ""
+             (string-append
+              "# imitate possibly-missing readlink\n"
+              "readlink() {\n"
+              "  ls -l -- \"$1\" | sed -e \"s/^.* -> //\"\n"
+              "}\n"
+              "\n"))
+         "# Remember current directory\n"
+         "saveD=`pwd`\n"
+         "\n"
+         "# Find absolute path to this script,\n"
+         "# resolving symbolic references to the end\n"
+         "# (changes the current directory):\n"
+         "D=`dirname \"$0\"`\n"
+         "F=`basename \"$0\"`\n"
+         "cd \"$D\"\n"
+         "while test "
+         ;; On solaris, Edward Chrzanowski from Waterloo says that the man
+         ;; page says that -L is not supported, but -h is; on other systems
+         ;; (eg, freebsd) -h is listed as a compatibility feature
+         (if (regexp-match #rx"solaris" (path->string
+                                         (system-library-subpath)))
+             "-h" "-L")
+         " \"$F\"; do\n"
+         "  P=`readlink \"$F\"`\n"
+         "  D=`dirname \"$P\"`\n"
+         "  F=`basename \"$P\"`\n"
+         "  cd \"$D\"\n"
+         "done\n"
+         "D=`pwd`\n"
+         "\n"
+         "# Restore current directory\n"
+         "cd \"$saveD\"\n"
+         "\n"
+         "bindir=\"$D"
+         (let ([s (relativize bindir-explode dest-explode)])
+           (if s (string-append "/" (protect-shell-string s)) ""))
+         "\"\n"
+         "PATH=\"$saveP\"\n")
+        ;; fallback to absolute path header
+        (make-absolute-path-header bindir))))
+
+(define (make-absolute-path-header bindir)
+  (string-append "bindir=\""(protect-shell-string bindir)"\"\n"))
+
+(define (make-unix-launcher kind variant flags dest aux)
+  (install-template dest kind "sh" "sh") ; just for something that's executable
+  (let* ([alt-exe (let ([m (and (eq? kind 'mred)
+                                (script-variant? variant)
+                                (assq 'exe-name aux))])
+                    (and m
+                         (format "~a~a.app/Contents/MacOS/~a~a"
+                                 (cdr m) (variant-suffix variant #t)
+                                 (cdr m) (variant-suffix variant #t))))]
+         [x-flags? (and (eq? kind 'mred)
+                        (eq? (system-type) 'unix)
+                        (not (script-variant? variant)))]
+         [post-flags (cond
+                      [x-flags? (skip-x-flags flags)]
+                      [alt-exe null]
+                      [else flags])]
+         [pre-flags (cond
+                     [(not x-flags?) null]
+                     [else
+                      (let loop ([f flags])
+                        (if (eq? f post-flags)
+                            null
+                            (cons (car f) (loop (cdr f)))))])]
+         [pre-str (str-list->sh-str pre-flags)]
+         [post-str (str-list->sh-str post-flags)]
+         [header (string-append
+                  "#!/bin/sh\n"
+                  "# This script was created by make-"
+                  (symbol->string kind)"-launcher\n")]
+         [dir-finder
+          (let ([bindir (if alt-exe
+                            (find-gui-bin-dir)
+                            (find-console-bin-dir))])
+            (if (let ([a (assq 'relative? aux)])
+                  (and a (cdr a)))
+                (make-relative-path-header dest bindir)
+                (make-absolute-path-header bindir)))]
+         [exec (format
+                "exec \"${bindir}/~a~a\" ~a"
+                (or alt-exe (case kind
+                              [(mred) "gracket"]
+                              [(mzscheme) "racket"]))
+                (if alt-exe "" (variant-suffix variant #f))
+                pre-str)]
+         [args (format
+                "~a~a ${1+\"$@\"}\n"
+                (if alt-exe "" "-N \"$0\" ")
+                post-str)]
+         [assemble-exec (if (and (eq? kind 'mred)
+                                 (not (script-variant? variant))
+                                 (not (null? post-flags)))
+                            output-x-arg-getter
+                            string-append)])
+    (unless (find-console-bin-dir)
+      (error 'make-unix-launcher "unable to locate bin directory"))
+    (with-output-to-file dest
+      #:exists 'truncate
+      (lambda ()
+        (display header)
+        (newline)
+        ;; comments needed to rehack launchers when paths change
+        ;; (see setup/unixstyle-install.ss)
+        (display "# {{{ bindir\n")
+        (display dir-finder)
+        (display "# }}} bindir\n")
+        (newline)
+        (display (assemble-exec exec args))))))
+
+(define (utf-16-regexp b)
+  (byte-regexp (bytes-append (bytes->utf-16-bytes b)
+                             #"[^>]*"
+                             (bytes->utf-16-bytes #">"))))
+
+(define (make-windows-launcher kind variant flags dest aux)
+  (if (not (and (let ([m (assq 'independent? aux)])
+                  (and m (cdr m)))))
+    ;; Normal launcher:
+    (make-embedding-executable
+     dest (eq? kind 'mred) #f null null null flags aux #t variant)
+    ;; Independent launcher (needed for Setup PLT):
+    (begin
+      (install-template dest kind "mzstart.exe" "mrstart.exe")
+      (let ([bstr (bytes->utf-16-bytes
+                   (string->bytes/utf-8 (str-list->dos-str flags)))]
+            [p (open-input-file dest)]
+            [m (utf-16-regexp #"<Command Line: Replace This")]
+            [x (utf-16-regexp #"<Executable Directory: Replace This")]
+            [v (utf-16-regexp #"<Executable Variant: Replace This")])
+        (let* ([exedir (bytes->utf-16-bytes
+                        (bytes-append
+                         (path->bytes (let ([bin-dir (if (eq? kind 'mred)
+                                                       (find-gui-bin-dir)
+                                                       (find-console-bin-dir))])
+                                        (if (let ([m (assq 'relative? aux)])
+                                              (and m (cdr m)))
+                                          (or (relativize (normalize+explode-path bin-dir)
+                                                          (normalize+explode-path dest))
+                                              (build-path 'same))
+                                          bin-dir)))
+                         ;; null wchar marks end of executable directory
+                         #"\0\0"))]
+               [find-it ; Find the magic start
+                (lambda (magic s)
+                  (file-position p 0)
+                  (let ([m (regexp-match-positions magic p)])
+                    (if m
+                      (car m)
+                      (begin
+                        (close-input-port p)
+                        (when (file-exists? dest) (delete-file dest))
+                        (error 'make-windows-launcher
+                               "Couldn't find ~a position in template" s)))))]
+               [exedir-poslen (find-it x "executable path")]
+               [command-poslen (find-it m "command-line")]
+               [variant-poslen (find-it v "variant")]
+               [pos-exedir (car exedir-poslen)]
+               [len-exedir (- (cdr exedir-poslen) (car exedir-poslen))]
+               [pos-command (car command-poslen)]
+               [len-command (- (cdr command-poslen) (car command-poslen))]
+               [pos-variant (car variant-poslen)]
+               [space (char->integer #\space)]
+               [write-magic
+                (lambda (p s pos len)
+                  (file-position p pos)
+                  (display s p)
+                  (display (make-bytes (- len (bytes-length s)) space) p))]
+               [check-len
+                (lambda (len s es)
+                  (when (> (bytes-length s) len)
+                    (when (file-exists? dest) (delete-file dest))
+                    (error
+                     (format
+                      "~a exceeds limit of ~a characters with ~a characters: ~a"
+                      es len (string-length s) s))))])
+          (close-input-port p)
+          (check-len len-exedir exedir "executable home directory")
+          (check-len len-command bstr "collection/file name")
+          (let ([p (open-output-file dest #:exists 'update)])
+            (write-magic p exedir pos-exedir len-exedir)
+            (write-magic p (bytes-append bstr #"\0\0") pos-command len-command)
+            (let* ([suffix (variant-suffix (current-launcher-variant) #t)]
+                   [suffix-bytes
+                    (bytes-append
+                     (list->bytes
+                      (append-map (lambda (c) (list c 0))
+                                  (bytes->list (string->bytes/latin-1 suffix))))
+                     #"\0\0")])
+              (write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes)))
+            (close-output-port p)))))))
+
+;; OS X launcher code:
+
+;; make-macosx-launcher : symbol (listof str) pathname ->
+(define (make-macosx-launcher kind variant flags dest aux)
+  (if (or (eq? kind 'mzscheme) (script-variant? variant))
+      ;; Racket or script launcher is the same as for Unix
+      (make-unix-launcher kind variant flags dest aux)
+      ;; Gracket "launcher" is a stand-alone executable
+      (make-embedding-executable dest (eq? kind 'mred) #f
+                                 null null null
+                                 flags
+                                 aux
+                                 #t
+                                 variant)))
+
+(define (make-macos-launcher kind variant flags dest aux)
+  (install-template dest kind "GoMr" "GoMr")
+  (let* ([p (open-input-file dest)]
+         [m (regexp-match-positions #rx#"<Insert offset here>" p)])
+    ;; fast-forward to the end:
+    (let ([s (make-bytes 4096)])
+      (let loop ()
+        (if (eof-object? (read-bytes! s p)) (file-position p) (loop))))
+    (let ([data-fork-size (file-position p)])
+      (close-input-port p)
+      (let ([p (open-output-file dest #:exists 'update)]
+            [str (str-list->sh-str
+                  (append (if (eq? kind 'mred) null '("-Z")) flags))])
+        (file-position p (caar m))
+        (display (integer->integer-bytes (string-length str) 4 #t #t) p)
+        (display (integer->integer-bytes data-fork-size 4 #t #t) p)
+        (file-position p data-fork-size)
+        (display str p)
+        (close-output-port p)))))
+
+(define (get-maker)
+  (case (system-type)
+    [(unix)    make-unix-launcher]
+    [(windows) make-windows-launcher]
+    [(macos)   make-macos-launcher]
+    [(macosx)  make-macosx-launcher]))
+
+(define (make-gracket-launcher flags dest [aux null])
+  ((get-maker) 'mred (current-launcher-variant) flags dest aux))
+(define (make-mred-launcher flags dest [aux null])
+  ((get-maker) 'mred (current-launcher-variant) (list* "-I" "scheme/gui/init" flags) dest aux))
+
+(define (make-racket-launcher flags dest [aux null])
+  ((get-maker) 'mzscheme (current-launcher-variant) flags dest aux))
+(define (make-mzscheme-launcher flags dest [aux null])
+  ((get-maker) 'mzscheme (current-launcher-variant) (list* "-I" "scheme/init" flags) dest aux))
+
+(define (strip-suffix s)
+  (path-replace-suffix s #""))
+
+(define (build-aux-from-path aux-root)
+  (let ([aux-root (if (string? aux-root) (string->path aux-root) aux-root)])
+    (define (try key suffix)
+      (let ([p (path-replace-suffix aux-root suffix)])
+        (if (file-exists? p) (list (cons key p)) null)))
+    (append
+     (try 'icns #".icns")
+     (try 'ico #".ico")
+     (try 'independent? #".lch")
+     (let ([l (try 'creator #".creator")])
+       (if (null? l)
+         l
+         (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
+           (with-input-from-file (cdar l)
+             (lambda ()
+               (let ([s (read-string 4)])
+                 (if s (list (cons (caar l) s)) null)))))))
+     (let ([l (try 'file-types #".filetypes")])
+       (if (null? l)
+         l
+         (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
+           (with-input-from-file (cdar l)
+             (lambda ()
+               (let*-values ([(d) (read)]
+                             [(local-dir base dir?) (split-path aux-root)]
+                             [(icon-files)
+                              (append-map
+                               (lambda (spec)
+                                 (let ([m (assoc "CFBundleTypeIconFile" spec)])
+                                   (if m
+                                     (list (build-path
+                                            (path->complete-path local-dir)
+                                            (format "~a.icns" (cadr m))))
+                                     null)))
+                               d)])
+                 (list (cons 'file-types d)
+                       (cons 'resource-files
+                             (remove-duplicates icon-files)))))))))
+     (let ([l (try 'file-types #".utiexports")])
+       (if (null? l)
+         l
+         (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
+           (with-input-from-file (cdar l)
+             (lambda ()
+               (let ([d (read)])
+                 (list (cons 'uti-exports d)))))))))))
+
+(define (make-gracket-program-launcher file collection dest)
+  (make-mred-launcher (list "-l-" (string-append collection "/" file))
+                      dest
+                      (build-aux-from-path
+                       (build-path (collection-path collection)
+                                   (strip-suffix file)))))
+(define (make-mred-program-launcher file collection dest)
+  (make-gracket-program-launcher file collection dest))
+
+(define (make-racket-program-launcher file collection dest)
+  (make-mzscheme-launcher (list "-l-" (string-append collection "/" file))
+                          dest
+                          (build-aux-from-path
+                           (build-path (collection-path collection)
+                                       (strip-suffix file)))))
+(define (make-mzscheme-program-launcher file collection dest)
+  (make-racket-program-launcher file collection dest))
+
+(define (unix-sfx file mred?)
+  (string-downcase (regexp-replace* #px"\\s" file "-")))
+
+(define (sfx file mred?)
+  (case (system-type)
+    [(unix) (unix-sfx file mred?)]
+    [(windows)
+     (string-append (if mred? file (unix-sfx file mred?)) ".exe")]
+    [else file]))
+
+(define (program-launcher-path name mred?)
+  (let* ([variant (current-launcher-variant)]
+         [mac-script? (and (eq? (system-type) 'macosx)
+                           (script-variant? variant))])
+    (let ([p (add-file-suffix
+              (build-path
+               (if (or mac-script? (not mred?))
+                   (find-console-bin-dir)
+                   (find-gui-bin-dir))
+               ((if mac-script? unix-sfx sfx) name mred?))
+              variant
+              mred?)])
+      (if (and (eq? (system-type) 'macosx)
+               (not (script-variant? variant)))
+          (path-replace-suffix p #".app")
+          p))))
+
+(define (gracket-program-launcher-path name)
+  (program-launcher-path name #t))
+(define (mred-program-launcher-path name)
+  (gracket-program-launcher-path name))
+
+(define (racket-program-launcher-path name)
+  (case (system-type)
+    [(macosx)
+     (add-file-suffix (build-path (find-console-bin-dir) (unix-sfx name #f))
+                      (current-launcher-variant)
+                      #f)]
+    [else (program-launcher-path name #f)]))
+(define (mzscheme-program-launcher-path name)
+  (racket-program-launcher-path name))
+
+(define (gracket-launcher-is-directory?)
+  #f)
+(define (racket-launcher-is-directory?)
+  #f)
+(define (mred-launcher-is-directory?)
+  #f)
+(define (mzscheme-launcher-is-directory?)
+  #f)
+
+(define (gracket-launcher-is-actually-directory?)
+  (and (eq? 'macosx (system-type))
+       (not (script-variant? (current-launcher-variant)))))
+(define (mred-launcher-is-actually-directory?)
+  (gracket-launcher-is-actually-directory?))
+(define (racket-launcher-is-actually-directory?)
+  #f)
+(define (mzscheme-launcher-is-actually-directory?)
+  #f)
+
+;; Helper:
+(define (put-file-extension+style+filters type)
+  (case type
+    [(windows) (values "exe" null '(("Executable" "*.exe")))]
+    [(macosx) (values "app" '(packages) '(("App" "*.app")))]
+    [else (values #f null null)]))
+
+(define (gracket-launcher-add-suffix path)
+  (embedding-executable-add-suffix path #t))
+(define (mred-launcher-add-suffix path)
+  (gracket-launcher-add-suffix path))
+
+(define (racket-launcher-add-suffix path)
+  (embedding-executable-add-suffix path #f))
+(define (mzscheme-launcher-add-suffix path)
+  (racket-launcher-add-suffix path))
+
+(define (gracket-launcher-put-file-extension+style+filters)
+  (put-file-extension+style+filters
+   (if (and (eq? 'macosx (system-type))
+            (script-variant? (current-launcher-variant)))
+     'unix
+     (system-type))))
+(define (mred-launcher-put-file-extension+style+filters)
+  (gracket-launcher-put-file-extension+style+filters))
+
+(define (racket-launcher-put-file-extension+style+filters)
+  (put-file-extension+style+filters
+   (if (eq? 'macosx (system-type)) 'unix (system-type))))
+(define (mzscheme-launcher-put-file-extension+style+filters)
+  (racket-launcher-put-file-extension+style+filters))
+
+(define (gracket-launcher-up-to-date? dest [aux null])
+  (racket-launcher-up-to-date? dest aux))
+(define (mred-launcher-up-to-date? dest [aux null])
+  (racket-launcher-up-to-date? dest aux))
+(define (mzscheme-launcher-up-to-date? dest [aux null])
+  (racket-launcher-up-to-date? dest aux))
+
+(define (racket-launcher-up-to-date? dest [aux null])
+  (cond
+    ;; When running Setup PLT under Windows, the
+    ;;  launcher process stays running until Racket
+    ;;  completes, which means that it cannot be
+    ;;  overwritten at that time. So we assume
+    ;;  that a Setup-PLT-style independent launcher
+    ;;  is always up-to-date.
+    [(eq? 'windows (system-type))
+     (and (let ([m (assq 'independent? aux)]) (and m (cdr m)))
+          (file-exists? dest))]
+    ;; For any other setting, we could implement
+    ;;  a fancy check, but for now always re-create
+    ;;  launchers.
+    [else #f]))
+
+(define (install-gracket-program-launcher file collection name)
+  (make-gracket-program-launcher file collection
+                                 (gracket-program-launcher-path name)))
+
+(define (install-racket-program-launcher file collection name)
+  (make-racket-program-launcher file collection
+                                (racket-program-launcher-path name)))
+
+(define (install-mred-program-launcher file collection name)
+  (make-mred-program-launcher file collection
+                              (mred-program-launcher-path name)))
+
+(define (install-mzscheme-program-launcher file collection name)
+  (make-mzscheme-program-launcher file collection
+                                  (mzscheme-program-launcher-path name)))
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require racket/runtime-path)
+
+(define-runtime-path whalesong-path "whalesong.rkt")
+
+(make-racket-launcher (list (path->string whalesong-path))
+                      "whalesong"
+                      '())

scribblings/manual.scrbl

@@ -0,0 +1,386 @@
+#lang scribble/manual
+@(require planet/scribble
+          planet/version
+          planet/resolver
+          scribble/eval
+          racket/sandbox
+          (for-label racket/base))
+
+
+
+@;; I may need an evaluator for some small examples.
+@(define my-evaluator
+   (call-with-trusted-sandbox-configuration 
+    (lambda ()
+      (parameterize ([sandbox-output 'string]
+                     [sandbox-error-output 'string])
+        (make-evaluator 'racket)))))
+
+
+
+@title{Whalesong: a Racket to JavaScript compiler}
+@author+email["Danny Yoo" "dyoo@cs.wpi.edu"]
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@; Warning Will Robinson, Warning!
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@centered{@larger{@bold{@italic{Warning: this is work in progress!}}}}
+
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Introduction}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+Whalesong is a compiler from Racket to JavaScript; it takes Racket
+programs and translates them so that they can run stand-alone on a
+user's web browser.  It should allow Racket programs to run with
+little modification, and provide access through the foreign-function
+interface to native JavaScript APIs.  The included runtime library
+also includes a framework to programming the web in functional
+event-driven style.
+
+
+The GitHub source repository to Whalesong can be found at
+@url{https://github.com/dyoo/whalesong}.
+
+
+
+Prerequisites: at least @link["http://racket-lang.org/"]{Racket
+5.1.1}, and a @link["http://www.java.com"]{Java 1.6} SDK.
+      @; (This might be superfluous information, so commented out
+      @;  for the moment...)
+      @;The majority of the project is written
+      @;@link["http://docs.racket-lang.org/ts-guide/index.html"]{Typed
+      @;Racket}, and Racket 5.1.1 and above provides the support necessary to
+      @;compile Whalesong; otherwise, compilation may take an unusual amount
+      @;of time.
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Getting started}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+@subsection{Installing Whalesong}
+
+At the time of this writing, Whalesong hasn't been deployed to
+@link["http://planet.racket-lang.org"]{PLaneT} yet, so getting it
+requires doing a little bit of manual work.  The steps are:
+
+@itemlist[
+@item{Check Whalesong out of Github.}
+@item{Set up the PLaneT development link to your local Whalesong instance.}
+@item{Run @tt{raco setup} over Whalesong to finish the installation}]
+
+We can check it out of the source repository in
+@link["https://github.com/"]{GitHub}; the repository can be checked out by
+using @tt{git clone}.  At the command-line, clone the tree
+with: @verbatim|{ $ git clone git://github.com/dyoo/whalesong.git }|
+This should check the repository in the current directory.
+
+
+
+Next, let's set up a @link["http://docs.racket-lang.org/planet/Developing_Packages_for_PLaneT.html#(part._devlinks)"]{PLaneT development link}.  Make sure you are in the
+parent directory that contains the @filepath{whalesong} repository, and
+then run this on your command line:
+@verbatim|{
+$ planet link dyoo whalesong.plt 1 0 whalesong
+}|
+
+
+Finally, we need to set up Whalesong with @tt{raco setup}.
+Here's how to do this at the command
+line:
+@verbatim|{
+$ raco setup -P dyoo whalesong.plt 1 0
+}|
+This should compile Whalesong, as well as set up the @filepath{whalesong} executable.
+Any time the source code in @filepath{whalesong} changes, we should repeat
+this @tt{raco setup} step again.
+
+
+At this point, you should be able to rung @filepath{whalesong} from the command line.
+@verbatim|{
+$ ./whalesong
+Expected one of the following: [build, get-runtime, get-javascript].                    
+           }|
+and if this does appear, then Whalesong should be installed successfully.
+
+
+
+
+@subsection{Running Whalesong}
+
+Let's try making a simple, standalone executable.  At the moment, the
+program must be written in the base language of @racket[(planet
+dyoo/whalesong)].  This restriction currently prevents arbitrary
+racket/base programs from compiling, and the developers will be working
+to remove this restriction.
+
+
+Write a @filepath{hello.rkt} with the following content
+@filebox["hello.rkt"]{
+@codeblock{
+    #lang planet dyoo/whalesong
+    (display "hello world")
+    (newline)
+}}
+This program can be executed in Racket,
+@verbatim|{
+$ racket hello.rkt 
+hello world
+$
+}|
+and it can also be packaged with @filepath{whalesong}.
+@verbatim|{
+    $ whalesong build hello.rkt
+
+    $ ls -l hello.xhtml
+    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.xhtml
+}|
+Running @tt{whalesong build} on a Racket program will produce a self-contained
+@filepath{.xhtml} file.  If you open this file in your favorite web browser,
+you should see a triumphant message show on screen.
+
+
+We can do something slightly more interesting.  Let's write a Whalesong program
+that accesses the JavaScript DOM.  Call this file @filepath{dom-play.rkt}.
+@filebox["dom-play.rkt"]{
+@codeblock|{
+#lang planet dyoo/whalesong
+
+;; Uses the JavaScript FFI, which provides bindings for:
+;; $ and call
+(require (planet dyoo/whalesong/js))
+
+;; insert-break: -> void
+(define (insert-break)
+  (call ($ "<br/>") "appendTo" body)
+  (void))
+
+;; write-message: any -> void
+(define (write-message msg)
+  (void (call (call (call ($ "<span/>") "text" msg)
+                    "css" "white-space" "pre")
+              "appendTo"
+              body)))
+
+;; Set the background green, and show some content
+;; on the browser.
+(void (call body "css" "background-color" "lightgreen"))
+(void (call ($ "<h1>Hello World</h1>") "appendTo" body))
+(write-message "Hello, this is a test!")
+(insert-break)
+(let loop ([i 0])
+  (cond
+   [(= i 10)
+    (void)]
+   [else
+    (write-message "iteration ") (write-message i)
+    (insert-break)
+    (loop (add1 i))]))
+}|}
+This program uses the @link["http:/jquery.com"]{JQuery} API provided by @racketmodname[(planet dyoo/whalesong/js)],
+as well as the native JavaScript FFI to produce output on the browser.
+If w run Whalesong on this program, and view the resulting @filepath{dom-play.xhtml} in your
+web browser, we should see a pale, green page with some output.
+
+
+
+
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Extended example}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Reference}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(This section should describe the whalesong language.)
+
+
+
+@subsection{The @filepath{whalesong} command-line}
+
+(This section should describe the whalesong launcher and the options
+we can use.)
+
+(We want to add JavaScript compression here as an option.)
+
+(We also need an example that shows how to use the get-javascript and get-runtime
+commands to do something interesting...)
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Internals}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+Skip this section if you're a regular user: this is really notes internal
+to Whalesong development.
+
+(This section should describe the internal details of the runtime,
+including the type map from Racket values to JavaScript values.  It
+should also describe how to write FFI bindings.)
+
+@subsection{Architecture}
+
+The basic idea is to reuse most of the Racket compiler infrastructure.
+We use the underlying Racket compiler to produce bytecode from Racket
+source; it also performs macro expansion and module-level
+optimizations for us.  We parse that bytecode using the
+@racketmodname[compiler/zo-parse] collection to get an AST,
+compile that to an
+intermediate language, and finally assemble JavaScript.
+
+@verbatim|{
+                        AST          IL                     JS
+ parse-bytecode.rkt ----------> compiler.rkt --------> assembler.rkt ------->
+    (todo)
+}|
+
+The IL is intended to be translated straightforwardly.  We currently
+have an assembler to JavaScript, as well as a simulator
+in @filepath{simulator.rkt}.  The simulator allows us to test the compiler in a
+controlled environment.
+
+
+@subsection{parser/parse-bytecode.rkt}
+
+(We try to insulate against changes in the bytecode structure by
+using the version-case library to choose a bytecode parser based on
+the Racket version number.  Add more content here as necessary...)
+
+@subsection{compiler/compiler.rkt}
+
+This translates the AST to the intermediate language.  The compiler has its
+origins in the register compiler in @link[    "http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-35.html#%_sec_5.5"
+]{Structure and Interpretation of
+Computer Programs}  with some significant modifications.
+                  
+                  Since this is a stack machine,
+we don't need any of the register-saving infrastructure in the
+original compiler.  We also need to support slightly different linkage
+structures, since we want to support multiple value contexts.  We're
+trying to generate code that works effectively on a machine like the
+one described in \url{http://plt.eecs.northwestern.edu/racket-machine/}.
+
+
+The intermediate language is defined in @filepath{il-structs.rkt}, and a
+simulator for the IL in @filepath{simulator/simulator.rkt}.  See
+@filepath{tests/test-simulator.rkt} to see the simulator in action, and
+@filepath{tests/test-compiler.rkt} to see how the output of the compiler can be fed
+into the simulator.
+
+The assumed machine is a stack machine with the following atomic
+registers:
+@itemlist[
+    @item{val: value}
+    @item{proc: procedure}
+    @item{argcount: number of arguments}
+]
+and two stack registers:
+@itemlist[
+          @item{env: environment stack}
+          @item{control: control stack}
+]
+
+@subsection{js-assembler/assemble.rkt}
+The intent is to potentially support different back end generators 
+for the IL.  @filepath{js-assembler/assemble.rkt} provides a backend
+for JavaScript.
+
+The JavaScript assembler plays a few tricks to make things like tail
+calls work:
+
+@itemlist[
+          @item{Each basic block is translated to a function taking a MACHINE
+            argument.}
+
+           @item{ Every GOTO becomes a function call.}
+
+           @item{ The head of each basic-blocked function checks to see if we
+     should trampoline
+     (http://en.wikipedia.org/wiki/Trampoline_(computers))}
+
+           @item{We support a limited form of computed jump by assigning an
+     attribute to the function corresponding to a return point.  See
+     the code related to the LinkedLabel structure for details.}
+]
+
+Otherwise, the assembler is fairly straightforward.  It depends on
+library functions defined in @filepath{runtime-src/runtime.js}.  As soon as the compiler
+stabilizes, we will be pulling in the runtime library in Moby Scheme
+into this project.  We are right in the middle of doing this, so expect
+a lot of flux here.
+
+
+The assembled output distinguishes between Primitives and Closures.
+Primitives are only allowed to return single values back, and are not
+allowed to do any higher-order procedure calls.  Closures, on the
+other hand, have full access to the machine, but they are responsible
+for calling the continuation and popping off their arguments when
+they're finished.
+
+
+@subsection{Tests}
+
+The test suite in @filepath{tests/test-all.rkt} runs the test suite.
+You'll need to
+run this on a system with a web browser, as the suite will evaluate
+JavaScript and make sure it is producing values.  A bridge module
+in @filepath{tests/browser-evaluate.rkt} brings up a temporary web server
+that allows us
+to pass values between Racket and the JavaScript evaluator on the
+browser for testing output.
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Incomplete features}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(This section should describe what needs to get done next.)
+
+(I should catalog the bug list in GitHub, as well as the feature list,
+so I have a better idea of what's needed to complete the project.)
+
+
+(We also need a list of the primitives missing that prevent us from
+running @racketmodname[racket/base]; it's actually a short list that
+I'll be attacking once things stabilize.)
+
+
+
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@section{Acknowledgements}
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@;; shriram, kathi, emmanuel, everyone who helped with moby and wescheme
+@;;
+@;; also need to list out all the external libraries we're using
+@;; and the license.
+
+
+Whalesong uses code and utilities from the following external projects:
+@itemlist[
+@item{   jshashtable (@url{http://www.timdown.co.uk/jshashtable/})}
+@item{   js-numbers (@url{http://github.com/dyoo/js-numbers/})}
+@item{   JSON (@url{http://www.json.org/js.html})}
+@item{   jquery (@url{http://jquery.com/})}
+@item{   Google Closure Compiler (@url{http://code.google.com/p/closure-compiler/})}
+]