diff --git a/compiler/kernel-primitives.rkt b/compiler/kernel-primitives.rkt index 7155da6..46f41c1 100644 --- a/compiler/kernel-primitives.rkt +++ b/compiler/kernel-primitives.rkt @@ -71,6 +71,8 @@ 'current-inspector 'make-struct-field-accessor 'make-struct-field-mutator + + 'gensym )) (define-predicate KernelPrimitiveName? KernelPrimitiveName) diff --git a/examples/maze.rkt b/examples/maze.rkt new file mode 100644 index 0000000..7ea2961 --- /dev/null +++ b/examples/maze.rkt @@ -0,0 +1,21 @@ +#lang planet dyoo/whalesong + +;; Maze generation via Recursive Backtracking technique. +;; http://weblog.jamisbuck.org/2010/12/27/maze-generation-recursive-backtracking + +(define-struct cell (carved visited) #:mutable #:transparent) + +(define (make-grid width height f) + (build-vector + width + (lambda (i) + (build-vector + height + (lambda (j) + (f i j)))))) + +(define grid (make-grid 20 20 + (lambda (i j) + (make-cell 0 #f)))) + +grid \ No newline at end of file diff --git a/js-assembler/assemble-helpers.rkt b/js-assembler/assemble-helpers.rkt index 5d89403..e98b8ee 100644 --- a/js-assembler/assemble-helpers.rkt +++ b/js-assembler/assemble-helpers.rkt @@ -136,9 +136,15 @@ [(path? val) (format "RUNTIME.makePath(~s)" (path->string val))] + #;[(vector? val) + (format "RUNTIME.makeVector(~s)" + (string-join (for/list ([elt (vector->list val)]) + (loop elt)) + ","))] [else (error 'assemble-const "Unsupported datum ~s" val)]))) + (: assemble-listof-assembled-values ((Listof String) -> String)) (define (assemble-listof-assembled-values vals) (let loop ([vals vals]) diff --git a/js-assembler/runtime-src/baselib-check.js b/js-assembler/runtime-src/baselib-check.js index 1c3aba8..99b93a5 100644 --- a/js-assembler/runtime-src/baselib-check.js +++ b/js-assembler/runtime-src/baselib-check.js @@ -143,6 +143,11 @@ baselib.strings.isString, 'string'); + var checkSymbolOrString = makeCheckArgumentType( + function(x) { return (baselib.symbols.isSymbol(x) || + baselib.strings.isString(x)); }, + 'symbol or string'); + var checkMutableString = makeCheckArgumentType( baselib.strings.isMutableString, 'mutable string'); @@ -241,10 +246,11 @@ exports.makeCheckListofArgumentType = makeCheckListofArgumentType; exports.checkOutputPort = checkOutputPort; + exports.checkSymbol = checkSymbol; exports.checkString = checkString; + exports.checkSymbolOrString = checkSymbolOrString; exports.checkMutableString = checkMutableString; exports.checkChar = checkChar; - exports.checkSymbol = checkSymbol; exports.checkProcedure = checkProcedure; exports.checkNumber = checkNumber; exports.checkReal = checkReal; diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index 9c1965a..2a3291d 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/js-assembler/runtime-src/baselib-primitives.js @@ -55,6 +55,7 @@ var checkOutputPort = baselib.check.checkOutputPort; var checkString = baselib.check.checkString; + var checkSymbolOrString = baselib.check.checkSymbolOrString; var checkMutableString = baselib.check.checkMutableString; var checkSymbol = baselib.check.checkSymbol; var checkByte = baselib.check.checkByte; @@ -114,6 +115,30 @@ installPrimitiveConstant('false', false); + // The parameter keys here must be uninterned symbols, so we explicitly + // call the symbol constructor here. + installPrimitiveConstant('exception-handler-key', + new baselib.symbols.Symbol("exnh")); + installPrimitiveConstant('parameterization-key', + new baselib.symbols.Symbol("paramz")); + installPrimitiveConstant('break-enabled-key', + new baselib.symbols.Symbol("break-on?")); + + + var gensymCounter = 0; + installPrimitiveProcedure( + 'gensym', + makeList(0, 1), + function(MACHINE) { + var baseName = "g"; + if (MACHINE.argcount === 1) { + baseName = checkSymbolOrString(MACHINE, 'gensym', 0).toString(); + } + gensymCounter++; + return new baselib.symbols.Symbol(baseName + gensymCounter); + }); + + installPrimitiveProcedure( 'display', makeList(1, 2), diff --git a/js-assembler/runtime-src/baselib-vectors.js b/js-assembler/runtime-src/baselib-vectors.js index 66e67d3..b7daaa9 100644 --- a/js-assembler/runtime-src/baselib-vectors.js +++ b/js-assembler/runtime-src/baselib-vectors.js @@ -99,6 +99,7 @@ var isVector = function (x) { return x instanceof Vector; }; + // makeVector: x ... -> vector var makeVector = function () { return Vector.makeInstance(arguments.length, arguments); }; diff --git a/lang/base.rkt b/lang/base.rkt index 43ee2b8..ee25569 100644 --- a/lang/base.rkt +++ b/lang/base.rkt @@ -1,9 +1,21 @@ #lang s-exp "kernel.rkt" -(provide (except-out (all-from-out "kernel.rkt")) - (all-from-out "private/list.rkt")) +(provide (except-out (all-from-out "kernel.rkt") -(require "private/list.rkt") + ;; Don't publically export the bindings from #%paramz. + exception-handler-key + parameterization-key + break-enabled-key + + ;; Use the traced app + #;#%app) + + (all-from-out "private/list.rkt") + + #;(rename-out [traced-app #%app])) + +(require "private/list.rkt" + "private/traced-app.rkt") ;; Kludge: This forces modbeg to be compiled and packaged. diff --git a/lang/kernel.rkt b/lang/kernel.rkt index aa09bed..57080f3 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -3,8 +3,18 @@ sgn conjugate)) (prefix-in racket: racket/base) racket/local - (for-syntax racket/base)) + (for-syntax racket/base) + + (only-in '#%paramz + exception-handler-key + parameterization-key + break-enabled-key)) + + +(provide exception-handler-key + parameterization-key + break-enabled-key) ;; constants @@ -146,7 +156,9 @@ values apply - call-with-values) + call-with-values + + gensym) (define (-identity x) x) @@ -255,7 +267,7 @@ raise-mismatch-error magnitude conjugate ;; inexact->exact -;; exact->inexact + ;; exact->inexact number->string string->number procedure? diff --git a/lang/private/traced-app.rkt b/lang/private/traced-app.rkt new file mode 100644 index 0000000..10d4548 --- /dev/null +++ b/lang/private/traced-app.rkt @@ -0,0 +1,23 @@ +#lang s-exp "../kernel.rkt" + +(require (for-syntax racket/base)) + +(provide traced-app traced-app-key) + +(define traced-app-key (gensym 'traced-app-key)) + + +(define-syntax (traced-app stx) + (syntax-case stx () + [(_ operator operands ...) + (with-syntax ([key #'traced-app-key] + [pos (vector (format "~s" (syntax-source stx)) + (syntax-position stx) + (syntax-line stx) + (syntax-column stx) + (syntax-span stx))]) + (syntax/loc stx + (with-continuation-mark key 'pos + (#%app operator operands ...))))] + [else + stx])) diff --git a/make/make.rkt b/make/make.rkt index 02ad72f..a565368 100644 --- a/make/make.rkt +++ b/make/make.rkt @@ -146,13 +146,15 @@ (foldl (lambda: ([mp : ModuleLocator] [acc : (Listof Source)]) (let ([rp [ModuleLocator-real-path mp]]) - (cond [((current-kernel-module-locator?) - mp) - acc] - [(path? rp) - (cons (make-ModuleSource rp) acc)] - [else - acc]))) + (cond + ;; Ignore modules that are implemented by Whalesong. + [((current-kernel-module-locator?) + mp) + acc] + [(path? rp) + (cons (make-ModuleSource rp) acc)] + [else + acc]))) '() dependent-module-names)]) paths)])])) diff --git a/parameters.rkt b/parameters.rkt index 48841f6..6956466 100644 --- a/parameters.rkt +++ b/parameters.rkt @@ -41,14 +41,26 @@ (: current-kernel-module-locator? (Parameterof (ModuleLocator -> Boolean))) -;; Produces true if the given module locator should be treated as a root one. +;; Produces true if the given module locator should be treated as a primitive root one +;; that is implemented by us. (define current-kernel-module-locator? (make-parameter (lambda: ([locator : ModuleLocator]) - (or (and (eq? (ModuleLocator-name locator) '#%kernel) - (eq? (ModuleLocator-real-path locator) '#%kernel)) - (eq? (ModuleLocator-name locator) - 'whalesong/lang/kernel.rkt))))) + (or (kernel-locator? locator) + (paramz-locator? locator))))) + +(: kernel-locator? (ModuleLocator -> Boolean)) +(define (kernel-locator? locator) + (or (and (eq? (ModuleLocator-name locator) '#%kernel) + (eq? (ModuleLocator-real-path locator) '#%kernel)) + (eq? (ModuleLocator-name locator) + 'whalesong/lang/kernel.rkt))) + + +(: paramz-locator? (ModuleLocator -> Boolean)) +(define (paramz-locator? locator) + (or (and (eq? (ModuleLocator-name locator) '#%paramz) + (eq? (ModuleLocator-real-path locator) '#%paramz))))