## pervasive.pkg
#
# Global definitions visible in all packages.
#
# This global availability gets implemented (in part) by the
#
# far_imports = REF [ pervasive_far_tome ];
#
# line in analyse() from
#
# src/app/makelib/depend/make-dependency-graph.pkg#
### "We used to think that if we knew one,
### we knew two, because one and one are two.
### We are finding that we must learn a great
### deal more about `and'."
###
### -- Sir Arthur Eddington
###
### Quoted in Mathematical Maxims and Minims
### N Rose (Raleigh N C 1988).
infix my 90 ** ;
infix my 80 * / % div & >< ;
infix my 70 $ + - ~ | ^ ? \ ;
infixr my 60 @ . ! << >> >>> in ;
infix my 50 > < >= <= == != =~ .. ;
infix my 40 := o ;
infix my 20 ==> ;
infix my 10 then ;
# base_types is from src/lib/compiler/front/semantic/symbolmapstack/base-types-and-ops.pkg # inline_t is from src/lib/core/init/built-in.pkgBool == base_types::Bool; # Top-level type -- we need this one early.
my (o) : ((Y -> Z), (X -> Y)) -> (X -> Z)
= inline_t::compose;
stipulate
package bt = base_types; # base_types is from src/lib/core/init/built-in.pkg package it = inline_t; # inline_t is from src/lib/core/init/built-in.pkg package ps = protostring; # protostring is from src/lib/core/init/protostring.pkg package rt = runtime; # runtime is from src/lib/core/init/built-in.pkg.
fun strcat ("", s) => s;
strcat (s, "") => s;
strcat (x, y) => ps::meld2 (x, y);
end;
# core_two_word_unt is from src/lib/core/init/core-two-word-unt.pkg package ti = it::ti; # "ti" == "tagged_int": 31-bit on 32-bit architectures, 63-bit on 64-bit architectures.
package i1w = it::i1; # "i1w" == "one-word signed int" -- 32-bit on 32-bit architectures, 64-bit on 64-bit architectures.
package u1b = it::u8; # "u1b" == "one-byte unsigned int".
package tu = it::tu; # "tu" == "tagged_unt": 31-bit on 32-bit architectures, 63-bit on 64-bit architectures.
package u1w = it::u1; # "u1w" == "one-word unsigned int" -- 32-bit on 32-bit architectures, 64-bit on 64-bit architectures.
package mwi = core_multiword_int;
package u2w = core_two_word_unt; # "u2w" == "two-word unsigned int" -- 64-bit on 32-bit architectures, 128-bit on 64-bit architectures.
package i2w = core_two_word_int; # "i22" == "two-word signed int" -- 64-bit on 32-bit architectures, 128-bit on 64-bit architectures.
package f8b = it::f64; # "f8b" == "eight-byte float".
package cv = it::vector_of_chars;
package pv = it::poly_vector;
package di = it::default_int;
fun unt08adapt op args
=
u1b::bitwise_and (op args, 0uxFF);
unt08plus = unt08adapt u1b::(+);
unt08minus = unt08adapt u1b::(-);
unt08times = unt08adapt u1b::(*);
unt08neg = unt08adapt u1b::neg;
unt08lshift = unt08adapt u1b::lshift;
unt08rshift = unt08adapt u1b::rshift;
unt08rshiftl = unt08adapt u1b::rshiftl;
unt08bitwise_or = unt08adapt u1b::bitwise_or; # XXX QUERO FIXME Do we need to do 'unt08adapt' here?
unt08bitwise_xor = unt08adapt u1b::bitwise_xor; # XXX QUERO FIXME Do we need to do 'unt08adapt' here?
fun stringlt (a, b)
=
compare 0
where
al = cv::length a;
bl = cv::length b;
ashort = (di::(<)) (al, bl);
n = if ashort al; else bl;fi;
fun compare i
=
if ((it::(==)) (i, n))
#
ashort;
else
ai = cv::get_byte_as_char (a, i);
bi = cv::get_byte_as_char (b, i);
it::char::(<) (ai, bi) or
(it::(==) (ai, bi) and compare (di::(+) (i, 1)));
fi;
end;
fun stringle (a, b) = if (stringlt (b, a) ) FALSE; else TRUE;fi;
fun stringgt (a, b) = stringlt (b, a);
fun stringge (a, b) = stringle (b, a);
herein
stipulate
Int = bt::Int;
herein
Rowcol = { row: Int,
col: Int
};
end;
stipulate
Float = bt::Float;
herein
Complex = { r: Float, # Real part.
i: Float # Imaginary part.
};
Quaternion = { r: Float, #
i: Float, #
j: Float, #
k: Float #
};
Xyz = { x: Float, # Conceptually an affine xyzw point, except we drop the 'w' coordinate, giving up points at infinity.
y: Float, # (The compiler specially optimizes records of all floats, storing them unboxed.)
z: Float
};
Mat43 = { m00: Float, m01: Float, m02: Float, # Conceptually a 4x4 homogenous affine transform matrix for Xyz points, except we drop column 4, which does seldom-used perspective effects.
m10: Float, m11: Float, m12: Float,
m20: Float, m21: Float, m22: Float,
m30: Float, m31: Float, m32: Float
};
end;
#########################################################
# WARNING:
# Order is significant here, in that when in doubt
#
# src/lib/compiler/front/typer/types/resolve-overloaded-variables.pkg #
# will default to the first entry in the list.
#########################################################
overloaded my (_[]) : ((X, Y) -> Z)
=
(
it::rw_vector_of_chars::get,
it::vector_of_one_byte_unts::get,
it::rw_vector_of_one_byte_unts::get,
# # it::vector_of_eight_byte_floats::get, # Currently we use poly_vector instead of having a specialized vector_of_eight_byte_floats. XXX SUCKO FIXME
it::rw_vector_of_eight_byte_floats::get,
it::poly_rw_vector::get,
it::poly_vector::get,
it::vector_of_chars::get_byte_as_char, # == string::get_byte_as_char;
#
it::poly_rw_matrix::get,
it::rw_matrix_of_eight_byte_floats::get,
it::rw_matrix_of_one_byte_unts::get
);
overloaded my (_[]:=) : ((X, Y, Z) -> W)
=
(
it::rw_vector_of_one_byte_unts::set,
it::rw_vector_of_eight_byte_floats::set,
it::poly_rw_vector::set,
it::rw_vector_of_chars::set,
#
it::poly_rw_matrix::set,
it::rw_matrix_of_eight_byte_floats::set,
it::rw_matrix_of_one_byte_unts::set
);
# overload (_!) : (X -> X)
# as ti::(_!)
# also i1w::(_!)
# also i2w::(_!)
# also mwi::(_!);
# overload (_!) : (X -> X) as ti::(_!) also i1w::(_!) also i2w::(_!) also mwi::(_!);
overloaded my (-_) : (X -> X) # These (X -> X) etc type declarations are probably a mistake -- see Note [1].
=
( ti::neg,
i1w::neg,
i2w::neg,
mwi::neg,
tu::neg,
u1w::neg,
u2w::neg,
f8b::neg,
unt08neg
);
overloaded my (~_) : (X -> X)
=
( ti::bitwise_not,
# i1w::bitwise_not,
# i2w::bitwise_not,
# mwi::bitwise_not,
tu::bitwise_not,
u1w::bitwise_not,
# u2w::bitwise_not,
u1b::bitwise_not
);
overloaded my << : ((X, Y) -> X)
=
( ti::lshift,
i1w::lshift,
# i2w::lshift,
# mwi::lshift,
tu::lshift,
u1w::lshift,
# u2w::lshift,
unt08lshift
);
overloaded my >> : ((X, Y) -> X)
=
(
ti::rshift,
i1w::rshift,
# i2w::rshift,
# mwi::rshift,
tu::rshift,
u1w::rshift,
# u2w::rshift,
unt08rshift
);
overloaded my >>> : ((X, Y) -> X)
=
(
# ti::rshiftl,
# i1w::rshiftl,
# i2w::rshiftl,
# mwi::rshiftl,
tu::rshiftl,
u1w::rshiftl,
# u2w::rshiftl,
unt08rshiftl
);
stipulate
stipulate
(+) = ti::(+);
herein
fun rowcol_plus_rowcol (p1: Rowcol, p2: Rowcol)
=
{ row => p1.row + p2.row,
col => p1.col + p2.col
};
end;
stipulate
(+) = f8b::(+);
herein
fun xyz_plus_xyz (p1: Xyz, p2: Xyz)
=
{ x => p1.x + p2.x,
y => p1.y + p2.y,
z => p1.z + p2.z
};
fun cpx_plus_cpx (c1: Complex, c2: Complex)
=
{ r => c1.r + c2.r,
i => c1.i + c2.i
};
fun qtn_plus_qtn (q1: Quaternion, q2: Quaternion)
=
{ r => q1.r + q2.r,
i => q1.i + q2.i,
j => q1.j + q2.j,
k => q1.k + q2.k
};
end;
herein
overloaded my + : ((X, X) -> X)
=
( ti::(+),
i1w::(+),
i2w::(+),
mwi::(+),
tu::(+),
strcat,
u1w::(+),
u2w::(+),
f8b::(+),
unt08plus,
rowcol_plus_rowcol,
xyz_plus_xyz,
cpx_plus_cpx,
qtn_plus_qtn
);
end;
overloaded my | : ((X, X) -> X)
=
( ti::bitwise_or,
i1w::bitwise_or,
# i2w::bitwise_or,
# mwi::bitwise_or,
tu::bitwise_or,
u1w::bitwise_or,
# u2w::bitwise_or,
unt08bitwise_or
);
overloaded my ^ : ((X, X) -> X)
=
( ti::bitwise_xor,
i1w::bitwise_xor,
# i2w::bitwise_xor,
# mwi::bitwise_xor,
tu::bitwise_xor,
u1w::bitwise_xor,
# u2w::bitwise_xor,
unt08bitwise_xor
);
overloaded my & : ((X, X) -> X)
=
( ti::bitwise_and,
i1w::bitwise_and,
# i2w::bitwise_and,
# mwi::bitwise_and,
tu::bitwise_and,
u1w::bitwise_and,
# u2w::bitwise_and,
u1b::bitwise_and
);
stipulate
stipulate
(-) = ti::(-);
herein
fun rowcol_sub_rowcol (p1: Rowcol, p2: Rowcol)
=
{ row => p1.row - p2.row,
col => p1.col - p2.col
};
end;
stipulate
(-) = f8b::(-);
herein
fun xyz_sub_xyz (p1: Xyz, p2: Xyz)
=
{ x => p1.x - p2.x,
y => p1.y - p2.y,
z => p1.z - p2.z
};
fun cpx_sub_cpx (c1: Complex, c2: Complex)
=
{ r => c1.r - c2.r,
i => c1.i - c2.i
};
fun qtn_sub_qtn (q1: Quaternion, q2: Quaternion)
=
{ r => q1.r - q2.r,
i => q1.i - q2.i,
j => q1.j - q2.j,
k => q1.k - q2.k
};
end;
herein
overloaded my - : ((X, X) -> X)
=
( ti::(-),
i1w::(-),
i2w::(-),
mwi::(-),
tu::(-),
u1w::(-),
u2w::(-),
f8b::(-),
unt08minus,
rowcol_sub_rowcol,
xyz_sub_xyz,
cpx_sub_cpx,
qtn_sub_qtn
);
end;
stipulate
stipulate
(+) = f8b::(+);
(*) = f8b::(*);
herein
fun mat43_times_mat43 (m1: Mat43, m2: Mat43)
=
{ m00 => m1.m00 * m2.m00 + m1.m01 * m2.m10 + m1.m02 * m2.m20,
m01 => m1.m00 * m2.m01 + m1.m01 * m2.m11 + m1.m02 * m2.m21,
m02 => m1.m00 * m2.m02 + m1.m01 * m2.m12 + m1.m02 * m2.m22,
#
m10 => m1.m10 * m2.m00 + m1.m11 * m2.m10 + m1.m12 * m2.m20,
m11 => m1.m10 * m2.m01 + m1.m11 * m2.m11 + m1.m12 * m2.m21,
m12 => m1.m10 * m2.m02 + m1.m11 * m2.m12 + m1.m12 * m2.m22,
#
m20 => m1.m20 * m2.m00 + m1.m21 * m2.m10 + m1.m22 * m2.m20,
m21 => m1.m20 * m2.m01 + m1.m21 * m2.m11 + m1.m22 * m2.m21,
m22 => m1.m20 * m2.m02 + m1.m21 * m2.m12 + m1.m22 * m2.m22,
#
m30 => m1.m30 * m2.m00 + m1.m31 * m2.m10 + m1.m32 * m2.m20 + m2.m30,
m31 => m1.m30 * m2.m01 + m1.m31 * m2.m11 + m1.m32 * m2.m21 + m2.m31,
m32 => m1.m30 * m2.m02 + m1.m31 * m2.m12 + m1.m32 * m2.m22 + m2.m32
};
fun xyz_times_mat43 (p: Xyz, m: Mat43)
=
{ x => p.x * m.m00 + p.y * m.m10 + p.z * m.m20 + m.m30,
y => p.x * m.m01 + p.y * m.m11 + p.z * m.m21 + m.m31,
z => p.x * m.m02 + p.y * m.m12 + p.z * m.m22 + m.m32
};
fun xyz_times_xyz (p1: Xyz, p2: Xyz) # Dot-product of two vectors in Xyz form.
=
p1.x * p2.x + p1.y * p2.y + p1.z * p2.z;
fun float_times_xyz (f: bt::Float, p: Xyz)
=
{ x => f * p.x,
y => f * p.y,
z => f * p.z
};
fun cpx_times_cpx (c1: Complex, c2: Complex): Complex
=
{ r => c1.r * c2.r - c1.i * c2.i,
i => c1.r * c2.i + c1.i * c2.r
};
fun qtn_times_qtn (q1: Quaternion, q2: Quaternion): Quaternion
=
{ r => q1.r * q2.r - q1.i * q2.i - q1.j * q2.j - q1.k * q2.k,
i => q1.r * q2.i + q1.i * q2.r + q1.j * q2.k - q1.k * q2.j,
j => q1.r * q2.j - q1.i * q2.k + q1.j * q2.r + q1.k * q2.i,
k => q1.r * q2.k + q1.i * q2.j - q1.j * q2.i + q1.k * q2.r
};
# fun integer_times_int (integer, int)
# =
# mwi::(*) (integer, it::in::from_int int);
# fun int_times_integer (int, integer)
# =
# mwi::(*) (it::in::from_int int, integer);
fun int_times_float (int, float)
=
f8b::(*) (it::f64::from_tagged_int int, float);
fun float_times_int (float, int)
=
f8b::(*) (float, it::f64::from_tagged_int int);
fun int1_times_int (int1, int)
=
i1w::(*) (int1, i1w::from_int int);
fun int_times_int1 (int, int1)
=
i1w::(*) (i1w::from_int int, int1);
end;
herein
overloaded my * : ((X, Y) -> Z)
=
( ti::(*),
i1w::(*),
i2w::(*),
mwi::(*),
tu::(*),
u1w::(*),
u2w::(*),
f8b::(*),
unt08times,
mat43_times_mat43,
xyz_times_mat43,
xyz_times_xyz,
float_times_xyz,
# int_times_integer,
# integer_times_int,
int_times_float,
float_times_int,
int1_times_int,
int_times_int1,
cpx_times_cpx,
qtn_times_qtn
);
end;
stipulate # Cross-product of two vectors in Xyz form.
stipulate
(-) = f8b::(-);
(*) = f8b::(*);
herein
fun xyz_x_xyz (p1: Xyz, p2: Xyz)
=
{ x => p1.y * p2.z - p1.z * p2.y,
y => p1.x * p2.z - p1.z * p2.x,
z => p1.x * p2.y - p1.y * p2.x
};
end;
herein
overloaded my >< : ((X, X) -> X)
=
( xyz_x_xyz
);
end;
# Can't overload ** with float and int pow() right now
# because they are not currently defined this early
# in the game. XXX SUCKO FIXME
# overload ** : ((X, X) -> X)
# as math::pow;
overloaded my / : ((X, X) -> X)
=
( ti::div,
i1w::div,
i2w::div,
mwi::div,
u1b::div,
tu::div,
u1w::div,
u2w::div,
f8b::(/)
);
# NB: These should probably all do fast round-to-zero division (native on Intel32)
# rather than round-to-negative-infinity division (faked in software on Intel32)
# but I'm not convinced they do -- the code seems not too consistent across
# src/lib/core/init/built-in.pkg # src/lib/compiler/front/semantic/symbolmapstack/base-types-and-ops.pkg # src/lib/compiler/back/top/highcode/highcode-baseops.pkg # src/lib/compiler/back/top/nextcode/nextcode-form.pkg # src/lib/compiler/back/low/treecode/treecode-form.api # In particular, the use of 'rem' vs 'mod' seems inconsistent.
# (But perhaps only in unsigned cases where there is no difference...?)
# Anyhow, this may actually be ok, but it needs to be checked out.
# XXX QUERO FIXME.
overloaded my % : ((X, X) -> X)
=
( ti::mod,
i1w::mod,
i2w::mod,
mwi::mod,
u1b::mod,
tu::mod,
u1w::mod,
u2w::mod
);
# Same comment as above -- XXX BUGGO FIXME.
overloaded my < : ((X, X) -> Bool)
=
( ti::(<),
i1w::(<),
i2w::(<),
mwi::(<),
u1b::(<),
tu::(<),
u1w::(<),
u2w::(<),
f8b::(<),
it::char::(<),
stringlt
);
overloaded my <= : ((X, X) -> Bool)
=
( ti::(<=),
i1w::(<=),
i2w::(<=),
mwi::(<=),
u1b::(<=),
tu::(<=),
u1w::(<=),
u2w::(<=),
f8b::(<=),
it::char::(<=),
stringle
);
overloaded my > : ((X, X) -> Bool)
=
( ti::(>),
i1w::(>),
i2w::(>),
mwi::(>),
u1b::(>),
tu::(>),
u1w::(>),
u2w::(>),
f8b::(>),
it::char::(>),
stringgt
);
overloaded my >= : ((X, X) -> Bool)
=
( ti::(>=),
i1w::(>=),
i2w::(>=),
mwi::(>=),
u1b::(>=),
tu::(>=),
u1w::(>=),
u2w::(>=),
f8b::(>=),
it::char::(>=),
stringge
);
overloaded my abs: (X -> X)
=
( ti::abs,
i1w::abs,
i2w::abs,
mwi::abs,
f8b::abs
);
overloaded my min: ((X, X) -> X)
=
( ti::min,
i1w::min,
# i2w::min,
# mwi::min,
f8b::min
);
overloaded my max: ((X, X) -> X)
=
( ti::max,
i1w::max,
# i2w::min,
# mwi::min,
f8b::max
);
Void = bt::Void;
Exception = bt::Exception;
exception BIND = core::BIND;
exception MATCH = core::MATCH;
exception INDEX_OUT_OF_BOUNDS = core::INDEX_OUT_OF_BOUNDS; # SML/NJ calls this SUBSCRIPT.
exception SIZE = core::SIZE;
exception OVERFLOW = rt::OVERFLOW; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg exception DIVIDE_BY_ZERO = rt::DIVIDE_BY_ZERO; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg exception BAD_CHAR = it::char::BAD_CHAR;
exception DOMAIN;
exception NOT_FOUND; # Raised when a regex fails to match given string, and similar search situations.
exception IMPOSSIBLE;
String = bt::String;
exception DIE String;
# exception SPAN
# enum order
# enum option
# exception Option
# my the_else
# my not_null
# my the
# op ==
# my op !=
include package proto_pervasive; # proto_pervasive is from src/lib/core/init/proto-pervasive.pkg Null_Or(X) = Null_Or(X);
Fail_Or(X) = FAIL String
| WORK X
;
(*_) = it::deref;
deref = it::deref; # Synonym, handy when doing 'map' or such.
(:=) = it::(:=);
(then) = it::then : (X, Void) -> X;
ignore = it::ignore : X -> Void;
# Top-level types:
#
List == bt::List;
Ref == bt::Ref;
# Top-level value identifiers:
#
fun vector l
=
{ fun len ([], n) => n;
len ([_], n) => n+1;
len (_ ! _ ! r, n) => len (r, n+2);
end;
n = len (l, 0);
if (di::ltu (core::maximum_vector_length, n)) raise exception SIZE; fi;
if (n == 0) rt::zero_length_vector__global; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg else rt::asm::make_typeagnostic_ro_vector (n, l); # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg fi;
};
# Bool
not = it::inlnot;
(!_) = not;
fun !*boolref # Just to avoid having to write !(*boolref) all the time.
=
not *boolref;
Int = bt::Int;
Unt = bt::Unt;
Float = bt::Float;
float = it::f64::from_tagged_int;
fun floor x
=
if ((f8b::(<) (x, 1073741824.0))
and (f8b::(>=) (x, -1073741824.0)))
rt::asm::floor x; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg elif (f8b::(====) (x, x)) raise exception OVERFLOW; # not a NaN
else raise exception DOMAIN; # NaN
fi;
fun ceil x = (di::(-)) (-1, floor ((f8b::neg) (x + 1.0)));
fun trunc x = if (f8b::(<) (x, 0.0)) ceil x; else floor x;fi;
fun round x = floor (x + 0.5); # Bug: does not round-to-nearest XXX BUGGO FIXME
# List
exception EMPTY;
fun null [] => TRUE;
null _ => FALSE;
end;
fun head (h ! _) => h;
head [] => raise exception EMPTY;
end;
fun tail (_ ! t) => t;
tail [] => raise exception EMPTY;
end;
fun fold_forward f init list # 'f' is function to be applied, 'b' is initial value of result accumulator, 'l' is list to be folded.
=
fold' (list, init)
where
fun fold' ([], results) => results;
fold' (a ! rest, results) => fold' (rest, f (a, results));
end;
end;
fun length l
=
loop (0, l)
where
fun loop (n, []) => n;
loop (n, _ ! l) => loop (n + 1, l);
end;
end;
fun reverse l
=
fold_forward (!) [] l;
fun fold_backward f b # 'f' is function to be applied, 'b' is initial value of result accumulator, list to be folded is 3rd arg (implicit).
=
f2
where
fun f2 [] => b;
f2 (a ! r) => f (a, f2 r);
end;
end;
fun l1 @ l2
=
fold_backward (!) l2 l1;
fun apply f
=
a2
where
fun a2 [] => ();
a2 (h ! t) => { f h: Void;
a2 t;
};
end;
end;
fun apply' list fn
=
apply fn list;
fun map f
=
m
where
fun m [] => [];
m [a] => [f a];
m [a, b] => [f a, f b];
m [a, b, c] => [f a, f b, f c];
m (a ! b ! c ! d ! r) => f a ! f b ! f c ! f d ! m r;
end;
end;
fun map' list fn
=
map fn list;
# rw_vector
Array(X) = bt::Rw_Vector(X); # XXX BUGGO DELETEME
Rw_Vector(X) = bt::Rw_Vector(X);
# Vector
Vector(X) = bt::Vector(X);
# Char
Char = bt::Char;
to_int = it::char::ord;
from_int = it::char::chr;
# This doesn't work as-is because the string package isn't defined at this point:
# eq = string::(==);
# ne = string::(!=);
# le = string::(<=);
# ge = string::(>=);
# lt = string::(<);
# gt = string::(>);
#
# to_lower = string::to_lower;
# to_upper = string::to_upper;
# String:
#
stipulate
# Allocate an uninitialized string of given length
#
fun create n
=
{ if (di::ltu (core::maximum_vector_length, n)) raise exception SIZE; fi;
#
rt::asm::make_string n; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg };
unsafe_get = cv::get_byte_as_char;
unsafe_set = cv::set_char_as_byte;
herein
size = cv::length: String -> Int;
fun str (c: Char) : String
=
pv::get (ps::chars, it::cast c);
# Concatenate a list of strings together:
fun cat [s]
=>
s;
cat (sl: List( String ))
=>
{ fun length (i, [] ) => i;
length (i, s ! rest) => length (i+size s, rest);
end;
case (length (0, sl))
0 => "";
1 =>
{ fun find ("" ! r) => find r;
find (s ! _) => s;
find _ => "";
end; # * impossible *
find sl;
};
tot_len
=>
{ ss = create tot_len;
fun copy ([], _) => ();
copy (s ! r, i) => {
len = size s;
fun copy' j
=
if (j != len)
unsafe_set (ss, i+j, unsafe_get (s, j));
copy'(j+1);
fi;
copy' 0;
copy (r, i+len);
};
end;
copy (sl, 0);
ss;
};
esac;
};
end; # fun cat
# Implode a list of characters into a string:
fun implode [] => "";
implode cl
=>
ps::implode (length (cl, 0), cl)
where
fun length ([], n) => n;
length (_ ! r, n) => length (r, n+1);
end;
end;
end;
# Explode a string into a list of characters:
fun explode s
=
f (NIL, size s - 1)
where
fun f (l, -1) => l;
f (l, i) => f (unsafe_get (s, i) ! l, i - 1);
end;
end;
# Return the n-character substring of s starting at position i.
# NOTE: we use words to check the right bound so as to avoid
# raising overflow.
stipulate
package w = it::default_unt;
herein
fun substring (s, i, n)
=
if (((i < 0) or
(n < 0) or
(w::(<))(w::from_int (size s), (w::(+))(w::from_int i, w::from_int n)))
)
raise exception core::INDEX_OUT_OF_BOUNDS;
else
ps::unsafe_substring (s, i, n);
fi;
end;
# fun "" $ s => s;
# s $ "" => s;
# x $ y => ps::meld2 (x, y);
# end;
end; # stipulate
# Substring:
#
Substring = substring::Substring;
Substring = substring::Substring;
# I/O:
#
print = print_hook_guts::print;
# Simple interface to redirect interactive
# compiler to read from some stream other
# than the default (stdin):
#
run = read_eval_print_hook::run;
# Getting info about exceptions:
#
exception_name = exception_info_hook::exception_name;
exception_message = exception_info_hook::exception_message;
# Given 1 .. 10, # Compare to 'upto' def in src/lib/compiler/back/low/main/intel32/backend-lowhalf-intel32-g.pkg # return [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ]
#
fun i .. j
=
make_arithmetic_sequence (i, j, [])
where
fun make_arithmetic_sequence (i, j, result_so_far)
=
i > j ?? result_so_far
:: make_arithmetic_sequence (i, j - 1, j ! result_so_far);
end;
fun foreach [] thunk => ();
foreach (a ! rest) thunk => { thunk(a); foreach rest thunk; };
end;
fun identity i = i;
dotquotes__op = identity; # .'foo'
dotbrokets__op = identity; # .<foo>
dotbarets__op = identity; # .|foo|
dotslashets__op = identity; # ./foo/
dothashets__op = identity; # .#foo#
dotbackticks__op = identity; # .`foo`
backticks__op = \\ _ = raise exception DIE "`foo` op not defined; to define it do backticks__op = somefn;"; # Initialized to 'words' in src/app/makelib/main/makelib-g.pkg dotqquotes__op = \\ _ = raise exception DIE ".\"foo\" op not defined; to define it do dotqquotes__op = somefn;"; # Initialized to 'words' in src/app/makelib/main/makelib-g.pkg # NB: We also have symbols |i| <i> /i/ {i} <i| |i>.
# These are X -> Y.
# They may be set via
# (|_|) = foo;
# (<_>) = foo;
# (/_/) = foo;
# ({_}) = foo;
# (<_|) = foo;
# (|_>) = foo;
#
# I wonder if we shouldn't also have a .[_]: List(X) -> Y syntax.
stipulate
# Here for convenience we duplicate the contents of
# src/lib/src/issue-unique-id-g.pkg #
package p: api { Id;
id_zero: Id;
issue_unique_id: Void -> Id;
id_to_int: Id -> Int;
same_id: (Id, Id) -> Bool;
}
{
Id = Int; # Exported as an opaque type to reduce risk of confusing ids with other ints.
id_zero = 0;
next_id = REF 1;
fun issue_unique_id ()
=
{ # NB: No locking required at CML level because lack of fn calls in body means body cannot be pre-empted.
result = *next_id;
next_id := result + 1;
result;
};
fun id_to_int i = i; # To allow using ids as indices in red-black trees etc.
fun same_id (id1: Id, id2: Id)
=
id1 == id2;
};
herein
include package p;
end;
Crypt # 'crypt' as in 'cryptic," "hidden". Type for passing values while hiding their types. See Note[2].
= #
{ id: Id, # A globally unique id which can be used (e.g.) as a key to store the Crypt in indexed datastructures.
type: String, # Type of the contents of the data field, for debugging/inspection.
info: String, # Any added info about the data field, for debugging/inspection. This compensates for Crypt's lack of typesafety; it should include any information useful when debugging "Whoops, we got the wrong Crypt here" bugs. Often just the empty string.
data: Exception # The hidden value packed in an exception, taking advantage of the fact that Exception is Mythryl's only extensible datatype.
};
fun do_while (fn: Void -> Bool): Void # This little hack lets programmers write stuff like
= # do_while {.
if (fn ()) do_while fn; # do_some_stuff ();
else (); # continuation_condition ();
fi; # };
fun do_while_not (fn: Void -> Bool): Void # This little hack lets programmers write stuff like
= # do_while_not {.
if (fn ()) (); # do_some_stuff ();
else do_while_not fn; # termination_condition ();
fi; # };
end; # stipulate
################################################################################
# Note [1]
# ========
#
# First off, the += operator on overloaded types isn't checking these types,
# which is likely a bug. See Hue White listmail circa 2011-05-05.
#
# Secondly, as his example shows, it is reasonable to want to relax the
# (X,X)->X type for * (for example). There's no logical reason why it
# should have to be predeclared; the compiler should be able to scan
# the list and come up with the actual type signature describing the
# currently registered collection. Also, there may be room for optimizing
# the way the type-checker makes use of this information...?
################################################################################
# Note [2]
# ========
#
# The 'Crypt' type facilitates passing and storing values in a form
# where the intermediate packages handling the information flow and
# storage don't need to know the relevant types.
#
# The motivating example for this was publishing
# millboss_types::Mill_To_Millboss # millboss_types is from src/lib/x-kit/widget/edit/millboss-types.pkg# values in
# guiboss_types::Gadget_To_Guiboss # guiboss_types is from src/lib/x-kit/widget/gui/guiboss-types.pkg# without having to expose the entire millboss type complex to
# guiboss -- which was resulting in package dependency cycles,
# aside from being messy.
#
# The idea is that a resource like millboss_imp can be placed in a
# central registry like guiboss_imp as an anonymous Crypt, after
# which millboss_imp clients can retrieve the value via code like
#
# case millboss_crypt.val
# #
# g2b::MILL_TO_MILLBOSS mill_to_millboss
# =>
# {
# ... # Code using the mill_to_millboss port.
# };
#
# _ => log::fatal (sprintf "Expected Crypt of g2b::MILL_TO_MILLBOSS but got Crypt of key=>\"%s\" doc\"=%s\"" millboss_crypt.key millboss_crypt.doc);
# esac;
#
# Here we're giving up some typesafety for the sake of improved modularity.
################################################################################
# Here's an odd problem: Any reference to
# typeagnostic equality checking in this file
# triggers an error like
#
# mythryl-runtime-intel32: Fatal error -- unable to find picklehash (compiledfile identifier) '[...]'
#
# For example this stimulus exhibits the problem:
#
# fun x (a,b) = it::(==)(b, a);
#
# but this one does not (presumably the zero allows the
# compiler to produce integer equality test instead of
# typeagnostic one):
#
# fun x (a,b) = it::(==)(0, a);
#
# The simplest stimulus exhibiting the problem is likely:
#
# foo = (!=);
#
# XXX BUGGO FIXME
# Bind package _Core. We use the symbol "xcore", but after parsing
# is done this will be re-written to "_Core" by the bootstrap compilation
# machinery in ROOT/src/app/makelib/compile/compile-in-dependency-order-g.pkg.
# See file init.cmi for more details:
package xcore = core;
## (C) 1999 Lucent Technologies, Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.