Native.borg
Native.borg
`*-----------------------------------*`
`* >>>Pico v.1.1<<< *`
`* Theo D'Hondt *`
`* VUB Programming Technology Lab *`
`* (c)1999 *`
`*-----------------------------------*`
`* native declarations *`
`* (METACIRCULAR VERSION) *`
`*-----------------------------------*`
{ Init_Native():
{ CAS: "case";
CNT: "context";
SEL: "select";
TAB: "tab";
DCT: _VOID_;
ARG: _VOID_;
EXP: _VOID_;
meta_NBR(Nbr):
{ tag: Nbr[TAG_idx];
if(tag = NBR_tag,
Nbr[NBR_VAL_idx],
Error('number required')) };
meta_NUM(Num):
{ tag: Num[TAG_idx];
if(tag = NBR_tag,
Num[NBR_VAL_idx],
if(tag = FRC_tag,
Num[FRC_VAL_idx],
Error('number or fraction required'))) };
meta_ANY(Any):
{ tag: Any[TAG_idx];
if(tag = NBR_tag,
Any[NBR_VAL_idx],
if(tag = FRC_tag,
Any[FRC_VAL_idx],
if(tag = TXT_tag,
Any[TXT_VAL_idx],
Error('number, fraction or text required')))) };
meta_TXT(Txt):
{ tag: Txt[TAG_idx];
if(tag = TXT_tag,
Txt[TXT_VAL_idx],
Error('text required')) };
meta_TAB(Tab):
{ tag: Tab[TAG_idx];
if(tag = TAB_tag,
Tab[TAB_TAB_idx],
Error('table required')) };
base_NBR(Nbr):
if(is_number(Nbr),
Make_NBR(Nbr),
Error('number required'));
base_FRC(Frc):
if(is_fraction(Frc),
Make_FRC(Frc),
Error('number required'));
base_NUM(Num):
if(is_number(Num),
Make_NBR(Num),
if(is_fraction(Num),
Make_FRC(Num),
Error('number or fraction required')));
base_TXT(Txt):
if(is_text(Txt),
Make_TXT(Txt),
Error('text value required'));
base_TAB(Tab):
if(is_table(Tab),
Make_TAB(Tab),
Error('text value required'));
arg_0(Arg, Act()):
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 0,
Act(),
Error('no arguments allowed')) };
arg_1(Arg, Act(p)):
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 1,
Act(Eval(arg[1])),
Error('1 argument required')) };
arg_1_2(Arg, Ac1(p), Ac2(p,q)):
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 1,
Ac1(Eval(arg[1])),
if(size(arg) = 2,
Ac2(Eval(arg[1]),Eval(arg[2])),
Error('1 or 2 arguments required'))) };
arg_2(Arg, Act(p,q)):
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 2,
Act(Eval(arg[1]),Eval(arg[2])),
Error('2 arguments required')) };
chr(Txt):
if(size(Txt) = 1,
Txt,
Error('singe character expected'));
boolean(Bln, Cns, Alt):
if(Bln ~ _TRUE_,
Eval(Cns),
if(Bln ~ _FALSE_,
Eval(Alt),
Apply(p, Make_TAB([Cns, Alt]))));
add_fun@Arg:
arg_1_2(Arg,
base_NUM(+meta_NUM(p)),
if((p[TAG_idx] = TXT_tag)&(q[TAG_idx] = TXT_tag),
base_TXT(meta_TXT(p)+meta_TXT(q)),
base_NUM(meta_NUM(p)+meta_NUM(q))));
sub_fun@Arg:
arg_1_2(Arg,
base_NUM(-meta_NUM(p)),
base_NUM(meta_NUM(p)-meta_NUM(q)));
mul_fun@Arg:
arg_2(Arg,
base_NUM(meta_NUM(p)*meta_NUM(q)));
fdv_fun@Arg:
arg_2(Arg,
{ num: meta_NUM(q);
if(num = 0,
Error('division by zero'),
base_NUM(meta_NUM(p)/num)) });
idv_fun(#):
fun@Arg:
arg_2(Arg,
{ nbr: meta_NBR(q);
if(nbr = 0,
Error('division by zero'),
base_NBR(meta_NBR(p)#nbr)) });
exp_fun@Arg:
arg_2(Arg,
{ num: meta_NUM(p);
if(num<0,
Error('negative base number'),
base_FRC(num^meta_NUM(q))) });
rel_fun(#):
fun@Arg:
arg_2(Arg,
if((p[TAG_idx] = TXT_tag)&(q[TAG_idx] = TXT_tag),
if(meta_TXT(p)#meta_TXT(q), _TRUE_, _FALSE_),
if(meta_NUM(p)#meta_NUM(q), _TRUE_, _FALSE_)));
eqv_fun@Arg:
arg_2(Arg,
if(p ~ q, _TRUE_, _FALSE_));
nqv_fun@Arg:
arg_2(Arg,
if(p ~ q, _FALSE_, _TRUE_));
tru_fun@Arg:
arg_1(Arg,
base_NBR(trunc(meta_NUM(p))));
abs_fun@Arg:
arg_1(Arg,
base_NUM(abs(meta_NUM(p))));
chr_fun@Arg:
arg_1(Arg,
{ nbr: meta_NBR(p);
if((nbr<0)|(nbr>255),
Error('invalid ordinal'),
base_TXT(char(nbr))) });
ord_fun@Arg:
arg_1(Arg,
base_NBR(ord(chr(meta_TXT(p)))));
nbr_fun@Arg:
arg_1(Arg,
{ num: number(meta_TXT(p));
if(is_void(num),
_VOID_,
base_NUM(num))});
txt_fun@Arg:
arg_1(Arg,
base_TXT(text(meta_ANY(p))));
rnd_fun@Arg:
arg_0(Arg,
base_NBR(random()));
clk_fun@Arg:
arg_0(Arg,
base_NUM(clock()));
trs_fun(Opr):
fun@Arg:
arg_1(Arg,
base_FRC(Opr(meta_NUM(p))));
len_fun@Arg:
arg_1(Arg,
base_NBR(length(meta_TAB(p))));
epl_fun@Arg:
arg_1(Arg,
{ c: explode(meta_TXT(p));
cnt: 0;
t[size(c)]: base_TXT(c[cnt:=cnt+1]);
base_TAB(t) });
ipl_fun@Arg:
arg_1(Arg,
{ t: meta_TAB(p);
cnt: 0;
c[size(t)]: chr(meta_TXT(t[cnt:=cnt+1]));
base_TXT(implode(c))});
typ_fun(Tag):
fun@Arg:
arg_1(Arg,
if(p[TAG_idx] = Tag, _TRUE_, _FALSE_));
dct_fun(Arg):
arg_1(Arg,
if((p[TAG_idx] = VAR_TAG)|(p[TAG_idx] = CST_TAG), _TRUE_, _FALSE_));
siz_fun@Arg:
arg_1(Arg,
base_NBR(size(meta_TAB(p))));
tab_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
siz: size(arg);
if(siz>0,
{ cnt: 0;
rtb[siz]: Eval(arg[cnt:=cnt+1]);
Make_TAB(rtb) },
_EMPTY_) };
pai_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 2,
Make_TAB([Eval(arg[1]),Eval(arg[2])]),
Error('2 arguments required')) };
dsp_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
for(cnt:1, cnt<=size(arg), cnt:=cnt+1,
Print(Eval(arg[cnt])));
_EOLN_ };
acc_fun@Arg:
arg_0(Arg,
base_TXT(accept()));
trr_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 2,
Eval(arg[1]),
Error('2 arguments required')) };
fls_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 2,
Eval(arg[2]),
Error('2 arguments required')) };
and_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 2,
boolean(Eval(arg[1]), arg[2], _FALSE_),
Error('2 arguments required')) };
orr_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 2,
boolean(Eval(arg[1]), _TRUE_, arg[2]),
Error('2 arguments required')) };
not_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 1,
boolean(Eval(arg[1]), _FALSE_, _TRUE_),
Error('1 argument required')) };
bgn_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
siz: size(arg);
if(siz>0,
for(cnt:1, cnt<=siz, cnt:=cnt+1,
Eval(arg[cnt])),
Error('at least 1 argument required')) };
iff_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
siz: size(arg);
if(siz>1,
{ p: Eval(arg[1]);
if(siz = 2,
boolean(p, arg[2], _VOID_),
if(siz = 3,
boolean(p, arg[2], arg[3]),
Error('at most 3 arguments allowed'))) },
Error('at least 2 arguments required')) };
whi_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 2,
{ val: _VOID_;
while(boolean(Eval(arg[1]), _TRUE_, _FALSE_) ~ _TRUE_,
val:= Eval(arg[2]));
val },
Error('2 arguments required')) };
unt_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 2,
{ val: _VOID_;
until(boolean(Eval(arg[1]), _TRUE_, _FALSE_) ~ _TRUE_,
val:= Eval(arg[2]));
val },
Error('2 arguments required')) };
for_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 4,
{ val: _VOID_;
for(Eval(arg[1]), boolean(Eval(arg[2]), _TRUE_, _FALSE_) ~ _TRUE_, Eval(arg[3]),
val:= Eval(arg[4]));
val },
Error('4 arguments required')) };
cas_fun@Arg:
{ els: _VOID_;
arg: Arg[TAB_TAB_idx];
siz: size(arg);
max: -1073741823;
min: +1073741823;
loop(Pos):
if(Pos>siz,
if(max'at least 1 argument required'),
tbl[max-min+1]: els),
{ pai: meta_TAB(Eval(arg[Pos]));
if(pai[1]~_VOID_,
{ els:= pai[2];
loop(Pos+1) },
{ tag: meta_NBR(pai[1]);
if(tag > max, max:= tag);
if(tag < min, min:= tag);
tbl: loop(Pos+1);
tbl[tag-min+1]:= pai[2];
tbl }) });
tbl: TAB[loop(1)];
Make_FUN(SEL, arg_str, APL, DCT) };
lod_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
Error('not yet implemented') };
dmp_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
Error('not yet implemented') };
rea_fun@Arg:
arg_1(Arg,
Read(meta_TXT(p)));
eva_fun@Arg:
arg_1(Arg,
Eval(p));
pri_fun@Arg:
arg_1(Arg,
{ Print(p); _EOLN_ });
tag_fun@Arg:
arg_1(Arg,
p);
rnk_fun@Arg:
arg_1(Arg,
base_NBR(rank(meta_TAB(p))));
mak_fun@Arg:
{ voi(): _VOID_;
nat(): Make_NAT("", 0);
frc(): Make_FRC(0.0);
txt(): Make_TXT("");
tbb(): _EMPTY_;
fun(): Make_FUN("", _VOID_, _VOID_, _VOID_);
ref(): Make_REF("");
apl(): Make_APL("", _EMPTY_);
tbl(): Make_TBL("", Make_TAB([_ZERO_]));
msg(): Make_TBL("", Make_REF(""));
def(): Make_DEF(Make_REF(""), _VOID_);
dcl(): Make_DCL(Make_REF(""), _VOID_);
set(): Make_SET(Make_REF(""), _VOID_);
var(): Make_VAR("", _VOID_, _VOID_);
cst(): Make_CST("", _VOID_, _VOID_);
ctx(): Make_CTX(_VOID_, _ZERO_, _ZERO_, _EMPTY_);
nbr(): _ZERO_;
err(): Error("abstract grammar violation");
tag_case: case(VOI_tag <> voi,
NAT_tag <> nat,
FRC_tag <> frc,
TXT_tag <> txt,
TAB_tag <> tbb,
FUN_tag <> fun,
REF_tag <> var,
APL_tag <> apl,
TBL_tag <> tbl,
MES_tag <> msg,
DEF_tag <> def,
DCL_tag <> dcl,
SET_tag <> set,
VAR_tag <> var,
CST_tag <> cst,
CTX_tag <> ctx,
NBR_tag <> nbr,
void <> err);
mak_fun@Arg:=
{ arg_1(Arg,
{ tag: meta_NBR(p);
cas: tag_case(tag);
cas() }) };
mak_fun@Arg };
cal_fun@Arg:
arg_1(Arg,
Error('for documentation only'));
cnt_fun@Arg:
arg_2(Arg,
Error('for documentation only'));
esc_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
if(size(arg) = 1,
escape(Eval(arg[1])),
Error('1 argument required')) };
cpt_fun@Arg:
arg_0(Arg,
Capture());
ext_fun@Arg:
{ arg: Arg[TAB_TAB_idx];
cnt: 0;
lst[size(arg)]: meta_ANY(Eval(arg[cnt:= cnt+1]));
external@lst;
_VOID_ };
err_fun@Arg:
arg_1(Arg,
Error(meta_TXT(p)));
trc_fun@Arg:
arg_0(Arg, { trace(); _VOID_ });
sel_fun(Tag, Min, Max, Els, Tbl):
{ tag: meta_nbr(Eval(Tag));
if((tagMax), Els, Tbl[tag-Min+1]) };
nat_tab: [ '+',
'-',
'*',
'/',
'//',
'\\',
'^',
'<',
'<=',
'=',
'!=',
'>',
'>=',
'~',
'!~',
'trunc',
'abs',
'char',
'ord',
'number',
'text',
'random',
'clock',
'sqrt',
'sin',
'cos',
'tan',
'arcsin',
'arccos',
'arctan',
'exp',
'log',
'length',
'explode',
'implode',
'is_void',
'is_number',
'is_fraction',
'is_text',
'is_table',
'is_function',
'is_native',
'is_dictionary',
'is_context',
'size',
'tab',
'<>',
'display',
'accept',
'true',
'false',
'&',
'|',
'!',
'begin',
'if',
'while',
'until',
'for',
'case',
'load',
'dump',
'read',
'eval',
'print',
'tag',
'rank',
'make',
'capture',
'call',
'continue',
'escape',
'external',
'error',
'trace',
'select' ];
fun_tab: [ add_fun,
sub_fun,
mul_fun,
fdv_fun,
idv_fun(//),
idv_fun(\\),
exp_fun,
rel_fun(<),
rel_fun(<=),
rel_fun(=),
rel_fun(!=),
rel_fun(>),
rel_fun(>=),
eqv_fun,
nqv_fun,
tru_fun,
abs_fun,
chr_fun,
ord_fun,
nbr_fun,
txt_fun,
rnd_fun,
clk_fun,
trs_fun(sqrt),
trs_fun(sin),
trs_fun(cos),
trs_fun(tan),
trs_fun(arcsin),
trs_fun(arccos),
trs_fun(arctan),
trs_fun(exp),
trs_fun(log),
len_fun,
epl_fun,
ipl_fun,
typ_fun(VOI_tag),
typ_fun(NBR_tag),
typ_fun(FRC_tag),
typ_fun(TXT_tag),
typ_fun(TAB_tag),
typ_fun(FUN_tag),
typ_fun(NAT_tag),
dct_fun,
typ_fun(CTX_tag),
siz_fun,
tab_fun,
pai_fun,
dsp_fun,
acc_fun,
trr_fun,
fls_fun,
and_fun,
orr_fun,
not_fun,
bgn_fun,
iff_fun,
whi_fun,
unt_fun,
for_fun,
cas_fun,
lod_fun,
dmp_fun,
rea_fun,
eva_fun,
pri_fun,
tag_fun,
rnk_fun,
mak_fun,
cpt_fun,
cal_fun,
cnt_fun,
esc_fun,
ext_fun,
err_fun,
trc_fun,
sel_fun ];
Init_Native():=
{ global: Init_Dict();
DCT:= Make_VAR(SEL, Make_NAT(SEL, size(nat_tab)), _VOID_);
ARG:= Make_TAB([ Make_REF(CAS) ]);
EXP:= Make_APL(SEL, Make_TAB([ Make_REF(TAB), Make_REF(CAS) ]));
for(idx: 1, idx < size(nat_tab), idx:= idx+1,
{ nam: Make_TXT(nat_tab[idx]);
global:= Add_Var(nam,
Make_NAT(nam, fun_tab[idx]),
global) });
global:= Add_Var(Make_TXT('eoln') , _EOLN_, global);
global:= Add_Var(Make_TXT('void') , _VOID_, global);
_TRUE_ := Get_Any(Make_TXT('true'), global);
_FALSE_:= Get_Any(Make_TXT('false'), global);
Init_Eval(global);
void };
Init_Native() };
display('natives ...... installed', eoln) }