DIRECTORY
Ascii USING [CR, FF, Letter, LF, Lower, SP, TAB],
Atom USING [GetPName, MakeAtomFromRefText],
Basics USING [CompareCard],
BigCardinals USING [BigAdd, BigCARD, BigCompare, BigDivMod, BigFromBinaryRope, BigFromCard, BigFromSmall, BigMultiply, BigOdd, BigPowerOfTen, BigToBinaryRope, BigToDecimalRope, BigZero, FirstOneBit, MultiplyByDigit, Zero],
CardTab USING [Create, Fetch, Ref, Store],
IO USING [Backup, CharsAvail, Close, EndOf, EndOfStream, GetChar, GetIndex, GetInfo, GetLineRope, GetRefAny, PeekChar, PutChar, PutF, PutF1, PutFR1, PutRope, Reset, RIS, RopeFromROS, ROS, STREAM],
List USING [CompareProc, Length, Sort],
Real USING [Fix, FScale, Round],
RefTab USING [Create, Fetch, Insert, Ref],
RefText USING [Append, InlineAppendChar, ObtainScratch, ReleaseScratch, TrustTextRopeAsText],
Rope USING [Fetch, FindBackward, Flatten, FromChar, FromRefText, Length, Map, ROPE, Size, Substr, Text],
SafeStorage USING [GetReferentType, Type],
Scheme USING [Any, Apply, Arith, Bignum, Car, Cdr, Char, Compile, Complain, Complex, Cons, DefinePrimitive, endOfFile, Environment, Eval, Expand, false, Fixnum, Flonum, GetUserEnvironment, IsProcedure, KCheck, LookupVariableValue, MakeChar, MakeFixnum, MakePolar, MakeReal, MakeRectangular, Marker, Negative, Number, NumberRep, Pair, Primitive, PrimitiveSyntax, primitiveSyntaxForPrimitiveSyntaxRep, PrimitiveSyntaxRep, PrintProc, Procedure, ProperList, Ratnum, Record, RegisterInit, RopeFromString, RopeFromSymbol, SimpleVector, SimpleVectorRep, String, StringFromRope, Symbol, symbolForPrimitiveSyntaxRep, SymbolFromRope, Syntax, TheChar, TheString, True, true, undefined, unspecified, Vector, VectorFromList, VectorRef],
SchemeEvents USING [Dequeue, Enqueue, EnqueueStream, FlushAvailableWhitespace, InputQueue, MakeInputQueue, Reset],
SchemePrivate USING [ByteCodes, ByteCodesRep, ByteCodeTemplate, ByteCodeTemplateRep, ProcedureFromByteCodeTemplate, TidbitProcedure],
SchemeSys USING [CheckForAbort, DoWithIOErrorCatch, DoWithPorts, FindFileToLoad, GetFileCreateDateForStream, GetFileNameForStream, GetPort, GetRope, IsFileStream, OpenFile, SetPort],
SymTab USING [Create, Fetch, Ref, Store];
I/O Primitives
ThePort:
PUBLIC
PROC [any: Any]
RETURNS [Port] ~ {
WITH any
SELECT
FROM
p: Port => RETURN [p];
ENDCASE => Complain[any, "not a port"];
};
printWidth: INT ¬ 250;
PortPrim: PrimitiveProc ~ {
Inner:
PROC ~ {
SELECT self.data
FROM
$currentIn => { result ¬ SchemeSys.GetPort[undefined, TRUE] };
$currentOut => { result ¬ SchemeSys.GetPort[undefined, FALSE] };
$close => { IO.Close[ThePort[a]] };
$inputPred => {
WITH a
SELECT
FROM
p: Port => IF IO.GetInfo[p].variety#output THEN result ¬ true
ENDCASE => result ¬ false
};
$outputPred => {
WITH a
SELECT
FROM
p: Port => IF IO.GetInfo[p].variety#input THEN result ¬ true
ENDCASE => result ¬ false
};
$openIn => {
result ¬ SchemeSys.OpenFile[fileName: RopeFromString[TheString[a]], in: TRUE]
};
$openOut => {
result ¬ SchemeSys.OpenFile[fileName: RopeFromString[TheString[a]], in: FALSE]
};
$openInString => {
result ¬ IO.RIS[rope: RopeFromString[TheString[a]]]
};
$openOutString => {
result ¬ IO.ROS[]
};
$getOutString => {
WITH a
SELECT
FROM
port: Port => {
result ¬ StringFromRope[IO.RopeFromROS[port]];
[] ¬ IO.ROS[port];
}
ENDCASE => Complain[a, "not a port"];
};
$read => { result ¬ Read[SchemeSys.GetPort[a, TRUE]] };
$readChar => {
result ¬ endOfFile;
result ¬ MakeChar[IO.GetChar[SchemeSys.GetPort[a, TRUE] ! IO.EndOfStream => CONTINUE]];
};
$unreadChar => {
IO.Backup[self: SchemeSys.GetPort[b, TRUE], char: TheChar[a]];
};
$charReadyPred => {
p: Port ~ SchemeSys.GetPort[a, TRUE];
result ¬ IF IO.EndOf[p] OR IO.CharsAvail[p] # 0 THEN true ELSE false;
};
$eofObjectPred => { result ¬ IF a = endOfFile THEN true ELSE false };
$write => { Print[a: a, stream: SchemeSys.GetPort[b, FALSE], depth: INT.LAST, width: INT.LAST] };
$display => { Print[a: a, stream: SchemeSys.GetPort[b, FALSE], depth: -printDepth, width: printWidth] };
$newline => { IO.PutChar[SchemeSys.GetPort[a, FALSE], '\n] };
$writeChar => { IO.PutChar[SchemeSys.GetPort[b, FALSE], TheChar[a]] };
$binaryWrite => {
p: Port ~ SchemeSys.GetPort[b, FALSE];
IO.PutChar[p, '#];
IO.PutChar[p, '\001];
WriteBinary[a, p];
};
$changeLooks => {
p: Port ~ SchemeSys.GetPort[b, FALSE];
IO.PutF1[p, "%l", [rope[RopeFromString[TheString[a]]]]];
};
$setPrintProc => {
type: SafeStorage.Type ~ SafeStorage.GetReferentType[b];
card: CARD ~ CARDForType[type];
IF NOT IsProcedure[a] THEN Complain[a, "not a procedure"];
[] ¬ typedPrintProcs.Store[card, NEW[PrintProc ¬ SchemePrintProc]];
[] ¬ printProcData.Store[card, a];
};
$setCurrentInputPort => {
SchemeSys.SetPort[port: ThePort[a], in: TRUE];
};
$setCurrentOutputPort => {
SchemeSys.SetPort[port: ThePort[a], in: FALSE];
};
ENDCASE => ERROR;
};
result ¬ unspecified;
SchemeSys.DoWithIOErrorCatch[Inner];
};
NoteLoad:
PROC [userEnv: Environment, loadeeName, fullFName, createDate:
ROPE, definedSymbols: Any] ~ {
noteTaker: Scheme.Any ¬ NIL;
noteTakerName: Symbol ~ SymbolFromRope["*load-note-taker*"];
noteTaker ¬ LookupVariableValue[noteTakerName, userEnv ! Complain => CONTINUE];
IF noteTaker #
NIL
THEN {
p: Pair ¬ NIL;
IF createDate # NIL THEN p ¬ Cons[StringFromRope[createDate], p];
p ¬ Cons[StringFromRope[IF fullFName = NIL THEN loadeeName ELSE fullFName], p];
[] ¬ Apply[noteTaker, Cons[p, Cons[definedSymbols, NIL]] ! Complain => CONTINUE];
};
};
LoadPrim: PrimitiveProc ~ {
head: Pair ~ Cons[NIL, NIL];
last: Pair ¬ head;
env: Environment ~ NARROW[self.data];
loadeeName: ROPE ~ RopeFromString[TheString[a]];
Inner:
PROC [port:
IO.
STREAM, doExpand:
BOOL] ~ {
DoOne:
PROC [exp: Any] ~ {
WITH exp
SELECT
FROM
template: ByteCodeTemplate => {
proc: Procedure ~ ProcedureFromByteCodeTemplate[template, env];
last ¬ last.cdr ¬ Cons[Apply[proc, NIL], NIL];
RETURN;
};
pair: Pair => {
IF
NOT doExpand
THEN {
WITH pair.car
SELECT
FROM
syntax: PrimitiveSyntax => {
IF syntax = begin
THEN {
FOR tail: Any ¬ pair.cdr, Cdr[tail]
UNTIL tail =
NIL
DO
DoOne[Car[tail]];
ENDLOOP;
RETURN;
};
};
ENDCASE;
};
};
ENDCASE;
{
form: Any ~ IF doExpand THEN Expand[exp, env] ELSE exp;
proc: Procedure ~ Compile[form, env];
last ¬ last.cdr ¬ Cons[Apply[proc, NIL], NIL];
};
};
FOR exp: Any ¬ Read[port], Read[port]
UNTIL exp = endOfFile
DO
DoOne[exp];
ENDLOOP;
NoteLoad[env, loadeeName, SchemeSys.GetFileNameForStream[port], SchemeSys.GetFileCreateDateForStream[port], head.cdr];
};
SchemeSys.FindFileToLoad[loadeeName, Inner];
RETURN [head.cdr]
};
dot: Symbol ~ SymbolFromRope["."];
rpar: Symbol ~ SymbolFromRope[")"];
ReadRope:
PUBLIC
PROC [rope:
ROPE, forceLower:
BOOL]
RETURNS [Any] ~ {
RETURN [Read[IO.RIS[rope], forceLower]]
};
environmentRefSymbol: Symbol ¬ SymbolFromRope["environment-ref"];
ParseSymbolFromRope:
PROC [rope: Rope.
ROPE]
RETURNS [Any] ~ {
Handle environment-reference notation: look for colons in the given name and, if found, convert to calls on environment-ref.
index: INT ¬ rope.FindBackward[":"];
IF index = -1
OR rope.Fetch[0] = ':
OR index = rope.Length[]-1
THEN
RETURN [SymbolFromRope[rope]]
ELSE {
package: Rope.ROPE ¬ rope.Substr[0, index];
name: Rope.ROPE ¬ rope.Substr[index + 1];
RETURN [
Cons[environmentRefSymbol,
Cons[ParseSymbolFromRope[package],
Cons[Cons[$quote, Cons[SymbolFromRope[name],
NIL]],
NIL]]]];
};
};
Read:
PUBLIC
PROC [stream:
IO.
STREAM, forceLower:
BOOL ¬
TRUE]
RETURNS [readResult: Any ¬
NIL] ~ {
scratch: REF TEXT ~ RefText.ObtainScratch[100];
ReadInternal:
PROC [inList:
BOOL ¬
FALSE]
RETURNS [Any] ~ {
ch: CHAR ¬ '\000;
BEGIN
ch ¬ IO.GetChar[stream ! IO.EndOfStream => GO TO eof];
DO
-- loop for skipping comments
SELECT GetCharClass[ch]
FROM
whitespace => NULL;
comment => { [] ¬ IO.GetLineRope[stream] };
ENDCASE => EXIT;
ch ¬ IO.GetChar[stream ! IO.EndOfStream => GO TO eof];
ENDLOOP;
EXITS eof => RETURN [endOfFile]
END;
SELECT ch
FROM
'( => {
result: Any ¬ NIL;
last: Pair ¬ NIL;
DO
next: Any ¬ ReadInternal[inList: TRUE];
SELECT next
FROM
dot => {
afterDot: Any ¬ ReadInternal[inList: FALSE];
close: Any ¬ ReadInternal[inList: TRUE];
IF close # rpar
OR last =
NIL
THEN
Complain[result, "invalid dotted list"];
last.cdr ¬ afterDot;
RETURN [result]
};
rpar => { RETURN [result] };
endOfFile => { Complain[result, "unexpected-end-of-file"] };
ENDCASE => {
new: Pair ¬ Cons[next, NIL];
IF result = NIL THEN result ¬ new ELSE last.cdr ¬ new;
last ¬ new;
};
ENDLOOP;
};
') => {
IF
NOT inList
THEN
Complain[MakeChar[')], "unmatched right parenthesis"]
};
'\" => {
IO.Backup[self: stream, char: '\"];
RETURN [StringFromRope[NARROW[IO.GetRefAny[stream: stream]]]]
};
'\' => {
quoted: Any ¬ ReadInternal[inList: FALSE];
RETURN [Cons[$quote, Cons[quoted, NIL]]]
};
'\140
-- backquote -- => {
quoted: Any ¬ ReadInternal[inList: FALSE];
RETURN [Cons[$quasiquote, Cons[quoted, NIL]]]
};
', => {
q: Symbol ¬ $unquote;
IF IO.PeekChar[stream] = '@ THEN {[] ¬ IO.GetChar[stream]; q ¬ SymbolFromRope["unquote-splicing"]};
RETURN [Cons[q, Cons[ReadInternal[inList: FALSE], NIL]]]
};
'\000 => {
Must be Tioga formatting
RETURN [endOfFile]
};
'# => {
SELECT
IO.PeekChar[stream !
IO.EndOfStream => Complain[StringFromRope["#"], "unexpected end-of-file in middle of #-syntax"]]
FROM
'\001 => {[] ¬ IO.GetChar[stream]; RETURN [ReadBinary[stream]]};
'x, 'X, 'e, 'E, 'b, 'B, 'o, 'O, 'd, 'D, 'i, 'I, 's, 'S, 'l, 'L => {
token: REF TEXT ~ GetToken['#, stream, forceLower, inList, scratch];
RETURN [ParseNumber[CheckTEXT[token]]];
};
'( => {RETURN [VectorFromList[ReadInternal[inList: FALSE]]]};
'\" => {RETURN [ParseSymbolFromRope[NARROW[IO.GetRefAny[stream]]]]};
'\\ => {
s: CHAR ~ IO.GetChar[stream];
k:
CHAR ~
IO.PeekChar[stream
!
IO.EndOfStream =>
Complain[StringFromRope["#\\"],
"unexpected end-of-file in middle of #\\ character-name syntax"]];
IF Ascii.Letter[k]
THEN {
a: Any ~ Read[stream];
WITH a
SELECT
FROM
symbol: Symbol => {
rope: ROPE ~ RopeFromSymbol[symbol];
found: BOOL;
character: REF ANY;
Handle single-character names specially; the SymTab is case-insensitive.
IF Rope.Size[rope] = 1
THEN
RETURN [MakeChar[k]];
[found, character] ¬ SymTab.Fetch[x: charForName, key: rope];
IF found
THEN
RETURN [character];
};
ENDCASE => NULL;
Complain[a, "invalid character name"];
};
RETURN [MakeChar[IO.GetChar[stream]]]
};
'! => {
s: Any ¬ NIL;
[] ¬ IO.GetChar[stream];
s ¬ ReadInternal[inList: FALSE];
FOR p: PrimitiveSyntaxRep
IN PrimitiveSyntaxRep
DO
IF symbolForPrimitiveSyntaxRep[p] = s
THEN
RETURN [primitiveSyntaxForPrimitiveSyntaxRep[p]]
ENDLOOP;
IF s = $unspecified
THEN
RETURN [unspecified];
Complain[s, "unknown primitive syntax marker"];
};
't, 'T => { [] ¬ IO.GetChar[stream]; RETURN[true] };
'f, 'F => { [] ¬ IO.GetChar[stream]; RETURN[false] };
ENDCASE => {
ch: CHAR ~ IO.GetChar[stream];
rope: Rope.ROPE ~ IO.PutFR1["#%g", [character[ch]]];
Complain[StringFromRope[rope], "unknown syntax"];
};
};
ENDCASE => NULL; -- It's a complex token, either a symbol or a number
{
token: REF TEXT ¬ GetToken[ch, stream, forceLower, inList, scratch];
initial: CharClass ~ GetCharClass[token[0]];
hasColons: BOOL ¬ FALSE;
OKSym:
PROC
RETURNS [ok:
BOOL] ~
INLINE {
Also sets hasColons
[ok: ok, colons: hasColons] ¬ ValidAsSymbol[token];
};
SELECT
TRUE
FROM
inList
AND token.length = 1
AND (
SELECT token[0]
FROM '., ') =>
TRUE
ENDCASE =>
FALSE) =>
RETURN [Atom.MakeAtomFromRefText[token]];
OKSym[] => {
RETURN [IF hasColons THEN ParseSymbolFromRope[Rope.FromRefText[token]] ELSE Atom.MakeAtomFromRefText[token]]
};
initial = numeric
OR initial = dot
OR initial = sign => {
RETURN [ParseNumber[CheckTEXT[token]]];
};
ENDCASE =>
Complain[StringFromRope[Rope.FromRefText[token]], "illegally-formed symbol"];
};
};
readResult ¬ ReadInternal[];
RefText.ReleaseScratch[scratch];
};
paranoid: BOOL ~ FALSE;
CheckTEXT:
PROC [text:
REF
TEXT]
RETURNS [
REF
READONLY
TEXT] ~
INLINE {
Optionally copy into a TEXT of the exact size, to cause bounds faults when garbage would be referenced.
RETURN [IF paranoid THEN RefText.Append[to: NEW[TEXT[text.length]], from: text] ELSE text]
};
GetToken:
PROC [ch:
CHAR, stream:
IO.
STREAM, forceLower:
BOOL, tossTrailingWhite:
BOOL, scratch:
REF
TEXT]
RETURNS [token:
REF
TEXT] ~ {
This expects the initial character of the token to be in ch, and it better not be a terminator, comment, or whitespace.
IF tossTrailingWhite, may eat one whitespace character after the token.
token ¬ scratch;
token.length ¬ 0;
DO
SELECT GetCharClass[ch]
FROM
terminator, comment => { IO.Backup[stream, ch]; EXIT };
whitespace => { IF NOT tossTrailingWhite THEN IO.Backup[stream, ch]; EXIT };
ENDCASE => { token ¬ RefText.InlineAppendChar[token, ch] };
ch ¬ IO.GetChar[stream ! IO.EndOfStream => EXIT];
ENDLOOP;
IF token.length = 0 THEN ERROR; -- a caller bug
IF forceLower
THEN {
FOR i:
NAT
IN [0..token.length)
DO
token[i] ¬ Ascii.Lower[token[i]];
ENDLOOP;
};
};
ParseNumber:
PROC [text:
REF
READONLY
TEXT]
RETURNS [number: Any] ~ {
ch: CHAR;
culprit: Any ¬ endOfFile;
index: NAT ¬ 0;
len: NAT ~ text.length;
{
[number, index] ¬ ParseReal[text, index];
IF index < len
THEN
SELECT ch ¬ text[index]
FROM
'+, '- => {
imagPart: Any;
[imagPart, index] ¬ ParseReal[text, index];
number ¬ MakeRectangular[number, imagPart];
IF index >= len THEN GO TO blewIt;
ch ¬ text[(index¬index+1)-1];
IF Ascii.Lower[ch] # 'i
THEN {
culprit ¬ MakeChar[ch];
GO TO blewIt;
};
};
'@ => {
angle: Any;
[angle, index] ¬ ParseReal[text, index+1];
number ¬ MakePolar[number, angle];
};
ENDCASE => NULL;
IF index < len
THEN {
culprit ¬ MakeChar[text[index]];
GO TO blewIt;
};
EXITS
blewIt => Complain[culprit, "ill-formed number"];
};
};
bigZero: BigCardinals.BigCARD ~ BigCardinals.BigFromSmall[0];
bigOne: BigCardinals.BigCARD ~ BigCardinals.BigFromSmall[1];
preferFloat:
BOOL ¬
TRUE;
MultiplyByCARD:
PROC [big: BigCardinals.BigCARD, small:
CARD]
RETURNS [BigCardinals.BigCARD] ~ {
IF small = 0 OR BigCardinals.BigZero[big] THEN RETURN [bigZero];
IF small <= CARD16.LAST THEN RETURN [BigCardinals.MultiplyByDigit[big, small]];
RETURN [BigCardinals.BigMultiply[big, BigCardinals.BigFromCard[small]]];
};
ParseReal:
PROC [text:
REF
READONLY
TEXT, index:
NAT]
RETURNS [Any,
NAT] ~ {
len: NAT ~ text.length;
negative: BOOL ¬ FALSE;
exact: {true, false, unspecified} ¬ unspecified;
precisionSpecified: BOOL ¬ FALSE;
radix: CARDINAL ¬ 0; -- unspecified
exponent: INT ¬ 0;
exponentSign: INT ¬ 1;
state: {prefix, begin, numerator, dot, afterDot, denomBegin, denominator, suffixSign, suffixBegin, suffix} ¬ prefix;
ch: CHAR;
||| accumulators for numerator and denominator |||
smallLimit: CARD ~ CARD.LAST/16; -- if bigger than this, can't fit another digit
Digits: TYPE ~ RECORD [small: CARD, bigScale: CARD, big: BigCardinals.BigCARD ¬ BigCardinals.Zero]; -- represents small+(bigScale*big)
digitsZero: Digits ~ [small: 0, bigScale: 0, big: bigZero];
digitsOne: Digits ~ [small: 1, bigScale: 0, big: bigZero];
Which: TYPE ~ {num, denom};
val: ARRAY Which OF Digits ¬ [num: digitsZero, denom: digitsOne];
Fold:
PROC [w: Which] ~ {
val[w].big ¬ BigCardinals.BigAdd[
MultiplyByCARD[val[w].big, val[w].bigScale],
BigCardinals.BigFromCard[val[w].small]
];
val[w].small ¬ 0;
val[w].bigScale ¬ 1;
};
GetVal:
PROC [w: Which]
RETURNS [BigCardinals.BigCARD] ~
INLINE {
Fold[w];
RETURN [val[w].big]
};
AccumDigit:
PROC [w: Which, digit:
CARDINAL] ~
INLINE {
-- uses radix
IF val[w].small > smallLimit OR val[w].bigScale > smallLimit THEN Fold[w];
val[w].small ¬ val[w].small*radix+digit;
IF val[w].bigScale#0 THEN val[w].bigScale ¬ val[w].bigScale*radix;
};
{
AccumNumDigit:
PROC [ch:
CHAR, digit:
CARDINAL] ~ {
IF digit >= radix
THEN
Complain[MakeChar[ch], IO.PutFR1["illegal digit in radix %g numbers", [integer[radix]]]]
ELSE AccumDigit[num, digit]
};
AccumAfterDotDigit:
PROC [ch:
CHAR, digit:
CARDINAL] ~ {
AccumNumDigit[ch, digit];
AccumDigit[denom, 0];
};
AccumDenomDigit:
PROC [ch:
CHAR, digit:
CARDINAL] ~ {
IF digit >= radix
THEN
Complain[MakeChar[ch], IO.PutFR1["illegal digit in radix %g numbers", [integer[radix]]]]
ELSE AccumDigit[denom, digit]
};
SignFollows:
PROC
RETURNS [
BOOL] ~
INLINE {
RETURN [index<len AND GetCharClass[text[index]] = sign];
};
IF index < len
THEN
SELECT ch ¬ text[index]
FROM
'+, '- => {
index¬index+1;
negative ¬ (ch = '-);
};
ENDCASE;
WHILE index < len
DO
ch ¬ Ascii.Lower[text[(index¬index+1)-1]];
SELECT state
FROM
prefix => {
-- <prefix R>
IF ch = '#
THEN {
SetRadix:
PROC [r:
INTEGER] ~ {
IF radix = 0
THEN radix ¬ r
ELSE Complain[StringFromRope[IO.PutFR1["#%g", [character[ch]]]], "extra radix specifier"];
};
IF index>=len THEN Complain[StringFromRope[Rope.FromRefText[text]], "unexpected eof"];
SELECT ch ¬ Ascii.Lower[text[(index¬index+1)-1]]
FROM
'i, 'e =>
IF exact = unspecified
THEN {exact ¬ IF ch = 'i THEN false ELSE true}
ELSE Complain[StringFromRope[IO.PutFR1["#%g", [character[ch]]]], "extra exactness specifier"];
's, 'l =>
IF
NOT precisionSpecified
THEN precisionSpecified ¬ TRUE
ELSE Complain[StringFromRope[IO.PutFR1["#%g", [character[ch]]]], "extra precision specifier"];
ENDCASE =>
Complain[StringFromRope[IO.PutFR1["#%g", [character[ch]]]], "illegal numeric prefix"];
}
ELSE {
-- The next character is not a #
state ¬ begin;
IF radix = 0 THEN radix ¬ 10;
index ¬ index - 1;
};
};
begin => {
-- right after <prefix R>
SELECT ch
FROM
IN ['0..'9] => {
state ¬ numerator;
AccumNumDigit[ch, ch - '0];
};
IN ['a..'f] => {
state ¬ numerator;
AccumNumDigit[ch, ch - 'a + 10];
};
};
numerator => {
-- seen at least one <digit R>
SELECT
TRUE
FROM
ch = '/ => {
val[denom] ¬ digitsZero;
state ¬ denomBegin
};
ch = '. => {
state ¬ afterDot;
IF preferFloat AND exact = unspecified THEN exact ¬ false;
};
ch = '# => {
AccumNumDigit['0, 0]; -- Treat '# as an inexact zero
IF exact = true
THEN
Complain[MakeChar[ch], "an inexact digit appeared after an explicit #e exactness prefix"]
};
ch
IN ['0..'9] =>
AccumNumDigit[ch, ch - '0];
ch = 'e
AND (radix # 16
OR SignFollows[]) =>
state ¬ suffixSign;
ch
IN ['a..'f] =>
AccumNumDigit[ch, ch - 'a + 10];
ENDCASE =>
GO TO backupAndStop;
};
dot => {
-- no digits before the radix point; one required now
SELECT ch
FROM
IN ['0..'9] =>
AccumAfterDotDigit[ch, ch - '0];
IN ['a..'f] =>
AccumAfterDotDigit[ch, ch - 'a + 10];
state ¬ afterDot;
IF preferFloat AND exact = unspecified THEN exact ¬ false;
};
afterDot => {
-- the radix point has appeared, we can stop at any time
SELECT
TRUE
FROM
ch = '# => {
IF exact = true
THEN
Complain[MakeChar[ch], "an inexact digit appeared after an explicit #e exactness prefix"]
};
ch
IN ['0..'9] =>
AccumAfterDotDigit[ch, ch - '0];
ch = 'e
AND (radix # 16
OR SignFollows[]) =>
state ¬ suffixSign;
ch
IN ['a..'f] =>
AccumAfterDotDigit[ch, ch - 'a + 10];
ENDCASE =>
GO TO backupAndStop;
};
denomBegin => {
-- just saw the /
SELECT ch
FROM
IN ['0..'9] =>
AccumDenomDigit[ch, ch - '0];
IN ['a..'f] =>
AccumDenomDigit[ch, ch - 'a + 10];
state ¬ denominator;
};
denominator => {
-- seen at least one denominator digit
SELECT
TRUE
FROM
ch = '# => {
AccumDenomDigit['0, 0]; -- Treat '# as an inexact zero
IF exact = true
THEN
Complain[MakeChar[ch], "an inexact digit appeared after an explicit #e exactness prefix"]
};
ch
IN ['0..'9] =>
AccumDenomDigit[ch, ch - '0];
ch = 'e
AND (radix # 16
OR SignFollows[]) =>
state ¬ suffixSign;
ch
IN ['a..'f] =>
AccumDenomDigit[ch, ch - 'a + 10];
ENDCASE =>
GO TO backupAndStop;
};
suffixSign => {
-- just saw the 'e' for the exponent
IF preferFloat AND exact = unspecified THEN exact ← false;
SELECT ch
FROM
ENDCASE =>
index ¬ index-1;
state ¬ suffixBegin;
};
suffixBegin => {
-- ready for the first digit of the exponent
SELECT ch
FROM
IN ['0..'9] => {
exponent ¬ ch - '0;
state ¬ suffix;
};
};
suffix => {
-- seen at least one exponent digit
SELECT ch
FROM
IN ['0..'9] =>
exponent ¬ exponent * 10 + ch - '0;
ENDCASE =>
GO TO backupAndStop;
};
ENDCASE => ERROR; -- unknown state
REPEAT
backupAndStop => { index ¬ index-1 };
ENDLOOP;
SELECT state
FROM
numerator, afterDot, denominator, suffix => {
IF exact # false
AND exponent=0
AND val[num].bigScale = 0
AND val[denom].bigScale = 0
AND val[denom].small = 1
AND val[num].small <=
CARD[
INT.
LAST]
THEN {
SPECIAL CASE - Small exact integer
RETURN [MakeFixnum[IF negative THEN -INT[val[num].small] ELSE INT[val[num].small]], index];
};
IF exact = false
AND exponent=0
AND val[num].bigScale = 0
AND val[denom].bigScale = 0
AND val[num].small <= 1000000
AND val[denom].small <= 1000000
THEN {
SPECIAL CASE - Small inexact real; can generate flonum with only one roundoff
float: REAL ¬ REAL[INT[val[num].small]]/REAL[INT[val[denom].small]];
IF negative THEN float ¬ -float;
RETURN [NEW[NumberRep.flonum ¬ [FALSE, flonum[float]]], index];
};
RETURN [
MakeReal[
negative: negative,
numerator: GetVal[num],
denominator: GetVal[denom],
exponent: exponent * exponentSign,
radix: radix,
exact: exact # false], index];
};
EXITS
blewIt => Complain[MakeChar[ch], "illegal numeric body"];
};
};
ReadBinary:
PUBLIC
PROC [stream:
IO.
STREAM, symbolTable: SimpleVector ¬
NIL, encodingID:
BYTE ¬ 0]
RETURNS [Any] ~ {
ReadCount:
PROC
RETURNS [c:
CARD ¬ 0] ~ {
DO
byte: BYTE ~ ORD[IO.GetChar[stream]];
c ¬ c*128 + byte MOD 128;
IF byte < 128 THEN EXIT;
ENDLOOP;
};
ReadList:
PROC [length:
CARD, dotted:
BOOL ¬
FALSE]
RETURNS [Any] ~ {
first: Pair ¬ NIL;
last: Pair ¬ NIL;
THROUGH [0..length)
DO
new: Pair ~ Cons[ReadBinary[stream, symbolTable], NIL];
IF last = NIL THEN { first ¬ last ¬ new } ELSE { last ¬ last.cdr ¬ new };
ENDLOOP;
IF dotted THEN last.cdr ¬ ReadBinary[stream, symbolTable];
RETURN [first]
};
markerByte: BYTE ~ ORD[IO.GetChar[stream]];
IF markerByte >
ORD[Marker.
LAST]
THEN {Complain[MakeFixnum[IO.GetIndex[stream]], "malformed binary input at this byte index"]}
ELSE {
marker: Marker ~ VAL[markerByte];
SELECT marker
FROM
list0 => RETURN [NIL];
list1 => RETURN [ReadList[1]];
list2 => RETURN [ReadList[2]];
list3 => RETURN [ReadList[3]];
listN => RETURN [ReadList[ReadCount[]]];
dottedList => RETURN [ReadList[ReadCount[], TRUE]];
symbolTable => {
length: NAT ~ ReadCount[];
v: SimpleVector ~ NEW[SimpleVectorRep[length]];
FOR i:
NAT
IN [0..length)
DO
len: INT ~ ReadCount[];
name: ROPE ~ SchemeSys.GetRope[self: stream, len: len, demand: TRUE];
v[i] ¬ SymbolFromRope[name];
ENDLOOP;
RETURN [ReadBinary[stream, v]]
};
symbol => { RETURN [symbolTable[ReadCount[]]] };
quote => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[quote]] };
define => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[define]] };
setBang => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[setBang]] };
lambda => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[lambda]] };
begin => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[begin]] };
if => { RETURN [primitiveSyntaxForPrimitiveSyntaxRep[if]] };
true => { RETURN [true] };
false => { RETURN [false] };
char => { RETURN [MakeChar[IO.GetChar[stream]]] };
string => { RETURN [StringFromRope[SchemeSys.GetRope[stream, ReadCount[]]]] };
vector => {
length: NAT ~ ReadCount[];
v: SimpleVector ~ NEW[SimpleVectorRep[length]];
FOR i:
NAT
IN [0..length)
DO
v[i] ¬ ReadBinary[stream, symbolTable];
ENDLOOP;
RETURN [v];
};
zero => { RETURN [MakeFixnum[0]] };
one => { RETURN [MakeFixnum[1]] };
inexact => {
WITH ReadBinary[stream]
SELECT
FROM
num: Number => {num.exact ¬ FALSE; RETURN [num]};
ENDCASE => Complain[MakeFixnum[IO.GetIndex[stream]], "malformed binary input at this byte index"];
};
negFixnum => { RETURN [MakeFixnum[-INT[ReadCount[]]]] };
fixnum => { RETURN [MakeFixnum[ReadCount[]]] };
negFlonum, flonum => {
significand: INT ~ ReadCount[];
exponent: INT ~ WITH ReadBinary[stream] SELECT FROM n: Fixnum => n ENDCASE => Complain[MakeFixnum[IO.GetIndex[stream]], "malformed binary input at this byte index"];
mag: REAL ~ Real.FScale[REAL[significand], exponent];
RETURN [NEW [NumberRep.flonum ¬ [TRUE, flonum[IF marker=negFlonum THEN -mag ELSE mag]]]]
};
negBignum, bignum => {
RETURN [NEW [NumberRep.bignum ¬ [TRUE, bignum[neg: marker=negBignum, magnitude: BigCardinals.BigFromBinaryRope[SchemeSys.GetRope[self: stream, len: ReadCount[], demand: TRUE]]]]]]
};
ratnum => {
numerator: Any ~ ReadBinary[stream];
denominator: Any ~ ReadBinary[stream];
RETURN [NEW [NumberRep.ratnum ¬ [TRUE, ratnum[numerator: numerator, denominator: denominator]]]]
};
complex => {
x: Any ~ ReadBinary[stream];
y: Any ~ ReadBinary[stream];
RETURN [NEW [NumberRep.complex ¬ [TRUE, complex[x: x, y: y]]]]
};
unspecified => { RETURN [unspecified] };
byteCodes => {
length: NAT ~ ReadCount[];
bc: ByteCodes ~ NEW[ByteCodesRep[length]];
FOR i:
NAT
IN [0..length)
DO
bc[i] ¬ ORD[IO.GetChar[stream]];
ENDLOOP;
RETURN [bc];
};
byteCodeTemplate => {
name: Any ~ ReadBinary[stream, symbolTable];
envNames: SimpleVector ~ NARROW[ReadBinary[stream, symbolTable]];
dotted: BOOL ~ True[ReadBinary[stream, symbolTable]];
minArgs: NAT ~ KCheck[ReadBinary[stream, symbolTable]];
maxArgs: NAT ~ KCheck[ReadBinary[stream, symbolTable]];
globalNames: ProperList ~ NARROW[ReadBinary[stream, symbolTable]];
literals: ProperList ~ NARROW[ReadBinary[stream, symbolTable]];
doc: Rope.ROPE ~ RopeFromString[TheString[ReadBinary[stream, symbolTable]]];
ext: Any ~ ReadBinary[stream, symbolTable];
RETURN [
NEW[ByteCodeTemplateRep ¬ [
name: name,
envNames: envNames,
dotted: dotted,
minArgs: minArgs,
maxArgs: maxArgs,
globalNames: globalNames,
literals: literals,
doc: doc,
ext: ext
]]];
};
ENDCASE => ERROR;
};
};
charForName: SymTab.Ref ~ SymTab.Create[case: FALSE];
nameForChar: REF ARRAY CHAR OF ROPE ~ InitCharNames[];
InitCharNames:
PROC
RETURNS [
REF
ARRAY
CHAR
OF
ROPE] ~ {
a: REF ARRAY CHAR OF ROPE ¬ NEW[ARRAY CHAR OF ROPE];
AddName:
PROC [char:
CHAR, name:
ROPE] ~ {
[] ¬ SymTab.Store[x: charForName, key: name, val: MakeChar[char]];
a[char] ¬ name;
};
Names are added in increasing order of preference on output. That is, the last name assigned to each character is the one to be used on output.
FOR c:
CHAR
IN
CHAR
DO
AddName[c, Rope.Flatten[IO.PutFR1[format: "o%03b", value: [integer[ORD[c]]]]]];
ENDLOOP;
AddName['(, Rope.Flatten["OpenPar"]];
AddName['(, Rope.Flatten["OpenParen"]];
AddName['), Rope.Flatten["ClosePar"]];
AddName['), Rope.Flatten["CloseParen"]];
FOR c:
CHAR
IN (' ..'~]
DO
AddName[c, Rope.FromChar[c]];
ENDLOOP;
AddName['\r, Rope.Flatten["Return"]];
AddName['\l, Rope.Flatten["LineFeed"]];
AddName['\n, Rope.Flatten["Newline"]];
AddName['\t, Rope.Flatten["Tab"]];
AddName[' , Rope.Flatten["Space"]];
AddName['\f, Rope.Flatten["FormFeed"]];
RETURN [a]
};
PrintRopeLiteral:
PROC [stream:
IO.
STREAM, rope:
ROPE, width:
INT] ~ {
r: INT ¬ IF width > INT.LAST/8 THEN INT.LAST ELSE width*8;
Action:
PROC [c:
CHAR]
RETURNS [quit:
BOOL ¬
FALSE] ~ {
IF r = 0
THEN {
IO.PutRope[stream, "..."];
RETURN [TRUE]
};
IF c = '"
OR c='\\
THEN
IO.PutChar[stream, '\\];
IF c
IN [' .. '~]
THEN
IO.PutChar[stream, c]
ELSE
IO.PutF1[stream, "\\%03b", [cardinal[ORD[c]]]];
r ¬ r - 1;
};
IO.PutChar[stream, '"];
[] ¬ Rope.Map[base: rope, action: Action];
IO.PutChar[stream, '"];
};
sigBits:
REAL ¬ 24.0; -- default number of significant bits for non-flonum inexact numbers
PutInexactRatio:
PROC [stream:
IO.
STREAM, numerator, denominator: BigCardinals.BigCARD, significantBits:
REAL] ~ {
numBits: INT ~ BigCardinals.FirstOneBit[numerator];
denBits: INT ~ BigCardinals.FirstOneBit[denominator];
exponent: INT ~ Real.Round[(numBits-denBits-significantBits)*0.301];
sNum: BigCardinals.BigCARD ~ (
IF exponent >= 0
THEN numerator
ELSE BigCardinals.BigMultiply[numerator, BigCardinals.BigPowerOfTen[-exponent]]);
sDen: BigCardinals.BigCARD ~ (
IF exponent <= 0
THEN denominator
ELSE BigCardinals.BigMultiply[denominator, BigCardinals.BigPowerOfTen[exponent]]);
quo, rem: BigCardinals.BigCARD;
[quo, rem] ¬ BigCardinals.BigDivMod[sNum, sDen];
SELECT BigCardinals.BigCompare[BigCardinals.BigAdd[rem, rem], sDen]
FROM
greater => { quo ¬ BigCardinals.BigAdd[quo, bigOne] };
equal => {
break tie by rounding towards even.
IF BigCardinals.BigOdd[quo] THEN quo ¬ BigCardinals.BigAdd[quo, bigOne];
};
ENDCASE => NULL;
IF BigCardinals.BigZero[quo]
THEN IO.PutRope[stream, "0.0"]
ELSE {
digits: ROPE ¬ BigCardinals.BigToDecimalRope[quo];
nDigits: INT ¬ Rope.Size[digits];
exp: INT ¬ exponent;
WHILE nDigits > 2
AND Rope.Fetch[digits, nDigits-1] = '0
DO
digits ¬ Rope.Substr[base: digits, start: 0, len: nDigits-1];
nDigits ¬ nDigits-1;
exp ¬ exp + 1;
ENDLOOP;
IO.PutF[stream, "%g.%g", [character[Rope.Fetch[digits, 0]]], [rope[Rope.Substr[digits, 1]]]];
IF exp+(nDigits-1) # 0
THEN {
IO.PutF1[stream, "e%g", [integer[exp+(nDigits-1)]]];
};
};
};
typedPrintProcs: CardTab.Ref ~ CardTab.Create[];
fallbackPrintProcs: LIST OF PrintProc ¬ NIL;
printProcData: CardTab.Ref ~ CardTab.Create[];
CARDForType:
PROC [type: SafeStorage.Type]
RETURNS [
CARD] ~
INLINE {
RETURN [ORD[type]]
};
RegisterPrintProc:
PUBLIC PROC [proc: PrintProc, type: SafeStorage.Type] ~ {
[] ¬ typedPrintProcs.Store[CARDForType[type], NEW[PrintProc ¬ proc]];
};
RegisterFallbackPrintProc:
PUBLIC PROC [proc: PrintProc] ~ {
fallbackPrintProcs ¬ CONS[proc, fallbackPrintProcs];
};
RegisterSimplePrintProc:
PUBLIC PROC [typeName: Rope.
ROPE, type: SafeStorage.Type] ~ {
card: CARD ~ CARDForType[type];
[] ¬ typedPrintProcs.Store[card, NEW[PrintProc ¬ SimplePrintProc]];
[] ¬ printProcData.Store[card, typeName];
};
SimplePrintProc: PrintProc ~ {
type: SafeStorage.Type ~ SafeStorage.GetReferentType[value];
name: Rope.ROPE ~ NARROW[printProcData.Fetch[CARDForType[type]].val];
stream.PutF["#<%g @ %x>", [rope[name]], [cardinal[LOOPHOLE[value, CARD]]]];
};
SchemePrintProc: PrintProc ~ {
type: SafeStorage.Type ~ SafeStorage.GetReferentType[value];
proc: Any ~ printProcData.Fetch[CARDForType[type]].val;
[] ¬ Apply[proc, Cons[stream, Cons[value, Cons[IF display THEN true ELSE false, NIL]]]];
};
Print:
PUBLIC
PROC [a: Any, stream:
IO.
STREAM, depth:
INT ¬
INT.
LAST, width:
INT ¬
INT.
LAST] ~ {
HACK: if depth < 0, does display instead of write
display: BOOL ¬ depth < 0;
depth1: INT ¬ IF depth < 0 THEN depth+1 ELSE IF depth > 0 THEN depth-1 ELSE depth;
PrintList:
PROC [pair: Pair] ~ {
rest: Pair ¬ NIL;
rem: INT ¬ width;
FOR each: Pair ¬ pair, rest
UNTIL each =
NIL
DO
IF rest # NIL THEN IO.PutRope[stream, " "];
IF rem <= 0 THEN {IO.PutRope[stream, ". . ."]; EXIT};
Print[a: each.car, stream: stream, depth: depth1, width: width];
rem ¬ rem - 1;
WITH each.cdr
SELECT
FROM
p: Pair => rest ¬ p;
ENDCASE => {
IF each.cdr #
NIL
THEN {
IO.PutRope[stream, " . "];
Print[a: each.cdr, stream: stream, depth: depth1, width: width];
};
rest ¬ NIL;
};
ENDLOOP;
};
WITH a
SELECT
FROM
pair: Pair => {
IF depth = 0 THEN {IO.PutRope[stream, "( . . . )"]; RETURN};
IO.PutRope[stream, "("];
PrintList[pair];
IO.PutRope[stream, ")"];
};
num: Fixnum => IO.PutF1[stream, "%g", [integer[num]]];
num: Flonum => {
IF num.exact
THEN { Print[a: Arith[plus, num, MakeFixnum[0]], stream: stream, depth: depth1, width: width] }
ELSE { IO.PutF1[stream, "%g", [real[num.real]]] };
};
num: Bignum => {
IF num.neg THEN IO.PutChar[stream, '-];
IF num.exact
THEN {
IO.PutRope[stream, BigCardinals.BigToDecimalRope[num.magnitude]];
}
ELSE { PutInexactRatio[stream, num.magnitude, bigOne, sigBits] };
};
num: Ratnum => {
IF num.exact
THEN {
Print[num.numerator, stream, depth, width];
IO.PutChar[stream, '/];
Print[num.denominator, stream, depth, width];
}
ELSE {
numer: Bignum ~ NARROW[num.numerator];
denom: Bignum ~ NARROW[num.denominator];
IF numer.neg THEN IO.PutChar[stream, '-];
PutInexactRatio[stream, numer.magnitude, denom.magnitude, sigBits];
};
};
num: Complex => {
Print[num.x, stream, depth, width];
IF NOT Negative[num.y] THEN IO.PutChar[stream, '+];
Print[num.y, stream, depth, width];
IO.PutChar[stream, 'i];
};
b: REF BOOL => IO.PutRope[stream, IF b THEN "#t" ELSE "#f"];
v: SimpleVector => {
IF depth = 0 THEN {IO.PutRope[stream, "#( . . . )"]; RETURN};
IO.PutRope[stream, "#("];
FOR i:
NAT
IN [0..v.length)
DO
IF i # 0 THEN IO.PutRope[stream, " "];
IF i >= width THEN { IO.PutRope[stream, ". . ."]; EXIT };
Print[a: v[i], stream: stream, depth: depth1, width: width];
ENDLOOP;
IO.PutRope[stream, ")"];
};
v: Vector => {
IF depth = 0 THEN {IO.PutRope[stream, "#( . . . )"]; RETURN};
IO.PutRope[stream, "#("];
FOR i:
INT
IN [0..v.length)
DO
IF i # 0 THEN IO.PutRope[stream, " "];
IF i >= width THEN { IO.PutRope[stream, ". . ."]; EXIT };
Print[a: VectorRef[v, i], stream: stream, depth: depth1, width: width];
ENDLOOP;
IO.PutRope[stream, ")"];
};
symbol: Symbol => {
rope: Rope.Text ~ Atom.GetPName[symbol];
IF ValidAsSymbol[RefText.TrustTextRopeAsText[rope]].ok
THEN IO.PutRope[stream, rope]
ELSE IO.PutF1[stream, "#\"%q\"", [rope[rope]]];
};
string: String => {
IF depth < 0
THEN IO.PutRope[stream, RopeFromString[string]]
ELSE PrintRopeLiteral[stream, RopeFromString[string], width];
};
rope:
ROPE => {
IF depth < 0
THEN IO.PutRope[stream, rope]
ELSE PrintRopeLiteral[stream, rope, width];
};
char: Char => {
IF depth < 0
THEN IO.PutChar[stream, char]
ELSE IO.PutF1[stream, "#\\%g", [rope[nameForChar[char]]]];
};
p: Primitive => {
pRep: Pair ¬ Cons[StringFromRope[p.doc], NIL];
IF p.doc.Fetch[0] # '(
THEN {
IF p.dotted THEN pRep ¬ Cons[$rest, pRep] ELSE pRep ¬ Cons[NIL, pRep];
IF p.minArgs # p.maxArgs THEN pRep.car ¬ Cons[StringFromRope["]"], pRep.car];
FOR n:
NAT
DECREASING
IN [0..p.maxArgs)
DO
pRep.car ¬ Cons[SymbolFromRope[Rope.FromChar['a+n]], pRep.car];
IF n = p.minArgs THEN pRep.car ¬ Cons[StringFromRope["["], pRep.car];
ENDLOOP;
};
IO.PutF1[stream, "#<primitive %g: ", [atom[p.symbol]]];
depth1 ¬ -2;
PrintList[pRep];
IO.PutRope[stream, ">"];
};
p: TidbitProcedure => {
IO.PutRope[stream, "#<procedure "];
Print[p.code.name, stream];
IO.PutF1[stream, ": %g>", [rope[p.code.doc]]];
};
p: CompoundProcedure => {
names: SimpleVector ~ p.parameterNames;
pRep: Pair ← NIL;
IF ISTYPE[Car[p.body], String] AND Cdr[p.body] # NIL THEN -- it's a doc string
pRep ← Cons[Car[p.body], NIL];
IF pRep = NIL OR StringRef[NARROW[pRep.car], 0] # '( THEN {
IF p.dotted THEN
pRep ← Cons[names[names.length-1], pRep]
ELSE
pRep ← Cons[NIL, pRep];
FOR i: NAT DECREASING IN [0..names.length - (IF p.dotted THEN 1 ELSE 0)) DO
pRep.car ← Cons[names[i], pRep.car];
ENDLOOP;
};
IO.PutRope[stream, "#<procedure"];
IF depth # 0 THEN {
IO.PutRope[stream, " "];
depth1 ← -2;
PrintList[pRep]
};
IO.PutRope[stream, ">"];
};
s: Syntax => {
IO.PutRope[stream, "#<syntax "];
IF depth # 0 THEN Print[a: s.expander, stream: stream, depth: depth1, width: width];
IO.PutRope[stream, ">"];
};
p: PrimitiveSyntax => {
IF NOT display THEN IO.PutRope[stream, "#!"];
IO.PutRope[stream, RopeFromSymbol[symbolForPrimitiveSyntaxRep[p]]];
};
env: Environment => {
IO.PutRope[stream, "#<environment "];
Print[a: IF env.names = NIL THEN env[1] ELSE env.names, stream: stream, depth: -ABS[depth1], width: width]; -- force display
IO.PutRope[stream, ">"];
};
p: Port => {
class: ATOM ~ IO.GetInfo[stream: p].class;
IO.PutRope[stream, "#<"];
IO.PutRope[stream, SELECT IO.GetInfo[stream: p].variety FROM input => "input", output => "output", inputOutput => "input-output" ENDCASE => ERROR];
IO.PutRope[stream, "-port "];
IO.PutRope[stream, RopeFromSymbol[class]];
IF SchemeSys.IsFileStream[stream]
THEN {
IO.PutRope[stream, " "];
IO.PutRope[stream, SchemeSys.GetFileNameForStream[stream]];
};
IO.PutRope[stream, ">"];
};
r: Record => {
length: NAT ~ r.length;
index: NAT ¬ 0;
proc: Any ¬ NIL;
WHILE index # length
DO
WITH r[index]
SELECT
FROM
p: Pair => {
-- Magic cookie for record type: (print-proc . length)
proc ¬ p.car;
index ¬ KCheck[p.cdr, length];
};
ENDCASE =>
-- Oops! No magic cookie; record either bad or not yet together
GOTO bad;
ENDLOOP;
[] ¬ Apply[proc, Cons[stream, Cons[r, Cons[IF display THEN true ELSE false, NIL]]]];
EXITS
bad => stream.PutF1["#<Record @ %x>", [cardinal[LOOPHOLE[r, CARD]]]];
};
ENDCASE => {
SELECT a
FROM
NIL => IO.PutRope[stream, "()"];
endOfFile => IO.PutRope[stream, "#<eof-object>"];
unspecified => IO.PutRope[stream, "#!unspecified"];
ENDCASE => {
type: SafeStorage.Type ~ SafeStorage.GetReferentType[a];
WITH typedPrintProcs.Fetch[CARDForType[type]].val
SELECT
FROM
proc:
REF PrintProc =>
[] ¬ proc[stream, a, display];
ENDCASE => {
FOR tail:
LIST
OF PrintProc ¬ fallbackPrintProcs, tail.rest
UNTIL tail =
NIL
DO
IF tail.first[stream, a, display] THEN RETURN;
ENDLOOP;
IO.PutF1[stream, "%g", [refAny[a]]];
};
};
};
};
AtomTableEntry: TYPE ~ REF AtomTableEntryRep;
AtomTableEntryRep:
TYPE ~
RECORD [symbol: Symbol, n:
CARD];
CompareAtomTableEntry: List.CompareProc = {
[ref1: REF ANY, ref2: REF ANY] RETURNS [Basics.Comparison]
a: AtomTableEntry ~ NARROW[ref1];
b: AtomTableEntry ~ NARROW[ref2];
RETURN [Basics.CompareCard[b.n, a.n]]
};
largestFlonumFraction: REAL ¬ LargestFlonumFraction[];
LargestFlonumFraction:
PROC
RETURNS [
REAL] ~
INLINE {
a: REAL ¬ 0.5;
FOR i:
NAT
IN [0..1000)
DO
b: REAL ~ a+a+0.5;
IF b = REAL[Real.Fix[b]] THEN RETURN [a];
a ¬ b;
ENDLOOP;
ERROR; -- this doesn't act like floating point!
};
BinaryFlonum:
TYPE ~
RECORD [neg:
BOOL, significand:
CARD, exponent:
INT];
BinaryFlonumFromREAL:
PROC [real:
REAL]
RETURNS [b: BinaryFlonum ¬ [
FALSE, 0, 0]] ~ {
IF real < 0 THEN {real ¬ -real; b.neg ¬ TRUE};
WHILE real > largestFlonumFraction
DO
real ¬ Real.FScale[real, -1];
b.exponent ¬ b.exponent + 1;
ENDLOOP;
UNTIL real = Real.Round[real]
DO
real ¬ Real.FScale[real, 1];
b.exponent ¬ b.exponent - 1;
ENDLOOP;
b.significand ¬ Real.Round[real];
};
WriteBinary:
PUBLIC
PROC [a: Any, stream:
IO.
STREAM, encodingID:
BYTE ¬ 0] ~ {
list: LIST OF REF ¬ NIL;
tab: RefTab.Ref ~ RefTab.Create[];
n: INT ¬ 0;
recursionLimit: NAT ¬ 100; -- for protection against circular structures
WriteMarker: PROC [marker: Marker] ~ { IO.PutChar[stream, VAL[ORD[marker]]] };
WriteCount:
PROC [i:
CARD] ~ {
c: ARRAY [0..5) OF BYTE ¬ ALL[0];
k: NAT ¬ 0;
DO
c[k] ¬ (i MOD 128) + 128;
k ¬ k + 1;
i ¬ i / 128;
IF i = 0 THEN EXIT;
ENDLOOP;
c[0] ¬ c[0]-128;
UNTIL k = 0
DO
k ¬ k - 1;
IO.PutChar[stream, VAL[c[k]]];
ENDLOOP;
};
WriteNumber:
PROC [any: Any] ~ {
WITH any
SELECT
FROM
num: Fixnum => {
WriteMarker[IF num < 0 THEN negFixnum ELSE fixnum];
WriteCount[ABS[num]];
};
num: Flonum => {
b: BinaryFlonum ~ BinaryFlonumFromREAL[num.real];
WriteMarker[IF num.real < 0 THEN negFlonum ELSE flonum];
WriteCount[b.significand];
WriteMarker[IF b.exponent < 0 THEN negFixnum ELSE fixnum];
WriteCount[ABS[b.exponent]];
};
num: Bignum => {
rope: ROPE ~ BigCardinals.BigToBinaryRope[num.magnitude];
WriteMarker[IF num.neg THEN negBignum ELSE bignum];
WriteCount[Rope.Size[rope]];
IO.PutRope[stream, rope];
};
num: Ratnum => {
WriteMarker[ratnum];
WriteNumber[num.numerator];
WriteNumber[num.denominator];
};
num: Complex => {
WriteMarker[complex];
WriteNumber[num.x];
WriteNumber[num.y];
};
ENDCASE => Complain[any, "not an externalizeable number"];
};
Pass1:
PROC [a: Any] ~ {
SchemeSys.CheckForAbort[];
recursionLimit ¬ recursionLimit - 1; -- for protection against circular structures
DO
WITH a
SELECT
FROM
pair: Pair => { Pass1[pair.car]; a ¬ pair.cdr; LOOP };
symbol: Symbol => {
ate: AtomTableEntry ~ NARROW[RefTab.Fetch[x: tab, key: symbol].val];
IF ate =
NIL
THEN {
list ¬ CONS[NEW[AtomTableEntryRep ¬ [symbol, 1]], list];
[] ¬ RefTab.Insert[x: tab, key: symbol, val: list.first]
}
ELSE { ate.n ¬ ate.n + 1 }
};
v: SimpleVector => {
FOR i:
NAT
IN [0..v.length)
DO
Pass1[v[i]];
ENDLOOP;
};
v: Vector => {
FOR i:
INT
IN [0..v.length)
DO
Pass1[v.ref[v, i]];
ENDLOOP;
};
bct: ByteCodeTemplate => {
Pass1[bct.name];
Pass1[bct.envNames];
Pass1[bct.globalNames];
Pass1[bct.literals];
};
ENDCASE => NULL;
EXIT;
ENDLOOP;
recursionLimit ¬ recursionLimit + 1;
};
Pass2:
PROC [a: Any] ~ {
SchemeSys.CheckForAbort[];
WITH a
SELECT
FROM
pair: Pair => {
length: INT ¬ 0;
dotted: BOOL ¬ FALSE;
FOR tail: Any ¬ pair, Cdr[tail]
DO
WITH tail
SELECT
FROM
p: Pair => { length ¬ length + 1 };
ENDCASE => {dotted ¬ tail#NIL; EXIT};
ENDLOOP;
IF dotted
OR length > 3
THEN {
WriteMarker[IF dotted THEN dottedList ELSE listN];
WriteCount[length];
}
ELSE {
WriteMarker[SELECT length FROM 1 => list1, 2 => list2, 3 => list3 ENDCASE => ERROR];
};
FOR tail: Any ¬ pair, Cdr[tail]
DO
WITH tail
SELECT
FROM
p: Pair => {Pass2[p.car]};
ENDCASE => {IF dotted THEN Pass2[tail]; EXIT};
ENDLOOP;
};
symbol: Symbol => {
ate: AtomTableEntry ~ NARROW[RefTab.Fetch[x: tab, key: symbol].val];
WriteMarker[symbol];
WriteCount[ate.n];
};
primitiveSyntax: PrimitiveSyntax => {
WriteMarker[
SELECT primitiveSyntax
FROM
quote => quote, define => define, setBang => setBang, lambda => lambda, begin => begin, if => if
ENDCASE => ERROR];
};
num: Fixnum => {
SELECT num
FROM
0 => WriteMarker[zero];
1 => WriteMarker[one];
ENDCASE => WriteNumber[num]
};
num: Number => {
IF NOT num.exact THEN WriteMarker[inexact];
WriteNumber[num];
};
b: REF BOOL => { WriteMarker[IF b THEN true ELSE false] };
v: SimpleVector => {
WriteMarker[vector];
WriteCount[v.length];
FOR i:
NAT
IN [0..v.length)
DO
Pass2[v[i]];
ENDLOOP;
};
v: Vector => {
WriteMarker[vector];
WriteCount[v.length];
FOR i:
INT
IN [0..v.length)
DO
Pass2[v.ref[v, i]];
ENDLOOP;
};
string: String => {
rope: ROPE ~ RopeFromString[string];
WriteMarker[string];
WriteCount[Rope.Size[rope]];
IO.PutRope[stream, rope];
};
char: Char => {
WriteMarker[char];
IO.PutChar[stream, char];
};
bct: ByteCodeTemplate => {
WriteMarker[byteCodeTemplate];
Pass2[bct.name];
Pass2[bct.envNames];
Pass2[IF bct.dotted THEN true ELSE false];
Pass2[MakeFixnum[bct.minArgs]];
Pass2[MakeFixnum[bct.maxArgs]];
Pass2[bct.globalNames];
Pass2[bct.literals];
Pass2[StringFromRope[bct.doc]];
Pass2[bct.ext];
};
bc: ByteCodes => {
WriteMarker[byteCodes];
WriteCount[bc.size];
FOR i:
INT
IN [0..bc.size)
DO
IO.PutChar[stream, VAL[bc[i]]];
ENDLOOP;
};
ENDCASE => {
SELECT a
FROM
NIL => WriteMarker[list0];
unspecified => WriteMarker[unspecified];
ENDCASE => Complain[a, "cannot be externalized"];
};
};
Pass1[a];
IF list #
NIL
THEN {
list ¬ List.Sort[list: list, compareProc: CompareAtomTableEntry];
WriteMarker[symbolTable];
WriteCount[List.Length[list]];
FOR each:
LIST
OF
REF ¬ list, each.rest
UNTIL each =
NIL
DO
ate: AtomTableEntry ~ NARROW[each.first];
text: Rope.Text ~ Atom.GetPName[ate.symbol];
WriteCount[Rope.Size[text]];
IO.PutRope[self: stream, r: text];
ate.n ¬ n;
n ¬ n + 1;
ENDLOOP;
};
Pass2[a];
};
CharClass: TYPE ~ {lowercase, extendedAlpha, uppercase, numeric, dot, sign, terminator, whitespace, comment, other};
charClassTable: REF ARRAY CHAR OF CharClass ~ NEW[ARRAY CHAR OF CharClass ¬ InitCharClassTable[]];
GetCharClass:
PROC [char:
CHAR]
RETURNS [CharClass] ~
INLINE {
RETURN [charClassTable[char]]
};
InitCharClassTable:
PROC
RETURNS [a:
ARRAY
CHAR
OF CharClass] ~
INLINE {
FOR char:
CHAR
IN
CHAR
DO
a[char] ¬ (
SELECT char
FROM
Ascii.SP, Ascii.TAB, Ascii.CR, Ascii.LF, Ascii.FF => whitespace,
'(, '), '" => terminator,
IN ['a..'z] => lowercase,
IN ['A..'Z] => uppercase,
'; => comment,
'*, '/, '<, '=, '>, '!, '?, ':, '$, '%, '←, '&, '~, '^ => extendedAlpha,
IN ['0..'9] => numeric,
'+, '- => sign,
'. => dot,
'{, '} => extendedAlpha, -- A Cedar Scheme extension
ENDCASE => other
)
ENDLOOP;
};
ValidAsSymbol:
PROC [text:
REF
READONLY
TEXT]
RETURNS [ok:
BOOL ¬
TRUE, colons:
BOOL ¬
FALSE] ~ {
notInitialDot: BOOL ¬ TRUE;
IF text.length = 0 THEN RETURN [FALSE];
SELECT GetCharClass[text[0]]
FROM
lowercase, extendedAlpha => NULL;
sign => ok ¬ (text.length=1);
dot => {ok ¬ (text.length>1); notInitialDot ¬
FALSE};
A Cedar Scheme extension; allow symbols consisting solely of two or more dots
ENDCASE => {ok ¬ FALSE};
FOR i:
NAT
IN (0..text.length)
WHILE ok
DO
SELECT GetCharClass[text[i]]
FROM
extendedAlpha => { IF text[i] = ': THEN colons ¬ TRUE; ok ¬ notInitialDot };
lowercase, numeric, sign => {ok ¬ notInitialDot};
dot => NULL;
ENDCASE => {ok ¬ FALSE};
ENDLOOP;
};
Registration of Primitives
RegisterEssentials:
PROC [env: Environment] ~ {
DefinePrimitive[name: "input-port?", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $inputPred, doc: "test for input-port type"];
DefinePrimitive[name: "output-port?", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $outputPred, doc: "test for output-port type"];
DefinePrimitive[name: "current-input-port", nArgs: 0, dotted: FALSE, proc: PortPrim, env: env, data: $currentIn, doc: "returns the default input port"];
DefinePrimitive[name: "current-output-port", nArgs: 0, dotted: FALSE, proc: PortPrim, env: env, data: $currentOut, doc: "returns the default output port"];
DefinePrimitive[name: "open-input-file", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $openIn, doc: "open input file named by the string a"];
DefinePrimitive[name: "open-output-file", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $openOut, doc: "open output file named by the string a"];
DefinePrimitive[name: "close-input-port", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $close, doc: "close the port a"];
DefinePrimitive[name: "close-output-port", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $close, doc: "close the port a"];
DefinePrimitive[name: "read", nArgs: 1, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $read, doc: "read an object"];
DefinePrimitive[name: "read-char", nArgs: 1, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $readChar, doc: "read a character"];
DefinePrimitive[name: "char-ready?", nArgs: 1, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $charReadyPred, doc: "check for available characters"];
DefinePrimitive[name: "eof-object?", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $eofObjectPred, doc: "test for end-of-file object"];
DefinePrimitive[name: "write", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $write, doc: "write an object in unambiguous form"];
DefinePrimitive[name: "display", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $display, doc: "display an object in unclutterd form"];
DefinePrimitive[name: "newline", nArgs: 1, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $newline, doc: "begin a new line"];
DefinePrimitive[name: "write-char", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $writeChar, doc: "write a character"];
DefinePrimitive[name: "load", nArgs: 1, dotted: FALSE, proc: LoadPrim, env: env, data: env, doc: "load a Scheme file"];
};
RegisterExtensions:
PROC [env: Environment] ~ {
DefinePrimitive[name: "register-print-proc", nArgs: 2, dotted: FALSE, proc: PortPrim, env: env, data: $setPrintProc, doc: "(proc value) Register PROC as the printer for values of the same type as VALUE"];
DefinePrimitive[name: "open-input-string", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $openInString, doc: "create an input port on the string a"];
DefinePrimitive[name: "open-output-string", nArgs: 0, dotted: FALSE, proc: PortPrim, env: env, data: $openOutString, doc: "create an output port for get-output-string"];
DefinePrimitive[name: "get-output-string", nArgs: 1, dotted: FALSE, proc: PortPrim, env: env, data: $getOutString, doc: "get the string contents of a port created with open-output-string"];
DefinePrimitive[name: "unread-char", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $unreadChar, doc: "put back a lookahead character"];
DefinePrimitive[name: "binary-write", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $binaryWrite, doc: "write a binary item"];
DefinePrimitive[name: "change-looks", nArgs: 2, optional: 1, dotted: FALSE, proc: PortPrim, env: env, data: $changeLooks, doc: "Change the current looks on the port b using the string a"];
DefinePrimitive[name: "quit", nArgs: 0, dotted: FALSE, proc: REPPrim, data: $quit, doc: "Terminate the read-eval-print loop", env: env];
DefinePrimitive[name: "set-rep-environment!", nArgs: 1, dotted: FALSE, proc: REPPrim, data: $setEnv, doc: "(env) Change the environment used by the read-eval-print loop to env", env: env];
DefinePrimitive[name: "enqueue-action!", nArgs: 2, dotted: FALSE, proc: REPPrim, data: $enqueueAction, doc: "(action-queue action) Enqueue an action (thunk or expression) e.g. (enqueue-action! *read-eval-print-action-queue* action)", env: env];
DefinePrimitive[name: "make-read-eval-print-action-queue", nArgs: 0, dotted: FALSE, proc: REPPrim, data: $makeActionQueue, doc: "() Make a new action queue, e.g. (define *read-eval-print-action-queue* (make-read-eval-print-action-queue))", env: env];
DefinePrimitive[name: "%set-current-input-port!", nArgs: 1, dotted: FALSE, proc: PortPrim, data: $setCurrentInputPort, doc: "(port) Change the current default input port (don't use directly; use with-input-from-file instead)", env: env];
DefinePrimitive[name: "%set-current-output-port!", nArgs: 1, dotted: FALSE, proc: PortPrim, data: $setCurrentOutputPort, doc: "(port) Change the current default output port (don't use directly; use with-output-to-file instead)", env: env];
};