some cleanup; also turning on the context preservation stuff in hopes that it will make the generated code smaller
This commit is contained in:
parent
657d74e37b
commit
b7489b5b0c
|
@ -27,6 +27,7 @@
|
||||||
'>=
|
'>=
|
||||||
'cons
|
'cons
|
||||||
'car
|
'car
|
||||||
|
'caar
|
||||||
'cdr
|
'cdr
|
||||||
'cadr
|
'cadr
|
||||||
'caddr
|
'caddr
|
||||||
|
@ -81,6 +82,7 @@
|
||||||
'srcloc-position
|
'srcloc-position
|
||||||
'srcloc-span
|
'srcloc-span
|
||||||
|
|
||||||
|
'error
|
||||||
'raise-type-error
|
'raise-type-error
|
||||||
))
|
))
|
||||||
(define-predicate KernelPrimitiveName? KernelPrimitiveName)
|
(define-predicate KernelPrimitiveName? KernelPrimitiveName)
|
||||||
|
|
|
@ -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
|
|
|
@ -81,7 +81,8 @@
|
||||||
(lambda (ip)
|
(lambda (ip)
|
||||||
(get-compiled-code-from-port 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
|
;; get-compiled-code-from-port: input-port -> compiled-code
|
||||||
|
@ -89,6 +90,7 @@
|
||||||
(define (get-compiled-code-from-port ip)
|
(define (get-compiled-code-from-port ip)
|
||||||
;(printf "get-compiled-code-from-port\n")
|
;(printf "get-compiled-code-from-port\n")
|
||||||
(parameterize ([read-accept-reader #t]
|
(parameterize ([read-accept-reader #t]
|
||||||
|
[compile-context-preservation-enabled #t]
|
||||||
[current-namespace base-namespace])
|
[current-namespace base-namespace])
|
||||||
(define stx (read-syntax (object-name ip) ip))
|
(define stx (read-syntax (object-name ip) ip))
|
||||||
;(printf "got stx; now expanding out the images\n")
|
;(printf "got stx; now expanding out the images\n")
|
||||||
|
|
|
@ -442,7 +442,7 @@ M.modules[~s] =
|
||||||
|
|
||||||
(newline op)
|
(newline op)
|
||||||
(fprintf op "(function(M, SUCCESS, FAIL, PARAMS) {")
|
(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")))
|
(fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n")))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -88,6 +88,16 @@
|
||||||
);
|
);
|
||||||
var checkRational = baselib.check.checkRational;
|
var checkRational = baselib.check.checkRational;
|
||||||
var checkPair = baselib.check.checkPair;
|
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 checkList = baselib.check.checkList;
|
||||||
var checkListofChars = baselib.check.makeCheckListofArgumentType(baselib.chars.isChar,
|
var checkListofChars = baselib.check.makeCheckListofArgumentType(baselib.chars.isChar,
|
||||||
'character');
|
'character');
|
||||||
|
@ -557,8 +567,6 @@
|
||||||
});
|
});
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
installPrimitiveProcedure(
|
installPrimitiveProcedure(
|
||||||
'car',
|
'car',
|
||||||
1,
|
1,
|
||||||
|
@ -567,6 +575,20 @@
|
||||||
return firstArg.first;
|
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(
|
installPrimitiveProcedure(
|
||||||
'cdr',
|
'cdr',
|
||||||
1,
|
1,
|
||||||
|
|
|
@ -336,7 +336,7 @@ negative?
|
||||||
eqv?
|
eqv?
|
||||||
|
|
||||||
caar
|
caar
|
||||||
;; cadr
|
cadr
|
||||||
;; cdar
|
;; cdar
|
||||||
;; cddr
|
;; cddr
|
||||||
;; caaar
|
;; caaar
|
||||||
|
|
|
@ -77,8 +77,6 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(: only-bootstrapped-code : StatementsSource)
|
(: only-bootstrapped-code : (MyPromise StatementsSource))
|
||||||
(define only-bootstrapped-code
|
(define only-bootstrapped-code
|
||||||
(make-StatementsSource (get-bootstrapping-code)))
|
(my-delay (make-StatementsSource (get-bootstrapping-code))))
|
||||||
|
|
||||||
|
|
|
@ -87,7 +87,7 @@
|
||||||
;; Turns on caching of compiled programs, so that repeated compilations
|
;; Turns on caching of compiled programs, so that repeated compilations
|
||||||
;; will reuse existing work.
|
;; will reuse existing work.
|
||||||
(: current-with-cache? (Parameterof Boolean))
|
(: current-with-cache? (Parameterof Boolean))
|
||||||
(define current-with-cache? (make-parameter #f))
|
(define current-with-cache? (make-parameter #t))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -10,8 +10,7 @@
|
||||||
|
|
||||||
|
|
||||||
;; Parsing Racket 5.1.1 bytecode structures into our own structures.
|
;; Parsing Racket 5.1.1 bytecode structures into our own structures.
|
||||||
(require "typed-module-path.rkt"
|
(require "path-rewriter.rkt"
|
||||||
"path-rewriter.rkt"
|
|
||||||
"../compiler/expression-structs.rkt"
|
"../compiler/expression-structs.rkt"
|
||||||
"../compiler/lexical-structs.rkt"
|
"../compiler/lexical-structs.rkt"
|
||||||
"../parameters.rkt"
|
"../parameters.rkt"
|
||||||
|
|
|
@ -12,8 +12,7 @@
|
||||||
|
|
||||||
|
|
||||||
;; Parsing Racket 5.1.2 bytecode structures into our own structures.
|
;; Parsing Racket 5.1.2 bytecode structures into our own structures.
|
||||||
(require "typed-module-path.rkt"
|
(require "path-rewriter.rkt"
|
||||||
"path-rewriter.rkt"
|
|
||||||
"../compiler/expression-structs.rkt"
|
"../compiler/expression-structs.rkt"
|
||||||
"../compiler/lexical-structs.rkt"
|
"../compiler/lexical-structs.rkt"
|
||||||
"../parameters.rkt"
|
"../parameters.rkt"
|
||||||
|
|
|
@ -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)
|
|
Loading…
Reference in New Issue
Block a user