(********************************************************************)
(* *)
(* seed7_05.s7i Standard Seed7 library *)
(* Copyright (C) 1989 - 2007 Thomas Mertes *)
(* *)
(* This file is part of the Seed7 Runtime Library. *)
(* *)
(* The Seed7 Runtime Library is free software; you can *)
(* redistribute it and/or modify it under the terms of the GNU *)
(* Lesser General Public License as published by the Free Software *)
(* Foundation; either version 2.1 of the License, or (at your *)
(* option) any later version. *)
(* *)
(* The Seed7 Runtime Library is distributed in the hope that it *)
(* will be useful, but WITHOUT ANY WARRANTY; without even the *)
(* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR *)
(* PURPOSE. See the GNU Lesser General Public License for more *)
(* details. *)
(* *)
(* You should have received a copy of the GNU Lesser General *)
(* Public License along with this program; if not, write to the *)
(* Free Software Foundation, Inc., 51 Franklin Street, *)
(* Fifth Floor, Boston, MA 02110-1301, USA. *)
(* *)
(********************************************************************)
$ include "syntax.s7i";
(*
$ const $ type: type is $ newtype;
$ const type: void is $ newtype;
$ const type: proc is $ func void;
$ const void: empty is $ enumlit;
$ const type: expr is $ newtype;
$ const type: object is $ newtype;
$ const type: string is $ subtype object;
$ const type: ACTION is $ newtype;
$ const type: f_param is $ newtype;
*)
$ const $ func type: $ func (ref type param) is $ action "TYP_FUNC";
$ const $ func type: $ varfunc (ref type param) is $ action "TYP_VARFUNC";
$ const func ACTION: $ action (ref string param) is $ action "ACT_GEN";
$ const proc: $ (ref proc param) ::= (ref ACTION param) is $ action "ACT_CREATE";
$ const proc: $ destroy (ref string param) is action "STR_DESTR";
$ const proc: $ (ref func f_param param) ::= (ref ACTION param) is action "ACT_CREATE";
$ const func f_param: $ ref (ref type param) param is action "DCL_REF1";
$ const proc: const (ref type param) : (ref expr param) is (ref expr param) is action "DCL_CONST";
const proc: const (ref type param) : (ref expr param) is forward is action "DCL_FWD";
const proc: var (ref type param) : (ref expr param) is (ref expr param) is action "DCL_VAR";
const func f_param: ref (ref type param) : (ref expr param) is action "DCL_REF2";
const func f_param: val (ref type param) param is action "DCL_VAL1";
const func f_param: val (ref type param) : (ref expr param) is action "DCL_VAL2";
const func f_param: in var (ref type param) param is action "DCL_IN1VAR";
const func f_param: in var (ref type param) : (ref expr param) is action "DCL_IN2VAR";
const func f_param: inout (ref type param) param is action "DCL_INOUT1";
const func f_param: inout (ref type param) : (ref expr param) is action "DCL_INOUT2";
const func f_param: in (ref type param) param is action "DCL_REF1";
const func f_param: attr (ref type param) is action "DCL_ATTR";
const func f_param: attr (ref f_param param) is action "DCL_PARAM_ATTR";
const proc: (ref type param) ::= (ref type param) is action "TYP_CREATE";
const proc: destroy (ref type param) is action "TYP_DESTR";
const proc: (inout type param) := (ref type param) is action "TYP_CPY";
const proc: (ref func proc param) ::= (ref ACTION param) is action "ACT_CREATE";
const proc: (ref varfunc proc param) ::= (ref ACTION param) is action "ACT_CREATE";
const func proc: func begin (ref expr param) end func is action "PRC_BEGIN";
const func proc: func local (ref proc param) begin (ref expr param) end func is action "PRC_LOCAL";
const proc: (ref proc param) ::= (ref proc param) is action "PRC_CREATE";
const proc: (inout proc param) := (ref proc param) is action "PRC_CPY";
const proc: destroy (ref proc param) is action "PRC_NOOP";
const proc: noop is action "PRC_NOOP";
const proc: (ref void param) ; (ref void param) is noop;
const proc: PRINT (ref string param) is action "FIL_PRINT";
const proc: IN_PARAM_IS_VALUE (ref type: aType) is func
begin
const func f_param: in (attr aType) param is action "DCL_VAL1";
const func f_param: in (attr aType) : (ref expr param) is action "DCL_VAL2";
end func;
const proc: IN_PARAM_IS_REFERENCE (ref type: aType) is func
begin
const func f_param: in (attr aType) param is action "DCL_REF1";
const func f_param: in (attr aType) : (ref expr param) is action "DCL_REF2";
end func;
IN_PARAM_IS_REFERENCE(type);
IN_PARAM_IS_REFERENCE(proc);
IN_PARAM_IS_REFERENCE(object);
IN_PARAM_IS_REFERENCE(string);
IN_PARAM_IS_REFERENCE(ACTION);
const proc: BASIC_TYPE_DECLS (in type: aType) is func
begin
(* PRINT("in BASIC_TYPE_DECLS\n"); *)
const proc: TRACE (ref aType param) is action "REF_TRACE";
const proc: ignore (ref aType param) is noop;
const proc: (ref func aType param) ::= (ref ACTION param) is action "ACT_CREATE";
const proc: (ref varfunc aType param) ::= (ref ACTION param) is action "ACT_CREATE";
const proc: (ref func aType param) ::= (ref func aType param) is action "PRC_CREATE";
const proc: (ref varfunc aType param) ::= (ref varfunc aType param) is action "PRC_CREATE";
const proc: (inout func aType param) := (ref func aType param) is action "PRC_CPY";
const proc: (inout varfunc aType param) := (ref varfunc aType param) is action "PRC_CPY";
const type: typeof (ref aType param) is aType;
const proc: (ref func func aType param) ::= (ref ACTION param) is action "ACT_CREATE";
const proc: (ref func varfunc aType param) ::= (ref ACTION param) is action "ACT_CREATE";
const func func aType: func
result
var (attr aType) : (ref expr param) is (ref aType param)
local
(ref proc param)
begin
(ref expr param)
end func is action "PRC_RES_LOCAL";
const func func aType: func
result
var (attr aType) : (ref expr param) is (ref func aType param)
local
(ref proc param)
begin
(ref expr param)
end func is action "PRC_RES_LOCAL";
const func func aType: func
result
var (attr aType) : (ref expr param) is (ref aType param)
begin
(ref expr param)
end func is action "PRC_RES_BEGIN";
const func func aType: func
result
var (attr aType) : (ref expr param) is (ref func aType param)
begin
(ref expr param)
end func is action "PRC_RES_BEGIN";
const func func aType: return (ref func aType param) is action "PRC_RETURN";
const func func aType: return (ref aType param) is action "PRC_RETURN";
const func varfunc aType: return var (ref varfunc aType param) is action "PRC_VARFUNC";
const func varfunc aType: return var (inout aType param) is action "PRC_VARFUNC";
const func func aType: (attr aType) return (ref func aType param) is action "PRC_RETURN2";
const func func aType: (attr aType) return (ref aType param) is action "PRC_RETURN2";
const func varfunc aType: (attr aType) return var (ref varfunc aType param) is action "PRC_VARFUNC2";
const func varfunc aType: (attr aType) return var (inout aType param) is action "PRC_VARFUNC2";
end func;
BASIC_TYPE_DECLS(type);
BASIC_TYPE_DECLS(string);
BASIC_TYPE_DECLS(ACTION);
const proc: var (ref type: aType) : (ref expr: name) is default is func
begin
var aType: name is aType.value;
end func;
const func string: str (in type param) is action "TYP_STR";
const func string: (in string param) & (in string param) is action "STR_CAT";
const func type: gentype is action "TYP_GENTYPE";
const func type: gensub (in type param) is action "TYP_GENSUB";
const func type: newtype is func
result
var type: aType is void;
begin
aType := gentype;
(* PRINT("GENERATE type: newtype as "); PRINT(str(aType)); PRINT("\n"); *)
BASIC_TYPE_DECLS(aType);
(* TRACE(aType);
PRINT("\n"); *)
end func;
const func type: subtype (in type: baseType) is func
result
var type: aType is void;
begin
aType := gensub(baseType);
(* PRINT("GENERATE type: subtype "); PRINT(str(baseType)); PRINT(" as "); PRINT(str(aType)); PRINT("\n"); *)
BASIC_TYPE_DECLS(aType);
const type: base_type (attr aType) is baseType;
const func func aType: func
result
var (attr aType) : (ref expr param) is (ref baseType param)
local
(ref proc param)
begin
(ref expr param)
end func is action "PRC_RES_LOCAL";
const func func aType: func
result
var (attr aType) : (ref expr param) is (ref func baseType param)
local
(ref proc param)
begin
(ref expr param)
end func is action "PRC_RES_LOCAL";
const func func aType: func
result
var (attr aType) : (ref expr param) is (ref baseType param)
begin
(ref expr param)
end func is action "PRC_RES_BEGIN";
const func func aType: func
result
var (attr aType) : (ref expr param) is (ref func baseType param)
begin
(ref expr param)
end func is action "PRC_RES_BEGIN";
const func func aType: (attr aType) return (ref func baseType param) is action "PRC_RETURN2";
const func func aType: (attr aType) return (ref baseType param) is action "PRC_RETURN2";
const func varfunc aType: (attr aType) return var (ref varfunc baseType param) is action "PRC_VARFUNC2";
const func varfunc aType: (attr aType) return var (inout baseType param) is action "PRC_VARFUNC2";
(* TRACE(aType);
PRINT("\n"); *)
(*
pixel conv 25
pixel conv number
pixel conv (number)
pixel conv (2 + number)
pixel.conv 25
pixel.conv number
pixel.conv (number)
pixel.conv (2 + number)
pixel`25
pixel`number
pixel`(number)
pixel`(2 + number)
pixel^25
pixel^number
pixel^(number)
pixel^(2 + number)
pixel<-25
pixel<-number
pixel<-(number)
pixel<-(2 + number)
pixel~25
pixel~number
pixel~(number)
pixel~(2 + number)
pixel\25
pixel\number
pixel\(number)
pixel\(2 + number)
pixel$25
pixel$number
pixel$(number)
pixel$(2 + number)
pixel!25
pixel!number
pixel!(number)
pixel!(2 + number)
pixel%25
pixel%number
pixel%(number)
pixel%(2 + number)
pixel|25
pixel|number
pixel|(number)
pixel|(2 + number)
pixel.25
pixel.number
pixel.(number)
pixel.(2 + number)
pixel@25
pixel@number
pixel@(number)
pixel@(2 + number)
*)
end func;
(*
const func type: func (in type: baseType) is func
result
var type: aType is void;
begin
aType := gentype;
const func type: func baseType is aType;
const proc: TRACE (ref aType param) is action "REF_TRACE";
const proc: (ref aType param) ::= (ref ACTION param) is action "ACT_CREATE";
const proc: (ref aType param) ::= (ref aType param) is action "PRC_CREATE";
end func;
*)
const type: EXCEPTION is newtype;
const type: LEGAL is newtype;
const type: DISCRETE is subtype object;
const type: integer is subtype DISCRETE;
$ system "integer" is integer;
IN_PARAM_IS_VALUE(integer);
const type: char is subtype DISCRETE;
$ system "char" is char;
IN_PARAM_IS_VALUE(char);
const type: ENUMERATION is subtype DISCRETE;
IN_PARAM_IS_VALUE(ENUMERATION);
const type: INDEXABLE is subtype object;
const type: MODULE is subtype object;
const proc: destroy (ref ACTION param) is noop;
const proc: destroy (ref ENUMERATION param) is noop;
const proc: destroy (ref integer param) is noop;
const proc: destroy (ref char param) is noop;
const proc: destroy (ref EXCEPTION param) is noop;
const proc: (ref ACTION param) ::= (in ACTION param) is action "ACT_CREATE";
const proc: destroy (ref func ACTION param) is noop;
const proc: (inout ACTION param) := (in ACTION param) is action "ACT_CPY";
const proc: (ref ENUMERATION param) ::= (ref ENUMERATION param) is action "ENU_CREATE";
const proc: (ref ENUMERATION param) ::= enumlit is action "ENU_GENLIT";
const proc: (ref integer param) ::= (ref integer param) is action "INT_CREATE";
const proc: (ref char param) ::= (in char param) is action "CHR_CREATE";
const proc: (ref string param) ::= (in string param) is action "STR_CREATE";
const proc: (ref func object param) ::= (in ACTION param) is action "ACT_CREATE";
const proc: (ref EXCEPTION param) ::= (ref EXCEPTION param) is action "ENU_CREATE";
const proc: (ref EXCEPTION param) ::= enumlit is action "ENU_GENLIT";
const EXCEPTION: MEMORY_ERROR is enumlit;
const EXCEPTION: NUMERIC_ERROR is enumlit;
const EXCEPTION: RANGE_ERROR is enumlit;
const EXCEPTION: FILE_ERROR is enumlit;
const EXCEPTION: ILLEGAL_ACTION is enumlit;
$ system "memory_error" is MEMORY_ERROR;
$ system "numeric_error" is NUMERIC_ERROR;
$ system "range_error" is RANGE_ERROR;
$ system "file_error" is FILE_ERROR;
$ system "illegal_action" is ILLEGAL_ACTION;
const proc: raise (ref EXCEPTION param) is action "PRC_RAISE";
const func string: str (in ACTION param) is action "ACT_STR";
const ACTION: DYNAMIC is action "PRC_DYNAMIC";
const proc: exit (in integer param) is action "PRC_EXIT";
const proc: exit (PROGRAM) is func
begin
exit(0);
end func;
const proc: TRACE_OPTIONS (in string param) is action "PRC_SETTRACE";
const proc: TRACE_OBJ (in object param) is action "REF_TRACE";
const proc: TRACE_PROC (in proc param) is action "REF_TRACE";
const proc: DECLS is action "PRC_DECLS";
(* boolean *)
const type: boolean is subtype ENUMERATION;
IN_PARAM_IS_VALUE(boolean);
const proc: (ref boolean param) ::= (in boolean param) is action "BLN_CREATE";
const proc: destroy (ref boolean param) is noop;
const proc: (inout boolean param) := (in boolean param) is action "BLN_CPY";
const boolean: FALSE is enumlit;
const boolean: TRUE is enumlit;
$ system "true" is TRUE;
$ system "false" is FALSE;
const boolean: (attr boolean) . value is FALSE;
const boolean: (attr boolean) . first is FALSE;
const boolean: (attr boolean) . last is TRUE;
const func boolean: not (in boolean param) is action "BLN_NOT";
const func boolean: (in boolean param) and (in func boolean param) is action "BLN_AND";
const func boolean: (in boolean param) and (in varfunc boolean param) is action "BLN_AND";
const func boolean: (in boolean param) and (in boolean param) is action "BLN_AND";
const func boolean: (in boolean param) or (in func boolean param) is action "BLN_OR";
const func boolean: (in boolean param) or (in varfunc boolean param) is action "BLN_OR";
const func boolean: (in boolean param) or (in boolean param) is action "BLN_OR";
const func boolean: (in boolean param) = (in boolean param) is action "ENU_EQ";
const func boolean: (in boolean param) < (in boolean param) is action "BLN_LT";
const func boolean: (in boolean param) > (in boolean param) is action "BLN_GT";
const func boolean: (in boolean param) <= (in boolean param) is action "BLN_LE";
const func boolean: (in boolean param) >= (in boolean param) is action "BLN_GE";
const func boolean: (in boolean param) <> (in boolean param) is action "ENU_NE";
const func integer: hashCode (in boolean param) is action "BLN_ORD";
const func integer: ord (in boolean param) is action "BLN_ORD";
const func boolean: (attr boolean) conv (in integer param) is action "BLN_ICONV";
const varfunc boolean: (attr boolean) varConv (inout integer param) is action "TYP_VARCONV";
const boolean: succ (FALSE) is TRUE;
const boolean: pred (TRUE) is FALSE;
const func boolean: succ(ref boolean param) is DYNAMIC;
const func boolean: pred(ref boolean param) is DYNAMIC;
const proc: incr (inout boolean: bool_value) is func
begin
bool_value := succ(bool_value);
end func;
const proc: decr (inout boolean: bool_value) is func
begin
bool_value := pred(bool_value);
end func;
(*
const func boolean: not (attr TRUE) is FALSE;
const func boolean: not (attr FALSE) is TRUE;
const func boolean: (attr FALSE) and (func boolean) is FALSE;
const func boolean: (attr FALSE) and boolean is FALSE;
const func boolean: (attr FALSE) or (attr FALSE) is FALSE;
const func boolean: (attr FALSE) or (attr TRUE) is TRUE;
const func boolean: (attr FALSE) = (attr FALSE) is TRUE;
const func boolean: (attr FALSE) = (attr TRUE) is FALSE;
const func boolean: (attr FALSE) < (attr FALSE) is FALSE;
const func boolean: (attr FALSE) < (attr TRUE) is TRUE;
const func boolean: (attr FALSE) > boolean is FALSE;
const func boolean: (attr FALSE) <= boolean is TRUE;
const func boolean: (attr FALSE) >= (attr FALSE) is TRUE;
const func boolean: (attr FALSE) >= (attr TRUE) is FALSE;
const func boolean: (attr FALSE) <> (attr FALSE) is FALSE;
const func boolean: (attr FALSE) <> (attr TRUE) is TRUE;
const integer: ord (attr FALSE) is 0;
const func boolean: succ (attr FALSE) is TRUE;
const EXCEPTION: pred (attr FALSE) is RANGE_ERROR;
const string: str (attr FALSE) is "FALSE";
const func boolean: (attr TRUE) and (attr FALSE) is FALSE;
const func boolean: (attr TRUE) and (attr TRUE) is TRUE;
const func boolean: (attr TRUE) or (func boolean) is TRUE;
const func boolean: (attr TRUE) or boolean is TRUE;
const func boolean: (attr TRUE) = (attr FALSE) is FALSE;
const func boolean: (attr TRUE) = (attr TRUE) is TRUE;
const func boolean: (attr TRUE) < boolean is FALSE;
const func boolean: (attr TRUE) > (attr FALSE) is TRUE;
const func boolean: (attr TRUE) > (attr TRUE) is FALSE;
const func boolean: (attr TRUE) <= (attr FALSE) is FALSE;
const func boolean: (attr TRUE) <= (attr TRUE) is TRUE;
const func boolean: (attr TRUE) >= boolean is TRUE;
const func boolean: (attr TRUE) <> (attr FALSE) is TRUE;
const func boolean: (attr TRUE) <> (attr TRUE) is FALSE;
const integer: ord (attr TRUE) is 1;
const EXCEPTION: succ (attr TRUE) is RANGE_ERROR;
const func boolean: pred (attr TRUE) is FALSE;
const string: str (attr TRUE) is "TRUE";
*)
const type: (attr type) . value is void;
const func boolean: (in type param) = (in type param) is action "TYP_EQ";
const func boolean: (in type param) <> (in type param) is action "TYP_NE";
const func integer: compare (in type param, in type param) is action "TYP_CMP";
const func integer: hashCode (in type param) is action "TYP_HASHCODE";
const func boolean: is_func (in type param) is action "TYP_ISFUNC";
const func boolean: is_varfunc (in type param) is action "TYP_ISVARFUNC";
const func type: result_type (in type param) is action "TYP_RESULT";
const func boolean: is_derived (in type param) is action "TYP_ISDERIVED";
const func type: meta (in type param) is action "TYP_META";
const proc: addInterface (in type param, in type param) is action "TYP_ADDINTERFACE";
(* IF *)
const type: ELSIF_RESULT is newtype;
const proc: (ref ELSIF_RESULT param) ::= enumlit is action "ENU_GENLIT";
const ELSIF_RESULT: ELSIF_EMPTY is enumlit;
const type: ELSIF_PROC is (func ELSIF_RESULT);
IN_PARAM_IS_REFERENCE(ELSIF_PROC);
const proc: (ref ELSIF_PROC param) ::= (ref ELSIF_RESULT param) is action "ENU_CREATE";
const proc: if (in boolean param) then
(in proc param)
end if is action "PRC_IF";
const proc: if (in boolean param) then
(in proc param)
(in ELSIF_PROC param)
end if is action "PRC_IF_ELSIF";
const ELSIF_PROC: elsif (in boolean param) then
(in proc param) is action "PRC_IF";
const ELSIF_PROC: elsif (in boolean param) then
(in proc param)
(in ELSIF_PROC param) is action "PRC_IF_ELSIF";
const ELSIF_PROC: else
(in void param) is ELSIF_EMPTY;
(*
const proc: if TRUE then (in void param) end if is noop;
const proc: if TRUE then (in void param) (in ELSIF_PROC param) end if is noop;
const proc: if FALSE then (in proc param) end if is noop;
const proc: if FALSE then (in proc param) (in ELSIF_RESULT param) end if is noop;
const ELSIF_PROC: elsif TRUE then (in void param) is ELSIF_EMPTY;
const ELSIF_PROC: elsif TRUE then (in void param) (in ELSIF_PROC param) is ELSIF_EMPTY;
const ELSIF_PROC: elsif FALSE then (in proc param) is ELSIF_EMPTY;
const ELSIF_PROC: elsif FALSE then (in proc param) (in ELSIF_RESULT param) is ELSIF_EMPTY;
*)
(* WHILE + REPEAT *)
const proc: while (in func boolean param) do (in proc param) end while is action "PRC_WHILE";
const proc: while (in varfunc boolean param) do (in proc param) end while is action "PRC_WHILE";
const proc: while (ref boolean param) do (in proc param) end while is action "PRC_WHILE";
const proc: repeat (in proc param) until (in func boolean param) is action "PRC_REPEAT";
const proc: repeat (in proc param) until (in varfunc boolean param) is action "PRC_REPEAT";
const proc: repeat (in proc param) until (ref boolean param) is action "PRC_REPEAT";
const proc: global (in proc param) end global is action "DCL_GLOBAL";
(* integer *)
const integer: (attr integer) . value is 0;
const func integer: + (in integer param) is action "INT_PLUS";
const func integer: - (in integer param) is action "INT_MINUS";
const func integer: ! (in integer param) is action "INT_FACT";
const proc: (inout integer param) := (in integer param) is action "INT_CPY";
const proc: (inout integer param) +:= (in integer param) is action "INT_GROW";
const proc: (inout integer param) -:= (in integer param) is action "INT_SHRINK";
const proc: (inout integer param) *:= (in integer param) is action "INT_MULT_ASSIGN";
const proc: (inout integer param) <<:= (in integer param) is action "INT_LSHIFT_ASSIGN";
const proc: (inout integer param) >>:= (in integer param) is action "INT_RSHIFT_ASSIGN";
const func integer: (in integer param) + (in integer param) is action "INT_ADD";
const func integer: (in integer param) - (in integer param) is action "INT_SBTR";
const func integer: (in integer param) * (in integer param) is action "INT_MULT";
const func integer: (in integer param) div (in integer param) is action "INT_DIV";
const func integer: (in integer param) rem (in integer param) is action "INT_REM";
const func integer: (in integer param) mdiv (in integer param) is action "INT_MDIV";
const func integer: (in integer param) mod (in integer param) is action "INT_MOD";
const func integer: (in integer param) ** (in integer param) is action "INT_POW";
const func integer: (in integer param) << (in integer param) is action "INT_LSHIFT";
const func integer: (in integer param) >> (in integer param) is action "INT_RSHIFT";
const func integer: (in integer param) ! (in integer param) is action "INT_BINOM";
const func boolean: (in integer param) = (in integer param) is action "INT_EQ";
const func boolean: (in integer param) < (in integer param) is action "INT_LT";
const func boolean: (in integer param) > (in integer param) is action "INT_GT";
const func boolean: (in integer param) <= (in integer param) is action "INT_LE";
const func boolean: (in integer param) >= (in integer param) is action "INT_GE";
const func boolean: (in integer param) <> (in integer param) is action "INT_NE";
const func integer: compare (in integer param, in integer param) is action "INT_CMP";
const func integer: hashCode (in integer param) is action "INT_HASHCODE";
const func integer: succ (in integer param) is action "INT_SUCC";
const func integer: pred (in integer param) is action "INT_PRED";
const func integer: abs (in integer param) is action "INT_ABS";
const func integer: sqrt (in integer param) is action "INT_SQRT";
const func integer: log2 (in integer param) is action "INT_LOG2";
const func boolean: odd (in integer param) is action "INT_ODD";
const func integer: ord (in integer param) is action "INT_ORD";
const func integer: (attr integer) conv (in integer param) is action "INT_CONV";
const func string: str (in integer param) is action "INT_STR";
const func string: literal (in integer param) is action "INT_STR";
const func string: str (in integer param, in integer param) is action "INT_STR_BASED";
const func string: (in integer param) lpad0 (in integer param) is action "INT_LPAD0";
const proc: incr (inout integer param) is action "INT_INCR";
const proc: decr (inout integer param) is action "INT_DECR";
const func integer: rand (in integer param, in integer param) is action "INT_RAND";
const func integer: bitLength (in integer param) is action "INT_BIT_LENGTH";
const func integer: lowestSetBit (in integer param) is action "INT_LOWEST_SET_BIT";
const func integer: (attr integer) parse (in string param) is action "INT_PARSE";
const func boolean: rand (in boolean: low, in boolean: high) is
return odd(rand(ord(low), ord(high)));
const func integer: compare (in boolean: aBoolean1, in boolean: aBoolean2) is
return compare(ord(aBoolean1), ord(aBoolean2));
(* char *)
const char: (attr char) . value is ' ';
const char: (attr char) . first is '\0\';
const char: (attr char) . last is '\512\';
const proc: (inout char param) := (in char param) is action "CHR_CPY";
const func boolean: (in char param) = (in char param) is action "CHR_EQ";
const func boolean: (in char param) < (in char param) is action "CHR_LT";
const func boolean: (in char param) > (in char param) is action "CHR_GT";
const func boolean: (in char param) <= (in char param) is action "CHR_LE";
const func boolean: (in char param) >= (in char param) is action "CHR_GE";
const func boolean: (in char param) <> (in char param) is action "CHR_NE";
const func integer: compare (in char param, in char param) is action "CHR_CMP";
const func integer: hashCode (in char param) is action "CHR_HASHCODE";
const func integer: ord (in char param) is action "CHR_ORD";
const func char: (attr char) conv (in integer param) is action "CHR_ICONV";
const varfunc char: (attr char) varConv (inout integer param) is action "TYP_VARCONV";
const func char: chr (in integer param) is action "CHR_CHR";
const func char: succ (in char param) is action "CHR_SUCC";
const func char: pred (in char param) is action "CHR_PRED";
const func string: str (in char param) is action "CHR_STR";
const func char: lower (in char param) is action "CHR_LOW";
const func char: upper (in char param) is action "CHR_UP";
const proc: incr (inout char param) is action "CHR_INCR";
const proc: decr (inout char param) is action "CHR_DECR";
const func char: rand (in char: low, in char: high) is
return chr(rand(ord(low), ord(high)));
(* Procedures literal and c_literal defined after string *)
(* Procedure read defined after operations for IN and OUT *)
(* string *)
const string: (attr string) . value is "";
const func string: (in string param) mult (in integer param) is action "STR_MULT";
const proc: (inout string param) := (in string param) is action "STR_CPY";
const proc: (inout string param) &:= (in string param) is action "STR_APPEND";
const proc: (inout string param) &:= (in char param) is action "STR_PUSH";
const proc: (inout string param) @:= [ (in integer param) ] (in char param) is action "STR_ELEMCPY";
const func string: (in string param) lpad (in integer param) is action "STR_LPAD";
const func string: (in string param) lpad0 (in integer param) is action "STR_LPAD0";
const func string: (in string param) rpad (in integer param) is action "STR_RPAD";
const func string: (in string param) <& (in string param) is action "STR_CAT";
const func char: (in string param) [ (in integer param) ] is action "STR_IDX";
const func string: (in string param) [ (in integer param) .. ] is action "STR_TAIL";
const func string: (in string param) [ .. (in integer param) ] is action "STR_HEAD";
const func string: (in string param) [ (in integer param) ..
(in integer param) ] is action "STR_RANGE";
const func string: (in string param) [ (in integer param) len
(in integer param) ] is action "STR_SUBSTR";
const func boolean: (in string param) = (in string param) is action "STR_EQ";
const func boolean: (in string param) < (in string param) is action "STR_LT";
const func boolean: (in string param) > (in string param) is action "STR_GT";
const func boolean: (in string param) <= (in string param) is action "STR_LE";
const func boolean: (in string param) >= (in string param) is action "STR_GE";
const func boolean: (in string param) <> (in string param) is action "STR_NE";
const func integer: compare (in string param, in string param) is action "STR_CMP";
const func integer: hashCode (in string param) is action "STR_HASHCODE";
const func integer: length (in string param) is action "STR_LNG";
const func integer: pos (in string param, in string param) is action "STR_POS";
const func integer: pos (in string param, in char param) is action "STR_CHPOS";
const func integer: pos (in string param, in string param,
in integer param) is action "STR_IPOS";
const func integer: pos (in string param, in char param,
in integer param) is action "STR_CHIPOS";
const func integer: rpos (in string param, in string param) is action "STR_RPOS";
const func integer: rpos (in string param, in char param) is action "STR_RCHPOS";
(* const proc: count (in string param, in string param) is action "STR_CNT"; *)
const func string: replace (in string param, in string param, in string param) is action "STR_REPL";
const func string: upper (in string param) is action "STR_UP";
const func string: lower (in string param) is action "STR_LOW";
const func string: trim (in string param) is action "STR_TRIM";
const func string: striToUtf8 (in string param) is action "STR_TOUTF8";
const func string: utf8ToStri (in string param) is action "STR_UTF8TOSTRI";
const func string: str (in string param) is action "STR_STR";
const func string: literal (in string param) is action "STR_LIT";
const func string: c_literal (in string param) is action "STR_CLIT";
const func string: replace2 (in string: main_stri, in string: search1,
in string: search2, in string: repl_stri) is func
result
var string: result is "";
local
var integer: start_pos is 0;
var integer: end_pos is 0;
begin
result := main_stri;
start_pos := pos(result, search1);
while start_pos <> 0 do
end_pos := pos(result, search2, start_pos + length(search1));
if end_pos <> 0 then
end_pos +:= length(search2);
result := result[ .. pred(start_pos)] &
repl_stri & result[end_pos .. ];
end_pos := start_pos + length(repl_stri);
start_pos := pos(result, search1, end_pos);
else
start_pos := 0;
end if;
end while;
end func;
const func boolean: startsWith (in string: stri, in string: prefix) is
return stri[.. length(prefix)] = prefix;
const func boolean: startsWith (in string: stri, in string: prefix, in integer: index) is
return stri[index len length(prefix)] = prefix;
const func boolean: endsWith (in string: stri, in string: suffix) is
return stri[succ(length(stri) - length(suffix)) ..] = suffix;
const func string: getint (inout string: stri) is func
result
var string: result is "";
local
var integer: leng is 0;
var integer: pos is 1;
begin
leng := length(stri);
while pos <= leng and stri[pos] >= '0' and stri[pos] <= '9' do
incr(pos);
end while;
result := stri[.. pred(pos)];
stri := stri[pos ..];
end func;
const func string: gets (inout string: stri, in integer: leng) is func
result
var string: result is "";
begin
result := stri[.. leng];
stri := stri[succ(leng) ..];
end func;
const func string: (attr string) parse (in string: stri) is func
result
var string: result is "";
begin
result := stri;
end func;
const func char: (attr char) parse (in string: stri) is func
result
var char: result is ' ';
begin
if length(stri) >= 1 then
result := stri[1];
else
raise RANGE_ERROR;
end if;
end func;
const func boolean: (attr boolean) parse (in string: stri) is func
result
var boolean: result is FALSE;
begin
if stri = "TRUE" then
result := TRUE;
elsif stri = "FALSE" then
result := FALSE;
else
raise RANGE_ERROR;
end if;
end func;
const func string: str (in boolean: aBool) is func
result
var string: result is "";
begin
if aBool then
result := "TRUE";
else
result := "FALSE";
end if;
end func;
(* Procedures literal and c_literal from char *)
const func string: literal (in char: ch) is func
result
var string: result is "";
begin
if ch = ''' then
result := "'\\''";
elsif ch <= chr(255) then
result := literal(str(ch));
result := "'" & result[2 .. length(result) - 1] & "'";
else
result := "'\\" & str(ord(ch)) & "\\'";
end if;
end func;
const func string: c_literal (in char: ch) is func
result
var string: result is "";
begin
if ch = ''' then
result := "'\\''";
elsif ch <= chr(127) then
result := c_literal(str(ch));
result := "'" & result[2 .. length(result) - 1] & "'";
else
result := str(ord(ch));
(*
result := "'\\" &
str(ord(ch) div 64) &
str(ord(ch) div 8 mod 8) &
str(ord(ch) mod 8) & "'";
*)
end if;
end func;
(* REFERENCE *)
const type: reference is subtype object;
IN_PARAM_IS_VALUE(reference);
const proc: (ref reference param) ::= (in reference param) is action "REF_CREATE";
const proc: destroy (ref reference param) is noop;
const proc: (inout reference param) := (in reference param) is action "REF_CPY";
(* Deactivated since it allows 'reference' := anything which is aggainst type checking *)
(* const proc: (inout reference param) := (in object param) is action "REF_MKREF"; *)
const func boolean: (in reference param) = (in reference param) is action "REF_EQ";
const func boolean: (in reference param) <> (in reference param) is action "REF_NE";
const func integer: compare (in reference param, in reference param) is action "REF_CMP";
const func integer: hashCode (in reference param) is action "REF_HASHCODE";
const func string: str (ref reference param) is action "REF_STR";
const func reference: _GENERATE_NIL is action "REF_NIL";
const reference: NIL is _GENERATE_NIL;
const reference: (attr reference) . value is NIL;
const func type: getType (in reference param) is action "REF_TYPE";
const proc: setType (in reference param, in type param) is action "REF_SETTYPE";
const func boolean: is_symb (in reference param) is action "REF_ISSYMB";
const func f_param: symb (in reference param) is action "REF_SYMB";
const func type: getValue (in reference param, attr type) is action "TYP_VALUE";
const func reference: getfunc (in expr param) is action "DCL_GETFUNC";
const func reference: getobj (in expr param) is action "DCL_GETOBJ";
const proc: TRACE_REF (in reference param) is action "REF_TRACE";
const func type: get_type (in reference: type_ref) is func
result
var type: result is void;
begin
if type_ref <> NIL and getType(type_ref) = type then
result := getValue(type_ref, type);
end if;
end func;
(* REF_LIST *)
const type: ref_list is subtype object;
IN_PARAM_IS_REFERENCE(ref_list);
const proc: (ref ref_list param) ::= (in ref_list param) is action "RFL_CREATE";
const proc: destroy (ref ref_list param) is action "RFL_DESTR";
const proc: (inout ref_list param) := (in ref_list param) is action "RFL_CPY";
const proc: (inout ref_list param) &:= (in ref_list param) is action "RFL_APPEND";
const proc: (inout ref_list param) @:= [ (in integer param) ] (in reference param) is action "RFL_ELEMCPY";
const func ref_list: _GENERATE_EMPTY_REFLIST is action "RFL_EMPTY";
const ref_list: (attr ref_list) . EMPTY is _GENERATE_EMPTY_REFLIST;
const ref_list: (attr ref_list) . value is ref_list.EMPTY;
const func ref_list: make_list (in reference param) is action "RFL_MKLIST";
const func boolean: (in ref_list param) = (in ref_list param) is action "RFL_EQ";
const func boolean: (in ref_list param) <> (in ref_list param) is action "RFL_NE";
const func reference: (in ref_list param) [ (in integer param) ] is action "RFL_IDX";
const func ref_list: (in ref_list param) [ (in integer param) .. ] is action "RFL_TAIL";
const func ref_list: (in ref_list param) [ .. (in integer param) ] is action "RFL_HEAD";
const func ref_list: (in ref_list param) [ (in integer param) ..
(in integer param) ] is action "RFL_RANGE";
const func ref_list: (in ref_list param) & (in ref_list param) is action "RFL_CAT";
const func boolean: (in reference param) in (in ref_list param) is action "RFL_ELEM";
const func boolean: (in reference param) not in (in ref_list param) is action "RFL_NOT_ELEM";
const func integer: pos (in ref_list param, in reference param) is action "RFL_POS";
const func integer: pos (in ref_list param, in reference param,
in integer param) is action "RFL_IPOS";
const proc: incl (in ref_list param, in reference param) is action "RFL_INCL";
const proc: excl (in ref_list param, in reference param) is action "RFL_EXCL";
const func integer: length (in ref_list param) is action "RFL_LNG";
const proc: TRACE_LIST (in ref_list param) is action "RFL_TRACE";
const proc: for (inout reference param) range (ref ref_list param) do (ref proc param) end for is action "RFL_FOR";
(* POINTER *)
var type: CURR_STRUCT_PTR is void;
var type: FORWARD_PTR is void;
const func boolean: is_declared (in type param) is action "TYP_ISDECLARED";
const func boolean: is_forward (in type param) is action "TYP_ISFORWARD";
const func type: forward_ptr (ref expr: baseTypeName) is func
result
var type: ptrType is void;
begin
PRINT("forward_ptr\n");
(*
TRACE(baseTypeName);
*)
const type: baseTypeName is forward;
ptrType := newtype;
FORWARD_PTR := ptrType;
IN_PARAM_IS_VALUE(ptrType);
const proc: (ref ptrType param) ::= (in ptrType param) is action "REF_CREATE";
const proc: destroy (ref ptrType param) is noop;
const proc: (inout ptrType param) := (in ptrType param) is action "REF_CPY";
const func boolean: (in ptrType param) = (in ptrType param) is action "REF_EQ";
const func boolean: (in ptrType param) <> (in ptrType param) is action "REF_NE";
const func ptrType: (attr ptrType) conv (in reference param) is action "REF_CONV";
const func reference: (attr reference) conv (in ptrType param) is action "REF_CONV";
const ptrType: (attr ptrType) . NIL is ptrType conv NIL;
const ptrType: (attr ptrType) . value is ptrType.NIL;
end func;
const proc: finish_ptr (in type: baseType, in type: ptrType) is func
begin
if FORWARD_PTR <> void then
PRINT("finish_ptr\n");
FORWARD_PTR := void;
const type: ptr (attr baseType) is ptrType;
const type: base_type (attr ptrType) is baseType;
const func ptrType: & (in baseType param) is action "REF_ADDR";
const func baseType: (in ptrType param) ^ is action "REF_DEREF";
end if;
end func;
const func type: ptr (in type: baseType) is func
result
var type: ptrType is void;
begin
if FORWARD_PTR <> void then
if is_declared(baseType) then
PRINT("declared\n");
elsif is_forward(baseType) then
PRINT("forward\n");
else
PRINT("undeclared\n");
end if;
ptrType := FORWARD_PTR;
finish_ptr(baseType, ptrType);
else
if is_declared(baseType) then
PRINT("declared\n");
ptrType := CURR_STRUCT_PTR;
elsif is_forward(baseType) then
PRINT("forward\n");
else
ptrType := get_type(getobj(ptr (attr baseType)));
end if;
end if;
if ptrType = void then
global
ptrType := newtype;
IN_PARAM_IS_VALUE(ptrType);
const type: ptr (attr baseType) is ptrType;
const type: base_type (attr ptrType) is baseType;
const proc: (ref ptrType param) ::= (in ptrType param) is action "REF_CREATE";
const proc: destroy (ref ptrType param) is noop;
const proc: (inout ptrType param) := (in ptrType param) is action "REF_CPY";
const func boolean: (in ptrType param) = (in ptrType param) is action "REF_EQ";
const func boolean: (in ptrType param) <> (in ptrType param) is action "REF_NE";
const func ptrType: & (in baseType param) is action "REF_ADDR";
const func baseType: (in ptrType param) ^ is action "REF_DEREF";
const func ptrType: (attr ptrType) conv (in reference param) is action "REF_CONV";
const func reference: (attr reference) conv (in ptrType param) is action "REF_CONV";
const ptrType: (attr ptrType) . NIL is ptrType conv NIL;
const ptrType: (attr ptrType) . value is ptrType.NIL;
end global;
end if;
end func;
const func type: varptr (in type: baseType) is func
result
var type: varptrType is void;
begin
varptrType := get_type(getobj(varptr (attr baseType)));
if varptrType = void then
global
varptrType := newtype;
IN_PARAM_IS_VALUE(varptrType);
const type: varptr (attr baseType) is varptrType;
const type: base_type (attr varptrType) is baseType;
const proc: (ref varptrType param) ::= (in varptrType param) is action "REF_CREATE";
const proc: destroy (ref varptrType param) is noop;
const proc: (inout varptrType param) := (in varptrType param) is action "REF_CPY";
const func boolean: (in varptrType param) = (in varptrType param) is action "REF_EQ";
const func boolean: (in varptrType param) <> (in varptrType param) is action "REF_NE";
const func varptrType: & (inout baseType param) is action "REF_ADDR";
const varfunc baseType: (in varptrType param) ^ is action "REF_DEREF";
const func varptrType: (attr varptrType) conv (in reference param) is action "REF_CONV";
const func reference: (attr reference) conv (in varptrType param) is action "REF_CONV";
const varptrType: (attr varptrType) . NIL is varptrType conv NIL;
const varptrType: (attr varptrType) . value is varptrType.NIL;
end global;
end if;
end func;
(* FOR *)
const proc: for (inout integer param) range (in integer param) to (in integer param) do
(in proc param)
end for is action "PRC_FOR_TO";
const proc: for (inout integer param) range (in integer param) downto (in integer param) do
(in proc param)
end for is action "PRC_FOR_DOWNTO";
const proc: FOR_STEP_DECLS (in type: aType) is func
begin
if getobj((inout aType param) +:= (in integer param)) <> NIL then
const proc: for (inout aType: variable) range (in aType: lower_limit) to (in aType: upper_limit)
step (in integer: incr_step) do
(in proc: statements) end for is func
begin
variable := lower_limit;
while variable <= upper_limit do
statements;
variable +:= incr_step;
end while;
end func;
end if;
if getobj((inout aType param) -:= (in integer param)) <> NIL then
const proc: for (inout aType: variable) range (in aType: upper_limit) downto (in aType: lower_limit)
step (in integer: decr_step) do
(in proc: statements) end for is func
begin
variable := upper_limit;
while variable >= lower_limit do
statements;
variable -:= decr_step;
end while;
end func;
end if;
end func;
const proc: FOR_DECLS (in type: aType) is func
begin
const proc: for (inout aType: variable) range (in aType: lower_limit) to (in aType: upper_limit) do
(in proc: statements) end for is func
begin
variable := lower_limit;
if variable <= upper_limit then
statements;
while variable < upper_limit do
incr(variable);
statements;
end while;
end if;
end func;
const proc: for (inout aType: variable) range (in aType: upper_limit) downto (in aType: lower_limit) do
(in proc: statements) end for is func
begin
variable := upper_limit;
if variable >= lower_limit then
statements;
while variable > lower_limit do
decr(variable);
statements;
end while;
end if;
end func;
FOR_STEP_DECLS(aType);
end func;
FOR_STEP_DECLS(integer);
FOR_DECLS(char);
FOR_DECLS(boolean);
const proc: for (inout char: variable) range (in string: stri) do
(in proc: statements)
end for is func
local
var integer: number is 0;
begin
for number range 1 to length(stri) do
variable := stri[number];
statements;
end for;
end func;
(* STRUCT *)
const type: STRUCT is newtype;
IN_PARAM_IS_REFERENCE(STRUCT);
const proc: (ref STRUCT param) ::= (in STRUCT param) is action "SCT_CREATE";
const proc: destroy (ref STRUCT param) is action "SCT_DESTR";
const proc: (inout STRUCT param) := (in STRUCT param) is action "SCT_CPY";
const func integer: length (in STRUCT param) is action "SCT_LNG";
(* const func STRUCT: elem (in type param) : (in expr param) is (in expr param) is action "SCT_ELEM"; *)
const func STRUCT: (in STRUCT param) & (in STRUCT param) is action "SCT_CAT";
const proc: incl (inout STRUCT param, in reference param) is action "SCT_INCL";
const func STRUCT: empty (attr STRUCT) is action "SCT_EMPTY";
(* const func reference: (in STRUCT param) [ (in integer param) ] is action "SCT_REFIDX"; *)
const func ref_list: declare_elements (ref proc param) is action "DCL_ELEMENTS";
(*
const proc: (attr integer) <- ( (in integer param) ) is noop;
integer<-(1);
*)
const func type: new struct (ref proc: elem_decl) end struct is func
result
var type: structType is void;
local
var type: ptrType is void;
var type: varptrType is void;
var ref_list: elem_list is ref_list.EMPTY;
var STRUCT: struct_value is empty(STRUCT);
var integer: number is 0;
var reference: elem_obj is NIL;
begin
structType := newtype;
IN_PARAM_IS_REFERENCE(structType);
ptrType := ptr structType;
CURR_STRUCT_PTR := ptrType;
varptrType := varptr structType;
elem_list := declare_elements(elem_decl);
const proc: (ref structType param) ::= (in structType param) is action "SCT_CREATE";
const proc: destroy (ref structType param) is action "SCT_DESTR";
const proc: (inout structType param) := (in structType param) is action "SCT_CPY";
const func ptrType: alloc (in structType param) is action "SCT_ALLOC";
const func varptrType: varalloc (in structType param) is action "SCT_ALLOC";
const func structType: (attr structType) conv (in STRUCT param) is action "SCT_CONV";
const func STRUCT: (attr STRUCT) conv (in structType param) is action "SCT_CONV";
for number range 1 to length(elem_list) do
elem_obj := elem_list[number];
if is_symb(elem_obj) then
(* TRACE(elem_obj); PRINT("\n"); *)
incl(struct_value, elem_obj);
const func getType(elem_obj): (in structType param) . (symb elem_obj) is action "SCT_SELECT";
const varfunc getType(elem_obj): (inout structType param) . (symb elem_obj) is action "SCT_SELECT";
const func getType(elem_obj): (in ptrType param) -> (symb elem_obj) is action "REF_SELECT";
const varfunc getType(elem_obj): (in varptrType param) -> (symb elem_obj) is action "REF_SELECT";
end if;
end for;
const structType: (attr structType) . value is structType conv struct_value;
end func;
const func type: new struct end struct is func
result
var type: structType is void;
local
var type: ptrType is void;
var type: varptrType is void;
begin
structType := newtype;
IN_PARAM_IS_REFERENCE(structType);
ptrType := ptr structType;
varptrType := varptr structType;
const proc: (ref structType param) ::= (in structType param) is action "SCT_CREATE";
const proc: destroy (ref structType param) is action "SCT_DESTR";
const proc: (inout structType param) := (in structType param) is action "SCT_CPY";
const func ptrType: alloc (in structType param) is action "SCT_ALLOC";
const func varptrType: varalloc (in structType param) is action "SCT_ALLOC";
const func structType: (attr structType) conv (in STRUCT param) is action "SCT_CONV";
const func STRUCT: (attr STRUCT) conv (in structType param) is action "SCT_CONV";
const structType: (attr structType) . value is structType conv empty(STRUCT);
end func;
const func type: new (in type: baseType) struct (ref proc: elem_decl) end struct is func
result
var type: structType is void;
local
var type: ptrType is void;
var type: varptrType is void;
var ref_list: elem_list is ref_list.EMPTY;
var STRUCT: struct_value is empty(STRUCT);
var integer: number is 0;
var reference: elem_obj is NIL;
begin
structType := subtype baseType;
IN_PARAM_IS_REFERENCE(structType);
ptrType := ptr structType;
varptrType := varptr structType;
elem_list := declare_elements(elem_decl);
const proc: (ref structType param) ::= (in structType param) is action "SCT_CREATE";
const proc: destroy (ref structType param) is action "SCT_DESTR";
const proc: (inout structType param) := (in structType param) is action "SCT_CPY";
const func ptrType: alloc (in structType param) is action "SCT_ALLOC";
const func varptrType: varalloc (in structType param) is action "SCT_ALLOC";
const func structType: (attr structType) conv (in STRUCT param) is action "SCT_CONV";
const func STRUCT: (attr STRUCT) conv (in structType param) is action "SCT_CONV";
for number range 1 to length(elem_list) do
elem_obj := elem_list[number];
if is_symb(elem_obj) then
incl(struct_value, elem_obj);
const func getType(elem_obj): (in structType param) . (symb elem_obj) is action "SCT_SELECT";
const varfunc getType(elem_obj): (inout structType param) . (symb elem_obj) is action "SCT_SELECT";
const func getType(elem_obj): (in ptrType param) -> (symb elem_obj) is action "REF_SELECT";
const varfunc getType(elem_obj): (in varptrType param) -> (symb elem_obj) is action "REF_SELECT";
end if;
end for;
const structType: (attr structType) . value is structType conv struct_value;
end func;
const func type: new (in type: baseType) struct end struct is func
result
var type: structType is void;
local
var type: ptrType is void;
var type: varptrType is void;
begin
structType := subtype baseType;
IN_PARAM_IS_REFERENCE(structType);
ptrType := ptr structType;
varptrType := varptr structType;
const proc: (ref structType param) ::= (in structType param) is action "SCT_CREATE";
const proc: destroy (ref structType param) is action "SCT_DESTR";
const proc: (inout structType param) := (in structType param) is action "SCT_CPY";
const func ptrType: alloc (in structType param) is action "SCT_ALLOC";
const func varptrType: varalloc (in structType param) is action "SCT_ALLOC";
const func structType: (attr structType) conv (in STRUCT param) is action "SCT_CONV";
const func STRUCT: (attr STRUCT) conv (in structType param) is action "SCT_CONV";
const structType: (attr structType) . value is structType conv empty(STRUCT);
end func;
const func type: sub (in type: baseType) struct (ref proc: elem_decl) end struct is func
result
var type: structType is void;
local
var type: ptrType is void;
var type: varptrType is void;
var ref_list: elem_list is ref_list.EMPTY;
var STRUCT: struct_value is empty(STRUCT);
var integer: number is 0;
var reference: elem_obj is NIL;
begin
structType := subtype baseType;
IN_PARAM_IS_REFERENCE(structType);
ptrType := ptr structType;
varptrType := varptr structType;
elem_list := declare_elements(elem_decl);
const proc: (ref structType param) ::= (in structType param) is action "SCT_CREATE";
const proc: destroy (ref structType param) is action "SCT_DESTR";
const proc: (inout structType param) := (in structType param) is action "SCT_CPY";
const func ptrType: alloc (in structType param) is action "SCT_ALLOC";
const func varptrType: varalloc (in structType param) is action "SCT_ALLOC";
const func structType: (attr structType) conv (in STRUCT param) is action "SCT_CONV";
const func STRUCT: (attr STRUCT) conv (in structType param) is action "SCT_CONV";
for number range 1 to length(elem_list) do
elem_obj := elem_list[number];
if is_symb(elem_obj) then
incl(struct_value, elem_obj);
const func getType(elem_obj): (in structType param) . (symb elem_obj) is action "SCT_SELECT";
const varfunc getType(elem_obj): (inout structType param) . (symb elem_obj) is action "SCT_SELECT";
const func getType(elem_obj): (in ptrType param) -> (symb elem_obj) is action "REF_SELECT";
const varfunc getType(elem_obj): (in varptrType param) -> (symb elem_obj) is action "REF_SELECT";
end if;
end for;
const structType: (attr structType) . value is structType conv (STRUCT conv (baseType.value) & struct_value);
end func;
const func type: sub (in type: baseType) struct end struct is func
result
var type: structType is void;
local
var type: ptrType is void;
var type: varptrType is void;
begin
structType := subtype baseType;
IN_PARAM_IS_REFERENCE(structType);
ptrType := ptr structType;
varptrType := varptr structType;
const proc: (ref structType param) ::= (in structType param) is action "SCT_CREATE";
const proc: destroy (ref structType param) is action "SCT_DESTR";
const proc: (inout structType param) := (in structType param) is action "SCT_CPY";
const func ptrType: alloc (in structType param) is action "SCT_ALLOC";
const func varptrType: varalloc (in structType param) is action "SCT_ALLOC";
const func structType: (attr structType) conv (in STRUCT param) is action "SCT_CONV";
const func STRUCT: (attr STRUCT) conv (in structType param) is action "SCT_CONV";
const structType: (attr structType) . value is structType conv (STRUCT conv (baseType.value));
end func;
(* SUBRANGE *)
const proc: SUBRANGE_TYPES (in type: baseType) is func
begin
const func type: subrange (in baseType: first) .. (in baseType: last) is func
result
var type: subrangeType is void;
begin
global
subrangeType := subtype baseType;
IN_PARAM_IS_REFERENCE(subrangeType);
const subrangeType: (attr subrangeType) . first is first;
const subrangeType: (attr subrangeType) . last is last;
if baseType.value >= first and baseType.value <= last then
const subrangeType: (attr subrangeType) . value is baseType.value;
else
const subrangeType: (attr subrangeType) . value is first;
end if;
if baseType <> integer then
const func subrangeType: (attr subrangeType) conv (in baseType: enum) is action "ENU_CONV";
end if;
const func subrangeType: (attr subrangeType) conv (in integer: number) is
return subrangeType conv baseType conv number;
end global;
end func;
end func;
SUBRANGE_TYPES(integer);
SUBRANGE_TYPES(char);
SUBRANGE_TYPES(boolean);
(* TUPLE *)
const func type: tuple (in type: baseType) is func
result
var type: tupleType is void;
begin
tupleType := get_type(getfunc(tuple (attr baseType)));
if tupleType = void then
global
tupleType := newtype;
IN_PARAM_IS_REFERENCE(tupleType);
const type: tuple (attr baseType) is tupleType;
const proc: (ref tupleType param) ::= (in tupleType param) is action "ARR_CREATE";
const proc: destroy (ref tupleType param) is action "ARR_DESTR";
const func tupleType: (in baseType param) , (in baseType param) is action "ARR_GEN";
const func tupleType: (in tupleType param) , (in baseType param) is action "ARR_EXTEND";
(*
const func tupleType: (in baseType: lower_limit) .. (in baseType: upper_limit) is func
result
var tupleType: result is
local
var baseType: element is baseType.value;
begin
element := lower_limit;
if variable <= upper_limit then
result &:= element;
while element < upper_limit then
result &:= element;
incr(element);
end while;
end if;
end func;
*)
end global;
end if;
end func;
const type: TST_1 is tuple integer;
const type: TST_2 is tuple integer;
const type: ARRAY_IDX_RANGE is new struct
var integer: minIdx is 1;
var integer: maxIdx is 0;
end struct;
const func ARRAY_IDX_RANGE: [ (in integer: minIdx) .. (in integer: maxIdx) ] is func
result
var ARRAY_IDX_RANGE: result is ARRAY_IDX_RANGE.value;
begin
result.minIdx := minIdx;
result.maxIdx := maxIdx;
end func;
(* ARRAY *)
const func type: array (in type: baseType) is func
result
var type: arrayType is void;
local
var type: tupleType is void;
begin
arrayType := get_type(getfunc(array (attr baseType)));
if arrayType = void then
global
arrayType := newtype;
IN_PARAM_IS_REFERENCE(arrayType);
tupleType := tuple(baseType);
const type: array (attr baseType) is arrayType;
const type: base_type (attr arrayType) is baseType;
const proc: (ref arrayType param) ::= (in arrayType param) is action "ARR_CREATE";
const proc: destroy (ref arrayType param) is action "ARR_DESTR";
const proc: (inout arrayType param) := (in arrayType param) is action "ARR_CPY";
const proc: (inout arrayType param) &:= (in arrayType param) is action "ARR_APPEND";
const func arrayType: [] (in tupleType param) is action "ARR_ARRLIT";
const func arrayType: [] (in baseType param) is action "ARR_BASELIT";
const func arrayType: [ (in integer param) ] (in tupleType param) is action "ARR_ARRLIT2";
const func arrayType: [ (in integer param) ] (in baseType param) is action "ARR_BASELIT2";
const func arrayType: (in arrayType param) & (in arrayType param) is action "ARR_CAT";
const func baseType: (in arrayType param) [ (in integer param) ] is action "ARR_IDX";
const varfunc baseType: (inout arrayType param) [ (in integer param) ] is action "ARR_IDX";
const func arrayType: (in arrayType param) [ (in integer param) .. ] is action "ARR_TAIL";
const func arrayType: (in arrayType param) [ .. (in integer param) ] is action "ARR_HEAD";
const func arrayType: (in arrayType param) [ (in integer param) ..
(in integer param) ] is action "ARR_RANGE";
const func baseType: remove (inout arrayType param, in integer param) is action "ARR_REMOVE";
const func integer: length (in arrayType param) is action "ARR_LNG";
const func integer: minIdx (in arrayType param) is action "ARR_MINIDX";
const func integer: maxIdx (in arrayType param) is action "ARR_MAXIDX";
const func arrayType: (in integer param) times (in baseType param) is action "ARR_TIMES";
const func arrayType: (attr arrayType) . _GENERATE_EMPTY_ARRAY is action "ARR_EMPTY";
const arrayType: (attr arrayType) . value is arrayType._GENERATE_EMPTY_ARRAY;
const func tupleType: (attr tupleType) conv (in arrayType param) is action "ARR_CONV";
const func arrayType: (in ARRAY_IDX_RANGE: arrayIdxRange) times
(in baseType: base_value) is func
result
var arrayType: result is arrayType.value;
begin
result := succ(arrayIdxRange.maxIdx - arrayIdxRange.minIdx) times base_value;
result := [arrayIdxRange.minIdx] (tupleType conv result);
end func;
const proc: for (inout baseType: variable) range (in arrayType: arr) do
(in proc: statements)
end for is func
local
var integer: number is 0;
begin
for number range minIdx(arr) to maxIdx(arr) do
variable := arr[number];
statements;
end for;
end func;
const proc: for key (inout integer: keyVar) range (in arrayType: arr) do
(in proc: statements)
end for is func
begin
for keyVar range minIdx(arr) to maxIdx(arr) do
statements;
end for;
end func;
const func baseType: rand (in arrayType: arr) is
baseType return arr[rand(minIdx(arr), maxIdx(arr))];
const proc: insert (inout arrayType: arr, in integer: index, in baseType: element) is func
begin
if index >= minIdx(arr) and index <= succ(maxIdx(arr)) then
arr := arr[.. pred(index)] & [] (element) & arr[index ..];
else
raise RANGE_ERROR;
end if;
end func;
if getobj((in baseType param) = (in baseType param)) <> NIL and
getobj((in baseType param) <> (in baseType param)) <> NIL then
const func boolean: (in arrayType: arr1) = (in arrayType: arr2) is func
result
var boolean: isEqual is FALSE;
local
var integer: number is 1;
begin
if minIdx(arr1) = minIdx(arr2) and maxIdx(arr1) = maxIdx(arr2) then
isEqual := TRUE;
number := minIdx(arr1);
while number <= maxIdx(arr1) and isEqual do
isEqual := arr1[number] = arr2[number];
incr(number);
end while;
end if;
end func;
const func boolean: (in arrayType: arr1) <> (in arrayType: arr2) is func
result
var boolean: isNotEqual is TRUE;
local
var integer: number is 1;
begin
if minIdx(arr1) = minIdx(arr2) and maxIdx(arr1) = maxIdx(arr2) then
isNotEqual := FALSE;
number := minIdx(arr1);
while number <= maxIdx(arr1) and not isNotEqual do
isNotEqual := arr1[number] <> arr2[number];
incr(number);
end while;
end if;
end func;
end if;
if getobj((in baseType param) < (in baseType param)) <> NIL and
getobj((in baseType param) > (in baseType param)) <> NIL then
const proc: insert (inout arrayType: arr, in baseType: element) is func
local
var integer: number is 1;
begin
number := minIdx(arr);
while number <= maxIdx(arr) and arr[number] < element do
incr(number);
end while;
if number > maxIdx(arr) then
arr := arr & [] (element);
elsif arr[number] > element then
arr := arr[.. pred(number)] & [] (element) & arr[number ..];
end if;
end func;
end if;
if getobj(compare(in baseType param, in baseType param)) <> NIL then
const reference: (attr arrayType) . dataCompare is getobj(compare(in baseType param, in baseType param));
const func arrayType: SORT (in arrayType param, in reference param) is action "ARR_SORT";
const func arrayType: sort (in arrayType: arr_obj) is
return SORT(arr_obj, arrayType.dataCompare);
end if;
end global;
end if;
end func;
const type: TEST_1 is array integer;
const type: TEST_2 is array integer;
const type: TEST_3 is array string;
(*
const type: TEST_4 is array char;
const type: TEST_5 is array boolean;
const type: TEST_6 is array array char;
const type: TEST_7 is array array string;
*)
const func type: array [ (in type: indexType) ] (in type: baseType) is func
result
var type: arrayType is void;
local
var type: stdArrayType is void;
var type: tupleType is void;
begin
arrayType := get_type(getfunc(array [ (attr indexType) ] (attr baseType)));
if arrayType = void then
global
arrayType := newtype;
IN_PARAM_IS_REFERENCE(arrayType);
stdArrayType := array baseType;
tupleType := tuple(baseType);
const type: array [ (attr indexType) ] (attr baseType) is arrayType;
const type: base_type (attr arrayType) is baseType;
const proc: (ref arrayType param) ::= (in arrayType param) is action "ARR_CREATE";
const proc: destroy (ref arrayType param) is action "ARR_DESTR";
const proc: (inout arrayType param) := (in arrayType param) is action "ARR_CPY";
const proc: (inout arrayType param) &:= (in arrayType param) is action "ARR_APPEND";
const func arrayType: (in arrayType param) & (in arrayType param) is action "ARR_CAT";
const func integer: length (in arrayType param) is action "ARR_LNG";
const func integer: minIntIdx (in arrayType param) is action "ARR_MINIDX";
const func integer: maxIntIdx (in arrayType param) is action "ARR_MAXIDX";
const func stdArrayType: (attr stdArrayType) conv (in arrayType param) is action "ARR_CONV";
const func arrayType: (attr arrayType) conv (in stdArrayType param) is action "ARR_CONV";
const func tupleType: (attr tupleType) conv (in arrayType param) is action "ARR_CONV";
const varfunc stdArrayType: (attr stdArrayType) conv (inout arrayType param) is action "TYP_VARCONV";
const func arrayType: (attr arrayType) . _GENERATE_EMPTY_ARRAY is action "ARR_EMPTY";
const arrayType: (attr arrayType) . value is arrayType._GENERATE_EMPTY_ARRAY;
const func arrayType: [ (attr indexType) ] (in tupleType: arr_tuple) is
return arrayType conv ([ord(indexType.value)] arr_tuple);
const func arrayType: [ (attr indexType) ] (in baseType: base_elem) is
return arrayType conv ([ord(indexType.value)] base_elem);
const func baseType: (in arrayType: an_array) [ (in indexType: an_index) ] is
baseType return stdArrayType conv an_array[ord(an_index)];
const varfunc baseType: (inout arrayType: an_array) [ (in indexType: an_index) ] is
baseType return var stdArrayType conv an_array[ord(an_index)];
const func arrayType: (in arrayType: an_array) [ (in indexType: an_index) .. ] is
return arrayType conv (stdArrayType conv an_array[ord(an_index) .. ]);
const func arrayType: (in arrayType: an_array) [ .. (in indexType: an_index) ] is
return arrayType conv (stdArrayType conv an_array[ .. ord(an_index)]);
const func arrayType: (in arrayType: an_array) [ (in indexType: index1) .. (in indexType: index2) ] is
return arrayType conv (stdArrayType conv an_array[ord(index1) .. ord(index2)]);
const func indexType: minIdx (in arrayType: arr) is
return indexType conv minIntIdx(arr);
const func indexType: maxIdx (in arrayType: arr) is
return indexType conv maxIntIdx(arr);
const proc: for (inout baseType: variable) range (in arrayType: arr) do
(in proc: statements) end for is func
local
var integer: number is 0;
begin
for number range minIntIdx(arr) to maxIntIdx(arr) do
variable := stdArrayType conv arr[number];
statements;
end for;
end func;
const proc: for key (inout indexType: keyVar) range (in arrayType: arr) do
(in proc: statements)
end for is func
begin
for keyVar range minIdx(arr) to maxIdx(arr) do
statements;
end for;
end func;
if getobj((attr indexType) . first) <> NIL and
getobj((attr indexType) . last) <> NIL then
const func arrayType: (attr indexType) times (in baseType: base_value) is func
result
var arrayType: result is arrayType.value;
begin
result := arrayType conv (succ(ord(indexType.last) - ord(indexType.first)) times base_value);
result := arrayType conv ([ord(indexType.first)] (tupleType conv result));
end func;
end if;
(*
PRINT(str(arrayType));
PRINT(" = array [");
PRINT(str(indexType));
PRINT("] ");
PRINT(str(baseType));
PRINT("\n");
*)
end global;
end if;
end func;
(*
const type: test_x is array [char] string;
const type: test_y is array [char] string;
const type: test_z is array [integer] string;
*)
const proc: ENABLE_SORT (in type: arrayType) is func
begin
const reference: (attr arrayType) . dataCompare is getobj(compare(in base_type(arrayType) param, in base_type(arrayType) param));
const func arrayType: SORT (in arrayType param, in reference param) is action "ARR_SORT";
const func arrayType: sort (in arrayType: arr_obj) is
return SORT(arr_obj, arrayType.dataCompare);
end func;
(* Functions with arrays of strings *)
const func array string: split (in string param, in char param) is action "STR_CHSPLIT";
const func array string: split (in string param, in string param) is action "STR_SPLIT";
const func string: join (in array string: striArray, in char: delimiter) is func
result
var string: result is "";
local
var integer: pos is 0;
begin
result := striArray[minIdx(striArray)];
for pos range succ(minIdx(striArray)) to maxIdx(striArray) do
result &:= str(delimiter);
result &:= striArray[pos];
end for;
end func;
const func string: join (in array string: striArray, in string: delimiter) is func
result
var string: result is "";
local
var integer: pos is 0;
begin
result := striArray[minIdx(striArray)];
for pos range succ(minIdx(striArray)) to maxIdx(striArray) do
result &:= delimiter;
result &:= striArray[pos];
end for;
end func;
const func boolean: isDigitString (in string: stri) is func
result
var boolean: result is TRUE;
local
var char: ch is ' ';
begin
result := stri <> "";
for ch range stri do
if ch < '0' or ch > '9' then
result := FALSE;
end if;
end for;
end func;
const func boolean: isDigitString (in string: stri, in integer: base) is func
result
var boolean: result is TRUE;
local
var char: ch is ' ';
begin
result := stri <> "";
if base <= 10 then
for ch range stri do
if ch < '0' or ch >= chr(base) then
result := FALSE;
end if;
end for;
else
for ch range stri do
if (ch < '0' or ch > '9') and
(ch < 'a' or ch >= chr(ord('a') + base - 10)) and
(ch < 'A' or ch >= chr(ord('A') + base - 10)) then
result := FALSE;
end if;
end for;
end if;
end func;
(* LIST
const func type: list (in type: baseType) is func
result
var type: LST is void;
local
var type: tupleType is void;
begin
LST := get_type(getobj(list (attr baseType)));
if LST = void then
global
LST := newtype;
IN_PARAM_IS_REFERENCE(LST);
tupleType := tuple(baseType);
const type: list (attr baseType) is LST;
const type: base_type (attr LST) is baseType;
const proc: (ref LST param) ::= (in LST param) is action "LST_CREATE";
const proc: destroy (ref LST param) is action "LST_DESTR";
const proc: (inout LST param) := (in LST param) is action "LST_CPY";
const proc: (inout LST param) &:= (in LST param) is action "LST_APPEND";
const func LST: [] (in tupleType param) is action "LST_LSTLIT";
const func LST: [] (in baseType param) is action "LST_BASELIT";
const func LST: [ (in integer param) ] (in tupleType param) is action "LST_LSTLIT2";
const func LST: [ (in integer param) ] (in baseType param) is action "LST_BASELIT2";
const func LST: (in LST param) & (in LST param) is action "LST_CAT";
const func baseType: (in LST param) [ (in integer param) ] is action "LST_IDX";
const varfunc baseType: (inout LST param) [ (in integer param) ] is action "LST_IDX";
const func LST: (in LST param) [ (in integer param) .. ] is action "LST_TAIL";
const func LST: (in LST param) [ .. (in integer param) ] is action "LST_HEAD";
const func LST: (in LST param) [ (in integer param) ..
(in integer param) ] is action "LST_RANGE";
const func integer: length (in LST param) is action "LST_LNG";
const func LST: (in integer param) times (in baseType param) is action "LST_TIMES";
const LST: (attr LST) . value is 0 times baseType.value;
end global;
end if;
end func;
*)
(* HASH *)
const func type: hash [ (in type: keyType) ] (in type: baseType) is func
result
var type: hashType is void;
begin
hashType := get_type(getfunc(hash [ (attr keyType) ] (attr baseType)));
if hashType = void then
global
hashType := newtype;
IN_PARAM_IS_REFERENCE(hashType);
const type: hash [ (attr keyType) ] (attr baseType) is hashType;
const type: key_type (attr hashType) is keyType;
const type: base_type (attr hashType) is baseType;
const reference: (attr hashType) . keyCreate is getfunc((ref keyType param) ::= (in keyType param));
const reference: (attr hashType) . keyDestroy is getfunc(destroy(ref keyType param));
const reference: (attr hashType) . keyCopy is getfunc((inout keyType param) := (in keyType param));
const reference: (attr hashType) . keyCompare is getfunc(compare(in keyType param, in keyType param));
const reference: (attr hashType) . dataCreate is getfunc((ref baseType param) ::= (in baseType param));
const reference: (attr hashType) . dataDestroy is getfunc(destroy(ref baseType param));
const reference: (attr hashType) . dataCopy is getfunc((inout baseType param) := (in baseType param));
const proc: CREATE (ref hashType param, in hashType param,
in reference param, in reference param,
in reference param, in reference param) is action "HSH_CREATE";
const proc: DESTROY (ref hashType param, in reference param,
in reference param) is action "HSH_DESTR";
const proc: COPY (inout hashType param, in hashType param,
in reference param, in reference param,
in reference param, in reference param) is action "HSH_CPY";
const proc: FOR_DATA (inout baseType param, in hashType param,
in proc param, in reference param) is action "HSH_FOR";
const proc: FOR_KEY (inout keyType param, in hashType param,
in proc param, in reference param) is action "HSH_FOR_KEY";
const proc: FOR_DATA_KEY (inout baseType param, inout keyType param,
in hashType param, in proc param,
in reference param, in reference param) is action "HSH_FOR_DATA_KEY";
const func array keyType: KEYS (in hashType param, in reference param,
in reference param) is action "HSH_KEYS";
const func array baseType: VALUES (in hashType param, in reference param,
in reference param) is action "HSH_VALUES";
const proc: (ref hashType: dest) ::= (in hashType: source) is func
begin
CREATE(dest, source, hashType.keyCreate, hashType.keyDestroy,
hashType.dataCreate, hashType.dataDestroy);
end func;
const proc: destroy (ref hashType: oldHash) is func
begin
DESTROY(oldHash, hashType.keyDestroy, hashType.dataDestroy);
end func;
const proc: (inout hashType: dest) := (in hashType: source) is func
begin
COPY(dest, source, hashType.keyCreate, hashType.keyDestroy,
hashType.dataCreate, hashType.dataDestroy);
end func;
const func integer: length (in hashType param) is action "HSH_LNG";
const func baseType: INDEX (in hashType param, in keyType param,
in integer param, in reference param) is action "HSH_IDX";
const varfunc baseType: INDEX (inout hashType param, in keyType param,
in integer param, in reference param) is action "HSH_IDX";
const func baseType: INDEX2 (in hashType param, in keyType param,
in baseType param, in integer param,
in reference param, in reference param,
in reference param) is action "HSH_IDX2";
const varfunc baseType: INDEX2 (inout hashType param, in keyType param,
in baseType param, in integer param,
in reference param, in reference param,
in reference param) is action "HSH_IDX2";
const func ptr baseType: REFINDEX (in hashType param, in keyType param,
in integer param, in reference param) is action "HSH_REFIDX";
const proc: INCL (inout hashType param, in keyType param,
in baseType param, in integer param,
in reference param, in reference param,
in reference param, in reference param) is action "HSH_INCL";
const proc: EXCL (inout hashType param, in keyType param,
in integer param, in reference param,
in reference param, in reference param) is action "HSH_EXCL";
(*
const func ptr baseType: @ (in hashType param) [ (in string param) ] is action "HSH_REFIDX";
const func varptr baseType: @ (inout hashType param) [ (in string param) ] is action "HSH_REFIDX";
const varfunc baseType: table (inout hashType param, in baseType param) is action "HSH_NEW";
const func baseType: free (inout hashType param, in baseType param) is action "HSH_FREE";
*)
const func boolean: CONTAINS (in hashType param, in keyType param,
in integer param, in reference param) is action "HSH_CONTAINS";
(*
const func hashType: (attr hashType) conv (in hashType param) is action "HSH_CONV";
const varfunc hashType: (attr hashType) conv (inout hashType param) is action "TYP_VARCONV";
*)
const func hashType: (attr hashType) . _GENERATE_EMPTY_HASH is action "HSH_EMPTY";
const hashType: (attr hashType) . EMPTY_HASH is hashType._GENERATE_EMPTY_HASH;
const hashType: (attr hashType) . value is hashType._GENERATE_EMPTY_HASH;
const func baseType: (in hashType: aHash) [ (in keyType: aKey) ] is
return INDEX(aHash, aKey, hashCode(aKey), hashType.keyCompare);
const varfunc baseType: (inout hashType: aHash) [ (in keyType: aKey) ] is
return var INDEX(aHash, aKey, hashCode(aKey), hashType.keyCompare);
const func boolean: (in keyType: aKey) in (in hashType: aHash) is
return CONTAINS(aHash, aKey, hashCode(aKey), hashType.keyCompare);
const func boolean: (in keyType: aKey) not in (in hashType: aHash) is
return not CONTAINS(aHash, aKey, hashCode(aKey), hashType.keyCompare);
const proc: incl (inout hashType: aHash, in keyType: aKey, in baseType: anElem) is func
begin
INCL(aHash, aKey, anElem, hashCode(aKey), hashType.keyCompare,
hashType.keyCreate, hashType.dataCreate, hashType.dataCopy);
end func;
const proc: excl (inout hashType: aHash, in keyType: aKey) is func
begin
EXCL(aHash, aKey, hashCode(aKey), hashType.keyCompare,
hashType.keyDestroy, hashType.dataDestroy);
end func;
const proc: (inout hashType: aHash) @:= [ (in keyType: aKey) ] (in baseType: anElem) is func
begin
INCL(aHash, aKey, anElem, hashCode(aKey), hashType.keyCompare,
hashType.keyCreate, hashType.dataCreate, hashType.dataCopy);
end func;
(*
const proc: clear (inout hashType: aHash) is func
local
var baseType: anElem is baseType.value;
begin
for anElem range source do
excl(dest, anElem);
end for;
end func;
*)
const proc: for (inout baseType: forVar) range (in hashType: aHash) do
(in proc: statements)
end for is func
begin
FOR_DATA(forVar, aHash, statements, hashType.dataCopy);
end func;
const proc: for key (inout keyType: keyVar) range (in hashType: aHash) do
(in proc: statements)
end for is func
begin
FOR_KEY(keyVar, aHash, statements, hashType.keyCopy);
end func;
const proc: for (inout baseType: forVar) key (inout keyType: keyVar) range (in hashType: aHash) do
(in proc: statements)
end for is func
begin
FOR_DATA_KEY(forVar, keyVar, aHash, statements, hashType.dataCopy, hashType.keyCopy);
end func;
const func array keyType: keys (in hashType: aHash) is
return KEYS(aHash, hashType.keyCreate, hashType.keyDestroy);
const func array baseType: values (in hashType: aHash) is
return VALUES(aHash, hashType.dataCreate, hashType.dataDestroy);
if getfunc(hashCode(in baseType param)) <> NIL and
getfunc(compare(in baseType param, in baseType param)) <> NIL then
const func hash [baseType] array keyType: flip (in hashType: aHash) is func
result
var hash [baseType] array keyType: result is (hash [baseType] array keyType).value;
local
var keyType: aKey is keyType.value;
var baseType: aValue is baseType.value;
begin
for aValue key aKey range aHash do
if aValue in result then
result[aValue] &:= [] (aKey);
else
result @:= [aValue] [] (aKey);
end if;
end for;
end func;
end if;
end global;
end if;
end func;
(*
const type: TEST_100 is hash [string] integer;
const type: TEST_101 is hash [integer] string;
const type: TEST_102 is hash [char] boolean;
const type: TEST_103 is hash [string] reference;
const type: TEST_104 is hash [string] hash [integer] reference;
const type: TEST_105 is hash [string] array integer;
ignore(flip(TEST_101.value));
*)
(*
var TEST_100: TEST_HASH is TEST_100.EMPTY_HASH;
incl(TEST_HASH, "asdf", 25);
incl(TEST_HASH, "gold", 1000);
PRINT(str(TEST_HASH["asdf"]));
PRINT(str(TEST_HASH["gold"]));
PRINT(str(TEST_HASH["silver"]));
var TEST_100: TEST_HASH2 is TEST_HASH;
excl(TEST_HASH, "gold");
PRINT(str(TEST_HASH["gold"]));
PRINT(str(TEST_HASH2["gold"]));
*)
(* SET *)
const type: bitset is subtype object;
IN_PARAM_IS_REFERENCE(bitset);
const proc: (ref bitset param) ::= (in bitset param) is action "SET_CREATE";
const proc: destroy (ref bitset param) is action "SET_DESTR";
const proc: (inout bitset param) := (in bitset param) is action "SET_CPY";
const func bitset: (in bitset param) | (in bitset param) is action "SET_UNION";
const func bitset: (in bitset param) >< (in bitset param) is action "SET_SYMDIFF";
const func bitset: (in bitset param) & (in bitset param) is action "SET_INTERSECT";
const func bitset: (in bitset param) - (in bitset param) is action "SET_DIFF";
const func boolean: (in bitset param) = (in bitset param) is action "SET_EQ";
const func boolean: (in bitset param) < (in bitset param) is action "SET_LT";
const func boolean: (in bitset param) > (in bitset param) is action "SET_GT";
const func boolean: (in bitset param) <= (in bitset param) is action "SET_LE";
const func boolean: (in bitset param) >= (in bitset param) is action "SET_GE";
const func boolean: (in bitset param) <> (in bitset param) is action "SET_NE";
const func integer: compare (in bitset param, in bitset param) is action "SET_CMP";
const func integer: hashCode (in bitset param) is action "SET_HASHCODE";
const func boolean: (in integer param) in (in bitset param) is action "SET_ELEM";
const func boolean: (in integer param) not in (in bitset param) is action "SET_NOT_ELEM";
const proc: incl (inout bitset param, in integer param) is action "SET_INCL";
const proc: excl (inout bitset param, in integer param) is action "SET_EXCL";
const func integer: card (in bitset param) is action "SET_CARD";
const func integer: rand (in bitset param) is action "SET_RAND";
const func integer: min (in bitset param) is action "SET_MIN";
const func integer: max (in bitset param) is action "SET_MAX";
const func bitset: { (in integer param) } is action "SET_BASELIT";
const func bitset: { (in tuple integer param) } is action "SET_ARRLIT";
const func integer: (attr integer) conv (in bitset param) is action "SET_SCONV";
const func bitset: (attr bitset) conv (in integer param) is action "SET_ICONV";
const func bitset: _GENERATE_EMPTY_SET is action "SET_EMPTY";
const bitset: EMPTY_SET is _GENERATE_EMPTY_SET;
const bitset: (attr bitset) . EMPTY_SET is EMPTY_SET;
const bitset: (attr bitset) . value is EMPTY_SET;
(*
const func bitset: { (in tuple integer: value) } is func
result
var bitset: result is EMPTY_SET;
local
var integer: number is 0;
begin
for number range 1 to length([] value) do
incl(result, ([] value)[number]);
end for;
end func;
*)
const func bitset: { (in integer: lower_value) .. (in integer: upper_value) } is func
result
var bitset: result is EMPTY_SET;
local
var integer: value is 0;
begin
for value range lower_value to upper_value do
incl(result, value);
end for;
end func;
const proc: for (inout integer: variable) range (in bitset: aSet) do
(in proc: statements)
end for is func
begin
if card(aSet) > 0 then
for variable range min(aSet) to max(aSet) do
if variable in aSet then
statements;
end if;
end for;
end if;
end func;
const func string: str (in bitset: aSet) is func
result
var string: result is "{";
local
var integer: setElement is 0;
begin
for setElement range aSet do
if result <> "{" then
result &:= ", ";
end if;
result &:= str(setElement);
end for;
result &:= "}";
end func;
const func bitset: (attr bitset) parse (in var string: stri) is func
result
var bitset: result is EMPTY_SET;
begin
if stri[1] = '{' then
repeat
repeat
stri := stri[2 ..];
until stri[1] <> ' ';
if stri[1] >= '0' and stri[1] <= '9' then
incl(result, integer parse getint(stri));
elsif stri[1] <> '}' then
raise RANGE_ERROR;
end if;
until stri[1] <> ',';
if stri <> "}" then
raise RANGE_ERROR;
end if;
else
raise RANGE_ERROR;
end if;
end func;
const type: set of (attr integer) is bitset;
const func type: BITSET_OF (in type: baseType) is func
result
var type: setType is void;
local
var type: tupleType is void;
var type: array_type is void;
begin
setType := get_type(getfunc(BITSET_OF(attr baseType)));
if setType = void then
global
setType := newtype;
IN_PARAM_IS_REFERENCE(setType);
const type: BITSET_OF (attr baseType) is setType;
const type: base_type (attr setType) is baseType;
const proc: (ref setType param) ::= (in setType param) is action "SET_CREATE";
const proc: destroy (ref setType param) is action "SET_DESTR";
const proc: (inout setType param) := (in setType param) is action "SET_CPY";
const func setType: (in setType param) | (in setType param) is action "SET_UNION";
const func setType: (in setType param) >< (in setType param) is action "SET_SYMDIFF";
const func setType: (in setType param) & (in setType param) is action "SET_INTERSECT";
const func setType: (in setType param) - (in setType param) is action "SET_DIFF";
const func boolean: (in setType param) = (in setType param) is action "SET_EQ";
const func boolean: (in setType param) < (in setType param) is action "SET_LT";
const func boolean: (in setType param) > (in setType param) is action "SET_GT";
const func boolean: (in setType param) <= (in setType param) is action "SET_LE";
const func boolean: (in setType param) >= (in setType param) is action "SET_GE";
const func boolean: (in setType param) <> (in setType param) is action "SET_NE";
const func integer: compare (in setType param, in setType param) is action "SET_CMP";
const func integer: hashCode (in setType param) is action "SET_HASHCODE";
const func integer: card (in setType param) is action "SET_CARD";
const func bitset: (attr bitset) conv (in setType param) is action "SET_CONV";
const varfunc bitset: (attr bitset) varConv (inout setType param) is action "TYP_VARCONV";
const func setType: (attr setType) conv (in bitset param) is action "SET_CONV";
const setType: (attr setType) . EMPTY_SET is setType conv EMPTY_SET;
const setType: (attr setType) . value is setType conv EMPTY_SET;
const func boolean: (in baseType: aValue) in (in setType: aSet) is
return ord(aValue) in bitset conv aSet;
const func boolean: (in baseType: aValue) not in (in setType: aSet) is
return ord(aValue) not in bitset conv aSet;
const proc: incl (inout setType: aSet, in baseType: aValue) is func
begin
incl(bitset varConv aSet, ord(aValue));
end func;
const proc: excl (inout setType: aSet, in baseType: aValue) is func
begin
excl(bitset varConv aSet, ord(aValue));
end func;
const func baseType: rand (in setType: aSet) is
return baseType conv rand(bitset conv aSet);
const func baseType: min (in setType: aSet) is
return baseType conv min(bitset conv aSet);
const func baseType: max (in setType: aSet) is
return baseType conv max(bitset conv aSet);
const func setType: { (in baseType: value) } is
return setType conv ( { ord(value) } );
tupleType := tuple baseType;
array_type := array baseType;
const func setType: { (in tupleType: value) } is func
result
var setType: result is setType.EMPTY_SET;
local
var integer: number is 0;
begin
for number range 1 to length([] value) do
incl(result, ([] value)[number]);
end for;
end func;
const func setType: { (in baseType: lower_value) .. (in baseType: upper_value) } is func
result
var setType: result is setType.EMPTY_SET;
local
var baseType: value is baseType.value;
begin
for value range lower_value to upper_value do
incl(result, value);
end for;
end func;
const proc: for (inout baseType: variable) range (in setType: aSet) do
(in proc: statements)
end for is func
begin
if card(aSet) > 0 then
for variable range min(aSet) to max(aSet) do
if variable in aSet then
statements;
end if;
end for;
end if;
end func;
if getobj(str(ref baseType param)) <> NIL then
const func string: str (in setType: aSet) is func
result
var string: result is "{";
local
var baseType: setElement is baseType.value;
begin
for setElement range aSet do
if result <> "{" then
result &:= ", ";
end if;
result &:= str(setElement);
end for;
result &:= "}";
end func;
end if;
end global;
end if;
end func;
const func type: HASHSET_OF (in type: baseType) is func
result
var type: setType is void;
local
var type: tupleType is void;
var type: array_type is void;
begin
setType := get_type(getfunc(HASHSET_OF(attr baseType)));
if setType = void then
global
setType := newtype;
IN_PARAM_IS_REFERENCE(setType);
const type: HASHSET_OF (attr baseType) is setType;
const type: base_type (attr setType) is baseType;
const reference: (attr setType) . keyCreate is getfunc((ref baseType param) ::= (in baseType param));
const reference: (attr setType) . keyDestroy is getfunc(destroy(ref baseType param));
const reference: (attr setType) . keyCopy is getfunc((inout baseType param) := (in baseType param));
const reference: (attr setType) . keyCompare is getfunc(compare(in baseType param, in baseType param));
const reference: (attr setType) . dataCreate is getfunc((ref boolean param) ::= (in boolean param));
const reference: (attr setType) . dataDestroy is getfunc(destroy(ref boolean param));
const reference: (attr setType) . dataCopy is getfunc((inout boolean param) := (in boolean param));
const proc: CREATE (ref setType param, in setType param,
in reference param, in reference param,
in reference param, in reference param) is action "HSH_CREATE";
const proc: DESTROY (ref setType param, in reference param,
in reference param) is action "HSH_DESTR";
const proc: COPY (inout setType param, in setType param,
in reference param, in reference param,
in reference param, in reference param) is action "HSH_CPY";
const proc: FOR_KEY (inout baseType param, in setType param,
in proc param, in reference param) is action "HSH_FOR_KEY";
const proc: (ref setType: dest) ::= (in setType: source) is func
begin
CREATE(dest, source, setType.keyCreate, setType.keyDestroy,
setType.dataCreate, setType.dataDestroy);
end func;
const proc: destroy (ref setType: oldSet) is func
begin
DESTROY(oldSet, setType.keyDestroy, setType.dataDestroy);
end func;
const proc: (inout setType: dest) := (in setType: source) is func
begin
COPY(dest, source, setType.keyCreate, setType.keyDestroy,
setType.dataCreate, setType.dataDestroy);
end func;
const func integer: card (in setType param) is action "HSH_LNG";
const func setType: (attr setType) . _GENERATE_EMPTY_SET is action "HSH_EMPTY";
const setType: (attr setType) . EMPTY_SET is setType._GENERATE_EMPTY_SET;
const setType: (attr setType) . value is setType._GENERATE_EMPTY_SET;
const proc: INCL (inout setType param, in baseType param,
in boolean param, in integer param,
in reference param, in reference param,
in reference param, in reference param) is action "HSH_INCL";
const proc: EXCL (inout setType param, in baseType param,
in integer param, in reference param,
in reference param, in reference param) is action "HSH_EXCL";
const func boolean: CONTAINS (in setType param, in baseType param,
in integer param, in reference param) is action "HSH_CONTAINS";
const func boolean: (in baseType: aValue) in (in setType: aSet) is
return CONTAINS(aSet, aValue, hashCode(aValue), setType.keyCompare);
const func boolean: (in baseType: aValue) not in (in setType: aSet) is
return not CONTAINS(aSet, aValue, hashCode(aValue), setType.keyCompare);
const proc: incl (inout setType: aSet, in baseType: aValue) is func
begin
INCL(aSet, aValue, TRUE, hashCode(aValue), setType.keyCompare,
setType.keyCreate, setType.dataCreate, setType.dataCopy);
end func;
const proc: excl (inout setType: aSet, in baseType: aValue) is func
begin
EXCL(aSet, aValue, hashCode(aValue), setType.keyCompare,
setType.keyDestroy, setType.dataDestroy);
end func;
const func setType: { (in baseType: value) } is func
result
var setType: result is setType.EMPTY_SET;
local
var integer: number is 0;
begin
incl(result, value);
end func;
const proc: for (inout baseType: variable) range (in setType: aSet) do
(in proc: statements)
end for is func
begin
FOR_KEY(variable, aSet, statements, setType.keyCopy);
end func;
tupleType := tuple baseType;
array_type := array baseType;
const func setType: { (in tupleType: value) } is func
result
var setType: result is setType.EMPTY_SET;
local
var integer: number is 0;
begin
for number range 1 to length([] value) do
incl(result, ([] value)[number]);
end for;
end func;
end global;
end if;
end func;
const func type: set of (in type: baseType) is func
result
var type: setType is void;
begin
setType := get_type(getfunc(set of (attr baseType)));
if setType = void then
if getobj(ord(ref baseType param)) <> NIL then
setType := BITSET_OF(baseType);
else
setType := HASHSET_OF(baseType);
end if;
global
const type: set of (attr baseType) is setType;
end global;
end if;
end func;
const type: TEST_A is set of integer;
const type: TEST_B is set of char;
const type: TEST_C is set of char;
const type: TEST_D is set of boolean;
const type: TEST_E is set of string;
const set of char: alpha is {'A' .. 'Z'} | {'a' .. 'z'};
const set of char: alnum is {'A' .. 'Z'} | {'a' .. 'z'} | {'0' .. '9'};
const set of char: digit is {'0' .. '9'};
const func integer: toInt (in string: stri, in integer: base) is func
result
var integer: result is 0;
local
const array integer: digitval is [] ( # -1 is illegal
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, # 0 - 9
-1, -1, -1, -1, -1, -1, -1, #
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, # A - M
23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, # N - Z
-1, -1, -1, -1, -1, -1,
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, # a - m
23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35); # n - z
var integer: pos is 1;
var integer: digit is 0;
begin
for pos range 1 to length(stri) do
digit := digitval[ord(stri[pos]) - 47];
if digit = -1 then
raise RANGE_ERROR;
end if;
result := result * base + digit;
end for;
end func;
(* INTERFACE *)
const func type: new interface is func
result
var type: interfaceType is void;
begin
interfaceType := newtype;
IN_PARAM_IS_REFERENCE(interfaceType);
const proc: (ref interfaceType param) ::= (ref interfaceType param) is action "ITF_CREATE";
const proc: destroy (ref interfaceType param) is noop;
const proc: (inout interfaceType param) := (ref interfaceType param) is action "ITF_CPY";
const func boolean: (in interfaceType param) = (in interfaceType param) is action "ITF_EQ";
const func boolean: (in interfaceType param) <> (in interfaceType param) is action "ITF_NE";
end func;
const func type: sub (in type: baseType) interface is func
result
var type: interfaceType is void;
begin
interfaceType := subtype baseType;
IN_PARAM_IS_REFERENCE(interfaceType);
const proc: (ref interfaceType param) ::= (ref interfaceType param) is action "ITF_CREATE";
const proc: destroy (ref interfaceType param) is noop;
const proc: (inout interfaceType param) := (ref interfaceType param) is action "ITF_CPY";
const func boolean: (in interfaceType param) = (in interfaceType param) is action "ITF_EQ";
const func boolean: (in interfaceType param) <> (in interfaceType param) is action "ITF_NE";
end func;
(* body *)
(*
const proc: body (ref type: STRU) is (ref expr: DECLS) end body is func
begin
const proc: DECL_BODY (attr STRU) is func
DECLS;
end func;
DECL_BODY(STRU);
end func;
*)
(* CLASS *)
const func type: new class (ref proc: elem_decl) end class is func
result
var type: classType is void;
local
var type: ptrType is void;
var type: varptrType is void;
var ref_list: elem_list is ref_list.EMPTY;
var STRUCT: struct_value is empty(STRUCT);
var integer: number is 0;
var reference: elem_obj is NIL;
begin
classType := newtype;
IN_PARAM_IS_REFERENCE(classType);
ptrType := ptr classType;
CURR_STRUCT_PTR := ptrType;
varptrType := varptr classType;
elem_list := declare_elements(elem_decl);
const func boolean: (ref classType param) = (ref classType param) is action "ENU_EQ";
const func boolean: (ref classType param) <> (ref classType param) is action "ENU_NE";
const proc: (ref classType param) ::= (in classType param) is action "SCT_CREATE";
const proc: destroy (ref classType param) is action "SCT_DESTR";
const proc: (inout classType param) := (in classType param) is action "SCT_CPY";
const func ptrType: alloc (in classType param) is action "SCT_ALLOC";
const func varptrType: varalloc (in classType param) is action "SCT_ALLOC";
const func classType: (attr classType) conv (in STRUCT param) is action "SCT_CONV";
const func STRUCT: (attr STRUCT) conv (in classType param) is action "SCT_CONV";
for number range 1 to length(elem_list) do
elem_obj := elem_list[number];
if is_symb(elem_obj) then
(* TRACE(elem_obj); PRINT("\n"); *)
incl(struct_value, elem_obj);
const func getType(elem_obj): (in classType param) . (symb elem_obj) is action "SCT_SELECT";
const varfunc getType(elem_obj): (inout classType param) . (symb elem_obj) is action "SCT_SELECT";
const func getType(elem_obj): (in ptrType param) -> (symb elem_obj) is action "REF_SELECT";
const varfunc getType(elem_obj): (in varptrType param) -> (symb elem_obj) is action "REF_SELECT";
end if;
end for;
const classType: (attr classType) . value is classType conv struct_value;
end func;
(*
const func type: MAKE_CLASS (ref type: STRU) is func
result
var type: CLS is void;
local
var integer: number is 0;
var reference: elem_obj is NIL;
begin
CLS := newtype;
for number range 1 to length(elem_list) do
elem_obj := elem_list[number];
const func getType(elem_obj): (ref CLS param) . (symb elem_obj) is action "CLS_SELECT";
end for;
const proc: (ref CLS param) ::= (ref CLS param) is action "CLS_CREATE";
const proc: (ref CLS param) ::= (ref STRU param) is action "CLS_CREATE2";
const proc: (inout CLS param) := (ref CLS param) is action "CLS_CPY";
const proc: (inout CLS param) := (ref STRU param) is action "CLS_CPY2";
const proc: (ref CLS param) = (ref CLS param) is action "CLS_EQ";
const proc: (ref CLS param) <> (ref CLS param) is action "CLS_NE";
const func type: (attr CLS) . struct_type is STRU;
end func;
const func type: new class (ref STRUCT: elem_list) end class is func
result
var type: CLS is void;
local
var type: STRU is void;
var integer: number is 0;
var reference: elem_obj is NIL;
begin
CLS := newtype;
STRU := newtype;
const proc: (ref func STRU param) ::= (ref STRUCT param) is action "SCT_CREATE";
const func STRU: (attr STRU) . value is elem_list;
const func STRU: (attr CLS) . value is elem_list;
const func STRUCT: (ref STRU param) & (ref STRUCT param) is action "SCT_CAT";
const proc: (ref STRU param) ::= (ref STRU param) is action "SCT_CREATE";
const proc: (inout STRU param) := (ref STRU param) is action "SCT_CPY";
for number range 1 to length(elem_list) do
elem_obj := elem_list[number];
const func getType(elem_obj): (ref STRU param) . (symb elem_obj) is action "SCT_SELECT";
const func getType(elem_obj): (ref CLS param) . (symb elem_obj) is action "CLS_SELECT";
end for;
const proc: (ref CLS param) ::= (ref CLS param) is action "CLS_CREATE";
const proc: (ref CLS param) ::= (ref STRU param) is action "CLS_CREATE2";
const proc: (inout CLS param) := (ref CLS param) is action "CLS_CPY";
const proc: (inout CLS param) := (ref STRU param) is action "CLS_CPY2";
const proc: (ref CLS param) = (ref CLS param) is action "CLS_EQ";
const proc: (ref CLS param) <> (ref CLS param) is action "CLS_NE";
const func type: (attr CLS) . struct_type is STRU;
end func;
*)
const type: linkedList is new struct
var reference: next is NIL;
end struct;
const proc: type_implements_interface (in type: aType, in type: interfaceType) is func
begin
const proc: (ref interfaceType param) ::= (ref aType param) is action "ITF_CREATE2";
const proc: (inout interfaceType param) := (ref aType param) is action "ITF_CPY2";
const func interfaceType: (attr interfaceType) conv (ref aType param) is action "ITF_CONV2";
const func aType: xalloc (in aType: newStuct) is func
result
var aType: result is aType.value;
begin
result := newStuct;
end func;
addInterface(aType, interfaceType);
end func;
(* LIST
const type: LIST is subtype INDEXABLE;
IN_PARAM_IS_REFERENCE(LIST);
const proc: destroy (ref LIST param) is action "LST_DESTR";
const proc: (ref LIST param) ::= (ref LIST param) is action "LST_CREATE";
const proc: (inout LIST param) := (ref LIST param) is action "LST_CPY";
const func LIST: (ref LIST param) & (ref LIST param) is action "LST_CAT";
const func object: (ref LIST param) [ (ref integer param) ] is action "LST_IDX";
const func LIST: (ref LIST param) [ (ref integer param) .. ] is action "LST_TAIL";
const func LIST: (ref LIST param) [ .. (ref integer param) ] is action "LST_HEAD";
const func integer: length (ref LIST param) is action "LST_LNG";
const func LIST: _GENERATE_EMPTY_LIST is action "LST_EMPTY";
const LIST: (attr LIST) . EMPTY is _GENERATE_EMPTY_LIST;
const LIST: (attr LIST) . value is _GENERATE_EMPTY_LIST;
(* const proc: object in (ref LIST param) is action "LST_ELEM"; *)
const proc: incl(ref LIST param, ref object param) is action "LST_INCL";
const proc: excl(ref LIST param, ref object param) is action "LST_EXCL";
(* const proc: INDEX_EXPR := (ref LIST param) is action "LST_CPY"; *)
const proc: for (inout object: variable) range (ref LIST: obj_list) do
(ref proc: statements) end for is func
local
var integer: number is 0;
begin
for number range 1 to length(obj_list) do
variable := obj_list[number];
statements;
end for;
end func;
const proc: str (ref LIST: aList) is func
result
var string: result is "";
local
var reference: obj is NIL;
var boolean: FIRST_OBJ is TRUE;
begin
result := "{";
for obj range aList do
if FIRST_OBJ then
FIRST_OBJ := FALSE;
else
result := result & ", ";
end if;
result := result & str(obj);
end for;
result := result & "}";
end func;
const proc: literal (ref LIST: aList) is func
result
var string: result is "";
local
var reference: obj is NIL;
var boolean: FIRST_OBJ is TRUE;
begin
result := "{";
for obj range aList do
if FIRST_OBJ then
FIRST_OBJ := FALSE;
else
result := result & ", ";
end if;
result := result & str(obj);
end for;
result := result & "}";
end func;
*)
(* INDEXABLE *)
const func integer: length (ref INDEXABLE param) is DYNAMIC;
const func object: (ref INDEXABLE param) [ (ref integer param) ] is DYNAMIC;
(*
const func boolean: (ref object: obj) in (ref INDEXABLE: AREA1) is func
result
var boolean: result is FALSE;
local
var integer: number is 0;
begin
for number range 1 to length(AREA1) do
if obj = AREA1[number] then
result := TRUE;
end if;
end for;
end func;
const func boolean: (ref INDEXABLE: AREA1) = (ref INDEXABLE: AREA2) is func
result
var boolean: result is TRUE;
local
var integer: leng is 0;
var integer: INDEX is 1;
begin
leng := length(AREA1);
if leng <> length(AREA2) then
result := FALSE;
else
for INDEX range 1 to leng do
if AREA1[INDEX] <> AREA2[INDEX] then
result := FALSE;
end if;
end for;
end if;
end func;
const func boolean: (ref INDEXABLE: AREA1) <> (ref INDEXABLE: AREA2) is func
result
var boolean: result is FALSE;
local
var integer: leng is 0;
var integer: INDEX is 1;
begin
leng := length(AREA1);
if leng <> length(AREA2) then
result := TRUE;
else
for INDEX range 1 to leng do
if AREA1[INDEX] = AREA2[INDEX] then
result := TRUE;
end if;
end for;
end if;
end func;
*)
(* CASE_DECLS *)
const proc: CASE_DECLS (in type: aType) is func
local
var type: WHEN_RESULT is void;
var type: WHEN_PROC is void;
var type: SELECTOR_TYPE is void;
begin
(* PRINT("in CASE_DECLS "); PRINT(str(aType)); PRINT("\n"); *)
WHEN_RESULT := newtype;
WHEN_PROC := (func WHEN_RESULT);
SELECTOR_TYPE := set of aType;
const proc: case (ref aType param) of end case is noop;
const proc: case (ref aType param) of
(ref WHEN_PROC param)
end case is action "PRC_CASE";
const proc: case (ref aType param) of
(ref WHEN_PROC param)
otherwise : (ref proc param)
end case is action "PRC_CASE_DEF";
const proc: (ref WHEN_RESULT param) ::= enumlit is action "ENU_GENLIT";
const WHEN_RESULT: WHEN_EMPTY (attr aType) is enumlit;
const proc: (ref WHEN_PROC param) ::= (ref WHEN_RESULT param) is action "ENU_CREATE";
const WHEN_PROC: when (ref SELECTOR_TYPE param) : (ref proc param) is WHEN_EMPTY(aType);
const WHEN_PROC: when (ref SELECTOR_TYPE param) : (ref proc param)
(ref WHEN_PROC param) is WHEN_EMPTY(aType);
end func;
CASE_DECLS(integer);
CASE_DECLS(char);
CASE_DECLS(boolean);
(* CASE_DECLS(string); *)
const func ref_list: expr_to_list (ref expr: elem_expr) is action "RFL_EXPR";
const proc: TRACE (ref expr param) is action "REF_TRACE";
const func type: new enum (ref expr: elem_expr) end enum is func
result
var type: enumType is void;
local
var ref_list: elem_list is ref_list.EMPTY;
var integer: number is 0;
var reference: elem_obj is NIL;
var ref_list: literal_list is ref_list.EMPTY;
begin
global
enumType := subtype ENUMERATION;
IN_PARAM_IS_REFERENCE(enumType);
elem_list := expr_to_list(elem_expr);
const proc: (ref enumType param) ::= (in enumType param) is action "ENU_CREATE";
const proc: (ref enumType param) ::= enumlit is action "ENU_GENLIT";
const proc: destroy (ref enumType param) is noop;
const proc: (inout enumType param) := (in enumType param) is action "ENU_CPY";
const func boolean: (in enumType param) = (in enumType param) is action "ENU_EQ";
const func boolean: (in enumType param) <> (in enumType param) is action "ENU_NE";
const func enumType: getValue(in reference param, attr enumType) is action "ENU_VALUE";
const func enumType: ICONV2(in integer param, in ref_list param,
attr enumType) is action "ENU_ICONV2";
const func integer: ORD2(in enumType param, in ref_list param) is action "ENU_ORD2";
literal_list := ref_list.EMPTY;
for number range 1 to length(elem_list) do
elem_obj := elem_list[number];
# const integer: ord(symb elem_obj) is pred(number);
const enumType: .(symb elem_obj) is enumlit;
elem_obj := getobj(. (symb elem_obj));
if elem_obj <> NIL and getType(elem_obj) = enumType then
literal_list := literal_list & make_list(elem_obj);
end if;
end for;
const ref_list: (attr enumType) . literal_list is literal_list;
if length(literal_list) >= 1 then
const enumType: (attr enumType) . value is getValue(literal_list[1], enumType);
const enumType: (attr enumType) . first is getValue(literal_list[1], enumType);
const enumType: (attr enumType) . last is getValue(literal_list[length(literal_list)], enumType);
end if;
const func enumType: (attr enumType) conv (in integer: number) is
return ICONV2(number, enumType.literal_list, enumType);
const func integer: ord (in enumType: enum_val) is
return ORD2(enum_val, enumType.literal_list);
const func integer: (attr integer) conv (in enumType: enum_val) is
return ord(enum_val);
const func enumType: succ (ref enumType: enum_val) is
return enumType conv succ(ord(enum_val));
const func enumType: pred (ref enumType: enum_val) is
return enumType conv pred(ord(enum_val));
const proc: incr (inout enumType: enum_val) is func
begin
enum_val := succ(enum_val);
end func;
const proc: decr (inout enumType: enum_val) is func
begin
enum_val := pred(enum_val);
end func;
const func boolean: (in enumType: enum_val1) < (in enumType: enum_val2) is
return ord(enum_val1) < ord(enum_val2);
const func boolean: (in enumType: enum_val1) <= (in enumType: enum_val2) is
return ord(enum_val1) <= ord(enum_val2);
const func boolean: (in enumType: enum_val1) > (in enumType: enum_val2) is
return ord(enum_val1) > ord(enum_val2);
const func boolean: (in enumType: enum_val1) >= (in enumType: enum_val2) is
return ord(enum_val1) >= ord(enum_val2);
FOR_DECLS(enumType);(* Necessary for this is <= < >= > *)
CASE_DECLS(enumType);
SUBRANGE_TYPES(enumType);
end global;
end func;
(* COLOR *)
const type: color is new struct
var integer: red_part is 0;
var integer: green_part is 0;
var integer: blue_part is 0;
end struct;
const func boolean: (in color: col1) = (in color: col2) is
return col1.red_part = col2.red_part and
col1.green_part = col2.green_part and
col1.blue_part = col2.blue_part;
const func boolean: (in color: col1) <> (in color: col2) is
return col1.red_part <> col2.red_part or
col1.green_part <> col2.green_part or
col1.blue_part <> col2.blue_part;
const func color: (in color: col1) + (in color: col2) is func
result
var color: result is color.value;
begin
result.red_part := (col1.red_part + col2.red_part) div 2;
result.green_part := (col1.green_part + col2.green_part) div 2;
result.blue_part := (col1.blue_part + col2.blue_part) div 2;
end func;
const func color: color (in integer: red, in integer: green, in integer: blue) is func
result
var color: result is color.value;
begin
result.red_part := red;
result.green_part := green;
result.blue_part := blue;
end func;
const func color: gray (in integer: brightness) is func
result
var color: result is color.value;
begin
result.red_part := brightness;
result.green_part := brightness;
result.blue_part := brightness;
end func;
const func integer: compare (in color: col1, in color: col2) is func
result
var integer: result is 0;
begin
if col1.red_part < col2.red_part then
result := -1;
elsif col1.red_part > col2.red_part then
result := 1;
elsif col1.green_part < col2.green_part then
result := -1;
elsif col1.green_part > col2.green_part then
result := 1;
elsif col1.blue_part < col2.blue_part then
result := -1;
elsif col1.blue_part > col2.blue_part then
result := 1;
end if;
end func;
const func integer: hashCode (in color: col) is
return col.red_part + col.green_part + col.blue_part;
(* BLOCK *)
const proc: BLOCK_DECLS (in type: unusedType) is func
local
var type: CATCH_RESULT is void;
var type: CATCH_PROC is void;
begin
(* PRINT("in BLOCK_DECLS\n"); *)
CATCH_RESULT := new enum CATCH_EMPTY end enum;
CATCH_PROC := (func CATCH_RESULT);
const proc: block (ref proc param) exception end block is noop;
const proc: block (ref proc param) exception
(ref CATCH_PROC param)
end block is action "PRC_BLOCK";
(*const proc: block (ref proc param) exception
(ref CATCH_PROC param)
otherwise : (ref proc param)
end block is action "PRC_BLOCK_DEF"; *)
const proc: (ref CATCH_PROC param) ::= (ref CATCH_RESULT param) is action "ENU_CREATE";
const CATCH_PROC: catch (ref EXCEPTION param) : (ref proc param) is CATCH_RESULT.value;
const CATCH_PROC: catch (ref EXCEPTION param) : (ref proc param)
(ref CATCH_PROC param) is CATCH_RESULT.value;
end func;
BLOCK_DECLS(void);
(* PRIMITIVE_FILE *)
const type: PRIMITIVE_FILE is newtype;
IN_PARAM_IS_VALUE(PRIMITIVE_FILE);
const proc: (ref PRIMITIVE_FILE param) ::= (ref PRIMITIVE_FILE param) is action "FIL_CREATE";
const proc: destroy (ref PRIMITIVE_FILE param) is noop;
const proc: (inout PRIMITIVE_FILE param) := (ref PRIMITIVE_FILE param) is action "FIL_CPY";
const func boolean: (ref PRIMITIVE_FILE param) = (ref PRIMITIVE_FILE param) is action "FIL_EQ";
const func boolean: (ref PRIMITIVE_FILE param) <> (ref PRIMITIVE_FILE param) is action "FIL_NE";
const func PRIMITIVE_FILE: _GENERATE_EMPTY_PRIMITIVE_FILE is action "FIL_EMPTY";
const PRIMITIVE_FILE: (attr PRIMITIVE_FILE) . value is _GENERATE_EMPTY_PRIMITIVE_FILE;
const PRIMITIVE_FILE: PRIMITIVE_NULL_FILE is PRIMITIVE_FILE.value;
const func PRIMITIVE_FILE: PRIMITIVE_INPUT is action "FIL_IN";
const func PRIMITIVE_FILE: PRIMITIVE_OUTPUT is action "FIL_OUT";
const func PRIMITIVE_FILE: PRIMITIVE_ERROR is action "FIL_ERR";
const integer: IO_FULL_BUFFERING is 0;
const integer: IO_LINE_BUFFERING is 1;
const integer: IO_NO_BUFFERING is 2;
const func PRIMITIVE_FILE: PRIMITIVE_FILE_OPEN (in string param, in string param) is action "FIL_OPEN";
const proc: setbuf (ref PRIMITIVE_FILE param, ref integer param, ref integer param) is action "FIL_SETBUF";
const proc: close (ref PRIMITIVE_FILE param) is action "FIL_CLOSE";
const func boolean: eof (ref PRIMITIVE_FILE param) is action "FIL_EOF";
const func boolean: hasNext (ref PRIMITIVE_FILE param) is action "FIL_HAS_NEXT";
const proc: flush (ref PRIMITIVE_FILE param) is action "FIL_FLUSH";
const func char: getc (ref PRIMITIVE_FILE param) is action "FIL_GETC";
const func string: gets (ref PRIMITIVE_FILE param, ref integer param) is action "FIL_GETS";
const func string: word_read (ref PRIMITIVE_FILE param, inout char param) is action "FIL_WORD_READ";
const func string: line_read (ref PRIMITIVE_FILE param, inout char param) is action "FIL_LINE_READ";
const proc: write (ref PRIMITIVE_FILE param, in string param) is action "FIL_WRITE";
const func integer: length (ref PRIMITIVE_FILE param) is action "FIL_LNG";
const proc: seek (ref PRIMITIVE_FILE param, ref integer param) is action "FIL_SEEK";
const func integer: tell (ref PRIMITIVE_FILE param) is action "FIL_TELL";
const func string: literal (ref PRIMITIVE_FILE param) is action "FIL_LIT";
const char: EOF is chr(-1);
(* Procedures and Elements granted for every file *)
const type: file is sub object interface;
const proc: write (inout file param, in string param) is DYNAMIC;
const proc: writeln (inout file param) is DYNAMIC;
const proc: backSpace (inout file param) is DYNAMIC;
const proc: close (inout file param) is DYNAMIC;
const proc: flush (ref file param) is DYNAMIC;
const func char: getc (inout file param) is DYNAMIC;
const func string: gets (inout file param, in integer param) is DYNAMIC;
const func string: getln (inout file param) is DYNAMIC;
const func string: getwd (inout file param) is DYNAMIC;
const func string: getk (ref file param) is DYNAMIC;
const func boolean: eoln (ref file param) is DYNAMIC;
(**
* Return TRUE if the end-of-file indicator is set, FALSE otherwise.
* The end-of-file indicator is set when at least one request to read
* from the file failed.
* @return the state of the end-of-file indicator.
*)
const func boolean: eof (ref file param) is DYNAMIC;
(**
* Return FALSE if 'getc' would return EOF, TRUE otherwise.
* This function allows a file to be handled like an iterator.
* @return a boolean value indicating if 'getc' would not return EOF.
*)
const func boolean: hasNext (ref file param) is DYNAMIC;
(**
* Return the length of a file.
*)
const func integer: length (ref file param) is DYNAMIC;
const proc: seek (inout file param, in integer param) is DYNAMIC;
const func integer: tell (ref file param) is DYNAMIC;
const func char: (ref file param).bufferChar is DYNAMIC;
const varfunc char: (inout file param).bufferChar is DYNAMIC;
const func boolean: (ref file param).io_empty is DYNAMIC;
const varfunc boolean: (inout file param).io_empty is DYNAMIC;
const func boolean: (ref file param).io_ok is DYNAMIC;
const varfunc boolean: (inout file param).io_ok is DYNAMIC;
const func boolean: io_ok (in file: aFile) is
return aFile.io_ok;
const func boolean: io_error (in file: aFile) is
return not aFile.io_ok;
const func boolean: io_empty (in file: aFile) is
return aFile.io_empty;
const func boolean: io_filled (in file: aFile) is
return not aFile.io_empty;
const proc: readln (inout file: aFile) is func
local
var string: stri is "";
begin
stri := getln(aFile);
aFile.io_empty := stri = "";
aFile.io_ok := TRUE;
end func;
(* null_file *)
const type: null_file is new struct
var char: bufferChar is '\n';
var boolean: io_empty is FALSE;
var boolean: io_ok is TRUE;
end struct;
type_implements_interface(null_file, file);
const func boolean: (ref null_file param) = (ref null_file param) is action "ENU_EQ";
const func boolean: (ref null_file param) <> (ref null_file param) is action "ENU_NE";
var null_file: STD_NULL is null_file.value;
const file: (attr file) . value is STD_NULL;
const proc: write (in null_file param, in string param) is noop;
const string: gets (in null_file param, in integer param) is "";
const func char: getc (inout null_file: aFile) is func
result
var char: ch is ' ';
local
var string: buffer is "";
begin
buffer := gets(aFile, 1);
if buffer = "" then
ch := EOF;
else
ch := buffer[1];
end if;
end func;
const func string: getwd (inout null_file: aFile) is func
result
var string: stri is "";
local
var string: buffer is "";
begin
repeat
buffer := gets(aFile, 1);
until buffer <> " " and buffer <> "\t";
while buffer <> " " and buffer <> "\t" and
buffer <> "\n" and buffer <> "" do
stri &:= buffer;
buffer := gets(aFile, 1);
end while;
if buffer = "" then
aFile.bufferChar := EOF;
else
aFile.bufferChar := buffer[1];
end if;
end func;
const func string: getln (inout null_file: aFile) is func
result
var string: stri is "";
local
var string: buffer is "";
begin
buffer := gets(aFile, 1);
while buffer <> "\n" and buffer <> "" do
stri &:= buffer;
buffer := gets(aFile, 1);
end while;
if buffer = "" then
aFile.bufferChar := EOF;
else
aFile.bufferChar := buffer[1];
end if;
end func;
const proc: writeln (inout null_file: aFile) is func
begin
write(aFile, "\n");
end func;
const boolean: eof (ref null_file param) is TRUE;
const boolean: hasNext (ref null_file param) is FALSE;
const func boolean: eoln (ref null_file: aFile) is
return aFile.bufferChar = '\n';
const integer: length (ref null_file param) is 0;
const proc: seek (ref null_file param, in integer param) is noop;
const integer: tell (ref null_file param) is 1;
const proc: backSpace (ref null_file: aFile) is noop;
const proc: close (ref null_file param) is noop;
const proc: flush (ref null_file param) is noop;
(* Set of operations for external_file *)
const type: external_file is sub null_file struct
var PRIMITIVE_FILE: ext_file is PRIMITIVE_NULL_FILE;
var string: name is "";
end struct;
type_implements_interface(external_file, file);
const func external_file: malloc (ref external_file: ext_file) is func
result
var external_file: result is external_file.value;
begin
result := ext_file;
end func;
const func file: open (in string: file_name, in string: access) is func
result
var file: result is STD_NULL;
local
var PRIMITIVE_FILE: open_file is PRIMITIVE_NULL_FILE;
var external_file: new_file is external_file.value;
begin
open_file := PRIMITIVE_FILE_OPEN(file_name, access);
if open_file <> PRIMITIVE_NULL_FILE then
new_file.ext_file := open_file;
new_file.name := file_name;
result := malloc(new_file);
end if;
end func;
(*
const func external_file: open (in string: file_name, in string: access) is func
result
var external_file: result is external_file.value;
local
var PRIMITIVE_FILE: open_file is PRIMITIVE_NULL_FILE;
begin
open_file := PRIMITIVE_FILE_OPEN(file_name, access);
if open_file <> PRIMITIVE_NULL_FILE then
result := external_file.value;
result.ext_file := open_file;
result.name := file_name;
end if;
end func;
*)
const proc: close (ref external_file: aFile) is func
begin
close(aFile.ext_file);
end func;
const proc: flush (ref external_file: aFile) is func
begin
flush(aFile.ext_file);
end func;
const proc: write (in external_file: aFile, in string: stri) is func
begin
write(aFile.ext_file, stri);
end func;
const proc: writeln (in external_file: aFile) is func
begin
write(aFile.ext_file, "\n");
end func;
const proc: backSpace (ref external_file: aFile) is func
begin
write(aFile.ext_file, "\b \b");
end func;
const func char: getc (in external_file: aFile) is
return getc(aFile.ext_file);
const func string: gets (in external_file: aFile, in integer: leng) is
return gets(aFile.ext_file, leng);
const func string: getwd (inout external_file: aFile) is
return word_read(aFile.ext_file, aFile.bufferChar);
const func string: getln (inout external_file: aFile) is
return line_read(aFile.ext_file, aFile.bufferChar);
const func boolean: eof (ref external_file: aFile) is
return eof(aFile.ext_file);
const func boolean: hasNext (ref external_file: aFile) is
return hasNext(aFile.ext_file);
const func integer: length (ref external_file: aFile) is
return length(aFile.ext_file);
const proc: seek (ref external_file: aFile, in integer: pos) is func
begin
seek(aFile.ext_file, pos);
end func;
const func integer: tell (ref external_file: aFile) is
return tell(aFile.ext_file);
(* System STD_IN, STD_OUT and STD_ERR files *)
const func external_file: INIT_STD_FILE (ref PRIMITIVE_FILE: primitive_file,
in string: file_name) is func
result
var external_file: result is external_file.value;
begin
result.ext_file := primitive_file;
result.name := file_name;
end func;
var external_file: STD_IN is INIT_STD_FILE(PRIMITIVE_INPUT, "STD_IN");
var external_file: STD_OUT is INIT_STD_FILE(PRIMITIVE_OUTPUT, "STD_OUT");
var external_file: STD_ERR is INIT_STD_FILE(PRIMITIVE_ERROR, "STD_ERR");
(* Set of operations for IN and OUT *)
var file: IN is STD_IN;
var file: OUT is STD_OUT;
var file: PROT_OUTFILE is STD_OUT;
const proc: writeln is func
begin
writeln(OUT);
end func;
const proc: write (NL) is func
begin
writeln(OUT);
end func;
const proc: readln is func
local
var string: stri is "";
begin
stri := getln(IN);
IN.io_empty := stri = "";
IN.io_ok := TRUE;
end func;
const proc: read (NL) is func
begin
readln;
end func;
(* io definitions for string *)
const proc: writeln (inout file: aFile, in string: stri) is func
begin
write(aFile, stri);
writeln(aFile);
end func;
const proc: read (inout file: aFile, inout string: stri) is func
begin
stri := getwd(aFile);
aFile.io_empty := stri = "";
aFile.io_ok := TRUE;
end func;
const proc: readln (inout file: aFile, inout string: stri) is func
begin
stri := getln(aFile);
aFile.io_empty := stri = "";
aFile.io_ok := TRUE;
end func;
const proc: write (in string: stri) is func
begin
write(OUT, stri);
end func;
const proc: writeln (in string: stri) is func
begin
write(OUT, stri);
writeln(OUT);
end func;
const proc: read (inout string: stri) is func
begin
read(IN, stri);
end func;
const proc: readln (inout string: stri) is func
begin
readln(IN, stri);
end func;
(* enable_io *)
const proc: enable_input (in type: aType) is func
begin
const proc: read (inout file: aFile, inout aType: aValue) is func
local
var string: stri is "";
begin
stri := getwd(aFile);
aFile.io_empty := stri = "";
block
aValue := aType parse stri;
aFile.io_ok := TRUE;
exception
catch RANGE_ERROR:
aFile.io_ok := FALSE;
end block;
end func;
const proc: readln (inout file: aFile, inout aType: aValue) is func
local
var string: stri is "";
begin
stri := getln(aFile);
aFile.io_empty := stri = "";
block
aValue := aType parse stri;
aFile.io_ok := TRUE;
exception
catch RANGE_ERROR:
aFile.io_ok := FALSE;
end block;
end func;
const proc: read (inout aType: aValue) is func
begin
read(IN, aValue);
end func;
const proc: readln (inout aType: aValue) is func
begin
readln(IN, aValue);
end func;
end func;
const proc: enable_output (in type: aType) is func
begin
const proc: write (inout file: aFile, in aType: aValue) is func
begin
write(aFile, str(aValue));
end func;
const proc: writeln (inout file: aFile, in aType: aValue) is func
begin
write(aFile, str(aValue));
writeln(aFile);
end func;
const proc: write (in aType: aValue) is func
begin
write(OUT, aValue);
end func;
const proc: writeln (in aType: aValue) is func
begin
write(OUT, aValue);
writeln(OUT);
end func;
const func string: (in aType: aValue) lpad (in integer: leng) is
return str(aValue) lpad leng;
const func string: (in aType: aValue) rpad (in integer: leng) is
return str(aValue) rpad leng;
const func string: (in string: stri) <& (in aType: aValue) is
return stri & str(aValue);
const func string: (in aType: aValue) <& (in string: stri) is
return str(aValue) & stri;
end func;
const proc: enable_io (in type: aType) is func
begin
enable_input(aType);
enable_output(aType);
end func;
enable_io(char);
enable_io(integer);
enable_io(boolean);
enable_io(bitset);
# enable_output(type);
# enable_output(ACTION);
(* text *)
const type: text is subtype file;
(* Procedures and Elements granted for every text *)
# const proc: write (inout text param, in string param) is DYNAMIC;
# const proc: write (inout text param, in char param) is DYNAMIC;
# const proc: writeln (inout text param) is DYNAMIC;
# const proc: backSpace (ref text param) is DYNAMIC;
const func integer: height (ref text param) is DYNAMIC;
const func integer: width (ref text param) is DYNAMIC;
const func integer: line (ref text param) is DYNAMIC;
const func integer: column (ref text param) is DYNAMIC;
const proc: clear (inout text param) is DYNAMIC;
const proc: clear (in text param, in integer param, in integer param,
in integer param, in integer param) is DYNAMIC;
const proc: v_scroll (inout text param, in integer param) is DYNAMIC;
const proc: v_scroll (inout text param, in integer param, in integer param,
in integer param, in integer param, in integer param) is DYNAMIC;
const proc: h_scroll (ref text param, in integer param) is DYNAMIC;
const proc: h_scroll (ref text param, in integer param, in integer param,
in integer param, in integer param, in integer param) is DYNAMIC;
const proc: color (inout text param, in color param) is DYNAMIC;
const proc: color (inout text param, in color param, in color param) is DYNAMIC;
const proc: setPos (inout text param, in integer param, in integer param) is DYNAMIC;
const proc: setPosXY (inout text param, in integer param, in integer param) is DYNAMIC;
const proc: setLine (ref text param, ref integer param) is DYNAMIC;
const proc: setColumn (ref text param, ref integer param) is DYNAMIC;
const proc: setXY (ref text param, ref integer param, ref integer param) is DYNAMIC;
const proc: flush (ref text param) is DYNAMIC;
const proc: cursor (ref text param, ref boolean param) is DYNAMIC;
const proc: cursor_on (ref text param) is DYNAMIC;
const proc: cursor_off (ref text param) is DYNAMIC;
const proc: box (ref text param) is DYNAMIC;
const proc: clear_box (ref text param) is DYNAMIC;
(* ARGS + ENV *)
const func array string: argv (PROGRAM) is action "PRC_ARGS";
const func string: name (PROGRAM) is action "PRG_NAME";
const func string: getenv (in string param) is action "STR_GETENV";
(* DIRECTORY *)
const integer: FILE_ABSENT is 0; # A component of path does not exist
const integer: FILE_UNKNOWN is 1; # File exists but has an unknown type
const integer: FILE_REGULAR is 2;
const integer: FILE_DIR is 3;
const integer: FILE_CHAR is 4;
const integer: FILE_BLOCK is 5;
const integer: FILE_FIFO is 6;
const integer: FILE_SYMLINK is 7;
const integer: FILE_SOCKET is 8;
const type: filePermission is new enum
EXEC_OTHER,
WRITE_OTHER,
READ_OTHER,
EXEC_GROUP,
WRITE_GROUP,
READ_GROUP,
EXEC_USER,
WRITE_USER,
READ_USER
end enum;
const type: fileMode is set of filePermission;
const func integer: (attr integer) conv (in fileMode: mode) is
return integer conv (bitset conv mode);
const func fileMode: (attr fileMode) conv (in integer: int_mode) is
return fileMode conv (bitset conv int_mode);
const func string: str (in fileMode: aFileMode) is func
result
var string: result is "";
local
const array [filePermission] string: name is
[filePermission] ("x", "w", "r", "x", "w", "r", "x", "w", "r");
var filePermission: aPermission is READ_USER;
begin
for aPermission range READ_USER downto EXEC_OTHER do
if aPermission in aFileMode then
result &:= name[aPermission];
else
result &:= "-";
end if;
end for;
end func;
enable_output(fileMode);
const proc: chdir (in string param) is action "CMD_CHDIR";
const proc: mkdir (in string param) is action "CMD_MKDIR";
const func string: getcwd is action "CMD_GETCWD";
const func integer: fileSize (in string param) is action "CMD_FILESIZE";
const func integer: fileType (in string param) is action "CMD_FILETYPE";
const func integer: fileTypeSL (in string param) is action "CMD_FILETYPE_SL";
const func fileMode: fileMode (in string param) is action "CMD_FILEMODE";
const proc: setFileMode (in string param, in fileMode param) is action "CMD_SET_FILEMODE";
const func array string: read_dir (in string param) is action "CMD_LS";
const proc: remove (in string param) is action "CMD_REMOVE";
const proc: removeAnyFile (in string param) is action "CMD_REMOVE_ANY_FILE";
const proc: rename (in string param, in string param) is action "CMD_MOVE";
const proc: cloneFile (in string param, in string param) is action "CMD_CLONE_FILE";
const proc: copyFile (in string param, in string param) is action "CMD_COPY_FILE";
const func string: readlink (in string param) is action "CMD_READLINK";
const proc: symlink (in string param, in string param) is action "CMD_SYMLINK";
const func string: configValue (in string param) is action "CMD_CONFIG_VALUE";
const func boolean: fileExists (in string: file_name) is func
result
var boolean: result is FALSE;
local
var file: a_file is STD_NULL;
begin
a_file := open(file_name, "r");
if a_file <> STD_NULL then
close(a_file);
result := TRUE;
end if;
end func;
const proc: heapstat (PROGRAM) is action "PRC_HEAPSTAT";
const func integer: heapsize (PROGRAM) is action "PRC_HSIZE";
const proc: PRIMITIVE_INCLUDE (in string param) is action "PRC_INCLUDE";
var set of string: INCLUDED_LIBRARY_LIST is (set of string).value;
const proc: include (in string: library) is func
local
var string: libraryName is "";
begin
if rpos(library, '/') <> 0 then
libraryName := library[succ(rpos(library, '/')) ..];
else
libraryName := library;
end if;
if libraryName not in INCLUDED_LIBRARY_LIST then
incl(INCLUDED_LIBRARY_LIST, libraryName);
PRIMITIVE_INCLUDE(library);
end if;
end func;
(*
const proc: var (ref expr: typeExpr) : (ref expr: nameExpr) is (ref expr: initExpr) is action "PRC_TRACE";
*)
const proc: main is forward;
$ system "main" is main;