├── README.md ├── info.rkt └── whalesong ├── Makefile ├── README ├── base └── lang │ └── reader.rkt ├── bf ├── lang │ └── reader.rkt ├── language.rkt ├── parser.rkt └── semantics.rkt ├── bump-version.rkt ├── call-with-timeout.rkt ├── compiler ├── analyzer-structs.rkt ├── analyzer.rkt ├── arity-structs.rkt ├── bootstrapped-primitives.rkt ├── compiler-helper.rkt ├── compiler-structs.rkt ├── compiler.rkt ├── expression-structs.rkt ├── il-structs.rkt ├── kernel-primitives.rkt ├── lexical-env.rkt ├── lexical-structs.rkt └── optimize-il.rkt ├── cs019 ├── cs019-pre-base.rkt ├── cs019.rkt ├── deviations.txt ├── firstorder.rkt ├── get-cs019-names.rkt ├── info.rkt ├── lang │ └── reader.rkt ├── lists.rkt ├── private │ ├── info.rkt │ └── sigs-patched.rkt ├── rewrite-error-message.rkt ├── teach-runtime.rkt ├── teach.rkt └── teachhelp.rkt ├── examples ├── alert.rkt ├── cs019 │ ├── hello.rkt │ ├── tick-tock │ │ ├── index.html │ │ └── tick-tock.rkt │ └── where-am-i │ │ ├── index.html │ │ └── where-am-i.rkt ├── dom-play.rkt ├── drag-and-drop │ ├── drag-and-drop-1.rkt │ ├── drag-and-drop-2.rkt │ ├── style.css │ └── view.html ├── eli-number-puzzle.rkt ├── expanding-circle.rkt ├── fact.rkt ├── google-maps │ ├── maps.rkt │ └── test-maps.rkt ├── hello-bf.rkt ├── hello-css.css ├── hello-css.rkt ├── hello-kr.rkt ├── hello.rkt ├── image-library-example.rkt ├── images │ └── humpback.jpg ├── iron-puzzle │ ├── iron-puzzle.png │ └── iron-puzzle.rkt ├── js-get-message │ ├── js-get-message-child.rkt │ └── js-get-message-parent.html ├── list-length.rkt ├── logo.rkt ├── mathjax-script.js ├── mathjax.rkt ├── mouse.rkt ├── pacman.rkt ├── rain-world-program.rkt ├── raphael-demo.rkt ├── read-bytes.rkt ├── select.rkt ├── shuffling.rkt ├── sierpinski-carpet.rkt ├── snip.rkt ├── using-resources.rkt ├── whale.rkt └── window-size.rkt ├── expand-out-images.rkt ├── experiments ├── gauss │ ├── foo2.html │ ├── foo2.js │ ├── gauss.c │ ├── gauss.html │ ├── gauss.js │ ├── gauss.rkt │ └── notes.txt ├── primitives-for-racket-base.txt ├── racket-expander.rkt ├── test.xhtml └── trying-to-compile-hello-world.txt ├── generate-c-star-d.rkt ├── get-module-bytecode.rkt ├── helpers.rkt ├── ie-compat ├── canvas.text.js ├── excanvas.js └── optimer-normal-normal.js ├── image.rkt ├── image ├── main.rkt └── private │ ├── color.rkt │ ├── colordb.js │ ├── js-impl.js │ ├── kernel.js │ ├── main.rkt │ └── racket-impl.rkt ├── info.rkt ├── js-assembler ├── assemble-expression.rkt ├── assemble-helpers.rkt ├── assemble-open-coded.rkt ├── assemble-perform-statement.rkt ├── assemble-structs.rkt ├── assemble.rkt ├── cache.rkt ├── check-valid-module-source.rkt ├── collect-jump-targets.rkt ├── find-primitive-implemented.rkt ├── fracture.rkt ├── get-js-vm-implemented-primitives.rkt ├── get-runtime.rkt ├── hash-cache.rkt ├── module-knowledge.rkt ├── package.rkt ├── quote-cdata.rkt └── runtime-src │ ├── base64.js │ ├── baselib-arity.js │ ├── baselib-boxes.js │ ├── baselib-bytes.js │ ├── baselib-chars.js │ ├── baselib-check.js │ ├── baselib-constants.js │ ├── baselib-contmarks.js │ ├── baselib-dict.js │ ├── baselib-equality.js │ ├── baselib-exceptions.js │ ├── baselib-format.js │ ├── baselib-frames.js │ ├── baselib-functions.js │ ├── baselib-hashes.js │ ├── baselib-inspectors.js │ ├── baselib-keywords.js │ ├── baselib-lists.js │ ├── baselib-loadscript.js │ ├── baselib-modules.js │ ├── baselib-numbers.js │ ├── baselib-paramz.js │ ├── baselib-paths.js │ ├── baselib-placeholders.js │ ├── baselib-ports.js │ ├── baselib-primitives.js │ ├── baselib-readergraph.js │ ├── baselib-regexps.js │ ├── baselib-srclocs.js │ ├── baselib-strings.js │ ├── baselib-structs.js │ ├── baselib-symbols.js │ ├── baselib-unionfind.js │ ├── baselib-vectors.js │ ├── baselib.js │ ├── hashes-footer.js │ ├── hashes-header.js │ ├── jquery-protect-footer.js │ ├── jquery-protect-header.js │ ├── jquery.js │ ├── js-numbers.js │ ├── jshashtable-2.1_src.js │ ├── json2.js │ ├── llrbtree.js │ ├── read.js │ ├── runtime.js │ └── top.js ├── js.rkt ├── js ├── js-impl.js ├── main.rkt ├── racket-impl.rkt ├── world.rkt └── world │ ├── geo.rkt │ ├── js-impl.js │ ├── main.rkt │ ├── racket-impl.rkt │ ├── test-geo.rkt │ ├── test.rkt │ └── world-event-handler.rkt ├── korean └── lang │ └── reader.rkt ├── lang ├── base.rkt ├── base │ └── reader.rkt ├── bool.rkt ├── check-expect │ └── check-expect.rkt ├── js │ ├── js.rkt │ ├── query.rkt │ └── record.rkt ├── kernel.rkt ├── korean.rkt ├── list.rkt ├── posn.rkt ├── private │ ├── call-ec.rkt │ ├── hash.rkt │ ├── info.rkt │ ├── list.rkt │ ├── map.rkt │ ├── qq-and-or.rkt │ ├── shared-body.rkt │ ├── shared.rkt │ ├── stx.rkt │ ├── traced-app.rkt │ └── with-handlers.rkt ├── reader.rkt ├── unsafe │ ├── js-impl.js │ ├── ops.rkt │ └── racket-impl.rkt └── whalesong.rkt ├── language-namespace.rkt ├── logger.rkt ├── make-launcher.rkt ├── make-planet-archive.sh ├── make ├── get-dependencies.rkt ├── make-structs.rkt └── make.rkt ├── notes ├── NOTES ├── phonegap-stuff.txt └── racket-days-abstract.txt ├── parameters.rkt ├── parser ├── baby-parser.rkt ├── modprovide.rkt ├── parse-bytecode-5.1.1.rkt ├── parse-bytecode-5.1.2.rkt ├── parse-bytecode-5.2.1.rkt ├── parse-bytecode-5.2.rkt ├── parse-bytecode-5.3.3.7.rkt ├── parse-bytecode-5.3.rkt ├── parse-bytecode.rkt ├── path-rewriter.rkt └── where-is-collects.rkt ├── private ├── command.rkt └── prefix-dispatcher.rkt ├── promise.rkt ├── repl-prototype ├── README ├── htdocs │ ├── break.png │ ├── easyXDM-min.js │ ├── index.html │ ├── index.js │ ├── jquery-1.9.1.min.js │ ├── json2-min.js │ ├── repl.js │ ├── rpc.html │ ├── rpc.js │ ├── tests-base.js │ ├── tests.html │ ├── tests.js │ ├── torture-tests.html │ └── torture-tests.js ├── modularize-input-port.rkt ├── repl-compile.rkt ├── sandboxed-server.rkt ├── server.rkt └── write-runtime.rkt ├── resource.rkt ├── resource ├── coerse-content-bytes.rkt ├── compile-time.rkt ├── js-impl.js ├── main.rkt ├── munge-path.rkt ├── query.rkt ├── racket-impl.rkt ├── record.rkt ├── runtime.rkt ├── specialize │ ├── impl.rkt │ ├── js-impl.js │ └── racket-impl.rkt └── structs.rkt ├── sandbox ├── cloth-simulation.rkt ├── monty-hall │ ├── index.html │ ├── monty-hall.rkt │ └── style.css ├── sample-run.rkt ├── test-storage.rkt └── todo-storage │ ├── index.html │ └── todo.rkt ├── scribblings ├── cs019.scrbl ├── internals.scrbl ├── manual.scrbl └── scribble-helpers.rkt ├── sets.rkt ├── simply-scheme ├── lang │ └── reader.rkt └── semantics.rkt ├── storage.rkt ├── storage └── storage.rkt ├── tests ├── browser-harness.rkt ├── clipart-test │ ├── clipart.rkt │ └── dog.jpg ├── coersing │ ├── Makefile │ ├── fact.rkt │ └── index.html ├── module-test │ ├── m1.rkt │ └── m2.rkt ├── more-tests │ ├── basics-cs019.expected │ ├── basics-cs019.rkt │ ├── booleans-cs019.appcache │ ├── booleans-cs019.expected │ ├── booleans-cs019.html │ ├── booleans-cs019.rkt │ ├── booleans.expected │ ├── booleans.rkt │ ├── canvas.text.js │ ├── chars.expected │ ├── chars.rkt │ ├── checking-cs019.expected │ ├── checking-cs019.rkt │ ├── checking.expected │ ├── checking.rkt │ ├── colors.expected │ ├── colors.rkt │ ├── conform.expected │ ├── conform.rkt │ ├── cont-marks-1.expected │ ├── cont-marks-1.rkt │ ├── cont-marks-2.expected │ ├── cont-marks-2.rkt │ ├── divide-by-zero-with-handlers.expected │ ├── divide-by-zero-with-handlers.rkt │ ├── dots-should-be-syntax-error.rkt │ ├── earley.expected │ ├── earley.rkt │ ├── excanvas.js │ ├── exn-1.expected │ ├── exn-1.rkt │ ├── exn-2.expected │ ├── exn-2.rkt │ ├── exn-3.expected │ ├── exn-3.rkt │ ├── fact.expected │ ├── fact.rkt │ ├── fft.expected │ ├── fft.rkt │ ├── fringe.expected │ ├── fringe.rkt │ ├── gauss-sum-with-prompts.expected │ ├── gauss-sum-with-prompts.rkt │ ├── graphs.expected │ ├── graphs.rkt │ ├── hash-code.expected │ ├── hash-code.rkt │ ├── hashes.expected │ ├── hashes.rkt │ ├── hello-bf.expected │ ├── hello-bf.rkt │ ├── hello.expected │ ├── hello.rkt │ ├── images.expected │ ├── images.rkt │ ├── isolating-bug.expected │ ├── isolating-bug.rkt │ ├── js-binding.expected │ ├── js-binding.rkt │ ├── lists-cs019.expected │ ├── lists-cs019.rkt │ ├── lists.expected │ ├── lists.rkt │ ├── man-vs-boy.expected │ ├── man-vs-boy.rkt │ ├── map.expected │ ├── map.rkt │ ├── module-scoping-helper.rkt │ ├── module-scoping.expected │ ├── module-scoping.rkt │ ├── nestedloop.expected │ ├── nestedloop.rkt │ ├── nqueens.rkt │ ├── nucleic2.expected │ ├── nucleic2.rkt │ ├── numbers.expected │ ├── numbers.rkt │ ├── optimer-normal-normal.js │ ├── printing.expected │ ├── printing.rkt │ ├── quasi.expected │ ├── quasi.rkt │ ├── ramanujan-pi.expected │ ├── ramanujan-pi.rkt │ ├── scheme-whalesong.expected │ ├── scheme-whalesong.rkt │ ├── sharing-cs019.expected │ ├── sharing-cs019.rkt │ ├── sharing.expected │ ├── sharing.rkt │ ├── sigs-cs019.expected │ ├── sigs-cs019.rkt │ ├── simple-apply.expected │ ├── simple-apply.rkt │ ├── simple-functions.expected │ ├── simple-functions.rkt │ ├── simple-loop.expected │ ├── simple-loop.rkt │ ├── simple-structs.expected │ ├── simple-structs.rkt │ ├── simple.expected │ ├── simple.rkt │ ├── sk-generator-2.expected │ ├── sk-generator-2.rkt │ ├── sk-generator.expected │ ├── sk-generator.rkt │ ├── string-tests.expected │ ├── string-tests.rkt │ ├── view.expected │ ├── view.rkt │ ├── weird-cc.expected │ └── weird-cc.rkt ├── older-tests │ ├── all-tests.rkt │ ├── benchmarks │ │ ├── conform.rkt │ │ ├── do-measures.rkt │ │ ├── graphs.rkt │ │ ├── nboyer.rkt │ │ ├── nfa.rkt │ │ ├── nucleic2.rkt │ │ ├── run-benchmark.rkt │ │ ├── run-do-measures.rkt │ │ ├── run-nboyer.rkt │ │ ├── sboyer.rkt │ │ └── tak.rkt │ ├── check-coverage.rkt │ ├── moby-programs │ │ ├── 42.rkt │ │ ├── all-tests.rkt │ │ ├── and-or.rkt │ │ ├── apply.rkt │ │ ├── arity.rkt │ │ ├── atan.rkt │ │ ├── begin.rkt │ │ ├── case-lambda.rkt │ │ ├── check-error.rkt │ │ ├── compose.rkt │ │ ├── continuation-marks.rkt │ │ ├── continuation-prompts-2.rkt │ │ ├── continuation-prompts-3.rkt │ │ ├── continuation-prompts.rkt │ │ ├── cycles.rkt │ │ ├── define-struct.rkt │ │ ├── display-and-write.rkt │ │ ├── double-client.rkt │ │ ├── double.js │ │ ├── double.rkt │ │ ├── eof.rkt │ │ ├── exercise-control.rkt │ │ ├── exn.rkt │ │ ├── falling-ball.rkt │ │ ├── ffi-2.rkt │ │ ├── ffi.rkt │ │ ├── for-each.rkt │ │ ├── identity.rkt │ │ ├── image-equality.rkt │ │ ├── images.rkt │ │ ├── js-big-bang-timer.rkt │ │ ├── js-input.rkt │ │ ├── jsworld-effects.rkt │ │ ├── jsworld.rkt │ │ ├── letrec.rkt │ │ ├── list.rkt │ │ ├── local.rkt │ │ ├── location.rkt │ │ ├── math.rkt │ │ ├── misc.rkt │ │ ├── more-jsworld.ss │ │ ├── permissions.rkt │ │ ├── quasiquote.rkt │ │ ├── raise.rkt │ │ ├── random.rkt │ │ ├── recur.rkt │ │ ├── repeating-decimals.rkt │ │ ├── require.rkt │ │ ├── required-2.rkt │ │ ├── required-3.rkt │ │ ├── required-4.rkt │ │ ├── required-5.rkt │ │ ├── required.rkt │ │ ├── rotate.rkt │ │ ├── run-all-tests.rkt │ │ ├── seconds.rkt │ │ ├── setbang.rkt │ │ ├── sleep.rkt │ │ ├── struct.rkt │ │ ├── values.rkt │ │ ├── vararity.rkt │ │ ├── vector.rkt │ │ ├── when-unless.rkt │ │ ├── with-handlers-1.rkt │ │ └── with-handlers-2.rkt │ ├── mz-tests │ │ ├── all-tests.rkt │ │ ├── basic.rkt │ │ ├── list.rkt │ │ ├── missing-features.txt │ │ ├── number.rkt │ │ ├── numstrs.rkt │ │ ├── run-all-tests.rkt │ │ ├── test-files-notes.txt │ │ └── testing.rkt │ ├── require-test │ │ ├── m.rkt │ │ ├── m1.rkt │ │ ├── m2.rkt │ │ ├── m3.rkt │ │ └── test.rkt │ ├── run-all-tests.rkt │ └── unit-tests │ │ ├── browser │ │ ├── build-tests │ │ └── webTest.html │ │ ├── run-tests │ │ ├── struct-tests.js │ │ └── tests.js ├── run-more-tests.rkt ├── test-all.rkt ├── test-assemble.rkt ├── test-browser-evaluate.rkt ├── test-compiler-2.rkt ├── test-compiler.rkt ├── test-conform.rkt ├── test-earley.rkt ├── test-get-dependencies.rkt ├── test-helpers.rkt ├── test-package.rkt ├── test-parse-bytecode-on-collects.rkt ├── test-parse-bytecode.rkt ├── test-parse.rkt └── test-simulator.rkt ├── tool ├── button-with-alternatives.rkt └── tool-ui.rkt ├── type-helpers.rkt ├── union-find.rkt ├── version-case └── version-case.rkt ├── version.rkt ├── web-world.rkt ├── web-world ├── DESIGN ├── event.rkt ├── examples │ ├── attr-animation │ │ ├── attr-animation.rkt │ │ ├── index.html │ │ └── style.css │ ├── boid │ │ ├── boid.rkt │ │ └── index.html │ ├── color-buttons │ │ ├── color-buttons.rkt │ │ └── view.html │ ├── dwarves-with-remove │ │ ├── dwarves-with-remove.rkt │ │ └── index.html │ ├── dwarves │ │ ├── dwarves.rkt │ │ └── index.html │ ├── field │ │ ├── field.rkt │ │ └── index.html │ ├── field2 │ │ ├── field2.rkt │ │ └── index.html │ ├── forward-backward │ │ ├── forward-backward.rkt │ │ └── index.html │ ├── hello │ │ ├── hello.rkt │ │ ├── index.html │ │ └── style.css │ ├── hello2 │ │ └── hello2.rkt │ ├── hot-cross-buns │ │ ├── hot-cross-buns.rkt │ │ └── index.html │ ├── phases │ │ ├── index1.html │ │ ├── index2.html │ │ └── phases.rkt │ ├── redirected │ │ ├── index.html │ │ └── redirected.rkt │ ├── tick-tock-2 │ │ └── tick-tock-2.rkt │ ├── tick-tock │ │ ├── index.html │ │ └── tick-tock.rkt │ ├── todo │ │ ├── index.html │ │ └── todo.rkt │ └── where-am-i │ │ ├── index.html │ │ └── where-am-i.rkt ├── helpers.rkt ├── impl.rkt ├── info.rkt ├── js-impl.js ├── js-tree-cursor.js ├── main.rkt └── racket-impl.rkt ├── wescheme └── lang │ ├── reader.rkt │ └── semantics.rkt ├── whalesong-cmd.rkt ├── whalesong-gui.rkt ├── whalesong-helpers.rkt ├── whalesong.rkt ├── world.rkt └── world ├── info.rkt ├── js-impl.js ├── kernel.js ├── main.rkt ├── racket-impl.rkt └── raw-jsworld.js /README.md: -------------------------------------------------------------------------------- 1 | whalesong 2 | ========= 3 | 4 | Whalesong: Racket to JavaScript compiler 5 | 6 | Danny here: unfortunately, I am unable to do much development on 7 | Whalesong these days, so my source tree has bit-rotted and not 8 | followed changes to recent changes to Racket. My apologies! 9 | 10 | You may find better results with the fork at: 11 | [https://github.com/soegaard/whalesong](https://github.com/soegaard/whalesong). 12 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | (define collection 'multi) 3 | -------------------------------------------------------------------------------- /whalesong/Makefile: -------------------------------------------------------------------------------- 1 | all: build 2 | 3 | build: planet-link launcher setup 4 | 5 | bump-version: 6 | racket bump-version.rkt 7 | 8 | launcher: 9 | racket make-launcher.rkt 10 | 11 | test: test-more 12 | 13 | test-all: test 14 | 15 | 16 | ## TODO: fix the tests harness in tests/test-all. I have to remove references 17 | ## to deleted files. 18 | # test-analyzer: 19 | # raco make -v --disable-inline test-analyzer.rkt 20 | # racket test-analyzer.rkt 21 | # test-all: 22 | # racket tests/test-all.rkt 23 | # test-browser-evaluate: 24 | # racket tests/test-browser-evaluate.rkt 25 | # test-compiler: 26 | # racket tests/test-compiler.rkt 27 | # test-parse-bytecode-on-collects: 28 | # racket tests/test-parse-bytecode-on-collects.rkt 29 | # test-earley: 30 | # racket tests/test-earley.rkt 31 | # test-conform: 32 | # racket tests/test-conform.rkt 33 | 34 | test-more: bump-version build 35 | racket tests/run-more-tests.rkt 36 | 37 | doc: 38 | 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 39 | 40 | 41 | cs019-doc: 42 | scribble ++xref-in setup/xref load-collections-xref --redirect-main http://docs.racket-lang.org/ --dest generated-docs scribblings/cs019.scrbl 43 | 44 | 45 | 46 | setup: 47 | 48 | raco setup --no-docs -P dyoo whalesong.plt 1 19 49 | 50 | 51 | planet-link: 52 | raco planet link dyoo whalesong.plt 1 19 . 53 | -------------------------------------------------------------------------------- /whalesong/base/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | 3 | ;; http://docs.racket-lang.org/planet/hash-lang-planet.html 4 | 5 | #:language (lambda (ip) 6 | `(file ,(path->string base-lang-path))) 7 | 8 | (require racket/runtime-path) 9 | (define-runtime-path base-lang-path "../../lang/base.rkt") 10 | -------------------------------------------------------------------------------- /whalesong/bf/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | #:language (lambda () 'whalesong/bf/language) 3 | #:read my-read 4 | #:read-syntax my-read-syntax 5 | #:info my-get-info 6 | (require "../parser.rkt") 7 | 8 | (define (my-read in) 9 | (syntax->datum (my-read-syntax #f in))) 10 | 11 | (define (my-read-syntax src in) 12 | (parse-expr src in)) 13 | 14 | 15 | 16 | ;; Extension: we'd like to cooperate with DrRacket and tell 17 | ;; it to use the default, textual lexer and color scheme when 18 | ;; editing bf programs. 19 | ;; 20 | ;; See: http://docs.racket-lang.org/guide/language-get-info.html 21 | ;; for more details, as well as the documentation in 22 | ;; syntax/module-reader. 23 | (define (my-get-info key default default-filter) 24 | (case key 25 | [(color-lexer) 26 | (dynamic-require 'syntax-color/default-lexer 27 | 'default-lexer)] 28 | [else 29 | (default-filter key default)])) 30 | 31 | -------------------------------------------------------------------------------- /whalesong/bump-version.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/runtime-path 4 | racket/port 5 | racket/list) 6 | 7 | (define-runtime-path version.rkt "version.rkt") 8 | 9 | (define version-text (call-with-input-file version.rkt port->string)) 10 | 11 | (define revised-text (regexp-replace #px"\\.(\\d+)" 12 | version-text 13 | (lambda (whole sub) 14 | (string-append 15 | "." 16 | (number->string 17 | (add1 (string->number sub))))))) 18 | 19 | (call-with-output-file version.rkt (lambda (op) (display revised-text op)) 20 | #:exists 'replace) -------------------------------------------------------------------------------- /whalesong/compiler/analyzer-structs.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | 4 | (require "arity-structs.rkt" 5 | "expression-structs.rkt" 6 | "lexical-structs.rkt" 7 | "kernel-primitives.rkt" 8 | "il-structs.rkt") 9 | 10 | 11 | (provide (all-defined-out)) 12 | 13 | 14 | ;; Static knowledge about an expression. 15 | ;; 16 | ;; We try to keep at compile time a mapping from environment positions to 17 | ;; statically known things, to generate better code. 18 | 19 | 20 | (define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) 21 | 22 | (define-type CompileTimeEnvironmentEntry 23 | (U '? ;; no knowledge 24 | Prefix ;; placeholder: necessary since the toplevel lives in the environment too 25 | StaticallyKnownLam ;; The value is a known lam 26 | ModuleVariable ;; The value is a variable from a module 27 | PrimitiveKernelValue 28 | Const 29 | )) 30 | 31 | 32 | (define-struct: StaticallyKnownLam ([name : (U Symbol LamPositionalName)] 33 | [entry-point : Symbol] 34 | [arity : Arity]) #:transparent) 35 | 36 | 37 | 38 | 39 | 40 | (define-struct: Analysis ([ht : (HashTable Expression CompileTimeEnvironmentEntry)])) 41 | 42 | 43 | (: empty-analysis (-> Analysis)) 44 | (define (empty-analysis) 45 | (make-Analysis (make-hash))) -------------------------------------------------------------------------------- /whalesong/compiler/arity-structs.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (provide (all-defined-out)) 4 | 5 | ;; Arity 6 | (define-type Arity (U AtomicArity (Listof (U AtomicArity)))) 7 | (define-type AtomicArity (U Natural ArityAtLeast)) 8 | (define-struct: ArityAtLeast ([value : Natural]) 9 | #:transparent) 10 | (define-predicate AtomicArity? AtomicArity) 11 | (define-predicate listof-atomic-arity? (Listof AtomicArity)) 12 | -------------------------------------------------------------------------------- /whalesong/compiler/compiler-helper.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide ensure-const-value) 4 | 5 | (define (ensure-const-value x) 6 | (cond 7 | [(symbol? x) 8 | x] 9 | [(boolean? x) 10 | x] 11 | [(string? x) 12 | x] 13 | [(number? x) 14 | x] 15 | [(void? x) 16 | x] 17 | [(null? x) 18 | x] 19 | [(char? x) 20 | x] 21 | [(bytes? x) 22 | x] 23 | [(path? x) 24 | x] 25 | [(pair? x) 26 | (begin (ensure-const-value (car x)) 27 | (ensure-const-value (cdr x)) 28 | x)] 29 | [(vector? x) 30 | (begin (for-each ensure-const-value (vector->list x))) 31 | x] 32 | [(box? x) 33 | (ensure-const-value (unbox x)) 34 | x] 35 | [else 36 | (error 'ensure-const-value "Not a const value: ~s\n" x)])) 37 | 38 | -------------------------------------------------------------------------------- /whalesong/cs019/cs019-pre-base.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | 3 | 4 | (require (for-syntax "teach.rkt") 5 | (for-syntax racket/base)) 6 | 7 | ;; FIXME: there's something wrong with the compiler: it's not picking 8 | ;; up that teach-runtime is a dependency. 9 | (require "teach-runtime.rkt") 10 | 11 | (provide cs019-lambda 12 | cs019-define 13 | cs019-when 14 | cs019-unless 15 | cs019-set! 16 | cs019-case 17 | cs019-local 18 | cs019-dots) 19 | 20 | (define-syntax cs019-define advanced-define/proc) 21 | (define-syntax cs019-lambda advanced-lambda/proc) 22 | (define-syntaxes (cs019-when cs019-unless) (values advanced-when/proc advanced-unless/proc)) 23 | (define-syntax cs019-set! advanced-set!/proc) 24 | (define-syntax cs019-case advanced-case/proc) 25 | (define-syntax cs019-local intermediate-local/proc) 26 | (define-syntax cs019-dots beginner-dots/proc) 27 | -------------------------------------------------------------------------------- /whalesong/cs019/firstorder.rkt: -------------------------------------------------------------------------------- 1 | (module firstorder mzscheme 2 | 3 | (provide make-first-order 4 | first-order->higher-order) 5 | 6 | (define-values (struct:fo make-first-order fo? fo-get fo-set!) 7 | (make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0)) 8 | 9 | (define fo-proc-id (make-struct-field-accessor fo-get 1)) 10 | 11 | (define (first-order->higher-order id) 12 | (let ([v (syntax-local-value id (lambda () #f))]) 13 | (if (or (fo? v) 14 | (and (set!-transformer? v) 15 | (fo? (set!-transformer-procedure v)))) 16 | (syntax-property 17 | (syntax-local-introduce 18 | (fo-proc-id (if (fo? v) v (set!-transformer-procedure v)))) 19 | 'disappeared-use 20 | (syntax-local-introduce id)) 21 | id)))) 22 | 23 | 24 | -------------------------------------------------------------------------------- /whalesong/cs019/get-cs019-names.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Grabs all the names exported by the real cs019 language, so we can 4 | ;; compare and see what names are missing from our implementation. 5 | (require racket/set) 6 | 7 | (provide cs019-names 8 | whalesong-cs019-names 9 | missing-cs019-names) 10 | 11 | 12 | (define-namespace-anchor anchor) 13 | (define ns (namespace-anchor->namespace anchor)) 14 | 15 | 16 | (require (prefix-in cs019: (planet cs019/cs019/cs019))) 17 | (define cs019-names 18 | (for/set ([name (namespace-mapped-symbols ns)] 19 | #:when (regexp-match #rx"^cs019:" (symbol->string name))) 20 | (string->symbol 21 | (substring (symbol->string name) (string-length "cs019:"))))) 22 | 23 | 24 | (require (prefix-in whalesong-cs019: "cs019.rkt")) 25 | (define whalesong-cs019-names 26 | (for/set ([name (namespace-mapped-symbols ns)] 27 | #:when (regexp-match #rx"^whalesong-cs019:" (symbol->string name))) 28 | (string->symbol 29 | (substring (symbol->string name) (string-length "whalesong-cs019:"))))) 30 | 31 | 32 | (define missing-cs019-names 33 | (set-subtract cs019-names whalesong-cs019-names)) -------------------------------------------------------------------------------- /whalesong/cs019/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | (define compile-omit-paths '("get-cs019-names.rkt")) 3 | 4 | 5 | -------------------------------------------------------------------------------- /whalesong/cs019/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | 3 | ;; http://docs.racket-lang.org/planet/hash-lang-planet.html 4 | 5 | #:language (lambda (ip) 6 | `(file ,(path->string cs019.rkt))) 7 | 8 | (require racket/runtime-path) 9 | (define-runtime-path cs019.rkt "../cs019.rkt") 10 | -------------------------------------------------------------------------------- /whalesong/cs019/private/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | ;; sigs is the original version of Shriram's signature library. We'll 4 | ;; be patching it anyway, so don't compile this source file. 5 | (define compile-omit-paths '("sigs.rkt")) 6 | 7 | -------------------------------------------------------------------------------- /whalesong/cs019/teach-runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | 3 | (provide check-not-undefined) 4 | 5 | ;; Wrapped around uses of local-bound variables: 6 | (define (check-not-undefined name val) 7 | (if (eq? val undefined) 8 | (raise 9 | (make-exn:fail:contract:variable 10 | (format "local variable used before its definition: ~a" name) 11 | (current-continuation-marks) 12 | name)) 13 | val)) 14 | (define undefined (letrec ([x x]) x)) 15 | -------------------------------------------------------------------------------- /whalesong/examples/alert.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/js) 3 | (alert "hello world") 4 | -------------------------------------------------------------------------------- /whalesong/examples/cs019/hello.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/cs019 2 | "hello world" 3 | -------------------------------------------------------------------------------- /whalesong/examples/cs019/tick-tock/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | My simple program 4 | 5 |

The current counter is: fill-me-in

6 | 7 | 8 | -------------------------------------------------------------------------------- /whalesong/examples/cs019/tick-tock/tick-tock.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/cs019 2 | 3 | (define-resource index.html) 4 | 5 | 6 | (define: (draw [world : Number$] [dom : View$]) -> View$ 7 | (update-view-text (view-focus dom "counter") world)) 8 | 9 | 10 | (define: (tick [world : Number$] [dom : View$]) -> Number$ 11 | (add1 world)) 12 | 13 | 14 | (define: (stop? [world : Number$] [dom : View$]) -> Boolean$ 15 | (> world 10)) 16 | 17 | (big-bang 0 18 | (initial-view index.html) 19 | (to-draw draw) 20 | (on-tick tick 1) 21 | (stop-when stop?)) 22 | -------------------------------------------------------------------------------- /whalesong/examples/cs019/where-am-i/index.html: -------------------------------------------------------------------------------- 1 | 2 | Where in the world am I? 3 | 4 |

5 | I am at: dunno. 6 | The mock location says: dunno. 7 |

8 | 9 | 10 | -------------------------------------------------------------------------------- /whalesong/examples/dom-play.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/js) 4 | 5 | 6 | ;; insert-break: -> void 7 | (define (insert-break) 8 | (call-method ($ "
") "appendTo" body) 9 | (void)) 10 | 11 | 12 | (define (write-message msg) 13 | (void (call-method (call-method (call-method ($ "") "text" msg) 14 | "css" "white-space" "pre") 15 | "appendTo" 16 | body))) 17 | 18 | 19 | 20 | ;; Set the background green. 21 | (void (call-method body "css" "background-color" "lightgreen")) 22 | (void (call-method ($ "

Hello World

") "appendTo" body)) 23 | (write-message "Hello, this is a test!") 24 | (insert-break) 25 | (let loop ([i 0]) 26 | (cond 27 | [(= i 10) 28 | (void)] 29 | [else 30 | (write-message "iteration ") (write-message i) 31 | (insert-break) 32 | (loop (add1 i))])) 33 | 34 | (write-message "viewport-width: ") (write-message (viewport-width)) 35 | (insert-break) 36 | (write-message "viewport-height: ") (write-message (viewport-height)) 37 | (insert-break) 38 | -------------------------------------------------------------------------------- /whalesong/examples/drag-and-drop/style.css: -------------------------------------------------------------------------------- 1 | 2 | #playground { 3 | background-color: lightgray; 4 | border: 1px solid black; 5 | width: 500px; 6 | height: 500px; 7 | display: block; 8 | position: relative; 9 | } 10 | 11 | 12 | .shape { 13 | position: relative; 14 | background-color: orange; 15 | border: 1px solid black; 16 | } -------------------------------------------------------------------------------- /whalesong/examples/drag-and-drop/view.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 |

Drag and drop example

8 | 9 |
10 | This is the playground. 11 |
12 | 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /whalesong/examples/eli-number-puzzle.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | ;; Eli's puzzle 4 | ;; 5 | ;; http://lists.racket-lang.org/users/archive/2011-July/046849.html 6 | 7 | (require whalesong/world) 8 | 9 | (define-struct world (seq output)) 10 | 11 | ;; streak: (listof number) -> number 12 | (define (streak lst) 13 | (let ([elt (car lst)]) 14 | (let loop ([lst lst]) 15 | (cond 16 | [(null? lst) 0] 17 | [(= (car lst) 18 | elt) 19 | (add1 (loop (cdr lst)))] 20 | [else 21 | 0])))) 22 | 23 | (define (my-drop lst n) 24 | (cond 25 | [(= n 0) 26 | lst] 27 | [else 28 | (my-drop (cdr lst) (sub1 n))])) 29 | 30 | (define (tick w) 31 | (let* ([streak-length (streak (world-seq w))] 32 | [next-self-describing-chunk 33 | (list streak-length (car (world-seq w)))]) 34 | (make-world (append (my-drop (world-seq w) streak-length) 35 | next-self-describing-chunk) 36 | (append (world-output w) 37 | (list streak-length 38 | (car (world-seq w))))))) 39 | 40 | (define (draw w) 41 | (world-output w)) 42 | 43 | (big-bang (make-world '(1) '()) 44 | (on-tick tick 1) 45 | (to-draw draw)) 46 | -------------------------------------------------------------------------------- /whalesong/examples/expanding-circle.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/world 4 | whalesong/image) 5 | 6 | 7 | (define handler (on-tick add1 1)) 8 | handler 9 | 10 | "big bang should follow:" 11 | 12 | 13 | (define (draw w) 14 | (circle w 'solid 'blue)) 15 | 16 | 17 | (big-bang 1 18 | (on-tick add1 1/28) 19 | (stop-when (lambda (w) (> w 500))) 20 | (to-draw draw) 21 | ) 22 | 23 | 24 | "all done" 25 | -------------------------------------------------------------------------------- /whalesong/examples/fact.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (provide fact) 3 | (define (fact x) 4 | (cond 5 | [(= x 0) 6 | 1] 7 | [else 8 | (* x (fact (sub1 x)))])) 9 | -------------------------------------------------------------------------------- /whalesong/examples/google-maps/test-maps.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | "maps.rkt") 4 | 5 | ;; Note: this is dyoo's API key. Please don't abuse this. :) 6 | (initialize-google-maps-api! "AIzaSyCRKQNI_nbyyN1286cssEy3taKj5IZcHN8" #f) 7 | 8 | 9 | ;; We dynamically create a dom node for the presentation of the map, 10 | ;; and an auxiliary gmap value that we use to manage the internal 11 | ;; state of the map. 12 | (define-values (dom gmap) 13 | (make-dom-and-map 41.82706261971936 -71.39962630844116)) 14 | 15 | 16 | ;; on-map-click: world handler 17 | ;; Creates an on-map-click associated to the gmap, ready to be used in 18 | ;; a big bang. 19 | ;; It'll be used as an input device for our world program. 20 | (define on-map-click (make-on-map-click gmap)) 21 | 22 | 23 | 24 | (xexp->dom '(h1 "Google Maps demonstration")) 25 | 26 | (big-bang "???" 27 | (initial-view 28 | (xexp->dom 29 | `(div (p (@ (id "where")) 30 | "<>") 31 | (hr) 32 | ,dom 33 | (hr) 34 | (p "Instructions: click the map. The " 35 | "world program will follow the map clicks.")))) 36 | (to-draw (lambda (w v) 37 | (update-view-text (view-focus v "where") 38 | (format "~a" w)))) 39 | (on-map-click (lambda (w v lat lng) 40 | (list lat lng)))) 41 | -------------------------------------------------------------------------------- /whalesong/examples/hello-bf.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/bf 2 | 3 | +++++ +++++ initialize counter (cell #0) to 10 4 | [ use loop to set the next four cells to 70/100/30/10 5 | > +++++ ++ add 7 to cell #1 6 | > +++++ +++++ add 10 to cell #2 7 | > +++ add 3 to cell #3 8 | > + add 1 to cell #4 9 | <<<< - decrement counter (cell #0) 10 | ] 11 | > ++ . print 'H' 12 | > + . print 'e' 13 | +++++ ++ . print 'l' 14 | . print 'l' 15 | +++ . print 'o' 16 | > ++ . print ' ' 17 | << +++++ +++++ +++++ . print 'W' 18 | > . print 'o' 19 | +++ . print 'r' 20 | ----- - . print 'l' 21 | ----- --- . print 'd' 22 | > + . print '!' 23 | > . print '\n' 24 | -------------------------------------------------------------------------------- /whalesong/examples/hello-css.css: -------------------------------------------------------------------------------- 1 | body { 2 | background-color: blue 3 | } 4 | -------------------------------------------------------------------------------- /whalesong/examples/hello-css.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | 5 | (define-resource hello-css.css) 6 | (define-resource hello-css-main.html) 7 | 8 | (big-bang 0 9 | (initial-view hello-css-main.html) 10 | (to-draw (lambda (w v) v))) 11 | 12 | "done" 13 | -------------------------------------------------------------------------------- /whalesong/examples/hello-kr.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/korean 2 | 3 | 4 | (정의 (안녕 이름) 5 | (string-append "안녕" " " 이름)) 6 | 7 | 8 | (displayln (안녕 "danny")) 9 | 10 | 11 | (정의 (f x) 12 | (조건부 13 | [(= x 0) 14 | 1] 15 | [다른 16 | (* x (f (- x 1)))])) 17 | 18 | (f 50) 19 | 20 | 21 | (정의-구조 사람 (이름 나이)) 22 | (make-사람 "danny" 32) 23 | -------------------------------------------------------------------------------- /whalesong/examples/hello.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (display "hello world") 4 | (newline) 5 | -------------------------------------------------------------------------------- /whalesong/examples/images/humpback.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dyoo/whalesong/636e0b4e399e4523136ab45ef4cd1f5a84e88cdc/whalesong/examples/images/humpback.jpg -------------------------------------------------------------------------------- /whalesong/examples/iron-puzzle/iron-puzzle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dyoo/whalesong/636e0b4e399e4523136ab45ef4cd1f5a84e88cdc/whalesong/examples/iron-puzzle/iron-puzzle.png -------------------------------------------------------------------------------- /whalesong/examples/js-get-message/js-get-message-child.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/js/world 3 | whalesong/js 4 | whalesong/web-world) 5 | 6 | ;; Test of getting world events from arbitrary JavaScript function application. 7 | 8 | ;; We first define a new event handler type, by using make-js-world-event: 9 | (define-values (on-message send) 10 | (make-js-world-event)) 11 | 12 | ;; It gives us two values back: 13 | ;; 1. An event handler that can be passed to big-bang 14 | ;; 2. A raw JavaScript function that can fire events 15 | 16 | 17 | ;; Let's attach the send-event function to a toplevel function on the window. 18 | (void ((js-function->procedure "function(send) { $(window).bind('message', function(e) { send(e.originalEvent.data); })}") 19 | send)) 20 | ;; js-function lifts JavaScript functions to regular function we can call. 21 | 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | ;; With this infrastructure, we can make a world program that responds to window postMessage. For example, 25 | ;; we can present a log of all the messages we receive. 26 | 27 | (define-struct world (time messages)) 28 | 29 | (define (read-message w v msg) 30 | (make-world (world-time w) 31 | (cons (format "at time ~a: ~s" 32 | (world-time w) 33 | msg) 34 | (world-messages w)))) 35 | 36 | (define (tick w v) 37 | (make-world (add1 (world-time w)) 38 | (world-messages w))) 39 | 40 | 41 | ;; Finally, let's use our big bang: 42 | (big-bang (make-world 0 '()) 43 | (on-tick tick 1) 44 | (on-message read-message)) 45 | 46 | -------------------------------------------------------------------------------- /whalesong/examples/js-get-message/js-get-message-parent.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Testing message passing across windows 4 | 5 | 6 | 12 | 13 | 14 | 15 |

This is a world program:

16 | 17 | 18 |
19 |
And this a regular JavaScript program:

21 | 22 | 23 | 24 | 25 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /whalesong/examples/list-length.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (define (mylen x acc) 4 | (cond 5 | [(empty? x) 6 | acc] 7 | [else 8 | (mylen (rest x) (add1 acc))])) 9 | "computing length" 10 | (define v (build-list 1000000 (lambda (i) i))) 11 | (printf "Built list\n") 12 | (mylen v 0) 13 | "done computing length" 14 | -------------------------------------------------------------------------------- /whalesong/examples/logo.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/image) 4 | 5 | 6 | (define lst 7 | (list (image-url "http://racket-lang.org/logo.png") 8 | (image-url "http://www.bootstrapworld.org/images/icon.gif"))) 9 | (list lst lst) 10 | -------------------------------------------------------------------------------- /whalesong/examples/mathjax-script.js: -------------------------------------------------------------------------------- 1 | 13 | 21 | 22 | -------------------------------------------------------------------------------- /whalesong/examples/mathjax.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world) 3 | 4 | ;;; This demonstrates how to use MathJax to write equations. 5 | ;;; Use --include-script mathjax-script.js to include the MathJax. 6 | ;;; racket whalesong.rkt build --include-script mathjax-script.js mathjax.rkt 7 | 8 | ;; tick: world view -> world 9 | (define (tick n view) 10 | (add1 n)) 11 | 12 | ;; draw: world view -> view 13 | (define (draw n view) 14 | (->view 15 | (xexp->dom `(p "This equation has no integer solutions: " 16 | ,(let ([n (number->string n)]) 17 | (format "$$ x^~a + y^~a = z^~a $$" n n n)))))) 18 | 19 | (big-bang 3 20 | (initial-view (xexp->dom '(html (head) (body)))) 21 | (on-tick tick 5) 22 | (to-draw draw)) 23 | -------------------------------------------------------------------------------- /whalesong/examples/mouse.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/world 4 | whalesong/image) 5 | 6 | (define width 640) 7 | (define height 480) 8 | 9 | (define-struct posn (x y)) 10 | 11 | (define (mouse world x y type) 12 | (cond 13 | 14 | [(string=? type "move") 15 | (make-posn x y)] 16 | 17 | [else 18 | world])) 19 | 20 | (define (draw w) 21 | (place-image (circle 20 'solid 'red) 22 | (posn-x w) 23 | (posn-y w) 24 | (empty-scene width height))) 25 | 26 | (printf "let's see how this works.\n\n") 27 | (big-bang (make-posn 0 0) 28 | (on-mouse mouse) 29 | (to-draw draw)) 30 | -------------------------------------------------------------------------------- /whalesong/examples/read-bytes.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (let loop ([b (read-byte)]) 4 | (cond 5 | [(eof-object? b) 6 | (void)] 7 | [else 8 | (display (string (integer->char b))) 9 | (loop (read-byte))])) 10 | -------------------------------------------------------------------------------- /whalesong/examples/select.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/web-world) 4 | 5 | (define (draw w v) 6 | (define v2 (view-focus v "fill-me-in")) 7 | (update-view-text v2 w)) 8 | 9 | (define view (xexp->dom '(div 10 | (h1 "test") 11 | (select (@ (id "my-select")) 12 | (option (@ (value "red")) "Red") 13 | (option (@ (value "green")) "Green") 14 | (option (@ (value "blue")) "Blue")) 15 | (p 16 | "I see: " 17 | (span (@ (id "fill-me-in"))))))) 18 | 19 | (define (when-select-changed w v) 20 | (view-form-value (view-focus v "my-select"))) 21 | 22 | (define bound-view 23 | (view-bind-many view ["my-select" "change" when-select-changed])) 24 | 25 | (big-bang "nothing yet" 26 | (initial-view bound-view) 27 | (to-draw draw)) 28 | -------------------------------------------------------------------------------- /whalesong/examples/shuffling.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | 4 | ;; shuffle: vector -> vector 5 | ;; Reorders the contents of a vector according to the Fisher-Yates shuffling algorithm. 6 | (define (shuffle! a-vec) 7 | (letrec ([iter (lambda (i) 8 | (cond 9 | [(<= i 0) 10 | a-vec] 11 | [else 12 | (let* ([index (random (add1 i))] 13 | [t (vector-ref a-vec i)]) 14 | (vector-set! a-vec i (vector-ref a-vec index)) 15 | (vector-set! a-vec index t) 16 | (iter (sub1 i)))]))]) 17 | (iter (sub1 (vector-length a-vec))))) 18 | 19 | (shuffle! (vector)) 20 | (shuffle! (vector 'one)) 21 | (shuffle! (vector 1 2)) 22 | (shuffle! (vector "red" "white" "blue")) 23 | (shuffle! (list->vector (string->list "abcdefghijklmnopqrstuvwxyz"))) 24 | -------------------------------------------------------------------------------- /whalesong/examples/sierpinski-carpet.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | (require whalesong/image) 3 | ;; Sierpenski carpet. 4 | ;; http://rosettacode.org/wiki/Sierpinski_carpet#Scheme 5 | 6 | (define SQUARE (square 5 "solid" "red")) 7 | (define SPACE (square 5 "solid" "white")) 8 | 9 | (define (carpet n) 10 | (local [(define (in-carpet? x y) 11 | (cond ((or (zero? x) (zero? y)) 12 | #t) 13 | ((and (= 1 (remainder x 3)) (= 1 (remainder y 3))) 14 | #f) 15 | (else 16 | (in-carpet? (quotient x 3) (quotient y 3)))))] 17 | 18 | (letrec ([outer (lambda (i) 19 | (cond 20 | [(< i (expt 3 n)) 21 | (local ([define a-row 22 | (letrec ([inner 23 | (lambda (j) 24 | (cond [(< j (expt 3 n)) 25 | (cons (if (in-carpet? i j) 26 | SQUARE 27 | SPACE) 28 | (inner (add1 j)))] 29 | [else 30 | empty]))]) 31 | (inner 0))]) 32 | (cons (apply beside a-row) 33 | (outer (add1 i))))] 34 | [else 35 | empty]))]) 36 | (apply above (outer 0))))) 37 | 38 | 39 | (carpet 4) 40 | -------------------------------------------------------------------------------- /whalesong/examples/using-resources.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/resource 4 | whalesong/image) 5 | 6 | (define-resource whale-resource "images/humpback.jpg") 7 | (define-resource self-resource "using-resources.rkt") 8 | 9 | (define whale-image 10 | (image-url 11 | (resource->url whale-resource))) 12 | 13 | (list whale-image whale-image) 14 | (resource? whale-image) 15 | (image? whale-image) 16 | 17 | 18 | (list whale-resource whale-resource) 19 | (resource? whale-resource) 20 | (image? whale-resource) 21 | 22 | 23 | (list self-resource self-resource) 24 | (resource? self-resource) 25 | (image? self-resource) 26 | -------------------------------------------------------------------------------- /whalesong/examples/whale.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/world 4 | whalesong/image) 5 | 6 | (define-struct world (x direction)) 7 | 8 | 9 | (define whale-image (image-url "http://hashcollision.org/whalesong/humpback.jpg")) 10 | 11 | (define scene-width (* (image-width whale-image) 5)) 12 | 13 | (define (draw w) 14 | (place-image whale-image 15 | (world-x w) 16 | (/ (image-height whale-image) 2) 17 | (empty-scene scene-width 18 | (image-height whale-image)))) 19 | 20 | (define (tick w) 21 | (make-world (modulo (+ (world-x w) 22 | (world-direction w)) 23 | (+ scene-width (image-width whale-image))) 24 | (world-direction w))) 25 | 26 | 27 | (define (key w a-key) 28 | (cond 29 | [(key=? a-key "left") 30 | (make-world (world-x w) (sub1 (world-direction w)))] 31 | [(key=? a-key "right") 32 | (make-world (world-x w) (add1 (world-direction w)))] 33 | [else 34 | w])) 35 | 36 | 37 | (big-bang (make-world 0 5) 38 | (on-tick tick) 39 | (to-draw draw) 40 | (on-key key)) 41 | -------------------------------------------------------------------------------- /whalesong/examples/window-size.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/js) 4 | 5 | (when (in-javascript-context?) 6 | (viewport-width)) 7 | 8 | (when (in-javascript-context?) 9 | (viewport-height)) 10 | -------------------------------------------------------------------------------- /whalesong/experiments/gauss/foo2.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /whalesong/experiments/gauss/gauss.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | int main(int argc, char**argv) { 5 | unsigned long long i, n, acc=0; 6 | struct timeval start, end; 7 | sscanf(argv[1], "%llu", &n); 8 | 9 | 10 | gettimeofday(&start, NULL); 11 | for (i = 0; i <= n; i++) { 12 | acc = acc + i; 13 | } 14 | gettimeofday(&end, NULL); 15 | printf("%llu (%f milliseconds)\n", 16 | acc, 17 | (1000.0*(end.tv_sec - start.tv_sec) + 18 | ((end.tv_usec - start.tv_usec) / 1000.0) )); 19 | } 20 | -------------------------------------------------------------------------------- /whalesong/experiments/gauss/gauss.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /whalesong/experiments/gauss/gauss.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (define (gauss n) 5 | (gauss-iter n 0)) 6 | 7 | (define (gauss-iter n acc) 8 | (if (= n 0) 9 | acc 10 | (gauss-iter (sub1 n) (+ acc n)))) 11 | 12 | 13 | (define n (string->number (vector-ref (current-command-line-arguments) 0))) 14 | (define start (current-inexact-milliseconds)) 15 | (define result (gauss n)) 16 | (define end (current-inexact-milliseconds)) 17 | 18 | (printf "~a (~a milliseconds)\n" result (- end start)) -------------------------------------------------------------------------------- /whalesong/experiments/gauss/notes.txt: -------------------------------------------------------------------------------- 1 | Racket is about 20 times slower than C on gauss. 2 | 3 | My compiled output is about 60 times slower than a raw JavaScript loop. 4 | -------------------------------------------------------------------------------- /whalesong/image.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "lang/base.rkt" 2 | (require "image/main.rkt") 3 | (provide (all-from-out "image/main.rkt")) 4 | -------------------------------------------------------------------------------- /whalesong/image/main.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | 3 | (require "private/main.rkt" 4 | "private/color.rkt") 5 | 6 | (provide (all-from-out "private/main.rkt") 7 | (all-from-out "private/color.rkt")) 8 | -------------------------------------------------------------------------------- /whalesong/image/private/color.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (provide (except-out [struct-out color] color make-color) 4 | [rename-out [-color make-color] 5 | [-color color]]) 6 | 7 | (define-struct color (red green blue alpha) 8 | #:extra-constructor-name make-color) 9 | 10 | (define -color 11 | (case-lambda 12 | [(r g b) 13 | (color r g b 255)] 14 | [(r g b a) 15 | (color r g b a)])) -------------------------------------------------------------------------------- /whalesong/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define name "Whalesong") 4 | (define blurb '("A Racket to JavaScript compiler")) 5 | (define release-notes '((p "Bug fixes."))) 6 | (define version "1.21") 7 | (define primary-file "make-launcher.rkt") 8 | (define categories '(devtools)) 9 | (define repositories '("4.x")) 10 | (define required-core-version "5.1.1") 11 | 12 | ;; I am disabling the automatic launchers: it's causing issues with 13 | ;; file permissions. The program "make-launcher.rkt" will build a 14 | ;; whalesong launcher, so I need to revise the instructions to use it 15 | ;; instead. 16 | ;; 17 | ;; (define racket-launcher-libraries '("whalesong.rkt")) 18 | ;; (define racket-launcher-names '("whalesong")) 19 | ;; 20 | 21 | (define homepage "http://hashcollision.org/whalesong") 22 | (define scribblings '(("scribblings/manual.scrbl"))) 23 | (define compile-omit-paths '("tests" 24 | "sandbox" 25 | "examples" 26 | "experiments" 27 | "simulator" 28 | "tmp")) 29 | (define can-be-loaded-with 'all) 30 | -------------------------------------------------------------------------------- /whalesong/js-assembler/assemble-structs.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (provide (all-defined-out)) 4 | 5 | 6 | (require "../compiler/il-structs.rkt") 7 | 8 | 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;; Assembly 12 | 13 | (define-struct: BasicBlock ([name : Symbol] 14 | [stmts : (Listof UnlabeledStatement)]) 15 | #:transparent) 16 | 17 | 18 | 19 | ;; Represents a hashtable from symbols to basic blocks 20 | (define-type Blockht (HashTable Symbol BasicBlock)) 21 | -------------------------------------------------------------------------------- /whalesong/js-assembler/cache.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (define-struct cached-entry (real-path ;; path to a module. 3 | whalesong-version ;; string 4 | md5 ;; md5 of the original source in real-path 5 | bytes) 6 | #:transparent) ;; bytes 7 | 8 | -------------------------------------------------------------------------------- /whalesong/js-assembler/module-knowledge.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Provides a mapping of the core bindings in kernel, so that we know statically 4 | ;; if something is implemented as a primitive or a closure. 5 | (require syntax/modresolve) 6 | 7 | (provide bound-procedure-names) 8 | 9 | 10 | (define ns (make-base-empty-namespace)) 11 | (define bound-procedure-names 12 | (let ([path (resolve-module-path 'whalesong/lang/kernel #f)]) 13 | (parameterize ([current-namespace ns]) 14 | (namespace-require path) 15 | (for/list ([name (namespace-mapped-symbols)] 16 | #:when (namespace-variable-value name #t (lambda () #f))) 17 | name)))) 18 | 19 | 20 | -------------------------------------------------------------------------------- /whalesong/js-assembler/quote-cdata.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | ;; quoting cdata for script tags. This is used to help generate SCRIPT bodies in XHTML. 4 | ;; Note that this won't help too much in regular HTML5 documents. 5 | 6 | (provide quote-cdata) 7 | 8 | 9 | (: quote-cdata (String -> String)) 10 | (define (quote-cdata s) 11 | (string-append "" 13 | s 14 | "]]]]>") 15 | "]]>")) 16 | 17 | 18 | 19 | ;; (: quote-cdata (String -> String)) 20 | ;; (define (quote-cdata str) 21 | ;; (let ([chunks (regexp-split #rx"\\]\\]>" str)]) 22 | ;; (apply string-append (map wrap (process chunks))))) 23 | 24 | 25 | ;; (: get-cdata-chunks (String -> (Listof String))) 26 | ;; (define (get-cdata-chunks s) 27 | ;; (let ([chunks (regexp-split #rx"\\]\\]>" s)]) 28 | ;; (process chunks))) 29 | 30 | 31 | ;; (: process ((Listof String) -> (Listof String))) 32 | ;; (define (process lst) 33 | ;; (cond 34 | ;; [(empty? (rest lst)) 35 | ;; lst] 36 | ;; [else 37 | ;; (cons (string-append (first lst) "]]") 38 | ;; (process (cons (string-append ">" (second lst)) 39 | ;; (rest (rest lst)))))])) 40 | 41 | ;; (: wrap (String -> String)) 42 | ;; (define (wrap s) 43 | ;; (string-append "")) 44 | -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/baselib-constants.js: -------------------------------------------------------------------------------- 1 | /*jslint vars: true, maxerr: 50, indent: 4 */ 2 | 3 | 4 | // Other miscellaneous constants 5 | (function (baselib) { 6 | 'use strict'; 7 | var exports = {}; 8 | baselib.constants = exports; 9 | 10 | 11 | var VoidValue = function () {}; 12 | VoidValue.prototype.toString = function () { 13 | return "#"; 14 | }; 15 | 16 | var VOID_VALUE = new VoidValue(); 17 | 18 | 19 | var EofValue = function () {}; 20 | EofValue.prototype.toString = function () { 21 | return "#"; 22 | }; 23 | 24 | var EOF_VALUE = new EofValue(); 25 | 26 | 27 | exports.VOID_VALUE = VOID_VALUE; 28 | exports.EOF_VALUE = EOF_VALUE; 29 | }(this.plt.baselib)); -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/baselib-inspectors.js: -------------------------------------------------------------------------------- 1 | /*jslint vars: true, maxerr: 50, indent: 4 */ 2 | 3 | // Structure types 4 | 5 | (function (baselib) { 6 | 'use strict'; 7 | var exports = {}; 8 | baselib.inspectors = exports; 9 | 10 | 11 | var Inspector = function () { 12 | }; 13 | var DEFAULT_INSPECTOR = new Inspector(); 14 | 15 | Inspector.prototype.toString = function () { 16 | return "#"; 17 | }; 18 | 19 | var isInspector = baselib.makeClassPredicate(Inspector); 20 | 21 | 22 | 23 | exports.Inspector = Inspector; 24 | exports.DEFAULT_INSPECTOR = DEFAULT_INSPECTOR; 25 | 26 | exports.isInspector = isInspector; 27 | 28 | 29 | }(this.plt.baselib)); -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/baselib-keywords.js: -------------------------------------------------------------------------------- 1 | /*jslint unparam: true, vars: true, maxerr: 50, indent: 4 */ 2 | 3 | // Keywords 4 | 5 | (function (baselib) { 6 | 'use strict'; 7 | var exports = {}; 8 | baselib.keywords = exports; 9 | 10 | 11 | var Keyword = function (val) { 12 | this.val = val; 13 | }; 14 | 15 | var keywordCache = {}; 16 | 17 | var hasOwnProperty = {}.hasOwnProperty; 18 | 19 | // makeInstance: string -> Keyword. 20 | Keyword.makeInstance = function (val) { 21 | // To ensure that we can eq? symbols with equal values. 22 | if (!(hasOwnProperty.call(keywordCache, val))) { 23 | keywordCache[val] = new Keyword(val); 24 | } 25 | return keywordCache[val]; 26 | }; 27 | 28 | Keyword.prototype.equals = function (other, aUnionFind) { 29 | return other instanceof Keyword && 30 | this.val === other.val; 31 | }; 32 | 33 | Keyword.prototype.hashCode = function(depth) { 34 | var k = baselib.hashes.getEqualHashCode("Keyword"); 35 | k += baselib.hashes.getEqualHashCode(this.val, depth); 36 | k = baselib.hashes.hashMix(k); 37 | return k; 38 | }; 39 | 40 | 41 | Keyword.prototype.toString = function (cache) { 42 | return this.val; 43 | }; 44 | 45 | Keyword.prototype.toWrittenString = function (cache) { 46 | return this.val; 47 | }; 48 | 49 | Keyword.prototype.toDisplayedString = function (cache) { 50 | return this.val; 51 | }; 52 | 53 | 54 | exports.Keyword = Keyword; 55 | 56 | }(this.plt.baselib)); -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/baselib-paramz.js: -------------------------------------------------------------------------------- 1 | // Hardcoded parameters. 2 | (function(baselib) { 3 | 'use strict'; 4 | var exports = {}; 5 | baselib.paramz = exports; 6 | 7 | // The parameter keys here must be uninterned symbols, so we explicitly 8 | // call the symbol constructor here. 9 | var exceptionHandlerKey = new baselib.symbols.Symbol("exnh"); 10 | var parameterizationKey = new baselib.symbols.Symbol("paramz"); 11 | var breakEnabledKey = new baselib.symbols.Symbol("break-on?"); 12 | 13 | exports.exceptionHandlerKey = exceptionHandlerKey; 14 | exports.parameterizationKey = parameterizationKey; 15 | exports.breakEnabledKey = breakEnabledKey; 16 | 17 | })(this['plt'].baselib); 18 | -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/baselib-paths.js: -------------------------------------------------------------------------------- 1 | /*jslint vars: true, maxerr: 50, indent: 4 */ 2 | 3 | 4 | (function (baselib) { 5 | 'use strict'; 6 | var exports = {}; 7 | baselib.paths = exports; 8 | 9 | // Paths 10 | 11 | var Path = function (p) { 12 | this.path = p; 13 | }; 14 | 15 | Path.prototype.toString = function () { 16 | return "#"; 17 | }; 18 | 19 | 20 | Path.prototype.equals = function(other, aUnionFind) { 21 | return (other instanceof Path && 22 | this.path === other.path); 23 | }; 24 | 25 | Path.prototype.hashCode = function(depth) { 26 | var k = baselib.hashes.getEqualHashCode("path"); 27 | k += baselib.hashes.getEqualHashCode(this.path, depth); 28 | k = baselib.hashes.hashMix(k); 29 | return k; 30 | }; 31 | 32 | 33 | ////////////////////////////////////////////////////////////////////// 34 | 35 | var makePath = function (p) { 36 | return new Path(p); 37 | }; 38 | 39 | var isPath = baselib.makeClassPredicate(Path); 40 | 41 | 42 | 43 | exports.Path = Path; 44 | exports.makePath = makePath; 45 | exports.isPath = isPath; 46 | 47 | }(this.plt.baselib)); -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/baselib-regexps.js: -------------------------------------------------------------------------------- 1 | /*jslint vars: true, maxerr: 50, indent: 4 */ 2 | 3 | (function (baselib) { 4 | 'use strict'; 5 | var exports = {}; 6 | baselib.regexps = exports; 7 | 8 | 9 | // Regular expressions. 10 | 11 | var RegularExpression = function (pattern) { 12 | this.pattern = pattern; 13 | }; 14 | 15 | 16 | var ByteRegularExpression = function (pattern) { 17 | this.pattern = pattern; 18 | }; 19 | 20 | ////////////////////////////////////////////////////////////////////// 21 | 22 | exports.RegularExpression = RegularExpression; 23 | exports.ByteRegularExpression = ByteRegularExpression; 24 | 25 | }(this.plt.baselib)); -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/baselib-srclocs.js: -------------------------------------------------------------------------------- 1 | /*jslint vars: true, white: true, plusplus: false, maxerr: 50, indent: 4 */ 2 | (function(baselib) { 3 | 'use strict'; 4 | 5 | var exports = {}; 6 | baselib.srclocs = exports; 7 | 8 | // (define-struct srcloc (source line column position span)) 9 | var srcloc = baselib.structs.makeStructureType( 10 | 'srcloc', false, 5, 0, false, false); 11 | 12 | var makeSrcloc = function() { 13 | var args = [].slice.call(arguments); 14 | return srcloc.constructor(args); 15 | }; 16 | 17 | var isSrcloc = srcloc.predicate; 18 | var srclocSource = function(x) { return srcloc.accessor(x, 0); }; 19 | var srclocLine = function(x) { return srcloc.accessor(x, 1); }; 20 | var srclocColumn = function(x) { return srcloc.accessor(x, 2); }; 21 | var srclocPosition = function(x) { return srcloc.accessor(x, 3); }; 22 | var srclocSpan = function(x) { return srcloc.accessor(x, 4); }; 23 | 24 | ////////////////////////////////////////////////////////////////////// 25 | exports.makeSrcloc = makeSrcloc; 26 | exports.isSrcloc = isSrcloc; 27 | exports.srclocSource = srclocSource; 28 | exports.srclocLine = srclocLine; 29 | exports.srclocColumn = srclocColumn; 30 | exports.srclocPosition = srclocPosition; 31 | exports.srclocSpan = srclocSpan; 32 | 33 | }(this.plt.baselib)); -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/baselib-unionfind.js: -------------------------------------------------------------------------------- 1 | /*jslint devel: false, browser: true, vars: true, plusplus: true, maxerr: 500, indent: 4 */ 2 | (function (baselib) { 3 | "use strict"; 4 | 5 | // Union/find for circular equality testing. 6 | 7 | var UnionFind = function () { 8 | // this.parenMap holds the arrows from an arbitrary pointer 9 | // to its parent. 10 | this.parentMap = baselib.hashes.makeLowLevelEqHash(); 11 | }; 12 | 13 | // find: ptr -> UnionFindNode 14 | // Returns the representative for this ptr. 15 | UnionFind.prototype.find = function (ptr) { 16 | var parent = (this.parentMap.containsKey(ptr) ? 17 | this.parentMap.get(ptr) : ptr); 18 | if (parent === ptr) { 19 | return parent; 20 | } else { 21 | var rep = this.find(parent); 22 | // Path compression: 23 | this.parentMap.put(ptr, rep); 24 | return rep; 25 | } 26 | }; 27 | 28 | // merge: ptr ptr -> void 29 | // Merge the representative nodes for ptr1 and ptr2. 30 | UnionFind.prototype.merge = function (ptr1, ptr2) { 31 | this.parentMap.put(this.find(ptr1), this.find(ptr2)); 32 | }; 33 | 34 | 35 | 36 | baselib.UnionFind = UnionFind; 37 | 38 | }(this.plt.baselib)); -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/hashes-footer.js: -------------------------------------------------------------------------------- 1 | }()); 2 | -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/hashes-header.js: -------------------------------------------------------------------------------- 1 | (function() { 2 | 'use strict'; -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/jquery-protect-footer.js: -------------------------------------------------------------------------------- 1 | } 2 | })(window, void(0)); -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/jquery-protect-header.js: -------------------------------------------------------------------------------- 1 | (function(window, undefined) { 2 | // dyoo: this library has been modified slightly so it checks to see 3 | // if window.jQuery has already been installed. This is to prevent an ugly issue 4 | // with regards to a memory leak if one tries to repeatedly load jQuery. 5 | // NOTE: this portion of the file (jquery-protect-header.js) is intentionally 6 | // unbalanced. It'll be closed up by jquery-protect-footer.js. 7 | if (!window.jQuery) { 8 | -------------------------------------------------------------------------------- /whalesong/js-assembler/runtime-src/top.js: -------------------------------------------------------------------------------- 1 | 2 | // The following contains the Whalesong runtime. 3 | 4 | 5 | -------------------------------------------------------------------------------- /whalesong/js.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "lang/base.rkt" 2 | (require "js/main.rkt") 3 | (provide [except-out (all-from-out "js/main.rkt") 4 | js-function->procedure 5 | js-async-function->procedure] 6 | [rename-out [-js-function->procedure js-function->procedure] 7 | [-js-async-function->procedure js-async-function->procedure]] 8 | js-function?) 9 | 10 | (define raw-js-function? 11 | (js-function->procedure (js-eval "function(x) { return typeof(x) === 'function'}"))) 12 | 13 | (define (js-function? x) 14 | (raw-js-function? x)) 15 | 16 | (define (-js-function->procedure x) 17 | (cond 18 | [(string? x) 19 | (js-function->procedure (js-eval x))] 20 | [(js-function? x) 21 | (js-function->procedure x)] 22 | [else 23 | (raise-type-error 'js-function->procedure "js-function or string" x)])) 24 | 25 | (define (-js-async-function->procedure x) 26 | (cond 27 | [(string? x) 28 | (js-async-function->procedure (js-eval x))] 29 | [(js-function? x) 30 | (js-async-function->procedure x)] 31 | [else 32 | (raise-type-error 'js-async-function->procedure "js-function or string" x)])) -------------------------------------------------------------------------------- /whalesong/js/main.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/js/js.rkt" 2 | 3 | (declare-implementation 4 | #:racket "racket-impl.rkt" 5 | #:javascript ("js-impl.js") 6 | #:provided-values (alert 7 | body 8 | call-method 9 | $ 10 | 11 | js-function->procedure 12 | js-async-function->procedure 13 | 14 | window 15 | 16 | get-attr 17 | set-attr! 18 | 19 | js-string? 20 | string->js-string 21 | js-string->string 22 | 23 | js-number? 24 | number->js-number 25 | js-number->number 26 | 27 | viewport-width 28 | viewport-height 29 | in-javascript-context? 30 | 31 | js-null? 32 | js-null 33 | 34 | js-eval 35 | 36 | load-script 37 | )) -------------------------------------------------------------------------------- /whalesong/js/world.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | (require "world/main.rkt") 3 | (provide (all-from-out "world/main.rkt")) -------------------------------------------------------------------------------- /whalesong/js/world/geo.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (require "../../js.rkt") 4 | (require "../../js/world.rkt") 5 | 6 | (provide on-geo) 7 | 8 | (define setup-geo 9 | (js-function->procedure 10 | "function(locationCallback) { 11 | return navigator.geolocation.watchPosition( 12 | function(evt) { 13 | var coords = evt.coords; 14 | locationCallback(plt.runtime.makeFloat(coords.latitude), 15 | plt.runtime.makeFloat(coords.longitude)); })}")) 16 | 17 | (define shutdown-geo 18 | (js-function->procedure 19 | "function(watchId) { 20 | navigator.geolocation.clearWatch(watchId); }")) 21 | 22 | 23 | ;; A new event handler type for geolocation: 24 | ;; 25 | ;; Use it as any other world handler: 26 | ;; 27 | ;; (big-bang ... 28 | ;; [on-geo (lambda (world view lat lng) 29 | ;; ...)] 30 | ;; 31 | ;; ...) 32 | (define on-geo (make-world-event-handler setup-geo shutdown-geo)) 33 | 34 | -------------------------------------------------------------------------------- /whalesong/js/world/main.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | (require "world-event-handler.rkt") 3 | (provide (all-from-out "world-event-handler.rkt")) 4 | -------------------------------------------------------------------------------- /whalesong/js/world/racket-impl.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (provide make-world-event-handler) 4 | 5 | (define (make-world-event-handler setup shutdown) 6 | (error 'make-world-event-handler "Must be run under a JavaScript context.")) 7 | -------------------------------------------------------------------------------- /whalesong/js/world/test-geo.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/web-world 4 | "geo.rkt") 5 | 6 | 7 | (big-bang (list 'undefined 'undefined) 8 | (on-geo (lambda (w v lat lng) 9 | (list lat lng)))) 10 | -------------------------------------------------------------------------------- /whalesong/js/world/test.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/js/world 3 | whalesong/js 4 | whalesong/web-world) 5 | 6 | ;; Test of getting world events from arbitrary JavaScript function application. 7 | 8 | 9 | ;; js-function->procedure lifts JavaScript functions to regular 10 | ;; procedures that we can call. 11 | (define setup-timer 12 | (js-function->procedure (js-eval "function(x) { window.sendTheTick = x; }"))) 13 | 14 | (define shutdown-timer 15 | (js-function->procedure (js-eval "function(_) { window.sendTheTick = void(0); }"))) 16 | 17 | 18 | 19 | ;; We first define a new event handler type, by using make-js-world-event: 20 | (define on-event (make-world-event-handler setup-timer shutdown-timer)) 21 | 22 | 23 | 24 | (define (tick w v) 25 | (add1 w)) 26 | 27 | 28 | ;; Finally, let's use our big bang: 29 | (big-bang 0 30 | (on-event tick) ;; Note the on-event here 31 | (stop-when (lambda (w v) (> w 5)))) 32 | 33 | 34 | ;; Run this program. A big-bang should be in progress and show 0. 35 | ;; 36 | ;; Next, open up your developer window, and call window.sendTheTick(). 37 | ;; You should see the world respond. 38 | -------------------------------------------------------------------------------- /whalesong/js/world/world-event-handler.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/js/js.rkt" 2 | (require "../../web-world.rkt") 3 | (declare-implementation 4 | #:racket "racket-impl.rkt" 5 | #:javascript ("js-impl.js") 6 | #:provided-values (make-world-event-handler)) -------------------------------------------------------------------------------- /whalesong/korean/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | #:language (lambda () 'whalesong/lang/korean) 3 | -------------------------------------------------------------------------------- /whalesong/lang/base.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "kernel.rkt" 2 | 3 | (provide (except-out (all-from-out "kernel.rkt") 4 | 5 | ;; Don't publically export the bindings from #%paramz. 6 | exception-handler-key 7 | parameterization-key 8 | break-enabled-key 9 | 10 | ;; or define-syntax-parameter 11 | define-syntax-parameter 12 | syntax-parameterize 13 | ) 14 | (all-from-out "private/list.rkt") 15 | (all-from-out "private/map.rkt") 16 | (all-from-out "private/hash.rkt") 17 | (all-from-out "private/call-ec.rkt") 18 | (all-from-out "private/with-handlers.rkt") 19 | (all-from-out "list.rkt") 20 | quasiquote) 21 | 22 | (require "private/list.rkt" 23 | "private/map.rkt" 24 | "private/hash.rkt" 25 | "private/call-ec.rkt" 26 | "private/with-handlers.rkt" 27 | "list.rkt" 28 | (only-in "private/qq-and-or.rkt" quasiquote)) 29 | 30 | 31 | ;; Kludge: This forces modbeg to be compiled and packaged. 32 | (require racket/private/modbeg) 33 | -------------------------------------------------------------------------------- /whalesong/lang/base/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | 3 | ;; http://docs.racket-lang.org/planet/hash-lang-planet.html 4 | 5 | #:language (lambda (ip) 6 | `(file ,(path->string base-lang-path))) 7 | 8 | (require racket/runtime-path) 9 | (define-runtime-path base-lang-path "../base.rkt") 10 | -------------------------------------------------------------------------------- /whalesong/lang/bool.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "kernel.rkt" 2 | 3 | (provide true false false? 4 | boolean=? 5 | symbol=?) 6 | 7 | (define true #t) 8 | (define false #f) 9 | 10 | (define (false? v) (eq? v #f)) 11 | 12 | (define (boolean=? x y) 13 | (unless (and (boolean? x) (boolean? y)) 14 | (raise-type-error 'boolean=? "boolean" (if (boolean? x) 1 0) x y)) 15 | (eq? x y)) 16 | 17 | (define (symbol=? x y) 18 | (unless (and (symbol? x) (symbol? y)) 19 | (raise-type-error 'symbol=? "symbol" (if (symbol? x) 1 0) x y)) 20 | (eq? x y)) 21 | 22 | -------------------------------------------------------------------------------- /whalesong/lang/korean.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "base.rkt" 2 | 3 | (require (for-syntax racket/base)) 4 | (provide (all-defined-out) 5 | (all-from-out "base.rkt")) 6 | 7 | 8 | (define-syntax 정의 9 | (make-rename-transformer #'define)) 10 | 11 | 12 | (define-syntax 정의-구조 13 | (make-rename-transformer #'define-struct)) 14 | 15 | 16 | (define-syntax 지역 17 | (make-rename-transformer #'local)) 18 | 19 | 20 | (define-syntax 조건부 21 | (make-rename-transformer #'cond)) 22 | 23 | 24 | (define-syntax 다른 25 | (make-rename-transformer #'else)) 26 | 27 | 28 | (define-syntax 면 29 | (make-rename-transformer #'if)) 30 | 31 | 32 | (define-syntax 케이스 33 | (make-rename-transformer #'case)) 34 | 35 | 36 | (define-syntax 람다 37 | (make-rename-transformer #'lambda)) 38 | 39 | 40 | (define-syntax 수정 41 | (make-rename-transformer #'set!)) 42 | 43 | 44 | (define-syntax 또는 45 | (make-rename-transformer #'or)) 46 | 47 | 48 | (define-syntax 과 49 | (make-rename-transformer #'and)) 50 | 51 | 52 | (define-syntax 필요 53 | (make-rename-transformer #'require)) -------------------------------------------------------------------------------- /whalesong/lang/posn.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "kernel.rkt" 2 | 3 | ;; The posn struct for the teaching languages 4 | (provide struct:posn make-posn posn? posn-x posn-y set-posn-x! set-posn-y! 5 | posn #;(rename-out (posn posn-id))) 6 | 7 | (struct posn (x y) #:mutable #:transparent) 8 | 9 | ;; We define a separate function so tha it has the 10 | ;; name `make-posn': 11 | (define (make-posn x y) (posn x y)) 12 | -------------------------------------------------------------------------------- /whalesong/lang/private/call-ec.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../kernel.rkt" 2 | 3 | (require (for-syntax racket/base 4 | syntax/parse)) 5 | 6 | (provide call-with-escape-continuation 7 | call/ec 8 | let/ec) 9 | 10 | 11 | (define (call-with-escape-continuation proc) 12 | (define p (make-continuation-prompt-tag 'escape)) 13 | (call-with-continuation-prompt 14 | (lambda () 15 | (proc (lambda args 16 | (unless (continuation-prompt-available? p) 17 | (error 'call-with-escape-continuation 18 | "escape continuation used out of context")) 19 | (abort-current-continuation p (lambda () 20 | (apply values args)))))) 21 | p)) 22 | 23 | (define call/ec (procedure-rename call-with-escape-continuation 'call/ec)) 24 | 25 | 26 | (define-syntax (let/ec stx) 27 | (syntax-parse stx 28 | [(_ name:id body:expr ...+) 29 | (syntax/loc stx 30 | (call-with-escape-continuation (lambda (name) 31 | body ...)))])) 32 | -------------------------------------------------------------------------------- /whalesong/lang/private/hash.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../kernel.rkt" 2 | 3 | (provide hash-map hash-for-each) 4 | 5 | (define (hash-map a-hash f) 6 | (unless (hash? a-hash) 7 | (raise-type-error 'hash-map "hash" a-hash)) 8 | (unless (and (procedure? f) (procedure-arity-includes? f 2)) 9 | (raise-type-error 'hash-map "procedure (arity 2)" f)) 10 | (let loop ([keys (hash-keys a-hash)]) 11 | (if (null? keys) 12 | '() 13 | (cons (f (car keys) (hash-ref a-hash (car keys))) 14 | (loop (cdr keys)))))) 15 | 16 | 17 | (define (hash-for-each a-hash f) 18 | (unless (hash? a-hash) 19 | (raise-type-error 'hash-for-each "hash" a-hash)) 20 | (unless (and (procedure? f) (procedure-arity-includes? f 2)) 21 | (raise-type-error 'hash-for-each "procedure (arity 2)" f)) 22 | (let loop ([keys (hash-keys a-hash)]) 23 | (if (null? keys) 24 | (void) 25 | (begin 26 | (f (car keys) (hash-ref a-hash (car keys))) 27 | (loop (cdr keys)))))) 28 | 29 | 30 | -------------------------------------------------------------------------------- /whalesong/lang/private/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define compile-omit-paths '("shared-body.rkt")) 4 | -------------------------------------------------------------------------------- /whalesong/lang/private/shared.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../kernel.rkt" 2 | 3 | (require (for-syntax scheme/base 4 | syntax/stx 5 | syntax/kerncase 6 | syntax/struct 7 | racket/struct-info 8 | scheme/include) 9 | "traced-app.rkt") 10 | 11 | (provide shared) 12 | 13 | (define-for-syntax code-insp (current-code-inspector)) 14 | 15 | (define undefined (letrec ([x x]) x)) 16 | (require (only-in "../kernel.rkt" [cons the-cons])) 17 | 18 | (define-syntax shared 19 | (lambda (stx) 20 | (define make-check-cdr #f) 21 | ;; Include the implementation. 22 | ;; See shared-body.rkt. 23 | (include "shared-body.rkt"))) 24 | -------------------------------------------------------------------------------- /whalesong/lang/private/traced-app.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../kernel.rkt" 2 | 3 | (require (for-syntax racket/base)) 4 | 5 | (provide traced-app traced-app-key traced-callee-key) 6 | 7 | (define traced-app-key (gensym 'traced-app-key)) 8 | (define traced-callee-key (gensym 'traced-callee-key)) 9 | 10 | 11 | (define-syntax-parameter traced-app 12 | (lambda (stx) 13 | (syntax-case stx () 14 | [(_ operator operands ...) 15 | (with-syntax ([key #'traced-app-key] 16 | [pos (vector (format "~s" (syntax-source stx)) 17 | (syntax-position stx) 18 | (syntax-line stx) 19 | (syntax-column stx) 20 | (syntax-span stx))]) 21 | (syntax/loc stx 22 | (with-continuation-mark key 'pos 23 | (#%plain-app operator operands ...))))] 24 | [(_) 25 | (syntax/loc stx 26 | (#%app))]))) 27 | -------------------------------------------------------------------------------- /whalesong/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | 3 | ;; http://docs.racket-lang.org/planet/hash-lang-planet.html 4 | 5 | #:language (lambda (ip) 6 | `(file ,(path->string whalesong-lang-path))) 7 | 8 | (require racket/runtime-path) 9 | (define-runtime-path whalesong-lang-path "whalesong.rkt") 10 | -------------------------------------------------------------------------------- /whalesong/lang/unsafe/js-impl.js: -------------------------------------------------------------------------------- 1 | 2 | EXPORTS['unsafe-car'] = 3 | plt.baselib.functions.makePrimitiveProcedure( 4 | 'unsafe-car', 5 | 1, 6 | function(MACHINE) { 7 | return MACHINE.e[MACHINE.e.length - 1].first; 8 | }); 9 | 10 | 11 | EXPORTS['unsafe-cdr'] = 12 | plt.baselib.functions.makePrimitiveProcedure( 13 | 'unsafe-cdr', 14 | 1, 15 | function(MACHINE) { 16 | return MACHINE.e[MACHINE.e.length - 1].rest; 17 | }); 18 | -------------------------------------------------------------------------------- /whalesong/lang/unsafe/ops.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../js/js.rkt" 2 | 3 | (declare-implementation 4 | #:racket "racket-impl.rkt" 5 | #:javascript ("js-impl.js") 6 | #:provided-values (unsafe-car 7 | unsafe-cdr)) 8 | -------------------------------------------------------------------------------- /whalesong/lang/unsafe/racket-impl.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (only-in '#%unsafe unsafe-car unsafe-cdr)) 4 | (provide unsafe-car unsafe-cdr) 5 | -------------------------------------------------------------------------------- /whalesong/language-namespace.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide lookup-language-namespace) 5 | 6 | 7 | 8 | 9 | (define language-namespace-cache (make-hash)) 10 | ;; lookup-language-namespace: module-path -> namespace 11 | ;; Returns a namespace associated with the lang. 12 | (define (lookup-language-namespace lang) 13 | (hash-ref language-namespace-cache lang 14 | (lambda () 15 | (let ([ns (make-base-empty-namespace)]) 16 | (parameterize ([current-namespace ns]) 17 | (namespace-require lang)) 18 | (hash-set! language-namespace-cache lang ns) 19 | ns)))) 20 | -------------------------------------------------------------------------------- /whalesong/logger.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | racket/list) 4 | 5 | ;; A small module to provide logging for Whalesong. 6 | 7 | 8 | (provide whalesong-logger) 9 | 10 | (define whalesong-logger (make-logger 'whalesong)) 11 | 12 | 13 | (define (log-debug message . args) 14 | (log-message whalesong-logger 15 | 'debug 16 | (if (empty? args) message (apply format message args)) 17 | #f)) 18 | 19 | 20 | (define (log-warning message . args) 21 | (log-message whalesong-logger 22 | 'warning 23 | (if (empty? args) message (apply format message args)) 24 | #f)) 25 | 26 | (define (log-error message . args) 27 | (log-message whalesong-logger 28 | 'error 29 | (if (empty? args) message (apply format message args)) 30 | #f)) 31 | 32 | 33 | 34 | (define should-print-logs? #f) 35 | (define (set-whalesong-log-printing! v) 36 | (set! should-print-logs? v)) 37 | 38 | (void (thread (lambda () 39 | (let ([receiver 40 | (make-log-receiver whalesong-logger 'debug)]) 41 | (let loop () 42 | (let ([msg (sync receiver)]) 43 | (when should-print-logs? 44 | (match msg 45 | [(vector level msg data) 46 | (printf "~a: ~a\n" level msg)])) 47 | (loop))))))) 48 | 49 | 50 | 51 | 52 | (provide whalesong-logger log-debug log-warning log-error 53 | set-whalesong-log-printing!) -------------------------------------------------------------------------------- /whalesong/make-planet-archive.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | MAJOR=1 3 | MINOR=21 4 | PROJNAME=whalesong 5 | 6 | 7 | OLDDIR=`pwd` 8 | mkdir -p tmp 9 | rm -rf tmp/$PROJNAME 10 | echo "Checking out clean repo" 11 | git archive --format=tar --prefix=$PROJNAME/ HEAD | (cd tmp && tar xf -) 12 | 13 | ## Remove any directories that we don't want as part of the repository. 14 | rm -rf $OLDDIR/tmp/whalesong/experiments 15 | rm -rf $OLDDIR/tmp/whalesong/notes 16 | rm -rf $OLDDIR/tmp/whalesong/simulator 17 | rm -rf $OLDDIR/tmp/whalesong/sandbox 18 | rm -rf $OLDDIR/tmp/whalesong/tests 19 | 20 | 21 | cd $OLDDIR/tmp 22 | 23 | raco planet unlink dyoo $PROJNAME.plt $MAJOR $MINOR 24 | raco planet link dyoo $PROJNAME.plt $MAJOR $MINOR $PROJNAME 25 | echo "Making planet package" 26 | raco planet create $PROJNAME 27 | 28 | raco planet unlink dyoo $PROJNAME.plt $MAJOR $MINOR 29 | 30 | cd $OLDDIR 31 | cp tmp/$PROJNAME.plt . -------------------------------------------------------------------------------- /whalesong/make/get-dependencies.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | (require "../compiler/expression-structs.rkt" 3 | "../compiler/lexical-structs.rkt" 4 | "../sets.rkt") 5 | 6 | ;; Collect the complete list of dependencies for a module. 7 | 8 | 9 | (provide get-dependencies 10 | expression-module-path) 11 | 12 | 13 | (: get-dependencies (Expression -> (Listof ModuleLocator))) 14 | (define (get-dependencies expr) 15 | (let ([deps ((inst new-set ModuleLocator))]) 16 | (let: visit : 'ok ([expr : Expression expr]) 17 | (cond 18 | [(Top? expr) 19 | (visit (Top-code expr)) 20 | 'ok] 21 | [(Module? expr) 22 | (for-each (lambda: ([mn : ModuleLocator]) 23 | (set-insert! deps mn)) 24 | (Module-requires expr)) 25 | 'ok] 26 | [else 27 | 'ok])) 28 | (set->list deps))) 29 | 30 | 31 | (: expression-module-path (Expression -> (U False ModuleLocator))) 32 | ;; Given a toplevel expression of a module, returns its self-declared ModuleLocator. 33 | ;; If we can't find one, return false. 34 | (define (expression-module-path expr) 35 | (cond 36 | [(Top? expr) 37 | (expression-module-path (Top-code expr))] 38 | [(Module? expr) 39 | (Module-path expr)] 40 | [else 41 | #f])) -------------------------------------------------------------------------------- /whalesong/parser/modprovide.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | "../compiler/expression-structs.rkt") 4 | 5 | (provide get-provided-names) 6 | 7 | ;; get-provided-names: bytecode -> (listof ModuleProvide) 8 | (define (get-provided-names bytecode) 9 | (match bytecode 10 | [(struct Top [_ (struct Module (name path prefix requires provides code))]) 11 | provides] 12 | [else 13 | '()])) 14 | -------------------------------------------------------------------------------- /whalesong/parser/where-is-collects.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | (require/typed racket/path 3 | (normalize-path (Path -> Path))) 4 | 5 | (provide collects-path) 6 | 7 | (define collects-path 8 | (normalize-path 9 | (let: ([p : Path (find-system-path 'collects-dir)]) 10 | (cond 11 | [(relative-path? p) 12 | (define maybe-path (find-executable-path (find-system-path 'exec-file) 13 | (find-system-path 'collects-dir))) 14 | (cond 15 | [(path? maybe-path) 16 | maybe-path] 17 | [else 18 | (error 'collects-path "Could not find collects path")])] 19 | [else 20 | p])))) 21 | -------------------------------------------------------------------------------- /whalesong/promise.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | (require (for-syntax racket/base)) 3 | 4 | ;; Working around what appears to be a bug in Typed Racket 5 | ;; by implementing my own promises. 6 | 7 | (provide my-delay my-force MyPromise) 8 | 9 | 10 | (define-struct: Sentinel ()) 11 | 12 | 13 | (define-struct: (a) MyPromise ([forced? : Boolean] 14 | [thunk : (-> a)] 15 | [val : (U Sentinel a)]) 16 | #:mutable) 17 | 18 | 19 | (define-syntax (my-delay stx) 20 | (syntax-case stx () 21 | [(_ expr ...) 22 | (syntax/loc stx 23 | (make-MyPromise #f 24 | (lambda () expr ...) 25 | (make-Sentinel)))])) 26 | 27 | (: my-force (All (a) (MyPromise a) -> a)) 28 | (define (my-force a-promise) 29 | (cond 30 | [(MyPromise-forced? a-promise) 31 | (define val (MyPromise-val a-promise)) 32 | (if (Sentinel? val) 33 | (error 'force "Impossible") 34 | val)] 35 | [else 36 | (define val ((MyPromise-thunk a-promise))) 37 | (set-MyPromise-val! a-promise val) 38 | (set-MyPromise-forced?! a-promise #t) 39 | val])) -------------------------------------------------------------------------------- /whalesong/repl-prototype/README: -------------------------------------------------------------------------------- 1 | This is an experiment in the dynamic evaluation of whalesong-generated 2 | code. 3 | 4 | ---------------------------------------------------------------------- 5 | 6 | 1. Run 'write-runtime.rkt'. This generates the runtime.js and 7 | library.js files in htdocs/collects. At the moment, the only files 8 | written out are those that support whalesong/wescheme, though to make 9 | this work, we'll want to parameterize write-runtime.rkt so it can take 10 | in the name of the languages that the REPL should know about. 11 | 12 | 2. Start the sandboxed server. Run sandboxed-server.rkt. 13 | 14 | Warning: you may need to first "raco make" both "sandboxed-server.rkt" 15 | and "server.rkt", because the Racket compilation may otherwise hit the 16 | memory ceiling imposed by the sandbox itself! 17 | 18 | ---------------------------------------------------------------------- 19 | 20 | TODO: 21 | 22 | 1. Parameterize write-runtime so it can take in a list of the 23 | language modules we need to compile. Similarly, parameterize 24 | sandbox-server.rkt so it knows which languages to allow. 25 | 26 | 2. Allow non-sexp-based language support. Currently, there's a nasty 27 | location bug in Racket 5.3.3's module-reader that makes us lose 28 | location information. I'm considering just forking a copy of the 29 | module reader just so we're not blocked on waiting for Racket 5.3.4, 30 | either that or losing location information altogether. -------------------------------------------------------------------------------- /whalesong/repl-prototype/htdocs/break.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dyoo/whalesong/636e0b4e399e4523136ab45ef4cd1f5a84e88cdc/whalesong/repl-prototype/htdocs/break.png -------------------------------------------------------------------------------- /whalesong/repl-prototype/htdocs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 |

Repl experiment

12 | 13 | 14 |
15 | 16 |
17 |
18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /whalesong/repl-prototype/htdocs/rpc.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | rpc 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /whalesong/repl-prototype/htdocs/tests.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 |

Repl tests

14 |

This page tests the behavior of REPL compilation.

15 | 16 |
17 |
18 |
Failures:
19 |
20 |
21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /whalesong/repl-prototype/htdocs/tests.js: -------------------------------------------------------------------------------- 1 | jQuery(document).ready(function() { 2 | "use strict"; 3 | 4 | plt.tests.initTests(function(runTests) { 5 | runTests(function() { $("#is-running").text( 6 | "Tests finished. " + 7 | plt.tests.getTestsRunCount() + " tests executed."); }); 8 | }); 9 | }); 10 | 11 | -------------------------------------------------------------------------------- /whalesong/repl-prototype/htdocs/torture-tests.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 |

Repl tests

14 |

This page tests the behavior of REPL compilation under repeated 15 | usage. This should just run forever.

16 | 17 |
18 |
19 |
Failures:
20 |
21 |
22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /whalesong/repl-prototype/htdocs/torture-tests.js: -------------------------------------------------------------------------------- 1 | jQuery(document).ready(function() { 2 | "use strict"; 3 | var i = 0; 4 | // Torture test: keep rerunning the tests over and over. 5 | plt.tests.initTests(function(runTests) { 6 | var k = function() { 7 | i = i + 1; 8 | $("#is-running").text( 9 | "Pass " + i + ": " + 10 | plt.tests.getTestsRunCount() + " tests executed."); 11 | setTimeout( 12 | function() { 13 | plt.tests.resetTests(); 14 | runTests(k); 15 | }, 16 | 0); 17 | }; 18 | 19 | runTests(k); 20 | }); 21 | }); 22 | 23 | -------------------------------------------------------------------------------- /whalesong/resource.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "lang/kernel.rkt" 2 | 3 | (require "resource/main.rkt") 4 | (provide (all-from-out "resource/main.rkt")) 5 | -------------------------------------------------------------------------------- /whalesong/resource/coerse-content-bytes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide coerse-content-bytes) 4 | 5 | ;; We need at least version 1.2 of the html-parsing library, because 6 | ;; there's a nasty bug in 1.0. 7 | (require (planet neil/html-parsing:1:2) 8 | (planet neil/html-writing)) 9 | 10 | ;; coerse-content-bytes: path bytes -> bytes 11 | ;; Given some bytes, we may need to do some data validation or cleanup. 12 | ;; In particular, when the file's HTML, we need to make sure we're 13 | ;; storing syntactically valid HTML. 14 | (define (coerse-content-bytes a-path bytes) 15 | (cond 16 | [(regexp-match #rx"\\.html$" 17 | (path->string a-path)) 18 | (define op (open-output-bytes)) 19 | (write-html (html->xexp (open-input-bytes bytes)) op) 20 | (get-output-bytes op)] 21 | [else 22 | bytes])) -------------------------------------------------------------------------------- /whalesong/resource/js-impl.js: -------------------------------------------------------------------------------- 1 | var resourceType = MACHINE.modules['whalesong/resource/structs.rkt'].getExternalExports().get('struct:resource'); 2 | 3 | var makePrimitiveProcedure = plt.baselib.functions.makePrimitiveProcedure; 4 | 5 | var checkResource = plt.baselib.check.makeCheckArgumentType( 6 | resourceType.predicate, 7 | "resource"); 8 | 9 | var getResourcePath = function(r) { return resourceType.accessor(r, 0); }; 10 | var getResourceKey = function(r) { return resourceType.accessor(r, 1); }; 11 | 12 | 13 | 14 | EXPORTS['resource->url'] = makePrimitiveProcedure( 15 | 'resource->url', 16 | 1, 17 | function(MACHINE) { 18 | var resource = checkResource(MACHINE, 'resource->url', 0); 19 | return String(getResourceKey(resource)); 20 | }); 21 | -------------------------------------------------------------------------------- /whalesong/resource/main.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/kernel.rkt" 2 | 3 | (require "compile-time.rkt" 4 | "runtime.rkt" 5 | "structs.rkt") 6 | (provide (all-from-out "compile-time.rkt" 7 | "runtime.rkt") 8 | resource?) 9 | -------------------------------------------------------------------------------- /whalesong/resource/munge-path.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require net/base64 3 | file/md5) 4 | 5 | (provide munge-path) 6 | 7 | ;; munge-path: path -> string 8 | ;; 9 | ;; Given a path, gives a munged base path string. 10 | (define (munge-path a-path) 11 | (define encoding-prefix (let ([op (open-output-string)]) 12 | (base64-encode-stream (open-input-bytes 13 | (md5 (path->string (build-path a-path)))) 14 | op 15 | "") 16 | (get-output-string op))) 17 | (define-values (base path dir?) (split-path a-path)) 18 | (string-append ;; encoding-prefix "_" 19 | (path->string path))) 20 | -------------------------------------------------------------------------------- /whalesong/resource/query.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/runtime-path 5 | syntax/modresolve 6 | racket/path 7 | "structs.rkt" 8 | ;; racket/gui/base 9 | ) 10 | 11 | 12 | (provide/contract [query (module-path? . -> . (listof resource?))]) 13 | 14 | (define-runtime-path record.rkt "record.rkt") 15 | (define ns (make-base-namespace)) 16 | 17 | ;; query: module-path -> (listof record) 18 | ;; Given a module, collect all of its resource records 19 | (define (query a-module-path) 20 | (let ([resolved-path (normalize-path (resolve-module-path a-module-path #f))]) 21 | (parameterize ([current-namespace ns]) 22 | (dynamic-require resolved-path (void)) ;; get the compile-time code running. 23 | ((dynamic-require-for-syntax record.rkt 'get-records) resolved-path)))) 24 | -------------------------------------------------------------------------------- /whalesong/resource/racket-impl.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide resource->url) 3 | 4 | (require "structs.rkt" 5 | net/url) 6 | 7 | 8 | ;; resource->url: resource -> string 9 | (define (resource->url r) 10 | (url->string (path->url (resource-path r)))) 11 | -------------------------------------------------------------------------------- /whalesong/resource/record.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide record-resource 4 | get-records) 5 | 6 | 7 | ;; Needs to be prefabricated 8 | (struct resource (path key content) #:prefab) 9 | 10 | 11 | (define records (make-hash)) 12 | 13 | (define (get-records a-path) 14 | (hash-ref records a-path '())) 15 | 16 | 17 | ;; Hack to work around bug that should be fixed after 5.1.3. The dynamic 18 | ;; require-for-syntax stuff isn't quite working right, which means 19 | ;; we can't use (require racket/port) here. 20 | (define (port->bytes p) 21 | (define out (open-output-bytes)) 22 | (let loop () 23 | (define b (read-byte p)) 24 | (cond 25 | [(eof-object? b) 26 | (get-output-bytes out)] 27 | [else 28 | (write-byte b out) 29 | (loop)]))) 30 | 31 | 32 | ;; record-javascript-implementation!: path path a-resource-path -> void 33 | (define (record-resource a-module-path a-resource-path a-key) 34 | (hash-set! records a-module-path 35 | (cons (resource a-resource-path a-key (call-with-input-file a-resource-path 36 | port->bytes)) 37 | (hash-ref records a-module-path '())))) 38 | -------------------------------------------------------------------------------- /whalesong/resource/runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/js/js.rkt" 2 | 3 | (require "structs.rkt") 4 | 5 | (declare-implementation 6 | #:racket "racket-impl.rkt" 7 | #:javascript ("js-impl.js") 8 | #:provided-values (resource->url)) 9 | 10 | -------------------------------------------------------------------------------- /whalesong/resource/specialize/impl.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/js/js.rkt" 2 | 3 | (require "../structs.rkt") 4 | 5 | (declare-implementation 6 | #:racket "racket-impl.rkt" 7 | #:javascript ("js-impl.js") 8 | #:provided-values (specialize!)) 9 | -------------------------------------------------------------------------------- /whalesong/resource/specialize/racket-impl.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide specialize!) 3 | 4 | (define (specialize! resource) 5 | resource) 6 | -------------------------------------------------------------------------------- /whalesong/resource/structs.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/kernel.rkt" 2 | 3 | (provide (all-defined-out)) 4 | 5 | ;; Needs to be prefabricated 6 | (struct resource (path key content) #:prefab) 7 | -------------------------------------------------------------------------------- /whalesong/sandbox/monty-hall/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 |

The Monty Hall game

8 | 9 |
10 |
Door 1
11 | 12 |
Door 2
13 | 14 |
Door 3
15 |
16 | 17 | 18 |
Messages will be written here.
19 | 20 | 21 |
22 | Change your answer? 23 | 24 | 25 |
26 | 27 |
More messages will be written here.
28 | 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /whalesong/sandbox/monty-hall/monty-hall.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/web-world 4 | whalesong/resource) 5 | 6 | (define-resource index.html) 7 | 8 | 9 | ;; The world consists of the doors, and at what point in the 10 | ;; game we're in. 11 | (define-struct door (opened? has-treasure?)) 12 | (define-struct world (stage door1 door2 door3)) 13 | 14 | 15 | ;; open-door: door -> door 16 | (define (open-door door) 17 | (make-door #t (door-has-treasure? door))) 18 | 19 | 20 | ;; new-world: -> world 21 | ;; Creates a world where all the doors are closed, and 22 | ;; behind one of the doors is the treasure. 23 | (define (new-world) 24 | (define with-treasure (random 3)) 25 | (make-world (make-door #f (= with-treasure 0)) 26 | (make-door #f (= with-treasure 1)) 27 | (make-door #f (= with-treasure 2)))) 28 | 29 | 30 | -------------------------------------------------------------------------------- /whalesong/sandbox/monty-hall/style.css: -------------------------------------------------------------------------------- 1 | .openedDoor { 2 | color: green; 3 | display: inline; 4 | 5 | padding: 20px; 6 | } 7 | 8 | .closedDoor { 9 | color: blue; 10 | display: inline; 11 | 12 | padding: 20px; 13 | } 14 | 15 | #doors { 16 | border: 1px solid black; 17 | } 18 | 19 | #message1 { 20 | opacity: 0.4; 21 | } 22 | 23 | #switch { 24 | opacity: 0.4; 25 | } 26 | 27 | #message2 { 28 | opacity: 0.4; 29 | } 30 | 31 | #restart { 32 | } -------------------------------------------------------------------------------- /whalesong/sandbox/sample-run.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require whalesong/get-module-bytecode 3 | whalesong/parser/parse-bytecode 4 | whalesong/compiler/compiler 5 | whalesong/compiler/compiler-structs 6 | whalesong/js-assembler/assemble) 7 | 8 | (define bytecode 9 | (get-module-bytecode 10 | (open-input-string 11 | (string-append "#lang whalesong\n" 12 | "(define (f x)\n" 13 | " (if (= x 0)\n" 14 | " 1\n" 15 | " (* x (f (sub1 x)))))\n\n" 16 | "(provide f)")))) 17 | 18 | (define ast (parse-bytecode (open-input-bytes bytecode))) 19 | 20 | (define stmts (compile ast 'val next-linkage/drop-multiple)) 21 | 22 | (define op (open-output-string)) 23 | (assemble/write-invoke stmts op) 24 | (define js-code (get-output-string op)) 25 | -------------------------------------------------------------------------------- /whalesong/sandbox/test-storage.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/storage) 4 | 5 | (storage-length) 6 | (storage-ref "whalesong test") 7 | (storage-set! "whalesong test" "hello world") 8 | (storage-ref "whalesong test") 9 | (storage-length) 10 | (storage-key 0) 11 | (storage-clear!) 12 | (storage-length) 13 | 14 | 15 | (storage-clear!) 16 | (storage-set! "name" "Danny") 17 | (storage-set! "advisor" "sk") 18 | (storage-set! "advisor" "kathi") 19 | (storage-length) 20 | (storage-key 0) 21 | (storage-key 1) 22 | (storage-remove! "advisor") 23 | (storage-length) 24 | (storage-key 0) 25 | (storage-remove! "name") 26 | (storage-length) 27 | (storage-clear!) 28 | -------------------------------------------------------------------------------- /whalesong/sandbox/todo-storage/index.html: -------------------------------------------------------------------------------- 1 | 2 | TODO List 3 | 4 |

TODO

5 | 6 |

Items

7 |
    8 | 9 | 10 |

    Adding an item

    11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /whalesong/scribblings/scribble-helpers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide inject-javascript-inline 4 | inject-javascript-src 5 | inject-empty-span-with-id) 6 | 7 | (require scribble/core 8 | scribble/html-properties 9 | scriblib/render-cond) 10 | 11 | 12 | 13 | ;; Adds JavaScript if we're rendering in HTML. 14 | (define (inject-javascript-inline . body) 15 | (cond-element 16 | [latex ""] 17 | [html (make-element (make-style #f (list (make-script-property "text/javascript" 18 | body))) 19 | '())] 20 | [text ""])) 21 | 22 | 23 | (define (inject-javascript-src src) 24 | (cond-element 25 | [latex ""] 26 | [html 27 | (make-element 28 | (make-style #f 29 | (list 30 | (make-alt-tag "script") 31 | (make-attributes 32 | `((type . "text/javascript") 33 | (src . ,src))))) 34 | '())] 35 | 36 | [text ""])) 37 | 38 | 39 | (define (inject-empty-span-with-id id) 40 | (cond-element 41 | [latex ""] 42 | [html 43 | (make-element 44 | (make-style #f 45 | (list 46 | (make-alt-tag "span") 47 | (make-attributes 48 | `((id . , id))))) 49 | '())] 50 | 51 | [text ""])) 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | ;;(define (google-analytics) 60 | ;; (make-tag -------------------------------------------------------------------------------- /whalesong/simply-scheme/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | #:language (lambda (ip) 'whalesong/simply-scheme/semantics) 3 | -------------------------------------------------------------------------------- /whalesong/storage.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "lang/base.rkt" 2 | (require "storage/storage.rkt") 3 | (provide (all-from-out "storage/storage.rkt")) -------------------------------------------------------------------------------- /whalesong/storage/storage.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | 3 | ;; Bindings to HTML5 storage 4 | ;; http://dev.w3.org/html5/webstorage/ 5 | 6 | 7 | (require "../js.rkt") 8 | 9 | (provide storage-length 10 | storage-key 11 | storage-ref 12 | storage-set! 13 | storage-remove! 14 | storage-clear!) 15 | 16 | 17 | (define localStorage (get-attr window "localStorage")) 18 | 19 | (define (storage-length) 20 | (inexact->exact (js-number->number (get-attr localStorage "length")))) 21 | 22 | (define (storage-key i) 23 | (unless (exact-nonnegative-integer? i) 24 | (raise-type-error 'storage-key "natural" i)) 25 | (js-string->string (call-method localStorage "key" (number->js-number i)))) 26 | 27 | (define (storage-ref name) 28 | (unless (string? name) 29 | (raise-type-error 'storage-ref "string" name)) 30 | (define val (call-method localStorage "getItem" (string->js-string name))) 31 | (if (js-null? val) 32 | #f 33 | (js-string->string val))) 34 | 35 | (define (storage-set! name value) 36 | (unless (string? name) 37 | (raise-type-error 'storage-set! "string" name 0)) 38 | (unless (string? value) 39 | (raise-type-error 'storage-set! "string" value 1)) 40 | (void (call-method localStorage "setItem" 41 | (string->js-string name) 42 | (string->js-string value)))) 43 | 44 | (define (storage-remove! name) 45 | (unless (string? name) 46 | (raise-type-error 'storage-remove! "string" name)) 47 | (void (call-method localStorage "removeItem" 48 | (string->js-string name)))) 49 | 50 | (define (storage-clear!) 51 | (void (call-method localStorage "clear"))) -------------------------------------------------------------------------------- /whalesong/tests/clipart-test/dog.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dyoo/whalesong/636e0b4e399e4523136ab45ef4cd1f5a84e88cdc/whalesong/tests/clipart-test/dog.jpg -------------------------------------------------------------------------------- /whalesong/tests/coersing/Makefile: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | all: 4 | ../../whalesong get-javascript --verbose fact.rkt > fact.js 5 | ../../whalesong get-runtime --verbose > runtime.js 6 | -------------------------------------------------------------------------------- /whalesong/tests/coersing/fact.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (provide fact) 3 | (define (fact x) 4 | (cond 5 | [(= x 0) 6 | 1] 7 | [else 8 | (* x (fact (sub1 x)))])) 9 | 10 | 11 | ;;(printf "test: ~s\n" (fact 4)) 12 | -------------------------------------------------------------------------------- /whalesong/tests/coersing/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 27 | 28 | 29 | 30 | The factorial of 10000 is being computed. 31 | 32 | 33 | -------------------------------------------------------------------------------- /whalesong/tests/module-test/m1.rkt: -------------------------------------------------------------------------------- 1 | (module m1 '#%kernel 2 | (#%require "m2.rkt")) -------------------------------------------------------------------------------- /whalesong/tests/module-test/m2.rkt: -------------------------------------------------------------------------------- 1 | (module m2 '#%kernel 2 | (display "hello world") 3 | (newline)) -------------------------------------------------------------------------------- /whalesong/tests/more-tests/basics-cs019.expected: -------------------------------------------------------------------------------- 1 | Running tests... 2 | All 11 tests passed! 3 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/booleans-cs019.appcache: -------------------------------------------------------------------------------- 1 | CACHE MANIFEST 2 | ## Timestamp: Monday, October 3rd, 2011 3:49:42pm 3 | booleans-cs019.js 4 | optimer-normal-normal.js 5 | canvas.text.js 6 | excanvas.js 7 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/booleans-cs019.expected: -------------------------------------------------------------------------------- 1 | false 2 | true 3 | false 4 | false 5 | false 6 | false 7 | false 8 | true 9 | false 10 | true 11 | false 12 | false 13 | true 14 | true 15 | false 16 | false 17 | true 18 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/booleans-cs019.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/cs019 2 | 3 | 4 | (boolean? "t") 5 | (boolean? #t) 6 | (boolean? 0) 7 | (boolean? #\t) 8 | 9 | (char? "t") 10 | (char? #t) 11 | (char? 0) 12 | (char? #\t) 13 | 14 | (char=? #\a #\b) 15 | (char=? #\a #\a) 16 | (char=? #\a #\a #\b) 17 | (char=? #\a #\b #\a) 18 | (char=? #\a #\a #\a) 19 | 20 | true 21 | false 22 | (false? true) 23 | (false? false) 24 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/booleans.expected: -------------------------------------------------------------------------------- 1 | false 2 | true 3 | false 4 | false 5 | false 6 | false 7 | false 8 | true 9 | false 10 | true 11 | false 12 | false 13 | true 14 | true 15 | false 16 | false 17 | true 18 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/booleans.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | (require whalesong/lang/bool) 3 | 4 | (boolean? "t") 5 | (boolean? #t) 6 | (boolean? 0) 7 | (boolean? #\t) 8 | 9 | (char? "t") 10 | (char? #t) 11 | (char? 0) 12 | (char? #\t) 13 | 14 | (char=? #\a #\b) 15 | (char=? #\a #\a) 16 | (char=? #\a #\a #\b) 17 | (char=? #\a #\b #\a) 18 | (char=? #\a #\a #\a) 19 | 20 | true 21 | false 22 | (false? true) 23 | (false? false) 24 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/chars.expected: -------------------------------------------------------------------------------- 1 | #\A 2 | #\B 3 | #\C 4 | #\A 5 | #\B 6 | #\C 7 | #\a 8 | #\b 9 | #\c 10 | #\a 11 | #\b 12 | #\c 13 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/chars.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | (char-upcase #\a) 4 | (char-upcase #\b) 5 | (char-upcase #\c) 6 | (char-upcase #\A) 7 | (char-upcase #\B) 8 | (char-upcase #\C) 9 | 10 | (char-downcase #\a) 11 | (char-downcase #\b) 12 | (char-downcase #\c) 13 | (char-downcase #\A) 14 | (char-downcase #\B) 15 | (char-downcase #\C) 16 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/checking-cs019.expected: -------------------------------------------------------------------------------- 1 | Running tests... 2 | check-expect: actual value "hello huh" differs from "this should fail", the expected value 3 | at: #, line 7, column 0 4 | Ran 3 tests. 5 | 2 tests passed. 6 | One test failed. 7 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/checking-cs019.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/cs019 2 | 3 | (define (greet name) 4 | (string-append "hello " name)) 5 | 6 | (check-expect (greet "danny") "hello danny") 7 | (check-expect (greet "huh") "this should fail") 8 | (check-expect (greet "world") "hello world") 9 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/checking.expected: -------------------------------------------------------------------------------- 1 | Running tests... 2 | check-expect: actual value "hello huh" differs from "this should fail", the expected value 3 | at: #, line 7, column 0 4 | Ran 3 tests. 5 | 2 tests passed. 6 | One test failed. 7 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/checking.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (define (greet name) 4 | (string-append "hello " name)) 5 | 6 | (check-expect (greet "danny") "hello danny") 7 | (check-expect (greet "huh") "this should fail") 8 | (check-expect (greet "world") "hello world") 9 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/colors.expected: -------------------------------------------------------------------------------- 1 | (color 3 4 5 0) 2 | (color 3 5 7 0) 3 | 3 4 | 1 5 | 4 6 | 5 7 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/colors.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | (require whalesong/image) 4 | (color 3 4 5 0) 5 | (make-color 3 5 7 0) 6 | 7 | 8 | (define c1 (color 3 1 4 5)) 9 | (color-red c1) 10 | (color-green c1) 11 | (color-blue c1) 12 | (color-alpha c1) 13 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/conform.expected: -------------------------------------------------------------------------------- 1 | 6 -> 26 -> 16 2 | 16 -> 132 -> 30 3 | 30 -> 374 -> 31 4 | 31 -> 119 5 | ok. 6 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/cont-marks-1.expected: -------------------------------------------------------------------------------- 1 | () 2 | (3628800) 3 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/cont-marks-1.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (define (puzzle n) 4 | (if (= n 0) 5 | (continuation-mark-set->list (current-continuation-marks) 'secret) 6 | (with-continuation-mark 'secret 7 | (* n (first (continuation-mark-set->list (current-continuation-marks) 'secret))) 8 | (puzzle (sub1 n))))) 9 | 10 | (continuation-mark-set->list (current-continuation-marks) 'secret) 11 | 12 | (with-continuation-mark 'secret 1 13 | (puzzle 10)) 14 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/cont-marks-2.expected: -------------------------------------------------------------------------------- 1 | () 2 | (3628800) 3 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/cont-marks-2.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | (define (puzzle n) 4 | (if (= n 0) 5 | (continuation-mark-set->list (current-continuation-marks) 'secret) 6 | (with-continuation-mark 'secret 7 | (* n (first (continuation-mark-set->list (current-continuation-marks) 'secret))) 8 | (puzzle (sub1 n))))) 9 | 10 | (continuation-mark-set->list (current-continuation-marks) 'secret) 11 | 12 | (with-continuation-mark 'secret 1 13 | (puzzle 10)) 14 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/divide-by-zero-with-handlers.expected: -------------------------------------------------------------------------------- 1 | I see "/: division by zero" 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/divide-by-zero-with-handlers.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (with-handlers ([exn:fail? 4 | (lambda (exn) 5 | (printf "I see ~s\n" (exn-message exn)))]) 6 | (/ 1 0)) 7 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/dots-should-be-syntax-error.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/cs019 2 | 3 | .. ;; should raise a teaching syntax error 4 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/earley.expected: -------------------------------------------------------------------------------- 1 | 58786 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/exn-1.expected: -------------------------------------------------------------------------------- 1 | "nested catch" 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/exn-1.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | 4 | (with-handlers ([exn:fail? 5 | (lambda (exn) 6 | "nested catch")]) 7 | (with-handlers ([exn:fail? 8 | (lambda (exn) 9 | (raise exn))]) 10 | (/ 1 0))) 11 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/exn-2.expected: -------------------------------------------------------------------------------- 1 | +inf.0 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/exn-2.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (with-handlers ([exn:fail:contract? 3 | (lambda (exn) +inf.0)]) 4 | (/ 1 0)) 5 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/exn-3.expected: -------------------------------------------------------------------------------- 1 | Error: car: expected pair as argument 1 but received 17 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/exn-3.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (with-handlers ([(lambda (exn) #f) 4 | (lambda (exn) +inf.0)]) 5 | (car 17)) 6 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/fact.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (define (fact x) 3 | (cond 4 | [(= x 0) 5 | 1] 6 | [else 7 | (* x (fact (sub1 x)))])) 8 | (fact 1) 9 | (fact 10) 10 | (fact 100) 11 | (fact 1000) 12 | (fact 10000) 13 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/fft.expected: -------------------------------------------------------------------------------- 1 | true 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/fringe.expected: -------------------------------------------------------------------------------- 1 | 1 2 | 2 3 | 3 4 | 4 5 | 5 6 | Done! 7 | a 8 | Done! 9 | a 10 | b 11 | Done! 12 | a 13 | b 14 | c 15 | Done! 16 | a 17 | b 18 | c 19 | Done! 20 | a 21 | b 22 | c 23 | d 24 | Done! 25 | a 26 | b 27 | c 28 | d 29 | Done! 30 | a 31 | b 32 | c 33 | d 34 | Done! 35 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/gauss-sum-with-prompts.expected: -------------------------------------------------------------------------------- 1 | 5050 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/gauss-sum-with-prompts.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (define (f i acc) 4 | (cond [(> i 0) 5 | (abort-current-continuation (default-continuation-prompt-tag) 6 | (lambda () 7 | (f (sub1 i) (+ i acc)))) 8 | (printf "You should not see this\n") 9 | (/ 1 0)] 10 | [else 11 | acc])) 12 | 13 | (define (gauss i) 14 | (call-with-continuation-prompt (lambda () 15 | (f i 0)))) 16 | 17 | (gauss 100) 18 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/hash-code.expected: -------------------------------------------------------------------------------- 1 | "boxes" 2 | 1159182323 3 | "bytes" 4 | 121827633 5 | "chars" 6 | 1932714901 7 | 1932717986 8 | "hashes" 9 | 1118728238 10 | 964361183 11 | "lists" 12 | 448104403 13 | 1541271846 14 | "strings" 15 | 801766744 16 | "structs" 17 | 1930147392 18 | 402355443 19 | "symbols" 20 | 22978968 21 | 721172405 22 | "vectors" 23 | 1344488202 24 | 803618204 25 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/hash-code.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | (require whalesong/lang/private/shared) 3 | 4 | ;; boxes 5 | "boxes" 6 | (equal-hash-code (box 42)) 7 | 8 | ;; bytes 9 | "bytes" 10 | (equal-hash-code #"testing") 11 | ;; chars 12 | "chars" 13 | (equal-hash-code #\A) 14 | (equal-hash-code #\B) 15 | ;; hashes 16 | "hashes" 17 | (equal-hash-code (make-hash '((1 . x) 18 | (2 . y) 19 | (3 . z)))) 20 | (define ht (make-hash)) 21 | (hash-set! ht 'self ht) 22 | (hash-set! ht 'foo 4) 23 | (equal-hash-code ht) 24 | 25 | ;; keywords 26 | ; 27 | 28 | ;; lists 29 | "lists" 30 | (equal-hash-code (list 1 2 3 4 5)) 31 | (equal-hash-code (shared ([a (cons 1 b)] 32 | [b (cons 2 a)]) 33 | a)) 34 | 35 | 36 | ;; paths 37 | ; 38 | ;; placeholders 39 | ;; 40 | 41 | ;; strings 42 | "strings" 43 | (equal-hash-code "Hello world") 44 | 45 | ;; structs 46 | "structs" 47 | (define-struct thing (name age) #:mutable) 48 | (equal-hash-code (make-thing "danny" 32)) 49 | (equal-hash-code (shared ([a (make-thing a a)]) a)) 50 | 51 | ;; symbols 52 | "symbols" 53 | (equal-hash-code 'hello) 54 | (equal-hash-code 'world) 55 | 56 | ;; vectors 57 | "vectors" 58 | (equal-hash-code #(1 2 3 4 5)) 59 | (equal-hash-code (shared ([v (vector 1 2 v 3 v)]) v)) 60 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/hashes.expected: -------------------------------------------------------------------------------- 1 | false 2 | false 3 | true 4 | true 5 | true 6 | true 7 | true 8 | true 9 | #hash() 10 | #hasheqv() 11 | #hasheq() 12 | #hash((4 . four) (3 . three) (2 . two) (1 . one)) 13 | #hasheqv((4 . four) (3 . three) (2 . two) (1 . one)) 14 | #hasheq((4 . four) (3 . three) (2 . two) (1 . one)) 15 | one 16 | not-found 17 | 1 18 | 2 19 | 2 20 | 1 21 | 1 22 | 1 23 | 1 24 | #hash((1 . one) (2 . two) (3 . three) (4 . four)) 25 | #hasheqv((1 . one) (2 . two) (3 . three) (4 . four)) 26 | #hasheq((1 . one) (2 . two) (3 . three) (4 . four)) 27 | true 28 | true 29 | true 30 | true 31 | false 32 | false 33 | false 34 | true 35 | false 36 | false 37 | false 38 | true 39 | danny 40 | dyoo@hashcollision.org 41 | unknown 42 | not-there 43 | two 44 | one 45 | two 46 | not-there 47 | two 48 | 49 | "hash-has-key" 50 | false 51 | true 52 | false 53 | true 54 | 55 | #hash((1 . one) (2 . two)) 56 | #hasheqv((1 . one) (2 . two)) 57 | #hasheq((1 . one) (2 . two)) 58 | 59 | A 60 | alphabet 61 | 62 | 1 63 | 2 64 | 65 | true 66 | false 67 | false 68 | false 69 | true 70 | false 71 | false 72 | false 73 | true 74 | 75 | (author name) 76 | (author name) 77 | (graham-knuth-patashnik concrete-mathematics) 78 | (graham-knuth-patashnik concrete-mathematics) 79 | ((graham-knuth-patashnik author) (concrete-mathematics name)) 80 | ((graham-knuth-patashnik author) (concrete-mathematics name)) 81 | "author" 82 | "name" 83 | "graham-knuth-patashnik" 84 | "concrete-mathematics" 85 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/hello-bf.expected: -------------------------------------------------------------------------------- 1 | Hello World! 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/hello-bf.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/bf 2 | +++++ +++++ [ > +++++ ++ > +++++ +++++ > +++ > + <<<< - ] > ++ . > + 3 | . +++++ ++ . . +++ . > ++ . << +++++ +++++ +++++ . > . +++ . 4 | ----- - . ----- --- . > + . > . 5 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/hello.expected: -------------------------------------------------------------------------------- 1 | hello world 2 | hello again 3 | helloworld 4 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/hello.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | (displayln "hello world") 3 | 4 | 5 | (displayln (format "hello ~a" "again")) 6 | 7 | (printf "hello") 8 | (printf "world\n") 9 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/images.expected: -------------------------------------------------------------------------------- 1 | true 2 | true 3 | false 4 | true 5 | false 6 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/images.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | (require whalesong/image) 3 | 4 | (image-color? "red") 5 | (image-color? "blue") 6 | (image-color? 42) 7 | 8 | (image-color? (make-color 3 4 5 0)) 9 | (image-color? "color") 10 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/isolating-bug.expected: -------------------------------------------------------------------------------- 1 | # 2 | # 3 | # 4 | # 5 | # 6 | in the result of call-with-values 7 | (# # # # #) 8 | --- 9 | # 10 | # 11 | # 12 | # 13 | # 14 | *** 15 | # 16 | # 17 | # 18 | # 19 | # 20 | in the result of call-with-values 21 | (# # # # #) 22 | --- 23 | # 24 | # 25 | # 26 | # 27 | # 28 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/js-binding.expected: -------------------------------------------------------------------------------- 1 | "plus: " 2 | 7 3 | "wait for one second: " 4 | "minus:" 5 | 239725 6 | helloworldtesting -------------------------------------------------------------------------------- /whalesong/tests/more-tests/js-binding.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/js) 3 | 4 | (define js-plus 5 | (js-function->procedure "function(x, y) { return x + y; }")) 6 | 7 | (define js-minus 8 | (js-function->procedure "function(x, y) { return x - y; }")) 9 | 10 | (define raw-sleep 11 | (js-async-function->procedure 12 | "function(success, fail, n) { setTimeout(function() { success(plt.runtime.VOID);}, n); }")) 13 | (define (sleep n) 14 | (unless (real? n) 15 | (raise-type-error 'sleep "real" n)) 16 | (raw-sleep (inexact->exact (floor (* n 1000)))) 17 | (void)) 18 | 19 | 20 | "plus: " (js-plus 3 4) 21 | "wait for one second: " (sleep 1) 22 | "minus:" (js-minus 239748 23) 23 | 24 | 25 | (for-each (lambda (x) 26 | (display x) 27 | (sleep 1)) 28 | '(hello world testing)) 29 | 30 | 31 | ;; I need exception handling... 32 | ;; 33 | ;(define i-should-fail 34 | ; (js-async-function->procedure "function(success, fail) { fail('I should fail'); }")) 35 | ;(i-should-fail) 36 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/lists-cs019.expected: -------------------------------------------------------------------------------- 1 | Running tests... 2 | All 10 tests passed! 3 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/lists-cs019.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/cs019 2 | 3 | (define web-colors 4 | (shared ([W (cons "white" G)] 5 | [G (cons "grey" W)]) 6 | W)) 7 | 8 | (check-expect (first web-colors) "white") 9 | (check-expect (second web-colors) "grey") 10 | (check-expect (third web-colors) "white") 11 | (check-expect (fourth web-colors) "grey") 12 | (check-expect (fifth web-colors) "white") 13 | (check-expect (sixth web-colors) "grey") 14 | (check-expect (seventh web-colors) "white") 15 | (check-expect (eighth web-colors) "grey") 16 | 17 | (check-expect (equal? (rest web-colors) (rest (rest (rest web-colors)))) true) 18 | (check-expect (eq? (rest web-colors) (rest (rest (rest web-colors)))) true) 19 | 20 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/lists.expected: -------------------------------------------------------------------------------- 1 | (1 2 3) 2 | ("hello" "world") 3 | true 4 | true 5 | true 6 | false 7 | true 8 | true 9 | false 10 | true 11 | hello 12 | () 13 | world 14 | true 15 | true 16 | false 17 | false 18 | false 19 | false 20 | true 21 | false 22 | true 23 | false 24 | false 25 | true 26 | (3 1 4) 27 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/lists.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | '(1 2 3) 4 | (list "hello" "world") 5 | 6 | (list? empty) 7 | (list? '(1)) 8 | (list? '(1 2)) 9 | (list? 1) 10 | 11 | (empty? empty) 12 | (empty? '()) 13 | (cons? '()) 14 | (cons? '(hello)) 15 | (first '(hello)) 16 | (rest '(hello)) 17 | (second '(hello world)) 18 | 19 | (andmap even? '(2 4 6 8)) 20 | (andmap even? '()) 21 | (andmap even? '(2 4 5 8)) 22 | (andmap even? '(5)) 23 | (andmap even? '(1 3 5 7)) 24 | (andmap even? '(1 3 8 7)) 25 | 26 | (ormap even? '(2 4 6 8)) 27 | (ormap even? '()) 28 | (ormap even? '(2 4 5 8)) 29 | (ormap even? '(5)) 30 | (ormap even? '(1 3 5 7)) 31 | (ormap even? '(1 3 8 7)) 32 | 33 | 34 | (vector->list #(3 1 4)) 35 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/man-vs-boy.expected: -------------------------------------------------------------------------------- 1 | -67 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/man-vs-boy.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | ;; Knuth's Man-or-boy-test. 4 | ;; http://rosettacode.org/wiki/Man_or_boy_test 5 | (define (A k x1 x2 x3 x4 x5) 6 | (letrec ([B (lambda () 7 | (set! k (- k 1)) 8 | (A k B x1 x2 x3 x4))]) 9 | (if (<= k 0) 10 | (+ (x4) (x5)) 11 | (B)))) 12 | (displayln (A 10 13 | (lambda () 1) 14 | (lambda () -1) 15 | (lambda () -1) 16 | (lambda () 1) 17 | (lambda () 0))) 18 | 19 | 20 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/map.expected: -------------------------------------------------------------------------------- 1 | (5 7 9) 2 | (5 7 9) 3 | (12 15 18) 4 | (1 2 3) 5 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/map.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (map (lambda (x y) (+ x y)) (list 1 2 3) (list 4 5 6)) 4 | (map + (list 1 2 3) (list 4 5 6)) 5 | (map + (list 1 2 3) (list 4 5 6) (list 7 8 9)) 6 | (map + (list 1 2 3)) 7 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/module-scoping-helper.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require (for-syntax racket/base)) 3 | (provide x x++ x+1 x=0 get-x) 4 | (define x 0) 5 | 6 | (define (set-x v) 7 | (set! x v)) 8 | 9 | (define (get-x) 10 | x) 11 | 12 | (define-syntax (x++ stx) 13 | #'(plusplus-x)) 14 | 15 | (define-syntax (x+1 stx) 16 | #'(set-x (add1 x))) 17 | 18 | (define (plusplus-x) 19 | (set! x (add1 x))) 20 | 21 | (define-syntax (x=0 stx) 22 | #'(set-x 0)) 23 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/module-scoping.expected: -------------------------------------------------------------------------------- 1 | 0 2 | 0 3 | 1 4 | 1 5 | 2 6 | 2 7 | 0 8 | 0 9 | 1 10 | 1 11 | 2 12 | 2 13 | 3 14 | 3 15 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/module-scoping.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require "module-scoping-helper.rkt") 3 | x ;; 0 4 | (get-x) ;; 0 5 | 6 | x+1 7 | x ;; 1 8 | (get-x) ;; 1 9 | 10 | x++ 11 | x 12 | (get-x) 13 | 14 | x=0 15 | x 16 | (get-x) 17 | 18 | x++ 19 | x 20 | (get-x) 21 | x++ 22 | x 23 | (get-x) 24 | 25 | x+1 26 | x 27 | (get-x) 28 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/nestedloop.expected: -------------------------------------------------------------------------------- 1 | (1000000 1000000) 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/nqueens.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | ;;; NQUEENS -- Compute number of solutions to 8-queens problem. 3 | ;; 2006/08 -- renamed `try' to `try-it' to avoid Bigloo collision (mflatt) 4 | ;; 2010/04 -- got rid of the one-armed id (stamourv) 5 | 6 | (define trace? #f) 7 | 8 | (define (nqueens n) 9 | 10 | (define (one-to n) 11 | (let loop ((i n) (l '())) 12 | (if (= i 0) l (loop (- i 1) (cons i l))))) 13 | 14 | (define (try-it x y z) 15 | (if (null? x) 16 | (if (null? y) 17 | (begin (if trace? (begin (write z) (newline)) #t) 1) 18 | 0) 19 | (+ (if (ok? (car x) 1 z) 20 | (try-it (append (cdr x) y) '() (cons (car x) z)) 21 | 0) 22 | (try-it (cdr x) (cons (car x) y) z)))) 23 | 24 | (define (ok? row dist placed) 25 | (if (null? placed) 26 | #t 27 | (and (not (= (car placed) (+ row dist))) 28 | (not (= (car placed) (- row dist))) 29 | (ok? row (+ dist 1) (cdr placed))))) 30 | 31 | (try-it (one-to n) '() '())) 32 | 33 | (let loop ((n 1000 ;10000 34 | ) 35 | (v 0)) 36 | (if (zero? n) 37 | v 38 | (loop (- n 1) (nqueens 8 39 | ; (if input 8 0) 40 | )))) 41 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/nucleic2.expected: -------------------------------------------------------------------------------- 1 | 33.797594890762696 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/numbers.expected: -------------------------------------------------------------------------------- 1 | true 2 | true 3 | true 4 | true 5 | false 6 | false 7 | false 8 | 3 9 | 6 10 | 9 11 | 20 12 | 20 13 | 3 14 | 3 15 | 1 16 | 3 17 | 3 18 | false 19 | false 20 | true 21 | false 22 | false 23 | true 24 | true 25 | false 26 | false 27 | true 28 | true 29 | false 30 | false 31 | true 32 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/numbers.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | 4 | (number? 0) 5 | (number? 3.14) 6 | (number? (expt 2 100)) 7 | (number? 2+3i) 8 | (number? "42") 9 | (number? 'this-is-a-test) 10 | (number? (list 3 4 5)) 11 | 12 | (max 3) 13 | (max 3 4 5 6) 14 | (max 3 1 4 1 5 9 2 6) 15 | (max 3 20) 16 | (max 20 3) 17 | 18 | (min 3) 19 | (min 3 4 5 6) 20 | (min 3 1 4 1 5 9 2 6) 21 | (min 3 20) 22 | (min 20 3) 23 | 24 | 25 | (positive? 0) 26 | (negative? 0) 27 | (positive? 42) 28 | (negative? 42) 29 | (positive? -42) 30 | (negative? -42) 31 | (positive? 3.1415926) 32 | (negative? 3.1415926) 33 | (positive? -3.1415926) 34 | (negative? -3.1415926) 35 | (positive? (expt 2 100)) 36 | (negative? (expt 2 100)) 37 | (positive? (expt -2 91)) 38 | (negative? (expt -2 91)) 39 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/printing.expected: -------------------------------------------------------------------------------- 1 | (list 1 2 3) 2 | (list "hello" "world") 3 | (list 'hello 'world) 4 | (cons 1 2) 5 | (list 1 2 3) 6 | (cons 1 (cons 2 (cons 3 4))) 7 | (list) 8 | 'hello 9 | (box 'hello) 10 | (vector 'hello 'world) 11 | (person 'danny 32) 12 | (person "jerry" 32) 13 | #0=(cons 1 #0#) 14 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/printing.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (current-print-mode "constructor") 4 | 5 | 6 | '(1 2 3) 7 | (list "hello" "world") 8 | (list 'hello 'world) 9 | (cons 1 2) 10 | (cons 1 (cons 2 (cons 3 empty))) 11 | (cons 1 (cons 2 (cons 3 4))) 12 | '() 13 | 14 | 'hello 15 | (box 'hello) 16 | (vector 'hello 'world) 17 | 18 | (define-struct person (name age)) 19 | (person 'danny 32) 20 | (person "jerry" 32) 21 | 22 | 23 | ;; This is slightly broken: we should follow DrRacket shared printing 24 | ;; notation. 25 | (shared ([a (cons 1 a)]) 26 | a) 27 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/quasi.expected: -------------------------------------------------------------------------------- 1 | (0 1 2 4) 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/quasi.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | `(0 ,@(list 1 2) 4) 3 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/ramanujan-pi.expected: -------------------------------------------------------------------------------- 1 | 3.1415926535897927 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/ramanujan-pi.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | ;; Srinivasa Ramanujan's infinite series for approximating pi. 3 | 4 | (define (sum f a b) 5 | (cond 6 | [(= a b) 7 | (f a)] 8 | [else 9 | (+ (f a) 10 | (sum f (add1 a) b))])) 11 | 12 | (define (fact x) 13 | (cond 14 | [(= x 0) 15 | 1] 16 | [else 17 | (* x (fact (sub1 x)))])) 18 | 19 | 20 | (define (1/pi-approx n) 21 | (* (/ (* 2 (sqrt 2)) 22 | 9801) 23 | (sum (lambda (k) 24 | (/ (* (fact (* 4 k)) 25 | (+ 1103 (* 26390 k))) 26 | (* (expt (fact k) 4) 27 | (expt 396 (* 4 k))))) 28 | 0 29 | n))) 30 | 31 | (define (pi-approx n) 32 | (/ 1 (1/pi-approx n))) 33 | 34 | 35 | (pi-approx 10) 36 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/scheme-whalesong.expected: -------------------------------------------------------------------------------- 1 | ("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two") 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/sharing-cs019.expected: -------------------------------------------------------------------------------- 1 | 1 2 | 1 3 | 1 4 | 1 5 | 2 6 | 1 7 | 2 8 | 5 9 | 5 10 | 5 11 | 1 12 | 7 13 | 1 14 | # 15 | true 16 | # 17 | 2 18 | jack 19 | jane 20 | 21 | jill 22 | jane 23 | 24 | 25 | true 26 | false 27 | #0=(cons 1 #0#) 28 | #0=(cons 1 (cons 2 #0#)) 29 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/sharing.expected: -------------------------------------------------------------------------------- 1 | 1 2 | 1 3 | 1 4 | 5 | true 6 | false 7 | 8 | 1 9 | 2 10 | 1 11 | 2 12 | 5 13 | 5 14 | 5 15 | 1 16 | 7 17 | 1 18 | # 19 | true 20 | # 21 | 2 22 | jack 23 | jane 24 | 25 | jill 26 | jane 27 | 28 | 29 | true 30 | false 31 | #0=(1 . #0#) 32 | #0=(1 2 . #0#) 33 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/sigs-cs019.expected: -------------------------------------------------------------------------------- 1 | Running tests... 2 | All 38 tests passed! 3 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple-apply.expected: -------------------------------------------------------------------------------- 1 | 14 2 | 14 3 | 14 4 | 14 5 | 14 6 | 120 7 | 120 8 | 120 9 | 120 10 | 120 11 | (2 3 4 5) 12 | (2 3 4 5) 13 | (2 3 4 5) 14 | (2 3 4 5) 15 | (2 3 4 5) 16 | 14 17 | 15 18 | false 19 | (3 4 5) 20 | 49 21 | "squaring" 22 | 49 23 | 64 24 | "now factorial" 25 | 1 26 | 1 27 | 2 28 | 6 29 | 24 30 | 120 31 | 144 32 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple-apply.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | (apply + 2 3 4 5 '()) 4 | (apply + 2 3 4 '(5)) 5 | (apply + 2 3 '(4 5)) 6 | (apply + 2 '(3 4 5)) 7 | (apply + '(2 3 4 5)) 8 | 9 | 10 | (apply * 2 3 4 5 '()) 11 | (apply * 2 3 4 '(5)) 12 | (apply * 2 3 '(4 5)) 13 | (apply * 2 '(3 4 5)) 14 | (apply * '(2 3 4 5)) 15 | 16 | (apply (lambda args args) 2 3 4 5 '()) 17 | (apply (lambda args args) 2 3 4 '(5)) 18 | (apply (lambda args args) 2 3 '(4 5)) 19 | (apply (lambda args args) 2 '(3 4 5)) 20 | (apply (lambda args args) '(2 3 4 5)) 21 | 22 | 23 | (apply (lambda (a b c) (+ a (* b c))) 2 3 '(4)) 24 | (add1 (apply (lambda (a b c) (+ a (* b c))) 2 3 '(4))) 25 | (= (apply (lambda (a b c) (+ a (* b c))) 2 3 '(4)) 26 | 0) 27 | 28 | (apply list 3 4 '(5)) 29 | 30 | 31 | (define (square x) 32 | (* x x)) 33 | 34 | (apply square '(7)) 35 | 36 | "squaring" 37 | 38 | (define (square2 x) 39 | (apply * (list x x))) 40 | 41 | (apply square2 '(7)) 42 | (apply square2 8 '()) 43 | 44 | 45 | "now factorial" 46 | 47 | (define (f x) 48 | (cond 49 | [(apply = `(,x 0)) 50 | 1] 51 | [else 52 | (apply * `(,x ,(apply f (apply sub1 (apply list x '())) '())))])) 53 | 54 | (f 0) 55 | (apply f 1 '()) 56 | (f 2) 57 | (apply f '(3)) 58 | (f 4) 59 | (f 5) 60 | (+ (apply f 4 '()) (f 5)) 61 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple-functions.expected: -------------------------------------------------------------------------------- 1 | 1 2 | 2 3 | 68 4 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple-functions.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | (provide (all-defined-out)) 4 | 5 | (define (f x) 6 | (* x x)) 7 | 8 | (define (g x) 9 | (+ x x)) 10 | 11 | (f 1) 12 | (g 1) 13 | (+ (f 2) (f (g (g 2)))) 14 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple-loop.expected: -------------------------------------------------------------------------------- 1 | 4950 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple-loop.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | (let myloop ([i 0] [acc 0]) 4 | (cond 5 | [(< i 100) 6 | (myloop (add1 i) (+ acc i))] 7 | [else 8 | acc])) 9 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple-structs.expected: -------------------------------------------------------------------------------- 1 | 3 2 | 4 3 | 3 4 | 4 5 | 5 6 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple-structs.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | 3 | (define-struct pair (f r)) 4 | (define-struct color (r g b)) 5 | 6 | 7 | 8 | 9 | (define p1 (make-pair 3 4)) 10 | (pair-f p1) 11 | (pair-r p1) 12 | 13 | 14 | 15 | (color-r (make-color 3 4 5)) 16 | (color-g (make-color 3 4 5)) 17 | (color-b (make-color 3 4 5)) 18 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple.expected: -------------------------------------------------------------------------------- 1 | 2 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/simple.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | ;; This should invoke the use of inline-variant from 5.2.1 3 | (provide f) 4 | (define (f x) x) 5 | (f 2) 6 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/sk-generator-2.expected: -------------------------------------------------------------------------------- 1 | "a" 2 | "b" 3 | "c" 4 | 1 5 | 2 6 | 3 7 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/sk-generator-2.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | (define (make-gen gen) 3 | (let ([cont (box #f)]) 4 | (lambda () 5 | (call/cc (lambda (caller) 6 | (if (unbox cont) 7 | ((unbox cont) caller) 8 | (gen (lambda (v) 9 | (call/cc (lambda (gen-k) 10 | (begin 11 | (set-box! cont gen-k) 12 | (caller v)))))))))))) 13 | 14 | (define g1 (make-gen (lambda (return) 15 | (begin 16 | (return "a") 17 | (return "b") 18 | (return "c"))))) 19 | 20 | (define g2 (make-gen (lambda (ret) 21 | (begin 22 | (ret 1) 23 | (ret 2) 24 | (ret 3))))) 25 | 26 | (g1) 27 | (g1) 28 | (g1) 29 | 30 | (g2) 31 | (g2) 32 | (g2) 33 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/sk-generator.expected: -------------------------------------------------------------------------------- 1 | "a" 2 | "b" 3 | "c" 4 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/sk-generator.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong/base 2 | (define (make-gen gen) 3 | (let ([cont #f]) 4 | (lambda () 5 | (call/cc (lambda (caller) 6 | (if cont 7 | (cont caller) 8 | (gen (lambda (v) 9 | (call/cc (lambda (gen-k) 10 | (begin 11 | (set! cont gen-k) 12 | (caller v)))))))))))) 13 | 14 | (define g1 (make-gen (lambda (return) 15 | (begin 16 | (return "a") 17 | (return "b") 18 | (return "c"))))) 19 | 20 | (g1) 21 | (g1) 22 | (g1) 23 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/view.expected: -------------------------------------------------------------------------------- 1 | "" 2 | "some text" 3 | (html (head) (body (p "hello world, this is a test") (div (@ (id "a div")) "some text"))) 4 | "blah" 5 | "baz" 6 | (html (head) (body (p (@ (class "baz"))))) 7 | 8 | "css test" 9 | "line-through" 10 | "underline" 11 | (html (head) (body (p (@ (style "text-decoration: underline; "))))) 12 | 13 | "------" 14 | "navigation" 15 | false 16 | false 17 | false 18 | false 19 | 20 | true 21 | false 22 | false 23 | false 24 | 25 | false 26 | true 27 | false 28 | true 29 | 30 | false 31 | true 32 | true 33 | false 34 | 35 | "------" 36 | "adding elements" 37 | (html (head) (body (h1 (@ (id "header"))) (p (@ (id "para")) (li "An item")))) 38 | (html (head) (body (h1 (@ (id "header"))) (p (@ (id "para")) (ul (li "one") (li "two"))))) 39 | (html (head) (body (h1 (@ (id "header"))) (p (@ (id "para")) (ul (li "one") (li "two") (li "three"))))) 40 | (html (head) (body (h1 (@ (id "header"))) (p (@ (id "para")) (ul (li "zero") (li "one"))))) 41 | 42 | "this is a message" 43 | "hello again" 44 | (html (head) (body (input (@ (id "my-field") (type "text") (value "this is a message"))))) 45 | (html (head) (body (input (@ (id "my-field") (type "text") (value "hello again"))))) 46 | "hello again" 47 | 48 | "id" 49 | "para" 50 | 51 | "remove" 52 | (html (head) (body "some text")) 53 | "some text" 54 | 55 | "forward and backward" 56 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/weird-cc.expected: -------------------------------------------------------------------------------- 1 | 11213 2 | -------------------------------------------------------------------------------- /whalesong/tests/more-tests/weird-cc.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (define program (lambda () (let ((y (call/cc (lambda (c) c)))) (display 1) (call/cc (lambda (c) (y c))) (display 2) (call/cc (lambda (c) (y c))) (display 3)))) 3 | 4 | (program) 5 | (newline) 6 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/all-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | 3 | (require "mz-tests/all-tests.rkt" 4 | "moby-programs/all-tests.rkt") 5 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/benchmarks/do-measures.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (require "nboyer.rkt" 4 | "sboyer.rkt" 5 | "tak.rkt" 6 | "nfa.rkt" 7 | "graphs.rkt") 8 | 9 | "(tak-benchmark)" 10 | (tak-benchmark) 11 | 12 | 13 | 14 | "(nboyer-benchmark 0)" 15 | (nboyer-benchmark 0) 16 | 17 | "(nboyer-benchmark 4)" 18 | (nboyer-benchmark 4) 19 | 20 | 21 | "sboyer" 22 | 23 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/benchmarks/nfa.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (require "run-benchmark.rkt") 4 | (provide recursive-nfa-benchmark) 5 | 6 | ; The recursive-nfa benchmark. (Figure 45, page 143.) 7 | 8 | (define (recursive-nfa input) 9 | 10 | (define (state0 input) 11 | (or (state1 input) (state3 input) #f)) 12 | 13 | (define (state1 input) 14 | (and (not (null? input)) 15 | (or (and (char=? (car input) #\a) 16 | (state1 (cdr input))) 17 | (and (char=? (car input) #\c) 18 | (state1 input)) 19 | (state2 input)))) 20 | 21 | (define (state2 input) 22 | (and (not (null? input)) 23 | (char=? (car input) #\b) 24 | (not (null? (cdr input))) 25 | (char=? (cadr input) #\c) 26 | (not (null? (cddr input))) 27 | (char=? (caddr input) #\d) 28 | 'state2)) 29 | 30 | (define (state3 input) 31 | (and (not (null? input)) 32 | (or (and (char=? (car input) #\a) 33 | (state3 (cdr input))) 34 | (state4 input)))) 35 | 36 | (define (state4 input) 37 | (and (not (null? input)) 38 | (char=? (car input) #\b) 39 | (not (null? (cdr input))) 40 | (char=? (cadr input) #\c) 41 | 'state4)) 42 | 43 | (or (state0 (string->list input)) 44 | 'fail)) 45 | 46 | (define (recursive-nfa-benchmark) 47 | (let ((input (string-append (make-string 133 #\a) "bc"))) 48 | (run-benchmark "Recursive nfa" 49 | (lambda () (recursive-nfa input)) 50 | 1000))) 51 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/benchmarks/run-do-measures.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../../main.rkt") 3 | 4 | (run-in-browser "do-measures.rkt") 5 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/benchmarks/run-nboyer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require (planet dyoo/js-vm)) 3 | (run-in-browser "nboyer.rkt") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/benchmarks/tak.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (provide tak-benchmark) 4 | (require "run-benchmark.rkt") 5 | 6 | 7 | (define (tak x y z) 8 | (if (not (< y x)) 9 | z 10 | (tak (tak (- x 1) y z) 11 | (tak (- y 1) z x) 12 | (tak (- z 1) x y)))) 13 | 14 | ;;; call: (tak 18 12 6) 15 | 16 | (define (tak-benchmark) 17 | (run-benchmark "Tak" (lambda () (tak 18 12 6)) 10)) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/42.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (printf "42.rkt\n") 4 | 5 | (define (f x) 6 | (* x x)) 7 | 8 | (check-expect (format "~s ~s ~s\n" 9 | (f 16) 10 | (f -5) 11 | (f 42)) 12 | "256 25 1764\n") 13 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/all-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | 4 | ;; This module requires the majority of tests here. 5 | 6 | 7 | 8 | ;; NOTE: js-input.rkt is not being tested here. Must be handled interactively. 9 | ;; NOTE: continuation-prompts.rkt is not being tested here. Must be handled interactively. 10 | ;; NOTE: continuation-prompts-3.rkt is not being tested here. Must be handled interactively. 11 | 12 | 13 | (require "sleep.rkt" 14 | "display-and-write.rkt" 15 | "repeating-decimals.rkt" 16 | "ffi.rkt" 17 | "ffi-2.rkt" 18 | "continuation-marks.rkt" 19 | "atan.rkt" 20 | "with-handlers-1.rkt" 21 | "with-handlers-2.rkt" 22 | "when-unless.rkt" 23 | "setbang.rkt" 24 | "require.rkt" 25 | "quasiquote.rkt" 26 | "permissions.rkt" 27 | "local.rkt" 28 | "for-each.rkt" 29 | "letrec.rkt" 30 | "recur.rkt" 31 | "math.rkt" 32 | "eof.rkt" 33 | "js-big-bang-timer.rkt" 34 | "images.rkt" 35 | "image-equality.rkt" 36 | "falling-ball.rkt" 37 | "exercise-control.rkt" 38 | "double-client.rkt" 39 | "define-struct.rkt" 40 | "continuation-prompts-2.rkt" 41 | "case-lambda.rkt" 42 | "begin.rkt" 43 | "and-or.rkt" 44 | "42.rkt" 45 | "cycles.rkt" 46 | "list.rkt" 47 | "vararity.rkt" 48 | "check-error.rkt" 49 | "vector.rkt" 50 | "struct.rkt" 51 | "arity.rkt" 52 | "apply.rkt" 53 | "values.rkt" 54 | "compose.rkt" 55 | "seconds.rkt" 56 | "random.rkt" 57 | "identity.rkt" 58 | "raise.rkt" 59 | "exn.rkt" 60 | "misc.rkt" 61 | "jsworld.rkt" 62 | "location.rkt" 63 | "rotate.rkt" 64 | "more-jsworld.ss") 65 | 66 | 67 | (printf "all-tests completed\n") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/and-or.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.ss" 2 | 3 | (printf "and-or.rkt\n") 4 | 5 | (check-expect (and true "hello") "hello") 6 | (check-expect (or #f #f "world" 'dontcomehere) 7 | "world") 8 | 9 | 10 | (check-expect (not 3) false) 11 | (check-expect (not (not 3)) true) 12 | 13 | (printf "and-or.rkt end\n") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/apply.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (require "../../lang/check-expect/test-expect.rkt") 4 | 5 | "apply.rkt" 6 | 7 | (check-expect (apply + '()) 0) 8 | (check-expect (apply + '(1 2 3)) 6) 9 | (check-expect (apply + 4 6 '(1 2 3)) 16) 10 | 11 | (define f (lambda args args)) 12 | (check-expect (apply f 'hello 'world '()) '(hello world)) 13 | 14 | (let ([g (λ (x) (* x x))]) 15 | (test-expect (apply g 3 '()) 9)) 16 | 17 | 18 | "apply.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/arity.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | "arity.rkt" 4 | (check-expect (procedure-arity (lambda () (void))) 0) 5 | (check-expect (procedure-arity (lambda (x) (void))) 1) 6 | (check-expect (procedure-arity (lambda (x y . z) (void))) 7 | (make-arity-at-least 2)) 8 | 9 | (check-expect (arity-at-least? (make-arity-at-least 0)) 10 | true) 11 | 12 | (check-expect (arity-at-least? 'not-an-arity) 13 | false) 14 | 15 | (check-expect (arity-at-least-value 16 | (make-arity-at-least 7)) 17 | 7) 18 | 19 | (define f 20 | (case-lambda [(x y) (list x y)] 21 | [(x y z) (list x y z)])) 22 | (check-expect (procedure-arity-includes? f 2) true) 23 | (check-expect (procedure-arity-includes? f 3) true) 24 | (check-expect (procedure-arity-includes? f 4) false) 25 | (check-expect (procedure-arity-includes? f 0) false) 26 | 27 | (check-expect (procedure-arity-includes? (lambda (x) (* x x)) 1) true) 28 | (check-expect (procedure-arity-includes? (lambda (x) (* x x)) 0) false) 29 | (check-expect (procedure-arity-includes? (lambda args (void)) 0) true) 30 | 31 | "arity.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/atan.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | "atan.rkt tests" 3 | 4 | (define delta 0.000001) 5 | 6 | (check-within (atan 0.5) 7 | 0.4636476090008061 8 | delta) 9 | (check-within (atan 2 1) 10 | 1.1071487177940904 11 | delta) 12 | (check-within (atan -2 -1) 13 | -2.0344439357957027 14 | delta) 15 | (check-within (real-part (atan 1.0+5.0i)) 16 | 1.530881333938778 17 | delta) 18 | 19 | (check-within (imag-part (atan 1.0+5.0i)) 20 | 0.19442614214700213 21 | delta) 22 | 23 | (check-within (atan +inf.0 -inf.0) 24 | 2.356194490192345 25 | delta) 26 | 27 | "atan.rkt tests done" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/begin.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.ss" 2 | 3 | (require "../../lang/check-expect/test-expect.rkt") 4 | 5 | (printf "begin.rkt\n") 6 | (printf "You should see the string \"hello world\" immediately after this: ") 7 | 8 | (begin (printf "hello ") 9 | (printf "world\n")) 10 | 11 | 12 | 13 | (let ([counter 17]) 14 | (test-expect (begin 15 | counter 16 | (set! counter (add1 counter)) 17 | counter) 18 | 18)) 19 | 20 | 21 | (let ([counter 17]) 22 | (test-expect (begin0 counter 23 | (set! counter (add1 counter)) 24 | counter) 25 | 17)) 26 | 27 | "begin.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/case-lambda.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.ss" 2 | 3 | (printf "case-lambda.rkt\n") 4 | 5 | (define f 6 | (case-lambda 7 | [(x) (list x)] 8 | [(x y) (list y x)] 9 | [(x y z) (list z y x)])) 10 | 11 | (check-expect (f 3) (list 3)) 12 | (check-expect (f 3 4) (list 4 3)) 13 | (check-expect (f 3 4 5) (list 5 4 3)) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/check-error.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (check-error (/ 1 0) "/: division by zero") 4 | 5 | 6 | #;(define-struct foo ()) 7 | #;(check-error (make-foo 3 4) 8 | "make-foo: expects no arguments, given 2: 3 4") 9 | 10 | 11 | #;(define (f x) 12 | (* x x)) 13 | #;(check-error (f 3 4) "procedure f: expects 1 argument, given 2: 3 4") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/compose.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | "compose.rkt" 4 | 5 | (define (f x) (* x x)) 6 | (define (g x) (+ x x)) 7 | 8 | (check-expect (procedure? (compose f g)) true) 9 | (check-expect ((compose f g) 7) 10 | (* 14 14)) 11 | 12 | (check-expect ((compose) 7) 13 | 7) 14 | 15 | (check-expect ((compose f) 7) 16 | 49) 17 | 18 | "compose.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/continuation-marks.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | (require "../../lang/check-expect/test-expect.rkt") 3 | 4 | "continuation-marks.rkt" 5 | 6 | (with-continuation-mark 'x 3 7 | (test-expect (continuation-mark-set->list 8 | (current-continuation-marks) 9 | 'x) 10 | '(3))) 11 | 12 | (with-continuation-mark 'x 3 13 | (with-continuation-mark 'x 4 14 | (test-expect (continuation-mark-set->list 15 | (current-continuation-marks) 16 | 'x) 17 | '(4)))) 18 | 19 | "continuation-marks.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/continuation-prompts-2.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | 4 | (define (escape v) 5 | (abort-current-continuation 6 | (default-continuation-prompt-tag) 7 | (lambda () v))) 8 | 9 | 10 | (printf "continuation-prompts-2.rkt\n") 11 | 12 | 13 | 14 | (printf "testing expected value from abort with default continuation prompt tag\n") 15 | (check-expect 16 | (+ 1 17 | (call-with-continuation-prompt 18 | (lambda () 19 | (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (escape 6)))))))) 20 | (default-continuation-prompt-tag))) 21 | 22 | 7) 23 | 24 | 25 | (check-expect 26 | (+ 1 27 | (call-with-continuation-prompt 28 | (lambda () 29 | (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (escape 24)))))))) 30 | (default-continuation-prompt-tag) 31 | (lambda (thunk) 32 | (printf "I see the escape\n") 33 | (thunk)))) 34 | 35 | 25) 36 | 37 | 38 | 39 | 40 | 41 | (printf "continuation-prompts-2 tests done!\n") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/continuation-prompts-3.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | 4 | (define n 0) 5 | (define (f) 6 | (call-with-continuation-prompt 7 | (lambda () 8 | (abort-current-continuation (default-continuation-prompt-tag) 9 | (lambda () 10 | (set! n (add1 n)) 11 | (when (< n 10000) 12 | (f))))) 13 | (default-continuation-prompt-tag) 14 | (lambda (thunk) 15 | (thunk)))) 16 | 17 | (f) 18 | 19 | n -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/continuation-prompts.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (call-with-continuation-prompt 4 | (lambda () (printf "Hello world\n") 5 | (values 3 4 5)) 6 | (default-continuation-prompt-tag) 7 | (lambda (thunk) 8 | (error))) 9 | 10 | 11 | 12 | (call-with-continuation-prompt 13 | (lambda (a b c) (printf "~a ~a ~a\n" a b c) 14 | (values 3 4 5)) 15 | (default-continuation-prompt-tag) 16 | (lambda (thunk) 17 | (error)) 18 | "hello" 19 | "world" 20 | "again") 21 | 22 | 23 | 24 | (abort-current-continuation (default-continuation-prompt-tag) 25 | (lambda () 26 | (printf "This is the error thunk."))) 27 | 28 | 29 | 30 | (printf "I should not see this\n") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/define-struct.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.ss" 2 | 3 | (printf "define-struct.rkt\n") 4 | 5 | (define-struct p (x y)) 6 | "should be a structure: " (make-p 3 4) 7 | (check-expect (p? (make-p 3 4)) 8 | true) 9 | (check-expect (p-x (make-p 3 4)) 3) 10 | (check-expect (p-y (make-p 3 4)) 4) 11 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/display-and-write.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | 4 | (printf "should not be in quotes: ") 5 | (display "hello world") 6 | (newline) 7 | (printf "should be in quotes: ") 8 | (write "hello world") 9 | (newline) 10 | 11 | 12 | ((current-print) "using current-print") 13 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/double-client.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (require "double.rkt") 4 | 5 | (check-expect (double 3) 6) 6 | 7 | (check-expect (double (double (double 2))) 16) 8 | 9 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/double.js: -------------------------------------------------------------------------------- 1 | EXPORTS['double'] = 2 | new types.PrimProc('double', 1, false, false, function(x) { return jsnums.multiply(x, 2)}); -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/double.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/js-impl/js-impl.rkt" 2 | 3 | (require-js "double.js") 4 | 5 | (provide double) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/eof.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | 4 | "eof.rkt" 5 | 6 | (check-expect (eof-object? eof) true) 7 | (check-expect (eof-object? 'eof) false) 8 | 9 | "eof.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/falling-ball.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.ss" 2 | 3 | ;; Simple falling ball example. A red ball falls down the screen 4 | ;; until hitting the bottom. 5 | 6 | 7 | (printf "falling-ball.rkt\n") 8 | 9 | (define-struct world (radius y)) 10 | 11 | 12 | ;; The dimensions of the screen: 13 | (define WIDTH 320) 14 | (define HEIGHT 480) 15 | 16 | ;; The radius of the red circle. 17 | (define RADIUS 15) 18 | 19 | ;; The world is the distance from the top of the screen. 20 | (define INITIAL-WORLD (make-world RADIUS 0)) 21 | 22 | ;; tick: world -> world 23 | ;; Moves the ball down. 24 | (define (tick w) 25 | (make-world RADIUS (+ (world-y w) 5))) 26 | 27 | 28 | ;; hits-floor?: world -> boolean 29 | ;; Returns true when the distance reaches the screen height. 30 | (define (hits-floor? w) 31 | (>= (world-y w) HEIGHT)) 32 | 33 | ;; We have some simple test cases. 34 | (check-expect (hits-floor? (make-world RADIUS 0)) false) 35 | (check-expect (hits-floor? (make-world RADIUS HEIGHT)) true) 36 | 37 | ;; render: world -> scene 38 | ;; Produces a scene with the circle at a height described by the world. 39 | (define (render w) 40 | (place-image (circle RADIUS "solid" "red") (/ WIDTH 2) (world-y w) 41 | (empty-scene WIDTH HEIGHT))) 42 | 43 | ;; Start up a big bang, 15 frames a second. 44 | (check-expect (big-bang INITIAL-WORLD 45 | (on-tick tick 1/15) 46 | (to-draw render) 47 | (stop-when hits-floor?)) 48 | (make-world 15 480)) 49 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/ffi-2.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | (require "../../ffi/ffi.rkt" 3 | "../../jsworld/jsworld.rkt" 4 | "../../lang/check-expect/check-expect.rkt") 5 | 6 | "my-ffi-2.rkt" 7 | 8 | ;; Check to see that we can expression on-tick with make-world-config. 9 | 10 | 11 | (define (my-on-tick world-updater) 12 | (make-world-config 13 | (lambda (success) 14 | (js-call (js-get-global-value "setInterval") 15 | #f 16 | (procedure->void-js-fun (lambda args (js-call success #f))) 17 | 1000)) 18 | 19 | (lambda (id) 20 | (printf "shutdown with clearInterval id=~s\n" id) 21 | (js-call (js-get-global-value "clearInterval") 22 | #f 23 | id)) 24 | 25 | (lambda (w) 26 | (world-updater w)))) 27 | 28 | 29 | 30 | 31 | (check-expect (big-bang 1 32 | 33 | (my-on-tick 34 | (lambda (w) 35 | (printf "tick!\n") 36 | (add1 w))) 37 | 38 | (stop-when 39 | (lambda (n) (= n 10)))) 40 | 10) 41 | 42 | 43 | (run-tests) 44 | "end my-ffi-2.rkt" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/for-each.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | 4 | "for-each" 5 | 6 | (for-each (lambda (x) (error 'nothing!)) '()) 7 | 8 | 9 | 10 | (define l1 '(hello world this is a test)) 11 | (define l2 '(hello this test)) 12 | (for-each (lambda (x) (set! l1 (remove x l1))) 13 | l2) 14 | (check-expect l1 '(world is a)) 15 | 16 | "for-each.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/identity.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (check-expect (identity 42) 42) 4 | 5 | (define p (cons 3 4)) 6 | (check-expect (identity p) p) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/js-big-bang-timer.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (require "../../jsworld/jsworld.rkt") 4 | 5 | 6 | (printf "js-big-bang-timer.rkt\n") 7 | (printf "number should be counting up to ten\n") 8 | (check-expect (big-bang 1 9 | (on-tick (lambda (w) 10 | (printf "~s~n" w) 11 | (add1 w)) 12 | 1/4) 13 | (stop-when (lambda (w) (= w 10)))) 14 | 10) 15 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/js-input.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (require "../../jsworld/jsworld.rkt") 4 | 5 | 6 | (define (make-ingredient-checkbox-sexp ingredient) 7 | (local [(define (on-check w v) 8 | (cond 9 | [v 10 | (cons ingredient w)] 11 | [else 12 | (remove ingredient w)]))] 13 | (list (js-div) 14 | (list (js-text ingredient)) 15 | (list (js-input "checkbox" 16 | on-check 17 | `(("value" ,ingredient))))))) 18 | 19 | (define c1 (make-ingredient-checkbox-sexp "mushrooms")) 20 | (define c2 (make-ingredient-checkbox-sexp "green peppers")) 21 | (define c3 (make-ingredient-checkbox-sexp "olives")) 22 | 23 | (define (draw w) 24 | (list (js-div) 25 | c1 26 | c2 27 | c3 28 | (list (js-text (format "The world is: ~s" w))))) 29 | 30 | (define (draw-css w) 31 | '()) 32 | 33 | 34 | (big-bang '() 35 | (to-draw-page draw draw-css)) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/jsworld-effects.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | (require "../../jsworld/define-effect.rkt") 3 | 4 | (define-effect effect:beep () 5 | #:impl (lambda (w) 6 | (printf "Beep!"))) 7 | 8 | "This is an effect: " (make-effect:beep) 9 | 10 | (check-expect (effect? (make-effect:beep)) #t) 11 | (check-expect (effect-type? (make-effect:beep)) #f) 12 | (check-expect (effect-type? struct:effect:beep) #t) 13 | (check-expect (effect-type? (make-effect:beep)) #f) 14 | 15 | 16 | 17 | (big-bang 0 18 | (initial-effect (make-effect:beep)) 19 | (stop-when (lambda (w) true))) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/letrec.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | (require "../../lang/check-expect/test-expect.rkt") 3 | 4 | "letrec" 5 | 6 | (letrec ([even? (lambda (x) 7 | (if (= x 0) 8 | true 9 | (odd? (sub1 x))))] 10 | [odd? (lambda (x) 11 | (if (= x 0) 12 | false 13 | (even? (sub1 x))))]) 14 | (test-expect (even? 1024) true) 15 | (test-expect (even? 1023) false) 16 | (test-expect (even? 2172) true) 17 | (test-expect (even? 2171) false)) 18 | 19 | 20 | 21 | 22 | (letrec-values ([(even? odd?) 23 | (values 24 | (lambda (x) 25 | (if (= x 0) 26 | true 27 | (odd? (sub1 x)))) 28 | (lambda (x) 29 | (if (= x 0) 30 | false 31 | (even? (sub1 x)))))]) 32 | (test-expect (even? 1024) true) 33 | (test-expect (even? 1023) false) 34 | (test-expect (even? 2172) true) 35 | (test-expect (even? 2171) false)) 36 | 37 | 38 | 39 | 40 | 41 | (letrec ([fact (lambda (x) 42 | (if (= x 0) 43 | 1 44 | (* x (fact (sub1 x)))))]) 45 | (test-expect (fact 3) 6) 46 | (test-expect (fact 4) 24) 47 | (test-expect (fact 5) 120)) 48 | 49 | 50 | "letrec.rkt end" 51 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/list.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | 4 | "list tests" 5 | 6 | (check-expect (list* 4) 7 | 4) 8 | 9 | (check-expect (list* 1 2 3) 10 | (cons 1 (cons 2 3))) 11 | 12 | (check-expect (list* 1 2 '(3)) 13 | (cons 1 (cons 2 (cons 3 empty)))) 14 | 15 | "end list tests" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/local.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.ss" 2 | 3 | 4 | (printf "local.rkt\n") 5 | 6 | (check-expect (local [(define (f x) 7 | (* x x)) 8 | (define (g x) 9 | (* x x x))] 10 | (f (g (g (f 3))))) 11 | 12 | 150094635296999121) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/location.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (require "../../lang/location.rkt") 4 | (require "../../lang/check-expect/check-expect.rkt") 5 | 6 | "location.rkt" 7 | 8 | 9 | (check-expect (location? (make-location "location.rkt" 88 7 0 37)) 10 | true) 11 | 12 | "The following should be a location " 13 | (make-location "location.rkt" 88 7 0 37) 14 | 15 | 16 | 17 | "location.rkt end" 18 | (run-tests) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/math.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | "math.rkt" 4 | 5 | (check-expect (number? pi) true) 6 | (check-expect (number? e) true) 7 | 8 | (check-within pi 22/7 0.1) 9 | (check-within e 2.718 0.1) 10 | 11 | (check-expect (=~ 3 4 1) true) 12 | (check-expect (=~ 3 4 .9) false) 13 | 14 | 15 | (check-expect (< 3 4) true) 16 | (check-expect (< 4 3) false) 17 | (check-expect (< 3 3) false) 18 | 19 | (check-expect (> 3 4) false) 20 | (check-expect (> 4 3) true) 21 | (check-expect (> 4 4) false) 22 | 23 | (check-expect (<= 3 4) true) 24 | (check-expect (<= 4 3) false) 25 | (check-expect (<= 3 3) true) 26 | 27 | (check-expect (>= 3 4) false) 28 | (check-expect (>= 4 3) true) 29 | (check-expect (>= 4 4) true) 30 | 31 | 32 | (check-expect (abs 3) 3) 33 | (check-expect (abs -3) 3) 34 | 35 | (check-expect (quotient 42 2) 21) 36 | (check-expect (remainder 42 2) 0) 37 | 38 | (check-expect (modulo 5 3) 2) 39 | 40 | (check-expect (max 3 4 5) 5) 41 | (check-expect (max 5) 5) 42 | 43 | (check-expect (min 3 4 5) 3) 44 | (check-expect (min 5) 5) 45 | 46 | 47 | (check-expect (gcd 3 4) 1) 48 | (check-expect (gcd 5 10 20) 5) 49 | 50 | 51 | (check-expect (lcm 3 4) 12) 52 | (check-expect (lcm 5 10 20) 20) 53 | 54 | 55 | (check-expect (floor 3) 3) 56 | (check-expect (ceiling 3) 3) 57 | 58 | (check-expect (round 3) 3) 59 | (check-expect (round 3) 3) 60 | 61 | (check-expect (floor 3.5) 3.0) 62 | (check-expect (ceiling 3.5) 4.0) 63 | 64 | (check-expect (floor -3.5) -4.0) 65 | (check-expect (ceiling -3.5) -3.0) 66 | 67 | 68 | 69 | 70 | 71 | "math.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/permissions.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | ;; Any program that's compiled with require-permission should have 4 | ;; the permissions of the module as part of the module record. 5 | 6 | (printf "permissions.rkt\n") 7 | 8 | (require "../../permissions/require-permission.rkt") 9 | 10 | (require-permission "network") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/quasiquote.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.ss" 2 | 3 | (printf "quasiquote.rkt\n") 4 | 5 | (define name "danny") 6 | (define roommates (list "guillaume" "isis" "andy")) 7 | 8 | (check-expect `(my name is ,name and I lived with ,@roommates) 9 | '(my name is "danny" and I lived with "guillaume" "isis" "andy")) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/raise.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | "raise.rkt" 4 | 5 | (check-expect 6 | (with-handlers ([string? identity]) 7 | (raise "hello world") 8 | 42) 9 | "hello world") 10 | 11 | 12 | (check-expect (exn? (with-handlers ([void identity]) 13 | (raise (make-exn "foo" (current-continuation-marks))))) 14 | true) 15 | 16 | (check-expect (exn:fail:contract:arity? (with-handlers ([void identity]) 17 | (+ "hello" "world"))) 18 | false) 19 | 20 | (check-expect (exn:fail:contract? (with-handlers ([void identity]) 21 | (+ "hello" "world"))) 22 | true) 23 | 24 | (check-expect (exn:fail:contract:arity? (with-handlers ([void identity]) 25 | (identity "hello" "world"))) 26 | true) 27 | 28 | (check-expect (exn:fail:contract:variable? (with-handlers ([void identity]) 29 | (identity "hello" "world"))) 30 | false) 31 | 32 | 33 | 34 | "raise.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/random.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | (require "../../lang/check-expect/test-expect.rkt") 3 | "random.rkt" 4 | 5 | 6 | (let loop ([i 0]) 7 | (when (< i 1000) 8 | (begin 9 | (test-within (random 100) 50 50) 10 | (loop (add1 i))))) 11 | 12 | (let loop ([i 0]) 13 | (when (< i 1000) 14 | (begin 15 | (test-within (random) 0.5 0.5) 16 | (loop (add1 i))))) 17 | 18 | "random.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/recur.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | 4 | "recur.rkt" 5 | (check-expect 6 | (recur loop ([i 0]) 7 | (cond [(= i 10) '()] 8 | [else 9 | (cons (* i i) 10 | (loop (add1 i)))])) 11 | '(0 1 4 9 16 25 36 49 64 81)) 12 | 13 | "recur.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/repeating-decimals.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | "repeating-decimals.rkt" 4 | 5 | 6 | 1/3 7 | 3227/555 8 | 1/9 9 | 1/3 10 | 2/3 11 | 9/11 12 | 7/12 13 | 1/81 14 | 22/7 15 | 16 | 1/7 17 | 1/17 18 | 1/19 19 | 1/23 20 | 1/97 21 | 1/29 22 | 23 | "repeating-decimals.rkt end" 24 | 25 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/require.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | (require "required.rkt") 3 | 4 | (require (prefix-in a-prefix: (only-in "required.rkt" f))) 5 | 6 | (require "required-2.rkt") 7 | 8 | (printf "require.rkt\n") 9 | 10 | (define (blah) 11 | 'blaaargh) 12 | 13 | (check-expect (blah) 'blaaargh) 14 | 15 | (check-expect (f 42) (* 42 42)) 16 | 17 | (check-expect (hypo 3 4) 5) 18 | 19 | (check-expect (h 16) (expt 16 5)) 20 | 21 | (check-expect (a-prefix:f 42) (* 42 42)) 22 | 23 | 24 | (check-expect (a-struct-x (make-a-struct 3 4 5)) 3) 25 | (check-expect (a-struct? (make-a-struct 3 4 5)) true) 26 | 27 | 28 | (check-expect game-name "Evolution chamber") 29 | 30 | ;; Hopefully, all-except-out will prevent a collision 31 | ;; between this binding and the one in required-5.rkt 32 | (define clashing-value "value with a binding in required-5.rkt") 33 | (check-expect clashing-value 34 | "value with a binding in required-5.rkt") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/required-2.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.ss" 2 | 3 | (require "required-3.rkt") 4 | (require "required-5.rkt") 5 | 6 | (provide hypo 7 | h) 8 | 9 | 10 | (define-struct a-struct (x y z)) 11 | (provide (struct-out a-struct)) 12 | 13 | 14 | (provide (except-out (all-from-out "required-5.rkt") 15 | clashing-value)) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/required-3.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.ss" 2 | 3 | (require "required-4.rkt") 4 | 5 | (provide (rename-out (-hypo hypo)) h) 6 | 7 | (define (-hypo a b) 8 | (sqrt (+ (sqr a) (sqr b)))) 9 | 10 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/required-4.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.ss" 2 | 3 | (provide (all-defined-out)) 4 | 5 | (define (h x) 6 | (* x x x x x)) 7 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/required-5.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (provide (all-defined-out)) 4 | 5 | (define game-name "Evolution chamber") 6 | 7 | 8 | (define clashing-value "don't look at me!") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/required.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | (provide f) 3 | 4 | (define (f x) 5 | (* x x)) 6 | 7 | 8 | (define h 'something-else) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/rotate.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | 4 | "rotate and scale" 5 | 6 | (printf "Three images at 30, 60, 90 degree rotation:\n") 7 | 8 | (rotate 30 (image-url "http://racket-lang.org/logo.png")) 9 | (rotate 60 (image-url "http://racket-lang.org/logo.png")) 10 | (rotate 90 (image-url "http://racket-lang.org/logo.png")) 11 | 12 | 13 | (printf "scaling small and large") 14 | (scale 1/2 (image-url "http://racket-lang.org/logo.png")) 15 | (scale 2 (image-url "http://racket-lang.org/logo.png")) 16 | 17 | (scale/xy 1 2 (image-url "http://racket-lang.org/logo.png")) 18 | (scale/xy 2 1 (image-url "http://racket-lang.org/logo.png")) 19 | 20 | "This should be the normal image" 21 | (scale/xy 1 1 (image-url "http://racket-lang.org/logo.png")) 22 | 23 | 24 | "Rotated, huge image" 25 | (rotate 30 (scale 3 (image-url "http://racket-lang.org/logo.png"))) 26 | 27 | "rotate and scale end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/run-all-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../../main.rkt") 3 | (run-in-browser "all-tests.rkt") 4 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/seconds.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (printf "current seconds: ~a\n" (current-seconds)) 4 | 5 | (printf "current-inexact-milliseconds: ~a\n" 6 | (current-inexact-milliseconds)) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/sleep.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (sleep 0) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/values.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | (require "../../lang/check-expect/test-expect.rkt") 3 | 4 | "values.rkt" 5 | 6 | (call-with-values (lambda () (values 3 4 5)) 7 | (lambda (x y z) 8 | (test-expect x 3) 9 | (test-expect y 4) 10 | (test-expect z 5))) 11 | 12 | (call-with-values (lambda () (values 3 4 5)) 13 | (lambda args 14 | (test-expect args '(3 4 5)))) 15 | 16 | (call-with-values (lambda () (values)) 17 | (lambda () 18 | (void))) 19 | 20 | 21 | 22 | "values.rkt end" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/vararity.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | "vararity" 4 | (define f (lambda args args)) 5 | 6 | (check-expect (f) empty) 7 | (check-expect (f 1 2) '(1 2)) 8 | "vararity done" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/vector.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/wescheme.rkt" 2 | 3 | (require "../../lang/check-expect/test-expect.rkt") 4 | (printf "vector.rkt\n") 5 | 6 | 7 | (define v (build-vector 5 (lambda (a) a))) 8 | (test-expect v #(0 1 2 3 4)) 9 | (test-expect (vector-length v) 5) 10 | 11 | (test-expect (vector? v) true) 12 | (test-expect (vector? '(not a vector)) false) 13 | 14 | 15 | (define v2 (build-vector 5 (lambda (a) (* a a)))) 16 | (test-expect v2 #(0 1 4 9 16)) 17 | 18 | (test-expect (vector->list #()) '()) 19 | (test-expect (vector->list v2) '(0 1 4 9 16)) 20 | 21 | 22 | (test-expect (list->vector '()) #()) 23 | (test-expect (list->vector '(a b c)) #(a b c)) 24 | 25 | 26 | (define v3 (vector 'hello 'world)) 27 | (test-expect v3 '#(hello world)) 28 | (vector-set! v3 0 'hola) 29 | (test-expect v3 '#(hola world)) 30 | (test-expect (vector-ref v3 0) 'hola) 31 | 32 | 33 | 34 | 35 | (printf "vector.rkt end\n") 36 | 37 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/when-unless.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.ss" 2 | 3 | 4 | (printf "when-unless.rkt\n") 5 | 6 | (when (= (expt 2 100) 7 | 1267650600228229401496703205376) 8 | 'ok) 9 | 10 | (unless (not (= (expt 2 100) 11 | 1/1267650600228229401496703205376)) 12 | (error 'not-ok)) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/with-handlers-1.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | 4 | (printf "with-handlers-1.rkt\n") 5 | 6 | (with-handlers ([(lambda (exn) 7 | (printf "Is the exception a failure? ~s~n" (exn:fail? exn)) 8 | (exn:fail? exn)) 9 | (lambda (exn) 10 | (printf "I'm in the handler and saying ok\n") 11 | 'ok)]) 12 | (/ 1 0) 13 | (error 'not-ok)) 14 | 15 | 16 | 17 | (with-handlers ([(lambda (exn) 18 | false) 19 | (lambda (exn) 20 | (printf "I'm in the handler and saying ok\n") 21 | (error 'not-ok))] 22 | [(lambda (exn) 23 | (printf "second test\n") 24 | true) 25 | (lambda (exn) 26 | 'ok)]) 27 | (/ 1 0) 28 | (error 'not-ok)) 29 | 30 | 31 | 32 | (with-handlers ([void (lambda (exn) (error 'not-ok))]) 33 | 'ok) 34 | 35 | 36 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/moby-programs/with-handlers-2.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | 4 | (printf "Testing with-handlers-2.rkt\n"); 5 | 6 | (with-handlers ([void (lambda (exn) 'ok)]) 7 | (with-handlers ([1 2]) 8 | (/ 1 0) 9 | (error "expected an error"))) 10 | 11 | 12 | (with-handlers ([void (lambda (exn) 'ok)]) 13 | (with-handlers ([void 2]) 14 | (/ 1 0) 15 | (error "expected an error"))) 16 | 17 | (with-handlers ([void (lambda (exn) 18 | (printf "outer\n") 19 | (error 'not-ok))]) 20 | (with-handlers ([void (lambda (exn) 21 | 'ok)]) 22 | (/ 1 0) 23 | (error "expected an error"))) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/mz-tests/all-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (require "basic.rkt" 4 | #;"number.rkt") 5 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/mz-tests/missing-features.txt: -------------------------------------------------------------------------------- 1 | mcons, mcar, mcdr, set-mcar!, set-mcdr! 2 | 3 | make-weak-box, weak-box-value, weak-box? 4 | 5 | hash-eq? hash-count 6 | make-immutable-hasheq, make-immutable-hash 7 | make-hasheqv 8 | make-weak-hasheq, make-weak-hash, make-weak-hasheqv 9 | 10 | parameterize 11 | read-case-sensitive 12 | 13 | keywords: keyword? string->keyword keyword->string 14 | 15 | eq-hash-code 16 | 17 | string-copy! 18 | 19 | exn:fail:out-of-memory? 20 | 21 | regular expressions: regexp-match, regexp-match-positions, ... 22 | 23 | call-with-escape-continuation, dynamic-wind, let/ec, call/ec 24 | 25 | call-with-exception-handler, uncaught-exception-handler 26 | 27 | normalize-arity 28 | 29 | read 30 | 31 | make-placeholder 32 | 33 | version, banner, system-type, current-command-line-arguments, system-library-subpath, current-output-port 34 | 35 | eval, eval-jit-enabled 36 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/mz-tests/run-all-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../../main.rkt") 3 | (run-in-browser "all-tests.rkt") 4 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/require-test/m.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | 3 | (require "m2.rkt" 4 | "m3.rkt") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/require-test/m1.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" -------------------------------------------------------------------------------- /whalesong/tests/older-tests/require-test/m2.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | (require "m1.rkt") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/require-test/m3.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../../lang/base.rkt" 2 | (require "m1.rkt") -------------------------------------------------------------------------------- /whalesong/tests/older-tests/require-test/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; check to see that multiple invokations don't duplicate code generation. 4 | 5 | (require "../../private/compile-moby-module.rkt" 6 | "../../private/module-record.rkt" 7 | racket/runtime-path) 8 | 9 | (define-runtime-path m.rkt 10 | "m.rkt" 11 | #;"/home/dyoo/Downloads/tmp/Package/tourguide.rkt") 12 | 13 | (define (check-module-names-unique! module-records) 14 | (let ([names (map module-record-name module-records)]) 15 | (unless (unique? names) 16 | (error 'check-module-names-unique! 17 | "modules with non-unique names: ~s" names)))) 18 | 19 | 20 | (define (unique? names) 21 | (let ([ht (make-hash)]) 22 | (let/ec return 23 | (for ([n names]) 24 | (cond [(hash-ref ht n #f) 25 | (return #f)] 26 | [else 27 | (hash-set! ht n #t)]) 28 | (return #t))))) 29 | 30 | 31 | 32 | 33 | 34 | (define (test) 35 | (define modules 36 | (compile-moby-modules m.rkt)) 37 | (check-module-names-unique! modules)) 38 | 39 | 40 | (test) -------------------------------------------------------------------------------- /whalesong/tests/older-tests/run-all-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list 3 | "../main.rkt" 4 | racket/runtime-path 5 | racket/system 6 | "check-coverage.rkt") 7 | 8 | (define-runtime-path my-directory ".") 9 | 10 | (when (find-executable-path "node") 11 | (printf "Running the VM internal test suite\n") 12 | (parameterize ([current-directory my-directory]) 13 | (system "unit-tests/run-tests") 14 | (printf "Press Enter to continue.\n") 15 | (void (read-line)))) 16 | 17 | 18 | (printf "Checking for untouched wescheme primitives\n") 19 | (unless (empty? (untouched-wescheme-primitives)) 20 | (print-coverage-report) 21 | (printf "Press Enter to continue.\n") 22 | (void (read-line))) 23 | 24 | (printf "Running browser tests\n") 25 | (run-in-browser "all-tests.rkt") 26 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/unit-tests/browser/build-tests: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cd `dirname $0` 4 | 5 | ../../../lib/build-test browser run-tests.js 6 | cat ../tests.js >> run-tests.js 7 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/unit-tests/browser/webTest.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | MzScheme VM Tests 4 | 5 | 6 | 7 |

    MzScheme VM Tests

    8 | 9 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /whalesong/tests/older-tests/unit-tests/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cd `dirname $0` 4 | 5 | if [ -z $1 ] || [ $1 == 'unit' ] 6 | then 7 | srcFile='tests.js' 8 | target='exec-tests.js' 9 | else if [ $1 == 'struct' ] 10 | then 11 | srcFile='struct-tests.js' 12 | target='exec-struct-tests.js' 13 | else 14 | echo $1 'is not a valid type of test' 15 | exit 16 | fi 17 | fi 18 | 19 | #if [ -f $target ] 20 | # then 21 | # echo "File exec-tests.js already exists." 22 | # echo "Please remove" $target "or use a different file." 23 | # exit 24 | #fi 25 | 26 | rm -f $target 27 | 28 | echo 'Building support files' 29 | echo 30 | ../../private/lib/build-test node $target 31 | echo 32 | 33 | #cat imports.js >> $target 34 | cat $srcFile >> $target 35 | node $target 36 | #rm -f $target 37 | -------------------------------------------------------------------------------- /whalesong/tests/test-all.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "test-parse.rkt" 4 | "test-parse-bytecode.rkt" 5 | ;; "test-simulator.rkt" 6 | ;; "test-compiler.rkt" 7 | ;; "test-compiler-2.rkt" 8 | "test-assemble.rkt" 9 | ;; "test-browser-evaluate.rkt" 10 | "test-package.rkt" 11 | "test-get-dependencies.rkt" 12 | "run-more-tests.rkt") 13 | -------------------------------------------------------------------------------- /whalesong/tests/test-helpers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (prefix-in racket: racket/base) 4 | racket/runtime-path 5 | "../compiler/compiler-structs.rkt" 6 | "../compiler/compiler.rkt" 7 | "../parser/parse-bytecode.rkt" 8 | "../get-module-bytecode.rkt" 9 | "../language-namespace.rkt") 10 | 11 | 12 | 13 | (provide parse parse-module run-compiler) 14 | 15 | (define-runtime-path kernel-language-path 16 | "../lang/kernel.rkt") 17 | 18 | 19 | ;; Use Racket's compiler, and then parse the resulting bytecode 20 | ;; to our own AST structures. 21 | (define (parse stx) 22 | (parameterize ([current-namespace (lookup-language-namespace 23 | `(file ,(path->string kernel-language-path)) 24 | #;'racket/base)] 25 | ;; We want to disable some optimizations for the moment. 26 | ;; See: http://docs.racket-lang.org/drracket/module.html 27 | [compile-context-preservation-enabled #t]) 28 | 29 | (let ([bc (racket:compile stx)] 30 | [op (open-output-bytes)]) 31 | (write bc op) 32 | (parse-bytecode 33 | (open-input-bytes (get-output-bytes op)))))) 34 | 35 | 36 | (define (parse-module x) 37 | (parse-bytecode (open-input-bytes (get-module-bytecode x)))) 38 | 39 | 40 | (define (run-compiler code) 41 | (compile (parse code) 'val next-linkage/drop-multiple)) -------------------------------------------------------------------------------- /whalesong/tests/test-package.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../js-assembler/package.rkt" 4 | "../make/make-structs.rkt") 5 | 6 | (printf "test-package.rkt\n") 7 | 8 | 9 | (define (follow? src) 10 | #t) 11 | 12 | (define (test s-exp) 13 | (package (make-SexpSource s-exp) 14 | #:should-follow-children? follow? 15 | #:output-port (open-output-string) #;(current-output-port))) 16 | 17 | 18 | (test '(define (factorial n) 19 | (if (= n 0) 20 | 1 21 | (* (factorial (- n 1)) 22 | n)))) 23 | (test '(let () 24 | (define (factorial n) 25 | (fact-iter n 1)) 26 | (define (fact-iter n acc) 27 | (if (= n 0) 28 | acc 29 | (fact-iter (- n 1) (* acc n)))) 30 | 'ok)) 31 | 32 | (test '(define (gauss n) 33 | (if (= n 0) 34 | 0 35 | (+ (gauss (- n 1)) 36 | n)))) 37 | 38 | (test '(define (fib n) 39 | (if (< n 2) 40 | 1 41 | (+ (fib (- n 1)) 42 | (fib (- n 2)))))) -------------------------------------------------------------------------------- /whalesong/type-helpers.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | (require (for-syntax racket/base 3 | syntax/parse)) 4 | 5 | ;; Provides helpers for use with Typed Racket programs. 6 | 7 | (provide ensure-type-subsetof) 8 | 9 | 10 | ;; Usage: (ensure-type-subsetof subtype supertype) 11 | ;; 12 | ;; Statically errors out if subtype is not within supertype. 13 | ;; 14 | (define-syntax (ensure-type-subsetof stx) 15 | (syntax-parse stx 16 | [(_ subtype:id supertype:id) 17 | ;; begin-splicing 18 | (with-syntax ([x (syntax/loc stx x)]) 19 | #`(void (lambda () (ann (values (ann #,(syntax/loc stx (error 'fail)) 20 | subtype)) supertype))))])) 21 | 22 | 23 | 24 | 25 | #| 26 | (define-type T0 (U 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o 'p 27 | 'q 'r 's 't 'u 'v 'w 'x 'y 'z)) 28 | (define-type T1 (U 'a 29 | 'e 30 | 'i 31 | 'o 32 | 'u)) 33 | (ensure-type-subsetof T1 T0) 34 | 35 | 36 | 37 | (define-struct: Id ([name : Symbol])) 38 | (define-struct: Num ([datum : Number])) 39 | (define-struct: Add ([lhs : Expr] 40 | [rhs : Expr])); 41 | (define-type Expr 42 | (U Id 43 | ;; Num ;; Uncomment to correct the type error 44 | Add)) 45 | (define-type ConstantExpr (U Id Num)) 46 | 47 | ;; And if we mess up at least it errors out at compile time 48 | (ensure-type-subsetof ConstantExpr Expr) 49 | |# -------------------------------------------------------------------------------- /whalesong/version-case/version-case.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (planet dyoo/version-case:1:9)) 3 | (provide (all-from-out (planet dyoo/version-case:1:9))) -------------------------------------------------------------------------------- /whalesong/version.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | ;; This is an internal version string. It should have no external meaning. 4 | ;; This file is touched by "bump.version.rkt": do not edit this file manually unless 5 | ;; you really know what you're doing. 6 | 7 | (provide version) 8 | (: version String) 9 | 10 | (define version "1.240") 11 | -------------------------------------------------------------------------------- /whalesong/web-world.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "lang/base.rkt" 2 | (require "web-world/main.rkt") 3 | (provide (all-from-out "web-world/main.rkt")) 4 | -------------------------------------------------------------------------------- /whalesong/web-world/event.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | 3 | (provide (all-defined-out)) 4 | 5 | (define-struct event (kvpairs)) 6 | 7 | 8 | (define (event-keys an-evt) 9 | (map car (event-kvpairs an-evt))) 10 | 11 | 12 | (define (event-ref an-evt a-key) 13 | (define clean-key (cond 14 | [(symbol? a-key) 15 | a-key] 16 | [(string? a-key) 17 | (string->symbol a-key)] 18 | [else 19 | (raise-type-error 'event-ref "symbol or string" a-key)])) 20 | (define kv (assq clean-key (event-kvpairs an-evt))) 21 | (cond [(eq? kv #f) 22 | (error 'event-ref "Could not find key ~a" a-key)] 23 | [else 24 | (car (cdr kv))])) 25 | 26 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/attr-animation/attr-animation.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/resource 4 | whalesong/web-world) 5 | 6 | (define-resource index.html) 7 | (define-resource style.css) 8 | 9 | (define (tick w v) 10 | (modulo (add1 w) 10)) 11 | 12 | 13 | ;; pick-block: view number -> view 14 | ;; Focus the view on block i. 15 | (define (pick-block v i) 16 | (view-focus v (format "~a" i))) 17 | 18 | 19 | (define (draw w v) 20 | (define v1 (update-view-attr 21 | (pick-block v w) 22 | "class" 23 | "selectedBlock")) 24 | (define v2 (update-view-attr 25 | (pick-block v1 (modulo (sub1 w) 10)) 26 | "class" 27 | "offsetBlock")) 28 | (define v3 (update-view-attr 29 | (pick-block v2 (modulo (add1 w) 10)) 30 | "class" 31 | "offsetBlock")) 32 | (define v4 (update-view-attr 33 | (pick-block v3 (modulo (- w 2) 10)) 34 | "class" 35 | "block")) 36 | (define v5 (update-view-attr 37 | (pick-block v4 (modulo (+ w 2) 10)) 38 | "class" 39 | "block")) 40 | v5) 41 | 42 | 43 | (big-bang 0 44 | (initial-view index.html) 45 | (on-tick tick) 46 | (to-draw draw)) 47 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/attr-animation/style.css: -------------------------------------------------------------------------------- 1 | .block { 2 | width : 80px; 3 | height : 10px; 4 | background-color : blue; 5 | display: inline-block; 6 | } 7 | 8 | .selectedBlock { 9 | width : 80px; 10 | height : 10px; 11 | background-color: navy; 12 | display: inline-block; 13 | } 14 | 15 | .offsetBlock { 16 | width : 80px; 17 | height : 10px; 18 | background-color: teal; 19 | display: inline-block; 20 | } -------------------------------------------------------------------------------- /whalesong/web-world/examples/boid/index.html: -------------------------------------------------------------------------------- 1 | 2 | Boid 3 | 14 | 15 | 16 |
    17 |
    18 | 19 | 20 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/color-buttons/color-buttons.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/web-world 4 | whalesong/resource) 5 | 6 | ;; The world is a string, the current color. 7 | (define-resource view.html) 8 | 9 | 10 | ;; update the world to the color indicated by the clicked button's 11 | ;; value. 12 | (define (click w v) 13 | (view-form-value v)) 14 | 15 | (define bound-view 16 | (view-bind-many view.html 17 | ["red-button" "click" click] 18 | ["gray-button" "click" click] 19 | ["blue-button" "click" click] 20 | ["orange-button" "click" click] 21 | ["green-button" "click" click] 22 | ["black-button" "click" click])) 23 | 24 | (define (draw w v) 25 | (define view-on-header (view-focus v "header")) 26 | (update-view-css view-on-header "color" w)) 27 | 28 | 29 | (big-bang "Black" 30 | (initial-view bound-view) 31 | (to-draw draw)) 32 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/color-buttons/view.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 |

    This is a header

    6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/dwarves-with-remove/dwarves-with-remove.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | (define-resource index.html) 5 | 6 | ;; The world is the set of dwarfs. 7 | 8 | 9 | ;; make-item: string -> view 10 | (define (make-item name) 11 | (view-bind (->view `(li ,name)) 12 | "click" 13 | hide-on-click)) 14 | 15 | 16 | ;; When a dwarf clicks, it hides! 17 | (define (hide-on-click w v) 18 | (remove (view-id v) w)) 19 | 20 | 21 | (define dwarf-names 22 | '("Doc" "Grumpy" "Happy" "Sleepy" "Bashful" "Sneezy" "Dopey")) 23 | 24 | 25 | ;; Update the view so it shows the next dwarf on the scene, 26 | ;; until we're all done. 27 | (define (draw w dom-view) 28 | (foldl (lambda (name view) 29 | (cond [(view-focus? view name) 30 | (define focused (view-focus view name)) 31 | (cond 32 | [(member name w) 33 | view] 34 | [else 35 | (view-remove focused)])] 36 | [else 37 | view])) 38 | dom-view 39 | dwarf-names)) 40 | 41 | 42 | 43 | ;; The first view consists of index.html. We attach event handlers 44 | ;; to each name here. 45 | (define my-view 46 | (view-bind-many* (->view index.html) 47 | (map (lambda (name) 48 | (list name "click" hide-on-click)) 49 | dwarf-names))) 50 | 51 | 52 | (big-bang dwarf-names 53 | (initial-view my-view) 54 | (to-draw draw)) 55 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/dwarves-with-remove/index.html: -------------------------------------------------------------------------------- 1 | 2 | Dwarves 3 | 4 |

    Dwarfs from Snow White

    5 |

    Click on a dwarf to make them hide.

    6 |
      7 |
    • Doc
      • 8 |
    • Grumpy
      • 9 |
    • Happy
      • 10 |
    • Sleepy
      • 11 |
    • Bashful
      • 12 |
    • Sneezy
      • 13 |
    • Dopey
      • 14 |
    15 | 16 | 17 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/dwarves/dwarves.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | (define-resource index.html) 5 | 6 | ;; The world is the set of dwarfs. 7 | 8 | 9 | ;; make-item: string -> view 10 | (define (make-item name) 11 | (view-bind (->view `(li ,name)) 12 | "click" 13 | hide-on-click)) 14 | 15 | 16 | ;; When a dwarf clicks, it hides! 17 | (define (hide-on-click w v) 18 | (remove (view-id v) w)) 19 | 20 | 21 | (define dwarf-names 22 | '("Doc" "Grumpy" "Happy" "Sleepy" "Bashful" "Sneezy" "Dopey")) 23 | 24 | 25 | ;; Update the view so it shows the next dwarf on the scene, 26 | ;; until we're all done. 27 | (define (draw w dom-view) 28 | (foldl (lambda (name view) 29 | (define focused (view-focus view name)) 30 | (cond 31 | [(member name w) 32 | (view-show focused)] 33 | [else 34 | (view-hide focused)])) 35 | dom-view 36 | dwarf-names)) 37 | 38 | 39 | 40 | ;; The first view consists of index.html. We attach event handlers 41 | ;; to each name here. 42 | (define my-view 43 | (foldl (lambda (name view) 44 | (view-bind (view-focus view name) 45 | "click" 46 | hide-on-click)) 47 | (->view index.html) 48 | dwarf-names)) 49 | 50 | 51 | (big-bang dwarf-names 52 | (initial-view my-view) 53 | (to-draw draw)) 54 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/dwarves/index.html: -------------------------------------------------------------------------------- 1 | 2 | Dwarves 3 | 4 |

    Dwarfs from Snow White

    5 |

    Click on a dwarf to make them hide.

    6 |
      7 |
    • Doc
      • 8 |
    • Grumpy
      • 9 |
    • Happy
      • 10 |
    • Sleepy
      • 11 |
    • Bashful
      • 12 |
    • Sneezy
      • 13 |
    • Dopey
      • 14 |
    15 | 16 | 17 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/field/field.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | 5 | (define-resource index.html) 6 | 7 | ;; The world is a string which represents the name of the user. 8 | 9 | 10 | ;; on-click: world view -> world 11 | ;; When the user clicks on the button, grab at the text of the 12 | ;; text-field. 13 | (define (on-click w button-view) 14 | (view-form-value (view-focus button-view "text-field"))) 15 | 16 | 17 | ;; draw: world view -> view 18 | ;; Take the view, and replace the template with the world value. 19 | (define (draw w dom) 20 | (update-view-text (view-focus dom "template") 21 | w)) 22 | 23 | 24 | (define my-view (view-bind (view-focus (->view index.html) 25 | "button") 26 | "click" 27 | on-click)) 28 | 29 | (big-bang "Jane Doe" 30 | (initial-view my-view) 31 | (to-draw draw)) 32 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/field/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | My simple program 4 | 5 | 6 | 7 | 8 | 9 | 10 |

    Hello fill-me-in!

    11 | 12 | 13 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/field2/field2.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | 5 | (define-resource index.html) 6 | 7 | ;; The world is: 8 | (define-struct world (name 9 | elapsed)) 10 | 11 | 12 | ;; on-click: world view -> world 13 | ;; When the user clicks on the button, grab at the text of the 14 | ;; text-field. 15 | (define (on-click w button-view) 16 | (make-world (view-form-value (view-focus button-view "text-field")) 17 | (world-elapsed w))) 18 | 19 | 20 | (define (tick w view) 21 | (make-world (world-name w) 22 | (add1 (world-elapsed w)))) 23 | 24 | 25 | ;; draw: world view -> view 26 | ;; Take the view, and replace the template with the world value. 27 | (define (draw w dom) 28 | (update-view-text 29 | (view-focus (update-view-text (view-focus dom "template") 30 | (world-name w)) 31 | "header") 32 | (if (= (world-elapsed w) 1) 33 | (format "~a second has elapsed" (world-elapsed w)) 34 | (format "~a seconds have elapsed" (world-elapsed w))))) 35 | 36 | 37 | (define my-view (view-bind (view-focus (->view index.html) 38 | "button") 39 | "click" 40 | on-click)) 41 | 42 | 43 | (big-bang (make-world "Jane Doe" 0) 44 | (initial-view my-view) 45 | (to-draw draw) 46 | (on-tick tick 1)) 47 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/field2/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | My simple program 4 | 5 | 6 | 7 |

    *foo* seconds have elapsed

    8 | 9 | 10 | 11 |

    Hello fill-me-in!

    12 | 13 | 14 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/forward-backward/index.html: -------------------------------------------------------------------------------- 1 | 2 | Test 3 | 4 |

    This is a test

    5 | 6 | 7 |
    8 | 9 | 10 | 11 | 12 | 13 |
    First Row
    Middle Row
    Last Row
    14 |
      15 |
    • Item one
      • 16 |
    • Item two
      • 17 |
    • 18 |
        19 |
      • Nested item one
        • 20 |
      • Nested item two
        • 21 |
      22 |
      • 23 |
    24 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/hello/hello.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | 5 | (define-resource index.html) 6 | (define-resource style.css) 7 | 8 | (big-bang "don't care" 9 | (initial-view index.html)) 10 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/hello/index.html: -------------------------------------------------------------------------------- 1 | 2 | Hello world 3 | 4 | 5 |

    Hello world

    6 | This is a test of the emergency broadcast system. 7 |
      8 |
    1. Item one
      2. 9 |
    2. Item two
      3. 10 |
    11 | 12 | 13 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/hello/style.css: -------------------------------------------------------------------------------- 1 | h1 { 2 | color: blue; 3 | } -------------------------------------------------------------------------------- /whalesong/web-world/examples/hello2/hello2.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/web-world) 4 | 5 | (big-bang 0 (initial-view "hello world")) 6 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/hot-cross-buns/index.html: -------------------------------------------------------------------------------- 1 | 2 | Hot Cross Buns 3 | 4 | Hot 5 | Cross 6 | Buns 7 | 8 |
    9 | 10 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/phases/index1.html: -------------------------------------------------------------------------------- 1 |
    This is phase one
    2 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/phases/index2.html: -------------------------------------------------------------------------------- 1 |
    2 |

    This is phase two.

    3 | 4 | 5 | 6 |

    Isn't this different?

    7 |
    8 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/phases/phases.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | 5 | (define-resource index1.html) 6 | (define-resource index2.html) 7 | 8 | 9 | ;; draw: world view -> view 10 | (define (draw w v) 11 | (cond 12 | [(= (modulo w 2) 0) 13 | index1.html] 14 | [else 15 | index2.html])) 16 | 17 | 18 | ;; tick: world view -> world 19 | (define (tick w v) 20 | (+ w 1)) 21 | 22 | 23 | (printf "Before the big bang\n") 24 | (big-bang 0 25 | (initial-view index1.html) 26 | (to-draw draw) 27 | (on-tick tick 1) 28 | (stop-when (lambda (w v) 29 | (> w 10)))) 30 | (printf "After the big bang\n") 31 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/redirected/index.html: -------------------------------------------------------------------------------- 1 | 2 | My simple program 3 | 4 |

    The current counter is: fill-me-in

    5 | 6 | 7 |

    There is content from the printf statements going into 8 | the hidden div below:

    9 | 10 |
    12 | 13 | 14 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/redirected/redirected.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | 5 | (define-resource index.html) 6 | 7 | (current-output-port (open-output-element "stdout")) 8 | 9 | 10 | ;; draw: world view -> view 11 | (define (draw w v) 12 | (update-view-text (view-focus v "counter") w)) 13 | 14 | 15 | 16 | ;; tick: world view -> world 17 | (define (tick w v) 18 | (printf "Tick ~s\n" w) 19 | (+ w 1)) 20 | 21 | (big-bang 0 22 | (initial-view index.html) 23 | (to-draw draw) 24 | (on-tick tick 1) 25 | (stop-when (lambda (w v) 26 | (> w 10)))) 27 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/tick-tock-2/tick-tock-2.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world) 3 | 4 | ;; tick: world view -> world 5 | (define (tick world view) 6 | (add1 world)) 7 | 8 | ;; draw: world view -> view 9 | (define (draw world view) 10 | (view-append-child view 11 | (xexp->dom `(p "hello, can you see this? " 12 | ,(number->string world))))) 13 | 14 | (big-bang 0 (initial-view 15 | (xexp->dom '(html (head) (body)))) 16 | (on-tick tick 1) 17 | (to-draw draw)) 18 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/tick-tock/index.html: -------------------------------------------------------------------------------- 1 | 2 | My simple program 3 | 4 |

    The current counter is: fill-me-in

    5 | 6 | 7 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/tick-tock/tick-tock.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | (require whalesong/web-world 3 | whalesong/resource) 4 | 5 | (define-resource index.html) 6 | 7 | 8 | ;; draw: world view -> view 9 | (define (draw w dom) 10 | (update-view-text (view-focus dom "counter") w)) 11 | 12 | 13 | 14 | ;; tick: world view -> world 15 | (define (tick w v) 16 | (add1 w)) 17 | 18 | (define (stop? world dom) 19 | (> world 10)) 20 | 21 | (big-bang 0 22 | (initial-view index.html) 23 | (to-draw draw) 24 | (on-tick tick 1) 25 | (stop-when stop?)) 26 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/todo/index.html: -------------------------------------------------------------------------------- 1 | 2 | TODO List 3 | 4 |

    TODO

    5 | 6 |

    Items

    7 |
      8 | 9 | 10 |

      Adding an item

      11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /whalesong/web-world/examples/where-am-i/index.html: -------------------------------------------------------------------------------- 1 | 2 | Where in the world am I? 3 | 4 |

      5 | I am at: dunno. 6 | The mock location says: dunno. 7 |

      8 | 9 | 10 | -------------------------------------------------------------------------------- /whalesong/web-world/helpers.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | 3 | (provide fresh-id) 4 | 5 | 6 | ;; fresh-id: -> string 7 | ;; Returns a freshly generated id. 8 | (define (fresh-id) 9 | (symbol->string (gensym 'fresh-web-world-id))) 10 | -------------------------------------------------------------------------------- /whalesong/web-world/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define compile-omit-paths '("examples")) 4 | -------------------------------------------------------------------------------- /whalesong/wescheme/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | #:language (lambda (ip) `(file ,(path->string semantics-path))) 3 | (require racket/runtime-path) 4 | (define-runtime-path semantics-path "semantics.rkt") 5 | -------------------------------------------------------------------------------- /whalesong/wescheme/lang/semantics.rkt: -------------------------------------------------------------------------------- 1 | #lang whalesong 2 | 3 | (require whalesong/image 4 | whalesong/world 5 | whalesong/lang/whalesong) 6 | 7 | (provide (all-from-out whalesong/lang/whalesong) 8 | (all-from-out whalesong/image) 9 | (all-from-out whalesong/world)) 10 | -------------------------------------------------------------------------------- /whalesong/whalesong.rkt: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env racket 2 | #lang racket/base 3 | 4 | (require racket/runtime-path 5 | racket/path 6 | syntax/modresolve) 7 | 8 | ;; We do things this way to ensure that we're using the latest 9 | ;; version of whalesong that's installed, and that the load-relative 10 | ;; path is in terms of the normalized paths, to avoid a very strange 11 | ;; low-level bug. 12 | (define whalesong.cmd 13 | (resolve-module-path 'whalesong/whalesong-cmd #f)) 14 | 15 | (dynamic-require (normalize-path whalesong.cmd) #f) 16 | -------------------------------------------------------------------------------- /whalesong/world.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "lang/base.rkt" 2 | (require "world/main.rkt") 3 | 4 | (provide (all-from-out "world/main.rkt")) 5 | -------------------------------------------------------------------------------- /whalesong/world/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define compile-omit-paths '("scratch")) 4 | -------------------------------------------------------------------------------- /whalesong/world/main.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/js/js.rkt" 2 | 3 | (require "../image.rkt") 4 | 5 | (declare-implementation 6 | #:racket "racket-impl.rkt" 7 | #:javascript ( 8 | ;; the raw implementation doesn't know anything about 9 | ;; Whalesong. 10 | "raw-jsworld.js" 11 | 12 | ;; We add Whalesong-specific things here. 13 | "kernel.js" 14 | "js-impl.js" 15 | ) 16 | #:provided-values (big-bang 17 | on-tick 18 | on-key 19 | on-mouse 20 | key=? 21 | to-draw 22 | stop-when)) 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /whalesong/world/racket-impl.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "../lang/base.rkt" 2 | 3 | (provide big-bang 4 | to-draw 5 | on-tick 6 | on-mouse 7 | on-key 8 | key=? 9 | stop-when) 10 | 11 | 12 | ;; Fixme: the errors below need to be replaced with 2htdp/world-based 13 | ;; implementations. 14 | 15 | 16 | (define (big-bang initial-world . args) 17 | (error 'big-bang "must be run in JavaScript context")) 18 | 19 | 20 | (define on-tick 21 | (case-lambda [(handler) 22 | (error 'on-tick "must be run in JavaScript context")] 23 | [(handler interval) 24 | (error 'on-tick "must be run in JavaScript context")])) 25 | 26 | 27 | (define (on-mouse handle) 28 | (error 'on-mouse "must be run in JavaScript context")) 29 | 30 | (define (to-draw handler) 31 | (error 'to-draw "must be run in JavaScript context")) 32 | 33 | (define (on-key handler) 34 | (error 'on-key "must be run in JavaScript context")) 35 | 36 | (define (key=? key-1 key-2) 37 | (error 'key=? "must be run in JavaScript context")) 38 | 39 | (define (stop-when handler) 40 | (error 'stop-when "must be run in JavaScript context")) 41 | --------------------------------------------------------------------------------