hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

changed hcl_geterrnum() to HCL_ERRNUM().
All checks were successful
continuous-integration/drone/push Build is passing
Details

Browse Source 
reintroduced hcl_geterrnum() as a function
This commit is contained in:
hyung-hwan
2024-02-03 13:36:05 +09:00
parent d339338a40
commit 9aa1bde1a1
15 changed files with 125 additions and 113 deletions
Download Patch File Download Diff File Expand all files Collapse all files

94
pas/hcl.pas
View File

@ -8,17 +8,11 @@ unit HCL;
interface
type
type
Interp = class
public
protected
handle: pointer;
private
handle1: integer;
handle2: integer;
handle3: integer;
handle4: integer;
handle5: integer;
handle6: integer;
public
constructor Create (x: integer);
destructor Destroy; override;
@ -34,12 +28,29 @@ type
function FetchErrorMsg(): string;
end;
InterpPtr = ^Interp;
Location = record
line: sizeint;
colm: sizeint;
filp: pwidechar;
end;
Synerr = record
num: integer;
loc: Location;
tgt: record
val: array[0..255] of widechar;
len: sizeint;
end;
end;
SynerrPtr = ^Synerr;
(*----- external hcl function -----*)
function hcl_errnum_to_errbcstr(errnum: integer; errbuf: pointer; errbufsz: sizeint): pointer; cdecl; external;
function hcl_errnum_is_synerr(errnum: integer): boolean; cdecl; external;
function hcl_openstd(xtnsize: sizeint; errnum: pointer): pointer; cdecl; external;
procedure hcl_close(handle: pointer); cdecl; external;
function hcl_geterrnum(handle: pointer): integer; cdecl; external;
function hcl_geterrbmsg(handle: pointer): pansichar; cdecl; external;
function hcl_ignite(handle: pointer; heapsize: sizeint): integer; cdecl; external;
function hcl_addbuiltinprims(handle: pointer): integer; cdecl; external;
@ -53,18 +64,19 @@ procedure hcl_detachccio(handle: pointer); cdecl; external;
function hcl_attachudiostdwithbcstr(handle: pointer; udi: pansichar; udo: pansichar): integer; cdecl; external;
procedure hcl_detachudio(handle: pointer); cdecl; external;
function hcl_compile(handle: pointer; cnode: pointer; flags: integer): integer; cdecl; external;
function hcl_execute(handle: pointer): integer; cdecl; external;
function hcl_execute(handle: pointer): pointer; cdecl; external;
procedure hcl_abort(handle: pointer) cdecl; external;
procedure hcl_getsynerr(handle: pointer; synerr: SynerrPtr) cdecl; external;
function hcl_count_ucstr(ptr: pwidechar): sizeint; cdecl; external;
(*----- end external hcl function -----*)
implementation
uses sysutils;
uses sysutils, math;
constructor Interp.Create (x: integer);
var
var
h: pointer;
errnum: integer;
errmsg: array[0..255] of AnsiChar;
@ -89,11 +101,30 @@ end;
function Interp.FetchErrorMsg(): string;
var
bmsg: PAnsiChar;
num: integer;
bmsg: pansichar;
serr: Synerr;
filp: pwidechar;
tgt: array[0..255] of widechar;
begin
(* TODO: if the errocode is syntax error. use the systax error message and locations info *)
bmsg := hcl_geterrbmsg(self.handle);
exit(string(bmsg))
num := hcl_geterrnum(self.handle);
if hcl_errnum_is_synerr(num) then begin
hcl_getsynerr(self.handle, @serr);
bmsg := hcl_geterrbmsg(self.handle);
filp := pwidechar(widestring(''));
if serr.loc.filp <> nil then filp := serr.loc.filp;
if serr.tgt.len > 0 then begin
sysutils.strlcopy(@tgt, serr.tgt.val, math.min(serr.tgt.len, length(tgt) - 1));
exit(format('%s at %s[%u:%u] - %s', [string(bmsg), string(filp), serr.loc.line, serr.loc.colm, string(tgt)]));
end
else begin
exit(format('%s at %s[%u:%u]', [string(bmsg), string(filp), serr.loc.line, serr.loc.colm]));
end;
end
else begin
bmsg := hcl_geterrbmsg(self.handle);
exit(string(bmsg))
end;
end;
procedure Interp.Ignite(heapsize: sizeint);
@ -121,6 +152,7 @@ end;
procedure Interp.Compile(text: pansichar; len: sizeint);
var
errnum: integer;
errmsg: string;
begin
if hcl_attachcciostdwithbcstr(self.handle, nil) <= -1 then begin
@ -132,12 +164,16 @@ begin
hcl_detachccio(self.handle);
raise Exception.Create('failed to begin feeding - ' + errmsg)
end;
if hcl_feedbchars(self.handle, text, len) <= -1 then begin
errnum := hcl_geterrnum(self.handle);
errmsg := self.FetchErrorMsg();
hcl_endfeed(self.handle);
hcl_detachccio(self.handle);
raise Exception.Create('failed to feed text - ' + errmsg)
if hcl_errnum_is_synerr(errnum) then
raise Exception.Create(errmsg)
else
raise Exception.Create('failed to feed text - ' + errmsg);
end;
if hcl_endfeed(self.handle) <= -1 then begin
@ -156,6 +192,7 @@ end;
procedure Interp.Compile(text: pwidechar; len: sizeint);
var
errnum: integer;
errmsg: string;
begin
if hcl_attachcciostdwithbcstr(self.handle, nil) <= -1 then begin
@ -169,10 +206,14 @@ begin
end;
if hcl_feeduchars(self.handle, text, len) <= -1 then begin
errnum := hcl_geterrnum(self.handle);
errmsg := self.FetchErrorMsg();
hcl_endfeed(self.handle);
hcl_detachccio(self.handle);
raise Exception.Create('failed to feed text - ' + errmsg)
if hcl_errnum_is_synerr(errnum) then
raise Exception.Create(errmsg)
else
raise Exception.Create('failed to feed text - ' + errmsg);
end;
if hcl_endfeed(self.handle) <= -1 then begin
@ -187,17 +228,18 @@ end;
procedure Interp.Execute();
var
n: integer;
errmsg: string;
begin
if hcl_attachudiostdwithbcstr(self.handle, nil, nil) <= -1 then begin
raise Exception.Create('failed to attach udio handlers - ' + self.FetchErrorMsg())
end;
n := hcl_execute(self.handle);
hcl_detachudio(self.handle);
if n <= -1 then
begin
raise Exception.Create('failed to execute - ' + self.FetchErrorMsg())
if hcl_execute(self.handle) = nil then begin
errmsg := self.FetchErrorMsg();
hcl_detachudio(self.handle);
raise Exception.Create('failed to execute - ' + errmsg)
end;
hcl_detachudio(self.handle);
end;
end. (* unit *)