suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: suzanne.soy:master
Branches Tags
suzanne.soy:master
suzanne.soy:v6.3
suzanne.soy:libs
suzanne.soy:quick-fix-undefined
suzanne.soy:patch-2
suzanne.soy:patch-1
suzanne.soy:triangle
suzanne.soy:js-eval
suzanne.soy:script-header
suzanne.soy:blocks
suzanne.soy:racketcon
suzanne.soy:structs
suzanne.soy:devel
suzanne.soy:18
suzanne.soy:1.16
suzanne.soy:1.14
suzanne.soy:1.11
suzanne.soy:1.10
suzanne.soy:1.9
suzanne.soy:1.8
suzanne.soy:1.7
suzanne.soy:1.6
suzanne.soy:1.5
suzanne.soy:1.4
suzanne.soy:before-mvr
suzanne.soy:1.3
suzanne.soy:0.02
suzanne.soy:chrome-dies
suzanne.soy:infinite-typecheck
suzanne.soy:before-racket-vm
..
compare: suzanne.soy:patch-2
Branches Tags
suzanne.soy:v6.3
suzanne.soy:master
suzanne.soy:libs
suzanne.soy:quick-fix-undefined
suzanne.soy:patch-2
suzanne.soy:patch-1
suzanne.soy:triangle
suzanne.soy:js-eval
suzanne.soy:script-header
suzanne.soy:blocks
suzanne.soy:racketcon
suzanne.soy:structs
suzanne.soy:devel
suzanne.soy:18
suzanne.soy:1.16
suzanne.soy:1.14
suzanne.soy:1.11
suzanne.soy:1.10
suzanne.soy:1.9
suzanne.soy:1.8
suzanne.soy:1.7
suzanne.soy:1.6
suzanne.soy:1.5
suzanne.soy:1.4
suzanne.soy:before-mvr
suzanne.soy:1.3
suzanne.soy:0.02
suzanne.soy:chrome-dies
suzanne.soy:infinite-typecheck
suzanne.soy:before-racket-vm

1 Commits
master ... patch-2

Author SHA1 Message Date
Jens Axel Søgaard
ecd0a52d85 Behaviour of (letrec ([x x]) x) changed in Racket 
The latest Racket has changed the behaviour of (letrec ([x x]) x).
Currently any program beginning with #lang whalesong fails due
to an "x undefined" error. The undefined value is now exported
from racket/undefined.
 2014-06-30 00:28:01 +02:00
93 changed files with 1449 additions and 32956 deletions
Show Stats Expand all files Collapse all files

46
README.md
View File

@ -1,46 +0,0 @@
Whalesong
=========
Important
---------
Whalesong needs Racket 6.2.
As is Whalesong doesn't work on version 6.3 or greater.
See https://github.com/soegaard/whalesong/issues/48
Installation
------------
raco pkg install -j 1 --force --deps search-auto --scope installation whalesong
Important: Use -j 1 to build Whalesong (this turns off parallel builds)
This also means, that you can't install Whalesong from the DrRacket package manager.
This fork of Whalesong differs from dyoo/whalesong in the following ways:
* Builds on latest release of Racket
(fixes the x undefined problem)
* Adds for
(require whalesong/lang/for)
* Adds match
(require whalesong/lang/match)
* Adds on-release
(as a complement to on-key)
Contributed by Darren Cruse
* Adds parameters
(require whalesong/lang/parameters)
* Extended whalesong/image and whalesong/images
(more functions, bug fixes, now matches WeScheme)
Contributed by Emmanuel Schanzer
* Adds play-sound
(assumes a browser with html5 audio support)
Contributed by Emmanuel Schanzer and Darren Cruse
* Bug fixes by Vishesh Yadav
* The flag --as-standalone-xhtml is now --as-standalone-html
and produces standalone html rather than xhtml.
Note: The implementation of parameters works fine,
as long as you don't mix parameterize with non-local-exits
and reentries (i.e. call/cc and friends)
/soegaard

25
whalesong/README
View File

@ -29,10 +29,11 @@ amount of time.
Example usage
Create a simple, executable of your program. At the moment, the program must
be written in the base language of whalesong. (This restriction currently
prevents arbitrary racket/base programs from compiling, and we'll be working to
remove this restriction.)
Create a simple, standalong executable of your program. At the
moment, the program must be written in the base language of whalesong.
(This restriction currently prevents arbitrary racket/base programs
from compiling, and we'll be working to remove this restriction.)
$ cat hello.rkt
#lang whalesong
@ -41,18 +42,8 @@ remove this restriction.)
$ ./whalesong.rkt build hello.rkt
$ ls -l hello.html
-rw-rw-r-- 1 dyoo nogroup 692213 Jun 7 18:00 hello.html
To build standalone executable of your program, provide --as-standalone-html
flag.
$ ./whalesong.rkt build --as-standalone-html hello.rkt
$ ls -l
-rw-rw-r-- 1 dyoo nogroup 692213 Jun 7 18:00 hello.html
NOTE: Earlier versions had --as-standalone-xhtml flag, which is now removed.
$ ls -l hello.xhtml
-rw-rw-r-- 1 dyoo nogroup 692213 Jun 7 18:00 hello.xhtml
[FIXME: add more examples]
@ -196,4 +187,4 @@ This uses code from the following projects:
jquery (http://jquery.com/)
[FIXME: add more]
[FIXME: add more]

15
whalesong/compiler/expression-structs.rkt
View File

@ -163,24 +163,11 @@
(define current-short-labels? (make-parameter #t))
(define make-label-counter 0)
(: reset-make-label-counter (-> Void))
(define (reset-make-label-counter)
(set! make-label-counter 0))
(: make-label (Symbol -> Symbol))
#;(define make-label
(define make-label
(let ([n 0])
(lambda (l)
(set! n (add1 n))
(if (current-short-labels?)
(string->symbol (format "_~a" n))
(string->symbol (format "~a~a" l n))))))
(define (make-label l)
(set! make-label-counter (+ make-label-counter 1))
(define n make-label-counter)
(if (current-short-labels?)
(string->symbol (format "_~a" n))
(string->symbol (format "~a~a" l n))))

6
whalesong/image/main.rkt
View File

@ -1,9 +1,7 @@
#lang s-exp "../lang/base.rkt"
(require "private/main.rkt"
"private/color.rkt"
"private/image.rkt")
"private/color.rkt")
(provide (all-from-out "private/main.rkt")
(all-from-out "private/color.rkt")
(all-from-out "private/image.rkt"))
(all-from-out "private/color.rkt"))

26
whalesong/image/private/image.rkt
View File

@ -1,26 +0,0 @@
#lang s-exp "../../lang/base.rkt"
;; Image functions that be implemented using racket based on primitives
;; NOTE: Modifications here may require rebuilding of Whalesong
(require "main.rkt"
"../../lang/for.rkt"
"../../lang/posn.rkt")
(provide place-images
place-images/align
empty-image)
; place-images : (listof image?) (listof posn?) image? -> image?
(define (place-images images posns scene)
(for/fold ([acc scene])
([img images] [posn posns])
(place-image img (posn-x posn) (posn-y posn) acc)))
; place-images : (listof image?) (listof posn?) x-place? y-place? image? -> image?
(define (place-images/align images posns x-place y-place scene)
(for/fold ([acc scene])
([img images] [posn posns])
(place-image/align img (posn-x posn) (posn-y posn) x-place y-place acc)))
(define empty-image (rectangle 0 0 "solid" "black"))

534
whalesong/image/private/js-impl.js
View File

@ -37,12 +37,9 @@ var isFontWeight = function(x){
|| (x === false); // false is also acceptable
};
var isMode = function(x) {
return ((isString(x) || isSymbol(x)) &&
(x.toString().toLowerCase() == "solid" ||
x.toString().toLowerCase() == "outline")) ||
((jsnums.isReal(x)) &&
(jsnums.greaterThanOrEqual(x, 0) &&
jsnums.lessThanOrEqual(x, 255)));
return ((isString(x) || isSymbol(x)) &&
(x.toString().toLowerCase() == "solid" ||
x.toString().toLowerCase() == "outline"));
};
var isPlaceX = function(x) {
@ -70,24 +67,8 @@ var isStyle = function(x) {
// Useful trigonometric functions based on htdp teachpack
// excess : compute the Euclidean excess
// Note: If the excess is 0, then C is 90 deg.
// If the excess is negative, then C is obtuse.
// If the excess is positive, then C is acuse.
function excess(sideA, sideB, sideC) {
return sideA*sideA + sideB*sideB - sideC*sideC;
}
// return c^2 = a^2 + b^2 - 2ab cos(C)
function cosRel(sideA, sideB, angleC) {
return (sideA*sideA) + (sideB*sideB) - (2*sideA*sideB*Math.cos(angleC * Math.PI/180));
}
var less = function(lhs, rhs) {
return (rhs - lhs) > 0.00001;
}
var checkString = plt.baselib.check.checkString;
var checkStringOrFalse = plt.baselib.check.makeCheckArgumentType(
@ -152,14 +133,11 @@ var checkPlaceY = plt.baselib.check.makeCheckArgumentType(
var checkAngle = plt.baselib.check.makeCheckArgumentType(
isAngle,
"finite real number between 0 and 360");
var checkRotateAngle = plt.baselib.check.makeCheckArgumentType(
isRotateAngle,
"finite real number between -360 and 360");
var checkMode = plt.baselib.check.makeCheckArgumentType(
isMode,
'solid or outline or [0-255]');
'solid or outline');
var checkSideCount = plt.baselib.check.makeCheckArgumentType(
@ -183,17 +161,9 @@ var checkListofColor = plt.baselib.check.makeCheckListofArgumentType(
//////////////////////////////////////////////////////////////////////
EXPORTS['image=?'] =
makePrimitiveProcedure(
'image=?',
2,
function(MACHINE) {
var img1 = checkImageOrScene(MACHINE,'image=?', 0);
var img2 = checkImageOrScene(MACHINE,'image=?', 1);
return img1.equals(img2);
});
//////////////////////////////////////////////////////////////////////
EXPORTS['image-color?'] =
@ -352,90 +322,6 @@ EXPORTS['image-url'] =
'image-url');
EXPORTS['video/url'] =
makeClosure(
'video/url',
1,
function(MACHINE) {
var path = checkString(MACHINE, 'video/url', 0);
PAUSE(
function(restart) {
var rawVideo = document.createElement('video');
rawVideo.src = path.toString();
rawVideo.addEventListener('canplay', function() {
restart(function(MACHINE) {
function pause(){ rawVideo.pause(); return true;};
finalizeClosureCall(
MACHINE,
makeFileVideo(path.toString(), rawVideo));
// aState.addBreakRequestedListener(pause);
});
});
rawVideo.addEventListener('error', function(e) {
restart(function(MACHINE) {
plt.baselib.exceptions.raiseFailure(
MACHINE,
plt.baselib.format.format(
"unable to load ~a: ~a",
[url,
e.message]));
});
});
rawVideo.src = path.toString();
}
);
});
// We keep a cache of loaded sounds:
var audioCache = {};
EXPORTS['play-sound'] =
makeClosure(
'play-sound',
1,
function(MACHINE) {
var path = checkString(MACHINE, 'play-sound', 0);
var fileAudio = audioCache[path];
if (fileAudio) {
// the sound was already loaded
finalizeClosureCall(
MACHINE,
fileAudio.play());
}
else {
// this sound has never been played before
PAUSE(
function(restart) {
fileAudio = makeFileAudio(path.toString());
audioCache[path] = fileAudio;
// let the audio file load before playing...
fileAudio.loading = true;
// (fileAudio.audio is the raw html5 Audio object)
fileAudio.audio.addEventListener('canplay', function() {
// ignore canplay events that follow the initial load
if(fileAudio.loading) {
restart(function(MACHINE) {
finalizeClosureCall(
MACHINE,
fileAudio.play());
});
fileAudio.loading = false; // we're done loading
}
})
fileAudio.audio.addEventListener('error', function(e) {
restart(function(MACHINE) {
plt.baselib.exceptions.raiseFailure(
MACHINE,
plt.baselib.format.format(
"unable to load ~a: ~a",
[path,
e.message]));
});
});
});
}
});
EXPORTS['overlay'] =
@ -474,22 +360,6 @@ EXPORTS['overlay/xy'] =
jsnums.toFixnum(deltaY));
});
EXPORTS['overlay/offset'] =
makePrimitiveProcedure(
'overlay/offset',
4,
function(MACHINE) {
var img1 = checkImage(MACHINE, "overlay/offset", 0);
var deltaX = checkReal(MACHINE, "overlay/offset", 1);
var deltaY = checkReal(MACHINE, "overlay/offset", 2);
var img2 = checkImage(MACHINE, "overlay/offset", 3);
var middleX = (img1.getWidth() - img2.getWidth()) / 2;
var middleY = (img1.getHeight() - img2.getHeight()) / 2;
return makeOverlayImage(img1,
img2,
jsnums.toFixnum(middleX) + deltaX,
jsnums.toFixnum(middleY) + deltaY);
});
EXPORTS['overlay/align'] =
@ -556,23 +426,6 @@ EXPORTS['underlay/xy'] =
-(jsnums.toFixnum(deltaY)));
});
EXPORTS['underlay/offset'] =
makePrimitiveProcedure(
'underlay/offset',
4,
function(MACHINE) {
var img1 = checkImage(MACHINE, "underlay/offset", 0);
var deltaX = checkReal(MACHINE, "underlay/offset", 1);
var deltaY = checkReal(MACHINE, "underlay/offset", 2);
var img2 = checkImage(MACHINE, "underlay/offset", 3);
var middleX = (img1.getWidth() - img2.getWidth()) / 2;
var middleY = (img1.getHeight() - img2.getHeight()) / 2;
return makeOverlayImage(img2,
img1,
-(jsnums.toFixnum(middleX) + deltaX),
-(jsnums.toFixnum(middleY) + deltaY));
});
EXPORTS['underlay/align'] =
makePrimitiveProcedure(
'underlay/align',
@ -717,42 +570,16 @@ EXPORTS['above/align'] =
EXPORTS['empty-scene'] =
makePrimitiveProcedure(
'empty-scene',
plt.baselib.lists.makeList(2, 3),
2,
function(MACHINE) {
var width = checkNonNegativeReal(MACHINE, 'empty-scene', 0);
var height = checkNonNegativeReal(MACHINE, 'empty-scene', 1);
var color = (MACHINE.a===3)? checkColor(MACHINE, 'empty-scene', 2) : null;
return makeSceneImage(jsnums.toFixnum(width),
return makeSceneImage(jsnums.toFixnum(width),
jsnums.toFixnum(height),
color,
[],
true);
});
EXPORTS['put-image'] =
makePrimitiveProcedure(
'put-image',
4,
function(MACHINE) {
var picture = checkImage(MACHINE, "put-image", 0);
var x = checkReal(MACHINE, "put-image", 1);
var y = checkReal(MACHINE, "put-image", 2);
var background = checkImageOrScene(MACHINE, "place-image", 3);
if (isScene(background)) {
return background.add(picture, jsnums.toFixnum(x), background.getHeight() - jsnums.toFixnum(y));
} else {
var newScene = makeSceneImage(background.getWidth(),
background.getHeight(),
null,
[],
false);
newScene = newScene.add(background, background.getWidth()/2, background.getHeight()/2);
newScene = newScene.add(picture, jsnums.toFixnum(x), background.getHeight() - jsnums.toFixnum(y));
return newScene;
}
});
EXPORTS['place-image'] =
@ -767,13 +594,12 @@ EXPORTS['place-image'] =
if (isScene(background)) {
return background.add(picture, jsnums.toFixnum(x), jsnums.toFixnum(y));
} else {
var newScene = makeSceneImage(background.getWidth(),
background.getHeight(),
null,
[],
false);
newScene = newScene.add(background, background.getWidth()/2, background.getHeight()/2);
newScene = newScene.add(picture, jsnums.toFixnum(x), jsnums.toFixnum(y));
var newScene = makeSceneImage(background.getWidth(),
background.getHeight(),
[],
false);
newScene = newScene.add(background.updatePinhole(0, 0), 0, 0);
newScene = newScene.add(picture, jsnums.toFixnum(x), jsnums.toFixnum(y));
return newScene;
}
@ -787,55 +613,49 @@ EXPORTS['place-image/align'] =
6,
function(MACHINE) {
var img = checkImage(MACHINE, "place-image/align", 0);
var x = jsnums.toFixnum(checkReal(MACHINE, "place-image/align", 1));
var y = jsnums.toFixnum(checkReal(MACHINE, "place-image/align", 2));
var x = checkReal(MACHINE, "place-image/align", 1);
var y = checkReal(MACHINE, "place-image/align", 2);
var placeX = checkPlaceX(MACHINE, "place-image/align", 3);
var placeY = checkPlaceY(MACHINE, "place-image/align", 4);
var background = checkImageOrScene(MACHINE, "place-image/align", 5);
var pinholeX = img.pinholeX || img.getWidth() / 2;
var pinholeY = img.pinholeY || img.getHeight() / 2;
// calculate x and y based on placeX and placeY
if (placeX == "left") x = x + pinholeX;
else if (placeX == "right") x = x - pinholeX;
if (placeY == "top") y = y + pinholeY;
else if (placeY == "bottom") y = y - pinholeY;
if (placeX == "left") x = x + img.pinholeX;
else if (placeX == "right") x = x - img.pinholeX;
if (placeY == "top") y = y + img.pinholeY;
else if (placeY == "bottom") y = y - img.pinholeY;
if (isScene(background)) {
return background.add(img, x, y);
return background.add(img, jsnums.toFixnum(x), jsnums.toFixnum(y));
} else {
var newScene = makeSceneImage(background.getWidth(),
background.getHeight(),
null,
[],
false);
newScene = newScene.add(background, background.getWidth()/2, background.getHeight()/2);
newScene = newScene.add(img, x, y);
var newScene = makeSceneImage(background.getWidth(),
background.getHeight(),
[],
false);
newScene = newScene.add(background.updatePinhole(0, 0), 0, 0);
newScene = newScene.add(img, jsnums.toFixnum(x), jsnums.toFixnum(y));
return newScene;
}
});
//////////////////////////////////////////////////////////////////////
// rotate: angle image -> image
// Rotates image by angle degrees in a counter-clockwise direction.
EXPORTS['rotate'] =
makePrimitiveProcedure(
'rotate',
2,
function(MACHINE) {
var angle = checkRotateAngle(MACHINE, "rotate", 0);
var angle360 = angle % 360;
var angle = checkAngle(MACHINE, "rotate", 0);
var img = checkImage(MACHINE, "rotate", 1);
// convert to clockwise rotation for makeRotateImage
if (angle360 < 0) {
return makeRotateImage(jsnums.toFixnum(-(360 + angle360)), img);
} else {
return makeRotateImage(jsnums.toFixnum(-angle360), img);
}
return makeRotateImage(jsnums.toFixnum(-angle), img);
});
EXPORTS['scale'] =
makePrimitiveProcedure(
'scale',
@ -963,21 +783,18 @@ EXPORTS['scene+line'] =
var y2 = checkReal(MACHINE, "scene+line", 4);
var c = checkColor(MACHINE, "scene+line", 5);
// make a scene containing the image
var newScene = makeSceneImage(jsnums.toFixnum(img.getWidth()),
jsnums.toFixnum(img.getHeight()),
null,
[],
false);
newScene = newScene.add(img, img.getWidth()/2, img.getHeight()/2);
var newScene = makeSceneImage(jsnums.toFixnum(img.getWidth()),
jsnums.toFixnum(img.getHeight()),
[],
true);
newScene = newScene.add(img.updatePinhole(0, 0), 0, 0);
// make an image containing the line
var line = makeLineImage(jsnums.toFixnum(x2-x1),
jsnums.toFixnum(y2-y1),
c,
false),
leftMost = Math.min(x1,x2),
topMost = Math.min(y1,y2);
jsnums.toFixnum(y2-y1),
c,
false);
// add the line to scene, offset by the original amount
return newScene.add(line, line.getWidth()/2+leftMost, line.getHeight()/2+topMost);
return newScene.add(line, jsnums.toFixnum(x1), jsnums.toFixnum(y1));
});
@ -1019,27 +836,9 @@ EXPORTS['rectangle'] =
s.toString(),
c);
});
/*
need to port over checks for isListofPosns and isListOfLength
EXPORTS['polygon'] =
makePrimitiveProcedure(
'polygon',
3,
function(MACHINE) {
function isPosnList(lst){ return isListOf(lst, types.isPosn); }
var points = checkListOfLength(MACHINE, "polygon", 0);
var points = checkListOfPosns(MACHINE, "polygon", 0);
var s = checkMode(MACHINE, "polygon", 2);
var c = checkColor(MACHINE, "polygon", 3);
return makePosnImage(points,
s.toString(),
c);
});
*/
EXPORTS['regular-polygon'] =
EXPORTS['regular-polygon'] =
makePrimitiveProcedure(
'regular-polygon',
4,
@ -1081,219 +880,14 @@ EXPORTS['triangle'] =
var s = checkNonNegativeReal(MACHINE, "triangle", 0);
var m = checkMode(MACHINE, "triangle", 1);
var c = checkColor(MACHINE, "triangle", 2);
return makeTriangleImage(jsnums.toFixnum(s),
jsnums.toFixnum(360-60),
jsnums.toFixnum(s),
m.toString(),
c);
return makeTriangleImage(jsnums.toFixnum(s),
60,
m.toString(),
c);
});
EXPORTS['triangle/sas'] =
makePrimitiveProcedure(
'triangle/sas',
5,
function(MACHINE) {
var sideA = checkNonNegativeReal(MACHINE, "triangle/sas", 0);
var angleB = checkAngle(MACHINE, "triangle/sas", 1);
var sideC = checkNonNegativeReal(MACHINE, "triangle/sas", 2);
var style = checkMode(MACHINE, "triangle/sas", 3);
var color = checkColor(MACHINE, "triangle/sas", 4);
// cast to fixnums
sideA = jsnums.toFixnum(sideA); angleB = jsnums.toFixnum(angleB); sideC = jsnums.toFixnum(sideC);
var sideB2 = cosRel(sideA, sideC, angleB);
var sideB = Math.sqrt(sideB2);
if (sideB2 <= 0) {
raise( types.incompleteExn(types.exnFailContract, "The given side, angle and side will not form a triangle: "
+ sideA + ", " + angleB + ", " + sideC, []) );
} else {
if (less(sideA + sideC, sideB) ||
less(sideB + sideC, sideA) ||
less(sideA + sideB, sideC)) {
raise( types.incompleteExn(types.exnFailContract, "The given side, angle and side will not form a triangle: "
+ sideA + ", " + angleB + ", " + sideC, []) );
}
}
var angleA = Math.acos(excess(sideB, sideC, sideA) / (2 * sideB * sideC)) * (180 / Math.PI);
return makeTriangleImage(jsnums.toFixnum(sideC),
jsnums.toFixnum(angleA),
jsnums.toFixnum(sideB),
style.toString(),
color);
});
EXPORTS['triangle/sss'] =
makePrimitiveProcedure(
'triangle/sss',
5,
function(MACHINE) {
var sideA = checkNonNegativeReal(MACHINE, "triangle/sss", 0);
var sideB = checkNonNegativeReal(MACHINE, "triangle/sss", 1);
var sideC = checkNonNegativeReal(MACHINE, "triangle/sss", 2);
var style = checkMode(MACHINE, "triangle/sss", 3);
var color = checkColor(MACHINE, "triangle/sss", 4);
// cast to fixnums
sideA = jsnums.toFixnum(sideA); sideB = jsnums.toFixnum(sideB); sideC = jsnums.toFixnum(sideC);
if (less(sideA + sideB, sideC) ||
less(sideC + sideB, sideA) ||
less(sideA + sideC, sideB)) {
raise( types.incompleteExn(types.exnFailContract, "The given sides will not form a triangle: "
+ sideA+", "+sideB+", "+sideC, []) );
}
var angleA = Math.acos(excess(sideB, sideC, sideA) / (2 * sideB * sideC)) * (180 / Math.PI);
return makeTriangleImage(jsnums.toFixnum(sideC),
jsnums.toFixnum(angleA),
jsnums.toFixnum(sideB),
style.toString(),
color);
});
EXPORTS['triangle/ass'] =
makePrimitiveProcedure(
'triangle/ass',
5,
function(MACHINE) {
var angleA = checkAngle(MACHINE, "triangle/ass", 0);
var sideB = checkNonNegativeReal(MACHINE, "triangle/ass", 1);
var sideC = checkNonNegativeReal(MACHINE, "triangle/ass", 2);
var style = checkMode(MACHINE, "triangle/ass", 3);
var color = checkColor(MACHINE, "triangle/ass", 4);
// cast to fixnums
angleA = jsnums.toFixnum(angleA); sideB = jsnums.toFixnum(sideB); sideC = jsnums.toFixnum(sideC);
if (colorDb.get(color)) { color = colorDb.get(color); }
if (less(180, angleA)) {
raise( types.incompleteExn(types.exnFailContract, "The given angle, side and side will not form a triangle: "
+ angleA + ", " + sideB + ", " + sideC, []) );
}
return makeTriangleImage(jsnums.toFixnum(sideC),
jsnums.toFixnum(angleA),
jsnums.toFixnum(sideB),
style.toString(),
color);
});
EXPORTS['triangle/ssa'] =
makePrimitiveProcedure(
'triangle/ssa',
5,
function(MACHINE) {
var sideA = checkNonNegativeReal(MACHINE, "triangle/ssa", 0);
var sideB = checkNonNegativeReal(MACHINE, "triangle/ssa", 1);
var angleC = checkAngle(MACHINE, "triangle/ssa", 2);
var style = checkMode(MACHINE, "triangle/ssa", 3);
var color = checkColor(MACHINE, "triangle/ssa", 4);
// cast to fixnums
sideA = jsnums.toFixnum(sideA); sideB = jsnums.toFixnum(sideB); angleC = jsnums.toFixnum(angleC);
if (less(180, angleC)) {
raise( types.incompleteExn(types.exnFailContract, "The given side, side and angle will not form a triangle: "
+ sideA + ", " + sideB + ", " + angleC, []) );
}
var sideC2 = cosRel(sideA, sideB, angleC);
var sideC = Math.sqrt(sideC2);
if (sideC2 <= 0) {
raise( types.incompleteExn(types.exnFailContract, "The given side, side and angle will not form a triangle: "
+ sideA + ", " + sideB + ", " + angleC, []) );
} else {
if (less(sideA + sideB, sideC) ||
less(sideC + sideB, sideA) ||
less(sideA + sideC, sideB)) {
raise( types.incompleteExn(types.exnFailContract, "The given side, side and angle will not form a triangle: "
+ sideA + ", " + sideB + ", " + angleC, []) );
}
}
var angleA = Math.acos(excess(sideB, sideC, sideA) / (2 * sideB * sideC)) * (180 / Math.PI);
return makeTriangleImage(jsnums.toFixnum(sideC),
jsnums.toFixnum(angleA),
jsnums.toFixnum(sideB),
style.toString(),
color);
});
EXPORTS['triangle/aas'] =
makePrimitiveProcedure(
'triangle/aas',
5,
function(MACHINE) {
var angleA = checkAngle(MACHINE, "triangle/aas", 0);
var angleB = checkAngle(MACHINE, "triangle/aas", 1);
var sideC = checkNonNegativeReal(MACHINE, "triangle/aas", 2);
var style = checkMode(MACHINE, "triangle/aas", 3);
var color = checkColor(MACHINE, "triangle/aas", 4);
// cast to fixnums
var angleA = jsnums.toFixnum(angleA); angleB = jsnums.toFixnum(angleB); sideC = jsnums.toFixnum(sideC);
var angleC = (180 - angleA - angleB);
if (less(angleC, 0)) {
raise( types.incompleteExn(types.exnFailContract, "The given angle, angle and side will not form a triangle: "
+ angleA + ", " + angleB + ", " + sideC, []) );
}
var hypotenuse = sideC / (Math.sin(angleC*Math.PI/180))
var sideB = hypotenuse * Math.sin(angleB*Math.PI/180);
return makeTriangleImage(jsnums.toFixnum(sideC),
jsnums.toFixnum(angleA),
jsnums.toFixnum(sideB),
style.toString(),
color);
});
EXPORTS['triangle/asa'] =
makePrimitiveProcedure(
'triangle/asa',
5,
function(MACHINE) {
var angleA = checkAngle(MACHINE, "triangle/asa", 0);
var sideB = checkNonNegativeReal(MACHINE, "triangle/asa", 1);
var angleC = checkAngle(MACHINE, "triangle/asa", 2);
var style = checkMode(MACHINE, "triangle/asa", 3);
var color = checkColor(MACHINE, "triangle/asa", 4);
// cast to fixnums
var angleA = jsnums.toFixnum(angleA); sideB = jsnums.toFixnum(sideB); angleC = jsnums.toFixnum(angleC);
var angleB = (180 - angleA - angleC);
if (less(angleB, 0)) {
raise( types.incompleteExn(types.exnFailContract, "The given angle, side and angle will not form a triangle: "
+ angleA + ", " + sideB + ", " + angleC, []) );
}
var base = (sideB * Math.sin(angleA*Math.PI/180)) / (Math.sin(angleB*Math.PI/180));
var sideC = (sideB * Math.sin(angleC*Math.PI/180)) / (Math.sin(angleB*Math.PI/180));
return makeTriangleImage(jsnums.toFixnum(sideC),
jsnums.toFixnum(angleA),
jsnums.toFixnum(sideB),
style.toString(),
color);
});
EXPORTS['triangle/saa'] =
makePrimitiveProcedure(
'triangle/saa',
5,
function(MACHINE) {
var sideA = checkNonNegativeReal(MACHINE, "triangle/saa", 0);
var angleB = checkAngle(MACHINE, "triangle/saa", 1);
var angleC = checkAngle(MACHINE, "triangle/saa", 2);
var style = checkMode(MACHINE, "triangle/saa", 3);
var color = checkColor(MACHINE, "triangle/saa", 4);
// cast to fixnums
var sideA = jsnums.toFixnum(sideA); angleB = jsnums.toFixnum(angleB); angleC = jsnums.toFixnum(angleC);
var angleA = (180 - angleC - angleB);
var hypotenuse = sideA / (Math.sin(angleA*Math.PI/180));
var sideC = hypotenuse * Math.sin(angleC*Math.PI/180);
var sideB = hypotenuse * Math.sin(angleB*Math.PI/180);
return makeTriangleImage(jsnums.toFixnum(sideC),
jsnums.toFixnum(angleA),
jsnums.toFixnum(sideB),
style.toString(),
color);
});
EXPORTS['right-triangle'] =
EXPORTS['right-triangle'] =
makePrimitiveProcedure(
'right-triangle',
4,
@ -1302,11 +896,10 @@ EXPORTS['right-triangle'] =
var side2 = checkNonNegativeReal(MACHINE, "right-triangle", 1);
var s = checkMode(MACHINE, "right-triangle", 2);
var c = checkColor(MACHINE, "right-triangle", 3);
return makeTriangleImage(jsnums.toFixnum(side1),
jsnums.toFixnum(360-90),
jsnums.toFixnum(side2),
s.toString(),
c);
return makeRightTriangleImage(jsnums.toFixnum(side1),
jsnums.toFixnum(side2),
s.toString(),
c);
});
@ -1316,18 +909,13 @@ EXPORTS['isosceles-triangle'] =
4,
function(MACHINE) {
var side = checkNonNegativeReal(MACHINE, "isosceles-triangle", 0);
var angleC = checkAngle(MACHINE, "isosceles-triangle", 1);
var angle = checkAngle(MACHINE, "isosceles-triangle", 1);
var s = checkMode(MACHINE, "isosceles-triangle", 2);
var c = checkColor(MACHINE, "isosceles-triangle", 3);
// cast to fixnums
side = jsnums.toFixnum(side); angleC = jsnums.toFixnum(angleC);
var angleAB = (180-angleC)/2;
var base = 2*side*Math.sin((angleC*Math.PI/180)/2);
return makeTriangleImage(jsnums.toFixnum(base),
jsnums.toFixnum(360-angleAB),// add 180 to make the triangle point up
jsnums.toFixnum(side),
s.toString(),
c);
return makeTriangleImage(jsnums.toFixnum(side),
jsnums.toFixnum(angle),
s.toString(),
c);
});
@ -1494,4 +1082,4 @@ EXPORTS['name->color'] =
var name = checkSymbolOrString(MACHINE, 'name->color', 0);
var result = colorDb.get('' + name) || false;
return result;
});
});

1725
whalesong/image/private/kernel.js
View File

File diff suppressed because it is too large Load Diff

18
whalesong/image/private/main.rkt
View File

@ -12,18 +12,15 @@
"js-impl.js")
#:provided-values (text
text/font
bitmap/url
image-url ;; older name for bitmap/url
open-image-url ;; older name for bitmap/url
video/url
play-sound
overlay
overlay/offset
overlay/xy
overlay/align
underlay
underlay/offset
underlay/xy
underlay/align
beside
@ -31,7 +28,6 @@
above
above/align
empty-scene
put-image
place-image
place-image/align
rotate
@ -47,17 +43,9 @@
circle
square
rectangle
polygon
regular-polygon
ellipse
triangle
triangle/sas
triangle/sss
triangle/ass
triangle/ssa
triangle/aas
triangle/asa
triangle/saa
right-triangle
isosceles-triangle
star
@ -78,6 +66,6 @@
side-count?
step-count?
image?
image=?
name->color
))

46
whalesong/image/private/racket-impl.rkt
View File

@ -5,11 +5,9 @@
(provide text
text/font
overlay
overlay/offset
overlay/xy
overlay/align
underlay
underlay/offset
underlay/xy
underlay/align
beside
@ -17,7 +15,6 @@
above
above/align
empty-scene
put-image
place-image
place-image/align
rotate
@ -33,17 +30,9 @@
circle
square
rectangle
polygon
regular-polygon
ellipse
triangle
triangle/sas
triangle/sss
triangle/ass
triangle/ssa
triangle/aas
triangle/asa
triangle/saa
right-triangle
isosceles-triangle
star
@ -62,22 +51,19 @@
angle?
side-count?
image?
image=?
;; Something funky is happening on the Racket side of things with regards
;; to step-count? See: http://bugs.racket-lang.org/query/?cmd=view&pr=12031
;; step-count?
bitmap/url
video/url
play-sound
name->color
step-count?
image-url
open-image-url
color-list->bitmap
)
@ -103,11 +89,9 @@
text
text/font
overlay
overlay/offset
overlay/xy
overlay/align
underlay
underlay/offset
underlay/xy
underlay/align
beside
@ -115,7 +99,6 @@
above
above/align
empty-scene
put-image
place-image
place-image/align
rotate
@ -131,17 +114,9 @@
circle
square
rectangle
polygon
regular-polygon
ellipse
triangle
triangle/sas
triangle/sss
triangle/ass
triangle/ssa
triangle/aas
triangle/asa
triangle/saa
right-triangle
isosceles-triangle
star
@ -159,15 +134,12 @@
y-place?
angle?
side-count?
image?
image=?
;; Something funky is happening on the Racket side of things with regards
;; to step-count? See: http://bugs.racket-lang.org/query/?cmd=view&pr=12031
;; step-count?
bitmap/url
video/url
play-sound
name->color
step-count?
image-url
@ -177,7 +149,7 @@
;(define (my-step-count? x)
; (and (integer? x)
@ -189,9 +161,9 @@
#;(define (name->color n)
(error 'name->color "not implemented yet"))
(error 'name->color "not implemented yet"))
#;(provide (rename-out [my-step-count? step-count?]
[bitmap/url image-url]
[bitmap/url open-image-url]))
[bitmap/url image-url]
[bitmap/url open-image-url]))

1
whalesong/info.rkt
View File

@ -24,7 +24,6 @@
"sandbox"
"examples"
"experiments"
"selfhost"
"simulator"
"tmp"))
(define can-be-loaded-with 'all)

2
whalesong/js-assembler/assemble.rkt
View File

@ -65,7 +65,6 @@
(display (assemble-current-interned-constant-closure-table) op)
(display "M.params.currentErrorHandler = fail;\n" op)
(display "M.params.currentSuccessHandler = success;\n" op)
(display #<<EOF
for (param in params) {
if (Object.hasOwnProperty.call(params, param)) {
@ -80,6 +79,7 @@ EOF
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))]
[else
;; Otherwise, we want to run under a trampolining context.
(display "M.c.push(new RT.CallFrame(function(M){ setTimeout(success, 0); },M.p));\n" op)
(fprintf op "M.trampoline(~a, ~a); })"
(assemble-label (make-Label (BasicBlock-name (first basic-blocks))))
(cond [(eq? trampoline-option 'with-preemption)

18
whalesong/js-assembler/package.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "assemble.rkt"
"quote-cdata.rkt"
"../logger.rkt"
"../make/make.rkt"
"../make/make-structs.rkt"
@ -42,7 +43,7 @@
(provide package
package-anonymous
package-standalone-html
package-standalone-xhtml
get-inert-code
get-standalone-code
write-standalone-code
@ -505,13 +506,14 @@ M.installedModules[~s] = function() {
;; package-standalone-html: X output-port -> void
(define (package-standalone-html source-code op)
;; package-standalone-xhtml: X output-port -> void
(define (package-standalone-xhtml source-code op)
(display (get-header) op)
(display (string-append (get-runtime)
(get-inert-code source-code
(lambda () (error 'package-standalone-html)))
invoke-main-module-code) op)
(display (quote-cdata
(string-append (get-runtime)
(get-inert-code source-code
(lambda () (error 'package-standalone-xhtml)))
invoke-main-module-code)) op)
(display *footer* op))
@ -589,7 +591,7 @@ M.installedModules[~s] = function() {
(format
#<<EOF
<!DOCTYPE html>
<html xml:lang="en">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<meta name="viewport" content="initial-scale=1.0, width=device-width, height=device-height, minimum-scale=1.0, maximum-scale=1.0, user-scalable=no" />
<meta charset="utf-8"/>

2
whalesong/js-assembler/runtime-src/runtime.js
View File

@ -297,7 +297,6 @@
'currentOutputPort': new StandardOutputPort(),
'currentErrorPort': new StandardErrorPort(),
'currentInputPort': new StandardInputPort(),
'currentSuccessHandler': function(MACHINE) {},
'currentErrorHandler': function(MACHINE, exn) {
MACHINE.params.currentErrorDisplayer(
MACHINE,
@ -753,7 +752,6 @@
that.running = false;
that.breakScheduled = false;
that.params.currentSuccessHandler(that);
release();
return;

2062
whalesong/lang/for.rkt
View File

File diff suppressed because it is too large Load Diff

718
whalesong/lang/kernel.rkt
View File

@ -3,8 +3,8 @@
sgn conjugate))
(prefix-in racket: racket/base)
racket/provide
racket/local
(for-syntax racket/base)
racket/local
(for-syntax racket/base)
racket/stxparam
(only-in '#%paramz
@ -37,28 +37,6 @@
(provide current-print-mode)
;; Custom letrec and letrec-values in order to avoid running
;; into the (in Racket) newly introduced undefined value.
(provide letrec letrec-values)
(define unique-undefined-value (list '<undefined>))
(define-syntax (letrec stx)
(syntax-case stx ()
[(_ ([id expr] ...) body ...)
(syntax/loc stx
(let ([id unique-undefined-value] ...)
(set! id expr) ...
(let () body ...)))]))
(define-syntax (letrec-values stx)
(syntax-case stx ()
[(_ ([(id ...) expr] ...) body ...)
(syntax/loc stx
(let ([id unique-undefined-value] ... ...)
(set!-values (id ...) expr) ...
(let () body ...)))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Primitive function stubs
@ -105,74 +83,74 @@
null
eof
#%plain-module-begin
#%module-begin
#%datum
#%app
#%module-begin
#%datum
#%app
#%plain-app
#%top-interaction
#%top
#%top-interaction
#%top
module
define
define-values
define-values
let-syntax
let-values
let*-values
define-struct
let-values
let*-values
define-struct
struct
if
cond
else
cond
else
=>
case
quote
unquote
unquote-splicing
lambda
case-lambda
let
let*
letrec
letrec-values
local
begin
begin0
set!
and
or
when
unless
case
quote
unquote
unquote-splicing
lambda
case-lambda
let
let*
letrec
letrec-values
local
begin
begin0
set!
and
or
when
unless
do
require
for-syntax
for-syntax
for-template
define-for-syntax
begin-for-syntax
prefix-in
only-in
define-for-syntax
begin-for-syntax
prefix-in
only-in
rename-in
except-in
provide
planet
all-defined-out
all-from-out
provide
planet
all-defined-out
all-from-out
prefix-out
except-out
rename-out
struct-out
except-out
rename-out
struct-out
filtered-out
combine-in
protect-out
combine-out
define-syntax-rule
define-syntax
define-syntaxes
define-syntax
define-syntaxes
let/cc
with-continuation-mark
with-continuation-mark
hash?
hash-equal?
hash-eq?
@ -194,20 +172,20 @@
hash-remove
equal-hash-code
hash-count
;; Kernel inlinable
*
-
+
=
/
sub1
add1
<
>
<=
>=
-
+
=
/
sub1
add1
<
>
<=
>=
cons
car
cdr
@ -218,15 +196,15 @@
not
eq?
values
;; The version of apply in racket/base is doing some stuff that
;; we are not handling yet. So we expose the raw apply here instead.
(rename-out [kernel:apply apply])
call-with-values
gensym
srcloc
make-srcloc
srcloc?
@ -235,25 +213,25 @@
srcloc-column
srcloc-position
srcloc-span
make-struct-type
make-struct-field-accessor
make-struct-field-mutator
struct-type?
exn:fail
struct:exn:fail
prop:exn:srclocs
current-inexact-milliseconds
current-seconds
continuation-prompt-available?
abort-current-continuation
call-with-continuation-prompt
;; needed for cs019-local
#%stratified-body
)
@ -270,293 +248,293 @@
;; Many of these should be pushed upward rather than stubbed, so that
;; Racket's compiler can optimize these.
(provide-stub-function
current-output-port
current-print
write
write-byte
display
newline
displayln
current-continuation-marks
continuation-mark-set->list
;; continuation-mark-set?
;; continuation-mark-set->list
;; struct-constructor-procedure?
;; struct-predicate-procedure?
;; struct-accessor-procedure?
;; struct-mutator-procedure?
;; make-arity-at-least
;; arity-at-least?
;; arity-at-least-value
;; compose
;; current-inexact-milliseconds
;; current-seconds
void
random
;; sleep
;; (identity -identity)
raise
error
raise-type-error
raise-mismatch-error
make-exn
make-exn:fail
make-exn:fail:contract
make-exn:fail:contract:arity
make-exn:fail:contract:variable
make-exn:fail:contract:divide-by-zero
;; exn?
;; exn:fail:contract:arity?
;; exn:fail:contract:variable?
;; exn:fail:contract:divide-by-zero?
exn:fail?
exn:fail:contract?
exn:fail:contract:arity?
exn-message
exn-continuation-marks
abs
quotient
remainder
modulo
max
min
gcd
lcm
floor
ceiling
round
truncate
numerator
denominator
expt
exp
log
sin
sinh
cos
cosh
tan
asin
acos
atan
sqr
sqrt
integer-sqrt
sgn
make-rectangular
make-polar
real-part
imag-part
angle
magnitude
conjugate
inexact->exact
exact->inexact
number->string
string->number
procedure?
procedure-arity
procedure-arity-includes?
procedure-rename
;; (undefined? -undefined?)
;; immutable?
void?
symbol?
string?
char?
boolean?
vector?
struct?
;; bytes?
byte?
number?
complex?
real?
rational?
integer?
exact-integer?
exact?
exact-nonnegative-integer?
inexact?
odd?
even?
zero?
positive?
negative?
box?
;; hash?
equal?
eqv?
caar
cdar
cadr
cddr
caaar
cdaar
cadar
cddar
caadr
cdadr
caddr
cdddr
caaaar
cdaaar
cadaar
cddaar
caadar
cdadar
caddar
cdddar
caaadr
cdaadr
cadadr
cddadr
caaddr
cdaddr
cadddr
cddddr
length
list*
list-ref
;; list-tail
append
reverse
for-each
map
andmap
ormap
memq
memv
member
memf
assq
assv
assoc
;; sort
box
;; box-immutable
unbox
set-box!
;; make-hash
;; make-hasheq
;; hash-set!
;; hash-ref
;; hash-remove!
;; hash-map
;; hash-for-each
make-string
string
string-length
string-ref
string=?
string<?
string>?
string<=?
string>=?
string-ci=?
string-ci<?
string-ci>?
string-ci<=?
string-ci>=?
string-copy
substring
string-append
string->list
list->string
string->symbol
symbol->string
format
printf
fprintf
;; string->immutable-string
string-set!
;; string-fill!
;; make-bytes
;; bytes
;; bytes->immutable-bytes
;; bytes-length
;; bytes-ref
;; bytes-set!
;; subbytes
;; bytes-copy
;; bytes-fill!
;; bytes-append
;; bytes->list
;; list->bytes
;; bytes=?
;; bytes<?
;; bytes>?
make-vector
vector
vector-length
vector-ref
vector-set!
vector->list
list->vector
char=?
char<?
char>?
char<=?
char>=?
char-ci=?
char-ci<?
char-ci>?
char-ci<=?
char-ci>=?
char-alphabetic?
char-numeric?
char-whitespace?
char-upper-case?
char-lower-case?
char->integer
integer->char
char-upcase
char-downcase
;; these are defined in bootstrapped-primitives in Whalesong's compiler package
call-with-current-continuation
call/cc
;; call-with-continuation-prompt
;; abort-current-continuation
default-continuation-prompt-tag
make-continuation-prompt-tag
continuation-prompt-tag?
make-reader-graph
make-placeholder
placeholder-set!
eof-object?
read-byte
hash-has-key?
hash-keys
hash-values
)
;; continuation-mark-set?
;; continuation-mark-set->list
;; struct-constructor-procedure?
;; struct-predicate-procedure?
;; struct-accessor-procedure?
;; struct-mutator-procedure?
;; make-arity-at-least
;; arity-at-least?
;; arity-at-least-value
;; compose
;; current-inexact-milliseconds
;; current-seconds
void
random
;; sleep
;; (identity -identity)
raise
error
raise-type-error
raise-mismatch-error
make-exn
make-exn:fail
make-exn:fail:contract
make-exn:fail:contract:arity
make-exn:fail:contract:variable
make-exn:fail:contract:divide-by-zero
;; exn?
;; exn:fail:contract:arity?
;; exn:fail:contract:variable?
;; exn:fail:contract:divide-by-zero?
exn:fail?
exn:fail:contract?
exn:fail:contract:arity?
exn-message
exn-continuation-marks
abs
quotient
remainder
modulo
max
min
gcd
lcm
floor
ceiling
round
truncate
numerator
denominator
expt
exp
log
sin
sinh
cos
cosh
tan
asin
acos
atan
sqr
sqrt
integer-sqrt
sgn
make-rectangular
make-polar
real-part
imag-part
angle
magnitude
conjugate
inexact->exact
exact->inexact
number->string
string->number
procedure?
procedure-arity
procedure-arity-includes?
procedure-rename
;; (undefined? -undefined?)
;; immutable?
void?
symbol?
string?
char?
boolean?
vector?
struct?
;; bytes?
byte?
number?
complex?
real?
rational?
integer?
exact-integer?
exact?
exact-nonnegative-integer?
inexact?
odd?
even?
zero?
positive?
negative?
box?
;; hash?
equal?
eqv?
caar
cdar
cadr
cddr
caaar
cdaar
cadar
cddar
caadr
cdadr
caddr
cdddr
caaaar
cdaaar
cadaar
cddaar
caadar
cdadar
caddar
cdddar
caaadr
cdaadr
cadadr
cddadr
caaddr
cdaddr
cadddr
cddddr
length
list*
list-ref
;; list-tail
append
reverse
for-each
map
andmap
ormap
memq
memv
member
memf
assq
assv
assoc
;; sort
box
;; box-immutable
unbox
set-box!
;; make-hash
;; make-hasheq
;; hash-set!
;; hash-ref
;; hash-remove!
;; hash-map
;; hash-for-each
make-string
string
string-length
string-ref
string=?
string<?
string>?
string<=?
string>=?
string-ci=?
string-ci<?
string-ci>?
string-ci<=?
string-ci>=?
string-copy
substring
string-append
string->list
list->string
string->symbol
symbol->string
format
printf
fprintf
;; string->immutable-string
string-set!
;; string-fill!
;; make-bytes
;; bytes
;; bytes->immutable-bytes
;; bytes-length
;; bytes-ref
;; bytes-set!
;; subbytes
;; bytes-copy
;; bytes-fill!
;; bytes-append
;; bytes->list
;; list->bytes
;; bytes=?
;; bytes<?
;; bytes>?
make-vector
vector
vector-length
vector-ref
vector-set!
vector->list
list->vector
char=?
char<?
char>?
char<=?
char>=?
char-ci=?
char-ci<?
char-ci>?
char-ci<=?
char-ci>=?
char-alphabetic?
char-numeric?
char-whitespace?
char-upper-case?
char-lower-case?
char->integer
integer->char
char-upcase
char-downcase
;; these are defined in bootstrapped-primitives in Whalesong's compiler package
call-with-current-continuation
call/cc
;; call-with-continuation-prompt
;; abort-current-continuation
default-continuation-prompt-tag
make-continuation-prompt-tag
continuation-prompt-tag?
make-reader-graph
make-placeholder
placeholder-set!
eof-object?
read-byte
hash-has-key?
hash-keys
hash-values
)

27
whalesong/lang/match.rkt
View File

@ -1,27 +0,0 @@
#lang whalesong
(require "private/match/match.rkt" "private/match/runtime.rkt"
(for-syntax racket/base))
(provide (except-out (all-from-out "private/match/match.rkt")
define-match-expander)
failure-cont
(rename-out [define-match-expander* define-match-expander]))
(define-for-syntax (no-old-match-form stx)
(raise-syntax-error
#f
"works only for constructor-based `match' form"
stx))
(define-syntax-rule (failure-cont) (fail))
(define-syntax define-match-expander*
(syntax-rules ()
[(_ id expr) (define-match-expander id expr)]
[(_ id expr expr2) (define-match-expander id
expr
no-old-match-form
(#%expression expr2))]))

84
whalesong/lang/parameters.rkt
View File

@ -1,84 +0,0 @@
#lang whalesong
(provide make-parameter parameterize)
;;;
;;; PARAMETERS
;;;
; This is an implementation of "parameters".
; Consider this a first approximation.
; Parameters in Racket implement a kind of dynamic binding that
; works nicely with threads and continuations.
; Since Whalesong currently is single-threaded there is
; nothing to worry about regarding threads.
; In standard Racket (parameterize bindings body) the bindings
; will be in effect while evaluating body. If control
; leaves body due to exceptions, escapes or similar, the
; bindings are reverted to their previous values. On re-entry
; to body (e.g. from a captured continuation) the bindings
; are supposed to be reinstated.
; Given dynamic-wind this behaviour is straight-forward to implement.
; Alas Whalesong does not support dynamic-wind yet, so in this
; implementation nothing happens, when control leaves body.
; In short: For programs that don't use call/cc and friends
; this implementation of parameters ought to work as expected.
(require (for-syntax racket/base))
(require (for-syntax syntax/parse))
; Parameterization can be nested, so we represent the parameter cell
; as a stack of values.
(struct parameter (values) #:mutable)
; Each parameter will get an unique id.
(define *parameters* '()) ; Assocation list from ids to parameter cells.
; syntax : (push! id-expr)
; push a new parameter cell to *parameters*
(define-syntax (push! stx)
(syntax-case stx ()
[(_ val)
#'(set! *parameters* (cons val *parameters*))]))
; find-parameter : id -> parameter
; return parameter associated with id
(define (find-parameter id)
(cond
[(assq id *parameters*) => cdr]
[else (error 'find-parameter "parameter not found, got id: ~a" id)]))
; make-parameter : value -> parameter-procecure
; Make new parameter and return its parameter procedure.
; The parameter procedure also acts as id for the parameter.
(define (make-parameter val)
(define p (parameter (list val)))
(define proc (case-lambda
[() (first (parameter-values (find-parameter proc)))]
[(v) (define p (find-parameter proc))
(define vs (cons v (parameter-values p)))
(set-parameter-values! p vs)]))
(push! (cons proc p))
proc)
; syntax : (parameterize bindings body ...)
; Evaluate body where the parameters in bindings
; are bound to the values given in bindings.
; Restore bindings afterwards.
(define-syntax (parameterize stx)
(syntax-case stx ()
[(_ ([param-expr val-expr]) body ...)
#'(let ()
(define proc param-expr)
(define p (find-parameter proc))
(define v val-expr)
(define old (parameter-values p))
(define vs (cons v old))
(set-parameter-values! p vs)
(begin0
body ...
(set-parameter-values! p old)))]))

481
whalesong/lang/private/match/compiler.rkt
View File

@ -1,481 +0,0 @@
#lang racket/base
(require (for-template whalesong/lang/whalesong
; racket/base
"runtime.rkt"
racket/stxparam
; racket/unsafe/ops
)
syntax/boundmap
syntax/stx
"patterns.rkt"
"split-rows.rkt"
"reorder.rkt"
racket/stxparam
racket/syntax)
(provide compile*)
;; for non-linear patterns
(define vars-seen (make-parameter null))
(define (hash-on f elems #:equal? [eql #t])
(define ht (if eql (make-hash) (make-hasheq)))
;; put all the elements e in the ht, indexed by (f e)
(for ([r
;; they need to be in the original order when they come out
(reverse elems)])
(define k (f r))
(hash-set! ht k (cons r (hash-ref ht k (lambda () null)))))
ht)
;; generate a clause of kind k
;; for rows rows, with matched variable x and rest variable xs
;; escaping to esc
(define (gen-clause k rows x xs esc)
(define-syntax-rule (constant-pat predicate-stx)
(with-syntax ([rhs (compile* (cons x xs)
(map (lambda (row)
(define-values (p ps)
(Row-split-pats row))
(define p* (Atom-p p))
(make-Row (cons p* ps)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
rows)
esc)])
#`[(#,predicate-stx #,x) rhs]))
(define (compile-con-pat accs pred pat-acc)
(with-syntax* ([(tmps ...) (generate-temporaries accs)]
[(accs ...) accs]
[pred pred]
[body (compile*
(append (syntax->list #'(tmps ...)) xs)
(map (lambda (row)
(define-values (p1 ps) (Row-split-pats row))
(make-Row (append (pat-acc p1) ps)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
rows)
esc)])
#`[(pred #,x) (let ([tmps (accs #,x)] ...) body)]))
(cond
[(eq? 'box k)
(compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
[(eq? 'pair k)
(compile-con-pat (list #'car #'cdr) #'pair?
(lambda (p) (list (Pair-a p) (Pair-d p))))]
[(eq? 'mpair k)
; XXX These should be unsafe-mcar* when mpairs have chaperones
(compile-con-pat (list #'mcar #'mcdr) #'mpair?
(lambda (p) (list (MPair-a p) (MPair-d p))))]
[(eq? 'string k) (constant-pat #'string?)]
[(eq? 'number k) (constant-pat #'number?)]
[(eq? 'symbol k) (constant-pat #'symbol?)]
[(eq? 'keyword k) (constant-pat #'keyword?)]
[(eq? 'char k) (constant-pat #'char?)]
[(eq? 'bytes k) (constant-pat #'bytes?)]
[(eq? 'regexp k) (constant-pat #'regexp?)]
[(eq? 'boolean k) (constant-pat #'boolean?)]
[(eq? 'null k) (constant-pat #'null?)]
;; vectors are handled specially
;; because each arity is like a different constructor
[(eq? 'vector k)
(let ([ht (hash-on (lambda (r)
(length (Vector-ps (Row-first-pat r)))) rows)])
(with-syntax ([(clauses ...)
(hash-map
ht
(lambda (arity rows)
(define ns (build-list arity values))
(with-syntax ([(tmps ...) (generate-temporaries ns)])
(with-syntax ([body
(compile*
(append (syntax->list #'(tmps ...)) xs)
(map (lambda (row)
(define-values (p1 ps)
(Row-split-pats row))
(make-Row (append (Vector-ps p1) ps)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
rows)
esc)]
[(n ...) ns])
#`[(#,arity)
(let ([tmps (vector-ref #,x n)] ...)
body)]))))])
#`[(vector? #,x)
(case (vector-length #,x) ; [Whalesong] unsafe-
clauses ...
[else (#,esc)])]))]
;; it's a structure
[(box? k)
;; all the rows are structures with the same predicate
(let* ([s (Row-first-pat (car rows))]
[accs (Struct-accessors s)]
[accs (if (Struct-complete? s)
(build-list (length accs)
(λ (i) (with-syntax ([a (list-ref accs i)])
#`(λ (x) (a x))))) ; [Whalesong]
accs)]
[pred (Struct-pred s)])
(compile-con-pat accs pred Struct-ps))]
[else (error 'match-compile "bad key: ~a" k)]))
;; produces the syntax for a let clause
(define (compile-one vars block esc)
(define-values (first rest-pats) (Row-split-pats (car block)))
(define x (car vars))
(define xs (cdr vars))
(cond
;; the Exact rule
[(Exact? first)
(let ([ht (hash-on (compose Exact-v Row-first-pat) block #:equal? #t)])
(with-syntax ([(clauses ...)
(hash-map
ht
(lambda (k v)
#`[(equal? #,x '#,k)
#,(compile* xs
(map (lambda (row)
(make-Row (cdr (Row-pats row))
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
v)
esc)]))])
#`(cond clauses ... [else (#,esc)])))]
;; the Var rule
[(Var? first)
(let ([transform
(lambda (row)
(define-values (p ps) (Row-split-pats row))
(define v (Var-v p))
(define seen (Row-vars-seen row))
;; a new row with the rest of the patterns
(cond
;; if this was a wild-card variable, don't bind
[(Dummy? p) (make-Row ps
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row))]
;; if we've seen this variable before, check that it's equal to
;; the one we saw
[(for/or ([e seen])
(let ([v* (car e)] [id (cdr e)])
(and (bound-identifier=? v v*) id)))
=>
(lambda (id)
(make-Row ps
#`(if ((match-equality-test) #,x #,id)
#,(Row-rhs row)
(fail))
(Row-unmatch row)
seen))]
;; otherwise, bind the matched variable to x, and add it to the
;; list of vars we've seen
[else (let ([v* (free-identifier-mapping-get
(current-renaming) v (lambda () v))])
(make-Row ps
#`(let ([#,v* #,x]) #,(Row-rhs row))
(Row-unmatch row)
(cons (cons v x) (Row-vars-seen row))))]))])
;; compile the transformed block
(compile* xs (map transform block) esc))]
;; the Constructor rule
[(CPat? first)
(let ;; put all the rows in the hash, indexed by their constructor
([ht (hash-on (lambda (r) (pat-key (Row-first-pat r))) block)])
(with-syntax ([(clauses ...)
(hash-map
ht (lambda (k v) (gen-clause k v x xs esc)))])
#`(cond clauses ... [else (#,esc)])))]
;; the Or rule
[(Or? first)
;; we only handle 1-row Ors atm - this is all the mixture rule should give
;; us
(unless (null? (cdr block))
(error 'compile-one "Or block with multiple rows: ~a" block))
(let* ([row (car block)]
[pats (Row-pats row)]
[seen (Row-vars-seen row)]
;; all the pattern alternatives
[qs (Or-ps (car pats))]
;; the variables bound by this pattern - they're the same for the
;; whole list
[vars
(for/list ([bv (bound-vars (car qs))]
#:when (for/and ([seen-var seen])
(not (free-identifier=? bv (car seen-var)))))
bv)])
(with-syntax ([(esc* success? var ...) (append (generate-temporaries '(esc* success?)) vars)])
;; do the or matching, and bind the results to the appropriate
;; variables
#`(let ([esc* (lambda () (values #f #,@(for/list ([v vars]) #'#f)))])
(let-values ([(success? var ...)
#,(compile* (list x)
(map (lambda (q)
(make-Row (list q)
#'(values #t var ...)
#f
seen))
qs)
#'esc*)])
;; then compile the rest of the row
(if success?
#,(compile* xs
(list (make-Row (cdr pats)
(Row-rhs row)
(Row-unmatch row)
(append (map cons vars vars) seen)))
esc)
(#,esc))))))]
;; the App rule
[(App? first)
;; we only handle 1-row Apps atm - this is all the mixture rule should
;; give us
(unless (null? (cdr block))
(error 'compile-one "App block with multiple rows: ~a" block))
(let* ([row (car block)]
[pats (Row-pats row)]
[app-pats (App-ps first)])
(with-syntax ([(t ...) (generate-temporaries app-pats)])
#`(let-values ([(t ...) (#,(App-expr first) #,x)])
#,(compile* (append (syntax->list #'(t ...)) xs)
(list (make-Row (append app-pats (cdr pats))
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
esc))))]
;; the And rule
[(And? first)
;; we only handle 1-row Ands
;; this is all the mixture rule should give us
(unless (null? (cdr block))
(error 'compile-one "And block with multiple rows: ~a" block))
(define row (car block))
(define pats (Row-pats row))
;; all the patterns
(define qs (And-ps (car pats)))
(compile* (append (map (lambda _ x) qs) xs)
(list (make-Row (append qs (cdr pats))
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
esc
;; don't re-order OrderedAnd patterns
(not (OrderedAnd? first)))]
;; the Not rule
[(Not? first)
;; we only handle 1-row Nots atm - this is all the mixture rule should
;; give us
(unless (null? (cdr block))
(error 'compile-one "Not block with multiple rows: ~a" block))
(let* ([row (car block)]
[pats (Row-pats row)]
;; the single pattern
[q (Not-p (car pats))])
(with-syntax ([(f) (generate-temporaries #'(f))])
#`(let ;; if q fails, we jump to here
([f (lambda ()
#,(compile* xs
(list (make-Row (cdr pats)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
esc))])
#,(compile* (list x)
;; if q doesn't fail, we jump to esc and fail the not
;; pattern
(list (make-Row (list q)
#`(#,esc)
(Row-unmatch row)
(Row-vars-seen row)))
#'f))))]
[(Pred? first)
;; multiple preds iff they have the identical predicate
(with-syntax ([pred? (Pred-pred first)]
[body (compile* xs
(map (lambda (row)
(define-values (_1 ps)
(Row-split-pats row))
(make-Row ps
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row)))
block)
esc)])
#`(cond [(pred? #,x) body] [else (#,esc)]))]
;; Generalized sequences... slightly tested
[(GSeq? first)
(let* ([headss (GSeq-headss first)]
[mins (GSeq-mins first)]
[maxs (GSeq-maxs first)]
[onces? (GSeq-onces? first)]
[tail (GSeq-tail first)]
[mutable? (GSeq-mutable? first)]
[make-Pair (if mutable? make-MPair make-Pair)]
[k (Row-rhs (car block))]
[xvar (car (generate-temporaries (list #'x)))]
[complete-heads-pattern
(lambda (ps)
(define (loop ps pat)
(if (pair? ps)
(make-Pair (car ps) (loop (cdr ps) pat))
pat))
(loop ps (make-Var xvar)))]
[heads
(for/list ([ps headss])
(complete-heads-pattern ps))]
[head-idss
(for/list ([heads headss])
(apply append (map bound-vars heads)))]
[hid-argss (map generate-temporaries head-idss)]
[head-idss* (map generate-temporaries head-idss)]
[hid-args (apply append hid-argss)]
[reps (generate-temporaries (for/list ([head heads]) 'rep))])
(with-syntax ([x xvar]
[var0 (car vars)]
[((hid ...) ...) head-idss]
[((hid* ...) ...) head-idss*]
[((hid-arg ...) ...) hid-argss]
[(rep ...) reps]
[(maxrepconstraint ...)
;; FIXME: move to side condition to appropriate pattern
(for/list ([repvar reps] [maxrep maxs])
(if maxrep #`(< #,repvar #,maxrep) #`#t))]
[(minrepclause ...)
(for/list ([repvar reps] [minrep mins] #:when minrep)
#`[(< #,repvar #,minrep) (fail)])]
[((hid-rhs ...) ...)
(for/list ([hid-args hid-argss] [once? onces?])
(for/list ([hid-arg hid-args])
(if once?
#`(car (reverse #,hid-arg))
#`(reverse #,hid-arg))))]
[(parse-loop failkv fail-tail)
(generate-temporaries #'(parse-loop failkv fail-tail))])
(with-syntax ([(rhs ...)
#`[(let ([hid-arg (cons hid* hid-arg)] ...)
(if maxrepconstraint
(let ([rep (add1 rep)])
(parse-loop x #,@hid-args #,@reps fail))
(begin (fail))))
...]]
[tail-rhs
#`(cond minrepclause ...
[else
(let ([hid hid-rhs] ... ...
[fail-tail fail])
#,(compile*
(cdr vars)
(list (make-Row rest-pats k
(Row-unmatch (car block))
(Row-vars-seen
(car block))))
#'fail-tail))])])
(parameterize ([current-renaming
(for/fold ([ht (copy-mapping (current-renaming))])
([id (apply append head-idss)]
[id* (apply append head-idss*)])
(free-identifier-mapping-put! ht id id*)
(free-identifier-mapping-for-each
ht
(lambda (k v)
(when (free-identifier=? v id)
(free-identifier-mapping-put! ht k id*))))
ht)])
#`(let parse-loop ([x var0]
[hid-arg null] ... ...
[rep 0] ...
[failkv #,esc])
#,(compile* (list #'x)
(append
(map (lambda (pats rhs)
(make-Row pats
rhs
(Row-unmatch (car block))
(Row-vars-seen
(car block))))
(map list heads)
(syntax->list #'(rhs ...)))
(list (make-Row (list tail)
#`tail-rhs
(Row-unmatch (car block))
(Row-vars-seen
(car block)))))
#'failkv))))))]
[else (error 'compile "unsupported pattern: ~a\n" first)]))
(define (compile* vars rows esc [reorder? #t])
(define (let/wrap clauses body)
(if (stx-null? clauses)
body
(quasisyntax (let* #,clauses #,body))))
(cond
;; if there are no rows, then just call the esc continuation
[(null? rows) #`(#,esc)]
;; if we have no variables, there are no more patterns to match
;; so we just pick the first RHS
[(null? vars)
(let ([fns
(let loop ([blocks (reverse rows)] [esc esc] [acc null])
(if (null? blocks)
;; if we're done, return the blocks
(reverse acc)
(with-syntax
(;; f is the name this block will have
[(f) (generate-temporaries #'(f))]
;; compile the block, with jumps to the previous esc
[c (with-syntax ([rhs #`(syntax-parameterize
([fail (make-rename-transformer
(quote-syntax #,esc))])
#,(Row-rhs (car blocks)))])
(define unmatch (Row-unmatch (car blocks)))
(if unmatch
(quasisyntax/loc unmatch
(call-with-continuation-prompt
(lambda () (let ([#,unmatch
(lambda ()
(abort-current-continuation match-prompt-tag))])
rhs))
match-prompt-tag
(lambda () (#,esc))))
#'rhs))])
;; then compile the rest, with our name as the esc
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
(let/wrap #'(fns ...) #'body)))]
;; otherwise, we split the matrix into blocks
;; and compile each block with a reference to its continuation
[else
(let*-values
([(rows vars) (if reorder?
(reorder-columns rows vars)
(values rows vars))]
[(fns)
(let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null])
(if (null? blocks)
;; if we're done, return the blocks
(reverse acc)
(with-syntax (;; f is the name this block will have
[(f) (generate-temporaries #'(f))]
;; compile the block, with jumps to the previous
;; esc
[c (compile-one vars (car blocks) esc)])
;; then compile the rest, with our name as the esc
(loop (cdr blocks)
#'f
(cons #`[f #,(syntax-property
#'(lambda () c)
'typechecker:called-in-tail-position #t)]
acc)))))])
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
(let/wrap #'(fns ...) #'body)))]))
;; (require mzlib/trace)
;; (trace compile* compile-one)

183
whalesong/lang/private/match/define-forms.rkt
View File

@ -1,183 +0,0 @@
#lang whalesong
(require (for-syntax racket/base
racket/syntax
(only-in racket/list append* remove-duplicates)
syntax/stx
syntax/parse
syntax/parse/experimental/template
racket/lazy-require))
(require (for-syntax "patterns.rkt" "gen-match.rkt")) ; [Whalesong]
#;(begin-for-syntax
(lazy-require ["patterns.rkt" (bound-vars)]
["gen-match.rkt" (go parse-id go/one)]))
(provide define-forms)
;; syntax classes for `define/match`
(begin-for-syntax
(define-syntax-class function-header
(pattern ((~or header:function-header name:id) . args:args)
#:attr params
(template ((?@ . (?? header.params ()))
. args.params))))
(define-syntax-class args
(pattern (arg:arg ...)
#:attr params #'(arg.name ...))
(pattern (arg:arg ... . rest:id)
#:attr params #'(arg.name ... rest)))
(define-splicing-syntax-class arg
#:attributes (name)
(pattern name:id)
(pattern [name:id default])
(pattern (~seq kw:keyword name:id))
(pattern (~seq kw:keyword [name:id default]))))
(define-syntax-rule (define-forms parse-id
match match* match-lambda match-lambda*
match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec
match/values match/derived match*/derived
define/match)
(...
(begin
(provide match match* match-lambda match-lambda* match-lambda**
match-let match-let* match-let-values match-let*-values
match-define match-define-values match-letrec
match/values match/derived match*/derived match-define-values
define/match)
(define-syntax (match* stx)
(syntax-parse stx
[(_ es . clauses)
(go parse-id stx #'es #'clauses)]))
(define-syntax (match*/derived stx)
(syntax-parse stx
[(_ es orig-stx . clauses)
(go parse-id #'orig-stx #'es #'clauses)]))
(define-syntax (match stx)
(syntax-parse stx
[(_ arg:expr clauses ...)
(go/one parse-id stx #'arg #'(clauses ...))]))
(define-syntax (match/derived stx)
(syntax-parse stx
[(_ arg:expr orig-stx clauses ...)
(go/one parse-id #'orig-stx #'arg #'(clauses ...))]))
(define-syntax (match/values stx)
(syntax-parse stx
[(_ arg:expr (~and cl0 [(pats ...) rhs ...]) clauses ...)
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
#`(let-values ([(ids ...) arg])
(match*/derived (ids ...) #,stx cl0 clauses ...)))]))
(define-syntax (match-lambda stx)
(syntax-parse stx
[(_ . clauses)
(with-syntax* ([arg (generate-temporary)]
[body #`(match/derived arg #,stx . clauses)])
(syntax/loc stx (lambda (arg) body)))]))
(define-syntax (match-lambda* stx)
(syntax-parse stx
[(_ . clauses)
(with-syntax* ([arg (generate-temporary)]
[body #`(match/derived arg #,stx . clauses)])
(syntax/loc stx (lambda arg body)))]))
(define-syntax (match-lambda** stx)
(syntax-parse stx
[(_ (~and clauses [(pats ...) . rhs]) ...)
(with-syntax* ([vars (generate-temporaries (car (syntax-e #'((pats ...) ...))))]
[body #`(match*/derived vars #,stx clauses ...)])
(syntax/loc stx (lambda vars body)))]))
(define-syntax (match-let-values stx)
(syntax-parse stx
[(_ (~and clauses ([(patss ...) rhss:expr] ...)) body1 body ...)
(define-values (idss let-clauses)
(for/lists (idss let-clauses)
([pats (syntax->list #'((patss ...) ...))]
[rhs (syntax->list #'(rhss ...))])
(define ids (generate-temporaries pats))
(values ids #`[#,ids #,rhs])))
#`(let-values #,let-clauses
(match*/derived #,(append* idss) #,stx
[(patss ... ...) (let () body1 body ...)]))]))
(define-syntax (match-let*-values stx)
(syntax-parse stx
[(_ () body1 body ...)
#'(let () body1 body ...)]
[(_ ([(pats ...) rhs] rest-pats ...) body1 body ...)
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
#`(let-values ([(ids ...) rhs])
(match*/derived (ids ...) #,stx
[(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...)
body1 body ...))])))]))
;; there's lots of duplication here to handle named let
;; some factoring out would do a lot of good
(define-syntax (match-let stx)
(syntax-parse stx
[(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...)
(with-syntax*
([vars (generate-temporaries #'(pat ...))]
[loop-body #`(match*/derived vars #,stx
[(pat ...) (let () body1 body ...)])])
#'(letrec ([nm (lambda vars loop-body)])
(nm init-exp ...)))]
[(_ ([pat init-exp:expr] ...) body1 body ...)
#`(match-let-values ([(pat) init-exp] ...) body1 body ...)]))
(define-syntax-rule (match-let* ([pat exp] ...) body1 body ...)
(match-let*-values ([(pat) exp] ...) body1 body ...))
(define-syntax (match-letrec stx)
(syntax-parse stx
[(_ ((~and cl [pat exp]) ...) body1 body ...)
(quasisyntax/loc stx
(let ()
#,@(for/list ([c (in-list (stx->list #'(cl ...)))]
[p (in-list (stx->list #'(pat ...)))]
[e (in-list (stx->list #'(exp ...)))])
(quasisyntax/loc c (match-define #,p #,e)))
body1 body ...))]))
(define-syntax (match-define stx)
(syntax-parse stx
[(_ pat rhs:expr)
(let ([p (parse-id #'pat)])
(with-syntax ([vars (bound-vars p)])
(quasisyntax/loc stx
(define-values vars (match*/derived (rhs) #,stx
[(pat) (values . vars)])))))]))
(define-syntax (match-define-values stx)
(syntax-parse stx
[(_ (pats ...) rhs:expr)
(define bound-vars-list (remove-duplicates
(foldr (λ (pat vars)
(append (bound-vars (parse-id pat)) vars))
'() (syntax->list #'(pats ...)))
bound-identifier=?))
(with-syntax ([(ids ...) (generate-temporaries #'(pats ...))])
(quasisyntax/loc stx
(define-values #,bound-vars-list
(match/values rhs
[(pats ...) (values . #,bound-vars-list)]))))]))
(define-syntax (define/match stx)
(syntax-parse stx
[(_ ?header:function-header ?clause ...)
(template
(define ?header
(match* (?? ?header.params)
?clause ...)))])))))

88
whalesong/lang/private/match/gen-match.rkt
View File

@ -1,88 +0,0 @@
#lang racket/base
(require "patterns.rkt" "compiler.rkt"
syntax/stx syntax/parse racket/syntax
(for-template racket/base (only-in "runtime.rkt" match:error fail)))
(provide go go/one)
;; this transforms `match'-style clauses into ones acceptable to `go'
;; go : syntax syntax syntax -> syntax
(define (go/one parse stx expr clauses)
(define-syntax-class cl
#:description "a clause with a pattern and a result"
(pattern [p . rhs]
#:with res (syntax/loc this-syntax [(p) . rhs])))
(syntax-parse clauses
[(c:cl ...)
(go parse stx (quasisyntax/loc expr (#,expr))
#'(c.res ...))]))
;; this parses the clauses using parse, then compiles them
;; go : syntax syntax syntax -> syntax
(define (go parse stx es clauses)
(syntax-parse clauses
[([pats . rhs] ...)
(parameterize ([orig-stx stx])
(unless (syntax->list es)
(raise-syntax-error 'match* "expected a sequence of expressions to match" es)))
(define/with-syntax form-name
(syntax-case stx ()
[(fname . _)
(identifier? #'fname)
(syntax-e #'fname)]
[_ 'match]))
(define len (length (syntax->list es)))
(define srcloc-list (list #`(quote #,(syntax-source stx))
#`(quote #,(syntax-line stx))
#`(quote #,(syntax-column stx))
#`(quote #,(syntax-position stx))
#`(quote #,(syntax-span stx))))
(define/with-syntax (xs ...) (generate-temporaries es))
(define/with-syntax (exprs ...) es)
(define/with-syntax outer-fail (generate-temporary #'fail))
(define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
(define/with-syntax raise-error
(quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name)))
(define parsed-clauses
(for/list ([clause (syntax->list clauses)]
[pats (syntax->list #'(pats ...))]
[rhs (syntax->list #'(rhs ...))])
(unless (syntax->list pats)
(raise-syntax-error 'match* "expected a sequence of patterns" pats))
(define lp (length (syntax->list pats)))
(unless (= len lp)
(raise-syntax-error
'match (format "wrong number of match clauses, expected ~a and got ~a" len lp) pats))
(define (mk unm rhs)
(make-Row (for/list ([p (syntax->list pats)]) (parse p))
(syntax-property
(quasisyntax/loc stx
(let () . #,rhs))
'feature-profile:pattern-matching 'antimark)
unm null))
(syntax-parse rhs
[()
(raise-syntax-error
'match
"expected at least one expression on the right-hand side"
clause)]
[(#:when e)
(raise-syntax-error
'match
"expected at least one expression on the right-hand side after #:when clause"
clause)]
[(#:when e rest ...) (mk #f #'((if e (let () rest ...) (fail))))]
[(((~datum =>) unm) . rhs) (mk #'unm #'rhs)]
[_ (mk #f rhs)])))
(define/with-syntax body
(compile* (syntax->list #'(xs ...)) parsed-clauses #'outer-fail))
(define/with-syntax (exprs* ...)
(for/list ([e (in-list (syntax->list #'(exprs ...)))])
(syntax-property e 'feature-profile:pattern-matching 'antimark)))
(syntax-property
(quasisyntax/loc stx
(let ([xs exprs*] ...)
(define (outer-fail) raise-error)
body))
'feature-profile:pattern-matching #t)]))

21
whalesong/lang/private/match/legacy-match.rkt
View File

@ -1,21 +0,0 @@
#lang racket/base
(require (only-in "runtime.rkt"
match-equality-test
exn:misc:match?)
(only-in "match-expander.rkt"
define-match-expander)
"define-forms.rkt"
(for-syntax "parse-legacy.rkt"
(only-in "patterns.rkt" match-...-nesting)))
(provide (for-syntax match-...-nesting)
match-equality-test
define-match-expander
exn:misc:match?)
(define-forms parse/legacy
match match* match-lambda match-lambda* match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec match/values match/derived match*/derived
define/match)

84
whalesong/lang/private/match/match-expander.rkt
View File

@ -1,84 +0,0 @@
#lang whalesong
(require (for-syntax racket/base "stxtime.rkt"))
(provide define-match-expander)
(begin-for-syntax
(define make-match-expander
(let ()
(define-struct match-expander (match-xform legacy-xform macro-xform)
#:property prop:set!-transformer
(λ (me stx)
(define xf (match-expander-macro-xform me))
(if (set!-transformer? xf)
((set!-transformer-procedure xf) stx)
(syntax-case stx (set!)
[(set! . _)
(raise-syntax-error #f "cannot mutate syntax identifier" stx)]
[_ (xf stx)])))
#:property prop:match-expander (struct-field-index match-xform)
#:property prop:legacy-match-expander (struct-field-index legacy-xform))
(values make-match-expander))))
(define-syntax (define-match-expander stx)
(define (lookup v alist)
(cond [(assoc v alist) => cadr]
[else #f]))
(define (parse args)
(let loop ([args args]
[alist '()])
(if (null? args)
alist
(let* ([stx-v (car args)]
[v (syntax-e stx-v)])
(cond
[(not (keyword? v))
(raise-syntax-error #f "argument must be a keyword" stx stx-v)]
[(not (memq v '(#:expression #:plt-match #:match)))
(raise-syntax-error
#f (format "keyword argument ~a is not a correct keyword" v)
stx stx-v)]
[else
(loop (cddr args) (cons (list v (cadr args)) alist))])))))
(syntax-case stx ()
[(_ id kw . rest)
(keyword? (syntax-e #'kw))
(let* ([args (syntax->list #'(kw . rest))]
[parsed-args (parse args)])
(with-syntax
([legacy-xform (lookup '#:match parsed-args)]
[match-xform (lookup '#:plt-match parsed-args)]
[macro-xform
(or (lookup '#:expression parsed-args)
#'(lambda (stx)
(raise-syntax-error
#f "this match expander must be used inside match"
stx)))])
(if (identifier? #'macro-xform)
(syntax/loc stx
(define-syntax id
(make-match-expander
match-xform
legacy-xform
(lambda (stx)
(syntax-case stx (set!)
[(nm . args) #'(macro-xform . args)]
[nm (identifier? #'nm) #'macro-xform]
[(set! . _)
(raise-syntax-error #f "match expander cannot be target of a set!" stx)])))))
(syntax/loc stx
(define-syntax id
(make-match-expander match-xform legacy-xform macro-xform))))))]
;; implement legacy syntax
[(_ id plt-match-xform match-xform std-xform)
#'(define-match-expander id #:plt-match plt-match-xform
#:match match-xform
#:expression std-xform)]
[(_ id plt-match-xform std-xform)
#'(define-match-expander id #:plt-match plt-match-xform
#:expression std-xform)]
[(_ id plt-match-xform)
#'(define-match-expander id #:plt-match plt-match-xform)]
;; error checking
[_ (raise-syntax-error #f "invalid use of define-match-expander" stx)]))

34
whalesong/lang/private/match/match.rkt
View File

@ -1,34 +0,0 @@
#lang whalesong
(require (only-in "runtime.rkt"
match-equality-test
exn:misc:match?)
(only-in "match-expander.rkt"
define-match-expander)
"define-forms.rkt"
"struct.rkt"
(for-syntax racket/lazy-require
(only-in "stxtime.rkt"
match-...-nesting
match-expander?
legacy-match-expander?
prop:match-expander
prop:legacy-match-expander)))
(require (for-syntax "parse.rkt")) ; [Whalesong]
#;(begin-for-syntax
(lazy-require ["parse.rkt" (parse)]))
(provide (for-syntax match-...-nesting match-expander? legacy-match-expander?
prop:match-expander prop:legacy-match-expander)
match-equality-test
define-match-expander
struct* ==
exn:misc:match?)
(define-forms parse
match match* match-lambda match-lambda* match-lambda** match-let match-let*
match-let-values match-let*-values
match-define match-define-values match-letrec match/values
match/derived match*/derived
define/match)

74
whalesong/lang/private/match/parameters.rkt
View File

@ -1,74 +0,0 @@
#lang whalesong
; This module contains a poor man's parameters.
(provide make-parameter parameterize)
(require (for-syntax syntax/parse
(only-in racket/base ...
with-syntax
syntax
generate-temporaries
#%app)))
; Assumptions:
; i) single thread
; ii) no continuation marks available
; The return value of make-parameter is not the parameter structure,
; but the getter/setter. When Whalesong gets support for applicable
; structures, the structure should be returned instead.
(struct param ([value #:mutable] getter guard)
; #:property prop:procedure (struct-field-index getter)
; Nope - whalesong does not support applicable structures
)
(define (make-parameter v [guard #f]) ; -> parameter?
; return new parameter procedure
; the value is initialized to v (in all threads)
; setting a new value will pass the value to a guard,
; the value returned by the guard will be used as the new value
; (the guard can raise an exception)
; the guard is not called for the initial value
(letrec ([getter (λ xs
(if (null? xs)
(param-value p)
(set-param-value! p (car xs))))]
[p (param v getter (and guard (λ(x) x)))])
getter))
(define-syntax (parameterize stx)
(syntax-parse stx
[(_ ([param-expr:expr val-expr:expr] ...) body0 body ...)
(with-syntax ([(param ...) (generate-temporaries #'(param-expr ...))]
[(old-value ...) (generate-temporaries #'(param-expr ...))])
#'(let ([param param-expr] ...)
(let ([old-value (param)] ...)
(param val-expr) ...
(begin0
(let () body0 body ...)
(param old-value) ...))))]))
;;; Tests
#;(begin
(define foo (make-parameter 11))
(list (list (foo) (foo 12) (foo))
(list 11 (void) 12))
(define bar (make-parameter 21))
(list (list (bar) (bar 22) (bar))
(list 21 (void) 22))
(list (parameterize ([foo 13] [bar 23])
(list (foo) (bar)))
(list 13 23))
(list (list (foo) (bar))
(list 12 22))
(list (parameterize ([foo 13] [bar 23])
(list (parameterize ([foo 14] [bar 24])
(list (foo) (bar)))
(foo) (bar)))
(list (list 14 24) 13 23)))

224
whalesong/lang/private/match/parse-helper.rkt
View File

@ -1,224 +0,0 @@
#lang racket/base
(require (for-template racket/base)
syntax/boundmap
racket/struct-info
;macro-debugger/emit
"patterns.rkt")
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err
match-expander-transform trans-match parse-struct
dd-parse parse-quote parse-id in-splicing?)
(define in-splicing? (make-parameter #f))
;; parse x as a match variable
;; x : identifier
(define (parse-id x)
(cond [(eq? '_ (syntax-e x))
(make-Dummy x)]
[(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern"
x)]
[else (make-Var x)]))
;; stx : syntax of pattern, starting with quote
;; parse : the parse function
(define (parse-quote stx parse)
(syntax-case stx (quote)
[(quote ())
(make-Null (make-Dummy stx))]
[(quote (a . b))
(make-Pair (parse (syntax/loc stx (quote a)))
(parse (syntax/loc stx (quote b))))]
[(quote vec)
(vector? (syntax-e #'vec))
(make-Vector (for/list ([e (syntax-e #'vec)])
(parse (quasisyntax/loc stx (quote #,e)))))]
[(quote bx)
(box? (syntax-e #'bx))
(make-Box (parse (quasisyntax/loc
stx
(quote #,(unbox (syntax-e #'bx))))))]
[(quote v)
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "non-literal in quote pattern" stx #'v))]
[_ (raise-syntax-error 'match "syntax error in quote pattern" stx)]))
;; parse : the parse fn
;; p : the repeated pattern
;; dd : the ... stx
;; rest : the syntax for the rest
;; pred? : recognizer for the parsed data structure (such as list?)
;; to-list: function to convert the value to a list
(define (dd-parse parse p dd rest pred? #:to-list [to-list #'values] #:mutable [mutable? #f])
(define count (ddk? dd))
(define min (and (number? count) count))
(define pat (parameterize ([match-...-nesting (add1 (match-...-nesting))])
(parse p)))
(define rest-pat (parse rest))
(cond [(and (not (in-splicing?)) ;; when we're inside splicing, rest-pat isn't the rest
(not min) ;; if we have a count, better generate general code
(Null? rest-pat)
(or (Var? pat) (Dummy? pat)))
(make-And (list (make-Pred pred?) (make-App to-list (list pat))))]
[else (make-GSeq (list (list pat))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
rest-pat
mutable?)]))
;; stx : the syntax object for the whole pattern
;; parse : the pattern parser
;; struct-name : identifier
;; pats : syntax representing the member patterns
;; returns a pattern
(define (parse-struct stx parse struct-name pats)
(let* ([fail (lambda ()
(raise-syntax-error
'match (format "~a does not refer to a structure definition"
(syntax->datum struct-name))
stx struct-name))]
[v (syntax-local-value struct-name fail)])
(unless (struct-info? v) (fail))
(let-values ([(id _1 pred acc _2 super)
(apply values (extract-struct-info v))])
;; this produces a list of all the super-types of this struct
;; ending when it reaches the top of the hierarchy, or a struct that we
;; can't access
(define (get-lineage struct-name)
(let ([super (list-ref (extract-struct-info (syntax-local-value
struct-name))
5)])
(cond [(equal? super #t) (values #t '())] ;; no super type exists
[(equal? super #f) (values #f '())] ;; super type is unknown
[else
(let-values ([(complete? lineage) (get-lineage super)])
(values complete?
(cons super lineage)))])))
(unless pred
(raise-syntax-error 'match (format "structure ~a does not have an associated predicate"
(syntax->datum struct-name))
stx struct-name))
(let-values ([(complete? lineage) (get-lineage struct-name)])
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc]
[(not (car acc)) (cdr acc)]
[else acc])])
(make-Struct pred
(syntax-property
pred
'disappeared-use (list struct-name))
lineage (and (checked-struct-info? v) complete?)
acc
(cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)]
[(syntax->list pats)
=>
(lambda (ps)
(unless (= (length ps) (length acc))
(raise-syntax-error
'match
(format "~a structure ~a: expected ~a but got ~a"
"wrong number for fields for"
(syntax->datum struct-name) (length acc)
(length ps))
stx pats))
(map parse ps))]
[else (raise-syntax-error
'match
"improper syntax for struct pattern"
stx pats)])))))))
(define (trans-match pred transformer pat)
(make-And (list (make-Pred pred) (make-App transformer (list pat)))))
;; transform a match-expander application
;; parse : stx -> pattern
;; expander : identifier
;; stx : the syntax of the match-expander application (armed)
;; accessor : match-expander -> syntax transformer/#f
;; error-msg : string
;; produces a parsed pattern
(define (match-expander-transform parse expander stx accessor
error-msg)
(let* ([expander* (syntax-local-value expander)]
[transformer (accessor expander*)]
;; this transformer might have been defined w/ `syntax-id-rules'
[transformer (if (set!-transformer? transformer)
(set!-transformer-procedure transformer)
transformer)])
(unless transformer (raise-syntax-error #f error-msg expander*))
(let* ([introducer (make-syntax-introducer)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (if (procedure-arity-includes? transformer 2)
(transformer expander* mstx)
(transformer mstx))]
[result (syntax-local-introduce (introducer mresult))])
;(emit-local-step stx result #:id expander)
(parse result))))
;; raise an error, blaming stx
(define (match:syntax-err stx msg)
(raise-syntax-error #f msg stx))
;; pattern-var? : syntax -> bool
;; is p an identifier representing a pattern variable?
(define (pattern-var? p)
(and (identifier? p) (not (ddk? p))))
;; ddk? : syntax -> number or boolean
;; if #f is returned, was not a ddk identifier
;; if #t is returned, no minimum
;; if a number is returned, that's the minimum
(define (ddk? s*)
(define (./_ c) (or (equal? c #\.) (equal? c #\_)))
(let ([s (syntax->datum s*)])
(and (symbol? s)
(if (memq s '(... ___))
#t
(let* ([m (regexp-match #rx"^(?:\\.\\.|__)([0-9]+)$"
(symbol->string s))]
[n (and m (string->number (cadr m)))])
(cond [(not n) #f]
[(zero? n) #t]
[(exact-nonnegative-integer? n) n]
[else (raise-syntax-error
'match "invalid number for ..k pattern"
s*)]))))))
;; parse-literal : racket-val -> pat option
;; is v is a literal, return a pattern matching it
;; otherwise, return #f
(define (parse-literal v)
(if (or (number? v) (string? v) (keyword? v) (symbol? v) (bytes? v)
(regexp? v) (boolean? v) (char? v))
(make-Exact v)
#f))
;; (listof pat) syntax -> void
;; ps is never null
;; check that all the ps bind the same set of variables
(define (all-vars ps stx)
(let* ([first-vars (bound-vars (car ps))]
[l (length ps)]
[ht (make-free-identifier-mapping)])
(for ([v first-vars]) (free-identifier-mapping-put! ht v 1))
(for* ([p (cdr ps)]
[v (bound-vars p)])
(cond [(free-identifier-mapping-get ht v (lambda () #f))
=> (lambda (n)
(free-identifier-mapping-put! ht v (add1 n)))]
[else (raise-syntax-error 'match
"variable not bound in all or patterns"
stx v)]))
(free-identifier-mapping-for-each
ht
(lambda (v n)
(unless (= n l)
(raise-syntax-error 'match "variable not bound in all or patterns"
stx v))))))

75
whalesong/lang/private/match/parse-legacy.rkt
View File

@ -1,75 +0,0 @@
#lang racket/base
(require (for-template racket/base)
"patterns.rkt"
"parse-helper.rkt"
"parse-quasi.rkt")
(provide parse/legacy)
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define (parse/legacy stx)
(define (rearm new-stx) (syntax-rearm new-stx stx))
(define (parse stx) (parse/legacy (rearm stx)))
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case* disarmed-stx (not $ ? and or = quasiquote quote)
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
(and (identifier? #'expander)
(legacy-match-expander?
(syntax-local-value #'expander (λ () #f))))
(match-expander-transform
parse #'expander disarmed-stx legacy-match-expander-proc
"This expander only works with the standard match syntax")]
[(and p ...)
(make-And (map parse (syntax->list #'(p ...))))]
[(or)
(make-Not (make-Dummy stx))]
[(or p ps ...)
(let ([ps (map parse (syntax->list #'(p ps ...)))])
(all-vars ps stx)
(make-Or ps))]
[(not p ...)
;; nots are conjunctions of negations
(let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
(make-And ps))]
[bx
(box? (syntax-e #'bx))
(make-Box (parse (unbox (syntax-e #'bx))))]
[#(es ...)
(ormap ddk? (syntax->list #'(es ...)))
(make-And (list (make-Pred #'vector?)
(make-App #'vector->list
(list (parse (syntax/loc stx (es ...)))))))]
[#(es ...)
(make-Vector (map parse (syntax->list #'(es ...))))]
[($ s . pats)
(parse-struct disarmed-stx parse #'s #'pats)]
[(? p q1 qs ...)
(make-And (cons (make-Pred #'p)
(map parse (syntax->list #'(q1 qs ...)))))]
[(? p)
(make-Pred (rearm #'p))]
[(= f p)
(make-App #'f (list (parse #'p)))]
[(quasiquote p)
(parse-quasi #'p parse)]
[(quote . rest)
(parse-quote disarmed-stx parse)]
[() (make-Null (make-Dummy #f))]
[(..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(p .. . rest)
(ddk? #'..)
(dd-parse parse #'p #'.. #'rest #'list?)]
[(e . es)
(make-Pair (parse #'e) (parse (syntax/loc stx es)))]
[x
(identifier? #'x)
(parse-id #'x)]
[v
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "syntax error in pattern" stx))]))

87
whalesong/lang/private/match/parse-quasi.rkt
View File

@ -1,87 +0,0 @@
#lang racket/base
(require (for-template racket/base)
"patterns.rkt"
"parse-helper.rkt")
(provide parse-quasi)
;; is pat a pattern representing a list?
(define (null-terminated? pat)
(cond [(Pair? pat) (null-terminated? (Pair-d pat))]
[(GSeq? pat) (null-terminated? (GSeq-tail pat))]
[(Null? pat) #t]
[else #f]))
;; combine a null-terminated pattern with another pattern to match afterwards
(define (append-pats p1 p2)
(cond [(Pair? p1) (make-Pair (Pair-a p1) (append-pats (Pair-d p1) p2))]
[(GSeq? p1) (make-GSeq (GSeq-headss p1)
(GSeq-mins p1)
(GSeq-maxs p1)
(GSeq-onces? p1)
(append-pats (GSeq-tail p1) p2)
(GSeq-mutable? p1))]
[(Null? p1) p2]
[else (error 'match "illegal input to append-pats")]))
;; parse stx as a quasi-pattern
;; parse parses unquote
(define (parse-quasi stx parse)
(define (pq s) (parse-quasi s parse))
(syntax-case stx (quasiquote unquote quote unquote-splicing)
[(unquote p) (parse #'p)]
[((unquote-splicing p) . rest)
(let ([pat (parameterize ([in-splicing? #t]) (parse #'p))]
[rpat (pq #'rest)])
(if (null-terminated? pat)
(append-pats pat rpat)
(raise-syntax-error 'match "non-list pattern inside unquote-splicing"
stx #'p)))]
[(p dd . rest)
(ddk? #'dd)
;; FIXME: parameterize dd-parse so that it can be used here
(let* ([count (ddk? #'dd)]
[min (and (number? count) count)])
(make-GSeq
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (pq #'p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(pq #'rest)
#f))]
[(a . b) (make-Pair (pq #'a) (pq #'b))]
;; prefab structs
[struct
(prefab-struct-key (syntax-e #'struct))
(let ([key (prefab-struct-key (syntax-e #'struct))]
[pats (cdr (vector->list (struct->vector (syntax-e #'struct))))])
(make-And (list (make-Pred #`(struct-type-make-predicate (prefab-key->struct-type '#,key #,(length pats))))
(make-App #'struct->vector
(list (make-Vector (cons (make-Dummy #f) (map pq pats)))))))
#;
(make-PrefabStruct key (map pq pats)))]
;; the hard cases
[#(p ...)
(ormap (lambda (p)
(or (ddk? p)
(syntax-case p (unquote-splicing)
[(unquote-splicing . _) #t]
[_ #f])))
(syntax->list #'(p ...)))
(make-And (list (make-Pred #'vector?)
(make-App #'vector->list
(list (pq (quasisyntax/loc stx (p ...)))))))]
[#(p ...)
(make-Vector (map pq (syntax->list #'(p ...))))]
[bx
(box? (syntax-e #'bx))
(make-Box (pq (unbox (syntax-e #'bx))))]
[()
(make-Null (make-Dummy #f))]
[v
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "syntax error in quasipattern" stx))]))

184
whalesong/lang/private/match/parse.rkt
View File

@ -1,184 +0,0 @@
#lang racket/base
(require racket/struct-info
"patterns.rkt"
"parse-helper.rkt"
"parse-quasi.rkt"
(for-template (only-in "runtime.rkt" matchable? mlist? mlist->list)
racket/base))
(provide parse)
(define (ht-pat-transform p)
(syntax-case p ()
[(a b) #'(list a b)]
[x (identifier? #'x) #'x]))
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
;; parse : syntax -> Pat
;; compile stx into a pattern, using the new syntax
(define (parse stx)
(define (rearm new-stx) (syntax-rearm new-stx stx))
(define (rearm+parse new-stx) (parse (rearm new-stx)))
(define disarmed-stx (syntax-disarm stx orig-insp))
(syntax-case* disarmed-stx (not var struct box cons list vector ? and or quote app
regexp pregexp list-rest list-no-order hash-table
quasiquote mcons list* mlist)
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
(and (identifier? #'expander)
(match-expander? (syntax-local-value #'expander
(lambda () #f))))
(match-expander-transform
rearm+parse #'expander disarmed-stx match-expander-proc
"This expander only works with the legacy match syntax")]
[(var v)
(identifier? #'v)
(Var (rearm #'v))]
[(and p ...)
(And (map rearm+parse (syntax->list #'(p ...))))]
[(or)
(Not (Dummy stx))]
[(or p ps ...)
(let ([ps (map rearm+parse (syntax->list #'(p ps ...)))])
(all-vars ps stx)
(Or ps))]
[(not p ...)
;; nots are conjunctions of negations
(let ([ps (map (compose Not rearm+parse) (syntax->list #'(p ...)))])
(And ps))]
[(regexp r)
(trans-match #'matchable?
(rearm #'(lambda (e) (regexp-match r e)))
(Pred #'values))]
[(regexp r p)
(trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))]
[(pregexp r)
(trans-match #'matchable?
(rearm
#'(lambda (e)
(regexp-match (if (pregexp? r) r (pregexp r)) e)))
(Pred #'values))]
[(pregexp r p)
(trans-match #'matchable?
(rearm
#'(lambda (e)
(regexp-match (if (pregexp? r) r (pregexp r)) e)))
(rearm+parse #'p))]
[(box e) (Box (parse #'e))]
[(vector es ...)
(ormap ddk? (syntax->list #'(es ...)))
(trans-match #'vector?
#'vector->list
(rearm+parse (syntax/loc stx (list es ...))))]
[(vector es ...)
(Vector (map rearm+parse (syntax->list #'(es ...))))]
[(hash-table p ... dd)
(ddk? #'dd)
(trans-match
#'hash?
#'(lambda (e) (hash-map e list))
(with-syntax ([(elems ...)
(map ht-pat-transform (syntax->list #'(p ...)))])
(rearm+parse (syntax/loc stx (list-no-order elems ... dd)))))]
[(hash-table p ...)
(ormap ddk? (syntax->list #'(p ...)))
(raise-syntax-error
'match "dot dot k can only appear at the end of hash-table patterns" stx
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
[(hash-table p ...)
(trans-match #'hash?
#'(lambda (e) (hash-map e list))
(with-syntax ([(elems ...)
(map ht-pat-transform
(syntax->list #'(p ...)))])
(rearm+parse (syntax/loc stx (list-no-order elems ...)))))]
[(hash-table . _)
(raise-syntax-error 'match "syntax error in hash-table pattern" stx)]
[(list-no-order p ... lp dd)
(ddk? #'dd)
(let* ([count (ddk? #'dd)]
[min (if (number? count) count #f)]
[max (if (number? count) count #f)]
[ps (syntax->list #'(p ...))])
(GSeq (cons (list (rearm+parse #'lp))
(for/list ([p ps]) (list (parse p))))
(cons min (map (lambda _ 1) ps))
(cons max (map (lambda _ 1) ps))
;; vars in lp are lists, vars elsewhere are not
(cons #f (map (lambda _ #t) ps))
(Null (Dummy (syntax/loc stx _)))
#f))]
[(list-no-order p ...)
(ormap ddk? (syntax->list #'(p ...)))
(raise-syntax-error
'match "dot dot k can only appear at the end of unordered match patterns"
stx
(ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))]
[(list-no-order p ...)
(let ([ps (syntax->list #'(p ...))])
(GSeq (for/list ([p ps]) (list (rearm+parse p)))
(map (lambda _ 1) ps)
(map (lambda _ 1) ps)
;; all of these patterns get bound to only one thing
(map (lambda _ #t) ps)
(Null (Dummy (syntax/loc stx _)))
#f))]
[(list) (Null (Dummy (syntax/loc stx _)))]
[(mlist) (Null (Dummy (syntax/loc stx _)))]
[(list ..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(mlist ..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(list p .. . rest)
(ddk? #'..)
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'list?)]
[(mlist p .. . rest)
(ddk? #'..)
(dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'mlist? #:to-list #'mlist->list #:mutable #t)]
[(list e es ...)
(Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
[(mlist e es ...)
(MPair (rearm+parse #'e) (rearm+parse (syntax/loc stx (mlist es ...))))]
[(list* . rest)
(rearm+parse (syntax/loc stx (list-rest . rest)))]
[(list-rest e)
(rearm+parse #'e)]
[(list-rest p dd . rest)
(ddk? #'dd)
(dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)) #'list?)]
[(list-rest e . es)
(Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
[(cons e1 e2) (Pair (rearm+parse #'e1) (rearm+parse #'e2))]
[(mcons e1 e2) (MPair (rearm+parse #'e1) (rearm+parse #'e2))]
[(struct s pats)
(parse-struct disarmed-stx rearm+parse #'s #'pats)]
[(s . pats)
(and (identifier? #'s) (struct-info? (syntax-local-value #'s (lambda () #f))))
(parse-struct disarmed-stx rearm+parse #'s #'pats)]
[(? p q1 qs ...)
(OrderedAnd
(list (Pred (rearm #'p))
(And (map rearm+parse (syntax->list #'(q1 qs ...))))))]
[(? p)
(Pred (rearm #'p))]
[(app f ps ...) ;; only make a list for more than one pattern
(App #'f (map rearm+parse (syntax->list #'(ps ...))))]
[(quasiquote p)
(parse-quasi #'p rearm+parse)]
[(quasiquote . _)
(raise-syntax-error 'match "illegal use of quasiquote")]
[(quote . _)
(parse-quote disarmed-stx rearm+parse)]
[x
(identifier? #'x)
(parse-id (rearm #'x))]
[v
(or (parse-literal (syntax-e #'v))
(raise-syntax-error 'match "syntax error in pattern" disarmed-stx))]))
;; (trace parse)

212
whalesong/lang/private/match/patterns.rkt
View File

@ -1,212 +0,0 @@
#lang racket/base
(require syntax/boundmap
racket/contract
"stxtime.rkt"
(for-syntax racket/base))
(provide (except-out (combine-out
(all-defined-out)
(all-from-out "stxtime.rkt"))
struct-key-ht
get-key
(struct-out Row)))
(define orig-stx (make-parameter #f))
(define-struct Pat () #:transparent)
;; v is an identifier
(define-struct (Var Pat) (v)
#:transparent
#:property
prop:custom-write (lambda (v p w?)
(fprintf p "(Var ~a)" (syntax-e (Var-v v)))))
(define-struct (Dummy Var) ()
#:transparent
#:property
prop:custom-write (lambda (v p w?) (fprintf p "_")))
;; constructor patterns
(define-struct (CPat Pat) () #:transparent)
;; start is what index to start at
(define-struct (Vector CPat) (ps) #:transparent)
(define-struct (Pair CPat) (a d) #:transparent)
(define-struct (MPair CPat) (a d) #:transparent)
(define-struct (Box CPat) (p) #:transparent)
;; p is a pattern to match against the literal
(define-struct (Atom CPat) (p) #:transparent)
(define-struct (String Atom) () #:transparent)
(define-struct (Number Atom) () #:transparent)
(define-struct (Symbol Atom) () #:transparent)
(define-struct (Keyword Atom) () #:transparent)
(define-struct (Char Atom) () #:transparent)
(define-struct (Bytes Atom) () #:transparent)
(define-struct (Regexp Atom) () #:transparent)
(define-struct (Boolean Atom) () #:transparent)
(define-struct (Null Atom) () #:transparent)
;; expr is an expression
;; ps is a list of patterns
(define-struct (App Pat) (expr ps) #:transparent)
;; pred is an expression
(define-struct (Pred Pat) (pred) #:transparent)
;; pred is an identifier
;; super is an identifier, or #f
;; complete? is a boolean
;; accessors is a listof identifiers (NB in reverse order from the struct info)
;; ps is a listof patterns
(define-struct (Struct CPat) (id pred super complete? accessors ps) #:transparent)
;; both fields are lists of pats
(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)
;; ps are patterns
(define-struct (Or Pat) (ps) #:transparent)
(define-struct (And Pat) (ps) #:transparent)
(define-struct (OrderedAnd And) () #:transparent)
;; p is a pattern
(define-struct (Not Pat) (p) #:transparent)
;; headss : listof listof pattern
;; mins : listof option number
;; maxs : listof option number
;; onces? : listof boolean -- is this pattern being bound only once (take the
;; car of the variables)
;; tail : pattern
;; mutable? : is this for mutable lists?
(define-struct (GSeq Pat) (headss mins maxs onces? tail mutable?) #:transparent)
;; match with equal?
;; v is a quotable racket value
(define-struct (Exact Pat) (v) #:transparent)
;; pats is a Listof Pat
;; rhs is an expression
;; unmatch is an identifier
;; vars-seen is a listof identifiers
(define-struct Row (pats rhs unmatch vars-seen) #:transparent
#:property
prop:custom-write
(lambda (v p w?) (fprintf p "(Row ~a <expr>)" (Row-pats v))))
(define struct-key-ht (make-free-identifier-mapping))
(define (get-key id)
(free-identifier-mapping-get
struct-key-ht id
(lambda ()
(let ([k (box-immutable (syntax-e id))])
(free-identifier-mapping-put! struct-key-ht id k)
k))))
;; pat-key returns either an immutable box, or a symbol., or #f
;; the result is a box iff the argument was a struct pattern
;; (eq? (pat-key p) (pat-key q)) if p and q match the same constructor
;; the result is #f if p is not a constructor pattern
(define (pat-key p)
(cond [(Struct? p) (get-key (Struct-id p))]
[(Box? p) 'box]
[(Vector? p) 'vector]
[(Pair? p) 'pair]
[(MPair? p) 'mpair]
[(String? p) 'string]
[(Symbol? p) 'symbol]
[(Number? p) 'number]
[(Bytes? p) 'bytes]
[(Char? p) 'char]
[(Regexp? p) 'regexp]
[(Keyword? p) 'keyword]
[(Boolean? p) 'boolean]
[(Null? p) 'null]
[else #f]))
;; (require mzlib/trace)
;; (trace pat-key)
;; Row-first-pat : Row -> Pat
;; Row must not have empty list of pats
(define (Row-first-pat r)
(car (Row-pats r)))
(define (Row-split-pats r)
(define p (Row-pats r))
(values (car p) (cdr p)))
;; merge : (liftof (listof id)) -> (listof id)
;; merges lists of identifiers, removing module-identifier=? duplicates
(define (merge l)
(cond [(null? l) null]
[(null? (cdr l)) (car l)]
[else (let ([m (make-module-identifier-mapping)])
(for* ([ids l] [id ids])
(module-identifier-mapping-put! m id #t))
(module-identifier-mapping-map m (lambda (k v) k)))]))
;; bound-vars : Pat -> listof identifiers
(define (bound-vars p)
(cond
[(Dummy? p) null]
[(Pred? p) null]
[(Var? p)
(let ([v (Var-v p)])
(list (free-identifier-mapping-get (current-renaming) v (lambda () v))))]
[(Or? p)
(bound-vars (car (Or-ps p)))]
[(Box? p)
(bound-vars (Box-p p))]
[(Atom? p) null]
[(Pair? p)
(merge (list (bound-vars (Pair-a p)) (bound-vars (Pair-d p))))]
[(MPair? p)
(merge (list (bound-vars (MPair-a p)) (bound-vars (MPair-d p))))]
[(GSeq? p)
(merge (cons (bound-vars (GSeq-tail p))
(for/list ([pats (GSeq-headss p)])
(merge (for/list ([pat pats])
(bound-vars pat))))))]
[(Vector? p)
(merge (map bound-vars (Vector-ps p)))]
[(Struct? p)
(merge (map bound-vars (Struct-ps p)))]
[(App? p)
(merge (map bound-vars (App-ps p)))]
[(Not? p) null]
[(And? p)
(merge (map bound-vars (And-ps p)))]
[(Exact? p) null]
[else (error 'match "bad pattern: ~a" p)]))
(define current-renaming (make-parameter (make-free-identifier-mapping)))
(define (copy-mapping ht)
(define new-ht (make-free-identifier-mapping))
(free-identifier-mapping-for-each
ht (lambda (k v) (free-identifier-mapping-put! new-ht k v)))
new-ht)
#|
;; EXAMPLES
(define p-x (make-Var #'x))
(define p-y (make-Var #'y))
(define p-d (make-Dummy #'_))
(define p-cons (make-Pair p-x p-y))
(define p-vec (make-Vector (list p-x p-y p-d)))
(define r1 (make-Row (list p-x) #'#f #f null))
(define r2 (make-Row (list p-y) #'#f #f null))
(define r3 (make-Row (list p-cons) #'#f #f null))
(define r4 (make-Row (list p-vec p-d) #'#f #f null))
|#
(provide/contract (struct Row ([pats (listof Pat?)]
[rhs syntax?]
[unmatch (or/c identifier? false/c)]
[vars-seen (listof (cons/c identifier?
identifier?))])))

87
whalesong/lang/private/match/reorder.rkt
View File

@ -1,87 +0,0 @@
#lang racket/base
(require "patterns.rkt"
(for-syntax racket/base))
(provide reorder-columns)
#|
(define p-x (make-Var #'x))
(define p-y (make-Var #'y))
(define p-d (make-Dummy #'_))
(define p-cons (make-Pair p-x p-y))
(define p-vec (make-Vector (list p-x p-y p-d)))
(define r1 (make-Row (list p-x) #'#f #f null))
(define r2 (make-Row (list p-y) #'#f #f null))
(define r3 (make-Row (list p-cons) #'#f #f null))
(define r4 (make-Row (list p-vec p-d) #'#f #f null))
(define r5 (make-Row (list p-x p-y p-cons) #'1 #f null))
(define r6 (make-Row (list p-cons p-y p-vec) #'1 #f null))
|#
(define-sequence-syntax in-par
(lambda () (raise-syntax-error 'in-par "bad"))
(lambda (stx)
(syntax-case stx ()
[((id) (_ lst-exprs))
#'[(id)
(:do-in
;;outer bindings
([(lst) lst-exprs])
;; outer check
(void) ; (unless (list? lst) (in-list lst))
;; loop bindings
([lst lst])
;; pos check
(not (ormap null? lst))
;; inner bindings
([(id) (map car lst)])
;; pre guard
#t
;; post guard
#t
;; loop args
((map cdr lst)))]]
[_ (error 'no (syntax->datum stx))])))
(define (or-all? ps l)
(ormap (lambda (p) (andmap p l)) ps))
(define (count-while pred l)
(for/sum ([e (in-list l)] #:break (not (pred e))) 1))
(define (score col)
(define n (length col))
(define c (car col))
(define preds (list Var? Pair? Null?))
(cond [(or-all? preds col) (add1 n)]
[(andmap CPat? col) n]
[(Var? c) (count-while Var? col)]
[(Pair? c) (count-while Pair? col)]
[(Vector? c) (count-while Vector? col)]
[(Box? c) (count-while Box? col)]
[else 0]))
(define (reorder-by ps scores*)
(for/fold
([pats null])
([score-ref scores*])
(cons (list-ref ps score-ref) pats)))
(define (reorder-columns rows vars)
(define scores (for/list ([i (in-naturals)]
[column (in-par (map (compose Row-pats) rows))])
(cons i (score column))))
(define scores* (reverse (map car (sort scores > #:key cdr))))
(values
(for/list ([row rows])
(let ([ps (Row-pats row)])
(make-Row (reorder-by ps scores*)
(Row-rhs row)
(Row-unmatch row)
(Row-vars-seen row))))
(reorder-by vars scores*)))

72
whalesong/lang/private/match/runtime.rkt
View File

@ -1,72 +0,0 @@
#lang whalesong
(require "parameters.rkt") ; whalesong-libs
(require racket/stxparam
(for-syntax racket/base))
(provide match-equality-test
exn:misc:match?
match:error
fail
matchable?
match-prompt-tag
mlist? mlist->list)
(define match-prompt-tag (make-continuation-prompt-tag 'match))
; (define match-equality-test (make-parameter equal?))
; This is an parameter that a user of match can set in order
; to change the the equality operations used to determine
; if repeated uses of an identifier in a pattern has "equal" values.
; The default is equal?, so in the Whalesong matcher we just hardcode it.
(define match-equality-test (λ () equal?))
(define-struct (exn:misc:match exn:fail) (value srclocs)
#:property prop:exn:srclocs (lambda (ex) (exn:misc:match-srclocs ex)))
(define (match:error val srclocs form-name)
(raise (make-exn:misc:match (format "~a: no matching clause for ~e" form-name val)
(current-continuation-marks)
val
srclocs)))
(define-syntax-parameter fail
(lambda (stx)
(raise-syntax-error
#f "used out of context: not in match pattern" stx)))
;; can we pass this value to regexp-match?
(define (matchable? e)
(or (string? e)
; (bytes? e) ; [Whalesong] no byte strings
))
;; duplicated because we can't depend on `compatibility` here
(define mpair? pair?) ; [Whalesong] no mutable pairs
(define mcdr cdr) ; [Whalesong]
(define mcar car)
(define (mlist? l)
(cond
[(null? l) #t]
[(mpair? l)
(let loop ([turtle l][hare (mcdr l)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(let ([hare (mcdr hare)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(loop (mcdr turtle) (mcdr hare))]
[else #f]))]
[else #f]))]
[else #f]))
(define (mlist->list l)
(cond
[(null? l) null]
[else (cons (mcar l) (mlist->list (mcdr l)))]))

81
whalesong/lang/private/match/split-rows.rkt
View File

@ -1,81 +0,0 @@
#lang racket/base
(require "patterns.rkt")
(provide split-rows)
;; split-rows : Listof[Row] -> Listof[Listof[Row]]
;; takes a matrix, and returns a list of matrices
;; each returned matrix does not require the mixture rule to do compilation of
;; the first column.
(define (split-rows rows [acc null])
(define (loop/var matched-rows prev-mats rows)
(if (null? rows)
(reverse (cons (reverse matched-rows) prev-mats))
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond [(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))]
[(Var? p)
(loop/var (cons r matched-rows) prev-mats rs)]
[else
(split-rows rows (cons (reverse matched-rows) prev-mats))]))))
(define (loop/con matched-rows prev-mats struct-key rows)
(if (null? rows)
(reverse (cons (reverse matched-rows) prev-mats))
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond [(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))]
[(and (Struct? p) struct-key (eq? (pat-key p) struct-key))
;; (printf "struct-keys were equal: ~a\n" struct-key)
(loop/con (cons r matched-rows) prev-mats struct-key rs)]
[(and (Struct? p) (not struct-key))
;; (printf "no struct-key so far: ~a\n" struct-key)
(loop/con (cons r matched-rows) prev-mats (pat-key p) rs)]
[(and (CPat? p) (not (Struct? p)))
;; (printf "wasn't a struct: ~a\n" p)
(loop/con (cons r matched-rows) prev-mats struct-key rs)]
[else (split-rows rows (cons (reverse matched-rows)
prev-mats))]))))
(define (loop/exact matched-rows prev-mats rows)
(if (null? rows)
(reverse (cons (reverse matched-rows) prev-mats))
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond
[(Row-unmatch r)
(split-rows rows (cons (reverse matched-rows) prev-mats))]
[(Exact? p)
(loop/exact (cons r matched-rows) prev-mats rs)]
[else (split-rows rows (cons (reverse matched-rows) prev-mats))]))))
(if (null? rows)
(reverse acc)
(let* ([r (car rows)]
[p (Row-first-pat r)]
[rs (cdr rows)])
(cond [(Row-unmatch r)
(split-rows rs (cons (list r) acc))]
[(Var? p)
(loop/var (list r) acc rs)]
[(Exact? p)
(loop/exact (list r) acc rs)]
[(CPat? p)
(if (Struct? p)
(begin
;; (printf "found a struct: ~a\n" (pat-key r))
(loop/con (list r) acc (pat-key p) rs))
(loop/con (list r) acc #f rs))]
[else (split-rows rs (cons (list r) acc))]))))
;; (require mzlib/trace)
;; (trace split-rows)
;; EXAMPLES:
#|
(define mat1 (list r1 r2 r3))
(define mat2 (list r1 r3 r2 r1))
|#

80
whalesong/lang/private/match/struct.rkt
View File

@ -1,80 +0,0 @@
#lang whalesong
(require "match-expander.rkt"
(for-syntax racket/base
racket/struct-info
syntax/id-table
racket/list))
(define-match-expander
struct*
(lambda (stx)
(syntax-case stx ()
[(_ struct-name (field+pat ...))
(let* ([fail (lambda ()
(raise-syntax-error
'struct* "not a structure definition"
stx #'struct-name))]
[v (if (identifier? #'struct-name)
(syntax-local-value #'struct-name fail)
(fail))]
[field-acc->pattern (make-free-id-table)])
(unless (struct-info? v) (fail))
; Check each pattern and capture the field-accessor name
(for-each (lambda (an)
(syntax-case an ()
[(field pat)
(unless (identifier? #'field)
(raise-syntax-error
'struct* "not an identifier for field name"
stx #'field))
(let ([field-acc
(datum->syntax #'field
(string->symbol
(format "~a-~a"
(syntax-e #'struct-name)
(syntax-e #'field)))
#'field)])
(when (free-id-table-ref field-acc->pattern field-acc #f)
(raise-syntax-error 'struct* "Field name appears twice" stx #'field))
(free-id-table-set! field-acc->pattern field-acc #'pat))]
[_
(raise-syntax-error
'struct* "expected a field pattern of the form (<field-id> <pat>)"
stx an)]))
(syntax->list #'(field+pat ...)))
(let* (; Get the structure info
[acc (fourth (extract-struct-info v))]
;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(empty? acc) acc]
[(not (first acc)) (rest acc)]
[else acc])]
; Order the patterns in the order of the accessors
[pats-in-order
(for/list ([field-acc (in-list acc)])
(begin0
(free-id-table-ref
field-acc->pattern field-acc
(syntax/loc stx _))
; Use up pattern
(free-id-table-remove! field-acc->pattern field-acc)))])
; Check that all patterns were used
(free-id-table-for-each
field-acc->pattern
(lambda (field-acc pat)
(when pat
(raise-syntax-error 'struct* "field name not associated with given structure type"
stx field-acc))))
(quasisyntax/loc stx
(struct struct-name #,pats-in-order))))])))
(provide struct* ==)
(define-match-expander
==
(lambda (stx)
(syntax-case stx ()
[(_ val comp)
#'(? (lambda (x) (comp val x)))]
[(_ val) #'(? (lambda (x) (equal? val x)))])))

28
whalesong/lang/private/match/stxtime.rkt
View File

@ -1,28 +0,0 @@
#lang racket/base
(provide (all-defined-out))
(define match-...-nesting (make-parameter 0))
(struct acc-prop (n acc))
(define (make-struct-type-property/accessor name [guard #f] [supers null])
(define-values (p pred? acc)
(make-struct-type-property name
(λ (pval sinfo)
(cond [(exact-nonnegative-integer? pval)
(acc-prop pval (cadddr sinfo))]
[else (if (procedure? guard)
(guard pval sinfo)
pval)]))
supers))
(values p pred? (lambda (v)
(define v* (acc v))
(if (acc-prop? v*)
((acc-prop-acc v*) v (acc-prop-n v*))
v*))))
(define-values (prop:match-expander match-expander? match-expander-proc)
(make-struct-type-property/accessor 'prop:match-expander))
(define-values (prop:legacy-match-expander legacy-match-expander? legacy-match-expander-proc)
(make-struct-type-property/accessor 'prop:legacy-match-expander ))

16315
whalesong/lang/private/match/test-match.js
View File

File diff suppressed because one or more lines are too long

0
whalesong/lang/private/match/test-match_1.js
View File

2
whalesong/lang/private/shared.rkt
View File

@ -6,13 +6,13 @@
syntax/struct
racket/struct-info
scheme/include)
racket/undefined
"traced-app.rkt")
(provide shared)
(define-for-syntax code-insp (current-code-inspector))
(define undefined (letrec ([x x]) x))
(require (only-in "../kernel.rkt" [cons the-cons]))
(define-syntax shared

2
whalesong/parameters.rkt
View File

@ -88,7 +88,7 @@
(: current-report-port (Parameterof Output-Port))
(define current-report-port (make-parameter (current-error-port)))
(define current-report-port (make-parameter (current-output-port)))
(: current-timing-port (Parameterof Output-Port))

1
whalesong/parser/parse-bytecode-5.3.3.7.rkt
View File

@ -228,7 +228,6 @@
(make-ModuleLocator (rewrite-path resolved-path-name)
(normalize-path resolved-path-name))]
[else
(displayln (list 'wrap-module-name resolved-path-name rewritten-path))
(error 'wrap-module-name "Unable to resolve module path ~s."
resolved-path-name)]))]))

4
whalesong/scribblings/manual.scrbl
View File

@ -76,12 +76,12 @@ document lives in @url{http://hashcollision.org/whalesong}.}}
@centered{@smaller{Current commit head is @tt{@git-head}.}})
"")
@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@section{Introduction}
@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@defmodule[whalesong #:lang]
Whalesong is a compiler from Racket to JavaScript; it takes Racket
programs and translates them so that they can run stand-alone on a
user's web browser. It should allow Racket programs to run with

74
whalesong/selfhost/base64.rkt
View File

@ -1,74 +0,0 @@
#lang whalesong
(require whalesong/lang/for)
; Implements http://en.wikipedia.org/wiki/Base64
(provide base64-encode) ; string -> string
(define (bytes-ref bs i)
(define c (string-ref bs i))
(char->integer c))
(define (string->bytes s)
(for/list ([c (in-string s)])
(char->integer c)))
;
(define ranges '(["AZ" 0] ; 0 to 25
["az" 26] ; 16 to 51
["09" 52] ; 52 to 61
["++" 62] ; 62
["//" 63])) ; 63
; > (vector-ref base64-digit (char->integer #\A))
; 0
; > (vector-ref digit-base64 0)
; 65 (which is #\A)
(define-values (base64-digit digit-base64)
(let ([bd (make-vector 256 #f)]
[db (make-vector 64 #f)])
(for ([r ranges] #:when #t
[i (in-range (bytes-ref (car r) 0) (add1 (bytes-ref (car r) 1)))]
[n (in-naturals (cadr r))])
(vector-set! bd i n)
(vector-set! db n i))
(values bd db)))
(define (3bytes->24bit a b c)
; convert 3 bytes into a single 24 bit number
(+ (* a 65536) (* b 256) c))
(define (24bit->base64 n)
; convert a 24 bit number into base 64
(define a (remainder n 64))
(define n1 (quotient n 64))
(define b (remainder n1 64))
(define n2 (quotient n1 64))
(define c (remainder n2 64))
(define d (quotient n2 64))
(list d c b a))
(define =byte (bytes-ref "=" 0))
(define (base64-encode s)
(define sn (string-length s))
(define (encode s)
(define n sn)
(define ds
(for/list ([i (in-range 0 n 3)])
(define a (bytes-ref s i))
(define b (bytes-ref s (+ i 1)))
(define c (bytes-ref s (+ i 2)))
(for/list ([digit (24bit->base64 (3bytes->24bit a b c))])
(integer->char (vector-ref digit-base64 digit)))))
(define padding (case (remainder sn 3) [(0) 0] [(1) 2] [(2) 1]))
(define padding= (case (remainder sn 3) [(0) '()] [(1) (list #\= #\=)] [(2) (list #\=)]))
(define ds* (apply append ds))
(list->string (reverse (append padding= (drop (reverse ds*) padding)))))
(case (remainder sn 3)
[(0) (encode s)]
[(1) (encode (string-append s (string (integer->char 0) (integer->char 0))))]
[(2) (encode (string-append s (string (integer->char 0))))]))

45
whalesong/selfhost/compiler/analyzer-structs.rkt
View File

@ -1,45 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "arity-structs.rkt"
"expression-structs.rkt"
"lexical-structs.rkt"
"kernel-primitives.rkt"
"il-structs.rkt")
(provide (all-defined-out))
;; Static knowledge about an expression.
;;
;; We try to keep at compile time a mapping from environment positions to
;; statically known things, to generate better code.
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
(define-type CompileTimeEnvironmentEntry
(U '? ;; no knowledge
Prefix ;; placeholder: necessary since the toplevel lives in the environment too
StaticallyKnownLam ;; The value is a known lam
ModuleVariable ;; The value is a variable from a module
PrimitiveKernelValue
Const
))
(define-struct: StaticallyKnownLam ([name : (U Symbol LamPositionalName)]
[entry-point : Symbol]
[arity : Arity]) #:transparent)
(define-struct: Analysis ([ht : (HashTable Expression CompileTimeEnvironmentEntry)]))
(: empty-analysis (-> Analysis))
(define (empty-analysis)
(make-Analysis (make-hash)))

352
whalesong/selfhost/compiler/analyzer.rkt
View File

@ -1,352 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "expression-structs.rkt"
"analyzer-structs.rkt"
"arity-structs.rkt"
"lexical-structs.rkt"
"il-structs.rkt"
"compiler-structs.rkt"
; racket/list
)
(require "compiler-helper.rkt")
(provide collect-all-lambdas-with-bodies
collect-lam-applications
extract-static-knowledge
ensure-prefix)
;; Holds helper functions we use for different analyses.
;; Given a lambda body, collect all the applications that exist within
;; it. We'll use this to determine what procedures can safely be
;; transformed into primitives.
(: collect-lam-applications (Lam CompileTimeEnvironment -> (Listof CompileTimeEnvironmentEntry)))
(define (collect-lam-applications lam cenv)
(let loop
([exp (Lam-body lam)] ; : Expression
[cenv cenv] ; : CompileTimeEnvironment
[acc '()]) ; : (Listof CompileTimeEnvironmentEntry)
(cond
[(Top? exp)
(loop (Top-code exp)
(cons (Top-prefix exp) cenv)
acc)]
[(Module? exp)
(loop (Module-code exp)
(cons (Module-prefix exp) cenv)
acc)]
[(Constant? exp)
acc]
[(LocalRef? exp)
acc]
[(ToplevelRef? exp)
acc]
[(ToplevelSet? exp)
(loop (ToplevelSet-value exp) cenv acc)]
[(Branch? exp)
(define acc-1 (loop (Branch-predicate exp) cenv acc))
(define acc-2 (loop (Branch-consequent exp) cenv acc-1))
(define acc-3 (loop (Branch-alternative exp) cenv acc-2))
acc-3]
[(Lam? exp)
acc]
[(CaseLam? exp)
acc]
[(EmptyClosureReference? exp)
acc]
[(Seq? exp)
(foldl (lambda (e ; [e : Expression]
acc ; [acc : (Listof CompileTimeEnvironmentEntry)]
)
(loop e cenv acc))
acc
(Seq-actions exp))]
[(Splice? exp)
(foldl (lambda (e ; [e : Expression]
acc ; [acc : (Listof CompileTimeEnvironmentEntry)]
)
(loop e cenv acc))
acc
(Splice-actions exp))]
[(Begin0? exp)
(foldl (lambda (e ; [e : Expression]
acc ; [acc : (Listof CompileTimeEnvironmentEntry)]
)
(loop e cenv acc))
acc
(Begin0-actions exp))]
[(App? exp)
(define new-cenv
(append (build-list (length (App-operands exp)) (lambda (i #;[i : Natural]) '?))
cenv))
(foldl (lambda (e #;[e : Expression]
acc #;[acc : (Listof CompileTimeEnvironmentEntry)])
(loop e new-cenv acc))
(cons (extract-static-knowledge (App-operator exp) new-cenv)
(loop (App-operator exp) new-cenv acc))
(App-operands exp))]
[(Let1? exp)
(define acc-1 (loop (Let1-rhs exp) (cons '? cenv) acc))
(define acc-2 (loop (Let1-body exp)
(cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv))
cenv)
acc-1))
acc-2]
[(LetVoid? exp)
(loop (LetVoid-body exp)
(append (build-list (LetVoid-count exp) (lambda (i #;[i : Natural]) '?))
cenv)
acc)]
[(InstallValue? exp)
(loop (InstallValue-body exp) cenv acc)]
[(BoxEnv? exp)
(loop (BoxEnv-body exp) cenv acc)]
[(LetRec? exp)
(let ([n (length (LetRec-procs exp))])
(let ([new-cenv (append (map (lambda (p #;[p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda (i #;[i : Natural]) '?))
(drop cenv n))))
(LetRec-procs exp))
(drop cenv n))])
(loop (LetRec-body exp) new-cenv acc)))]
[(WithContMark? exp)
(define acc-1 (loop (WithContMark-key exp) cenv acc))
(define acc-2 (loop (WithContMark-value exp) cenv acc-1))
(define acc-3 (loop (WithContMark-body exp) cenv acc-2))
acc-3]
[(ApplyValues? exp)
(define acc-1 (loop (ApplyValues-proc exp) cenv acc))
(define acc-2 (loop (ApplyValues-args-expr exp) cenv acc-1))
acc-2]
[(DefValues? exp)
(loop (DefValues-rhs exp) cenv acc)]
[(PrimitiveKernelValue? exp)
acc]
[(VariableReference? exp)
(loop (VariableReference-toplevel exp) cenv acc)]
[(Require? exp)
acc])))
(: extract-static-knowledge (Expression CompileTimeEnvironment ->
CompileTimeEnvironmentEntry))
;; Statically determines what we know about the expression, given the compile time environment.
;; We should do more here eventually, including things like type inference or flow analysis, so that
;; we can generate better code.
(define (extract-static-knowledge exp cenv)
(cond
[(Lam? exp)
;(log-debug "known to be a lambda")
(make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp)
(if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp)))]
[(and (LocalRef? exp)
(not (LocalRef-unbox? exp)))
(let ([entry (list-ref cenv (LocalRef-depth exp))])
;(log-debug (format "known to be ~s" entry))
entry)]
[(EmptyClosureReference? exp)
(make-StaticallyKnownLam (EmptyClosureReference-name exp)
(EmptyClosureReference-entry-label exp)
(if (EmptyClosureReference-rest? exp)
(make-ArityAtLeast (EmptyClosureReference-num-parameters exp))
(EmptyClosureReference-num-parameters exp)))]
[(ToplevelRef? exp)
;(log-debug (format "toplevel reference of ~a" exp))
;(when (ToplevelRef-constant? exp)
; (log-debug (format "toplevel reference ~a should be known constant" exp)))
(let ([name ; : (U Symbol False GlobalBucket ModuleVariable)
(list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp))))
(ToplevelRef-pos exp))])
(cond
[(ModuleVariable? name)
;(log-debug (format "toplevel reference is to ~s" name))
name]
[(GlobalBucket? name)
'?]
[else
;(log-debug (format "nothing statically known about ~s" exp))
'?]))]
[(Constant? exp)
(make-Const (ensure-const-value (Constant-v exp)))]
[(PrimitiveKernelValue? exp)
exp]
[else
;(log-debug (format "nothing statically known about ~s" exp))
'?]))
(: collect-all-lambdas-with-bodies (Expression -> (Listof lam+cenv)))
;; Finds all the lambdas in the expression.
(define (collect-all-lambdas-with-bodies exp)
(let loop ; : (Listof lam+cenv)
([exp exp] ; : Expression
[cenv '()]) ; : CompileTimeEnvironment
(cond
[(Top? exp)
(loop (Top-code exp) (cons (Top-prefix exp) cenv))]
[(Module? exp)
(loop (Module-code exp) (cons (Module-prefix exp) cenv))]
[(Constant? exp)
'()]
[(LocalRef? exp)
'()]
[(ToplevelRef? exp)
'()]
[(ToplevelSet? exp)
(loop (ToplevelSet-value exp) cenv)]
[(Branch? exp)
(append (loop (Branch-predicate exp) cenv)
(loop (Branch-consequent exp) cenv)
(loop (Branch-alternative exp) cenv))]
[(Lam? exp)
(cons (make-lam+cenv exp (extract-lambda-cenv exp cenv))
(loop (Lam-body exp)
(extract-lambda-cenv exp cenv)))]
[(CaseLam? exp)
(cons (make-lam+cenv exp cenv)
(apply append (map (lambda (lam #;[lam : (U Lam EmptyClosureReference)])
(loop lam cenv))
(CaseLam-clauses exp))))]
[(EmptyClosureReference? exp)
'()]
[(Seq? exp)
(apply append (map (lambda (e #;[e : Expression]) (loop e cenv))
(Seq-actions exp)))]
[(Splice? exp)
(apply append (map (lambda (e #;[e : Expression]) (loop e cenv))
(Splice-actions exp)))]
[(Begin0? exp)
(apply append (map (lambda (e #;[e : Expression]) (loop e cenv))
(Begin0-actions exp)))]
[(App? exp)
(let ([new-cenv (append (build-list (length (App-operands exp)) (lambda (i #;[i : Natural]) '?))
cenv)])
(append (loop (App-operator exp) new-cenv)
(apply append (map (lambda (e #;[e : Expression]) (loop e new-cenv)) (App-operands exp)))))]
[(Let1? exp)
(append (loop (Let1-rhs exp)
(cons '? cenv))
(loop (Let1-body exp)
(cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv))
cenv)))]
[(LetVoid? exp)
(loop (LetVoid-body exp)
(append (build-list (LetVoid-count exp) (lambda (i #;[i : Natural]) '?))
cenv))]
[(InstallValue? exp)
(loop (InstallValue-body exp) cenv)]
[(BoxEnv? exp)
(loop (BoxEnv-body exp) cenv)]
[(LetRec? exp)
(let ([n (length (LetRec-procs exp))])
(let ([new-cenv (append (map (lambda (p #;[p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda (i #;[i : Natural]) '?))
(drop cenv n))))
(LetRec-procs exp))
(drop cenv n))])
(append (apply append
(map (lambda (lam #;[lam : Lam])
(loop lam new-cenv))
(LetRec-procs exp)))
(loop (LetRec-body exp) new-cenv))))]
[(WithContMark? exp)
(append (loop (WithContMark-key exp) cenv)
(loop (WithContMark-value exp) cenv)
(loop (WithContMark-body exp) cenv))]
[(ApplyValues? exp)
(append (loop (ApplyValues-proc exp) cenv)
(loop (ApplyValues-args-expr exp) cenv))]
[(DefValues? exp)
(append (loop (DefValues-rhs exp) cenv))]
[(PrimitiveKernelValue? exp)
'()]
[(VariableReference? exp)
(loop (VariableReference-toplevel exp) cenv)]
[(Require? exp)
'()]
[else (error 'here (list exp cenv))]
)))
(: extract-lambda-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment))
;; Given a Lam and the ambient environment, produces the compile time environment for the
;; body of the lambda.
(define (extract-lambda-cenv lam cenv)
(append (map (lambda (d #;[d : Natural])
(list-ref cenv d))
(Lam-closure-map lam))
(build-list (if (Lam-rest? lam)
(add1 (Lam-num-parameters lam))
(Lam-num-parameters lam))
(lambda (i #;[i : Natural]) '?))))
(: ensure-prefix (CompileTimeEnvironmentEntry -> Prefix))
(define (ensure-prefix x)
(if (Prefix? x)
x
(error 'ensure-prefix "Not a prefix: ~s" x)))

13
whalesong/selfhost/compiler/arity-structs.rkt
View File

@ -1,13 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide (all-defined-out))
;; Arity
(define-type Arity (U AtomicArity (Listof (U AtomicArity))))
(define-type AtomicArity (U Natural ArityAtLeast))
(define-struct ArityAtLeast (value) #:transparent)
; (define-predicate AtomicArity? AtomicArity)
(define (AtomicArity? o) (or (natural? o) (ArityAtLeast? o)))
; (define-predicate listof-atomic-arity? (Listof AtomicArity))
(define (listof-atomic-arity? o)
(and (list? o) (andmap AtomicArity? o)))

346
whalesong/selfhost/compiler/bootstrapped-primitives.rkt
View File

@ -1,346 +0,0 @@
#lang typed/racket/base
(require "arity-structs.rkt"
"expression-structs.rkt"
"lexical-structs.rkt"
"il-structs.rkt"
(except-in "compiler.rkt" compile)
"compiler-structs.rkt")
(require (rename-in "compiler.rkt"
[compile whalesong-compile]))
(require/typed "../parameters.rkt"
(current-defined-name (Parameterof (U Symbol LamPositionalName))))
(require/typed "../parser/parse-bytecode.rkt"
(parse-bytecode (Compiled-Expression -> Expression)))
(provide get-bootstrapping-code)
;; The primitive code necessary to do call/cc
(: call/cc-label Symbol)
(define call/cc-label 'callCCEntry)
(define call/cc-closure-entry 'callCCClosureEntry)
;; (call/cc f)
;; Tail-calls f, providing it a special object that knows how to do the low-level
;; manipulation of the environment and control stack.
(define (make-call/cc-code)
(statements
(append-instruction-sequences
call/cc-label
;; Precondition: the environment holds the f function that we want to jump into.
;; First, move f to the proc register
(make-AssignImmediate 'proc (make-EnvLexicalReference 0 #f))
;; Next, capture the envrionment and the current continuation closure,.
(make-PushEnvironment 2 #f)
(make-AssignPrimOp (make-EnvLexicalReference 0 #f)
(make-CaptureControl 0 default-continuation-prompt-tag))
(make-AssignPrimOp (make-EnvLexicalReference 1 #f)
;; When capturing, skip over f and the two slots we just added.
(make-CaptureEnvironment 3 default-continuation-prompt-tag))
(make-AssignPrimOp (make-EnvLexicalReference 2 #f)
(make-MakeCompiledProcedure call/cc-closure-entry
1 ;; the continuation consumes a single value
(list 0 1)
'call/cc))
(make-PopEnvironment (make-Const 2)
(make-Const 0))
;; Finally, do a tail call into f.
(make-AssignImmediate 'argcount (make-Const 1))
(compile-general-procedure-call '()
(make-Const 1) ;; the stack at this point holds a single argument
'val
return-linkage)
;; The code for the continuation code follows. It's supposed to
;; abandon the current continuation, initialize the control and environment, and then jump.
call/cc-closure-entry
(make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
(make-Perform (make-InstallClosureValues! 2))
(make-Perform (make-RestoreControl! default-continuation-prompt-tag))
(make-Perform (make-RestoreEnvironment!))
(make-AssignImmediate 'proc (make-ControlStackLabel))
(make-PopControlFrame)
(make-Goto (make-Reg 'proc)))))
(: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
;; Generates the bootstrapped code for some of the primitives. Note: the source must compile
;; under #%kernel, or else!
(define make-bootstrapped-primitive-code
(let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns]) (namespace-require ''#%kernel))
(lambda (name src)
(parameterize ([current-defined-name name])
(append
(whalesong-compile (parameterize ([current-namespace ns])
(parse-bytecode (compile src)))
(make-PrimitivesReference name) next-linkage/drop-multiple))))))
(: make-map-src (Symbol Symbol -> Any))
;; Generates the code for map.
(define (make-map-src name combiner)
`(letrec-values ([(first-tuple) (lambda (lists)
(if (null? lists)
'()
(cons (car (car lists))
(first-tuple (cdr lists)))))]
[(rest-lists) (lambda (lists)
(if (null? lists)
'()
(cons (cdr (car lists))
(rest-lists (cdr lists)))))]
[(all-empty?) (lambda (lists)
(if (null? lists)
#t
(if (null? (car lists))
(all-empty? (cdr lists))
#f)))]
[(some-empty?) (lambda (lists)
(if (null? lists)
#f
(if (null? (car lists))
#t
(some-empty? (cdr lists)))))]
[(do-it) (lambda (f lists)
(letrec-values ([(loop) (lambda (lists)
(if (all-empty? lists)
null
(if (some-empty? lists)
(error
',name
"all lists must have the same size")
(,combiner (apply f (first-tuple lists))
(loop (rest-lists lists))))))])
(loop lists)))])
(lambda (f . args)
(do-it f args))))
(: get-bootstrapping-code (-> (Listof Statement)))
(define (get-bootstrapping-code)
(append
;; Other primitives
(make-bootstrapped-primitive-code
'map
(make-map-src 'map 'cons))
(make-bootstrapped-primitive-code
'for-each
(make-map-src 'for-each 'begin))
(make-bootstrapped-primitive-code
'andmap
(make-map-src 'andmap 'and))
(make-bootstrapped-primitive-code
'ormap
(make-map-src 'ormap 'or))
(make-bootstrapped-primitive-code
'caar
'(lambda (x)
(car (car x))))
(make-bootstrapped-primitive-code
'memq
'(letrec-values ([(memq) (lambda (x l)
(if (null? l)
#f
(if (eq? x (car l))
l
(memq x (cdr l)))))])
memq))
(make-bootstrapped-primitive-code
'memv
'(letrec-values ([(memv) (lambda (x l)
(if (null? l)
#f
(if (eqv? x (car l))
l
(memv x (cdr l)))))])
memv))
(make-bootstrapped-primitive-code
'memf
'(letrec-values ([(memf) (lambda (x f l)
(if (null? l)
#f
(if (f x)
l
(memf x f (cdr l)))))])
memf))
(make-bootstrapped-primitive-code
'assq
'(letrec-values ([(assq) (lambda (x l)
(if (null? l)
#f
(if (eq? x (caar l))
(car l)
(assq x (cdr l)))))])
assq))
(make-bootstrapped-primitive-code
'assv
'(letrec-values ([(assv) (lambda (x l)
(if (null? l)
#f
(if (eqv? x (caar l))
(car l)
(assv x (cdr l)))))])
assv))
(make-bootstrapped-primitive-code
'assoc
'(letrec-values ([(assoc) (lambda (x l)
(if (null? l)
#f
(if (equal? x (caar l))
(car l)
(assoc x (cdr l)))))])
assoc))
(make-bootstrapped-primitive-code
'length
'(letrec-values ([(length-iter) (lambda (l i)
(if (null? l)
i
(length-iter (cdr l) (add1 i))))])
(lambda (l) (length-iter l 0))))
(make-bootstrapped-primitive-code
'append
'(letrec-values ([(append-many) (lambda (lsts)
(if (null? lsts)
null
(if (null? (cdr lsts))
(car lsts)
(append-2 (car lsts)
(append-many (cdr lsts))))))]
[(append-2) (lambda (l1 l2)
(if (null? l1)
l2
(cons (car l1) (append-2 (cdr l1) l2))))])
(lambda args (append-many args))))
(make-bootstrapped-primitive-code
'call-with-values
'(lambda (producer consumer)
(call-with-values (lambda () (producer)) consumer)))
;; The call/cc code is special:
(let ([after-call/cc-code (make-label 'afterCallCCImplementation)])
(append
`(,(make-AssignPrimOp (make-PrimitivesReference 'call/cc)
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-AssignPrimOp (make-PrimitivesReference 'call-with-current-continuation)
(make-MakeCompiledProcedure call/cc-label 1 '() 'call/cc))
,(make-Goto (make-Label after-call/cc-code)))
(make-call/cc-code)
`(,after-call/cc-code)))
;; values
;; values simply keeps all (but the first) value on the stack, preserves the argcount, and does a return
;; to the multiple-value-return address.
(let ([after-values-body-defn (make-label 'afterValues)]
[values-entry (make-label 'valuesEntry)]
[on-zero-values (make-label 'onZeroValues)]
[on-single-value (make-label 'onSingleValue)])
`(,(make-Goto (make-Label after-values-body-defn))
,values-entry
,(make-TestAndJump (make-TestOne (make-Reg 'argcount)) on-single-value)
,(make-TestAndJump (make-TestZero (make-Reg 'argcount)) on-zero-values)
;; Common case: we're running multiple values. Put the first in the val register
;; and go to the multiple value return.
,(make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
,(make-AssignImmediate 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-PopControlFrame)
,(make-Goto (make-Reg 'proc))
;; Special case: on a single value, just use the regular return address
,on-single-value
,(make-AssignImmediate 'val (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
,(make-AssignImmediate 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-Goto (make-Reg 'proc))
;; On zero values, leave things be and just return.
,on-zero-values
,(make-AssignImmediate 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-PopControlFrame)
,(make-Goto (make-Reg 'proc))
,after-values-body-defn
,(make-AssignPrimOp (make-PrimitivesReference 'values)
(make-MakeCompiledProcedure values-entry
(make-ArityAtLeast 0)
'()
'values))))
;; As is apply:
(let ([after-apply-code (make-label 'afterApplyCode)]
[apply-entry (make-label 'applyEntry)])
`(,(make-Goto (make-Label after-apply-code))
,apply-entry
;; Push the procedure into proc.
,(make-AssignImmediate 'proc (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
;; Correct the number of arguments to be passed.
,(make-AssignImmediate 'argcount (make-SubtractArg (make-Reg 'argcount)
(make-Const 1)))
;; Splice in the list argument.
,(make-Perform (make-SpliceListIntoStack! (make-SubtractArg (make-Reg 'argcount)
(make-Const 1))))
;; Finally, jump into the procedure body
,@(statements (compile-general-procedure-call '()
(make-Reg 'argcount) ;; the stack contains only the argcount elements.
'val
return-linkage))
,after-apply-code
,(make-AssignPrimOp (make-PrimitivesReference 'apply)
(make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply))))))

38
whalesong/selfhost/compiler/compiler-helper.rkt
View File

@ -1,38 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide ensure-const-value)
(define (ensure-const-value x)
(cond
[(symbol? x)
x]
[(boolean? x)
x]
[(string? x)
x]
[(number? x)
x]
[(void? x)
x]
[(null? x)
x]
[(char? x)
x]
[(bytes? x)
x]
[(path? x)
x]
[(pair? x)
(begin (ensure-const-value (car x))
(ensure-const-value (cdr x))
x)]
[(vector? x)
(begin (for-each ensure-const-value (vector->list x)))
x]
[(box? x)
(ensure-const-value (unbox x))
x]
[else
(error 'ensure-const-value "Not a const value: ~s\n" x)]))

47
whalesong/selfhost/compiler/compiler-structs.rkt
View File

@ -1,47 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "expression-structs.rkt"
"analyzer-structs.rkt")
(provide (all-defined-out))
;; A ValuesContext describes if a context either
;; * accepts any number multiple values by dropping them from the stack.
;; * accepts any number of multiple values by maintaining them on the stack.
;; * accepts exactly n values, erroring out
(define-type ValuesContext (U 'tail
'drop-multiple
'keep-multiple
Natural))
;; Linkage
(define-struct: NextLinkage ([context : ValuesContext]))
(define next-linkage/drop-multiple (make-NextLinkage 'drop-multiple))
(define next-linkage/expects-single (make-NextLinkage 1))
(define next-linkage/keep-multiple-on-stack (make-NextLinkage 'keep-multiple))
;; LabelLinkage is a labeled GOTO.
(define-struct: LabelLinkage ([label : Symbol]
[context : ValuesContext]))
;; Both ReturnLinkage and ReturnLinkage/NonTail deal with multiple
;; values indirectly, through the alternative multiple-value-return
;; address in the LinkedLabel of their call frame.
(define-struct: ReturnLinkage ([tail? : Boolean]))
(define return-linkage (make-ReturnLinkage #t))
(define return-linkage/nontail (make-ReturnLinkage #f))
(define-type Linkage (U NextLinkage
LabelLinkage
ReturnLinkage))
;; Lambda and compile-time environment
(define-struct: lam+cenv ([lam : (U Lam CaseLam)]
[cenv : CompileTimeEnvironment]))

2392
whalesong/selfhost/compiler/compiler.rkt
View File

File diff suppressed because it is too large Load Diff

173
whalesong/selfhost/compiler/expression-structs.rkt
View File

@ -1,173 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "lexical-structs.rkt")
(provide (all-defined-out))
;; Expressions
(define-type Expression (U
Top
Constant
ToplevelRef
LocalRef
ToplevelSet
Branch
Lam
CaseLam
EmptyClosureReference
Seq
Splice
Begin0
App
Let1
LetVoid
LetRec
InstallValue
BoxEnv
WithContMark
ApplyValues
DefValues
PrimitiveKernelValue
Module
VariableReference
Require))
(define-struct: Module ([name : Symbol]
[path : ModuleLocator]
[prefix : Prefix]
[requires : (Listof ModuleLocator)]
[provides : (Listof ModuleProvide)]
[code : Expression])
#:transparent)
(define-struct: ModuleProvide ([internal-name : Symbol]
[external-name : Symbol]
[source : ModuleLocator])
#:transparent)
(define-struct: Top ([prefix : Prefix]
[code : Expression]) #:transparent)
(define-struct: Constant ([v : Any]) #:transparent)
(define-struct: ToplevelRef ([depth : Natural]
[pos : Natural]
[constant? : Boolean]
[check-defined? : Boolean]) #:transparent)
(define-struct: LocalRef ([depth : Natural]
[unbox? : Boolean]) #:transparent)
(define-struct: ToplevelSet ([depth : Natural]
[pos : Natural]
[value : Expression]) #:transparent)
(define-struct: Branch ([predicate : Expression]
[consequent : Expression]
[alternative : Expression]) #:transparent)
(define-struct: CaseLam ([name : (U Symbol LamPositionalName)]
[clauses : (Listof (U Lam EmptyClosureReference))]
[entry-label : Symbol]) #:transparent)
(define-struct: Lam ([name : (U Symbol LamPositionalName)]
[num-parameters : Natural]
[rest? : Boolean]
[body : Expression]
[closure-map : (Listof Natural)]
[entry-label : Symbol]) #:transparent)
;; An EmptyClosureReference has enough information to create the lambda value,
;; assuming that the lambda's body has already been compiled. The entry-label needs
;; to have been shared with an existing Lam, and the closure must be empty.
(define-struct: EmptyClosureReference ([name : (U Symbol LamPositionalName)]
[num-parameters : Natural]
[rest? : Boolean]
[entry-label : Symbol]) #:transparent)
;; We may have more information about the lambda's name. This will show it.
(define-struct: LamPositionalName ([name : Symbol]
[path : String] ;; the source of the name
[line : Natural]
[column : Natural]
[offset : Natural]
[span : Natural]) #:transparent)
(define-struct: Seq ([actions : (Listof Expression)]) #:transparent)
(define-struct: Splice ([actions : (Listof Expression)]) #:transparent)
(define-struct: Begin0 ([actions : (Listof Expression)]) #:transparent)
(define-struct: App ([operator : Expression]
[operands : (Listof Expression)]) #:transparent)
(define-struct: Let1 ([rhs : Expression]
[body : Expression]) #:transparent)
(define-struct: LetVoid ([count : Natural]
[body : Expression]
[boxes? : Boolean]) #:transparent)
;; During evaluation, the closures corresponding to procs are expected
;; to be laid out so that stack position 0 corresponds to procs[0],
;; stack position 1 to procs[1], and so on.
(define-struct: LetRec ([procs : (Listof Lam)]
[body : Expression]) #:transparent)
(define-struct: InstallValue ([count : Natural] ;; how many values to install
[depth : Natural] ;; how many slots to skip
[body : Expression]
[box? : Boolean]) #:transparent)
(define-struct: BoxEnv ([depth : Natural]
[body : Expression]) #:transparent)
(define-struct: WithContMark ([key : Expression]
[value : Expression]
[body : Expression]) #:transparent)
(define-struct: ApplyValues ([proc : Expression]
[args-expr : Expression]) #:transparent)
;; Multiple value definition
(define-struct: DefValues ([ids : (Listof ToplevelRef)]
[rhs : Expression]) #:transparent)
(define-struct: PrimitiveKernelValue ([id : Symbol]) #:transparent)
(define-struct: VariableReference ([toplevel : ToplevelRef]) #:transparent)
(define-struct: Require ([path : ModuleLocator]) #:transparent)
(: current-short-labels? (Parameterof Boolean))
(define current-short-labels? (make-parameter #t))
(: make-label (Symbol -> Symbol))
(define make-label
(let ([n 0])
(lambda (l)
(set! n (add1 n))
(if (current-short-labels?)
(string->symbol (format "_~a" n))
(string->symbol (format "~a~a" l n))))))

666
whalesong/selfhost/compiler/il-structs.rkt
View File

@ -1,666 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide (all-defined-out))
(require "expression-structs.rkt"
"lexical-structs.rkt"
"kernel-primitives.rkt"
"arity-structs.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Registers of the machine:
(define-type StackRegisterSymbol (U 'control 'env))
(define-type AtomicRegisterSymbol (U 'val 'proc 'argcount))
(define-type RegisterSymbol (U StackRegisterSymbol AtomicRegisterSymbol))
;(define-predicate AtomicRegisterSymbol? AtomicRegisterSymbol)
(define (AtomicRegisterSymbol? o)
(or (eq? o 'control) (eq? o 'env)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; An operation can refer to the following arguments:
(define-type OpArg (U Const ;; an constant
Label ;; an label
Reg ;; an register
EnvLexicalReference ;; a reference into the stack
EnvPrefixReference ;; a reference into an element in the toplevel.
EnvWholePrefixReference ;; a reference into a toplevel prefix in the stack.
SubtractArg
ControlStackLabel
ControlStackLabel/MultipleValueReturn
ControlFrameTemporary
CompiledProcedureEntry
CompiledProcedureClosureReference
ModuleEntry
ModulePredicate
PrimitiveKernelValue
VariableReference
))
(define (OpArg? o)
(or (Const? o) ;; an constant
(Label? o) ;; an label
(Reg? o) ;; an register
(EnvLexicalReference? o) ;; a reference into the stack
(EnvPrefixReference? o) ;; a reference into an element in the toplevel.
(EnvWholePrefixReference? o) ;; a reference into a toplevel prefix in the stack.
(SubtractArg? o)
(ControlStackLabel? o)
(ControlStackLabel/MultipleValueReturn? o)
(ControlFrameTemporary? o)
(CompiledProcedureEntry? o)
(CompiledProcedureClosureReference? o)
(ModuleEntry? o)
(ModulePredicate? o)
(PrimitiveKernelValue? o)
(VariableReference? o)))
;; Targets: these are the allowable lhs's for a targetted assignment.
(define-type Target (U AtomicRegisterSymbol
EnvLexicalReference
EnvPrefixReference
PrimitivesReference
GlobalsReference
ControlFrameTemporary
ModulePrefixTarget
))
(define-struct: ModuleVariableThing () #:transparent)
;; When we need to store a value temporarily in the top control frame, we can use this as a target.
(define-struct: ControlFrameTemporary ([name : (U 'pendingContinuationMarkKey ;; for continuation marks
'pendingApplyValuesProc ;; for apply-values
'pendingBegin0Count
'pendingBegin0Values
)])
#:transparent)
;; Targetting the prefix attribute of a module.
(define-struct: ModulePrefixTarget ([path : ModuleLocator])
#:transparent)
(define-struct: ModuleVariableReference ([name : Symbol]
[module-name : ModuleLocator])
#:transparent)
(define-type const-value
(Rec C
(U Symbol
String
Number
Boolean
Void
Null
Char
Bytes
Path
(Pairof C C)
(Vectorof C)
(Boxof C))))
(define-struct: Label ([name : Symbol])
#:transparent)
(define-struct: Reg ([name : AtomicRegisterSymbol])
#:transparent)
(define-struct: Const ([const : const-value])
#:transparent)
;; Limited arithmetic on OpArgs
(define-struct: SubtractArg ([lhs : OpArg]
[rhs : OpArg])
#:transparent)
(: new-SubtractArg (OpArg OpArg -> OpArg))
(define (new-SubtractArg lhs rhs)
;; FIXME: do some limited constant folding here
(cond
[(and (Const? lhs)(Const? rhs))
(let ([lhs-val (Const-const lhs)]
[rhs-val (Const-const rhs)])
(cond [(and (number? lhs-val)
(number? rhs-val))
(make-Const (- lhs-val rhs-val))]
[else
(make-SubtractArg lhs rhs)]))]
[(Const? rhs)
(let ([rhs-val (Const-const rhs)])
(cond
[(and (number? rhs-val)
(= rhs-val 0))
lhs]
[else
(make-SubtractArg lhs rhs)]))]
[else
(make-SubtractArg lhs rhs)]))
;; Gets the return address embedded at the top of the control stack.
(define-struct: ControlStackLabel ()
#:transparent)
;; Gets the secondary (mulitple-value-return) return address embedded
;; at the top of the control stack.
(define-struct: ControlStackLabel/MultipleValueReturn ()
#:transparent)
;; Get the entry point of a compiled procedure.
(define-struct: CompiledProcedureEntry ([proc : OpArg])
#:transparent)
;; Get at the nth value in a closure's list of closed values.
(define-struct: CompiledProcedureClosureReference ([proc : OpArg]
[n : Natural])
#:transparent)
(define-struct: PrimitivesReference ([name : Symbol])
#:transparent)
(define-struct: GlobalsReference ([name : Symbol])
#:transparent)
;; Produces the entry point of the module.
(define-struct: ModuleEntry ([name : ModuleLocator])
#:transparent)
(define-struct: ModulePredicate ([module-name : ModuleLocator]
[pred : (U 'invoked? 'linked?)])
#:transparent)
;; A straight-line statement includes non-branching stuff.
(define-type StraightLineStatement (U
DebugPrint
Comment
MarkEntryPoint
AssignImmediate
AssignPrimOp
Perform
PopEnvironment
PushEnvironment
PushImmediateOntoEnvironment
PushControlFrame/Generic
PushControlFrame/Call
PushControlFrame/Prompt
PopControlFrame))
(define (StraightLineStatement? o)
(or (DebugPrint? o)
(Comment? o)
(MarkEntryPoint? o)
(AssignImmediate? o)
(AssignPrimOp? o)
(Perform? o)
(PopEnvironment? o)
(PushEnvironment? o)
(PushImmediateOntoEnvironment? o)
(PushControlFrame/Generic? o)
(PushControlFrame/Call? o)
(PushControlFrame/Prompt? o)
(PopControlFrame? o)))
(define-type BranchingStatement (U Goto TestAndJump))
(define (BranchingStatement? o) (or (Goto? o) (TestAndJump? o)))
;; instruction sequences
(define-type UnlabeledStatement (U StraightLineStatement BranchingStatement))
; (define-predicate UnlabeledStatement? UnlabeledStatement)
(define (UnlabeledStatement? o) (or (StraightLineStatement? o) (BranchingStatement? o)))
;; Debug print statement.
(define-struct: DebugPrint ([value : OpArg])
#:transparent)
(define-type Statement (U UnlabeledStatement
Symbol ;; label
LinkedLabel ;; Label with a reference to a multiple-return-value label
))
(define (Statement? o)
(or (UnlabeledStatement? o)
(symbol? o)
(LinkedLabel? o)))
(define-struct: LinkedLabel ([label : Symbol]
[linked-to : Symbol])
#:transparent)
;; Returns a pair of labels, the first being the mutiple-value-return
;; label and the second its complementary single-value-return label.
(: new-linked-labels (Symbol -> (Values Symbol LinkedLabel)))
(define (new-linked-labels sym)
(define a-label-multiple (make-label (string->symbol (format "~aMultiple" sym))))
(define a-label (make-LinkedLabel (make-label sym) a-label-multiple))
(values a-label-multiple a-label))
;; FIXME: it would be nice if I can reduce AssignImmediate and
;; AssignPrimOp into a single Assign statement, but I run into major
;; issues with Typed Racket taking minutes to compile. So we're
;; running into some kind of degenerate behavior.
(define-struct: AssignImmediate ([target : Target]
[value : OpArg])
#:transparent)
(define-struct: AssignPrimOp ([target : Target]
[op : PrimitiveOperator])
#:transparent)
;; Pop n slots from the environment, skipping past a few first.
(define-struct: PopEnvironment ([n : OpArg]
[skip : OpArg])
#:transparent)
(define-struct: PushEnvironment ([n : Natural]
[unbox? : Boolean])
#:transparent)
;; Evaluate the value, and then push it onto the top of the environment.
(define-struct: PushImmediateOntoEnvironment ([value : OpArg]
[box? : Boolean])
#:transparent)
(define-struct: PopControlFrame ()
#:transparent)
;; A generic control frame only holds marks and other temporary variables.
(define-struct: PushControlFrame/Generic ()
#:transparent)
;; Adding a frame for getting back after procedure application.
;; The 'proc register must hold either #f or a closure at the time of
;; this call, as the control frame will hold onto the called procedure record.
(define-struct: PushControlFrame/Call ([label : LinkedLabel])
#:transparent)
(define-struct: PushControlFrame/Prompt
([tag : (U OpArg DefaultContinuationPromptTag)]
[label : LinkedLabel])
#:transparent)
(define-struct: DefaultContinuationPromptTag ()
#:transparent)
(define default-continuation-prompt-tag
(make-DefaultContinuationPromptTag))
(define-struct: Goto ([target : (U Label
Reg
ModuleEntry
CompiledProcedureEntry)])
#:transparent)
(define-struct: Perform ([op : PrimitiveCommand])
#:transparent)
(define-struct: TestAndJump ([op : PrimitiveTest]
[label : Symbol])
#:transparent)
(define-struct: Comment ([val : Any])
#:transparent)
;; Marks the head of every lambda.
(define-struct: MarkEntryPoint ([label : Symbol])
#:transparent)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Primitive Operators
;; The operators that return values, that are used in AssignPrimopStatement.
;; The reason this is here is really to get around what looks like a Typed Racket issue.
;; I would prefer to move these all to OpArgs, but if I do, Typed Racket takes much longer
;; to type my program than I'd like.
(define-type PrimitiveOperator (U GetCompiledProcedureEntry
MakeCompiledProcedure
MakeCompiledProcedureShell
ModuleVariable
PrimitivesReference
GlobalsReference
MakeBoxedEnvironmentValue
CaptureEnvironment
CaptureControl
CallKernelPrimitiveProcedure
ApplyPrimitiveProcedure
))
;; Gets the label from the closure stored in the 'proc register and returns it.
(define-struct: GetCompiledProcedureEntry ()
#:transparent)
;; Constructs a closure, given the label, # of expected arguments,
;; and the set of lexical references into the environment that the
;; closure needs to close over.
(define-struct: MakeCompiledProcedure ([label : Symbol]
[arity : Arity]
[closed-vals : (Listof Natural)]
[display-name : (U Symbol LamPositionalName)])
#:transparent)
;; Constructs a closure shell. Like MakeCompiledProcedure, but doesn't
;; bother with trying to capture the free variables.
(define-struct: MakeCompiledProcedureShell ([label : Symbol]
[arity : Arity]
[display-name : (U Symbol LamPositionalName)])
#:transparent)
(define-struct: CallKernelPrimitiveProcedure ([operator : KernelPrimitiveName/Inline]
[operands : (Listof (U OpArg ModuleVariable))]
[expected-operand-types : (Listof OperandDomain)]
;; For each operand, #t will add code to typecheck the operand
[typechecks? : (Listof Boolean)])
#:transparent)
(define-struct: ApplyPrimitiveProcedure ([name : Symbol]) #:transparent)
(define-struct: MakeBoxedEnvironmentValue ([depth : Natural])
#:transparent)
;; Capture the current environment, skipping skip frames.
(define-struct: CaptureEnvironment ([skip : Natural]
[tag : (U DefaultContinuationPromptTag OpArg)]))
;; Capture the control stack, skipping skip frames.
(define-struct: CaptureControl ([skip : Natural]
[tag : (U DefaultContinuationPromptTag OpArg)]))
;; Primitive tests (used with TestAndBranch)
(define-type PrimitiveTest (U
TestFalse
TestTrue
TestOne
TestZero
TestClosureArityMismatch
))
(define-struct: TestFalse ([operand : OpArg]) #:transparent)
(define-struct: TestTrue ([operand : OpArg]) #:transparent)
(define-struct: TestOne ([operand : OpArg]) #:transparent)
(define-struct: TestZero ([operand : OpArg]) #:transparent)
(define-struct: TestClosureArityMismatch ([closure : OpArg]
[n : OpArg]) #:transparent)
;; Check that the value in the prefix has been defined.
;; If not, raise an error and stop evaluation.
(define-struct: CheckToplevelBound! ([depth : Natural]
[pos : Natural])
#:transparent)
;; Check that the global can be defined.
;; If not, raise an error and stop evaluation.
(define-struct: CheckGlobalBound! ([name : Symbol])
#:transparent)
;; Check the closure procedure value in 'proc and make sure it's a closure
;; that can accept the right arguments (stored as a number in the argcount register.).
(define-struct: CheckClosureAndArity! ()
#:transparent)
;; Check the primitive can accept the right arguments
;; (stored as a number in the argcount register.).
(define-struct: CheckPrimitiveArity! () #:transparent)
;; Extends the environment with a prefix that holds
;; lookups to the namespace.
(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))])
#:transparent)
;; Adjusts the environment by pushing the values in the
;; closure (held in the proc register) into itself.
(define-struct: InstallClosureValues! ([n : Natural])
#:transparent)
(define-struct: SetFrameCallee! ([proc : OpArg])
#:transparent)
;; Splices the list structure that lives in env[depth] into position.
;; Depth must evaluate to a natural.
(define-struct: SpliceListIntoStack! ([depth : OpArg])
#:transparent)
;; Unsplices the length arguments on the stack, replacing with a list of that length.
;; Side effects: touches both the environment and argcount appropriately.
(define-struct: UnspliceRestFromStack! ([depth : OpArg]
[length : OpArg])
#:transparent)
(define-struct: FixClosureShellMap! (;; depth: where the closure shell is located in the environment
[depth : Natural]
[closed-vals : (Listof Natural)])
#:transparent)
;; Raises an exception that says that we expected a number of values.
;; Assume that argcount is not equal to expected.
(define-struct: RaiseContextExpectedValuesError! ([expected : Natural])
#:transparent)
;; Raises an exception that says that we're doing a
;; procedure application, but got sent an incorrect number.
(define-struct: RaiseArityMismatchError! ([proc : OpArg]
[expected : Arity]
[received : OpArg])
#:transparent)
;; Raises an exception that says that we're doing a
;; procedure application, but got sent an incorrect number.
(define-struct: RaiseOperatorApplicationError! ([operator : OpArg])
#:transparent)
;; Raise a runtime error if we hit a use of an unimplemented kernel primitive.
(define-struct: RaiseUnimplementedPrimitiveError! ([name : Symbol])
#:transparent)
;; Changes over the control located at the given argument from the structure in env[1]
(define-struct: RestoreControl! ([tag : (U DefaultContinuationPromptTag OpArg)]) #:transparent)
;; Changes over the environment located at the given argument from the structure in env[0]
(define-struct: RestoreEnvironment! () #:transparent)
;; Adds a continuation mark into the current top control frame.
(define-struct: InstallContinuationMarkEntry! () #:transparent)
;; Use the dynamic module loader to link the module into the runtime.
;; After successful linkage, jump into label.
(define-struct: LinkModule! ([path : ModuleLocator]
[label : Symbol]))
;; Installs a module record into the machine
(define-struct: InstallModuleEntry! ([name : Symbol]
[path : ModuleLocator]
[entry-point : Symbol])
#:transparent)
;; Mark that the module has been invoked.
(define-struct: MarkModuleInvoked! ([path : ModuleLocator])
#:transparent)
;; Give an alternative locator to the module as a main module.
;; Assumes the module has already been installed.
(define-struct: AliasModuleAsMain! ([from : ModuleLocator])
#:transparent)
;; Given the module locator, do any finalizing operations, like
;; setting up the module namespace.
(define-struct: FinalizeModuleInvokation! ([path : ModuleLocator]
[provides : (Listof ModuleProvide)])
#:transparent)
(define-type PrimitiveCommand (U
CheckToplevelBound!
CheckGlobalBound!
CheckClosureAndArity!
CheckPrimitiveArity!
ExtendEnvironment/Prefix!
InstallClosureValues!
FixClosureShellMap!
InstallContinuationMarkEntry!
SetFrameCallee!
SpliceListIntoStack!
UnspliceRestFromStack!
RaiseContextExpectedValuesError!
RaiseArityMismatchError!
RaiseOperatorApplicationError!
RaiseUnimplementedPrimitiveError!
RestoreEnvironment!
RestoreControl!
LinkModule!
InstallModuleEntry!
MarkModuleInvoked!
AliasModuleAsMain!
FinalizeModuleInvokation!
))
(define-type InstructionSequence (U Symbol
LinkedLabel
UnlabeledStatement
instruction-sequence-list
instruction-sequence-chunks))
(define-struct: instruction-sequence-list ([statements : (Listof Statement)])
#:transparent)
(define-struct: instruction-sequence-chunks ([chunks : (Listof InstructionSequence)])
#:transparent)
(define empty-instruction-sequence (make-instruction-sequence-list '()))
; (define-predicate Statement? Statement)
(: statements (InstructionSequence -> (Listof Statement)))
(define (statements s)
(reverse (statements-fold (inst cons Statement (Listof Statement))
'() s)))
(: statements-fold (All (A) ((Statement A -> A) A InstructionSequence -> A)))
(define (statements-fold f acc seq)
(cond
[(symbol? seq)
(f seq acc)]
[(LinkedLabel? seq)
(f seq acc)]
[(UnlabeledStatement? seq)
(f seq acc)]
[(instruction-sequence-list? seq)
(foldl f acc (instruction-sequence-list-statements seq))]
[(instruction-sequence-chunks? seq)
(foldl (lambda (subseq acc)
(statements-fold f acc subseq))
acc
(instruction-sequence-chunks-chunks seq))]))
(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
(define (append-instruction-sequences . seqs)
(append-seq-list seqs))
(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence-chunks (list seq1 seq2)))
(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
(define (append-seq-list seqs)
(if (null? seqs)
empty-instruction-sequence
(make-instruction-sequence-chunks seqs)))
; (define-predicate OpArg? OpArg)

380
whalesong/selfhost/compiler/kernel-primitives.rkt
View File

@ -1,380 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide (all-defined-out))
(require "arity-structs.rkt"
"lexical-structs.rkt"
; "../type-helpers.rkt"
)
(: kernel-module-name? (ModuleLocator -> Boolean))
;; Produces true if the module is hardcoded.
(define (kernel-module-name? name)
(: 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)
;; HACK HACK HACK
;; This is for srcloc:
(eq? (ModuleLocator-name locator)
'collects/racket/private/kernstruct.rkt)))
(: paramz-locator? (ModuleLocator -> Boolean))
(define (paramz-locator? locator)
(or (and (eq? (ModuleLocator-name locator) '#%paramz)
(eq? (ModuleLocator-real-path locator) '#%paramz))))
(: kernel-module-locator? (ModuleLocator -> Boolean))
;; Produces true if the given module locator should be treated as a primitive root one
;; that is implemented by us.
(define (kernel-module-locator? locator)
(or (kernel-locator? locator)
(paramz-locator? locator)))
(kernel-module-locator? name))
;; Given a kernel-labeled ModuleVariable, returns the kernel name for it.
(: kernel-module-variable->primitive-name (ModuleVariable -> Symbol))
(define (kernel-module-variable->primitive-name a-modvar)
;; FIXME: remap if the module is something else like whalesong/unsafe/ops
(ModuleVariable-name a-modvar))
(define-type OperandDomain (U 'number
'string
'vector
'box
'list
'pair
'caarpair
'any))
;; The following are primitives that the compiler knows about:
(define KernelPrimitiveNames (list '+
'-
'*
'/
'zero?
'add1
'sub1
'abs
'<
'<=
'=
'>
'>=
'cons
'car
'cdr
'caar
'cdar
'cadr
'cddr
'caaar
'cdaar
'cadar
'cddar
'caadr
'cdadr
'caddr
'cdddr
'caaaar
'cdaaar
'cadaar
'cddaar
'caadar
'cdadar
'caddar
'cdddar
'caaadr
'cdaadr
'cadadr
'cddadr
'caaddr
'cdaddr
'cadddr
'cddddr
'list
'list?
'list*
'list->vector
'vector->list
'vector
'vector-length
'vector-ref
'vector-set!
'make-vector
'equal?
'member
'memq
'memv
'memf
'append
'reverse
'length
'pair?
'null?
'not
'eq?
'eqv?
'remainder
'display
'newline
'call/cc
'box
'unbox
'set-box!
'string-append
'current-continuation-marks
'continuation-mark-set->list
'values
'call-with-values
'apply
'for-each
'current-print
'make-struct-type
'current-inspector
'make-struct-field-accessor
'make-struct-field-mutator
'gensym
'srcloc
'make-srcloc
'srcloc-source
'srcloc-line
'srcloc-column
'srcloc-position
'srcloc-span
'error
'raise-type-error
'raise-mismatch-error
'struct:exn:fail
'prop:exn:srclocs
'make-exn
'make-exn:fail
'make-exn:fail:contract
'make-exn:fail:contract:arity
'make-exn:fail:contract:variable
'make-exn:fail:contract:divide-by-zero
'exn:fail?
'exn:fail:contract?
'exn:fail:contract:arity?
'exn-message
'exn-continuation-marks
'hash?
'hash-equal?
'hash-eq?
'hash-eqv?
'hash
'hasheqv
'hasheq
'make-hash
'make-hasheqv
'make-hasheq
'make-immutable-hash
'make-immutable-hasheqv
'make-immutable-hasheq
'hash-copy
'hash-ref
'hash-has-key?
'hash-set!
'hash-set
'hash-remove!
'hash-remove
'equal-hash-code
'hash-count
'hash-keys
'hash-values
'string-copy
'unsafe-car
'unsafe-cdr
'continuation-prompt-available?
'abort-current-continuation
'call-with-continuation-prompt
))
; (define-predicate KernelPrimitiveName? KernelPrimitiveName)
(define (KernelPrimitiveName? s)
(member s KernelPrimitiveNames))
;; These are the primitives that we know how to inline.
(define KernelPrimitiveNames/Inline (list '+
'-
'*
'/
'zero?
'add1
'sub1
'<
'<=
'=
'>
'>=
'cons
'car
'caar
'cdr
'list
'list?
'pair?
'null?
'not
'eq?
'vector-ref
'vector-set!
))
(ensure-type-subsetof KernelPrimitiveName/Inline KernelPrimitiveName)
; (define-predicate KernelPrimitiveName/Inline? KernelPrimitiveName/Inline)
(define (KernelPrimitiveName/Inline? s)
(member s KernelPrimitiveNames/Inline))
(define-struct: IncorrectArity ([expected : Arity]))
(: kernel-primitive-expected-operand-types (KernelPrimitiveName/Inline Natural -> (U (Listof OperandDomain)
IncorrectArity)))
;; Given a primitive and the number of arguments, produces the list of expected domains.
;; TODO: do something more polymorphic.
(define (kernel-primitive-expected-operand-types prim arity)
(cond
[(eq? prim '+)
(build-list arity (lambda (i) 'number))]
[(eq? prim '-)
(cond [(> arity 0)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim '*)
(build-list arity (lambda (i) 'number))]
[(eq? prim '/)
(cond [(> arity 0)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'zero?)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'add1)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'sub1)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim '<)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '<=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '>)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '>=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim 'cons)
(list 'any 'any)]
[(eq? prim 'car)
(list 'pair)]
[(eq? prim 'caar)
(list 'caarpair)]
[(eq? prim 'cdr)
(list 'pair)]
[(eq? prim 'list)
(build-list arity (lambda (i) 'any))]
[(eq? prim 'list?)
(list 'any)]
[(eq? prim 'pair?)
(list 'any)]
[(eq? prim 'null?)
(list 'any)]
[(eq? prim 'not)
(list 'any)]
[(eq? prim 'eq?)
(list 'any 'any)]
[(eq? prim 'vector-ref)
(list 'vector 'number)]
[(eq? prim 'vector-set!)
(list 'vector 'number 'any)]))

237
whalesong/selfhost/compiler/lexical-env.rkt
View File

@ -1,237 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require racket/list
"lexical-structs.rkt"
"../sets.rkt")
(provide find-variable
extend-lexical-environment
extend-lexical-environment/names
extend-lexical-environment/parameter-names
extend-lexical-environment/boxed-names
extend-lexical-environment/placeholders
collect-lexical-references
lexical-references->compile-time-environment
place-prefix-mask
adjust-env-reference-depth
env-reference-depth)
;; Find where the variable is located in the lexical environment
(: find-variable (Symbol ParseTimeEnvironment -> LexicalAddress))
(define (find-variable name cenv)
(: find-pos (Symbol (Listof (U Symbol ModuleVariable False)) -> Natural))
(define (find-pos sym los)
(let ([elt (car los)])
(cond
[(and (symbol? elt) (eq? sym elt))
0]
[(and (ModuleVariable? elt) (eq? (ModuleVariable-name elt) sym))
0]
[else
(add1 (find-pos sym (cdr los)))])))
(let loop ; : LexicalAddress
([cenv cenv] ; : ParseTimeEnvironment
[depth 0]) ; : Natural
(cond [(empty? cenv)
(error 'find-variable "~s not in lexical environment" name)]
[else
(let ([elt (first cenv)]) ; : ParseTimeEnvironmentEntry
(cond
[(Prefix? elt)
(let prefix-loop ; : LexicalAddress
([names (Prefix-names elt)] ; : (Listof (U False Symbol GlobalBucket ModuleVariable))
[pos 0]) ; : Natural
(cond [(empty? names)
(loop (rest cenv) (add1 depth))]
[else
(let ([n (first names)]) ; : (U False Symbol GlobalBucket ModuleVariable)
(cond
[(and (symbol? n) (eq? name n))
(make-EnvPrefixReference depth pos #f)]
[(and (ModuleVariable? n) (eq? name (ModuleVariable-name n)))
(make-EnvPrefixReference depth pos #t)]
[(and (GlobalBucket? n) (eq? name (GlobalBucket-name n)))
(make-EnvPrefixReference depth pos #f)]
[else
(prefix-loop (rest names) (add1 pos))]))]))]
[(NamedBinding? elt)
(cond
[(eq? (NamedBinding-name elt) name)
(make-EnvLexicalReference depth (NamedBinding-boxed? elt))]
[else
(loop (rest cenv) (add1 depth))])]
[(eq? elt #f)
(loop (rest cenv) (add1 depth))]))])))
(: list-index (All (A) A (Listof A) -> (U #f Natural)))
(define (list-index x l)
(let loop ; : (U #f Natural)
([i 0] ; : Natural
[l l]) ; : (Listof A)
(cond
[(empty? l)
#f]
[(eq? x (first l))
i]
[else
(loop (add1 i) (rest l))])))
(: extend-lexical-environment
(ParseTimeEnvironment ParseTimeEnvironmentEntry -> ParseTimeEnvironment))
;; Extends the lexical environment with procedure bindings.
(define (extend-lexical-environment cenv extension)
(cons extension cenv))
(: extend-lexical-environment/names (ParseTimeEnvironment (Listof Symbol) (Listof Boolean) ->
ParseTimeEnvironment))
(define (extend-lexical-environment/names cenv names boxed?)
(append (map (lambda (n #;[n : Symbol]
b #;[b : Boolean]) (make-NamedBinding n #f b)) names boxed?)
cenv))
(: extend-lexical-environment/parameter-names (ParseTimeEnvironment (Listof Symbol) (Listof Boolean) -> ParseTimeEnvironment))
(define (extend-lexical-environment/parameter-names cenv names boxed?)
(append (map (lambda (n b) ; [n : Symbol] [b : Boolean]
(make-NamedBinding n #t b)) names boxed?)
cenv))
(: extend-lexical-environment/boxed-names (ParseTimeEnvironment (Listof Symbol) -> ParseTimeEnvironment))
(define (extend-lexical-environment/boxed-names cenv names)
(append (map (lambda (n) ; ([n : Symbol])
(make-NamedBinding n #f #t)) names)
cenv))
(: extend-lexical-environment/placeholders
(ParseTimeEnvironment Natural -> ParseTimeEnvironment))
;; Add placeholders to the lexical environment (This represents what happens during procedure application.)
(define (extend-lexical-environment/placeholders cenv n)
(append (build-list n (lambda (i) #;([i : Natural]) #f))
cenv))
(: collect-lexical-references ((Listof LexicalAddress)
->
(Listof (U EnvLexicalReference EnvWholePrefixReference))))
;; Given a list of lexical addresses, computes a set of unique references.
;; Multiple lexical addresses to a single prefix should be treated identically.
(define (collect-lexical-references addresses)
(let ([prefix-references ((inst new-set EnvWholePrefixReference))] ; : (Setof EnvWholePrefixReference)
[lexical-references ((inst new-set EnvLexicalReference))]) ; : (Setof EnvLexicalReference)
(let loop ; : (Listof (U EnvLexicalReference EnvWholePrefixReference))
([addresses addresses]) ; : (Listof LexicalAddress)
(cond
[(empty? addresses)
(append (set->list prefix-references)
((inst sort
EnvLexicalReference
EnvLexicalReference)
(set->list lexical-references)
lex-reference<?))]
[else
(let ([addr (first addresses)])
(cond
[(EnvLexicalReference? addr)
(set-insert! lexical-references
addr)
(loop (rest addresses))]
[(EnvPrefixReference? addr)
(set-insert! prefix-references
(make-EnvWholePrefixReference (EnvPrefixReference-depth addr)))
(loop (rest addresses))]))]))))
(: lex-reference<? (EnvLexicalReference EnvLexicalReference -> Boolean))
(define (lex-reference<? x y)
(< (EnvLexicalReference-depth x)
(EnvLexicalReference-depth y)))
(: lexical-references->compile-time-environment ((Listof EnvReference) ParseTimeEnvironment ParseTimeEnvironment
(Listof Symbol)
-> ParseTimeEnvironment))
;; Creates a lexical environment containing the closure's bindings.
(define (lexical-references->compile-time-environment refs cenv new-cenv symbols-to-keep)
(let loop ; : ParseTimeEnvironment
([refs (reverse refs)] ; : (Listof EnvReference)
[new-cenv new-cenv]) ; : ParseTimeEnvironment
(cond
[(empty? refs)
new-cenv]
[else
(let ([a-ref (first refs)]) ; : EnvReference
(cond
[(EnvLexicalReference? a-ref)
(loop (rest refs)
(cons (list-ref cenv (EnvLexicalReference-depth a-ref))
new-cenv))]
[(EnvWholePrefixReference? a-ref)
(loop (rest refs)
(cons (place-prefix-mask
(ensure-Prefix (list-ref cenv (EnvWholePrefixReference-depth a-ref)))
symbols-to-keep)
new-cenv))]))])))
(: ensure-Prefix (Any -> Prefix))
(define (ensure-Prefix x)
(if (Prefix? x)
x
(error 'ensure-Prefix "~s" x)))
(: place-prefix-mask (Prefix (Listof Symbol) -> Prefix))
;; Masks elements of the prefix off.
(define (place-prefix-mask a-prefix symbols-to-keep)
(make-Prefix
(map (lambda (n) #; ([n : (U False Symbol GlobalBucket ModuleVariable)])
(cond [(eq? n #f)
n]
[(symbol? n)
(if (member n symbols-to-keep)
n
#f)]
[(GlobalBucket? n)
(if (member (GlobalBucket-name n) symbols-to-keep)
n
#f)]
[(ModuleVariable? n)
(if (member (ModuleVariable-name n) symbols-to-keep)
n
#f)]))
(Prefix-names a-prefix))))
(: adjust-env-reference-depth (EnvReference Natural -> EnvReference))
(define (adjust-env-reference-depth target n)
(cond
[(EnvLexicalReference? target)
(make-EnvLexicalReference (+ n (EnvLexicalReference-depth target))
(EnvLexicalReference-unbox? target))]
[(EnvPrefixReference? target)
(make-EnvPrefixReference (+ n (EnvPrefixReference-depth target))
(EnvPrefixReference-pos target)
(EnvPrefixReference-modvar? target))]
[(EnvWholePrefixReference? target)
(make-EnvWholePrefixReference (+ n (EnvWholePrefixReference-depth target)))]))
(: env-reference-depth ((U EnvLexicalReference EnvPrefixReference EnvWholePrefixReference) -> Natural))
(define (env-reference-depth a-ref)
(cond
[(EnvLexicalReference? a-ref)
(EnvLexicalReference-depth a-ref)]
[(EnvPrefixReference? a-ref)
(EnvPrefixReference-depth a-ref)]
[(EnvWholePrefixReference? a-ref)
(EnvWholePrefixReference-depth a-ref)]))

66
whalesong/selfhost/compiler/lexical-structs.rkt
View File

@ -1,66 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(provide (all-defined-out))
;;;;;;;;;;;;;;
;; Lexical environments
;; A toplevel prefix contains a list of toplevel variables. Some of the
;; names may be masked out by #f.
(define-struct: Prefix ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))])
#:transparent)
(define-struct: GlobalBucket ([name : Symbol])
#:transparent)
;; A ModuleLocator is an identifier for a Module.
(define-struct: ModuleLocator ([name : Symbol]
[real-path : (U Symbol Path)])
#:transparent)
(define-struct: ModuleVariable ([name : Symbol]
[module-name : ModuleLocator])
#:transparent)
(define-struct: NamedBinding ([name : Symbol]
[parameter? : Boolean]
[boxed? : Boolean])
#:transparent)
(define-type ParseTimeEnvironmentEntry (U Prefix ;; a prefix
NamedBinding
False))
;; A compile-time environment is a (listof (listof symbol)).
;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
(define-type ParseTimeEnvironment (Listof ParseTimeEnvironmentEntry))
;; A lexical address is a reference to an value in the environment stack.
(define-type LexicalAddress (U EnvLexicalReference EnvPrefixReference))
(define-struct: EnvLexicalReference ([depth : Natural]
[unbox? : Boolean])
#:transparent)
(define-struct: EnvPrefixReference ([depth : Natural]
[pos : Natural]
[modvar? : Boolean])
#:transparent)
(define-struct: EnvWholePrefixReference ([depth : Natural])
#:transparent)
;; An environment reference is either lexical or referring to a whole prefix.
(define-type EnvReference (U EnvLexicalReference
EnvWholePrefixReference))

454
whalesong/selfhost/compiler/optimize-il.rkt
View File

@ -1,454 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require "expression-structs.rkt"
"il-structs.rkt"
"lexical-structs.rkt"
(prefix-in ufind: "../union-find.rkt")
racket/list)
; (require/typed "../logger.rkt" [log-debug (String -> Void)]) ; TODO /soegaard
(provide optimize-il)
;; perform optimizations on the intermediate language.
;;
(: optimize-il ((Listof Statement) -> (Listof Statement)))
(define (optimize-il statements)
;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...)
;; We should do some more optimizations here, like peephole...
(let* ([statements (filter not-no-op? statements)]
[statements (pairwise-reductions statements)]
[statements (flatten-adjacent-labels statements)])
statements))
(: flatten-adjacent-labels ((Listof Statement) -> (Listof Statement)))
;; Squash adjacent labels together.
(define (flatten-adjacent-labels statements)
(cond
[(empty? statements)
empty]
[else
;; The first pass through will collect adjacent labels and equate them.
(define a-forest (ufind:new-forest))
(let loop ; : 'ok
([stmts (rest statements)] ; : (Listof Statement)
[last-stmt (first statements)]) ; : Statement
(cond
[(empty? stmts)
'ok]
[else
(define next-stmt (first stmts))
(cond
[(and (symbol? last-stmt) (symbol? next-stmt))
(log-debug (format "merging label ~a and ~a" last-stmt next-stmt))
(ufind:union-set a-forest last-stmt next-stmt)
(loop (rest stmts) next-stmt)]
;; If there's a label, immediately followed by a direct Goto jump,
;; just equate the label and the jump.
[(and (symbol? last-stmt) (Goto? next-stmt))
(define goto-target (Goto-target next-stmt))
(cond
[(Label? goto-target)
(log-debug (format "merging label ~a and ~a" last-stmt (Label-name goto-target)))
(ufind:union-set a-forest last-stmt (Label-name goto-target))
(loop (rest stmts) next-stmt)]
[else
(loop (rest stmts) next-stmt)])]
[else
(loop (rest stmts) next-stmt)])]))
(: ref (Symbol -> Symbol))
(define (ref a-label)
(ufind:find-set a-forest a-label))
(: rewrite-target (Target -> Target))
(define (rewrite-target target)
target)
(: rewrite-oparg (OpArg -> OpArg))
(define (rewrite-oparg oparg)
(cond
[(Const? oparg)
oparg]
[(Label? oparg)
(make-Label (ref (Label-name oparg)))]
[(Reg? oparg)
oparg]
[(EnvLexicalReference? oparg)
oparg]
[(EnvPrefixReference? oparg)
oparg]
[(EnvWholePrefixReference? oparg)
oparg]
[(SubtractArg? oparg)
oparg]
[(ControlStackLabel? oparg)
oparg]
[(ControlStackLabel/MultipleValueReturn? oparg)
oparg]
[(ControlFrameTemporary? oparg)
oparg]
[(CompiledProcedureEntry? oparg)
oparg]
[(CompiledProcedureClosureReference? oparg)
oparg]
[(ModuleEntry? oparg)
oparg]
[(ModulePredicate? oparg)
oparg]
[(PrimitiveKernelValue? oparg)
oparg]
[(VariableReference? oparg)
oparg]))
(: rewrite-primop (PrimitiveOperator -> PrimitiveOperator))
(define (rewrite-primop op)
(cond
[(GetCompiledProcedureEntry? op)
op]
[(MakeCompiledProcedure? op)
(make-MakeCompiledProcedure (ref (MakeCompiledProcedure-label op))
(MakeCompiledProcedure-arity op)
(MakeCompiledProcedure-closed-vals op)
(MakeCompiledProcedure-display-name op))]
[(MakeCompiledProcedureShell? op)
(make-MakeCompiledProcedureShell (ref (MakeCompiledProcedureShell-label op))
(MakeCompiledProcedureShell-arity op)
(MakeCompiledProcedureShell-display-name op))]
[(MakeBoxedEnvironmentValue? op)
op]
[(CaptureEnvironment? op)
op]
[(CaptureControl? op)
op]
[(CallKernelPrimitiveProcedure? op)
op]
[(ApplyPrimitiveProcedure? op)
op]
[(ModuleVariable? op)
op]
[(PrimitivesReference? op)
op]
[(GlobalsReference? op)
op]))
(: rewrite-primcmd (PrimitiveCommand -> PrimitiveCommand))
(define (rewrite-primcmd cmd)
(cond
[(InstallModuleEntry!? cmd)
(make-InstallModuleEntry! (InstallModuleEntry!-name cmd)
(InstallModuleEntry!-path cmd)
(ref (InstallModuleEntry!-entry-point cmd)))]
[else
cmd]))
(: rewrite-primtest (PrimitiveTest -> PrimitiveTest))
(define (rewrite-primtest test)
test)
;; The second pass will then rewrite references of labels.
(let loop ; : (Listof Statement)
([stmts statements]) ; : (Listof Statement)
(cond
[(empty? stmts)
empty]
[else
(define a-stmt (first stmts))
(cond
[(symbol? a-stmt)
(cond
[(eq? (ref a-stmt) a-stmt)
(cons (ref a-stmt) (loop (rest stmts)))]
[else
(loop (rest stmts))])]
[(LinkedLabel? a-stmt)
(cons (make-LinkedLabel (LinkedLabel-label a-stmt)
(ref (LinkedLabel-linked-to a-stmt)))
(loop (rest stmts)))]
[(DebugPrint? a-stmt)
(cons a-stmt (loop (rest stmts)))
#;(loop (rest stmts))
]
[(Comment? a-stmt)
;(loop (rest stmts))
(cons a-stmt (loop (rest stmts)))
]
[(MarkEntryPoint? a-stmt)
(cons a-stmt (loop (rest stmts)))]
[(AssignImmediate? a-stmt)
(cons (make-AssignImmediate (rewrite-target (AssignImmediate-target a-stmt))
(rewrite-oparg (AssignImmediate-value a-stmt)))
(loop (rest stmts)))]
[(AssignPrimOp? a-stmt)
(cons (make-AssignPrimOp (rewrite-target (AssignPrimOp-target a-stmt))
(rewrite-primop (AssignPrimOp-op a-stmt)))
(loop (rest stmts)))]
[(Perform? a-stmt)
(cons (make-Perform (rewrite-primcmd (Perform-op a-stmt)))
(loop (rest stmts)))]
[(PopEnvironment? a-stmt)
(cons (make-PopEnvironment (rewrite-oparg (PopEnvironment-n a-stmt))
(rewrite-oparg (PopEnvironment-skip a-stmt)))
(loop (rest stmts)))]
[(PushEnvironment? a-stmt)
(cons a-stmt (loop (rest stmts)))]
[(PushImmediateOntoEnvironment? a-stmt)
(cons (make-PushImmediateOntoEnvironment (rewrite-oparg (PushImmediateOntoEnvironment-value a-stmt))
(PushImmediateOntoEnvironment-box? a-stmt))
(loop (rest stmts)))]
[(PushControlFrame/Generic? a-stmt)
(cons a-stmt (loop (rest stmts)))]
[(PushControlFrame/Call? a-stmt)
(define a-label (PushControlFrame/Call-label a-stmt))
(cons (make-PushControlFrame/Call
(make-LinkedLabel (LinkedLabel-label a-label)
(ref (LinkedLabel-linked-to a-label))))
(loop (rest stmts)))]
[(PushControlFrame/Prompt? a-stmt)
(define a-label (PushControlFrame/Prompt-label a-stmt))
(cons (make-PushControlFrame/Prompt (let ([tag (PushControlFrame/Prompt-tag a-stmt)])
(if (DefaultContinuationPromptTag? tag)
tag
(rewrite-oparg tag)))
(make-LinkedLabel (LinkedLabel-label a-label)
(ref (LinkedLabel-linked-to a-label))))
(loop (rest stmts)))]
[(PopControlFrame? a-stmt)
(cons a-stmt (loop (rest stmts)))]
[(Goto? a-stmt)
(define target (Goto-target a-stmt))
(cond
[(Label? target)
(cons (make-Goto (make-Label (ref (Label-name target))))
(loop (rest stmts)))]
[else
(cons a-stmt (loop (rest stmts)))])]
[(TestAndJump? a-stmt)
(cons (make-TestAndJump (rewrite-primtest (TestAndJump-op a-stmt))
(ref (TestAndJump-label a-stmt)))
(loop (rest stmts)))])]))]))
(: pairwise-reductions ((Listof Statement) -> (Listof Statement)))
(define (pairwise-reductions statements)
(let loop ([statements statements])
(cond
[(empty? statements)
empty]
[else
(let ([first-stmt (first statements)])
(: default (-> (Listof Statement)))
(define (default)
(cons first-stmt (loop (rest statements))))
(cond
[(empty? (rest statements))
(default)]
[else
(let ([second-stmt (second statements)])
(cond
;; A PushEnvironment followed by a direct AssignImmediate can be reduced to a single
;; instruction.
[(and (PushEnvironment? first-stmt)
(equal? first-stmt (make-PushEnvironment 1 #f))
(AssignImmediate? second-stmt))
(let ([target (AssignImmediate-target second-stmt)])
(cond
[(equal? target (make-EnvLexicalReference 0 #f))
(loop (cons (make-PushImmediateOntoEnvironment
(adjust-oparg-depth
(AssignImmediate-value second-stmt) -1)
#f)
(rest (rest statements))))]
[else
(default)]))]
;; Adjacent PopEnvironments with constants can be reduced to single ones
[(and (PopEnvironment? first-stmt)
(PopEnvironment? second-stmt))
(let ([first-n (PopEnvironment-n first-stmt)]
[second-n (PopEnvironment-n second-stmt)]
[first-skip (PopEnvironment-skip first-stmt)]
[second-skip (PopEnvironment-skip second-stmt)])
(cond [(and (Const? first-n) (Const? second-n) (Const? first-skip) (Const? second-skip))
(let ([first-n-val (Const-const first-n)]
[second-n-val (Const-const second-n)]
[first-skip-val (Const-const first-skip)]
[second-skip-val (Const-const second-skip)])
(cond
[(and (number? first-n-val)
(number? second-n-val)
(number? first-skip-val) (= first-skip-val 0)
(number? second-skip-val) (= second-skip-val 0))
(loop (cons (make-PopEnvironment (make-Const (+ first-n-val second-n-val))
(make-Const 0))
(rest (rest statements))))]
[else
(default)]))]
[else
(default)]))]
[else
(default)]))]))])))
(: not-no-op? (Statement -> Boolean))
(define (not-no-op? stmt) (not (no-op? stmt)))
(: no-op? (Statement -> Boolean))
;; Produces true if the statement should have no effect.
(define (no-op? stmt)
(cond
[(symbol? stmt)
#f]
[(LinkedLabel? stmt)
#f]
[(DebugPrint? stmt)
#f
#;#t]
[(MarkEntryPoint? stmt)
#f]
[(AssignImmediate? stmt)
(equal? (AssignImmediate-target stmt)
(AssignImmediate-value stmt))]
[(AssignPrimOp? stmt)
#f]
[(Perform? stmt)
#f]
[(Goto? stmt)
#f]
[(TestAndJump? stmt)
#f]
[(PopEnvironment? stmt)
(and (Const? (PopEnvironment-n stmt))
(equal? (PopEnvironment-n stmt)
(make-Const 0)))]
[(PushEnvironment? stmt)
(= (PushEnvironment-n stmt) 0)]
[(PushImmediateOntoEnvironment? stmt)
#f]
[(PushControlFrame/Generic? stmt)
#f]
[(PushControlFrame/Call? stmt)
#f]
[(PushControlFrame/Prompt? stmt)
#f]
[(PopControlFrame? stmt)
#f]
[(Comment? stmt)
#f]))
(: adjust-oparg-depth (OpArg Integer -> OpArg))
(define (adjust-oparg-depth oparg n)
(cond
[(Const? oparg) oparg]
[(Label? oparg) oparg]
[(Reg? oparg) oparg]
[(EnvLexicalReference? oparg)
(make-EnvLexicalReference (ensure-natural (+ n (EnvLexicalReference-depth oparg)))
(EnvLexicalReference-unbox? oparg))]
[(EnvPrefixReference? oparg)
(make-EnvPrefixReference (ensure-natural (+ n (EnvPrefixReference-depth oparg)))
(EnvPrefixReference-pos oparg)
(EnvPrefixReference-modvar? oparg))]
[(EnvWholePrefixReference? oparg)
(make-EnvWholePrefixReference (ensure-natural (+ n (EnvWholePrefixReference-depth oparg))))]
[(SubtractArg? oparg)
(make-SubtractArg (adjust-oparg-depth (SubtractArg-lhs oparg) n)
(adjust-oparg-depth (SubtractArg-rhs oparg) n))]
[(ControlStackLabel? oparg)
oparg]
[(ControlStackLabel/MultipleValueReturn? oparg)
oparg]
[(ControlFrameTemporary? oparg)
oparg]
[(CompiledProcedureEntry? oparg)
(make-CompiledProcedureEntry (adjust-oparg-depth (CompiledProcedureEntry-proc oparg) n))]
[(CompiledProcedureClosureReference? oparg)
(make-CompiledProcedureClosureReference
(adjust-oparg-depth (CompiledProcedureClosureReference-proc oparg) n)
(CompiledProcedureClosureReference-n oparg))]
[(PrimitiveKernelValue? oparg)
oparg]
[(ModuleEntry? oparg)
oparg]
[(ModulePredicate? oparg)
oparg]
[(VariableReference? oparg)
(let ([t (VariableReference-toplevel oparg)])
(make-VariableReference
(make-ToplevelRef (ensure-natural (+ n (ToplevelRef-depth t)))
(ToplevelRef-pos t)
(ToplevelRef-constant? t)
(ToplevelRef-check-defined? t))))]))
; (define-predicate natural? Natural)
(define (ensure-natural x)
(if (natural? x)
x
(error 'ensure-natural)))

58
whalesong/selfhost/helpers.rkt
View File

@ -1,58 +0,0 @@
#lang whalesong (require "selfhost-lang.rkt") (require whalesong/lang/for)
; #lang typed/racket/base
(require racket/list)
(provide list-union list-difference list-intersection unique/eq? unique/equal?)
(: list-union ((Listof Symbol) (Listof Symbol) -> (Listof Symbol)))
(define (list-union s1 s2)
(cond [(null? s1) s2]
[(memq (car s1) s2)
(list-union (cdr s1) s2)]
[else (cons (car s1) (list-union (cdr s1) s2))]))
(: list-difference ((Listof Symbol) (Listof Symbol) -> (Listof Symbol)))
(define (list-difference s1 s2)
(cond [(null? s1) '()]
[(memq (car s1) s2)
(list-difference (cdr s1) s2)]
[else
(cons (car s1) (list-difference (cdr s1) s2))]))
(: list-intersection ((Listof Symbol) (Listof Symbol) -> (Listof Symbol)))
(define (list-intersection s1 s2)
(cond [(null? s1) '()]
[(memq (car s1) s2)
(cons (car s1) (list-intersection (cdr s1) s2))]
[else
(list-intersection (cdr s1) s2)]))
;; Trying to work around what looks like a bug in typed racket:
(define string-sort (inst sort String String))
(: unique/eq? ((Listof Symbol) -> (Listof Symbol)))
(define (unique/eq? los)
(let ([ht ; : (HashTable Symbol Boolean)
(make-hasheq)])
(for ([l los])
(hash-set! ht l #t))
(map string->symbol
(string-sort
(hash-map ht (lambda (k v) ; ([k : Symbol] [v : Boolean])
(symbol->string k)))
string<?))))
(: unique/equal? (All (A) ((Listof A) -> (Listof A))))
(define (unique/equal? lst)
(cond
[(empty? lst)
empty]
[(member (first lst) (rest lst))
(unique/equal? (rest lst))]
[else
(cons (first lst)
(unique/equal? (rest lst)))]))

112
whalesong/selfhost/js-assembler/assemble-expression.rkt
View File

@ -1,112 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
; #lang typed/racket/base
(require "assemble-structs.rkt"
"assemble-helpers.rkt"
"assemble-open-coded.rkt"
"../compiler/lexical-structs.rkt"
"../compiler/il-structs.rkt"
racket/string)
(provide assemble-op-expression
current-interned-constant-closure-table
assemble-current-interned-constant-closure-table)
(: current-interned-constant-closure-table (Parameterof (HashTable Symbol MakeCompiledProcedure)))
(define current-interned-constant-closure-table
(make-parameter ((inst make-hasheq Symbol MakeCompiledProcedure))))
(: assemble-current-interned-constant-closure-table (-> String))
(define (assemble-current-interned-constant-closure-table)
(string-join (hash-map
(current-interned-constant-closure-table)
(lambda (a-label a-shell) ; ([a-label : Symbol] [a-shell : MakeCompiledProcedure])
(format "var ~a_c=new RT.Closure(~a,~a,void(0),~a);"
(assemble-label (make-Label (MakeCompiledProcedure-label a-shell)))
(assemble-label (make-Label (MakeCompiledProcedure-label a-shell)))
(assemble-arity (MakeCompiledProcedure-arity a-shell))
(assemble-display-name (MakeCompiledProcedure-display-name a-shell)))))
"\n"))
(: assemble-op-expression (PrimitiveOperator Blockht -> String))
(define (assemble-op-expression op blockht)
(cond
[(GetCompiledProcedureEntry? op)
"M.p.label"]
[(MakeCompiledProcedure? op)
(cond
;; Small optimization: try to avoid creating the array if we know up front
;; that the closure has no closed values. It's a constant that we lift up to the toplevel.
[(null? (MakeCompiledProcedure-closed-vals op))
(define assembled-label (assemble-label (make-Label (MakeCompiledProcedure-label op))))
(unless (hash-has-key? (current-interned-constant-closure-table) (MakeCompiledProcedure-label op))
(hash-set! (current-interned-constant-closure-table)
(MakeCompiledProcedure-label op)
op))
(format "~a_c" assembled-label)]
[else
(format "new RT.Closure(~a,~a,[~a],~a)"
(assemble-label (make-Label (MakeCompiledProcedure-label op)))
(assemble-arity (MakeCompiledProcedure-arity op))
(string-join (map
assemble-env-reference/closure-capture
;; The closure values are in reverse order
;; to make it easier to push, in bulk, into
;; the environment (which is also in reversed order)
;; during install-closure-values.
(reverse (MakeCompiledProcedure-closed-vals op)))
",")
(assemble-display-name (MakeCompiledProcedure-display-name op)))])]
[(MakeCompiledProcedureShell? op)
(format "new RT.Closure(~a,~a,void(0),~a)"
(assemble-label (make-Label (MakeCompiledProcedureShell-label op)))
(assemble-arity (MakeCompiledProcedureShell-arity op))
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
[(CaptureEnvironment? op)
(format "M.e.slice(0, M.e.length-~a)"
(CaptureEnvironment-skip op))]
[(CaptureControl? op)
(format "M.captureControl(~a,~a)"
(CaptureControl-skip op)
(let ([tag ; : (U DefaultContinuationPromptTag OpArg)
(CaptureControl-tag op)])
(cond [(DefaultContinuationPromptTag? tag)
(assemble-default-continuation-prompt-tag)]
[(OpArg? tag)
(assemble-oparg tag blockht)])))]
[(MakeBoxedEnvironmentValue? op)
(format "[M.e[M.e.length-~a]]"
(add1 (MakeBoxedEnvironmentValue-depth op)))]
[(CallKernelPrimitiveProcedure? op)
(open-code-kernel-primitive-procedure op blockht)]
[(ApplyPrimitiveProcedure? op)
(format "M.primitives[~s]._i(M)" (symbol->string (ApplyPrimitiveProcedure-name op)))]
[(ModuleVariable? op)
(format "M.modules[~s].getExports().get(~s)"
(symbol->string
(ModuleLocator-name
(ModuleVariable-module-name op)))
(symbol->string (ModuleVariable-name op)))]
[(PrimitivesReference? op)
(format "M.primitives[~s]" (symbol->string (PrimitivesReference-name op)))]
[(GlobalsReference? op)
(format "(M.globals[~s]!==void(0)?M.globals[~s]:M.params.currentNamespace.get(~s))"
(symbol->string (GlobalsReference-name op))
(symbol->string (GlobalsReference-name op))
(symbol->string (GlobalsReference-name op)))]))

527
whalesong/selfhost/js-assembler/assemble-helpers.rkt
View File

@ -1,527 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt" "../selfhost-strings.rkt")
; #lang typed/racket/base
(require "../compiler/il-structs.rkt"
"../compiler/expression-structs.rkt"
"../compiler/lexical-structs.rkt"
"../compiler/arity-structs.rkt"
"assemble-structs.rkt"
racket/list
; racket/string
racket/match)
; (require/typed net/base64 [base64-encode (Bytes -> Bytes)])
(require "../base64.rkt") ; base64-encode : string -> string
(provide assemble-oparg
assemble-target
assemble-const
assemble-lexical-reference
assemble-prefix-reference
assemble-whole-prefix-reference
assemble-reg
munge-label-name
assemble-label
assemble-listof-assembled-values
assemble-default-continuation-prompt-tag
assemble-env-reference/closure-capture
assemble-arity
assemble-jump
assemble-display-name
assemble-location
assemble-numeric-constant
assemble-module-variable-ref
block-looks-like-context-expected-values?
block-looks-like-pop-multiple-values-and-continue?
current-interned-symbol-table
assemble-current-interned-symbol-table
)
#;(require/typed typed/racket/base
[regexp-split (Regexp String -> (Listof String))])
(: assemble-oparg (OpArg Blockht -> String))
(define (assemble-oparg v blockht)
(cond
[(Reg? v)
(assemble-reg v)]
[(Label? v)
(assemble-label v)]
[(Const? v)
(assemble-const v)]
[(EnvLexicalReference? v)
(assemble-lexical-reference v)]
[(EnvPrefixReference? v)
(assemble-prefix-reference v)]
[(EnvWholePrefixReference? v)
(assemble-whole-prefix-reference v)]
[(SubtractArg? v)
(assemble-subtractarg v blockht)]
[(ControlStackLabel? v)
(assemble-control-stack-label v)]
[(ControlStackLabel/MultipleValueReturn? v)
(assemble-control-stack-label/multiple-value-return v)]
[(ControlFrameTemporary? v)
(assemble-control-frame-temporary v)]
[(CompiledProcedureEntry? v)
(assemble-compiled-procedure-entry v blockht)]
[(CompiledProcedureClosureReference? v)
(assemble-compiled-procedure-closure-reference v blockht)]
[(PrimitiveKernelValue? v)
(assemble-primitive-kernel-value v)]
[(ModuleEntry? v)
(assemble-module-entry v)]
[(ModulePredicate? v)
(assemble-module-predicate v)]
[(VariableReference? v)
(assemble-variable-reference v)]))
(: assemble-target (Target -> (String -> String)))
(define (assemble-target target)
(cond
[(PrimitivesReference? target)
(lambda (rhs) ; ([rhs : String])
(format "RT.Primitives[~s]=RT.Primitives[~s]||~a;"
(symbol->string (PrimitivesReference-name target))
(symbol->string (PrimitivesReference-name target))
rhs))]
[(ModuleVariable? target)
(lambda (rhs) ; ([rhs : String])
(format "M.modules[~s].getExports().set(~s,~s);"
(symbol->string (ModuleLocator-name (ModuleVariable-module-name target)))
(symbol->string (ModuleVariable-name target))
rhs))]
[else
(lambda (rhs) ; ([rhs : String])
(format "~a=~a;"
(ann (cond
[(eq? target 'proc)
"M.p"]
[(eq? target 'val)
"M.v"]
[(eq? target 'argcount)
"M.a"]
[(EnvLexicalReference? target)
(assemble-lexical-reference target)]
[(EnvPrefixReference? target)
(assemble-prefix-reference target)]
[(ControlFrameTemporary? target)
(assemble-control-frame-temporary target)]
[(GlobalsReference? target)
(format "M.globals[~s]" (symbol->string (GlobalsReference-name target)))]
[(ModulePrefixTarget? target)
(format "M.modules[~s].prefix"
(symbol->string (ModuleLocator-name (ModulePrefixTarget-path target))))])
String)
rhs))]))
(: assemble-control-frame-temporary (ControlFrameTemporary -> String))
(define (assemble-control-frame-temporary t)
(format "M.c[M.c.length-1].~a"
(ControlFrameTemporary-name t)))
(: current-interned-symbol-table (Parameterof (HashTable Symbol Symbol)))
(define current-interned-symbol-table
(make-parameter ((inst make-hasheq Symbol Symbol))))
(: assemble-current-interned-symbol-table (-> String))
(define (assemble-current-interned-symbol-table)
(string-join (hash-map
(current-interned-symbol-table)
(lambda (a-symbol variable-name) ; ([a-symbol : Symbol] [variable-name : Symbol])
(format "var ~a=RT.makeSymbol(~s);"
variable-name
(symbol->string a-symbol))))
"\n"))
;; fixme: use js->string
(: assemble-const (Const -> String))
(define (assemble-const stmt)
(let loop ; : String ([val : const-value (Const-const stmt)])
([val (Const-const stmt)])
(cond [(symbol? val)
(define intern-var (hash-ref (current-interned-symbol-table)
val
(lambda ()
(define fresh (gensym 'sym))
(hash-set! (current-interned-symbol-table) val fresh)
fresh)))
(symbol->string intern-var)
;;(format "RT.makeSymbol(~s)" (symbol->string val))
]
[(pair? val)
(format "RT.makePair(~a,~a)"
(loop (car val))
(loop (cdr val)))]
[(boolean? val)
(if val "true" "false")]
[(void? val)
"RT.VOID"]
[(empty? val)
(format "RT.NULL")]
[(number? val)
(assemble-numeric-constant val)]
[(string? val)
(format "~s" val)]
[(char? val)
(format "RT.makeChar(~s)" (string val))]
[(bytes? val)
;; This needs to be an array, because this may contain
;; a LOT of elements, and certain JS evaluators will break
;; otherewise.
(format "RT.makeBytesFromBase64(~s)"
(bytes->string/utf-8 (base64-encode val)))]
[(path? val)
(format "RT.makePath(~s)"
(path->string val))]
[(vector? val)
(format "RT.makeVector([~a])"
(string-join (map loop (vector->list val))
","))]
[(box? val)
(format "RT.makeBox(~s)"
(loop (unbox val)))])))
(: assemble-listof-assembled-values ((Listof String) -> String))
(define (assemble-listof-assembled-values vals)
(let loop ([vals vals])
(cond
[(empty? vals)
"RT.NULL"]
[else
(format "RT.makePair(~a,~a)" (first vals) (loop (rest vals)))])))
;; Slightly ridiculous definition, but I need it to get around what appear to
;; be Typed Racket bugs in its numeric tower.
; (define-predicate int? Integer)
(define int? integer?)
(: assemble-numeric-constant (Number -> String))
(define (assemble-numeric-constant a-num)
(: floating-number->js (Real -> String))
(define (floating-number->js a-num)
(cond
[(eqv? a-num -0.0)
"RT.NEGATIVE_ZERO"]
[(eqv? a-num +inf.0)
"RT.INF"]
[(eqv? a-num -inf.0)
"RT.NEGATIVE_INF"]
[(eqv? a-num +nan.0)
"RT.NAN"]
[else
(string-append "RT.makeFloat(" (number->string a-num) ")")]))
;; FIXME: fix the type signature when typed-racket isn't breaking on
;; (define-predicate ExactRational? (U Exact-Rational))
(: rational-number->js (Real -> String))
(define (rational-number->js a-num)
(cond [(= (denominator a-num) 1)
(string-append (integer->js (ensure-integer (numerator a-num))))]
[else
(string-append "RT.makeRational("
(integer->js (ensure-integer (numerator a-num)))
","
(integer->js (ensure-integer (denominator a-num)))
")")]))
(: ensure-integer (Any -> Integer))
(define (ensure-integer x)
(if (int? x)
x
(error "not an integer: ~e" x)))
(: integer->js (Integer -> String))
(define (integer->js an-int)
(cond
;; non-overflow case
[(< (abs an-int) 9e15)
(number->string an-int)]
;; overflow case
[else
(string-append "RT.makeBignum("
(format "~s" (number->string an-int))
")")]))
(cond
[(and (exact? a-num) (rational? a-num))
(rational-number->js a-num)]
[(real? a-num)
(floating-number->js a-num)]
[(complex? a-num)
(string-append "RT.makeComplex("
(assemble-numeric-constant (real-part a-num))
","
(assemble-numeric-constant (imag-part a-num))
")")]))
(: assemble-lexical-reference (EnvLexicalReference -> String))
(define (assemble-lexical-reference a-lex-ref)
(if (EnvLexicalReference-unbox? a-lex-ref)
(format "M.e[M.e.length-~a][0]"
(add1 (EnvLexicalReference-depth a-lex-ref)))
(format "M.e[M.e.length-~a]"
(add1 (EnvLexicalReference-depth a-lex-ref)))))
(: assemble-prefix-reference (EnvPrefixReference -> String))
(define (assemble-prefix-reference a-ref)
(cond
[(EnvPrefixReference-modvar? a-ref)
(format "M.e[M.e.length-~a][~a][0][M.e[M.e.length-~a][~a][1]]"
(add1 (EnvPrefixReference-depth a-ref))
(EnvPrefixReference-pos a-ref)
(add1 (EnvPrefixReference-depth a-ref))
(EnvPrefixReference-pos a-ref))]
[else
(format "M.e[M.e.length-~a][~a]"
(add1 (EnvPrefixReference-depth a-ref))
(EnvPrefixReference-pos a-ref))]))
(: assemble-whole-prefix-reference (EnvWholePrefixReference -> String))
(define (assemble-whole-prefix-reference a-prefix-ref)
(format "M.e[M.e.length-~a]"
(add1 (EnvWholePrefixReference-depth a-prefix-ref))))
(: assemble-reg (Reg -> String))
(define (assemble-reg a-reg)
(let ([name (Reg-name a-reg)])
(cond
[(eq? name 'proc)
"M.p"]
[(eq? name 'val)
"M.v"]
[(eq? name 'argcount)
"M.a"])))
(: munge-label-name (Label -> String))
(define (munge-label-name a-label)
(define chunks
(string-split-at-non-alphanumeric ; was (regexp-split #rx"[^a-zA-Z0-9]+" ...)
(symbol->string (Label-name a-label))))
(cond
[(empty? chunks)
(error "impossible: empty label ~s" a-label)]
[(empty? (rest chunks))
(string-append "_" (first chunks))]
[else
(string-append "_"
(first chunks)
(apply string-append (map string-titlecase (rest chunks))))]))
(: assemble-label (Label -> String))
(define (assemble-label a-label)
(munge-label-name a-label))
(: assemble-subtractarg (SubtractArg Blockht -> String))
(define (assemble-subtractarg s blockht)
(format "(~a-~a)"
(assemble-oparg (SubtractArg-lhs s) blockht)
(assemble-oparg (SubtractArg-rhs s) blockht)))
(: assemble-control-stack-label (ControlStackLabel -> String))
(define (assemble-control-stack-label a-csl)
"M.c[M.c.length-1].label")
(: assemble-control-stack-label/multiple-value-return (ControlStackLabel/MultipleValueReturn -> String))
(define (assemble-control-stack-label/multiple-value-return a-csl)
"(M.c[M.c.length-1].label.mvr||RT.si_context_expected_1)")
(: assemble-compiled-procedure-entry (CompiledProcedureEntry Blockht -> String))
(define (assemble-compiled-procedure-entry a-compiled-procedure-entry blockht)
(format "(~a).label"
(assemble-oparg (CompiledProcedureEntry-proc a-compiled-procedure-entry)
blockht)))
(: assemble-compiled-procedure-closure-reference (CompiledProcedureClosureReference Blockht -> String))
(define (assemble-compiled-procedure-closure-reference a-ref blockht)
(format "(~a).closedVals[(~a).closedVals.length - ~a]"
(assemble-oparg (CompiledProcedureClosureReference-proc a-ref) blockht)
(assemble-oparg (CompiledProcedureClosureReference-proc a-ref) blockht)
(add1 (CompiledProcedureClosureReference-n a-ref))))
(: assemble-default-continuation-prompt-tag (-> String))
(define (assemble-default-continuation-prompt-tag)
"RT.DEFAULT_CONTINUATION_PROMPT_TAG")
(: assemble-env-reference/closure-capture (Natural -> String))
;; When we're capturing the values for a closure, we need to not unbox
;; lexical references: they must remain boxes. So all we need is
;; the depth into the environment.
(define (assemble-env-reference/closure-capture depth)
(format "M.e[M.e.length-~a]"
(add1 depth)))
; (define-predicate natural? Natural)
(: assemble-arity (Arity -> String))
(define (assemble-arity an-arity)
(cond
[(natural? an-arity)
(number->string an-arity)]
[(ArityAtLeast? an-arity)
(format "(RT.makeArityAtLeast(~a))"
(ArityAtLeast-value an-arity))]
[(listof-atomic-arity? an-arity)
(assemble-listof-assembled-values
(map
(lambda (atomic-arity) ; ([atomic-arity : (U Natural ArityAtLeast)])
(cond
[(natural? atomic-arity)
(number->string atomic-arity)]
[(ArityAtLeast? atomic-arity)
(format "(RT.makeArityAtLeast(~a))"
(ArityAtLeast-value atomic-arity))]))
an-arity))]))
(: assemble-jump (OpArg Blockht -> String))
(define (assemble-jump target blockht)
(define (default)
(format "return(~a)(M);" (assemble-oparg target blockht)))
;; Optimization: if the target of the jump goes to a block whose
;; only body is a si-context-expected_1, then jump directly to that code.
(cond
[(Label? target)
(define target-block (hash-ref blockht (Label-name target)))
(cond
[(block-looks-like-context-expected-values? target-block)
=>
(lambda (expected)
(format "RT.si_context_expected(~a)(M);\n" expected))]
[else
(default)])]
[else
(default)]))
(: block-looks-like-context-expected-values? (BasicBlock -> (U Natural False)))
(define (block-looks-like-context-expected-values? a-block)
(match (BasicBlock-stmts a-block)
[(list (struct Perform ((struct RaiseContextExpectedValuesError! (expected))))
stmts ...)
expected]
[else
#f]))
(: block-looks-like-pop-multiple-values-and-continue? (BasicBlock -> (U False)))
(define (block-looks-like-pop-multiple-values-and-continue? a-block)
;; FIXME!
#f)
(: assemble-display-name ((U Symbol LamPositionalName) -> String))
(define (assemble-display-name name)
(cond
[(symbol? name)
(format "~s" (symbol->string name))]
[(LamPositionalName? name)
;; FIXME: record more interesting information here.
(format "~s" (symbol->string (LamPositionalName-name name)))]))
(: assemble-location ((U Reg Label) Blockht -> String))
(define (assemble-location a-location blockht)
(cond
[(Reg? a-location)
(assemble-reg a-location)]
[(Label? a-location)
(assemble-label a-location)]))
(: assemble-primitive-kernel-value (PrimitiveKernelValue -> String))
(define (assemble-primitive-kernel-value a-prim)
(format "M.primitives[~s]" (symbol->string (PrimitiveKernelValue-id a-prim))))
(: assemble-module-entry (ModuleEntry -> String))
(define (assemble-module-entry entry)
(format "M.modules[~s].label"
(symbol->string (ModuleLocator-name (ModuleEntry-name entry)))))
(: assemble-module-variable-ref (ModuleVariable -> String))
(define (assemble-module-variable-ref var)
(format "M.modules[~s].getExports().get(~s)"
(symbol->string (ModuleLocator-name (ModuleVariable-module-name var)))
(symbol->string (ModuleVariable-name var))))
(: assemble-module-predicate (ModulePredicate -> String))
(define (assemble-module-predicate entry)
(define modname (ModulePredicate-module-name entry))
(define pred (ModulePredicate-pred entry))
(cond
[(eq? pred 'invoked?)
(format "M.modules[~s].isInvoked"
(symbol->string (ModuleLocator-name modname)))]
[(eq? pred 'linked?)
(format "(M.installedModules[~s]!==void(0)&&M.modules[~s]!==undefined)"
(symbol->string (ModuleLocator-name modname))
(symbol->string (ModuleLocator-name modname)))]))
(: assemble-variable-reference (VariableReference -> String))
(define (assemble-variable-reference varref)
(let ([t (VariableReference-toplevel varref)])
(format "(new RT.VariableReference(M.e[M.e.length-~a],~a))"
(add1 (ToplevelRef-depth t))
(ToplevelRef-pos t))))

232
whalesong/selfhost/js-assembler/assemble-open-coded.rkt
View File

@ -1,232 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require (for-syntax racket/base))
; #lang typed/racket/base
(require "assemble-helpers.rkt"
"../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt"
"../compiler/kernel-primitives.rkt"
"assemble-structs.rkt"
racket/string
racket/list
typed/rackunit)
(provide open-code-kernel-primitive-procedure)
;; Conservative estimate: JavaScript evaluators don't like to eat
;; more than some number of arguments at once.
(define MAX-JAVASCRIPT-ARGS-AT-ONCE 100)
;; Workaround for a regression in Racket 5.3.1:
(define-syntax (mycase stx)
(syntax-case stx ()
[(_ op ((x ...) b ...) ...)
#'(let ([v op])
(cond
[(or (eqv? v 'x) ...) b ...] ...))]))
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure Blockht -> String))
(define (open-code-kernel-primitive-procedure op blockht)
(let* ([operator (CallKernelPrimitiveProcedure-operator op)] ;: KernelPrimitiveName/Inline
[operands (map (lambda (op) #;([op : (U OpArg ModuleVariable)]) ; : (Listof String)
(cond
[(OpArg? op)
(assemble-oparg op blockht)]
[(ModuleVariable? op)
(assemble-module-variable-ref op)]))
(CallKernelPrimitiveProcedure-operands op))]
[checked-operands ; : (Listof String)
(map (lambda (dom pos rand typecheck?)
; ([dom : OperandDomain] [pos : Natural] [rand : String]
; [typecheck? : Boolean])
(maybe-typecheck-operand operator dom pos rand typecheck?))
(CallKernelPrimitiveProcedure-expected-operand-types op)
(build-list (length operands) (lambda (i) #;([i : Natural]) i))
operands
(CallKernelPrimitiveProcedure-typechecks? op))])
(mycase operator
[(+)
(cond [(empty? checked-operands)
(assemble-numeric-constant 0)]
[(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
(format "RT.checkedAdd(M, ~a)" (string-join operands ","))]
[else
(format "RT.checkedAddSlowPath(M, [~a])" (string-join operands ","))])]
[(-)
(cond [(empty? (rest checked-operands))
(format "RT.checkedNegate(M, ~a)" (first operands))]
[(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
(format "RT.checkedSub(M, ~a)" (string-join operands ","))]
[else
(format "RT.checkedSubSlowPath(M, [~a])" (string-join operands ","))])]
[(*)
(cond [(empty? checked-operands)
(assemble-numeric-constant 1)]
[(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
(format "RT.checkedMul(M, ~a)" (string-join operands ","))]
[else
(format "RT.checkedMulSlowPath(M, [~a])" (string-join operands ","))])]
[(/)
(assemble-binop-chain "plt.baselib.numbers.divide" checked-operands)]
[(zero?)
(format "RT.checkedIsZero(M, ~a)" (first operands))]
[(add1)
(format "RT.checkedAdd1(M, ~a)" (first operands))]
[(sub1)
(format "RT.checkedSub1(M, ~a)" (first operands))]
[(<)
(assemble-boolean-chain "plt.baselib.numbers.lessThan" checked-operands)]
[(<=)
(assemble-boolean-chain "plt.baselib.numbers.lessThanOrEqual" checked-operands)]
[(=)
(cond
[(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
(format "RT.checkedNumEquals(M, ~a)" (string-join operands ","))]
[else
(format "RT.checkedNumEqualsSlowPath(M, [~a])" (string-join operands ","))])]
[(>)
(cond
[(< (length operands) MAX-JAVASCRIPT-ARGS-AT-ONCE)
(format "RT.checkedGreaterThan(M, ~a)" (string-join operands ","))]
[else
(format "RT.checkedGreaterThanSlowPath(M, [~a])" (string-join operands ","))])]
[(>=)
(assemble-boolean-chain "plt.baselib.numbers.greaterThanOrEqual" checked-operands)]
[(cons)
(format "RT.makePair(~a,~a)"
(first checked-operands)
(second checked-operands))]
[(car)
(format "RT.checkedCar(M, ~a)" (first operands))]
[(caar)
(format "(~a).first.first" (first checked-operands))]
[(cdr)
(format "RT.checkedCdr(M, ~a)" (first operands))]
[(list)
(let loop ([checked-operands checked-operands])
(assemble-listof-assembled-values checked-operands))]
[(list?)
(format "RT.isList(~a)"
(first checked-operands))]
[(vector-ref)
(format "RT.checkedVectorRef(M, ~a)"
(string-join operands ","))]
[(vector-set!)
(format "RT.checkedVectorSet(M, ~a)"
(string-join operands ","))]
[(pair?)
(format "RT.isPair(~a)"
(first checked-operands))]
[(null?)
(format "(~a===RT.NULL)" (first checked-operands))]
[(not)
(format "(~a===false)" (first checked-operands))]
[(eq?)
(format "(~a===~a)" (first checked-operands) (second checked-operands))])))
(: assemble-binop-chain (String (Listof String) -> String))
(define (assemble-binop-chain rator rands)
(cond
[(empty? rands)
""]
[(empty? (rest rands))
(first rands)]
[else
(assemble-binop-chain
rator
(cons (string-append rator "(" (first rands) ", " (second rands) ")")
(rest (rest rands))))]))
(check-equal? (assemble-binop-chain "plt.baselib.numbers.add" '("3" "4" "5"))
"plt.baselib.numbers.add(plt.baselib.numbers.add(3, 4), 5)")
(check-equal? (assemble-binop-chain "plt.baselib.numbers.subtract" '("0" "42"))
"plt.baselib.numbers.subtract(0, 42)")
(: assemble-boolean-chain (String (Listof String) -> String))
(define (assemble-boolean-chain rator rands)
(string-append "("
(string-join (let loop ([rands rands])
(cond
[(empty? rands)
'()]
[(empty? (rest rands))
'()]
[else
(cons (format "(~a(~a,~a))" rator (first rands) (second rands))
(loop (rest rands)))]))
"&&")
")"))
(: assemble-domain-check (Symbol OperandDomain String Natural -> String))
(define (assemble-domain-check caller domain operand-string pos)
(cond
[(eq? domain 'any)
operand-string]
[else
(let ([predicate ; : String
(case domain
[(number)
(format "RT.isNumber")]
[(string)
(format "RT.isString")]
[(list)
(format "RT.isList")]
[(pair)
(format "RT.isPair")]
[(caarpair)
(format "RT.isCaarPair")]
[(box)
(format "RT.isBox")]
[(vector)
(format "RT.isVector")])])
(format "RT.testArgument(M,~s,~a,~a,~a,~s)"
(symbol->string domain)
predicate
operand-string
pos
(symbol->string caller)))]))
(: maybe-typecheck-operand (Symbol OperandDomain Natural String Boolean -> String))
;; Adds typechecks if we can't prove that the operand is of the required type.
(define (maybe-typecheck-operand caller domain-type position operand-string typecheck?)
(cond
[typecheck?
(assemble-domain-check caller domain-type operand-string position)]
[else
operand-string]))

220
whalesong/selfhost/js-assembler/assemble-perform-statement.rkt
View File

@ -1,220 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require whalesong/lang/for)
; #lang typed/racket/base
(require "assemble-helpers.rkt"
"../compiler/il-structs.rkt"
"../compiler/expression-structs.rkt"
"../compiler/lexical-structs.rkt"
"../compiler/kernel-primitives.rkt"
"../parameters.rkt"
"assemble-structs.rkt"
racket/string)
(provide assemble-op-statement)
(: assemble-op-statement (PrimitiveCommand Blockht -> String))
(define (assemble-op-statement op blockht)
(cond
[(CheckToplevelBound!? op)
(format "if (M.e[M.e.length-~a][~a]===void(0)){ RT.raiseUnboundToplevelError(M,M.e[M.e.length-~a].names[~a]); }"
(add1 (CheckToplevelBound!-depth op))
(CheckToplevelBound!-pos op)
(add1 (CheckToplevelBound!-depth op))
(CheckToplevelBound!-pos op))]
[(CheckGlobalBound!? op)
(format "if (M.globals[~s]===void(0)&&M.params.currentNamespace.get(~s)===void(0)){ RT.raiseUnboundToplevelError(M,~s); }"
(symbol->string (CheckGlobalBound!-name op))
(symbol->string (CheckGlobalBound!-name op))
(symbol->string (CheckGlobalBound!-name op)))]
[(CheckClosureAndArity!? op)
"RT.checkClosureAndArity(M);"]
[(CheckPrimitiveArity!? op)
"RT.checkPrimitiveArity(M);"]
[(ExtendEnvironment/Prefix!? op)
(let (; : (Listof (U Symbol False GlobalBucket ModuleVariable))
[names (ExtendEnvironment/Prefix!-names op)])
(format "M.e.push([~a]);M.e[M.e.length-1].names=[~a];"
(string-join (map
(lambda (n) ; ([n : (U Symbol False GlobalBucket ModuleVariable)])
(cond [(symbol? n)
(format "M.params.currentNamespace.get(~s)||M.primitives[~s]"
(symbol->string n)
(symbol->string n))]
[(eq? n #f)
"false"]
[(GlobalBucket? n)
(format "M.globals[~s]!==void(0)?M.globals[~s]:M.params.currentNamespace.get(~s)"
(symbol->string (GlobalBucket-name n))
(symbol->string (GlobalBucket-name n))
(symbol->string (GlobalBucket-name n)))]
;; FIXME: this should be looking at the module path and getting
;; the value here! It shouldn't be looking into Primitives...
[(ModuleVariable? n)
(cond
[(kernel-module-name? (ModuleVariable-module-name n))
(format "M.primitives[~s]"
(symbol->string
(kernel-module-variable->primitive-name n)))]
[else
(define module-name
(symbol->string
(ModuleLocator-name
(ModuleVariable-module-name n))))
(format "[M.modules[~s].prefix,M.modules[~s].getPrefixOffset(~s),{moduleName:~s,name:~s}]"
module-name
module-name
(symbol->string (ModuleVariable-name n))
module-name
(symbol->string (ModuleVariable-name n)))])]))
names)
",")
(string-join (map
(lambda (n) ; ([n : (U Symbol False GlobalBucket ModuleVariable)])
(cond
[(symbol? n)
(format "~s" (symbol->string n))]
[(eq? n #f)
"false"]
[(GlobalBucket? n)
(format "~s" (symbol->string (GlobalBucket-name n)))]
[(ModuleVariable? n)
(format "~s" (symbol->string (ModuleVariable-name n)))]))
names)
",")))]
[(InstallClosureValues!? op)
(format "M.e.push(~a);"
(string-join (build-list (InstallClosureValues!-n op)
(lambda (i) ; ([i : Natural])
(format "M.p.closedVals[~a]" i)))
","))]
[(RestoreEnvironment!? op)
"M.e=M.e[M.e.length-2].slice(0);"]
[(RestoreControl!? op)
(format "M.restoreControl(~a);"
(let ([tag ; : (U DefaultContinuationPromptTag OpArg)
(RestoreControl!-tag op)])
(cond
[(DefaultContinuationPromptTag? tag)
(assemble-default-continuation-prompt-tag)]
[(OpArg? tag)
(assemble-oparg tag blockht)])))]
[(FixClosureShellMap!? op)
(format "M.e[M.e.length-~a].closedVals=[~a];"
(add1 (FixClosureShellMap!-depth op))
(string-join (map
assemble-env-reference/closure-capture
;; The closure values are in reverse order
;; to make it easier to push, in bulk, into
;; the environment (which is also in reversed order)
;; during install-closure-values.
(reverse (FixClosureShellMap!-closed-vals op)))
","))]
[(SetFrameCallee!? op)
(format "M.c[M.c.length-1].p=~a;"
(assemble-oparg (SetFrameCallee!-proc op)
blockht))]
[(SpliceListIntoStack!? op)
(format "M.spliceListIntoStack(~a);"
(assemble-oparg (SpliceListIntoStack!-depth op)
blockht))]
[(UnspliceRestFromStack!? op)
(format "M.unspliceRestFromStack(~a,~a);"
(assemble-oparg (UnspliceRestFromStack!-depth op) blockht)
(assemble-oparg (UnspliceRestFromStack!-length op) blockht))]
[(InstallContinuationMarkEntry!? op)
(string-append "M.installContinuationMarkEntry("
"M.c[M.c.length-1].pendingContinuationMarkKey,"
"M.v);")]
[(RaiseContextExpectedValuesError!? op)
(format "RT.raiseContextExpectedValuesError(M,~a);"
(RaiseContextExpectedValuesError!-expected op))]
[(RaiseArityMismatchError!? op)
(format "RT.raiseArityMismatchError(M,~a,~a);"
(assemble-oparg (RaiseArityMismatchError!-proc op) blockht)
(assemble-oparg (RaiseArityMismatchError!-received op) blockht))]
[(RaiseOperatorApplicationError!? op)
(format "RT.raiseOperatorApplicationError(M,~a);"
(assemble-oparg (RaiseOperatorApplicationError!-operator op) blockht))]
[(RaiseUnimplementedPrimitiveError!? op)
(format "RT.raiseUnimplementedPrimitiveError(M,~s);"
(symbol->string (RaiseUnimplementedPrimitiveError!-name op)))]
[(LinkModule!? op)
(format "RT.PAUSE(
function(restart){
var modname = ~s;
RT.currentModuleLoader(M,modname,
function(){
M.modules[modname] = M.installedModules[modname]();
restart(~a);
},
function(){
RT.raiseModuleLoadingError(M,modname);
});
});"
(symbol->string (ModuleLocator-name (LinkModule!-path op)))
(assemble-label (make-Label (LinkModule!-label op))))]
[(InstallModuleEntry!? op)
(format "M.installedModules[~s]=function(){return new RT.ModuleRecord(~s,~a);}"
(symbol->string (ModuleLocator-name (InstallModuleEntry!-path op)))
(symbol->string (InstallModuleEntry!-name op))
(assemble-label (make-Label (InstallModuleEntry!-entry-point op))))]
[(MarkModuleInvoked!? op)
(format "M.modules[~s].isInvoked=true;"
(symbol->string (ModuleLocator-name (MarkModuleInvoked!-path op))))]
[(AliasModuleAsMain!? op)
(format "M.mainModules.push(~s);"
(symbol->string (ModuleLocator-name (AliasModuleAsMain!-from op))))]
[(FinalizeModuleInvokation!? op)
(define modname (symbol->string (ModuleLocator-name (FinalizeModuleInvokation!-path op))))
(string-append
"(function (selfMod,ns,extNs,prefix) {"
(string-join (for/list ([a-provide (FinalizeModuleInvokation!-provides op)])
(cond [(kernel-module-name? (ModuleProvide-source a-provide))
(format "ns.set(~s, M.primitives[~s]);"
(symbol->string (ModuleProvide-external-name a-provide))
(symbol->string (ModuleProvide-internal-name a-provide)))]
[(equal? (ModuleLocator-name (ModuleProvide-source a-provide))
(ModuleLocator-name (FinalizeModuleInvokation!-path op)))
(string-append (format "ns.set(~s, prefix[selfMod.getPrefixOffset(~s)]);"
(symbol->string (ModuleProvide-internal-name a-provide))
(symbol->string (ModuleProvide-internal-name a-provide)))
;; For JS-derived code, it might be inconvenient to get the bindings by internal
;; name. We assign a separate mapping here to make it easier to access.
(format "extNs.set(~s, prefix[selfMod.getPrefixOffset(~s)]);"
(symbol->string (ModuleProvide-external-name a-provide))
(symbol->string (ModuleProvide-internal-name a-provide))))]
[else
(format "ns.set(~s, M.modules[~s].getExports().get(~s));"
(symbol->string (ModuleProvide-external-name a-provide))
(symbol->string (ModuleLocator-name (ModuleProvide-source a-provide)))
(symbol->string (ModuleProvide-internal-name a-provide)))]))
"")
(format "}(M.modules[~s],M.modules[~s].getExports(),M.modules[~s].getExternalExports(),M.modules[~s].prefix));" modname modname modname modname))]))

21
whalesong/selfhost/js-assembler/assemble-structs.rkt
View File

@ -1,21 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
; #lang typed/racket/base
(provide (all-defined-out))
(require "../compiler/il-structs.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Assembly
(define-struct: BasicBlock ([name : Symbol]
[stmts : (Listof UnlabeledStatement)])
#:transparent)
;; Represents a hashtable from symbols to basic blocks
(define-type Blockht (HashTable Symbol BasicBlock))

714
whalesong/selfhost/js-assembler/assemble.rkt
View File

@ -1,714 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt" whalesong/lang/for)
; #lang typed/racket/base
;; Assembles the statement stream into JavaScript.
(require "assemble-structs.rkt"
"assemble-helpers.rkt"
"assemble-expression.rkt"
"assemble-perform-statement.rkt"
"fracture.rkt"
"../compiler/il-structs.rkt"
"../sets.rkt"
"../helpers.rkt"
racket/string
racket/list)
; (require/typed "../logger.rkt" [log-debug (String -> Void)])
(provide assemble/write-invoke
assemble-statement)
;; Parameter that controls the generation of a trace.
(define emit-debug-trace? #f)
(: assemble/write-invoke ((Listof Statement) Output-Port (U 'no-trampoline 'without-preemption 'with-preemption) -> Void))
;; Writes out the JavaScript code that represents the anonymous invocation expression.
;; What's emitted is a function expression that, when invoked, runs the
;; statements.
(define (assemble/write-invoke stmts op trampoline-option)
(parameterize ([current-interned-symbol-table ((inst make-hash Symbol Symbol))]
[current-interned-constant-closure-table ((inst make-hash Symbol MakeCompiledProcedure))])
(display "(function(M, success, fail, params) {\n" op)
(display "\"use strict\";\n" op)
(display "var param;\n" op)
(display "var RT = plt.runtime;\n" op)
(define-values (basic-blocks entry-points) (fracture stmts))
(: function-entry-and-exit-names (Setof Symbol))
(define function-entry-and-exit-names
(list->set (get-function-entry-and-exit-names stmts)))
(: blockht : Blockht)
(define blockht (make-hash))
(for ([b basic-blocks])
(hash-set! blockht (BasicBlock-name b) b))
(write-blocks basic-blocks
blockht
(list->set entry-points)
function-entry-and-exit-names
op)
(write-linked-label-attributes stmts blockht op)
(display (assemble-current-interned-symbol-table) op)
(display (assemble-current-interned-constant-closure-table) op)
(display "M.params.currentErrorHandler = fail;\n" op)
(display #<<EOF
for (param in params) {
if (Object.hasOwnProperty.call(params, param)) {
M.params[param] = params[param];
}
}
EOF
op)
(cond [(eq? trampoline-option 'no-trampoline)
;; If it's a module statement, we just want to call it directly, to get things loaded.
(fprintf op "~a(M); })"
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))]
[else
;; Otherwise, we want to run under a trampolining context.
(display "M.c.push(new RT.CallFrame(function(M){ setTimeout(success, 0); },M.p));\n" op)
(fprintf op "M.trampoline(~a, ~a); })"
(assemble-label (make-Label (BasicBlock-name (first basic-blocks))))
(cond [(eq? trampoline-option 'with-preemption)
"false"]
[(eq? trampoline-option 'without-preemption)
"true"]))])))
(: write-blocks ((Listof BasicBlock) Blockht (Setof Symbol) (Setof Symbol) Output-Port -> Void))
;; Write out all the basic blocks associated to an entry point.
(define (write-blocks blocks blockht entry-points function-entry-and-exit-names op)
;; Since there may be cycles between the blocks, we cut the cycles by
;; making them entry points as well.
(insert-cycles-as-entry-points! entry-points blockht)
(set-for-each (lambda (s) #;([s : Symbol])
(log-debug (format "Emitting code for basic block ~s" s))
(assemble-basic-block (hash-ref blockht s)
blockht
entry-points
function-entry-and-exit-names
op)
(newline op))
entry-points))
(: insert-cycles-as-entry-points! ((Setof Symbol) Blockht -> 'ok))
(define (insert-cycles-as-entry-points! entry-points blockht)
(define visited ((inst new-seteq Symbol)))
(: loop ((Listof Symbol) -> 'ok))
(define (loop queue)
(cond
[(empty? queue)
'ok]
[else
;; Visit the next one.
(define next-to-visit (first queue))
(cond
[(set-contains? visited next-to-visit)
#;(unless (set-contains? entry-points next-to-visit)
(log-debug (format "Promoting ~a to an entry point" next-to-visit))
(set-insert! entry-points next-to-visit))
(loop (rest queue))]
[else
(set-insert! visited next-to-visit)
(set-insert! entry-points next-to-visit)
(loop (list-union (basic-block-out-edges (hash-ref blockht next-to-visit))
(rest queue)))])]))
(loop (set->list entry-points)))
(: write-linked-label-attributes ((Listof Statement) Blockht Output-Port -> 'ok))
(define (write-linked-label-attributes stmts blockht op)
(cond
[(empty? stmts)
'ok]
[else
(let ([stmt ; : Statement
(first stmts)])
(define (next) (write-linked-label-attributes (rest stmts) blockht op))
(cond
[(symbol? stmt)
(next)]
[(LinkedLabel? stmt)
;; Setting up multiple-value-return.
;; Optimization: in the most common case (expecting only one), we optimize away
;; the assignment, because there's a distinguished instruction, and it's implied
;; that if .mvr is missing, that the block only expects one.
(define linked-to-block (hash-ref blockht (LinkedLabel-linked-to stmt)))
(cond
[(block-looks-like-context-expected-values? linked-to-block)
=> (lambda (expected)
(cond
[(= expected 1)
(void)]
[else
(fprintf op "~a.mvr=RT.si_context_expected(~a);\n"
(munge-label-name (make-Label (LinkedLabel-label stmt)))
expected)]))]
[else
(fprintf op "~a.mvr=~a;\n"
(munge-label-name (make-Label (LinkedLabel-label stmt)))
(assemble-label (make-Label (LinkedLabel-linked-to stmt))))])
(next)]
[(DebugPrint? stmt)
(next)]
[(MarkEntryPoint? stmt)
(next)]
[(AssignImmediate? stmt)
(next)]
[(AssignPrimOp? stmt)
(next)]
[(Perform? stmt)
(next)]
[(TestAndJump? stmt)
(next)]
[(Goto? stmt)
(next)]
[(PushEnvironment? stmt)
(next)]
[(PopEnvironment? stmt)
(next)]
[(PushImmediateOntoEnvironment? stmt)
(next)]
[(PushControlFrame/Generic? stmt)
(next)]
[(PushControlFrame/Call? stmt)
(next)]
[(PushControlFrame/Prompt? stmt)
(next)]
[(PopControlFrame? stmt)
(next)]
[(Comment? stmt)
(next)]))]))
(: assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
(define (assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)
(cond
[(block-looks-like-context-expected-values? a-basic-block)
=>
(lambda (expected)
(cond
[(= expected 1)
'ok]
[else
(fprintf op "var ~a=RT.si_context_expected(~a);\n"
(munge-label-name (make-Label (BasicBlock-name a-basic-block)))
expected)
'ok]))]
[(block-looks-like-pop-multiple-values-and-continue? a-basic-block)
=>
(lambda (target)
(fprintf op "var ~a=RT.si_pop_multiple-values-and-continue(~a);"
(munge-label-name (make-Label (BasicBlock-name a-basic-block)))
target))]
[else
(default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
(: default-assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
(define (default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)
(fprintf op "var ~a=function(M){"
(assemble-label (make-Label (BasicBlock-name a-basic-block))))
(define is-self-looping?
(let ()
(cond [(not (empty? (BasicBlock-stmts a-basic-block)))
(define last-stmt
(last (BasicBlock-stmts a-basic-block)))
(cond
[(Goto? last-stmt)
(define target (Goto-target last-stmt))
(equal? target (make-Label (BasicBlock-name a-basic-block)))]
[else #f])]
[else #f])))
(cond
[is-self-looping?
(fprintf op "while(true){")
(when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
(fprintf op "if(--M.cbt<0){throw ~a;}\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block)))))
(assemble-block-statements (BasicBlock-name a-basic-block)
(drop-right (BasicBlock-stmts a-basic-block) 1)
blockht
entry-points
op)
(fprintf op "}")]
[else
(when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
(fprintf op "if(--M.cbt<0){throw ~a;}\n"
(assemble-label (make-Label (BasicBlock-name a-basic-block)))))
(assemble-block-statements (BasicBlock-name a-basic-block)
(BasicBlock-stmts a-basic-block)
blockht
entry-points
op)])
(display "};\n" op)
'ok)
(: assemble-block-statements (Symbol (Listof UnlabeledStatement) Blockht (Setof Symbol) Output-Port -> 'ok))
(define (assemble-block-statements name stmts blockht entry-points op)
(: default (UnlabeledStatement -> 'ok))
(define (default stmt)
;(when (and (empty? (rest stmts))
; (not (Goto? stmt)))
; (log-debug (format "Last statement of the block ~a is not a goto" name)))
(display (assemble-statement stmt blockht) op)
(newline op)
(assemble-block-statements name
(rest stmts)
blockht
entry-points
op))
(cond [(empty? stmts)
'ok]
[else
(define stmt (first stmts))
(cond
[(MarkEntryPoint? stmt)
(default stmt)]
[(DebugPrint? stmt)
(default stmt)]
[(AssignImmediate? stmt)
(default stmt)]
[(AssignPrimOp? stmt)
(default stmt)]
[(Perform? stmt)
(default stmt)]
[(TestAndJump? stmt)
(define test (TestAndJump-op stmt))
(: test-code String)
(define test-code (cond
[(TestFalse? test)
(format "if(~a===false)"
(assemble-oparg (TestFalse-operand test)
blockht))]
[(TestTrue? test)
(format "if(~a!==false)"
(assemble-oparg (TestTrue-operand test)
blockht))]
[(TestOne? test)
(format "if(~a===1)"
(assemble-oparg (TestOne-operand test)
blockht))]
[(TestZero? test)
(format "if(~a===0)"
(assemble-oparg (TestZero-operand test)
blockht))]
[(TestClosureArityMismatch? test)
(format "if(!RT.isArityMatching((~a).racketArity,~a))"
(assemble-oparg (TestClosureArityMismatch-closure test)
blockht)
(assemble-oparg (TestClosureArityMismatch-n test)
blockht))]))
(display test-code op)
(display "{" op)
(cond
[(set-contains? entry-points (TestAndJump-label stmt))
(display (assemble-jump (make-Label (TestAndJump-label stmt))
blockht) op)]
[else
(assemble-block-statements (BasicBlock-name
(hash-ref blockht (TestAndJump-label stmt)))
(BasicBlock-stmts
(hash-ref blockht (TestAndJump-label stmt)))
blockht
entry-points
op)])
(display "}else{" op)
(assemble-block-statements name (rest stmts) blockht entry-points op)
(display "}" op)
'ok]
[(Goto? stmt)
(let loop ([stmt stmt])
(define target (Goto-target stmt))
(cond
[(Label? target)
(define target-block (hash-ref blockht (Label-name target)))
(define target-name (BasicBlock-name target-block))
(define target-statements (BasicBlock-stmts target-block))
(cond
;; Optimization: if the target block consists of a single goto,
;; inline and follow the goto.
[(and (not (empty? target-statements))
(= 1 (length target-statements))
(Goto? (first target-statements)))
(loop (first target-statements))]
[(set-contains? entry-points (Label-name target))
(display (assemble-statement stmt blockht) op)
'ok]
[else
(log-debug (format "Assembling inlined jump into ~a" (Label-name target)) )
(assemble-block-statements target-name
target-statements
blockht
entry-points
op)])]
[(Reg? target)
(display (assemble-statement stmt blockht) op)
'ok]
[(ModuleEntry? target)
(display (assemble-statement stmt blockht) op)
'ok]
[(CompiledProcedureEntry? target)
(display (assemble-statement stmt blockht) op)
'ok]))]
[(PushControlFrame/Generic? stmt)
(default stmt)]
[(PushControlFrame/Call? stmt)
(default stmt)]
[(PushControlFrame/Prompt? stmt)
(default stmt)]
[(PopControlFrame? stmt)
(default stmt)]
[(PushEnvironment? stmt)
(default stmt)]
[(PopEnvironment? stmt)
(default stmt)]
[(PushImmediateOntoEnvironment? stmt)
(default stmt)]
[(Comment? stmt)
(default stmt)])]))
(: basic-block-out-edges (BasicBlock -> (Listof Symbol)))
;; Returns the neighboring blocks of this block.
(define (basic-block-out-edges a-block)
(: loop ((Listof UnlabeledStatement) -> (Listof Symbol)))
(define (loop stmts)
(: default (-> (Listof Symbol)))
(define (default)
(loop (rest stmts)))
(cond [(empty? stmts)
empty]
[else
(define stmt (first stmts))
(cond
[(MarkEntryPoint? stmt)
(default)]
[(DebugPrint? stmt)
(default)]
[(AssignImmediate? stmt)
(default)]
[(AssignPrimOp? stmt)
(default)]
[(Perform? stmt)
(default)]
[(TestAndJump? stmt)
(cons (TestAndJump-label stmt)
(loop (rest stmts)))]
[(Goto? stmt)
(define target (Goto-target stmt))
(cond
[(Label? target)
(cons (Label-name target)
(loop (rest stmts)))]
[(Reg? target)
(default)]
[(ModuleEntry? target)
(default)]
[(CompiledProcedureEntry? target)
(default)])]
[(PushControlFrame/Generic? stmt)
(default)]
[(PushControlFrame/Call? stmt)
(default)]
[(PushControlFrame/Prompt? stmt)
(default)]
[(PopControlFrame? stmt)
(default)]
[(PushEnvironment? stmt)
(default)]
[(PopEnvironment? stmt)
(default)]
[(PushImmediateOntoEnvironment? stmt)
(default)]
[(Comment? stmt)
(default)])]))
(loop (BasicBlock-stmts a-block)))
(: assemble-statement (UnlabeledStatement Blockht -> String))
;; Generates the code to assemble a statement.
(define (assemble-statement stmt blockht)
(define assembled
(cond
[(MarkEntryPoint? stmt)
;; Marking the entry point to the lambda should have no other effect.
""]
[(DebugPrint? stmt)
(format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));"
(assemble-oparg (DebugPrint-value stmt)
blockht))]
[(AssignImmediate? stmt)
(let ([t ; : (String -> String)
(assemble-target (AssignImmediate-target stmt))]
[v ; : OpArg
(AssignImmediate-value stmt)])
(t (assemble-oparg v blockht)))]
[(AssignPrimOp? stmt)
((assemble-target (AssignPrimOp-target stmt))
(assemble-op-expression (AssignPrimOp-op stmt)
blockht))]
[(Perform? stmt)
(assemble-op-statement (Perform-op stmt) blockht)]
[(TestAndJump? stmt)
(let* ([test ; : PrimitiveTest
(TestAndJump-op stmt)]
[jump ; : String
(assemble-jump
(make-Label (TestAndJump-label stmt))
blockht)])
;; to help localize type checks, we add a type annotation here.
(ann (cond
[(TestFalse? test)
(format "if(~a===false){~a}"
(assemble-oparg (TestFalse-operand test)
blockht)
jump)]
[(TestTrue? test)
(format "if(~a!==false){~a}"
(assemble-oparg (TestTrue-operand test)
blockht)
jump)]
[(TestOne? test)
(format "if(~a===1){~a}"
(assemble-oparg (TestOne-operand test)
blockht)
jump)]
[(TestZero? test)
(format "if(~a===0){~a}"
(assemble-oparg (TestZero-operand test)
blockht)
jump)]
[(TestClosureArityMismatch? test)
(format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
(assemble-oparg (TestClosureArityMismatch-closure test)
blockht)
(assemble-oparg (TestClosureArityMismatch-n test)
blockht)
jump)])
String))]
[(Goto? stmt)
(assemble-jump (Goto-target stmt)
blockht)]
[(PushControlFrame/Generic? stmt)
"M.c.push(new RT.Frame());"]
[(PushControlFrame/Call? stmt)
(format "M.c.push(new RT.CallFrame(~a,M.p));"
(let ([label ; : (U Symbol LinkedLabel)
(PushControlFrame/Call-label stmt)])
(cond
[(symbol? label)
(assemble-label (make-Label label))]
[(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)))])))]
[(PushControlFrame/Prompt? stmt)
(format "M.c.push(new RT.CallFrame(~a,M.p)); M.addPrompt(~a,false,M.e.length);"
(let ([label ; : (U Symbol LinkedLabel)
(PushControlFrame/Prompt-label stmt)])
(cond
[(symbol? label)
(assemble-label (make-Label label))]
[(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)))]))
(let ([tag ; : (U DefaultContinuationPromptTag OpArg)
(PushControlFrame/Prompt-tag stmt)])
(cond
[(DefaultContinuationPromptTag? tag)
(assemble-default-continuation-prompt-tag)]
[(OpArg? tag)
(assemble-oparg tag blockht)])))]
[(PopControlFrame? stmt)
"M.c.pop();"]
[(PushEnvironment? stmt)
(cond [(= (PushEnvironment-n stmt) 0)
""]
[(PushEnvironment-unbox? stmt)
(format "M.e.push(~a);" (string-join
(build-list (PushEnvironment-n stmt)
(lambda (i) ; ([i : Natural])
"[void(0)]"))
","))]
[else
(format "M.e.push(~a);" (string-join
(build-list (PushEnvironment-n stmt)
(lambda (i) ; ([i : Natural])
"void(0)"))
","))
;(format "M.e.length+=~a;" (PushEnvironment-n stmt))
])]
[(PopEnvironment? stmt)
(let ([skip ; : OpArg
(PopEnvironment-skip stmt)])
(cond
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
(cond [(equal? (PopEnvironment-n stmt)
(make-Const 1))
"M.e.pop();"]
[else
(format "M.e.length-=~a;"
(assemble-oparg (PopEnvironment-n stmt) blockht))])]
[else
(define skip (PopEnvironment-skip stmt))
(define n (PopEnvironment-n stmt))
(cond
[(and (Const? skip) (Const? n))
(format "M.e.splice(M.e.length-~a,~a);"
(+ (ensure-natural (Const-const skip))
(ensure-natural (Const-const n)))
(Const-const n))]
[else
(format "M.e.splice(M.e.length-(~a+~a),~a);"
(assemble-oparg skip blockht)
(assemble-oparg n blockht)
(assemble-oparg n blockht))])]))]
[(PushImmediateOntoEnvironment? stmt)
(format "M.e.push(~a);"
(let ([val-string ; : String
(cond [(PushImmediateOntoEnvironment-box? stmt)
(format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)
blockht))]
[else
(assemble-oparg (PushImmediateOntoEnvironment-value stmt)
blockht)])])
val-string))]
[(Comment? stmt)
(format "//~s\n" (Comment-val stmt))]))
(cond
[emit-debug-trace?
(string-append
(format "if(window.console!==void(0)&&typeof(window.console.log)==='function'){window.console.log(~s);\n}"
(format "~a" stmt))
assembled)]
[else
assembled]))
; (define-predicate natural? Natural)
(: ensure-natural (Any -> Natural))
(define (ensure-natural n)
(if (natural? n)
n
(error 'ensure-natural)))
(: get-function-entry-and-exit-names ((Listof Statement) -> (Listof Symbol)))
(define (get-function-entry-and-exit-names stmts)
(cond
[(empty? stmts)
'()]
[else
(define first-stmt (first stmts))
(cond
[(MarkEntryPoint? first-stmt)
(cons (MarkEntryPoint-label first-stmt)
(get-function-entry-and-exit-names (rest stmts)))]
[(LinkedLabel? first-stmt)
(cons (LinkedLabel-label first-stmt)
(cons (LinkedLabel-linked-to first-stmt)
(get-function-entry-and-exit-names (rest stmts))))]
[(AssignPrimOp? first-stmt)
(define op (AssignPrimOp-op first-stmt))
(cond
[(MakeCompiledProcedure? op)
(cons (MakeCompiledProcedure-label op)
(get-function-entry-and-exit-names (rest stmts)))]
[(MakeCompiledProcedureShell? first-stmt)
(cons (MakeCompiledProcedureShell-label op)
(get-function-entry-and-exit-names (rest stmts)))]
[else
(get-function-entry-and-exit-names (rest stmts))])]
[else
(get-function-entry-and-exit-names (rest stmts))])]))

7
whalesong/selfhost/js-assembler/cache.rkt
View File

@ -1,7 +0,0 @@
#lang whalesong
(define-struct cached-entry (real-path ;; path to a module.
whalesong-version ;; string
md5 ;; md5 of the original source in real-path
bytes)
#:transparent) ;; bytes

135
whalesong/selfhost/js-assembler/check-valid-module-source.rkt
View File

@ -1,135 +0,0 @@
#lang racket/base
(provide check-valid-module-source
[struct-out exn:invalid-module-source])
(require syntax/kerncase
syntax/modresolve
racket/path
"../parameters.rkt"
"../parser/path-rewriter.rkt")
(struct exn:invalid-module-source exn:fail ())
(define (abort-abort #:reason (reason "Invalid module source"))
(fprintf (current-report-port) "Aborting compilation.\n")
(raise (exn:invalid-module-source reason
(current-continuation-marks))))
(define ns (make-base-namespace))
(define (looks-like-old-moby-or-js-vm? module-source-path)
(or (call-with-input-file* module-source-path
(lambda (ip) (regexp-match #px"^\\s*#lang\\s+planet\\s+dyoo/moby" ip)))
(call-with-input-file* module-source-path
(lambda (ip) (regexp-match #px"^\\s*#lang\\s+planet\\s+dyoo/js-vm" ip)))))
(define (check-valid-module-source module-source-path)
;; Check that the file exists.
(unless (file-exists? module-source-path)
(fprintf (current-report-port) "ERROR: Can't read a Racket module from ~e. The file does not appear to exist.\n"
module-source-path)
(abort-abort))
;; Is the file one that we know how to symbolically resolve?
(cond [(rewrite-path module-source-path)
(void)]
[else
(fprintf (current-report-port)
"ERROR: The file ~e appears to be outside the root package directory ~e. You may need to use --root-dir.\n"
module-source-path
(current-root-path))
(abort-abort)])
;; Does it look like something out of moby or js-vm? Abort early, because if we don't do
;; this up front, Racket will try to install the deprecated module, and that's bad.
(when (looks-like-old-moby-or-js-vm? module-source-path)
(fprintf (current-report-port) "ERROR: The program in ~e appears to be written using the deprecated project js-vm or Moby.\n\nPlease change the lang line to:\n\n #lang whalesong\n\ninstead.\n"
module-source-path)
(abort-abort))
;; Check that it looks like a module.
(define stx
(with-handlers ([exn:fail?
(lambda (exn)
;; We can't even get the bytecode for the file.
;; Fail immediately.
(fprintf (current-report-port) "ERROR: Can't read a Racket module from ~e. The file may be ill-formed or be written in a language that Whalesong doesn't recognize.\n"
module-source-path)
(fprintf (current-report-port) "\nFor reference, the error message produced when trying to read ~e is:\n\n" module-source-path)
(fprintf (current-report-port) "~a\n" (exn-message exn))
(abort-abort))])
(parameterize ([read-accept-reader #t]
[read-accept-lang #t])
(call-with-input-file* module-source-path
(lambda (ip)
(port-count-lines! ip)
(read-syntax module-source-path ip))))))
(define relative-language-stx
(kernel-syntax-case stx #t
[(module name language body ...)
#'language]
[else
(fprintf (current-report-port) "ERROR: Can't read a Racket module from ~e. The file exists, but does not appear to be a Racket module.\n"
module-source-path)
(abort-abort)]))
;; Check that the module is written in a language that we allow.
(define resolved-language-path
(resolve-module-path (syntax->datum relative-language-stx)
module-source-path))
(cond
[(eq? resolved-language-path '#%kernel)
(void)]
[(path? resolved-language-path)
(define normalized-resolved-language-path
(normalize-path resolved-language-path))
(cond
[(within-root-path? normalized-resolved-language-path)
(void)]
[(within-whalesong-path? normalized-resolved-language-path)
(void)]
[else
;; Something bad is about to happen, as the module is written
;; in a language that we, most likely, can't compile.
;;
;; Let's see if we can provide a good error message here
(fprintf (current-report-port) "ERROR: The file ~e is a Racket module, but is written in the language ~a [~e], which Whalesong does not know how to compile.\n"
module-source-path
(syntax->datum relative-language-stx)
normalized-resolved-language-path)
(abort-abort)])])
;; Once we know that the module is in a language we allow, we
;; check that the file compiles.
(with-handlers ([exn:fail?
(lambda (exn)
(fprintf (current-report-port) "ERROR: the racket module ~e raises a compile-time error during compilation." module-source-path)
(fprintf (current-report-port) "\n\nFor reference, the error message produced during compilation is the following:\n\n")
(fprintf (current-report-port) "~a\n" (exn-message exn))
(newline (current-report-port))
(abort-abort))])
(parameterize ([current-namespace ns]
[current-load-relative-directory
(path-only module-source-path)]
[current-directory
(path-only module-source-path)])
(compile stx))))

357
whalesong/selfhost/js-assembler/collect-jump-targets.rkt
View File

@ -1,357 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
; #lang typed/racket/base
(require "../compiler/expression-structs.rkt"
"../compiler/il-structs.rkt"
"../compiler/lexical-structs.rkt"
"../helpers.rkt"
"../parameters.rkt"
racket/list)
(provide collect-general-jump-targets
collect-entry-points)
(: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol)))
;; collects all the labels that are potential targets for GOTOs or branches.
(define (collect-general-jump-targets stmts)
(: collect-statement (Statement -> (Listof Symbol)))
(define (collect-statement stmt)
(cond
[(symbol? stmt)
empty]
[(LinkedLabel? stmt)
(list (LinkedLabel-label stmt)
(LinkedLabel-linked-to stmt))]
[(DebugPrint? stmt)
empty]
[(MarkEntryPoint? stmt)
(list (MarkEntryPoint-label stmt))]
[(AssignImmediate? stmt)
(let ([v ; : OpArg
(AssignImmediate-value stmt)])
(collect-input v))]
[(AssignPrimOp? stmt)
(collect-primitive-operator (AssignPrimOp-op stmt))]
[(Perform? stmt)
(collect-primitive-command (Perform-op stmt))]
[(TestAndJump? stmt)
(list (TestAndJump-label stmt))]
[(Goto? stmt)
(collect-input (Goto-target stmt))]
[(PushEnvironment? stmt)
empty]
[(PopEnvironment? stmt)
empty]
[(PushImmediateOntoEnvironment? stmt)
(collect-input (PushImmediateOntoEnvironment-value stmt))]
[(PushControlFrame/Generic? stmt)
empty]
[(PushControlFrame/Call? stmt)
(label->labels (PushControlFrame/Call-label stmt))]
[(PushControlFrame/Prompt? stmt)
(label->labels (PushControlFrame/Prompt-label stmt))]
[(PopControlFrame? stmt)
empty]
[(Comment? stmt)
empty]))
(: collect-input (OpArg -> (Listof Symbol)))
(define (collect-input an-input)
(cond
[(Reg? an-input)
empty]
[(Const? an-input)
empty]
[(Label? an-input)
(list (Label-name an-input))]
[(EnvLexicalReference? an-input)
empty]
[(EnvPrefixReference? an-input)
empty]
[(EnvWholePrefixReference? an-input)
empty]
[(SubtractArg? an-input)
(append (collect-input (SubtractArg-lhs an-input))
(collect-input (SubtractArg-rhs an-input)))]
[(ControlStackLabel? an-input)
empty]
[(ControlStackLabel/MultipleValueReturn? an-input)
empty]
[(ControlFrameTemporary? an-input)
empty]
[(CompiledProcedureEntry? an-input)
(collect-input (CompiledProcedureEntry-proc an-input))]
[(CompiledProcedureClosureReference? an-input)
(collect-input (CompiledProcedureClosureReference-proc an-input))]
[(PrimitiveKernelValue? an-input)
empty]
[(ModuleEntry? an-input)
empty]
[(ModulePredicate? an-input)
empty]
[(VariableReference? an-input)
empty]))
(: collect-location ((U Reg Label) -> (Listof Symbol)))
(define (collect-location a-location)
(cond
[(Reg? a-location)
empty]
[(Label? a-location)
(list (Label-name a-location))]))
(: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol)))
(define (collect-primitive-operator op)
(cond
[(GetCompiledProcedureEntry? op)
empty]
[(MakeCompiledProcedure? op)
(list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op)
empty]
[(CaptureEnvironment? op)
empty]
[(CaptureControl? op)
empty]
[(MakeBoxedEnvironmentValue? op)
empty]
[(CallKernelPrimitiveProcedure? op)
empty]
[(ModuleVariable? op)
empty]
[(PrimitivesReference? op)
empty]
[(GlobalsReference? op)
empty]))
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
(define (collect-primitive-command op)
(cond
[(InstallModuleEntry!? op)
(list (InstallModuleEntry!-entry-point op))]
[else
empty]))
(: start-time Real)
(define start-time (current-inexact-milliseconds))
(: result (Listof Symbol))
(define result
(unique/eq?
(let loop ; : (Listof Symbol)
([stmts ; : (Listof Statement)
stmts])
(cond [(empty? stmts)
empty]
[else
(let ([stmt ; : Statement
(first stmts)])
(append (collect-statement stmt)
(loop (rest stmts))))]))))
(: end-time Real)
(define end-time (current-inexact-milliseconds))
(fprintf (current-timing-port) " collect-general-jump-targets: ~a milliseconds\n" (- end-time start-time))
result)
(: collect-entry-points ((Listof Statement) -> (Listof Symbol)))
;; collects all the labels that are general entry points. The entry points are
;; from the starting basic block, from functions headers, and finally return points.
(define (collect-entry-points stmts)
(: collect-statement (Statement -> (Listof Symbol)))
(define (collect-statement stmt)
(cond
[(symbol? stmt)
empty]
[(LinkedLabel? stmt)
(list (LinkedLabel-label stmt)
(LinkedLabel-linked-to stmt))]
[(MarkEntryPoint? stmt)
(list (MarkEntryPoint-label stmt))]
[(DebugPrint? stmt)
empty]
[(AssignImmediate? stmt)
(let ([v ; : OpArg
(AssignImmediate-value stmt)])
(collect-input v))]
[(AssignPrimOp? stmt)
(collect-primitive-operator (AssignPrimOp-op stmt))]
[(Perform? stmt)
(collect-primitive-command (Perform-op stmt))]
[(TestAndJump? stmt)
empty]
[(Goto? stmt)
empty]
[(PushEnvironment? stmt)
empty]
[(PopEnvironment? stmt)
empty]
[(PushImmediateOntoEnvironment? stmt)
(collect-input (PushImmediateOntoEnvironment-value stmt))]
[(PushControlFrame/Generic? stmt)
empty]
[(PushControlFrame/Call? stmt)
(label->labels (PushControlFrame/Call-label stmt))]
[(PushControlFrame/Prompt? stmt)
(label->labels (PushControlFrame/Prompt-label stmt))]
[(PopControlFrame? stmt)
empty]
[(Comment? stmt)
empty]))
(: collect-input (OpArg -> (Listof Symbol)))
(define (collect-input an-input)
(cond
[(Reg? an-input)
empty]
[(Const? an-input)
empty]
[(Label? an-input)
(list (Label-name an-input))]
[(EnvLexicalReference? an-input)
empty]
[(EnvPrefixReference? an-input)
empty]
[(EnvWholePrefixReference? an-input)
empty]
[(SubtractArg? an-input)
(append (collect-input (SubtractArg-lhs an-input))
(collect-input (SubtractArg-rhs an-input)))]
[(ControlStackLabel? an-input)
empty]
[(ControlStackLabel/MultipleValueReturn? an-input)
empty]
[(ControlFrameTemporary? an-input)
empty]
[(CompiledProcedureEntry? an-input)
(collect-input (CompiledProcedureEntry-proc an-input))]
[(CompiledProcedureClosureReference? an-input)
(collect-input (CompiledProcedureClosureReference-proc an-input))]
[(PrimitiveKernelValue? an-input)
empty]
[(ModuleEntry? an-input)
empty]
[(ModulePredicate? an-input)
empty]
[(VariableReference? an-input)
empty]))
(: collect-location ((U Reg Label) -> (Listof Symbol)))
(define (collect-location a-location)
(cond
[(Reg? a-location)
empty]
[(Label? a-location)
(list (Label-name a-location))]))
(: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol)))
(define (collect-primitive-operator op)
(cond
[(GetCompiledProcedureEntry? op)
empty]
[(MakeCompiledProcedure? op)
(list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op)
empty]
[(CaptureEnvironment? op)
empty]
[(CaptureControl? op)
empty]
[(MakeBoxedEnvironmentValue? op)
empty]
[(CallKernelPrimitiveProcedure? op)
empty]
[(ModuleVariable? op)
empty]
[(PrimitivesReference? op)
empty]
[(GlobalsReference? op)
empty]))
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
(define (collect-primitive-command op)
(cond
[(InstallModuleEntry!? op)
(list (InstallModuleEntry!-entry-point op))]
[else
empty]
;; currently written this way because I'm hitting some bad type-checking behavior.
#;([(CheckToplevelBound!? op)
empty]
[(CheckClosureAndArity!? op)
empty]
[(CheckPrimitiveArity!? op)
empty]
[(ExtendEnvironment/Prefix!? op)
empty]
[(InstallClosureValues!? op)
empty]
[(RestoreEnvironment!? op)
empty]
[(RestoreControl!? op)
empty]
[(SetFrameCallee!? op)
empty]
[(SpliceListIntoStack!? op)
empty]
[(UnspliceRestFromStack!? op)
empty]
[(FixClosureShellMap!? op)
empty]
[(InstallContinuationMarkEntry!? op)
empty]
[(RaiseContextExpectedValuesError!? op)
empty]
[(RaiseArityMismatchError!? op)
empty]
[(RaiseOperatorApplicationError!? op)
empty])))
(unique/eq?
(let loop ; : (Listof Symbol)
([stmts ; : (Listof Statement)
stmts])
(cond [(empty? stmts)
empty]
[else
(let ([stmt ; : Statement
(first stmts)])
(append (collect-statement stmt)
(loop (rest stmts))))]))))
(: label->labels ((U Symbol LinkedLabel) -> (Listof Symbol)))
(define (label->labels label)
(cond
[(symbol? label)
(list label)]
[(LinkedLabel? label)
(list (LinkedLabel-label label)
(LinkedLabel-linked-to label))]))

51
whalesong/selfhost/js-assembler/find-primitive-implemented.rkt
View File

@ -1,51 +0,0 @@
#lang racket/base
(require racket/runtime-path
racket/list
(for-syntax racket/base)
"../compiler/arity-structs.rkt")
;; Provides a list of symbols of the function implemented primitively. Knowing
;; this allows us to do certain procedure applications more efficiently without
;; touching the stack so much.
(provide primitive-ids)
(define a-regexp
#px"installPrimitiveProcedure\\s*\\(\\s*['\"]([^'\"]+)['\"]\\s*,\\s*([^\n]+)\n")
(define-runtime-path baselib-primitives.js
(build-path "runtime-src" "baselib-primitives.js"))
(define ip (open-input-file baselib-primitives.js))
(define (parse-arity-string s)
(define arity
(let loop ([s s])
(let ([s (regexp-replace #px",\\s+$" s "")])
(cond
[(regexp-match #px"^(\\d+)" s)
=>
(lambda (m) (string->number (second m)))]
[(regexp-match #px"^makeList\\((.+)\\)" s)
=>
(lambda (m)
(map string->number (regexp-split #px"\\s*,\\s*" (second m))))]
[(regexp-match #px"^baselib.arity.makeArityAtLeast\\((\\d+)\\)" s)
=>
(lambda (m)
(ArityAtLeast (string->number (second m))))]
[else
(error 'parse-arity-string "How to parse? ~e" s)]))))
arity)
(define primitive-ids
(let loop ()
(let ([a-match (regexp-match a-regexp ip)])
(cond
[a-match => (lambda (a-match)
(define name (second a-match))
(define arity-string (bytes->string/utf-8 (third a-match)))
(define arity (parse-arity-string arity-string))
(cons (cons (string->symbol (bytes->string/utf-8 name)) arity)
(loop)))]
[else empty]))))

111
whalesong/selfhost/js-assembler/fracture.rkt
View File

@ -1,111 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt" whalesong/lang/for)
; #lang typed/racket/base
(require "assemble-structs.rkt"
"collect-jump-targets.rkt"
"../compiler/il-structs.rkt"
"../compiler/expression-structs.rkt"
"../parameters.rkt"
racket/list)
;; Breaks up a sequence of statements into a list of basic blocks.
;;
;; The first basic block is special, and represents the start of execution.
;;
;; A basic block consists of a sequence of straight line statements, followed by one of
;; the following:
;;
;; * A conditional jump.
;; * An unconditional jump.
;; * Termination.
(provide fracture)
;; fracture: (listof stmt) -> (listof basic-block)
(: fracture ((Listof Statement) -> (values (Listof BasicBlock)
(Listof Symbol))))
(define (fracture stmts)
(define start-time (current-inexact-milliseconds))
(define-values (blocks entries)
(let* ([first-block-label ; : Symbol
(if (and (not (empty? stmts))
(symbol? (first stmts)))
(first stmts)
(make-label 'start))]
[stmts ; : (Listof Statement)
(if (and (not (empty? stmts))
(symbol? (first stmts)))
(rest stmts)
stmts)]
[jump-targets ; : (Listof Symbol)
(cons first-block-label (collect-general-jump-targets stmts))]
[entry-points ; : (Listof Symbol)
(cons first-block-label (collect-entry-points stmts))])
(define jump-targets-ht ((inst make-hasheq Symbol Boolean)))
(for ([name jump-targets])
(hash-set! jump-targets-ht name #t))
(set! start-time (current-inexact-milliseconds))
(let loop ; : (values (Listof BasicBlock) (Listof Symbol))
([name ; : Symbol
first-block-label]
[acc ; : (Listof UnlabeledStatement)
'()]
[basic-blocks ; : (Listof BasicBlock)
'()]
[stmts ; : (Listof Statement)
stmts]
[last-stmt-goto? ; : Boolean
#f])
(cond
[(null? stmts)
(values (reverse (cons (make-BasicBlock name (reverse acc))
basic-blocks))
entry-points)]
[else
(let ([first-stmt ; : Statement
(car stmts)])
(: do-on-label (Symbol -> (values (Listof BasicBlock) (Listof Symbol))))
(define (do-on-label label-name)
(cond
[(hash-has-key? jump-targets-ht label-name)
(loop label-name
'()
(cons (make-BasicBlock
name
(if last-stmt-goto?
(reverse acc)
(reverse (cons (make-Goto (make-Label label-name))
acc))))
basic-blocks)
(cdr stmts)
last-stmt-goto?)]
[else
(loop name
acc
basic-blocks
(cdr stmts)
last-stmt-goto?)]))
(cond
[(symbol? first-stmt)
(do-on-label first-stmt)]
[(LinkedLabel? first-stmt)
(do-on-label (LinkedLabel-label first-stmt))]
[else
(loop name
(cons first-stmt acc)
basic-blocks
(cdr stmts)
(Goto? (car stmts)))]))]))))
(define end-time (current-inexact-milliseconds))
(fprintf (current-timing-port) " assemble fracture: ~a milliseconds\n" (- end-time start-time))
(values blocks entries))

47
whalesong/selfhost/js-assembler/get-js-vm-implemented-primitives.rkt
View File

@ -1,47 +0,0 @@
#lang racket/base
(require racket/runtime-path
racket/file
racket/contract
racket/list)
;; Get the list of primitives implemented in js-vm-primitives.js
;; (define-runtime-path js-vm-primitives.js "runtime-src/js-vm-primitives.js")
(define-runtime-path whalesong-primitives.js "runtime-src/baselib-primitives.js")
;; sort&unique: (listof string) -> (listof string)
(define (sort&unique names)
(let ([ht (make-hash)])
(for ([name names])
(hash-set! ht name #t))
(sort (for/list ([name (in-hash-keys ht)])
name)
string<?)))
;; ;; primitive-names: (listof symbol)
;; (define js-vm-primitive-names
;; (map string->symbol
;; (sort&unique
;; (map (lambda (a-str)
;; (substring a-str
;; (string-length "PRIMITIVES['")
;; (- (string-length a-str) (string-length "']"))))
;; (let ([contents (file->string js-vm-primitives.js)])
;; (regexp-match* #px"PRIMITIVES\\[('|\")[^\\]]*('|\")\\]" contents))))))
(define whalesong-primitive-names
(map string->symbol
(sort&unique
(map (lambda (a-str)
(let ([match (regexp-match
#px"installPrimitiveProcedure\\(\\s+('|\")([^\\]]*)('|\")" a-str)])
(third match)))
(let ([contents (file->string whalesong-primitives.js)])
(regexp-match* #px"installPrimitiveProcedure\\(\\s+('|\")[^\\']*('|\")" contents))))))
(provide/contract ;[js-vm-primitive-names (listof symbol?)]
[whalesong-primitive-names (listof symbol?)])

110
whalesong/selfhost/js-assembler/get-runtime.rkt
View File

@ -1,110 +0,0 @@
#lang racket/base
;; Function to get the runtime library.
;;
;; The resulting Javascript will produce a file that loads:
;;
;;
;; jquery at the the toplevel
;; HashTable at the toplevel
;; jsnums at the toplevel
;;
;; followed by the base library
;;
(require racket/contract
racket/runtime-path
racket/port)
(provide/contract [get-runtime (-> string?)])
(define-runtime-path base-path "runtime-src")
;; The order matters here. link needs to come near the top, because
;; the other modules below have some circular dependencies that are resolved
;; by link.
(define files '(
top.js
;; jquery is special: we need to make sure it's resilient against
;; multiple invokation and inclusion.
jquery-protect-header.js
jquery.js
jquery-protect-footer.js
js-numbers.js
base64.js
baselib.js
baselib-dict.js
baselib-frames.js
baselib-loadscript.js
baselib-unionfind.js
baselib-equality.js
baselib-format.js
baselib-constants.js
baselib-numbers.js
baselib-lists.js
baselib-vectors.js
baselib-chars.js
baselib-symbols.js
baselib-paramz.js
baselib-strings.js
baselib-bytes.js
hashes-header.js
jshashtable-2.1_src.js
llrbtree.js
baselib-hashes.js
hashes-footer.js
baselib-regexps.js
baselib-paths.js
baselib-boxes.js
baselib-placeholders.js
baselib-keywords.js
baselib-structs.js
baselib-srclocs.js
baselib-ports.js
baselib-functions.js
baselib-modules.js
baselib-contmarks.js
baselib-arity.js
baselib-inspectors.js
baselib-exceptions.js
baselib-readergraph.js
;; baselib-check has to come after the definitions of types,
;; since it uses the type predicates immediately on init time.
baselib-check.js
baselib-primitives.js
runtime.js))
(define (path->string p)
(call-with-input-file p
(lambda (ip)
(port->string ip))))
(define text (apply string-append
(map (lambda (n)
(path->string
(build-path base-path (symbol->string n))))
files)))
(define (get-runtime)
text)

94
whalesong/selfhost/js-assembler/hash-cache.rkt
View File

@ -1,94 +0,0 @@
#lang racket/base
;; on-disk hashtable cache.
(require (prefix-in whalesong: "../version.rkt")
racket/runtime-path
racket/file
file/md5)
(define cache-directory-path
(build-path (find-system-path 'pref-dir)
"whalesong"))
(provide cached? save-in-cache!)
;; create-cache-directory!: -> void
(define (create-cache-directory!)
(unless (directory-exists? cache-directory-path)
(make-directory* cache-directory-path)))
;; clear-cache-files!: -> void
;; Remove all the cache files.
(define (clear-cache-files!)
(for ([file (directory-list cache-directory-path)])
(when (file-exists? (build-path cache-directory-path file))
(with-handlers ([exn:fail? void])
(delete-file (build-path cache-directory-path file))))))
(define whalesong-cache.scm
(build-path cache-directory-path
(format "whalesong-cache-~a.scm"
whalesong:version)))
(define (ensure-cache-db-structure!)
(when (not (file-exists? whalesong-cache.scm))
;; Clear existing cache files: they're obsolete.
(clear-cache-files!)
(call-with-output-file whalesong-cache.scm
(lambda (op)
(write (make-hash) op)))))
(define (get-db)
(hash-copy (call-with-input-file whalesong-cache.scm read)))
(define (write-db! hash)
(call-with-output-file whalesong-cache.scm
(lambda (op) (write hash op))
#:exists 'replace))
(create-cache-directory!)
(ensure-cache-db-structure!)
(define db (get-db))
;; cached?: path -> (U false bytes)
;; Returns a true value, (vector path md5-signature data), if we can
;; find an appropriate entry in the cache, and false otherwise.
(define (cached? path)
(cond
[(file-exists? path)
(hash-ref db
(list (path->string path)
(call-with-input-file* path md5))
#f)]
[else
#f]))
;; save-in-cache!: path bytes -> void
;; Saves a record.
(define (save-in-cache! path data)
(cond
[(file-exists? path)
(define signature (call-with-input-file* path md5))
(hash-set! db
(list (path->string path)
signature)
data)
(write-db! db)]
[else
(error 'save-in-cache! "File ~e does not exist" path)]))

19
whalesong/selfhost/js-assembler/module-knowledge.rkt
View File

@ -1,19 +0,0 @@
#lang racket/base
;; Provides a mapping of the core bindings in kernel, so that we know statically
;; if something is implemented as a primitive or a closure.
(require syntax/modresolve)
(provide bound-procedure-names)
(define ns (make-base-empty-namespace))
(define bound-procedure-names
(let ([path (resolve-module-path 'whalesong/lang/kernel #f)])
(parameterize ([current-namespace ns])
(namespace-require path)
(for/list ([name (namespace-mapped-symbols)]
#:when (namespace-variable-value name #t (lambda () #f)))
name))))

786
whalesong/selfhost/js-assembler/package.rkt
View File

@ -1,786 +0,0 @@
#lang racket/base
(require "assemble.rkt"
"../logger.rkt"
"../make/make.rkt"
"../make/make-structs.rkt"
"../parameters.rkt"
"../compiler/expression-structs.rkt"
"../parser/path-rewriter.rkt"
"../parser/parse-bytecode.rkt"
"../parser/modprovide.rkt"
"../resource/structs.rkt"
"../promise.rkt"
"check-valid-module-source.rkt"
"find-primitive-implemented.rkt"
(prefix-in hash-cache: "hash-cache.rkt")
racket/match
racket/list
racket/promise
racket/set
racket/path
racket/string
racket/port
syntax/modread
syntax/kerncase
syntax/modresolve
(prefix-in query: "../lang/js/query.rkt")
(prefix-in resource-query: "../resource/query.rkt")
(prefix-in runtime: "get-runtime.rkt")
(prefix-in racket: racket/base)
racket/runtime-path
json)
;; There is a dynamic require for (planet dyoo/closure-compile) that's done
;; if compression is turned on.
;; TODO: put proper contracts here
(provide package
package-anonymous
package-standalone-html
get-inert-code
get-standalone-code
write-standalone-code
get-runtime
write-runtime
current-on-resource
get-html-template)
;; notify: string (listof any)* -> void
;; Print out log message during the build process.
(define (notify msg . args)
(displayln (apply format msg args)))
(define primitive-identifiers-ht
(make-hash primitive-ids))
;; Sets up the compiler parameters we need to do javascript-specific compilation.
(define (with-compiler-params thunk)
(parameterize ([compile-context-preservation-enabled #t]
[current-primitive-identifier?
(lambda (a-name)
(hash-ref primitive-identifiers-ht a-name #f))])
(thunk)))
(define current-on-resource
(make-parameter (lambda (r)
(log-debug "Resource ~s should be written"
(resource-path r))
(void))))
(define-struct cached-entry (real-path ;; path to a module.
whalesong-version ;; string
md5 ;; md5 of the original source in real-path
bytes)
#:transparent) ;; bytes
(define-struct js-impl (name ;; symbol
real-path ;; path
src ;; string
)
#:transparent)
;; Packager: produce single .js files to be included to execute a
;; program.
(define (package-anonymous source-code
#:should-follow-children? should-follow?
#:output-port op)
(fprintf op "(function() {\n")
(package source-code
#:should-follow-children? should-follow?
#:output-port op)
(fprintf op " return invoke; })\n"))
;; check-valid-source: Source -> void
;; Check to see if the file, if a module, is a valid module file.
(define (check-valid-source src)
(cond
[(StatementsSource? src)
(void)]
[(MainModuleSource? src)
(check-valid-module-source (MainModuleSource-path src))]
[(ModuleSource? src)
(check-valid-module-source (ModuleSource-path src))]
[(SexpSource? src)
(void)]
[(UninterpretedSource? src)
(void)]))
;; source-is-javascript-module?: Source -> boolean
;; Returns true if the source looks like a Javascript-implemented module.
(define (source-is-javascript-module? src)
(cond
[(StatementsSource? src)
#f]
[(MainModuleSource? src)
(query:has-javascript-implementation?
`(file ,(path->string (MainModuleSource-path src))))]
[(ModuleSource? src)
(query:has-javascript-implementation?
`(file ,(path->string (ModuleSource-path src))))]
[(SexpSource? src)
#f]
[(UninterpretedSource? src)
#f]))
(define (source-resources src)
(cond
[(StatementsSource? src)
empty]
[(MainModuleSource? src)
(resource-query:query
`(file ,(path->string (MainModuleSource-path src))))]
[(ModuleSource? src)
(resource-query:query
`(file ,(path->string (ModuleSource-path src))))]
[(SexpSource? src)
empty]
[(UninterpretedSource? src)
empty]))
;; get-javascript-implementation: source -> UninterpretedSource
(define (get-javascript-implementation src)
(define (get-provided-name-code bytecode)
(apply string-append
(for/list ([modprovide (get-provided-names bytecode)]
[i (in-naturals)])
(string-append
(format "ns.set(~s,exports[~s]);\n"
(symbol->string (ModuleProvide-internal-name modprovide))
(symbol->string (ModuleProvide-external-name modprovide)))
(format "extNs.set(~s,exports[~s]);\n"
(symbol->string (ModuleProvide-external-name modprovide))
(symbol->string (ModuleProvide-external-name modprovide)))
(format "modrec.prefix[~a]=exports[~s];\n"
i
(symbol->string (ModuleProvide-external-name modprovide)))))))
(define (get-prefix-code bytecode)
(format "modrec.prefix=[~a];modrec.prefix.names=[~a];modrec.prefix.internalNames=[~a];"
(string-join (map (lambda (n) "void(0)")
(get-provided-names bytecode))
",")
(string-join (map (lambda (n)
(format "~s" (symbol->string
(ModuleProvide-internal-name n))))
(get-provided-names bytecode))
",")
(string-join (map (lambda (n)
(format "~s" (symbol->string
(ModuleProvide-external-name n))))
(get-provided-names bytecode))
",")))
(define (get-implementation-from-path path)
(let* ([name (rewrite-path path)]
[paths (query:query `(file ,(path->string path)))]
[text (string-join
(map (lambda (p)
(call-with-input-file p port->string))
paths)
"\n")]
[module-requires (query:lookup-module-requires path)]
[bytecode (parse-bytecode path)])
(when (not (empty? module-requires))
(log-debug "~a requires ~a"
path
module-requires))
(let ([module-body-text
(format "
if(--M.cbt<0) { throw arguments.callee; }
var modrec = M.modules[~s];
var ns = modrec.getExports();
var extNs = modrec.getExternalExports();
~a
var exports = {};
modrec.isInvoked = true;
(function(MACHINE, EXPORTS){~a})(M, exports);
~a
modrec.privateExports = exports;
return M.c.pop().label(M);"
(symbol->string name)
(get-prefix-code bytecode)
text
(get-provided-name-code bytecode))])
(make-UninterpretedSource
path
(format "
M.installedModules[~s] = function() {
return new plt.runtime.ModuleRecord(~s,
function(M) {
~a
});
}
"
(symbol->string name)
(symbol->string name)
(assemble-modinvokes+body module-requires module-body-text))
(map (lambda (p) (make-ModuleSource (normalize-path p)))
module-requires)))))
(cond
[(StatementsSource? src)
(error 'get-javascript-implementation src)]
[(MainModuleSource? src)
(get-implementation-from-path (MainModuleSource-path src))]
[(ModuleSource? src)
(get-implementation-from-path (ModuleSource-path src))]
[(SexpSource? src)
(error 'get-javascript-implementation)]
[(UninterpretedSource? src)
(error 'get-javascript-implementation)]))
;; source-module-name: source -> (U symbol #f)
;; Given a source, return its module name if it's a module.
;; If not, return #f.
(define (source-module-name src)
(cond
[(StatementsSource? src)
#f]
[(MainModuleSource? src)
(rewrite-path (MainModuleSource-path src))]
[(ModuleSource? src)
(rewrite-path (ModuleSource-path src))]
[(SexpSource? src)
#f]
[(UninterpretedSource? src)
(rewrite-path (UninterpretedSource-path src))]))
(define (assemble-modinvokes+body paths after)
(cond
[(empty? paths)
after]
[(empty? (rest paths))
(assemble-modinvoke (first paths) after)]
[else
(assemble-modinvoke (first paths)
(assemble-modinvokes+body (rest paths) after))]))
(define (assemble-modinvoke path after)
(let ([name (rewrite-path (path->string path))]
[afterName (gensym 'afterName)])
(format "
var ~a = function() { ~a };
plt.runtime.PAUSE(function(restart) {
var modName = ~s;
plt.runtime.currentModuleLoader(M,
modName,
function() {
restart(function(M) {
M.modules[modName] = M.installedModules[modName]();
if (! M.modules[modName].isInvoked) {
M.modules[modName].internalInvoke(M,
~a,
M.params.currentErrorHandler);
} else {
~a();
}
})
},
function() {
alert('Could not load ' + modName);
})
}); "
afterName
after
(symbol->string name)
afterName
afterName)))
;; package: Source (path -> boolean) output-port -> void
;; Compile package for the given source program.
;;
;; should-follow-children? indicates whether we should continue
;; following module paths of a source's dependencies.
;;
;; The generated output defines a function called 'invoke' with
;; four arguments (M, SUCCESS, FAIL, PARAMS). When called, it will
;; execute the code to either run standalone expressions or
;; load in modules.
(define (package source-code
#:should-follow-children? should-follow?
#:output-port op
#:next-file-path (next-file-path (lambda (module-name) (error 'package))))
(define resources (set))
;; wrap-source: source -> source
;; Translate all JavaScript-implemented sources into uninterpreted sources;
;; we'll leave its interpretation to on-visit-src.
(define (wrap-source src)
(log-debug "Checking valid source")
(check-valid-source src)
(log-debug "Checking if the source has a JavaScript implementation")
(cond
[(source-is-javascript-module? src)
(log-debug "Replacing implementation with JavaScript one.")
(get-javascript-implementation src)]
[else
src]))
;; maybe-with-fresh-file: source (-> any) -> any
;; Call thunk, perhaps in the dynamic extent where op is a new file.
(define (maybe-with-fresh-file src thunk)
(cond
[(current-one-module-per-file?)
(define old-port op)
(define temp-string (open-output-string))
(set! op temp-string)
(thunk)
(set! op old-port)
(define fresh-name (next-file-path (source-module-name src)))
(call-with-output-file fresh-name
(lambda (op)
(display (compress (get-output-string temp-string)) op))
#:exists 'replace)]
[else
(thunk)]))
(define (on-visit-src src ast stmts)
;; Record the use of resources on source module visitation...
(set! resources (set-union resources (list->set (source-resources src))))
(maybe-with-fresh-file
src
(lambda ()
(fprintf op "\n// ** Visiting ~a\n" (source-name src))
(define start-time (current-inexact-milliseconds))
(cond
[(UninterpretedSource? src)
(fprintf op "(function(M) {\n\"use strict\";\n ~a }(plt.runtime.currentMachine));" (UninterpretedSource-datum src))]
[else
(fprintf op "(")
(on-source src stmts op)
(fprintf op ")(plt.runtime.currentMachine,
function() {
if (window.console && window.console.log) {
window.console.log('loaded ' + ~s);
}
},
function(M, err) {
if (window.console && window.console.log) {
window.console.log('error: unable to load ' + ~s);
if (err && err.stack) { console.log(err.stack); }
}
},
{});"
(format "~a" (source-name src))
(format "~a" (source-name src)))
(define stop-time (current-inexact-milliseconds))
(fprintf (current-timing-port) " assembly: ~s milliseconds\n" (- stop-time start-time))
(void)]))))
(define (after-visit-src src)
(void))
(define (on-last-src)
(void))
(define packaging-configuration
(make-Configuration
wrap-source
should-follow?
;; on
on-visit-src
;; after
after-visit-src
;; last
on-last-src))
(with-compiler-params
(lambda () (make (list source-code) packaging-configuration)))
(for ([r resources])
((current-on-resource) r)))
;; on-source: Source (Promise (Listof Statement)) OutputPort -> void
;; Generates the source for the statements here.
;; Optimization: if we've seen this source before, we may be able to pull
;; it from the cache.
(define (on-source src stmts op)
(define (on-path path)
(cond
[(current-with-cache?)
(cond
[(cached? path)
=>
(lambda (bytes)
(display bytes op))]
[(cacheable? path)
(define string-op (open-output-bytes))
(assemble/write-invoke (my-force stmts) string-op 'no-trampoline)
(save-in-cache! path (get-output-bytes string-op))
(display (get-output-string string-op) op)]
[else
(assemble/write-invoke (my-force stmts) op 'no-trampoline)])]
[else
(assemble/write-invoke (my-force stmts) op 'no-trampoline)]))
(cond
[(ModuleSource? src)
(on-path (ModuleSource-path src))]
[(MainModuleSource? src)
(on-path (MainModuleSource-path src))]
[else
(assemble/write-invoke (my-force stmts) op 'without-preemption)]))
;; cached?: path -> (U false bytes)
;; Returns a true value (the cached bytes) if we've seen this path
;; and know its JavaScript-compiled bytes.
(define (cached? path)
(hash-cache:cached? path))
;; cacheable?: path -> boolean
;; Produces true if the file should be cached.
;; At the current time, only cache modules that are provided
;; by whalesong itself.
(define (cacheable? path)
(within-whalesong-path? path))
;; save-in-cache!: path bytes -> void
;; Saves the bytes in the cache, associated with that path.
;; TODO: Needs to sign with the internal version of Whalesong, and
;; the md5sum of the path's content.
(define (save-in-cache! path bytes)
(hash-cache:save-in-cache! path bytes))
;; package-standalone-html: X output-port -> void
(define (package-standalone-html source-code op)
(display (get-header) op)
(display (string-append (get-runtime)
(get-inert-code source-code
(lambda () (error 'package-standalone-html)))
invoke-main-module-code) op)
(display *footer* op))
;; write-runtime: output-port -> void
(define (write-runtime op)
(define (wrap-source src) src)
(let ([packaging-configuration
(make-Configuration
wrap-source
;; should-follow-children?
(lambda (src) #t)
;; on
(lambda (src ast stmts)
(on-source src stmts op)
(fprintf op "(M, function() { "))
;; after
(lambda (src)
(fprintf op " }, FAIL, PARAMS);"))
;; last
(lambda ()
(fprintf op "SUCCESS();")))])
(display (runtime:get-runtime) op)
(newline op)
(fprintf op "(function(M, SUCCESS, FAIL, PARAMS) {")
(with-compiler-params
(lambda ()
(make (list (my-force only-bootstrapped-code)) packaging-configuration)))
(fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n")))
(define closure-compile-ns (make-base-namespace))
(define (compress x)
(cond [(current-compress-javascript?)
(log-debug "compressing javascript...")
(parameterize ([current-namespace closure-compile-ns])
(define closure-compile (dynamic-require '(planet dyoo/closure-compile) 'closure-compile))
(closure-compile x))]
[else
(log-debug "not compressing javascript...")
x]))
(define *the-runtime*
(delay (let ([buffer (open-output-string)])
(write-runtime buffer)
(compress
(get-output-string buffer)))))
;; get-runtime: -> string
(define (get-runtime)
(force *the-runtime*))
(define (append-text-files paths)
(string-join (map (λ (p) (if (file-exists? p)
(bytes->string/utf-8 (call-with-input-file p port->bytes))
""))
paths)
"\n"))
;; get-header : -> string
(define (get-header)
(format
#<<EOF
<!DOCTYPE html>
<html xml:lang="en">
<head>
<meta name="viewport" content="initial-scale=1.0, width=device-width, height=device-height, minimum-scale=1.0, maximum-scale=1.0, user-scalable=no" />
<meta charset="utf-8"/>
<title></title>
~a
</head>
<script>
EOF
(append-text-files (current-header-scripts))))
;; get-html-template: (listof string) (#:manifest path) -> string
(define (get-html-template js-files
#:manifest (manifest #f)
#:with-legacy-ie-support? (with-legacy-ie-support? #t)
#:title (title "")
#:module-mappings (module-mappings (make-hash)))
(format #<<EOF
<!DOCTYPE html>
<html ~a>
<head>
~a
<meta name="viewport" content="initial-scale=1.0, width=device-width, height=device-height, minimum-scale=1.0, maximum-scale=1.0, user-scalable=no" />
<meta name="apple-mobile-web-app-capable" content="yes" />
<meta name="apple-mobile-web-app-status-bar-style" content="black" />
<meta charset="utf-8"/>
<title>~a</title>
~a
~a
<script>
plt.runtime.currentModuleLoader = plt.runtime.makeLocalFileModuleLoader(~a);
</script>
<script>
~a
</script>
</head>
<body>
</body>
</html>
EOF
(if manifest (format "manifest=~s" (path->string manifest)) "")
(if with-legacy-ie-support?
"<meta http-equiv='X-UA-Compatible' content='IE=7,chrome=1'><!--[if lt IE 9]><script src='excanvas.js' type='text/javascript'></script><script src='canvas.text.js'></script><script src='optimer-normal-normal.js'></script><![endif]-->"
"")
title
(append-text-files (current-header-scripts))
(string-join (map (lambda (js)
(format " <script src='~a'></script>\n" js))
js-files)
"")
(jsexpr->string module-mappings)
invoke-main-module-code))
;; get-inert-code: source (-> path) -> string
(define (get-inert-code source-code next-file-path)
(let ([buffer (open-output-string)])
(package source-code
#:should-follow-children? (lambda (src) #t)
#:output-port buffer
#:next-file-path next-file-path)
(compress
(get-output-string buffer))))
;; get-standalone-code: source -> string
(define (get-standalone-code source-code)
(let ([buffer (open-output-string)])
(write-standalone-code source-code buffer)
(compress
(get-output-string buffer))))
;; write-standalone-code: source output-port -> void
(define (write-standalone-code source-code op)
(package source-code
#:should-follow-children? (lambda (src) #t)
#:output-port op))
(define invoke-main-module-code
#<<EOF
var invokeMainModule = function() {
var M = plt.runtime.currentMachine;
var startTime = new Date().valueOf();
plt.runtime.invokeMains(
M,
function() {
// On main module invokation success:
var stopTime = new Date().valueOf();
if (window.console && window.console.log) {
window.console.log('evaluation took ' + (stopTime - startTime) + ' milliseconds');
}
},
function(e) {
var contMarkSet, context, i, appName, contextDiv, srclocProcedure;
var displayContext = function() {
var subcontextDiv = $('<div/>').css('color', 'red');
subcontextDiv.append("Stacktrace:\n");
if (contMarkSet) {
context = contMarkSet.getContext(M);
for (i = 0; i < context.length; i++) {
if (plt.runtime.isVector(context[i])) {
$('<div/>').text('at ' + context[i].elts[0] +
', line ' + context[i].elts[2] +
', column ' + context[i].elts[3])
.addClass('stacktrace')
.css('margin-left', '10px')
.css('whitespace', 'pre')
.appendTo(subcontextDiv);
} else if (plt.runtime.isProcedure(context[i])) {
if (context[i].displayName) {
$('<div/>').text('in ' + context[i].displayName)
.addClass('stacktrace')
.css('margin-left', '10px')
.css('whitespace', 'pre')
.appendTo(subcontextDiv);
}
}
}
}
contextDiv.append(subcontextDiv);
M.params.currentErrorDisplayer(M, contextDiv);
};
// On main module invokation failure
if (window.console && window.console.log) {
window.console.log(e.stack || e);
}
M.params.currentErrorDisplayer(
M, $(plt.baselib.format.toDomNode(e.stack || e)).css('color', 'red'));
if (Object.hasOwnProperty.call(e,'racketError') &&
plt.baselib.exceptions.isExn(e.racketError)) {
contMarkSet = plt.baselib.exceptions.exnContMarks(e.racketError);
contextDiv = $('<div/>');
if (e.racketError.structType &&
plt.baselib.structs.supportsStructureTypeProperty(
e.racketError.structType,
plt.baselib.structs.propExnSrcloc)) {
srclocProcedure = plt.baselib.functions.asJavaScriptFunction(
plt.baselib.structs.lookupStructureTypeProperty(
e.racketError.structType,
plt.baselib.structs.propExnSrcloc),
M);
srclocProcedure(function(v) {
if (plt.baselib.lists.isList(v)) {
while(v !== plt.baselib.lists.EMPTY) {
if (plt.baselib.srclocs.isSrcloc(v.first)) {
$('<div/>').text('at ' + plt.baselib.srclocs.srclocSource(v.first) +
', line ' + plt.baselib.srclocs.srclocLine(v.first) +
', column ' + plt.baselib.srclocs.srclocColumn(v.first))
.addClass('srcloc')
.css('margin-left', '10px')
.css('whitespace', 'pre')
.css('color', 'red')
.appendTo(contextDiv);
}
v = v.rest;
}
}
displayContext();
},
function(err) {
displayContext();
},
e.racketError);
} else {
displayContext();
}
}
});
};
$(document).ready(invokeMainModule);
EOF
)
(define *footer*
#<<EOF
</script>
<body></body>
</html>
EOF
)

58
whalesong/selfhost/js-assembler/quote-cdata.rkt
View File

@ -1,58 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt" "../selfhost-strings.rkt")
; #lang typed/racket/base
;; quoting cdata for script tags. This is used to help generate SCRIPT bodies in XHTML.
;; Note that this won't help too much in regular HTML5 documents.
(provide quote-cdata)
; CDATA (character data) sequence begins with
; <![CDATA[
; and ends with ]]>
; A CDATA section can not contain ]]>
; To encode, say, ]]> one would write <![CDATA[]]]]><![CDATA[>]]>
; I.e. replace all occurences of ]]> with ]]]]><![CDATA[>
; which stops and restarts the cdata sequence.
(: quote-cdata (String -> String))
#;(define (quote-cdata s)
(string-append "<![CDATA["
(regexp-replace* #rx"]]>" ; pattern
s ; input
"]]]]><![CDATA[>") ; insert
"]]>"))
(define (quote-cdata s)
(string-append "<![CDATA["
(string-replace "]]>"
"]]]]><![CDATA[>"
s)
"]]>"))
;; (: quote-cdata (String -> String))
;; (define (quote-cdata str)
;; (let ([chunks (regexp-split #rx"\\]\\]>" str)])
;; (apply string-append (map wrap (process chunks)))))
;; (: get-cdata-chunks (String -> (Listof String)))
;; (define (get-cdata-chunks s)
;; (let ([chunks (regexp-split #rx"\\]\\]>" s)])
;; (process chunks)))
;; (: process ((Listof String) -> (Listof String)))
;; (define (process lst)
;; (cond
;; [(empty? (rest lst))
;; lst]
;; [else
;; (cons (string-append (first lst) "]]")
;; (process (cons (string-append ">" (second lst))
;; (rest (rest lst)))))]))
;; (: wrap (String -> String))
;; (define (wrap s)
;; (string-append "<![CDATA[" s "]]>"))

126
whalesong/selfhost/parameters.rkt
View File

@ -1,126 +0,0 @@
#lang racket/base
;;; TODO (for selfhost)
;;; - change to #lang whalesong
;;; - first implmenet "paths"
(require "selfhost-parameters.rkt")
(require "compiler/expression-structs.rkt"
"compiler/lexical-structs.rkt"
"compiler/arity-structs.rkt"
"sets.rkt"
racket/path
racket/port)
#;(require/typed "logger.rkt"
[log-warning (String -> Void)])
(provide current-defined-name
current-module-path
current-root-path
current-warn-unimplemented-kernel-primitive
current-seen-unimplemented-kernel-primitives
current-primitive-identifier?
current-compress-javascript?
current-one-module-per-file?
current-with-cache?
current-with-legacy-ie-support?
current-header-scripts
current-report-port
current-timing-port
)
;(: current-module-path (Parameterof (U False Path)))
(define current-module-path
(make-parameter (build-path (current-directory) "anonymous-module.rkt")))
;(: current-root-path (Parameterof Path))
(define current-root-path
(make-parameter (normalize-path (current-directory))))
;(: current-warn-unimplemented-kernel-primitive (Parameterof (Symbol -> Void)))
(define current-warn-unimplemented-kernel-primitive
(make-parameter
(lambda (id) #;([id : Symbol])
(log-warning
(format "WARNING: Primitive Kernel Value ~s has not been implemented\n"
id)))))
;(: current-primitive-identifier? (Parameterof (Symbol -> (U False Arity))))
(define current-primitive-identifier? (make-parameter (lambda (name) #;([name : Symbol]) #f)))
;(: current-compress-javascript? (Parameterof Boolean))
(define current-compress-javascript? (make-parameter #f))
;; Turn this one so that js-assembler/package generates a file per module, as
;; opposed to trying to bundle them all together.
;(: current-one-module-per-file? (Parameterof Boolean))
(define current-one-module-per-file? (make-parameter #f))
;; 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))
;; Turns on ie legacy support; includes excanvas and other helper libraries
;; to smooth out compatibility issues.
;(: current-with-legacy-ie-support? (Parameterof Boolean))
(define current-with-legacy-ie-support? (make-parameter #t))
;; Keeps list of Javascript files to be included in the header.
;(: current-header-scripts (Parameterof (Listof Path)))
(define current-header-scripts (make-parameter '()))
;(: current-report-port (Parameterof Output-Port))
(define current-report-port (make-parameter (current-output-port)))
;(: current-timing-port (Parameterof Output-Port))
(define current-timing-port (make-parameter (open-output-nowhere) ;(current-output-port)
))
;;; Do not touch the following parameters: they're used internally by package
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(: current-seen-unimplemented-kernel-primitives (Parameterof (Setof Symbol)))
(define current-seen-unimplemented-kernel-primitives
(make-parameter
(new-seteq)))
;;; These parameters below will probably go away soon.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Workaround for what appears to be a bug in 5.3.1 pre-release
;(: UNKNOWN Symbol)
(define UNKNOWN 'unknown)
;(: current-defined-name (Parameterof (U Symbol LamPositionalName)))
(define current-defined-name (make-parameter UNKNOWN))

13
whalesong/selfhost/parser/modprovide.rkt
View File

@ -1,13 +0,0 @@
#lang whalesong (require "../selfhost-lang.rkt")
(require racket/match
"../compiler/expression-structs.rkt")
(provide get-provided-names)
;; get-provided-names: bytecode -> (listof ModuleProvide)
(define (get-provided-names bytecode)
(match bytecode
[(struct Top [_ (struct Module (name path prefix requires provides code))])
provides]
[else
'()]))

95
whalesong/selfhost/selfhost-lang.rkt
View File

@ -1,95 +0,0 @@
#lang whalesong
;;;
;;;
;;;
;;; Note: define-predicate is not defined as a no-op here.
;;; We need the error message to find where to add our own predicates.
(provide define-struct:
define-type
inst
make-parameter
parameterize
bytes?
path?
sort
natural?
vector-copy
bytes->string/utf-8 ; is values
path->string
; no-ops
:
ann
log-debug
ensure-type-subsetof)
(require "selfhost-parameters.rkt")
(require (for-syntax racket/base))
(define (bytes? o) #f) ; TODO
(define (path? o) #f) ; TODO
(define (sort xs <<)
(define (merge xs ys)
(cond
[(empty? xs) ys]
[(empty? ys) xs]
[else (define x (first xs))
(define y (first ys))
(if (<< x y)
(cons x (merge (rest xs) ys))
(cons y (merge xs (rest ys))))]))
(define (split xs)
(define n (length xs))
(cond [(<= n 1) (list xs '())]
[else (let loop ([ys '()] [xs xs] [i 0])
(if (> (* 2 i) (- n 1))
(list ys xs)
(loop (cons (first xs) ys) (rest xs) (+ i 1))))]))
(define n (length xs))
(cond [(< n 2) xs]
[else (define halves (split xs))
(merge (sort (first halves) <<)
(sort (second halves) <<))]))
; define-struct: uses the same syntax as the one from typed/racket, but it
; simply discards the types and expand into standard Whalesong define-struct.
(define-syntax (define-struct: stx)
(syntax-case stx (:)
[(ds: struct-name ([field-name : type] ...) options ...)
#'(define-struct struct-name (field-name ...) options ...)]))
(define-syntax (define-type stx) #'(void))
(define-syntax (: stx) #'(void))
(define-syntax (ensure-type-subsetof stx) #'(void))
(define-syntax (ann stx) (syntax-case stx () [(_ expr type) #'expr]))
(define-syntax (inst stx)
(syntax-case stx ()
[(_ e ignore ...)
#'e]))
(define (log-debug . _) (void))
(define (natural? o) (and (number? o) (integer? o) (not (negative? o))))
(require whalesong/lang/for)
(define (vector-copy vec [start 0] [end (vector-length vec)])
(define n (- end start))
(define v (make-vector n #\space))
(for ([i (in-range start end)]
[j (in-range 0 n)])
(vector-set! v j (vector-ref vec i)))
v)
(define bytes->string/utf-8 values)
(define (path->string x)
(error 'todo-implement-me))

47
whalesong/selfhost/selfhost-parameters.rkt
View File

@ -1,47 +0,0 @@
#lang whalesong
(require (for-syntax racket/base))
(provide make-parameter
parameterize)
(require (for-syntax syntax/parse))
(struct parameter (values) #:mutable)
(define *parameters* '())
(define *ids* '())
(define-syntax (push! stx)
(syntax-case stx ()
[(_ val)
#'(set! *parameters* (cons val *parameters*))]))
(define (find-parameter id)
(cond
[(assq id *parameters*) => cdr]
[else (error 'find-parameter "parameter not found, got id: ~a" id)]))
(define (make-parameter val)
(define p (parameter (list val)))
(define proc (case-lambda
[() (first (parameter-values (find-parameter proc)))]
[(v) (define p (find-parameter proc))
(define vs (cons v (parameter-values p)))
(set-parameter-values! p vs)]))
(push! (cons proc p))
proc)
(define-syntax (parameterize stx)
(syntax-case stx ()
[(_ () body ...)
#'(let () body ...)]
[(_ ([param-expr val-expr] more ...) body ...)
#'(let ()
(define proc param-expr)
(define p (find-parameter proc))
(define v val-expr)
(define old (parameter-values p))
(define vs (cons v old))
(set-parameter-values! p vs)
(begin0
(parameterize (more ...) body ...)
(set-parameter-values! p old)))]))

94
whalesong/selfhost/selfhost-strings.rkt
View File

@ -1,94 +0,0 @@
#lang whalesong (require "selfhost-lang.rkt" whalesong/lang/for)
(provide string-replace ; (string-replace k r s) replace all occurences of k in s with r
string-split-at-non-alphanumeric
string-join
string-titlecase)
(define string-titlecase values) ; for now XXX todo: used in munge-label
; string-index : string string [integer] -> integer
; return the index of the first occurence of k in the string s
; whose index is from or greater
(define (string-index k s [from 0])
(define kn (string-length k))
(define sn (string-length s))
(and (<= (+ from kn) sn)
(for/or ([i (in-range from (- sn kn -1))])
(and (for/and ([j (in-range i (+ i kn))] [l (in-range kn)])
(char=? (string-ref s j) (string-ref k l)))
i))))
; a new string is returned where occurences of the string k (the key)
; are replaced with the string r (the replacement) in the string s.
(define (string-replace k r s)
(define kn (string-length k))
(define sn (string-length s))
(let loop ([start 0] [from 0] [chunks '()])
(define i (string-index k s from))
(displayln (list 'loop start from chunks i))
(cond
[i
(define new-start (+ i kn))
(loop new-start
new-start
(cons r (cons (substring s start i) chunks)))]
[(empty? chunks)
(string-copy s)]
[else
(apply string-append
(reverse (cons (if (<= start sn)
(substring s start)
"")
chunks)))])))
; Test must evaluate to #t
#;(and (= (string-index "bar" "foobarbazbar")
(string-index "bar" "foobarbazbar" 1)
(string-index "bar" "foobarbazbar" 2)
(string-index "bar" "foobarbazbar" 3)
3)
(= (string-index "bar" "foobarbazbar" 4) 9)
(equal? (string-index "bar" "foobarbazbar" 10) #f))
; (string-replace "foo" "_" "abfoocdfoooo")
(define non-splitters
(let ()
(define alpha "qwertyuiopasdfghjklzxcvbnm")
(define ALPHA "QWERTYUIOPASDFGHJKLZXCVBNM")
(define nums "0123456789")
(string->list (string-append alpha ALPHA nums))))
; (regexp-split #rx"[^a-zA-Z0-9]+" s)
(define (string-split-at-non-alphanumeric s)
(define (splitter? c) (not (memq c non-splitters)))
(define chunks
(reverse
(let loop ([chunks '()] [current '()] [xs (string->list s)])
(cond
[(and (empty? xs) (empty? current))
chunks]
[(empty? xs)
(cons (reverse current) chunks)]
[(splitter? (car xs))
(loop (cons (reverse current) chunks) '() (cdr xs))]
[else
(loop chunks (cons (car xs) current) (cdr xs))]))))
(map list->string chunks))
(define (string-join strs [sep #f])
(apply string-append
(cond
[(empty? strs) '("")]
[(not sep) strs]
[else (let loop ([xs (list (car strs))] [ys (rest strs)])
(if (empty? ys)
(reverse xs)
(loop (cons (car ys) (cons sep xs))
(cdr ys))))])))

59
whalesong/selfhost/sets.rkt
View File

@ -1,59 +0,0 @@
#lang whalesong (require "selfhost-lang.rkt")
(provide ; Setof
new-set new-seteq
set-insert! set-remove! set-contains?
set-for-each set-map
set->list list->set)
; (define-struct: (A) set ([ht : (HashTable A Boolean)]))
(define-struct set (ht))
(define-type (Setof A) (set A))
(: new-set (All (A) (-> (Setof A))))
(define (new-set)
(make-set ((inst make-hash A Boolean))))
(: new-seteq (All (A) (-> (Setof A))))
(define (new-seteq)
(make-set ((inst make-hasheq A Boolean))))
(: set-insert! (All (A) ((Setof A) A -> Void)))
(define (set-insert! s elt)
(hash-set! (set-ht s) elt #t)
(void))
(: set-remove! (All (A) ((Setof A) A -> Void)))
(define (set-remove! s elt)
((inst hash-remove! A Boolean) (set-ht s) elt)
(void))
(: set-contains? (All (A) ((Setof A) A -> Boolean)))
(define (set-contains? s elt)
(hash-has-key? (set-ht s) elt))
(: set-for-each (All (A) ((A -> Any) (Setof A) -> Void)))
(define (set-for-each f s)
((inst hash-for-each A Boolean Any)
(set-ht s)
(lambda (k v) ; ([k : A] [v : Boolean])
(f k)))
(void))
(: set-map (All (A B) ((A -> B) (Setof A) -> (Listof B))))
(define (set-map f s)
((inst hash-map A Boolean B) (set-ht s) (lambda (k v) ; ([k : A] [v : Boolean])
(f k))))
(: set->list (All (A) ((Setof A) -> (Listof A))))
(define (set->list a-set)
(set-map (lambda (k) #;([k : A]) k) a-set))
(: list->set (All (A) ((Listof A) -> (Setof A))))
(define (list->set a-lst)
(let ([a-set (new-set)]) ; : (Setof A)
(for-each (lambda (k) #;([k : A])
(set-insert! a-set k))
a-lst)
a-set))

91
whalesong/selfhost/union-find.rkt
View File

@ -1,91 +0,0 @@
#lang typed/racket/base
;; Union-find hardcoded to do symbols.
(provide (all-defined-out))
;; A forest contains a collection of its nodes keyed by element.
;; The elements are compared by eq?
(define-struct: forest
([ht : (HashTable Symbol node)]))
;; A node is an element, a parent node, and a numeric rank.
(define-struct: node
([elt : Symbol]
[p : (U False node)]
[rank : Natural])
#:mutable)
;; Builds a new, empty forest.
(: new-forest (-> forest))
(define (new-forest)
(make-forest (make-hash)))
;; lookup-node: forest X -> node
;; Returns the node that's associated with this element.
(: lookup-node (forest Symbol -> node))
(define (lookup-node a-forest an-elt)
(unless (hash-has-key? (forest-ht a-forest) an-elt)
(make-set a-forest an-elt))
(hash-ref (forest-ht a-forest)
an-elt))
;; make-set: forest X -> void
;; Adds a new set into the forest.
(: make-set (forest Symbol -> Void))
(define (make-set a-forest an-elt)
(unless (hash-has-key? (forest-ht a-forest) an-elt)
(let ([a-node (make-node an-elt #f 0)])
(set-node-p! a-node a-node)
(hash-set! (forest-ht a-forest) an-elt a-node))))
(: find-set (forest Symbol -> Symbol))
;; Returns the representative element of elt.
(define (find-set a-forest an-elt)
(let ([a-node (lookup-node a-forest an-elt)])
(node-elt (get-representative-node a-node))))
(: get-representative-node (node -> node))
;; Returns the representative node of a-node, doing path
;; compression if we have to follow links.
(define (get-representative-node a-node)
(let ([p (node-p a-node)])
(cond [(eq? a-node p)
a-node]
[(node? p)
(let ([rep (get-representative-node p)])
;; Path compression is here:
(set-node-p! a-node rep)
rep)]
[else
;; impossible situation
(error 'get-representative-node)])))
(: union-set (forest Symbol Symbol -> Void))
;; Joins the two elements into the same set.
(define (union-set a-forest elt1 elt2)
(let ([rep1 (get-representative-node
(lookup-node a-forest elt1))]
[rep2 (get-representative-node
(lookup-node a-forest elt2))])
(cond
[(< (node-rank rep1) (node-rank rep2))
(set-node-p! rep1 rep2)]
[(> (node-rank rep1) (node-rank rep2))
(set-node-p! rep2 rep1)]
[else
(set-node-p! rep1 rep2)
(set-node-rank! rep1 (add1 (node-rank rep1)))])))

2
whalesong/tests/test-assemble.rkt
View File

@ -69,7 +69,7 @@
(display "var M = new plt.runtime.Machine();\n" op)
(display "(function() { " op)
(display "var myInvoke = " op)
(assemble/write-invoke a-statement op 'with-preemption)
(assemble/write-invoke a-statement op)
(display ";" op)
(fprintf op
"return function(succ, fail, params) {

923
whalesong/tests/test-images.rkt
View File

@ -1,923 +0,0 @@
#lang whalesong
(require whalesong/world)
(require whalesong/image)
;(play-sound "http://www.html5tutorial.info/media/vincent.mp3" true)
;; "Checking Empty scene"
;; (empty-scene 40 50 "red")
"These three circles (red, green, blue) should be left aligned"
(above/align "left"
(circle 30 "solid" "red")
(above/align "left" (circle 50 'solid 'green) (circle 20 'solid 'blue)))
"These three circles (red, green, blue) should be right aligned"
(above/align "right"
(circle 30 "solid" "red")
(above/align "right" (circle 50 'solid 'green) (circle 20 'solid 'blue)))
"These three circles (red, green, blue) should be middle aligned, vertically"
(above/align "middle"
(circle 30 "solid" "red")
(above/align "middle" (circle 50 'solid 'green) (circle 20 'solid 'blue)))
"These three circles (red, green, blue) should be top-aligned"
(beside/align "top"
(circle 30 "solid" "red")
(beside/align "top" (circle 50 'solid 'green) (circle 20 'solid 'blue)))
"These three circles (red, green, blue) should be bottom-aligned"
(beside/align "bottom"
(circle 30 "solid" "red")
(beside/align "bottom" (circle 50 'solid 'green) (circle 20 'solid 'blue)))
"These three circles (red, green, blue) should be middle-aligned, horizontally"
(beside/align "middle"
(circle 30 "solid" "red")
(beside/align "middle" (circle 50 'solid 'green) (circle 20 'solid 'blue)))
"should be a bar graph"
(define (make-stars number)
(cond [(eq? number 1) (star 12 "solid" "purple")]
[true (beside (star 12 "solid" "purple") (make-stars (- number 1)))] ))
(define (bar-graph l1)
(cond [(empty? l1) (circle 0 "outline" "blue")]
[true (above/align "left" (make-stars (car l1)) (bar-graph (cdr l1)))]))
(bar-graph '(1 3 5 3 9 5 3 4 4 3 5 2))
(check-expect (image? 'blue) #f)
(check-expect (image? (circle 20 "solid" "green")) #t)
"should be a solid green circle: " (circle 20 "solid" "green")
"should be an outline turquoise rectangle: " (rectangle 20 30 "outline" "turquoise")
"should be a solid, mostly-translucent red rectangle: " (rectangle 200 300 10 "red")
"should be an outline red rectangle: " (rectangle 200 300 "outline" "red")
"should be an *invisible* red rectangle: " (rectangle 200 300 0 "red")
(define halfred (make-color 255 0 0 128))
(define quarterred (make-color 255 0 0 64))
"should be a solid red triangle" (triangle 50 "solid" "red")
"should be a solid triangle made from a half-transparent red" (triangle 50 "solid" halfred)
"should be a solid, half-alpha triangle made from a half-transparent red" (triangle 50 128 halfred)
"should be a solid triangle made from a quater-trasparent red" (triangle 50 "solid" quarterred)
;(check-expect (color? (make-color 3 4 5)))
(check-expect (color-red (make-color 3 4 5)) 3)
(check-expect (color-green (make-color 3 4 5)) 4)
(check-expect (color-blue (make-color 3 4 5)) 5)
(check-expect (image? (empty-scene 20 50)) true)
(check-expect (image? (place-image (circle 50 'solid 'blue)
50
50
(empty-scene 100 100)))
true)
"should be a blue circle in a scene with a border: " (place-image (circle 50 'solid 'blue)
50
50
(empty-scene 100 100))
"should be a blue circle in the UR of a scene with a border: " (put-image (circle 50 'solid 'blue)
100
100
(empty-scene 100 100))
(check-expect (image?
(rectangle 20 20 'solid 'green))
true)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TEXT & TEXT/FONT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"simple text functionality"
(text "hello world" 20 'black)
(text (string-copy "hello world") 30 'purple)
(text "hello world" 40 'red)
"test font-weight"
(text/font "Hello" 24 "purple"
"Gill Sans" 'swiss 'normal 'bold #f)
(text/font "Hello" 24 "green"
"Gill Sans" 'swiss 'normal 'light #f)
"test font-style"
(text/font "Goodbye" 48 "indigo"
"Helvetica" 'modern 'italic 'normal #f)
(text/font "Goodbye" 48 "indigo"
"Helvetica" 'modern 'normal 'normal #f)
"test underline-height calculation"
(text/font "test this!" 80 "purple"
"Helvetica" 'roman 'normal 'normal #t)
(text/font "low-hanging glyphs" 36 "blue"
"Times" 'roman 'normal 'bold #t)
(text/font "teeny-tiny text" 8 "black"
"Times" 'roman 'normal 'bold #t)
(text/font "not really a link" 36 "blue"
"Courier" 'roman 'italic 'normal #t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; IMAGE-URL & VIDEO-URL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"importing images and video"
(image-url "http://www.bootstrapworld.org/images/icon.png")
(open-image-url "http://www.bootstrapworld.org/images/icon.png")
;(video/url "http://www.quirksmode.org/html5/videos/big_buck_bunny.mp4")
#;(overlay (circle 20 "solid" "red")
(video/url "http://www.quirksmode.org/html5/videos/big_buck_bunny.mp4"))
#;(rotate 45
(video/url "http://www.quirksmode.org/html5/videos/big_buck_bunny.mp4"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OVERLAY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"the next two images should be identical"
(overlay (circle 20 "solid" (make-color 50 50 255))
(square 40 "solid" (make-color 100 100 255)))
(overlay (circle 20 "solid" (make-color 50 50 255))
(regular-polygon 40 4 "solid" (make-color 100 100 255)))
(overlay (ellipse 10 10 "solid" "red")
(ellipse 20 20 "solid" "black")
(ellipse 30 30 "solid" "red")
(ellipse 40 40 "solid" "black")
(ellipse 50 50 "solid" "red")
(ellipse 60 60 "solid" "black"))
"the next two images should be identical"
(overlay (square 20 "solid" (make-color 50 50 255))
(square 26 "solid" (make-color 100 100 255))
(square 32 "solid" (make-color 150 150 255))
(square 38 "solid" (make-color 200 200 255))
(square 44 "solid" (make-color 250 250 255)))
(overlay (regular-polygon 20 4 "solid" (make-color 50 50 255))
(regular-polygon 26 4 "solid" (make-color 100 100 255))
(regular-polygon 32 4 "solid" (make-color 150 150 255))
(regular-polygon 38 4 "solid" (make-color 200 200 255))
(regular-polygon 44 4 "solid" (make-color 250 250 255)))
"overlay with place-image - target should be centered"
(place-image (overlay (ellipse 10 10 "solid" "white")
(ellipse 20 20 "solid" "black")
(ellipse 30 30 "solid" "white")
(ellipse 40 40 "solid" "black")
(ellipse 50 50 "solid" "white")
(ellipse 60 60 "solid" "black"))
150 100
(rectangle 300 200 "solid" "black"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OVERLAY/XY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"should be some overlay/xys"
(overlay/xy (rectangle 20 20 "outline" "black")
20 0
(rectangle 20 20 "outline" "black"))
(overlay/xy (rectangle 20 20 "solid" "red")
20 20
(rectangle 20 20 "solid" "black"))
(overlay/xy (rectangle 20 20 "solid" "red")
-20 -20
(rectangle 20 20 "solid" "black"))
(overlay/xy
(overlay/xy (ellipse 40 40 "outline" "black")
10
15
(ellipse 10 10 "solid" "forestgreen"))
20
15
(ellipse 10 10 "solid" "forestgreen"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OVERLAY/ALIGN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"some examples of overlay/align"
(overlay/align "middle" "middle"
(ellipse 60 30 "solid" "purple")
(rectangle 30 60 "solid" "orange"))
(overlay/align "right" "top"
(ellipse 60 30 "solid" "purple")
(rectangle 30 60 "solid" "orange"))
(overlay/align "left" "bottom"
(ellipse 60 30 "solid" "purple")
(rectangle 30 60 "solid" "orange"))
(overlay/align "right" "bottom"
(rectangle 20 20 "solid" "silver")
(rectangle 30 30 "solid" "seagreen")
(rectangle 40 40 "solid" "silver")
(rectangle 50 50 "solid" "seagreen"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; UNDERLAY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"some underlays"
(underlay (circle 20 'solid 'green)
(rectangle 10 20 'solid 'blue))
(underlay (ellipse 10 60 "solid" "red")
(ellipse 20 50 "solid" "black")
(ellipse 30 40 "solid" "red")
(ellipse 40 30 "solid" "black")
(ellipse 50 20 "solid" "red")
(ellipse 60 10 "solid" "black"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; UNDERLAY/XY & UNDERLAY/ALIGN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"examples of underlay and underlay/align"
(underlay/xy (circle 20 'solid 'green)
30 10
(rectangle 10 20 'solid 'blue))
;; color list
"the following should be a blue circle, but by using color-list->image"
(let ([circle-color-list (image->color-list (circle 20 'solid 'blue))])
;; fixme: add tests for number of colors
(color-list->image circle-color-list 40 40 0 0))
(underlay/align "middle" "middle"
(ellipse 60 30 "solid" "purple")
(rectangle 30 60 "solid" "orange"))
(underlay/align "right" "top"
(ellipse 60 30 "solid" "purple")
(rectangle 30 60 "solid" "orange"))
(underlay/align "left" "bottom"
(ellipse 60 30 "solid" "purple")
(rectangle 30 60 "solid" "orange"))
(underlay/align "right" "bottom"
(rectangle 50 50 "solid" "silver")
(rectangle 40 40 "solid" "seagreen")
(rectangle 30 30 "solid" "silver")
(rectangle 20 20 "solid" "seagreen"))
"This is issue 40 https://github.com/dyoo/WeScheme/issues/40"
(underlay/align "left" "middle"
(rectangle 30 60 "solid" "orange")
(ellipse 60 30 "solid" "purple"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BESIDE & BESIDE/ALIGN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"examples of beside and beside/align"
(beside (ellipse 20 70 "solid" "gray")
(ellipse 20 50 "solid" "darkgray")
(ellipse 20 30 "solid" "dimgray")
(ellipse 20 10 "solid" "black"))
(beside/align "bottom"
(ellipse 20 70 "solid" "lightsteelblue")
(ellipse 20 50 "solid" "mediumslateblue")
(ellipse 20 30 "solid" "slateblue")
(ellipse 20 10 "solid" "navy"))
(beside/align "top"
(ellipse 20 70 "solid" "mediumorchid")
(ellipse 20 50 "solid" "darkorchid")
(ellipse 20 30 "solid" "purple")
(ellipse 20 10 "solid" "indigo"))
"align these text images on their baselines"
(beside/align "baseline"
(text "ijy" 18 "black")
(text "ijy" 24 "black"))
"issue 25 https://github.com/dyoo/WeScheme/issues/25"
(beside/align "top"
(rectangle 20 100 "solid" "black")
(rectangle 20 120 "solid" "black")
(rectangle 20 80 "solid" "black"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ABOVE & ABOVE/ALIGN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"should be some examples of above and above/align"
(above (ellipse 70 20 "solid" "gray")
(ellipse 50 20 "solid" "darkgray")
(ellipse 30 20 "solid" "dimgray")
(ellipse 10 20 "solid" "black"))
(above/align "right"
(ellipse 70 20 "solid" "gold")
(ellipse 50 20 "solid" "goldenrod")
(ellipse 30 20 "solid" "darkgoldenrod")
(ellipse 10 20 "solid" "sienna"))
(above/align "left"
(ellipse 70 20 "solid" "yellowgreen")
(ellipse 50 20 "solid" "olivedrab")
(ellipse 30 20 "solid" "darkolivegreen")
(ellipse 10 20 "solid" "darkgreen"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PLACE-IMAGE/ALIGN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"should be right in the center"
(place-image/align (circle 16 "solid" "yellow")
32 32 "center" "center"
(rectangle 64 64 "solid" "goldenrod"))
"should be at the bottom-right corner"
(place-image/align (circle 16 "solid" "yellow")
32 32 "left" "top"
(rectangle 64 64 "solid" "goldenrod"))
"should be at the upper-left corner"
(place-image/align (circle 16 "solid" "yellow")
32 32 "right" "bottom"
(rectangle 64 64 "solid" "goldenrod"))
"test 'beside' with scenes -- from the DrRacket documentation"
(beside (place-image/align (circle 8 "solid" "tomato")
0 0 "center" "center"
(rectangle 32 32 "outline" "black"))
(place-image/align (circle 8 "solid" "tomato")
8 8 "center" "center"
(rectangle 32 32 "outline" "black"))
(place-image/align (circle 8 "solid" "tomato")
16 16 "center" "center"
(rectangle 32 32 "outline" "black"))
(place-image/align (circle 8 "solid" "tomato")
24 24 "center" "center"
(rectangle 32 32 "outline" "black"))
(place-image/align (circle 8 "solid" "tomato")
32 32 "center" "center"
(rectangle 32 32 "outline" "black")))
"some overlay and place-image stress tests"
(define flag2
(place-image
(rotate 90
(underlay/align
"center" "center"
(rectangle 50 450 "solid" "white")
(rotate 90
(rectangle 50 450 "solid" "white"))
(rotate 90
(rectangle 30 450 "solid" "red"))
(rotate 180
(rectangle 30 450 "solid" "red"))))
200 100
(place-image
(rotate 65
(underlay/align
"center" "center"
(rectangle 15 450 "solid" "red")
(rotate 50
(rectangle 15 450 "solid" "red"))))
200 100
(place-image
(rotate 65
(underlay/align
"center" "center"
(rectangle 40 450 "solid" "white")
(rotate 50
(rectangle 40 450 "solid" "white"))))
200 100
(rectangle 400 200 "solid" "navy")))))
(define Australia2
(place-image
flag2
200 100
(place-image
(star-polygon 30 7 3 "solid" "white")
650 60
(place-image
(star-polygon 50 7 3 "solid" "white")
200 300
(place-image
(star-polygon 40 7 3 "solid" "white")
60 20
(place-image
(star-polygon 40 7 3 "solid" "white")
68 124
(rectangle 900 400 "solid" "navy")))))))
flag2
Australia2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TRIANGLE, RIGHT TRIANGLE & ISOSCELES-TRIANGLE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Three triangles of various sizes and fills"
(triangle 36 "solid" "darkslategray")
(triangle 4 "solid" "purple")
(triangle 30 "outline" "cornflowerblue")
"Triangles side by side"
(beside (triangle 36 "solid" "darkslategray")
(triangle 30 "solid" "cornflowerblue"))
"Triangles above."
(above (triangle 36 "solid" "darkslategray")
(triangle 30 "solid" "cornflowerblue"))
"Three right triangles of various sizes and fills"
(right-triangle 36 48 "solid" "darkslategray")
(right-triangle 4 60 "solid" "purple")
(right-triangle 30 40 "solid" "cornflowerblue")
"Three isosceles triangles of various sizes and fills"
(isosceles-triangle 60 30 "solid" "aquamarine")
(isosceles-triangle 200 170 "outline" "seagreen")
(isosceles-triangle 60 330 "solid" "lightseagreen")
"Trying ASA triangle (30 40 60)"
(triangle/asa 30 40 60 "solid" "blue")
"Trying AAS triangle (30 60 40)"
(triangle/aas 30 60 40 "outline" "green")
"Trying SAA triangle (100 30 90)"
(triangle/saa 100 30 90 "solid" "red")
"Trying SSA triangle (60 60 40)"
(triangle/ass 60 60 40 "outline" "turquoise")
"Trying ASS triangle (60 80 90)"
(triangle/ass 60 80 90 "solid" "maroon")
"Trying SSS triangle (60 60 60)"
(triangle/sss 60 60 60 "outline" "red")
"Trying SAS triangle (60 30 60)"
(triangle/sas 60 30 60 "solid" "brown")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; STAR, RADIAL-STAR & STAR-POLYGON
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"old star implementation"
(star 5 8 4 "solid" "darkslategray")
(star 5 30 15 "outline" "black")
(star 5 20 10 "solid" "red")
"new star implementation"
(star 8 "solid" "darkslategray")
(star 30 "outline" "black")
(star 20 "solid" "red")
"radial star"
(radial-star 8 8 64 "solid" "darkslategray")
(radial-star 32 30 40 "outline" "black")
(radial-star 5 20 40 "solid" "red")
"star-polygon"
(star-polygon 40 5 2 "solid" "seagreen")
(star-polygon 40 7 3 "outline" "darkred")
(star-polygon 20 10 3 "solid" "cornflowerblue")
"should look like a pentagon"
(star-polygon 20 5 1 "solid" "darkblue")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SQUARE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Three squares of various sizes and fills"
(square 60 "outline" "black")
(square 200 "solid" "seagreen")
(square 100 "outline" "blue")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RHOMBUS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Three rhombuses of various sizes and fills"
(rhombus 40 45 "solid" "magenta")
(rhombus 100 200 "solid" "orange")
(rhombus 80 330 "outline" "seagreen")
"rhombuses beside each other"
(beside (rhombus 40 45 "solid" "magenta")
(rhombus 100 200 "solid" "orange")
(rhombus 80 330 "outline" "seagreen"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; REGULAR-POLYGON
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Some regular polygons..."
"A triangle of side-length 20: should be 20x17"
(regular-polygon 20 3 "solid" "purple")
"A square of side-length 40: should be 40x40"
(regular-polygon 40 4 "solid" "aquamarine")
"A pentagon of side-length 30: should be 49x46"
(regular-polygon 30 5 "solid" "pink")
"A hexagon of side-length 20: should be 40x35"
(regular-polygon 20 6 "solid" "gold")
"A septagon of side-length 40: should be 90x88"
(regular-polygon 40 7 "solid" "goldenrod")
"An octagon of side-length 30: should be 72x72"
(regular-polygon 30 8 "solid" "darkgoldenrod")
"A nonagon of side-length 20: should be 58x57"
(regular-polygon 20 9 "solid" "sienna")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; POLYGON
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Some polygons defined with posns..."
#;(polygon (list (make-posn 0 0)
(make-posn -10 20)
(make-posn 60 0)
(make-posn -10 -20))
"solid"
"burlywood")
#;(polygon (list (make-posn 0 0)
(make-posn 0 40)
(make-posn 20 40)
(make-posn 20 60)
(make-posn 40 60)
(make-posn 40 20)
(make-posn 20 20)
(make-posn 20 0))
"solid"
"plum")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ROTATE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Three images at 30, 60, 90 degree rotation:"
(rotate 30 (image-url "http://www.bootstrapworld.org/images/icon.png"))
(rotate 60 (image-url "http://www.bootstrapworld.org/images/icon.png"))
(rotate 90 (image-url "http://www.bootstrapworld.org/images/icon.png"))
"Rotated, huge image"
(rotate 30 (scale 3 (image-url "http://www.bootstrapworld.org/images/icon.png")))
"From the Racket documentation:"
(rotate 45 (ellipse 60 20 "solid" "olivedrab"))
(rotate 5 (rectangle 50 50 "outline" "black"))
"unrotated T"
(beside/align
"center"
(rectangle 40 20 "solid" "darkseagreen")
(rectangle 20 100 "solid" "darkseagreen"))
"rotate 45 degrees"
(rotate 45
(beside/align
"center"
(rectangle 40 20 "solid" "darkseagreen")
(rectangle 20 100 "solid" "darkseagreen")))
(beside
(rotate 30 (square 50 "solid" "red"))
(flip-horizontal
(rotate 30 (square 50 "solid" "blue"))))
(define blue-tri (triangle 100 "solid" "blue"))
"A solid blue triangle, rotated 0 degrees. Should be pointing up."
(rotate 0 blue-tri)
"A solid blue triangle, rotated 30 degrees ccw. Should be flush left"
(rotate 30 blue-tri)
"A solid blue triangle, rotated 90 degrees ccw. Should be pointing left."
(rotate 90 blue-tri)
"A solid blue triangle, rotated 180 degrees ccw. Should be pointing down."
(rotate 180 blue-tri)
"A solid blue triangle, rotated 270 degrees ccw. Should be pointing right."
(rotate 270 blue-tri)
"A solid blue triangle, rotated 630 degrees ccw. Should be pointing right."
(rotate 630 blue-tri)
"A solid blue triangle, rotated 360 degrees ccw. Should be pointing up."
(rotate 360 blue-tri)
"A solid blue triangle, rotated 360.1 degrees ccw. Should be approximately pointing up."
(rotate 360.1 blue-tri)
"A solid blue triangle, rotated 720.5 degrees ccw. Should be approximately pointing up."
(rotate 720.5 blue-tri)
"A solid blue triangle, rotated 1.5 degrees cw. Should be approximately pointing up."
(rotate -1.5 blue-tri)
"A solid blue triangle, rotated -90 degrees ccw (90 cw). Should be pointing right."
(rotate -90 blue-tri)
"A solid blue triangle, rotated -450 degrees ccw (450 cw). Should be pointing right."
(rotate -450 blue-tri)
"A solid blue triangle, rotated -810 degrees ccw (810 cw). Should be pointing right."
(rotate -810 blue-tri)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCALE & SCALE/XY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"scaling small and large"
(scale 1/2 (image-url "http://www.bootstrapworld.org/images/icon.png"))
(scale 2 (image-url "http://www.bootstrapworld.org/images/icon.png"))
(scale/xy 1 2 (image-url "http://www.bootstrapworld.org/images/icon.png"))
(scale/xy 2 1 (image-url "http://www.bootstrapworld.org/images/icon.png"))
"This should be the normal image"
(scale/xy 1 1 (image-url "http://www.bootstrapworld.org/images/icon.png"))
"From the Racket documentation: two identical ellipses, and a circle"
(scale 2 (ellipse 20 30 "solid" "blue"))
(ellipse 40 60 "solid" "blue")
(scale/xy 3
2
(ellipse 20 30 "solid" "blue"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FRAME AND CROP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"frame and crop examples from DrRacket documentation"
(frame (ellipse 20 20 "outline" "black"))
(beside
(ellipse 20 70 "solid" "lightsteelblue")
(frame (ellipse 20 50 "solid" "mediumslateblue"))
(ellipse 20 30 "solid" "slateblue")
(ellipse 20 10 "solid" "navy"))
(crop 0 0 40 40 (circle 40 "solid" "chocolate"))
(crop 40 60 40 60 (ellipse 80 120 "solid" "dodgerblue"))
(above
(beside (crop 40 40 40 40 (circle 40 "solid" "palevioletred"))
(crop 0 40 40 40 (circle 40 "solid" "lightcoral")))
(beside (crop 40 0 40 40 (circle 40 "solid" "lightcoral"))
(crop 0 0 40 40 (circle 40 "solid" "palevioletred"))))
"should be a quarter of a circle, inscribed in a square"
(place-image
(crop 0 0 20 20 (circle 20 "solid" "Magenta"))
10 10
(rectangle 40 40 "solid" "blue"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LINE, ADD-LINE & SCENE+LINE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Three tests for line"
(line 30 30 "black")
(line -30 20 "red")
(line 30 -20 "red")
"Three tests for add-line"
(add-line (ellipse 40 40 "outline" "maroon")
0 40 40 0 "maroon")
(add-line (rectangle 40 40 "solid" "gray")
-10 50 50 -10 "maroon")
(add-line
(rectangle 100 100 "solid" "darkolivegreen")
25 25 100 100
"goldenrod")
"Three tests for scene+line: should be identical to above, but cropped around base image"
(scene+line (ellipse 40 40 "outline" "maroon")
0 40 40 0 "maroon")
(scene+line (rectangle 40 40 "solid" "gray")
-10 50 50 -10 "maroon")
(scene+line
(rectangle 100 100 "solid" "darkolivegreen")
25 25 100 100
"goldenrod")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FLIP-VERTICAL & FLIP-HORIZONTAL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"a red triangle, a blue one flippled horizontally and a green one flippled vertically"
(right-triangle 30 40 "solid" "red")
(flip-horizontal (right-triangle 30 40 "solid" "blue"))
(flip-vertical (right-triangle 30 40 "solid" "green"))
"those three triangles beside each other"
(beside (right-triangle 30 40 "solid" "red")
(flip-horizontal (right-triangle 30 40 "solid" "blue"))
(flip-vertical (right-triangle 30 40 "solid" "green")))
"one image flipped vertically, and one flipped horizontally"
(flip-vertical (image-url "http://www.bootstrapworld.org/images/icon.png"))
(flip-horizontal (image-url "http://www.bootstrapworld.org/images/icon.png"))
"BESIDE: reference image"
(beside (square 20 "solid" (make-color 50 50 255))
(square 34 "solid" (make-color 150 150 255)))
"flip the second one horizontally"
(beside (square 20 "solid" (make-color 50 50 255))
(flip-horizontal (square 34 "solid" (make-color 150 150 255))))
"flip the second one vertically"
(beside (square 20 "solid" (make-color 50 50 255))
(flip-vertical (square 34 "solid" (make-color 150 150 255))))
"flip the first one horizontally"
(beside (flip-horizontal (square 20 "solid" (make-color 50 50 255)))
(square 34 "solid" (make-color 150 150 255)))
"flip the first one vertically"
(beside (flip-vertical (square 20 "solid" (make-color 50 50 255)))
(square 34 "solid" (make-color 150 150 255)))
"ABOVE: reference image"
(above (square 20 "solid" (make-color 50 50 255))
(square 34 "solid" (make-color 150 150 255)))
"flip the second one horizontally"
(above (square 20 "solid" (make-color 50 50 255))
(flip-horizontal (square 34 "solid" (make-color 150 150 255))))
"flip the second one vertically"
(above (square 20 "solid" (make-color 50 50 255))
(flip-vertical (square 34 "solid" (make-color 150 150 255))))
"flip the first one horizontally"
(above (flip-horizontal (square 20 "solid" (make-color 50 50 255)))
(square 34 "solid" (make-color 150 150 255)))
"flip the first one vertically"
(above (flip-vertical (square 20 "solid" (make-color 50 50 255)))
(square 34 "solid" (make-color 150 150 255)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; IMAGE EQUALITY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"checking a circle against a rectangle"
(check-expect (image=? (circle 50 "solid" "blue")
(rectangle 20 30 "outline" "turquoise"))
#f)
(check-expect (image=? (empty-scene 20 50) (empty-scene 20 50)) true)
"checking a circle against a different one"
(check-expect (image=? (circle 50 "solid" "blue")
(circle 50 "solid" "turquoise"))
#f)
"checking a triangle against a different one"
(check-expect (image=? (triangle 50 "solid" "blue")
(triangle 50 "outline" "blue"))
#f)
"checking a circle against a different one"
(check-expect (image=? (circle 50 "solid" "blue")
(circle 50 "solid" "turquoise"))
#f)
"checking a textImage against a different one"
(check-expect (image=? (text "purple" 50 "blue")
(text "purple" 50 "red"))
#f)
"checking a textImage against itself"
(check-expect (image=? (text "purple" 50 "blue")
(text "purple" 50 "blue"))
#t)
"checking a bitmap against itself"
(check-expect (image=? (bitmap/url "http://www.bootstrapworld.org/images/icon.gif")
(bitmap/url "http://www.bootstrapworld.org/images/icon.gif"))
#t)
"checking a bitmap against a shape of the same size"
(check-expect (image=? (bitmap/url "http://www.bootstrapworld.org/images/icon.gif")
(rectangle 150 150 "solid" "pink"))
#f)
"checking a bitmap against a shape of a different size"
(check-expect (image=? (bitmap/url "http://www.bootstrapworld.org/images/icon.gif")
(rectangle 100 100 "solid" "pink"))
#f)
"checking a bitmap against a different one"
(check-expect (image=? (bitmap/url "http://www.bootstrapworld.org/images/icon.gif")
(bitmap/url "http://www.bootstrapworld.org/images/icon.png"))
#f)
"checking a rectangle against itself"
(check-expect (image=? (rectangle 100 50 "solid" "blue")
(rectangle 100 50 "solid" "blue"))
#t)
"checking a rhombus against itself"
(check-expect (image=? (rhombus 100 50 "solid" "blue")
(rhombus 100 50 "solid" "blue"))
#t)
"checking a square against a 2x larger one that's been scaled by 1/2"
(check-expect (image=? (scale 1/2 (square 100 "solid" "blue"))
(square 50 "solid" "blue"))
#t)
"checking a square against a 2x larger one that's been scaled by 1/3"
(check-expect (image=? (scale 1/3 (square 100 "solid" "blue"))
(square 50 "solid" "blue"))
#f)
"checking a rectangle against its equivalent polygon"
(check-expect (image=? (regular-polygon 40 4 "solid" "black")
(rectangle 40 40 "solid" "black"))
#t)
"checking a circle against its equivalent ellipse"
(check-expect (image=? (circle 50 90 "orange")
(ellipse 100 100 90 "orange"))
#t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; IMAGE PROPERTIES
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"(image-width (ellipse 30 40 'solid' 'orange'))"
(image-width (ellipse 30 40 "solid" "orange"))
"(image-width (circle 30 'solid' 'orange'))"
(image-width (circle 30 "solid" "orange"))
"(image-width (beside (circle 20 'solid' 'orange') (circle 20 'solid' 'purple')))"
(image-width (beside (circle 20 "solid" "orange") (circle 20 "solid" "purple")))
"(image-height (overlay (circle 20 'solid' 'orange') (circle 30 'solid' 'purple')))"
(image-height (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
"(image-height (rectangle 10 0 'solid' 'purple'))"
(image-height (rectangle 10 0 "solid" "purple"))
"(image-baseline (text 'Hello' 24 'black'))"
(image-baseline (text "Hello" 24 "black"))
"(image-baseline (text/font 'Goodbye' 48 'indigo' 'Helvetica' 'modern 'normal 'normal #f))"
(image-baseline (text/font "Goodbye" 48 "indigo" "Helvetica" 'modern 'normal 'normal #f))
"(image-height (text/font 'Goodbye' 48 'indigo' 'Helvetica' 'modern 'normal 'normal #f))"
(image-height (text/font "Goodbye" 48 "indigo" "Helvetica" 'modern 'normal 'normal #f))
"(image-baseline (rectangle 100 100 'solid' 'black'))"
(image-baseline (rectangle 100 100 "solid" "black"))
"(image-height (rectangle 100 100 'solid' 'black'))"
(image-height (rectangle 100 100 "solid" "black"))
"(mode? 'outline')"
(mode? "outline")
"(mode? 'checkered')"
(mode? "checkered")
"(image-color? 'pink')"
(image-color? "pink")
"(image-color? 'puke')"
(image-color? "puke")
"(y-place? 'middle')"
(y-place? "middle")
"(x-place? 'up-top')"
(x-place? "up-top")
"(angle? 290)"
(angle? 290)
"(angle? -290)"
(angle? -290)
"(side-count? 20)"
(side-count? 20)
"(side-count? 2)"
(side-count? 2)
"(step-count? 2)"
(step-count? 2)
"(step-count? 0)"
(step-count? 0)

5
whalesong/tests/test-parse-bytecode.rkt
View File

@ -117,6 +117,7 @@
(make-LocalRef 0 #f)))
;; let1's
(check-equal? (run-my-parse #'(let ([y (f)])
'ok))
@ -196,6 +197,7 @@
(check-equal? (run-my-parse #'+)
(make-Top (make-Prefix (list))
(make-PrimitiveKernelValue '+)))
@ -381,8 +383,7 @@
;; todo: see what it would take to run a typed/racket/base language.
; This test currently breaks rewrite-path in path-rewriter.rkt
#;(void
(void
(run-my-parse '(module foo typed/racket/base
(provide x)
(: x Number)

11
whalesong/tests/test-parse.rkt
View File

@ -1,17 +1,10 @@
#lang racket/base
(require (rename-in "../parser/baby-parser.rkt"
[parse baby-parse])
(require "../parser/baby-parser.rkt"
"../compiler/lexical-structs.rkt"
"../compiler/expression-structs.rkt"
(for-syntax racket/base))
(define (parse x)
(parameterize ([current-short-labels? #f])
(reset-make-label-counter)
(baby-parse x)))
(printf "test-parse.rkt\n");
; Test out the compiler, using the simulator.

10
whalesong/whalesong-cmd.rkt
View File

@ -17,7 +17,7 @@
;; Usage:
;;
;; * Build standalone .html application.
;; * Build standalone .xhtml application.
;;
;; $ whalesong build main-module-name.rkt
;;
@ -102,8 +102,8 @@
dest-dir
("Set destination directory (default: current-directory)")
(current-output-dir dest-dir)]
[("--as-standalone-html")
("Write single standalone html file")
[("--as-standalone-xhtml")
("Write single standalone xhtml file")
(as-standalone-html? #t)]
#:multi
[("--include-script")
@ -115,7 +115,7 @@
(maybe-with-profiling
(if (as-standalone-html?)
(build-standalone-html path)
(build-standalone-xhtml path)
(build-html-and-javascript path)))]
["print-il" "print the intermediate translation of a module"
@ -200,7 +200,7 @@
(current-verbose? #t)]
[("--debug-show-timings")
("Display debug messages about compilation time.")
(current-timing-port (current-error-port))]
(current-timing-port (current-output-port))]
[("--enable-profiling")
("Enable profiling to standard output")
(with-profiling? #t)]

8
whalesong/whalesong-helpers.rkt
View File

@ -94,7 +94,7 @@
(flush-output (current-report-port))]))
(loop)))))))
(define (build-standalone-html f)
(define (build-standalone-xhtml f)
(with-catchall-exception-handler
(lambda ()
(turn-on-logger!)
@ -104,7 +104,7 @@
(build-path
(regexp-replace #rx"[.](rkt|ss)$"
(path->string filename)
".html"))])
".xhtml"))])
(unless (directory-exists? (current-output-dir))
(fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir))
(make-directory* (current-output-dir)))
@ -129,10 +129,10 @@
(build-path (current-output-dir)
(resource-key r)))]))])
(fprintf (current-report-port)
(format "Writing program ~s\n" (build-path (current-output-dir) output-filename)))
(format "Writing program ~s\n" (build-path (current-output-port) output-filename)))
(call-with-output-file* (build-path (current-output-dir) output-filename)
(lambda (op)
(package-standalone-html
(package-standalone-xhtml
(make-MainModuleSource
(normalize-path (build-path f)))
op))

1
whalesong/world.rkt
View File

@ -1,5 +1,4 @@
#lang s-exp "lang/base.rkt"
(require "world/main.rkt")
(provide (all-from-out "world/main.rkt"))

27
whalesong/world/impl.rkt
View File

@ -1,27 +0,0 @@
#lang s-exp "../lang/js/js.rkt"
(require "../image.rkt"
"types.rkt")
(declare-implementation
#:racket "racket-impl.rkt"
#:javascript (
;; the raw implementation doesn't know anything about
;; Whalesong.
"raw-jsworld.js"
;; We add Whalesong-specific things here.
"kernel.js"
"js-impl.js"
)
#:provided-values (big-bang
on-tick
on-key
on-release
on-mouse
key=?
to-draw
stop-when))

24
whalesong/world/js-impl.js
View File

@ -32,10 +32,7 @@ var checkHandler = plt.baselib.check.makeCheckArgumentType(
isWorldConfigOption,
"world configuration handler");
var worldNamespace = MACHINE.modules['whalesong/world/types.rkt'].getExternalExports();
var stopWithStruct = worldNamespace.get('struct:stop-with');
var isStopWithStruct = stopWithStruct.predicate
var stopWithWorld = function(s) { return stopWithStruct.accessor(s, 0); }
// The default tick delay is 28 times a second.
@ -90,16 +87,10 @@ EXPORTS['to-draw'] =
EXPORTS['stop-when'] =
makePrimitiveProcedure(
'stop-when',
plt.baselib.lists.makeList(1, 2),
1,
function(MACHINE) {
var f = checkProcedure1(MACHINE, "on-tick", 0);
if (MACHINE.a === 2) {
var lp = checkProcedure1(MACHINE, "to-draw", 1);
} else {
var lp = null;
}
return new StopWhen(f, lp);
return new StopWhen(f);
});
@ -112,15 +103,6 @@ EXPORTS['on-key'] =
return new OnKey(f);
});
EXPORTS['on-release'] =
makePrimitiveProcedure(
'on-release',
1,
function(MACHINE) {
var f = checkProcedureWithKey(MACHINE, "on-key", 0);
return new OnRelease(f);
});
EXPORTS['on-mouse'] =
makePrimitiveProcedure(
'on-mouse',

32
whalesong/world/kernel.js
View File

@ -168,22 +168,6 @@ OnKey.prototype.toRawHandler = function(MACHINE, toplevelNode) {
});
};
var OnRelease = function(handler) {
WorldConfigOption.call(this, 'on-release');
this.handler = handler;
}
OnRelease.prototype = plt.baselib.heir(WorldConfigOption.prototype);
OnRelease.prototype.toRawHandler = function(MACHINE, toplevelNode) {
var that = this;
var worldFunction = adaptWorldFunction(that.handler);
return rawJsworld.on_release(
function(w, e, success) {
worldFunction(w, getKeyCodeName(e), success);
});
};
var getKeyCodeName = function(e) {
var code = e.charCode || e.keyCode;
@ -282,6 +266,8 @@ ToDraw.prototype = plt.baselib.heir(OutputConfig.prototype);
ToDraw.prototype.toRawHandler = function(MACHINE, toplevelNode) {
var that = this;
var reusableCanvas;
var reusableCanvasNode;
var adaptedWorldFunction = adaptWorldFunction(this.handler);
var worldFunction = function(world, success) {
@ -289,12 +275,6 @@ ToDraw.prototype.toRawHandler = function(MACHINE, toplevelNode) {
adaptedWorldFunction(
world,
function(v) {
var reusableCanvas = toplevelNode.getElementsByTagName('canvas')[0];
var reusableCanvasNode;
if (reusableCanvas) {
reusableCanvasNode = rawJsworld.node_to_tree(reusableCanvas);
}
// fixme: once jsworld supports fail continuations, use them
// to check the status of the scene object and make sure it's an
// image.
@ -319,7 +299,6 @@ ToDraw.prototype.toRawHandler = function(MACHINE, toplevelNode) {
reusableCanvas.height = height;
}
var ctx = reusableCanvas.getContext("2d");
ctx.clearRect(0, 0, width, height);
v.render(ctx, 0, 0);
success([toplevelNode, reusableCanvasNode]);
} else {
@ -329,7 +308,6 @@ ToDraw.prototype.toRawHandler = function(MACHINE, toplevelNode) {
};
var cssFunction = function(w, k) {
var reusableCanvas = toplevelNode.getElementsByTagName('canvas')[0];
if (reusableCanvas) {
k([[reusableCanvas,
["padding", "0px"],
@ -374,10 +352,9 @@ DefaultDrawingOutput.prototype.toRawHandler = function(MACHINE, toplevelNode) {
var StopWhen = function(handler, last_picture) {
var StopWhen = function(handler) {
WorldConfigOption.call(this, 'stop-when');
this.handler = handler;
this.last_picture = last_picture && new ToDraw(last_picture);
};
StopWhen.prototype = plt.baselib.heir(WorldConfigOption.prototype);
@ -385,6 +362,5 @@ StopWhen.prototype = plt.baselib.heir(WorldConfigOption.prototype);
StopWhen.prototype.toRawHandler = function(MACHINE, toplevelNode) {
var that = this;
var worldFunction = adaptWorldFunction(that.handler);
var lastPictureHandler = that.last_picture && that.last_picture.toRawHandler(MACHINE, toplevelNode);
return rawJsworld.stop_when(worldFunction, undefined, lastPictureHandler);
return rawJsworld.stop_when(worldFunction);
};

28
whalesong/world/main.rkt
View File

@ -1,7 +1,25 @@
#lang s-exp "../lang/base.rkt"
#lang s-exp "../lang/js/js.rkt"
(require "../image.rkt")
(declare-implementation
#:racket "racket-impl.rkt"
#:javascript (
;; the raw implementation doesn't know anything about
;; Whalesong.
"raw-jsworld.js"
;; We add Whalesong-specific things here.
"kernel.js"
"js-impl.js"
)
#:provided-values (big-bang
on-tick
on-key
on-mouse
key=?
to-draw
stop-when))
(require "impl.rkt"
"types.rkt")
(provide (all-from-out "impl.rkt")
(all-from-out "types.rkt"))

13
whalesong/world/racket-impl.rkt
View File

@ -1,13 +1,10 @@
#lang s-exp "../lang/base.rkt"
(require "types.rkt")
(provide big-bang
to-draw
on-tick
on-mouse
on-key
on-release
key=?
stop-when)
@ -36,14 +33,8 @@
(define (on-key handler)
(error 'on-key "must be run in JavaScript context"))
(define (on-release handler)
(error 'on-release "must be run in JavaScript context"))
(define (key=? key-1 key-2)
(error 'key=? "must be run in JavaScript context"))
(define stop-when
(case-lambda [(handler)
(error 'stop-when "must be run in JavaScript context")]
[(handler last-picture)
(error 'stop-when "must be run in JavaScript context")]))
(define (stop-when handler)
(error 'stop-when "must be run in JavaScript context"))

75
whalesong/world/raw-jsworld.js
View File

@ -99,10 +99,6 @@ var rawJsworld = {};
function add_world_listener_first(listener) {
worldListeners.unshift(listener);
}
function add_world_listener(listener) {
worldListeners.push(listener);
}
@ -663,47 +659,17 @@ var rawJsworld = {};
handlers[i].onRegister(top);
}
}
var showLastPicture = function(w, oldW) {
if (stopWhen.last_picture_handler) {
var handler = stopWhen.last_picture_handler();
handler.onRegister(top);
handler._listener(w, oldW, function(v) {
Jsworld.shutdown({cleanShutdown: true});
})
} else {
Jsworld.shutdown({cleanShutdown: true});
}
};
var watchForTermination = function(w, oldW, k2) {
stopWhen.test(w,
function(stop) {
if (stop) {
showLastPicture(w, oldW);
}
k2();
});
function(stop) {
if (stop) {
Jsworld.shutdown({cleanShutdown: true});
}
else { k2(); }
});
};
add_world_listener(watchForTermination);
var watchForStopWith = function(w, oldW, k2) {
/**
* If we have a last_picture we call that with new world, or
* else call the regular draw handler
*
* TODO: We don't call regular draw handler as of now when
* when world ends with stop-with
*/
if (isStopWithStruct(w)) {
world = stopWithWorld(w); //NOTE: Is this assignment safe?
showLastPicture(world, oldW);
}
k2();
}
/* Its important that this stays above all handlers, so that we
* shutdown before calling any other handler */
add_world_listener_first(watchForStopWith);
// Finally, begin the big-bang.
copy_attribs(top, attribs);
@ -777,27 +743,7 @@ var rawJsworld = {};
}
Jsworld.on_key = on_key;
function on_release(release) {
return function() {
var wrappedRelease = function(e) {
preventDefault(e);
stopPropagation(e);
change_world(function(w, k) { release(w, e, k); }, doNothing);
};
return {
onRegister: function(top) {
//http://www.w3.org/TR/html5/editing.html#sequential-focus-navigation-and-the-tabindex-attribue
jQuery(top).attr('tabindex', 1);
jQuery(top).focus();
attachEvent(top, 'keyup', wrappedRelease);
},
onUnregister: function(top) {
detachEvent(top, 'keyup', wrappedRelease);
}
};
};
}
Jsworld.on_release = on_release;
// http://www.quirksmode.org/js/events_mouse.html
@ -897,18 +843,17 @@ var rawJsworld = {};
StopWhenHandler = function(test, receiver, last_picture_handler) {
StopWhenHandler = function(test, receiver) {
this.test = test;
this.receiver = receiver;
this.last_picture_handler = last_picture_handler;
};
// stop_when: CPS(world -> boolean) CPS(world -> boolean) -> handler
function stop_when(test, receiver, last_picture_handler) {
function stop_when(test, receiver) {
return function() {
if (receiver === undefined) {
receiver = function(w, k) { k(w); };
}
return new StopWhenHandler(test, receiver, last_picture_handler);
return new StopWhenHandler(test, receiver);
};
}
Jsworld.stop_when = stop_when;

5
whalesong/world/types.rkt
View File

@ -1,5 +0,0 @@
#lang s-exp "../lang/base.rkt"
(provide (struct-out stop-with))
(define-struct stop-with (world))