mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 14:58:50 +00:00
Assertions in runtime
This commit is contained in:
Dmitry Boulytchev
parent
27c091129a
commit
6322ee6bed
3 changed files with 171 additions and 173 deletions
|
|
@ -63,7 +63,24 @@ void __post_gc_subst () {}
|
|||
|
||||
# define UNBOXED(x) (((int) (x)) & 0x0001)
|
||||
# define UNBOX(x) (((int) (x)) >> 1)
|
||||
# define BOX(x) ((((int) (x)) << 1) | 0x0001)
|
||||
# define BOX(x) ((((int) (x)) << 1) | 0x0001)
|
||||
|
||||
static void vfailure (char *s, va_list args) {
|
||||
fprintf (stderr, "*** FAILURE: ");
|
||||
vfprintf (stderr, s, args); // vprintf (char *, va_list) <-> printf (char *, ...)
|
||||
exit (255);
|
||||
}
|
||||
|
||||
static void failure (char *s, ...) {
|
||||
va_list args;
|
||||
|
||||
va_start (args, s);
|
||||
vfailure (s, args);
|
||||
}
|
||||
|
||||
# define ASSERT_BOXED(memo, x) do if (UNBOXED(x)) failure ("boxed value expected in %s\n", memo); while (0)
|
||||
# define ASSERT_UNBOXED(memo, x) do if (!UNBOXED(x)) failure ("unboxed value expected in %s\n", memo); while (0)
|
||||
# define ASSERT_STRING(memo, x) do if (!UNBOXED(x) && TAG(TO_DATA(x)->tag) != STRING_TAG) failure ("sting value expected in %s\n", memo); while (0)
|
||||
|
||||
typedef struct {
|
||||
int tag;
|
||||
|
|
@ -79,6 +96,9 @@ extern void* alloc (size_t);
|
|||
|
||||
extern int Blength (void *p) {
|
||||
data *a = (data*) BOX (NULL);
|
||||
|
||||
ASSERT_BOXED(".length", p);
|
||||
|
||||
a = TO_DATA(p);
|
||||
return BOX(LEN(a->tag));
|
||||
}
|
||||
|
|
@ -107,19 +127,6 @@ char* de_hash (int n) {
|
|||
return ++p;
|
||||
}
|
||||
|
||||
static void vfailure (char *s, va_list args) {
|
||||
fprintf (stderr, "*** FAILURE: ");
|
||||
vfprintf (stderr, s, args); // vprintf (char *, va_list) <-> printf (char *, ...)
|
||||
exit (255);
|
||||
}
|
||||
|
||||
static void failure (char *s, ...) {
|
||||
va_list args;
|
||||
|
||||
va_start (args, s);
|
||||
vfailure (s, args);
|
||||
}
|
||||
|
||||
typedef struct {
|
||||
char *contents;
|
||||
int ptr;
|
||||
|
|
@ -291,15 +298,25 @@ static void stringcat (void *p) {
|
|||
|
||||
extern int LmatchSubString (char *subj, char *patt, int pos) {
|
||||
data *p = TO_DATA(patt);
|
||||
int n = LEN (p->tag);
|
||||
int n;
|
||||
|
||||
ASSERT_STRING("matchSubString:1", subj);
|
||||
ASSERT_STRING("matchSubString:2", patt);
|
||||
ASSERT_UNBOXED("matchSubString:3", pos);
|
||||
|
||||
n = LEN (p->tag);
|
||||
|
||||
return BOX(strncmp (subj + UNBOX(pos), patt, n) == 0);
|
||||
}
|
||||
|
||||
extern void* Lsubstring (void *subj, int p, int l) {
|
||||
data *d = TO_DATA(subj);
|
||||
int pp = UNBOX (p), ll = UNBOX (l);
|
||||
|
||||
|
||||
ASSERT_STRING("substring:1", subj);
|
||||
ASSERT_UNBOXED("substring:2", p);
|
||||
ASSERT_UNBOXED("substring:3", l);
|
||||
|
||||
if (pp + ll <= LEN(d->tag)) {
|
||||
data *r;
|
||||
|
||||
|
|
@ -331,6 +348,10 @@ extern struct re_pattern_buffer *Lregexp (char *regexp) {
|
|||
}
|
||||
|
||||
extern int LregexpMatch (struct re_pattern_buffer *b, char *s, int pos) {
|
||||
ASSERT_BOXED("regexpMatch:1", b);
|
||||
ASSERT_STRING("regexpMatch:2", s);
|
||||
ASSERT_UNBOXED("regexpMatch:3", pos);
|
||||
|
||||
return BOX (re_match (b, s, LEN(TO_DATA(s)->tag), UNBOX(pos), 0));
|
||||
}
|
||||
|
||||
|
|
@ -391,6 +412,10 @@ extern int Lcompare (void *p, void *q) {
|
|||
|
||||
extern void* Belem (void *p, int i) {
|
||||
data *a = (data *)BOX(NULL);
|
||||
|
||||
ASSERT_BOXED(".elem:1", p);
|
||||
ASSERT_UNBOXED(".elem:2", i);
|
||||
|
||||
a = TO_DATA(p);
|
||||
i = UNBOX(i);
|
||||
|
||||
|
|
@ -405,6 +430,8 @@ extern void* LmakeString (int length) {
|
|||
int n = UNBOX(length);
|
||||
data *r;
|
||||
|
||||
ASSERT_UNBOXED("makeStrig", length);
|
||||
|
||||
__pre_gc () ;
|
||||
|
||||
r = (data*) alloc (n + 1 + sizeof (int));
|
||||
|
|
@ -419,7 +446,7 @@ extern void* LmakeString (int length) {
|
|||
extern void* Bstring (void *p) {
|
||||
int n = strlen (p);
|
||||
void *s;
|
||||
|
||||
|
||||
__pre_gc ();
|
||||
|
||||
s = LmakeString (BOX(n));
|
||||
|
|
@ -433,6 +460,8 @@ extern void* Bstring (void *p) {
|
|||
extern void* Lstringcat (void *p) {
|
||||
void *s;
|
||||
|
||||
ASSERT_BOXED("stringcat", p);
|
||||
|
||||
__pre_gc ();
|
||||
|
||||
createStringBuf ();
|
||||
|
|
@ -469,7 +498,7 @@ extern void* Bclosure (int n, void *entry, ...) {
|
|||
int i = BOX(0),
|
||||
ai = BOX(0);
|
||||
data *r = (data*) BOX (NULL);
|
||||
|
||||
|
||||
__pre_gc ();
|
||||
|
||||
#ifdef DEBUG_PRINT
|
||||
|
|
@ -566,6 +595,7 @@ extern void* Bsexp (int n, ...) {
|
|||
|
||||
extern int Btag (void *d, int t, int n) {
|
||||
data *r = (data *) BOX (NULL);
|
||||
|
||||
if (UNBOXED(d)) return BOX(0);
|
||||
else {
|
||||
r = TO_DATA(d);
|
||||
|
|
@ -580,6 +610,7 @@ extern int Btag (void *d, int t, int n) {
|
|||
|
||||
extern int Barray_patt (void *d, int n) {
|
||||
data *r = BOX(NULL);
|
||||
|
||||
if (UNBOXED(d)) return BOX(0);
|
||||
else {
|
||||
r = TO_DATA(d);
|
||||
|
|
@ -590,6 +621,9 @@ extern int Barray_patt (void *d, int n) {
|
|||
extern int Bstring_patt (void *x, void *y) {
|
||||
data *rx = (data *) BOX (NULL),
|
||||
*ry = (data *) BOX (NULL);
|
||||
|
||||
ASSERT_STRING(".string_patt:2", y);
|
||||
|
||||
if (UNBOXED(x)) return BOX(0);
|
||||
else {
|
||||
rx = TO_DATA(x); ry = TO_DATA(y);
|
||||
|
|
@ -633,6 +667,9 @@ extern int Bsexp_tag_patt (void *x) {
|
|||
}
|
||||
|
||||
extern void* Bsta (void *v, int i, void *x) {
|
||||
ASSERT_BOXED(".sta:3", x);
|
||||
ASSERT_UNBOXED(".sta:2", i);
|
||||
|
||||
if (TAG(TO_DATA(x)->tag) == STRING_TAG)((char*) x)[UNBOX(i)] = (char) UNBOX(v);
|
||||
else ((int*) x)[UNBOX(i)] = v;
|
||||
|
||||
|
|
@ -674,6 +711,9 @@ extern void* /*Lstrcat*/ Li__Infix_4343 (void *a, void *b) {
|
|||
data *db = (data*) BOX (NULL);
|
||||
data *d = (data*) BOX (NULL);
|
||||
|
||||
ASSERT_STRING("++:1", a);
|
||||
ASSERT_STRING("++:2", b);
|
||||
|
||||
da = TO_DATA(a);
|
||||
db = TO_DATA(b);
|
||||
|
||||
|
|
@ -697,6 +737,7 @@ extern void* Lsprintf (char * fmt, ...) {
|
|||
va_list args;
|
||||
void *s;
|
||||
|
||||
ASSERT_STRING("sprintf:1", fmt);
|
||||
|
||||
va_start (args, fmt);
|
||||
fix_unboxed (fmt, args);
|
||||
|
|
@ -719,6 +760,9 @@ extern void* Lsprintf (char * fmt, ...) {
|
|||
extern void Lfprintf (FILE *f, char *s, ...) {
|
||||
va_list args = (va_list) BOX (NULL);
|
||||
|
||||
ASSERT_BOXED("fprintf:1", f);
|
||||
ASSERT_STRING("fprintf:2", s);
|
||||
|
||||
va_start (args, s);
|
||||
fix_unboxed (s, args);
|
||||
|
||||
|
|
@ -730,6 +774,8 @@ extern void Lfprintf (FILE *f, char *s, ...) {
|
|||
extern void Lprintf (char *s, ...) {
|
||||
va_list args = (va_list) BOX (NULL);
|
||||
|
||||
ASSERT_STRING("printf:1", s);
|
||||
|
||||
va_start (args, s);
|
||||
fix_unboxed (s, args);
|
||||
|
||||
|
|
@ -739,8 +785,13 @@ extern void Lprintf (char *s, ...) {
|
|||
}
|
||||
|
||||
extern FILE* Lfopen (char *f, char *m) {
|
||||
FILE* h = fopen (f, m);
|
||||
FILE* h;
|
||||
|
||||
ASSERT_STRING("fopen:1", f);
|
||||
ASSERT_STRING("fopen:2", m);
|
||||
|
||||
h = fopen (f, m);
|
||||
|
||||
if (h)
|
||||
return h;
|
||||
|
||||
|
|
@ -748,6 +799,8 @@ extern FILE* Lfopen (char *f, char *m) {
|
|||
}
|
||||
|
||||
extern void Lfclose (FILE *f) {
|
||||
ASSERT_BOXED("fclose", f);
|
||||
|
||||
fclose (f);
|
||||
}
|
||||
|
||||
|
|
@ -768,8 +821,12 @@ extern void* LreadLine () {
|
|||
}
|
||||
|
||||
extern void* Lfread (char *fname) {
|
||||
FILE *f = fopen (fname, "r");
|
||||
FILE *f;
|
||||
|
||||
ASSERT_STRING("fread", fname);
|
||||
|
||||
f = fopen (fname, "r");
|
||||
|
||||
if (f) {
|
||||
if (fseek (f, 0l, SEEK_END) >= 0) {
|
||||
long size = ftell (f);
|
||||
|
|
@ -788,7 +845,12 @@ extern void* Lfread (char *fname) {
|
|||
}
|
||||
|
||||
extern void Lfwrite (char *fname, char *contents) {
|
||||
FILE *f = fopen (fname, "w");
|
||||
FILE *f;
|
||||
|
||||
ASSERT_STRING("fwrite:1", fname);
|
||||
ASSERT_STRING("fwrite:2", contents);
|
||||
|
||||
f = fopen (fname, "w");
|
||||
|
||||
if (f) {
|
||||
if (fprintf (f, "%s", contents) < 0);
|
||||
|
|
|
|||
|
|
@ -1,141 +0,0 @@
|
|||
-- MNode (key, list of values, balance factor, left subtree, right subtree)
|
||||
-- balance factor = height (left subtree) - height (right subtree)
|
||||
fun insert (m, k, v) {
|
||||
fun rot (left, node) {
|
||||
return
|
||||
if left
|
||||
then case node of
|
||||
MNode (k, v, _, l, MNode (rk, rv, _, ll, rr)) ->
|
||||
MNode (rk, rv, 0, MNode (k, v, 0, l, ll), rr)
|
||||
esac
|
||||
else case node of
|
||||
MNode (k, v, _, MNode (lk, lv, _, ll, rr), r) ->
|
||||
MNode (lk, lv, 0, ll, MNode (k, v, 0, rr, r))
|
||||
esac
|
||||
fi
|
||||
}
|
||||
|
||||
fun factor (x) {
|
||||
return x [2]
|
||||
}
|
||||
|
||||
fun inner (m, k, v) {
|
||||
return
|
||||
case m of
|
||||
{} -> [true, MNode (k, {v}, 0, {}, {})]
|
||||
| MNode (kk, vv, bf, l, r) ->
|
||||
local c = compare (k, kk);
|
||||
if c == 0
|
||||
then [false, MNode (kk, v : vv, bf, l, r)]
|
||||
else if c < 0
|
||||
then
|
||||
case inner (l, k, v) of
|
||||
[true, ll] -> if bf < 0
|
||||
then [false, MNode (kk, vv, bf + 1, ll, r)]
|
||||
elif bf == 1
|
||||
then if ll.factor > 0
|
||||
then [false, rot (false, MNode (kk, vv, bf, ll, r))]
|
||||
else [false, rot (false, MNode (kk, vv, bf, rot (true, ll), r))]
|
||||
fi
|
||||
else [true, MNode (kk, vv, bf + 1, ll, r)]
|
||||
fi
|
||||
| [false, ll] -> [false, MNode (kk, vv, bf, ll, r)]
|
||||
esac
|
||||
else
|
||||
case inner (r, k, v) of
|
||||
[true, rr] -> if bf > 0
|
||||
then [false, MNode (kk, vv, bf - 1, l, rr)]
|
||||
elif bf == -1
|
||||
then if rr.factor < 0
|
||||
then [false, rot (true, MNode (kk, vv, bf, l, rr))]
|
||||
else [false, rot (true, MNode (kk, vv, bf, l, rot (false, rr)))]
|
||||
fi
|
||||
else [true, MNode (kk, vv, bf - 1, l, rr)]
|
||||
fi
|
||||
| [false, rr] -> [false, MNode (kk, vv, bf, l, rr)]
|
||||
esac
|
||||
fi
|
||||
fi
|
||||
esac
|
||||
}
|
||||
|
||||
return m.inner (k, v).snd
|
||||
}
|
||||
|
||||
fun find (m, k) {
|
||||
return
|
||||
case m of
|
||||
{} -> None
|
||||
| MNode (kk, vv, _, l, r) ->
|
||||
local c = compare (k, kk);
|
||||
if c == 0
|
||||
then case vv of v : _ -> Some (v) | _ -> None esac
|
||||
else find (if c < 0 then l else r fi, k)
|
||||
fi
|
||||
esac
|
||||
}
|
||||
|
||||
fun remove (m, k) {
|
||||
return
|
||||
case m of
|
||||
{} -> m
|
||||
| MNode (kk, vv, bf, l, r) ->
|
||||
local c = compare (k, kk);
|
||||
if c == 0
|
||||
then case vv of {} -> m | _ : vt -> MNode (kk, vt, l, r) esac
|
||||
else if c < 0
|
||||
then MNode (kk, vv, bf, remove (l, k), r)
|
||||
else MNode (kk, vv, bf, l, remove (r, k))
|
||||
fi
|
||||
fi
|
||||
esac
|
||||
}
|
||||
|
||||
fun validate (t) {
|
||||
fun inner (t, verify) {
|
||||
return
|
||||
case t of
|
||||
{} -> 0
|
||||
| MNode (k, _, bf, l, r) ->
|
||||
if verify (k)
|
||||
then
|
||||
local lh = validate (l, fun (x) {return x < k}),
|
||||
rh = validate (r, fun (x) {return x > k});
|
||||
|
||||
if bf == lh - rh
|
||||
then 1 + if lh > rh then lh else rh fi
|
||||
else failure ("Balance violation on key %s\n", k.string)
|
||||
fi
|
||||
else failure ("Order violation on key %s\n", k.string)
|
||||
fi
|
||||
esac
|
||||
}
|
||||
|
||||
inner (t, fun (x) {return true})
|
||||
}
|
||||
|
||||
local tree = {}, i;
|
||||
|
||||
for i := 100, i >= 1, i := i-1 do
|
||||
validate (tree);
|
||||
tree := insert (tree, i, i);
|
||||
printf ("Inserting: %s\n", i.string);
|
||||
printf ("Result : %s\n", tree.string)
|
||||
od;
|
||||
|
||||
tree := {};
|
||||
|
||||
for i := 1, i <= 100, i := i+2 do
|
||||
validate (tree);
|
||||
tree := insert (tree, i, i);
|
||||
printf ("Inserting: %s\n", i.string);
|
||||
printf ("Result : %s\n", tree.string)
|
||||
od;
|
||||
|
||||
for i := 2, i <= 100, i := i+2 do
|
||||
validate (tree);
|
||||
tree := insert (tree, i, i);
|
||||
printf ("Inserting: %s\n", i.string);
|
||||
printf ("Result : %s\n", tree.string)
|
||||
od
|
||||
|
||||
|
|
@ -1,7 +1,6 @@
|
|||
-- (C) Dmitry Boulytchev, St. Petersburg State University, JetBrains Research, 2020
|
||||
-- Matcher: simple string matching library.
|
||||
|
||||
|
||||
-- Create a regular expression representation.
|
||||
-- Arguments:
|
||||
-- r --- a string representation for regular expression (as per GNU regexp)
|
||||
|
|
@ -30,9 +29,19 @@ fun matcherCreate (buf, pos, line, col) {
|
|||
return buf.length - pos
|
||||
}
|
||||
|
||||
-- Moves the position pointer on given number of characters within one line (i.e.
|
||||
-- Moves the position pointer on given number of characters.
|
||||
fun shift (n) {
|
||||
return matcherCreate (buf, pos + n, line, col + n)
|
||||
local i, l = line, c = col;
|
||||
|
||||
for i := pos, i < n, i := i+1 do
|
||||
case buf [i] of
|
||||
'\n' -> l := l + 1; c := 1
|
||||
| '\t' -> c := c + 8
|
||||
| _ -> c := c + 1
|
||||
esac
|
||||
od;
|
||||
|
||||
return matcherCreate (buf, pos + n, l, c)
|
||||
}
|
||||
|
||||
fun matchString (s) {
|
||||
|
|
@ -53,7 +62,7 @@ fun matcherCreate (buf, pos, line, col) {
|
|||
else Fail (sprintf ("%s expected at %d:%d", r[1], line, col))
|
||||
fi
|
||||
}
|
||||
|
||||
|
||||
fun eof () {
|
||||
return rest () == 0
|
||||
}
|
||||
|
|
@ -70,7 +79,7 @@ fun show (m) {
|
|||
return m [0] ()
|
||||
}
|
||||
|
||||
fun eof (m) {
|
||||
fun endOf (m) {
|
||||
return m [1] ()
|
||||
}
|
||||
|
||||
|
|
@ -78,11 +87,13 @@ fun matchString (m, s) {
|
|||
return m [2] (s)
|
||||
}
|
||||
|
||||
-- Matches against a regexp
|
||||
fun matchRegexp (m, r) {
|
||||
return m [3] (r)
|
||||
}
|
||||
|
||||
fun matcherInit (buf) {
|
||||
-- Creates a fresh matcher from a string buffer
|
||||
public fun matcherInit (buf) {
|
||||
return matcherCreate (buf, 0, 1, 1)
|
||||
}
|
||||
|
||||
|
|
@ -90,10 +101,76 @@ fun matcherInit (buf) {
|
|||
|
||||
--}
|
||||
|
||||
local m = matcherInit ("abc");
|
||||
local m = matcherInit (" -- asdasdakm ,m.,msd .,m.,asd\n \n\n abc");
|
||||
|
||||
local
|
||||
lident = createRegexp ("[a-z][a-zA-Z_]*", "lowercase identifier"),
|
||||
uident = createRegexp ("[A-Z][a-zA-Z_]*", "uppercase identifier"),
|
||||
ws = createRegexp ("\\([ \t\n]\\|--[^\n]*\n\\)*", "whitespace"),
|
||||
str = createRegexp ("""\([^""]\|""""\)*""", "string literal"),
|
||||
decimal = createRegexp ("[0-9]+", "decimal literal"),
|
||||
chr = createRegexp ("'[^']'", "character literal");
|
||||
|
||||
fun token (s) {
|
||||
return fun (m) {return m.matchString (s)}
|
||||
}
|
||||
|
||||
fun lid (m) {
|
||||
return m.matchRegexp (lident)
|
||||
}
|
||||
|
||||
fun uid (m) {
|
||||
return m.matchRegexp (uident)
|
||||
}
|
||||
|
||||
fun const (m) {
|
||||
return m.matchRegexp (decimal)
|
||||
}
|
||||
|
||||
infixl "@" before "*" (p, f) {
|
||||
return fun (m) {
|
||||
return
|
||||
case p (m) of
|
||||
Succ (m, x) -> Succ (m, f (x))
|
||||
| err -> err
|
||||
esac
|
||||
}
|
||||
}
|
||||
|
||||
infixr "|>" after "!!" (l, r) {
|
||||
return fun (m) {
|
||||
return
|
||||
case l (m) of
|
||||
Succ (m, s) -> r (s) (m)
|
||||
| err -> err
|
||||
esac
|
||||
}
|
||||
}
|
||||
|
||||
infixr "||" after "|>" (l, r) {
|
||||
return fun (m) {
|
||||
return
|
||||
case l (m) of
|
||||
s@Succ (_, _) -> s
|
||||
| err -> r (m)
|
||||
esac
|
||||
}
|
||||
}
|
||||
|
||||
local expr = lid @ fun (s) {return Lid (s)} ||
|
||||
const @ fun (s) {return Dec (s)},
|
||||
assn = lid |> fun (id) {return token (":=") |> fun (s) {return expr @ fun (e) {return Assn (id, e)}}};
|
||||
|
||||
printf ("%s\n", assn (matcherInit ("x:=3")).string)
|
||||
|
||||
--local ident = createRegexp ("[a-z][a-zA-Z_]*", "identifier");
|
||||
--local ws = createRegexp ("[ \n\t]+", "whitespace");
|
||||
|
||||
--local ws = createRegexp ("\\([ \t\n]\\|--[^\n]*\n\\)*", "whitespace");
|
||||
|
||||
--local str = createRegexp ("""\([^""]\|""""\)*""", "string literal");
|
||||
--local lineComment = createRegexp ("--[^\n]*\n", "line comment");
|
||||
|
||||
--printf ("ws: %s\n", case m.matchRegexp (ws) of Succ (m, s) -> "(" ++ m.show ++ ", " ++ s ++ ")" | Fail (err) -> err.string esac);
|
||||
|
||||
local ident = createRegexp ("[a-z][a-zA-Z_]*", "identifier");
|
||||
local ws = createRegexp ("[ \n\t]+", "whitespace");
|
||||
local str = createRegexp ("""\([^""]\|""""\)*""", "string literal");
|
||||
|
||||
printf ("ident: %s\n", case m.matchRegexp (ident) of Succ (m, s) -> "(" ++ m.show ++ ", " ++ s ++ ")" | Fail (err) -> err.string esac)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue