[GODCC][COMMITTED] Adapt sources from UPPER to SUPPER stropping
Jose E. Marchesi
jemarch@gnu.org
Sun Apr 20 22:18:17 GMT 2025
---
src/Makefile.am | 2 +-
src/argp.a68 | 111 +++++------
src/godcc.a68 | 475 ++++++++++++++++++++++++------------------------
src/http.a68 | 118 ++++++------
src/json.a68 | 313 +++++++++++++++----------------
src/utils.a68 | 52 +++---
6 files changed, 546 insertions(+), 525 deletions(-)
diff --git a/src/Makefile.am b/src/Makefile.am
index 4355e90..055d192 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -15,7 +15,7 @@
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
-AM_A68FLAGS = -fa68-nil-checking
+AM_A68FLAGS = -fa68-nil-checking -fstropping=supper
bin_PROGRAMS = godcc
godcc_SOURCES = godcc.a68
diff --git a/src/argp.a68 b/src/argp.a68
index 2629b82..19dba05 100644
--- a/src/argp.a68
+++ b/src/argp.a68
@@ -16,6 +16,8 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
#
+# PR SUPPER PR #
+
# Each option can specify a name and a long name. The name is a
single character, and " " denotes the option has no short
name. The long name is a string, and the empty string ""
@@ -49,58 +51,61 @@
returns. Otherwise parsing continues.
#
-MODE ARGOPT = STRUCT (CHAR name, STRING long name,
- BOOL arg required, PROC(STRING)BOOL handler);
-
-PROC argp = (INT p, []ARGOPT opts,
- PROC(INT,STRING)BOOL no opt handler) VOID:
-BEGIN
- PROC getopt = (STRING prefix, STRING arg) ARGOPT:
- BEGIN ARGOPT res, BOOL found := FALSE;
- FOR i TO UPB opts WHILE NOT found
- DO IF arg = long name OF opts[i]
- OR (arg /= " " AND arg = name OF opts[i])
- THEN res := opts[i]; found := TRUE
- FI
- OD;
- (NOT found | error ("unknown option " + prefix + arg));
+mode ArgOpt = struct (char name, string long_name,
+ bool arg_required, proc(string)bool handler);
+
+proc argp = (int p, [][]ArgOpt opts,
+ proc(int,string)bool no_opt_handler,
+ proc(string)void error_handler) void:
+begin
+ proc getopt = (string prefix, string arg) ArgOpt:
+ begin ArgOpt res, bool found := false;
+ for i to UPB opts while NOT found
+ do for j to UPB opts[i] while NOT found
+ do if arg = long_name of opts[i][j]
+ OR (arg /= " " AND arg = name of opts[i][j])
+ then res := opts[i][j]; found := true
+ fi
+ od
+ od;
+ (NOT found | error_handler ("unknown option " + prefix + arg));
res
- END;
-
- BOOL found dash dash := FALSE,
- skip next opt := FALSE,
- continue := TRUE;
-
- FOR i FROM p TO argc WHILE continue
- DO STRING arg = argv (i);
- IF skip next opt
- THEN skip next opt := FALSE
- ELIF arg = "--" AND NOT found dash dash
- THEN found dash dash := TRUE
- ELIF found dash dash OR (UPB arg >= 1 ANDTH arg[1] /= "-")
- THEN continue := no opt handler (i + 1, arg)
- ELIF UPB arg > 1 ANDTH arg[2] = "-"
- THEN # Long option. It may have an argument. #
- INT eqidx = char in string (arg, "=");
- STRING optname = (eqidx > 0 | arg[3:eqidx - 1] | arg[3:]),
+ end;
+
+ bool found_dash_dash := false,
+ skip_next_opt := false,
+ continue := true;
+
+ for i from p to argc while continue
+ do string arg = argv (i);
+ if skip_next_opt
+ then skip_next_opt := false
+ elif arg = "--" AND NOT found_dash_dash
+ then found_dash_dash := true
+ elif found_dash_dash OR (UPB arg >= 1 andth arg[1] /= "-")
+ then continue := no_opt_handler (i + 1, arg)
+ elif UPB arg > 1 andth arg[2] = "-"
+ then # Long option. It may have an argument. #
+ int eqidx = char_in_string (arg, "=");
+ string optname = (eqidx > 0 | arg[3:eqidx - 1] | arg[3:]),
optarg = (eqidx > 0 AND UPB arg >= (eqidx + 1) | arg[eqidx + 1:]);
- ARGOPT opt = getopt ("--", optname);
-
- IF (arg required OF opt) AND optarg = ""
- THEN error ("option --" + arg + " requires an argument") FI;
- continue := (handler OF opt) (optarg)
- ELSE # This is one or more short options. #
- FOR j TO UPB arg[2:]
- DO ARGOPT opt = getopt ("-", arg[j + 1]);
- IF arg required OF opt
- THEN IF i = argc OREL argv (i + 1)[1] = "-"
- THEN error ("option -" + arg[2+j] + " requires an argument")
- FI;
- (handler OF opt) (argv (i + 1));
- skip next opt := TRUE
- ELSE continue := (handler OF opt) ("")
- FI
- OD
- FI
- OD
-END;
+ ArgOpt opt = getopt ("--", optname);
+
+ if (arg_required of opt) AND optarg = ""
+ then error_handler ("option --" + arg + " requires an argument") fi;
+ continue := (handler of opt) (optarg)
+ else # This is one or more short options. #
+ for j to UPB arg[2:]
+ do ArgOpt opt = getopt ("-", arg[j + 1]);
+ if arg_required of opt
+ then if i = argc orel (ELEMS argv (i + 1) > 1 andth argv (i + 1)[1] = "-")
+ then error_handler ("option -" + arg[2+j] + " requires an argument")
+ fi;
+ (handler of opt) (argv (i + 1));
+ skip_next_opt := true
+ else continue := (handler of opt) ("")
+ fi
+ od
+ fi
+ od
+end;
diff --git a/src/godcc.a68 b/src/godcc.a68
index a831e00..e82b43b 100644
--- a/src/godcc.a68
+++ b/src/godcc.a68
@@ -17,6 +17,8 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
#
+# PR SUPPER PR #
+
# Note that a lot of the functionality implemented in this file really
belong to libraries or the standard prelude, but since GCC doesn't
support separated compilation for Algol 68 yet we have to ship them
@@ -29,53 +31,53 @@
- HTTP support.
#
-BEGIN STRING godcc version = "1.0";
+begin string godcc_version = "1.0";
# Include some facilities. #
- PR include "utils.a68" PR
- PR include "argp.a68" PR
- PR include "json.a68" PR
- PR include "http.a68" PR
+ pr include "utils.a68" pr
+ pr include "argp.a68" pr
+ pr include "json.a68" pr
+ pr include "http.a68" pr
# Diagnostics. #
- BOOL be quiet := FALSE;
+ bool be_quiet := false;
- PROC info = (STRING msg) VOID:
- (NOT be quiet | puts (msg));
+ proc info = (string msg) void:
+ (NOT be_quiet | puts (msg));
- PROC error = (STRING msg) VOID:
- BEGIN puts ("godcc: error: " + msg + "\n");
- set exit status (1);
+ proc error = (string msg) void:
+ begin puts ("godcc: error: " + msg + "\n");
+ set_exit_status (1);
stop
- END;
+ end;
- PROC errorno = (STRING msg) VOID:
+ proc errorno = (string msg) void:
(error (msg + ": " + strerror (errno)));
# A few checked operations to keep code clean. #
- PROC fopen checked = (STRING path, BITS flags) INT:
- (INT res = fopen (path, flags);
- (res /= -1 | res | errorno ("opening " + path); SKIP));
+ proc fopen_checked = (string path, bits flags) int:
+ (int res = fopen (path, flags);
+ (res /= -1 | res | errorno ("opening " + path); skip));
- PROC fcreate checked = (STRING path, BITS mode) INT:
- (INT res = fcreate (path, mode);
- (res /= -1 | res | errorno ("creating " + path); SKIP));
+ proc fcreate_checked = (string path, bits mode_) int:
+ (int res = fcreate (path, mode_);
+ (res /= -1 | res | errorno ("creating " + path); skip));
- PROC fclose checked = (STRING path, INT fd) INT:
- (INT res = fclose (fd);
- (res /= -1 | res | errorno ("closing " + path); SKIP));
+ proc fclose_checked = (string path, int fd) int:
+ (int res = fclose (fd);
+ (res /= -1 | res | errorno ("closing " + path); skip));
- PROC fputs checked = (STRING path, INT fd, STRING str) INT:
- (INT res = fputs (fd, str);
- (res = 0 AND UPB str > 0 | errorno ("writing to " + path); SKIP | res));
+ proc fputs_checked = (string path, int fd, string str) int:
+ (int res = fputs (fd, str);
+ (res = 0 AND UPB str > 0 | errorno ("writing to " + path); skip | res));
# --help and --version #
- PROC do help = (STRING arg) BOOL:
- BEGIN puts ("Usage: godcc [ARG...] list (languages | compilers [-l LANGUAGE] | formats)\n\
+ proc do_help = (string arg) bool:
+ begin puts ("Usage: godcc [ARG...] list (languages | compilers [-l LANGUAGE] | formats)\n\
or: godcc [ARG...] compile [-c COMPILER] [-o OUTFILE] [SRCFILE] [-- [CARG...]]\n\
or: godcc [ARG...] format [-f FORMATTER] [-s STYLE] [-o OUTFILE] [SRCFILE]\n");
puts ("Command-line front-end to Compiler Explorer.\n");
@@ -109,17 +111,17 @@ BEGIN STRING godcc version = "1.0";
GODCC_CEPORT port to use for connecting to CE\n");
puts ("\n");
puts ("Report bugs to: jemarch@gnu.org\n");
- FALSE
- END;
+ false
+ end;
- PROC do version = (STRING arg) BOOL:
- BEGIN puts ("godcc " + godcc version + "\n\n");
+ proc do_version = (string arg) bool:
+ begin puts ("godcc " + godcc_version + "\n\n");
puts ("Copyright (C) 2025 Jose E. Marchesi.\n");
puts ("License GPLv3+: GNU GPL version 3 or later.\n");
puts ("This is free software: you are free to change and redistribute it.\n");
puts ("There is NO WARRANTY, to the extent permitted by law.\n");
- FALSE
- END;
+ false
+ end;
# Communication with Compiler Explorer is performed via a
socket.
@@ -128,277 +130,282 @@ BEGIN STRING godcc version = "1.0";
performed between calls of `ce connect' and `ce disconnect'.
#
- INT ce socket := -1;
+ int ce_socket := -1;
- STRING ce host = getenv ("GODCC_CEHOST");
- INT ce port = atoi (getenv ("GODCC_CEPORT"), 10);
+ string ce_host = getenv ("GODCC_CEHOST");
+ int ce_port = atoi (getenv ("GODCC_CEPORT"), 10);
- PROC ce connect = VOID:
- BEGIN (ce socket > -1 | error ("socket already open"));
- IF (ce socket := fconnect (ce host, ce port)) = -1
- THEN errorno ("connecting to " + ce host + ":" + itoa (ce port))
- FI
- END;
+ proc ce_connect = void:
+ begin (ce_socket > -1 | error ("socket already open"));
+ if (ce_socket := fconnect (ce_host, ce_port)) = -1
+ then errorno ("connecting to " + ce_host + ":" + itoa (ce_port))
+ fi
+ end;
- PROC ce disconnect = VOID:
- BEGIN (ce socket = -1 | error ("socket not open"));
- IF fclose (ce socket) = -1
- THEN errorno ("closing socket") FI;
- ce socket := -1
- END;
+ proc ce_disconnect = void:
+ begin (ce_socket = -1 | error ("socket not open"));
+ if fclose (ce_socket) = -1
+ then errorno ("closing socket") fi;
+ ce_socket := -1
+ end;
- PROC ce get json = (STRING what) JSONVAL:
- BEGIN JSONVAL val;
- PROC h = (INT e, n, fd) VOID:
- (IF e /= 0 THEN error ("received JSON in chunks") FI;
- val := json from fd (n, fd));
+ proc ce_get_json = (string what) JsonVal:
+ begin JsonVal val;
+ proc h = (int e, n, fd) void:
+ (if e /= 0 then error ("received JSON in chunks") fi;
+ val := json_from_fd (n, fd));
- http get ("/api/" + what,
+ http_get ("/api/" + what,
(("Host", "godbolt.org"),
("user-agent", "curl/7.74.0"),
("content-type", "application/json"),
("Accept", "application/json")),
- ce socket, h, FALSE # fragmented #);
+ ce_socket, h, false # fragmented #);
val
- END;
+ end;
- PROC ce post json = (STRING what, JSONVAL val) JSONVAL:
- BEGIN JSONVAL out val;
- PROC h = (INT e, n, fd) VOID:
- (IF e /= 0 THEN error ("received JSON in chunks") FI;
- out val := json from fd (n, fd));
+ proc ce_post_json = (string what, JsonVal val) JsonVal:
+ begin JsonVal out_val;
+ proc h = (int e, n, fd) void:
+ (if e /= 0 then error ("received JSON in chunks") fi;
+ out_val := json_from_fd (n, fd));
- http post ("/api/" + what, json to string (val),
+ http_post ("/api/" + what, json_to_string (val),
(("Host", "godbolt.org"),
("user-agent", "curl/7.74.0"),
("content-type", "application/json"),
("Accept", "application/json")),
- ce socket, h, FALSE # fragmented #);
- out val
- END;
+ ce_socket, h, false # fragmented #);
+ out_val
+ end;
- PROC ce get text = (STRING what, PROC(INT,INT,INT)VOID h) VOID:
- http get ("/api/" + what,
+ proc ce_get_text = (string what, proc(int,int,int)void h) void:
+ http_get ("/api/" + what,
(("Host", "godbolt.org"),
("user-agent", "curl/7.74.0"),
("Accept", "text/*")),
- ce socket, h, TRUE # fragmented #);
+ ce_socket, h, true # fragmented #);
- PROC ce post text = (STRING what, STRING arg,
- PROC(INT,INT,INT)VOID h) VOID:
- http post ("/api/" + what, arg,
+ proc ce_post_text = (string what, string arg,
+ proc(int,int,int)void h) void:
+ http_post ("/api/" + what, arg,
(("Host", "godbolt.org"),
("user-agent", "curl/7.74.0"),
("Accept", "text/*")),
- ce socket, h, TRUE # fragmented #);
+ ce_socket, h, true # fragmented #);
# Print a list of languages supported by CE. #
- PROC do languages = VOID:
- BEGIN
- ce connect;
- JSONVAL languages = ce get json ("languages");
- json foreach elem (languages,
- (JSONVAL v) VOID:
- puts (json str (json obj sel (v, "id")) + "\n"));
- ce disconnect
- END;
+ proc do_languages = void:
+ begin
+ ce_connect;
+ JsonVal languages = ce_get_json ("languages");
+ json_foreach_elem (languages,
+ (JsonVal v) void:
+ puts (json_str (json_obj_sel (v, "id")) + "\n"));
+ ce_disconnect
+ end;
# Print a list of compilers supported by CE. #
- PROC do compilers = (STRING language) VOID:
- BEGIN STRING what := "compilers";
+ proc do_compilers = (string language) void:
+ begin string what := "compilers";
(language /= "" | what +:= "/" + language);
- ce connect;
- ce get text (what,
- (INT e, n, fd) VOID:
- BEGIN (n > 0 | puts (fgets (fd, n)));
+ ce_connect;
+ ce_get_text (what,
+ (int e, n, fd) void:
+ begin (n > 0 | puts (fgets (fd, n)));
(e = 0 | puts ("\n"))
- END);
- ce disconnect
- END;
+ end);
+ ce_disconnect
+ end;
# Print a list of code formatters supported by CE. #
- PROC do formats = VOID:
- BEGIN
- PROC do format = (JSONVAL f) VOID:
- BEGIN JSONVAL format name = json obj sel (f, "name"),
- format styles = json obj sel (f, "styles");
+ proc do_formats = void:
+ begin
+ proc do_format = (JsonVal f) void:
+ begin JsonVal format_name = json_obj_sel (f, "name"),
+ format_styles = json_obj_sel (f, "styles");
- puts (json str (format name));
- json for each elem (format styles,
- (JSONVAL style) VOID:
- puts (" (" + json str (style) + ")"));
+ puts (json_str (format_name));
+ json_for_each_elem (format_styles,
+ (JsonVal style) void:
+ puts (" (" + json_str (style) + ")"));
puts ("\n");
- FALSE
- END;
+ false
+ end;
- ce connect;
- JSONVAL formats = ce get json ("formats");
- json foreach elem (formats, do format);
- ce disconnect
- END;
+ ce_connect;
+ JsonVal formats = ce_get_json ("formats");
+ json_foreach_elem (formats, do_format);
+ ce_disconnect
+ end;
# Compile a source file using the specified options. #
- PROC do compile = (STRING compiler, filename, out file,
- comp opts) VOID:
- BEGIN # Open the input file and read its contents. #
- INT fd := 0;
- IF filename /= "-"
- THEN fd := fopen checked (filename, file o rdonly) FI;
- STRING src, line;
- WHILE (line := fgets (fd, 0)) /= "" DO src +:= line OD;
+ proc do_compile = (string compiler, filename, out_file,
+ comp_opts) void:
+ begin # Open the input file and read its contents. #
+ int fd := 0;
+ if filename /= "-"
+ then fd := fopen_checked (filename, file_o_rdonly) fi;
+ string src, line;
+ while (line := fgets (fd, 0)) /= "" do src +:= line od;
# Open the output file. #
- INT out fd := 1;
- IF out file /= "-"
- THEN out fd := fcreate checked (out file, 8r644) FI;
+ int out_fd := 1;
+ if out_file /= "-"
+ then out_fd := fcreate_checked (out_file, 8r644) fi;
# Form the URI appending options if necessary. #
- STRING uri := "compiler/" + compiler + "/compile";
- IF comp opts /= ""
- THEN uri +:= "?options=" + http escape url (comp opts) FI;
+ string uri := "compiler/" + compiler + "/compile";
+ if comp_opts /= ""
+ then uri +:= "?options=" + http_escape_url (comp_opts) fi;
# Query the server, printing the response. #
- ce connect;
- ce post text (uri, src,
- (INT e, n, fd) VOID:
+ ce_connect;
+ ce_post_text (uri, src,
+ (int e, n, fd) void:
(n > 0 | puts (fgets (fd, n))));
- ce disconnect;
+ ce_disconnect;
# Close output file if required. #
- IF out fd /= 1
- THEN fclose checked (out file, out fd) FI
- END;
+ if out_fd /= 1
+ then fclose_checked (out_file, out_fd) fi
+ end;
# Format a source file using the specified formatter, style and
other options. #
- PROC do format = (STRING filename, formatter, style, out file,
- BOOL use spaces, INT tab width) VOID:
- BEGIN # Open the input file and read its contents. #
- INT fd := 0;
- IF filename /= "-"
- THEN fd := fopen checked (filename, file o rdonly) FI;
- STRING src, line;
- WHILE (line := fgets (fd, 0)) /= "" DO src +:= line OD;
+ proc do_format = (string filename, formatter, style, out_file,
+ bool use_spaces, int tab_width) void:
+ begin # Open the input file and read its contents. #
+ int fd := 0;
+ if filename /= "-"
+ then fd := fopen_checked (filename, file_o_rdonly) fi;
+ string src, line;
+ while (line := fgets (fd, 0)) /= "" do src +:= line od;
# Prepare the JSON query. #
- REF JSONFLD fields := NIL;
- fields := HEAP JSONFLD := ("source", json escape string (src), fields);
- IF style /= ""
- THEN fields := HEAP JSONFLD := ("base", style, fields) FI;
- fields := HEAP JSONFLD := ("useSpaces", use spaces, fields);
- fields := HEAP JSONFLD := ("tabWidth", tab width, fields);
- JSONOBJ obj;
- fields OF obj := fields;
- JSONVAL cmd = obj;
+ ref JsonFld fields := nil;
+ fields := heap JsonFld := ("source", json_escape_string (src), fields);
+ if style /= ""
+ then fields := heap JsonFld := ("base", style, fields) fi;
+ fields := heap JsonFld := ("useSpaces", use_spaces, fields);
+ fields := heap JsonFld := ("tabWidth", tab_width, fields);
+ JsonObj obj;
+ fields of obj := fields;
+ JsonVal cmd = obj;
# Query the server. #
- ce connect;
- JSONVAL res = ce post json ("format/" + formatter, cmd);
- ce disconnect;
+ ce_connect;
+ JsonVal res = ce_post_json ("format/" + formatter, cmd);
+ ce_disconnect;
# Process the response. #
- INT exit status = json int (json obj sel (res, "exit"));
- STRING answer = json str (json obj sel (res, "answer"));
- IF exit status /= 0
- THEN error (answer) FI;
+ int exit_status = json_int (json_obj_sel (res, "exit"));
+ string answer = json_str (json_obj_sel (res, "answer"));
+ if exit_status /= 0
+ then error (answer) fi;
# Write the formatted code to the output file. #
- INT out fd := 1;
- IF out file /= "-"
- THEN out fd := fcreate checked (out file, 8r644) FI;
- fputs checked (out file, out fd, answer);
- IF out fd /= 1
- THEN fclose checked (out file, out fd) FI
- END;
+ int out_fd := 1;
+ if out_file /= "-"
+ then out_fd := fcreate_checked (out_file, 8r644) fi;
+ fputs_checked (out_file, out_fd, answer);
+ if out_fd /= 1
+ then fclose_checked (out_file, out_fd) fi
+ end;
# Main program. #
- argp (2, ((" ", "help", FALSE, do help),
- (" ", "version", FALSE, do version),
- ("q", "quiet", FALSE, (STRING arg) BOOL:
- (be quiet := TRUE; TRUE))),
- (INT pos, STRING no opt arg) BOOL:
- IF no opt arg = "list"
- THEN STRING what;
+ argp (2, []ArgOpt ((" ", "help", false, do_help),
+ (" ", "version", false, do_version),
+ ("q", "quiet", false, (string arg) bool:
+ (be_quiet := true; true))),
+ (int pos, string no_opt_arg) bool:
+ if no_opt_arg = "list"
+ then string what;
argp (pos, (),
- (INT pos, STRING arg) BOOL:
- BEGIN IF arg = "languages" THEN do languages
- ELIF arg = "formats" THEN do formats
- ELIF arg = "compilers"
- THEN STRING language;
- [1]ARGOPT opts;
- opts[1] := ("l", "language", TRUE,
- (STRING arg) BOOL: (language := arg;
- TRUE));
+ (int pos, string arg) bool:
+ begin if arg = "languages" then do_languages
+ elif arg = "formats" then do_formats
+ elif arg = "compilers"
+ then string language;
+ [1]ArgOpt opts;
+ opts[1] := ("l", "language", true,
+ (string arg) bool: (language := arg;
+ true));
argp (pos, opts,
- (INT pos, STRING no opt arg) BOOL:
- (error ("invalid argument to list compilers"); SKIP));
- do compilers (language)
- ELSE error ("unknown subcommand " + arg); SKIP
- FI;
- FALSE
- END);
- FALSE
- ELIF no opt arg = "compile"
- THEN STRING compiler, src file := "-", out file := "-",
- comp opts;
+ (int pos, string no_opt_arg) bool:
+ (error ("invalid argument to list compilers"); ~),
+ error);
+ do_compilers (language)
+ else error ("unknown subcommand " + arg); skip
+ fi;
+ false
+ end,
+ error);
+ false
+ elif no_opt_arg = "compile"
+ then string compiler, src_file := "-", out_file := "-",
+ comp_opts;
# Try to infer the default for the compiler
from the progname. #
- BEGIN STRING progname = argv (1);
- INT dash = char in string (progname, "-");
- IF dash > 0 AND dash <= UPB progname
- THEN compiler := progname[dash+1:]
- FI
- END;
- argp (pos, (("c", "compiler", TRUE,
- (STRING arg) BOOL: (compiler := arg; TRUE)),
- ("o", "", TRUE,
- (STRING arg) BOOL: (out file := arg; TRUE))),
- (INT pos, STRING no opt arg) BOOL:
- BEGIN IF no opt arg[1] = "-"
- THEN comp opts +:= " " + no opt arg
- ELIF src file /= "-"
- THEN error ("please specify exactly one source file to compile")
- ELSE src file := no opt arg
- FI;
- TRUE
- END);
+ begin string progname = argv (1);
+ int dash = char_in_string (progname, "-");
+ if dash > 0 AND dash <= UPB progname
+ then compiler := progname[dash+1:]
+ fi
+ end;
+ argp (pos, []ArgOpt (("c", "compiler", true,
+ (string arg) bool: (compiler := arg; true)),
+ ("o", "", true,
+ (string arg) bool: (out_file := arg; true))),
+ (int pos, string no_opt_arg) bool:
+ begin if no_opt_arg[1] = "-"
+ then comp_opts +:= " " + no_opt_arg
+ elif src_file /= "-"
+ then error ("please specify exactly one source file to compile")
+ else src_file := no_opt_arg
+ fi;
+ true
+ end,
+ error);
(compiler = "" | error ("please specify a compiler with -c|--compiler"));
- do compile (compiler, src file, out file, comp opts);
- FALSE
- ELIF no opt arg = "format"
- THEN STRING formatter := "clangformat",
- style, src file := "-",
- out file := "-";
- BOOL use spaces := FALSE;
- INT tab width := 4;
- argp (pos, (("o", "", TRUE,
- (STRING arg) BOOL: (out file := arg; TRUE)),
- ("f", "formatter", TRUE,
- (STRING arg) BOOL: (formatter := arg; TRUE)),
- ("s", "style", TRUE,
- (STRING arg) BOOL: (style := arg; TRUE)),
- ("t", "tab-width", TRUE,
- (STRING arg) BOOL: (tab width := atoi (arg, 10); TRUE)),
- ("s", "use-spaces", FALSE,
- (STRING arg) BOOL: (use spaces := TRUE))),
- (INT pos, STRING no opt arg) BOOL:
- (IF src file /= "-"
- THEN error ("please specify exacly one source file to format")
- FI;
- src file := no opt arg;
- TRUE));
+ do_compile (compiler, src_file, out_file, comp_opts);
+ false
+ elif no_opt_arg = "format"
+ then string formatter := "clangformat",
+ style, src_file := "-",
+ out_file := "-";
+ bool use_spaces := false;
+ int tab_width := 4;
+ argp (pos, []ArgOpt (("o", "", true,
+ (string arg) bool: (out_file := arg; true)),
+ ("f", "formatter", true,
+ (string arg) bool: (formatter := arg; true)),
+ ("s", "style", true,
+ (string arg) bool: (style := arg; true)),
+ ("t", "tab-width", true,
+ (string arg) bool: (tab_width := atoi (arg, 10); true)),
+ ("s", "use-spaces", false,
+ (string arg) bool: (use_spaces := true))),
+ (int pos, string no_opt_arg) bool:
+ (if src_file /= "-"
+ then error ("please specify exacly one source file to format")
+ fi;
+ src_file := no_opt_arg;
+ true),
+ error);
style := (style = ""
| (formatter = "clangformat" | "GNU")
| style);
- do format (src file, formatter, style, out file, use spaces, tab width);
- FALSE
- ELSE error ("unknown subcommand " + no opt arg);
- SKIP
- FI)
-END
+ do_format (src_file, formatter, style, out_file, use_spaces, tab_width);
+ false
+ else error ("unknown subcommand " + no_opt_arg);
+ skip
+ fi,
+ error)
+end
diff --git a/src/http.a68 b/src/http.a68
index 6e4c5d1..4333830 100644
--- a/src/http.a68
+++ b/src/http.a68
@@ -16,6 +16,8 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
#
+# PR SUPPER PR #
+
# 'http get' performs a GET to a given 'uri' in the connection
established in 'socket'. A set of headers are provided in
HEADERS.
@@ -39,83 +41,83 @@
be notified in a single call to the callback.
#
-MODE HTTPHDR = STRUCT (STRING n, v);
+mode HTTPHdr = struct (string n, v);
-PROC http get = (STRING uri, []HTTPHDR headers,
- INT socket, PROC(INT,INT,INT)VOID h,
- BOOL fragmented) VOID:
-BEGIN # Prepare the header to send. #
- STRING msg := "GET " + uri + " HTTP/1.1\r\n";
- FOR i TO UPB headers
- DO msg +:= (n OF headers[i]) + ": " + (v OF headers[i]);
+proc http_get = (string uri, []HTTPHdr headers,
+ int socket, proc(int,int,int)void h,
+ bool fragmented) void:
+begin # Prepare the header to send. #
+ string msg := "GET " + uri + " HTTP/1.1\r\n";
+ for i to UPB headers
+ do msg +:= (n of headers[i]) + ": " + (v of headers[i]);
msg +:= "\r\n"
- OD;
+ od;
msg +:= "\r\n";
# Send it. #
fputs (socket, msg);
# Collect answer from server. #
- http process response (socket, h, fragmented)
-END;
+ http_process_response (socket, h, fragmented)
+end;
-PROC http post = (STRING uri, arg, []HTTPHDR headers,
- INT socket, PROC(INT,INT,INT)VOID h,
- BOOL fragmented) VOID:
-BEGIN # Prepare the header to send. #
- STRING msg := "POST " + uri + " HTTP/1.1\r\n";
- FOR i TO UPB headers
- DO msg +:= (n OF headers[i]) + ": " + (v OF headers[i]);
+proc http_post = (string uri, arg, []HTTPHdr headers,
+ int socket, proc(int,int,int)void h,
+ bool fragmented) void:
+begin # Prepare the header to send. #
+ string msg := "POST " + uri + " HTTP/1.1\r\n";
+ for i to UPB headers
+ do msg +:= (n of headers[i]) + ": " + (v of headers[i]);
msg +:= "\r\n"
- OD;
+ od;
msg +:= "Content-Length: " + itoa (UPB arg) + "\r\n";
msg +:= "\r\n";
msg +:= arg;
# Send it. #
fputs (socket, msg);
# Collect answer from server. #
- http process response (socket, h, fragmented)
-END;
+ http_process_response (socket, h, fragmented)
+end;
-PROC http process response = (INT socket,
- PROC(INT,INT,INT)VOID h,
- BOOL fragmented) VOID:
-BEGIN # First the header. #
- INT content length, STRING line, BOOL read chunks := FALSE;
- WHILE (line := fgets (socket, 0)) /= "\r\n"
- DO IF UPB line >= 17 ANDTH line[1:16] = "Content-Length: "
- THEN content length := atoi (line[17:], 10)
- ELIF UPB line >= 26 ANDTH line[1:26] = "Transfer-Encoding: chunked"
- THEN read chunks := TRUE
- FI
- OD;
+proc http_process_response = (int socket,
+ proc(int,int,int)void h,
+ bool fragmented) void:
+begin # First the header. #
+ int content_length, string line, bool read_chunks := false;
+ while (line := fgets (socket, 0)) /= "\r\n"
+ do if UPB line >= 17 andth line[1:16] = "Content-Length: "
+ then content_length := atoi (line[17:], 10)
+ elif UPB line >= 26 andth line[1:26] = "Transfer-Encoding: chunked"
+ then read_chunks := true
+ fi
+ od;
# Then the data. #
- IF read chunks
- THEN BOOL done := FALSE;
- WHILE NOT done
- DO STRING line = fgets (socket, 0);
- INT size = atoi (line, 16);
+ if read_chunks
+ then bool done := false;
+ while NOT done
+ do string line = fgets (socket, 0);
+ int size = atoi (line, 16);
h ((size = 0 | 0 | -1), size, socket);
fgetc (socket); fgetc (socket); # \r\n #
- (size = 0 | done := TRUE)
- OD;
+ (size = 0 | done := true)
+ od;
h (0, 0, socket)
- ELSE IF content length = 0
- THEN error ("couldn't find Content-Length header in response") FI;
- IF fragmented
- THEN # Call the handler to process the data in chunks.
+ else if content_length = 0
+ then error ("couldn't find Content-Length header in response") fi;
+ if fragmented
+ then # Call the handler to process the data in chunks.
Eighty is arbitrary, roughly a line size. #
- FOR i TO content length % 80
- DO h (content length - i * 80, 80, socket) OD;
- h (0, content length %* 80, socket)
- ELSE # Call the handler to process the data in one go. #
- h (0, content length, socket)
- FI
- FI
-END;
+ for i to content_length % 80
+ do h (content_length - i * 80, 80, socket) od;
+ h (0, content_length %* 80, socket)
+ else # Call the handler to process the data in one go. #
+ h (0, content_length, socket)
+ fi
+ fi
+end;
-PROC http escape url = (STRING url) STRING:
-BEGIN STRING res, CHAR sharp = REPR 35;
- FOR i TO UPB url
- DO CHAR c = url[i];
+proc http_escape_url = (string url) string:
+begin string res, char sharp = REPR 35;
+ for i to UPB url
+ do char c = url[i];
(c = " " | res +:= "%20"
|: c = "<" | res +:= "%3c"
|: c = ">" | res +:= "%3e"
@@ -140,6 +142,6 @@ BEGIN STRING res, CHAR sharp = REPR 35;
|: c = "&" | res +:= "%26"
|: c = "$" | res +:= "%24"
| res +:= c)
- OD;
+ od;
res
-END;
+end;
diff --git a/src/json.a68 b/src/json.a68
index f98aecf..a97004e 100644
--- a/src/json.a68
+++ b/src/json.a68
@@ -15,182 +15,187 @@
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
#
-
-MODE JSONVAL = UNION (BOOL,INT,STRING,JSONARR,JSONOBJ),
- JSONARR = STRUCT (REF JSONELM elements),
- JSONOBJ = STRUCT (REF JSONFLD fields),
- JSONELM = STRUCT (JSONVAL value, REF JSONELM next),
- JSONFLD = STRUCT (JSONVAL name, value, REF JSONFLD next);
-
-PROC json to string = (JSONVAL val) STRING:
- CASE val
- IN (BOOL b): (b | "true" | "false"),
- (INT i): itoa (i),
- (STRING s): """" + s + """",
- (JSONARR a): "[" + (REF JSONELM elem := elements OF a, STRING res;
- FOR i WHILE REF JSONELM (elem) :/=: NIL
- DO (i > 1 | res +:= ",");
- res +:= json to string (value OF elem);
- elem := next OF elem
- OD;
+
+# PR SUPPER PR #
+
+mode JSONVal = union (bool,int,string,JSONArr,JSONObj),
+ JSONArr = struct (ref JSONElm elements),
+ JSONObj = struct (ref JSONFld fields),
+ JSONElm = struct (JSONVal value, ref JSONElm next),
+ JSONFld = struct (JSONVal name, value, ref JSONFld next);
+
+ref JSONElm json_no_elm = nil;
+ref JSONFld json_no_fld = nil;
+
+proc json_to_string = (JSONVal val) string:
+ case val
+ in (bool b): (b | "true" | "false"),
+ (int i): itoa (i),
+ (string s): """" + s + """",
+ (JSONArr a): "[" + (ref JSONElm elem := elements of a, string res;
+ for i while elem :/=: json_no_elm
+ do (i > 1 | res +:= ",");
+ res +:= json_to_string (value of elem);
+ elem := next of elem
+ od;
res) + "]",
- (JSONOBJ o): "{" + (REF JSONFLD field := fields OF o, STRING res;
- FOR i WHILE REF JSONFLD (field) :/=: NIL
- DO (i > 1 | res +:= ",");
- res +:= json to string (name OF field);
+ (JSONObj o): "{" + (ref JSONFld field := fields of o, string res;
+ for i while field :/=: json_no_fld
+ do (i > 1 | res +:= ",");
+ res +:= json_to_string (name of field);
res +:= ":";
- res +:= json to string (value OF field);
- field := next OF field
- OD;
+ res +:= json_to_string (value of field);
+ field := next of field
+ od;
res) + "}"
- ESAC;
-
-CHAR eof = invalid char;
-CHAR ungetch := eof;
-
-PROC json from fd = (INT maxchars, INT fd) JSONVAL:
-BEGIN
- CHAR ch;
- INT usedchars;
-
- PROC getchar = CHAR:
- BEGIN IF usedchars > maxchars THEN ch := eof
- ELIF ungetch /= eof
- THEN ch := ungetch; ungetch := eof
- ELSE ch := fgetc (fd); used chars +:= 1
- FI;
+ esac;
+
+char eof = invalid_char;
+char ungetch := eof;
+
+proc json_from_fd = (int maxchars, int fd) JSONVal:
+begin
+ char ch;
+ int usedchars;
+
+ proc getchar = char:
+ begin if usedchars > maxchars then ch := eof
+ elif ungetch /= eof
+ then ch := ungetch; ungetch := eof
+ else ch := fgetc (fd); usedchars +:= 1
+ fi;
ch
- END;
+ end;
- PROC parse error = (STRING msg) VOID:
- IF ch = eof
- THEN error (msg + ", found end of file")
- ELSE error (msg + ", found '" + ch + "'")
- FI;
+ proc parse_error = (string msg) void:
+ if ch = eof
+ then error (msg + ", found end of file")
+ else error (msg + ", found '" + ch + "'")
+ fi;
- PROC parse number = INT:
- BEGIN INT num := 0;
- WHILE num := num * 10 + ABS ch - ABS "0";
+ proc parse_number = int:
+ begin int num := 0;
+ while num := num * 10 + ABS ch - ABS "0";
isdigit (getchar)
- DO SKIP OD;
+ do ~ od;
ungetch := ch;
num
- END;
-
- PROC parse string = STRING:
- BEGIN STRING res;
- WHILE getchar /= """"
- DO IF ch = eof THEN error ("while parsing string")
- ELIF ch = "\\"
- THEN ch = getchar;
- IF ch = eof THEN error ("unterminated string escape")
- ELIF ch = "n" THEN res +:= "\n"
- ELIF ch = "t" THEN res +:= "\t"
- ELIF ch = """" THEN res +:= """"
- ELIF ch = "\\" THEN res +:= ch
- ELSE error ("invalid string escape \\" + ch)
- FI
- ELSE res +:= ch
- FI
- OD;
+ end;
+
+ proc parse_string = string:
+ begin string res;
+ while getchar /= """"
+ do if ch = eof then error ("while parsing string")
+ elif ch = "\\"
+ then ch = getchar;
+ if ch = eof then error ("unterminated string escape")
+ elif ch = "n" then res +:= "\n"
+ elif ch = "t" then res +:= "\t"
+ elif ch = """" then res +:= """"
+ elif ch = "\\" then res +:= ch
+ else error ("invalid string escape \\" + ch)
+ fi
+ else res +:= ch
+ fi
+ od;
res
- END;
+ end;
- PROC expect char = (CHAR c) VOID:
- (getchar = eof OREL ch /= c | parse error ("expected '" + c + "'"));
+ proc expect_char = (char c) void:
+ (getchar = eof orel ch /= c | parse_error ("expected '" + c + "'"));
- PROC expect keyword = (STRING s) VOID:
- FOR i TO UPB s
- DO expect char (s[i]) OD;
+ proc expect_keyword = (string s) void:
+ for i to UPB s
+ do expect_char (s[i]) od;
- PROC parse array = JSONARR:
- BEGIN JSONARR res, REF JSONELM elems;
- FOR i WHILE getchar /= "]"
- DO ungetch := ch;
- IF i > 1 THEN ungetch := ch; expect char (",") FI;
- JSONVAL val = json from fd (maxchars - usedchars, fd);
+ proc parse_array = JSONArr:
+ begin JSONArr res, ref JSONElm elems;
+ for i while getchar /= "]"
+ do ungetch := ch;
+ if i > 1 then ungetch := ch; expect_char (",") fi;
+ JSONVal val = json_from_fd (maxchars - usedchars, fd);
# Array elements should keep written order. #
- elems := (REF JSONELM (elems) :=: NIL
- | HEAP JSONELM := (val, NIL)
- | (REF JSONELM e := elems;
- WHILE REF JSONELM (next OF e) :/=: NIL
- DO e := next OF e OD;
- next OF e := HEAP JSONELM := (val, NIL);
+ elems := (elems :=: json_no_elm
+ | heap JSONElm := (val, nil)
+ | (ref JSONElm e := elems;
+ while next of e :/=: json_no_elm
+ do e := next of e od;
+ next of e := heap JSONElm := (val, nil);
elems))
- OD;
- elements OF res := elems;
- (ch = eof | parse error ("unclosed array in JSON string"));
+ od;
+ elements of res := elems;
+ (ch = eof | parse_error ("unclosed array in JSON string"));
res
- END;
-
- PROC parse object = JSONOBJ:
- BEGIN JSONOBJ res, REF JSONFLD fields;
- FOR i WHILE getchar /= "}"
- DO ungetch := ch;
- IF i > 1 THEN expect char (",") FI;
- JSONVAL name = json from fd (maxchars - usedchars, fd);
- expect char (":");
- JSONVAL value = json from fd (maxchars - usedchars, fd);
- fields := HEAP JSONFLD := (name, value, fields)
- OD;
- fields OF res := fields;
- (ch = eof | parse error ("unclosed object in JSON string"));
+ end;
+
+ proc parse_object = JSONObj:
+ begin JSONObj res, ref JSONFld fields;
+ for i while getchar /= "}"
+ do ungetch := ch;
+ if i > 1 then expect_char (",") fi;
+ JSONVal name = json_from_fd (maxchars - usedchars, fd);
+ expect_char (":");
+ JSONVal value = json_from_fd (maxchars - usedchars, fd);
+ fields := heap JSONFld := (name, value, fields)
+ od;
+ fields of res := fields;
+ (ch = eof | parse_error ("unclosed object in JSON string"));
res
- END;
+ end;
getchar;
- (ch = "t" | expect keyword ("rue"); TRUE
- |: ch = "f" | expect keyword ("alse"); FALSE
- |: isdigit (ch) | parse number
- |: ch = """" | parse string
- |: ch = "[" | parse array
- |: ch = "{" | parse object
- | parse error ("invalid JSON"); SKIP)
-END;
-
-PROC json int = (JSONVAL v) INT:
- (v | (INT i): i | error ("expected integer in json str"); SKIP);
-
-PROC json str = (JSONVAL v) STRING:
- (v | (STRING s): s | error ("expected string in json str"); SKIP);
-
-PROC json foreach elem = (JSONVAL v, PROC(JSONVAL)VOID h) VOID:
-BEGIN CASE v
- IN (JSONARR a):
- (REF JSONELM elem := elements OF a;
- WHILE REF JSONELM (elem) :/=: NIL
- DO h (value OF elem);
- elem := next OF elem
- OD)
- OUT error ("expected array in json foreach elem")
- ESAC
-END;
-
-PROC json obj sel = (JSONVAL v, STRING fname) JSONVAL:
-BEGIN CASE v
- IN (JSONOBJ o):
- BEGIN REF JSONFLD field := fields OF o, BOOL found := FALSE;
- WHILE (REF JSONFLD (field) :/=: NIL) AND NOT found
- DO IF json str (name OF field) = fname
- THEN found := TRUE
- ELSE field := next OF field
- FI
- OD;
+ (ch = "t" | expect_keyword ("rue"); true
+ |: ch = "f" | expect_keyword ("alse"); false
+ |: isdigit (ch) | parse_number
+ |: ch = """" | parse_string
+ |: ch = "[" | parse_array
+ |: ch = "{" | parse_object
+ | parse_error ("invalid JSON"); skip)
+end;
+
+proc json_int = (JSONVal v) int:
+ (v | (int i): i | error ("expected integer in json str"); skip);
+
+proc json_str = (JSONVal v) string:
+ (v | (string s): s | error ("expected string in json str"); skip);
+
+proc json_foreach_elem = (JSONVal v, proc(JSONVal)void h) void:
+begin case v
+ in (JSONArr a):
+ (ref JSONElm elem := elements of a;
+ while elem :/=: json_no_elm
+ do h (value of elem);
+ elem := next of elem
+ od)
+ out error ("expected array in json foreach elem")
+ esac
+end;
+
+proc json_obj_sel = (JSONVal v, string fname) JSONVal:
+begin case v
+ in (JSONObj o):
+ begin ref JSONFld field := fields of o, bool found := false;
+ while (field :/=: json_no_fld) AND NOT found
+ do if json_str (name of field) = fname
+ then found := true
+ else field := next of field
+ fi
+ od;
(NOT found | error ("no " + fname + " field in json object"));
- value OF field
- END
- OUT error ("expected object in json obj sel"); SKIP
- ESAC
-END;
-
-PROC json escape string = (STRING str) STRING:
-BEGIN STRING res;
- FOR i TO UPB str
- DO CHAR newline = REPR 10, tab = REPR 9, c = str[i];
+ value of field
+ end
+ out error ("expected object in json obj sel"); skip
+ esac
+end;
+
+proc json_escape_string = (string str) string:
+begin string res;
+ for i to UPB str
+ do char newline = REPR 10, tab = REPR 9, c = str[i];
(c = "\\" | res +:= "\\\\"
|: c = newline | res +:= "\\n"
|: c = tab | res +:= "\\t"
| res +:= c)
- OD;
+ od;
res
-END;
+end;
diff --git a/src/utils.a68 b/src/utils.a68
index 5029012..a6769b8 100644
--- a/src/utils.a68
+++ b/src/utils.a68
@@ -16,49 +16,51 @@
along with this program. If not, see <http://www.gnu.org/licenses/>.
#
-PROC isdigit = (CHAR c) BOOL:
+# PR SUPPER PR #
+
+proc isdigit = (char c) bool:
ABS c >= ABS "0" AND ABS c <= ABS "9";
-PROC ishexdigit = (CHAR c) BOOL:
+proc ishexdigit = (char c) bool:
((ABS c >= ABS "0" AND ABS c <= ABS "9")
OR (ABS c >= ABS "a" AND ABS c <= ABS "f")
OR (ABS c >= ABS "A" AND ABS c <= ABS "F"));
-PROC atoi = (STRING s, INT base) INT:
-BEGIN
- PROC htoi = (CHAR c) INT:
+proc atoi = (string s, int base) int:
+begin
+ proc htoi = (char c) int:
ABS (c >= "0" AND c <= "9" | REPR (ABS c - ABS "0")
|: c >= "a" AND c <= "f" | REPR (ABS c - ABS "a" + 10)
|: c >= "A" AND c <= "F" | REPR (ABS c - ABS "A" + 10));
- PROC valid = (CHAR c) BOOL:
+ proc valid = (char c) bool:
(base <= 10 | isdigit (c) | ishexdigit (c));
- INT num := 0;
- FOR i TO UPB s WHILE valid (s[i])
- DO num := num * base + htoi (s[i])
- OD;
+ int num := 0;
+ for i to UPB s while valid (s[i])
+ do num := num * base + htoi (s[i])
+ od;
num
-END;
+end;
-PROC itoa = (INT i) STRING:
- IF i = 0
- THEN "0"
- ELSE INT n := ABS i;
- STRING res;
- WHILE n /= 0
- DO INT rem = n %* 10;
+proc itoa = (int i) string:
+ if i = 0
+ then "0"
+ else int n := ABS i;
+ string res;
+ while n /= 0
+ do int rem = n %* 10;
res := REPR (rem > 9
| (rem - 10) + ABS "a"
| rem + ABS "0") + res;
n %:= 10
- OD;
+ od;
(i < 0 | "-" + res | res)
- FI;
+ fi;
-PROC char in string = (STRING s, CHAR c) INT:
-BEGIN INT res := 0, BOOL found := FALSE;
- FOR i TO UPB s WHILE NOT found
- DO (s[i] = c | res := i; found := TRUE) OD;
+proc char_in_string = (string s, char c) int:
+begin int res := 0, bool found := false;
+ for i to UPB s while NOT found
+ do (s[i] = c | res := i; found := true) od;
res
-END;
+end;
--
2.30.2
More information about the Algol68
mailing list