diff --git a/compiler/kernel-primitives.rkt b/compiler/kernel-primitives.rkt index f825964..5817a90 100644 --- a/compiler/kernel-primitives.rkt +++ b/compiler/kernel-primitives.rkt @@ -27,6 +27,7 @@ '>= 'cons 'car + 'caar 'cdr 'cadr 'caddr @@ -81,6 +82,7 @@ 'srcloc-position 'srcloc-span + 'error 'raise-type-error )) (define-predicate KernelPrimitiveName? KernelPrimitiveName) diff --git a/examples/maze.rkt b/examples/maze.rkt deleted file mode 100644 index 7ea2961..0000000 --- a/examples/maze.rkt +++ /dev/null @@ -1,21 +0,0 @@ -#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/get-module-bytecode.rkt b/get-module-bytecode.rkt index fef4cae..8a3b55b 100644 --- a/get-module-bytecode.rkt +++ b/get-module-bytecode.rkt @@ -81,7 +81,8 @@ (lambda (ip) (get-compiled-code-from-port ip))) )]) - (get-module-code p))) + (parameterize ([compile-context-preservation-enabled #t]) + (get-module-code p)))) ;; get-compiled-code-from-port: input-port -> compiled-code @@ -89,6 +90,7 @@ (define (get-compiled-code-from-port ip) ;(printf "get-compiled-code-from-port\n") (parameterize ([read-accept-reader #t] + [compile-context-preservation-enabled #t] [current-namespace base-namespace]) (define stx (read-syntax (object-name ip) ip)) ;(printf "got stx; now expanding out the images\n") diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index 1e6088a..12d716d 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -442,7 +442,7 @@ M.modules[~s] = (newline op) (fprintf op "(function(M, SUCCESS, FAIL, PARAMS) {") - (make (list only-bootstrapped-code) packaging-configuration) + (make (list (my-force only-bootstrapped-code)) packaging-configuration) (fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n"))) diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index 43d653a..8d6799c 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/js-assembler/runtime-src/baselib-primitives.js @@ -88,6 +88,16 @@ ); var checkRational = baselib.check.checkRational; var checkPair = baselib.check.checkPair; + var checkCaarPair = baselib.check.makeCheckArgumentType( + function(x) { + return isPair(x) && isPair(x.first); + }, + 'caarable value'); + var checkCadrPair = baselib.check.makeCheckArgumentType( + function(x) { + return isPair(x) && isPair(x.first); + }, + 'cadrable value'); var checkList = baselib.check.checkList; var checkListofChars = baselib.check.makeCheckListofArgumentType(baselib.chars.isChar, 'character'); @@ -557,8 +567,6 @@ }); - - installPrimitiveProcedure( 'car', 1, @@ -567,6 +575,20 @@ return firstArg.first; }); + installPrimitiveProcedure( + 'caar', + 1, + function (M) { + var firstArg = checkCaarPair(M, 'caar', 0); + return firstArg.first.first; + }); + installPrimitiveProcedure( + 'cadr', + 1, + function (M) { + var firstArg = checkCadrPair(M, 'cadr', 0); + return firstArg.first.rest; + }); installPrimitiveProcedure( 'cdr', 1, diff --git a/lang/kernel.rkt b/lang/kernel.rkt index dd8bbb0..2defc63 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -336,7 +336,7 @@ negative? eqv? caar -;; cadr + cadr ;; cdar ;; cddr ;; caaar diff --git a/make/make-structs.rkt b/make/make-structs.rkt index 2f81b15..9b68dc8 100644 --- a/make/make-structs.rkt +++ b/make/make-structs.rkt @@ -77,8 +77,6 @@ -(: only-bootstrapped-code : StatementsSource) +(: only-bootstrapped-code : (MyPromise StatementsSource)) (define only-bootstrapped-code - (make-StatementsSource (get-bootstrapping-code))) - - + (my-delay (make-StatementsSource (get-bootstrapping-code)))) \ No newline at end of file diff --git a/parameters.rkt b/parameters.rkt index 369d533..facc49d 100644 --- a/parameters.rkt +++ b/parameters.rkt @@ -87,7 +87,7 @@ ;; Turns on caching of compiled programs, so that repeated compilations ;; will reuse existing work. (: current-with-cache? (Parameterof Boolean)) -(define current-with-cache? (make-parameter #f)) +(define current-with-cache? (make-parameter #t)) diff --git a/parser/parse-bytecode-5.1.1.rkt b/parser/parse-bytecode-5.1.1.rkt index 91efd45..febfbb3 100644 --- a/parser/parse-bytecode-5.1.1.rkt +++ b/parser/parse-bytecode-5.1.1.rkt @@ -10,8 +10,7 @@ ;; Parsing Racket 5.1.1 bytecode structures into our own structures. - (require "typed-module-path.rkt" - "path-rewriter.rkt" + (require "path-rewriter.rkt" "../compiler/expression-structs.rkt" "../compiler/lexical-structs.rkt" "../parameters.rkt" diff --git a/parser/parse-bytecode-5.1.2.rkt b/parser/parse-bytecode-5.1.2.rkt index 0ac12d4..eae6da5 100644 --- a/parser/parse-bytecode-5.1.2.rkt +++ b/parser/parse-bytecode-5.1.2.rkt @@ -12,8 +12,7 @@ ;; Parsing Racket 5.1.2 bytecode structures into our own structures. - (require "typed-module-path.rkt" - "path-rewriter.rkt" + (require "path-rewriter.rkt" "../compiler/expression-structs.rkt" "../compiler/lexical-structs.rkt" "../parameters.rkt" diff --git a/parser/typed-module-path.rkt b/parser/typed-module-path.rkt deleted file mode 100644 index 4c0e5de..0000000 --- a/parser/typed-module-path.rkt +++ /dev/null @@ -1,63 +0,0 @@ -#lang typed/racket/base - -(define-type RelativeString String) -(define-type UserString String) -(define-type PackageString String) - - - - -(define-type ModulePath (U (List 'quote Symbol) - RelativeString - (Pairof 'lib (Pairof RelativeString (Listof RelativeString))) - Symbol - (List 'file String) - (List 'planet Symbol) - (List 'planet String) - (Pairof 'planet - (Pairof RelativeString - (Pairof (U (List UserString PackageString) - (List UserString PackageString Natural) - (List UserString PackageString Natural MinorVersion)) - (Listof RelativeString)))))) - - -(define-type MinorVersion (U Natural - (List Natural Natural) - (List '= Natural) - (List '+ Natural) - (List '- Natural))) - - -(require/typed racket/base - - [opaque ModulePathIndex module-path-index?] - [opaque ResolvedModulePath resolved-module-path?] - - [module-path-index-resolve - (ModulePathIndex -> ResolvedModulePath)] - - [module-path-index-join - ((U ModulePath #f) - (U ModulePathIndex ResolvedModulePath #f) -> - ModulePathIndex)] - - [module-path-index-split - (ModulePathIndex -> (values (U ModulePath #f) - (U ModulePathIndex ResolvedModulePath #f)))] - - [resolved-module-path-name - (ResolvedModulePath -> (U Path Symbol))] - [make-resolved-module-path ((U Symbol Path) -> ResolvedModulePath)]) - - - -(provide - - ModulePath - ResolvedModulePath - - ModulePathIndex - module-path-index-resolve - module-path-index-join - module-path-index-split)