algol68-fringe: New language.

Well, not that new.  But it's a language which wasn't represented here
before.  I'm using the Algol 68 Genie implementation, which works as a
dynamic-ish runtime.  Astonishingly, it can call execve(2) but not
exit(3), so there's an appalling hack.  Sorry.

diff --git a/Makefile b/Makefile
index fea0598..2c43ae8 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -204,6 +204,21 @@ erlang-fringe:
        } >$@.new
        $(V_HIDE)chmod +x $@.new && mv $@.new $@
 
+###--------------------------------------------------------------------------
+### Algol 68.
+
+ALGOL68                         = /usr/local/bin/a68g
+
+LANGS                  += algol68
+TARGETS                        += algol68-fringe
+SOURCES                        += algol68-fringe.a68
+
+algol68-fringe: algol68-fringe.a68
+       $(call v_echo,GENSH){ echo '#! $(ALGOL68) --script';            \
+         cat $<;                                                       \
+       } >$@.new
+       $(V_HIDE)chmod +x $@.new && mv $@.new $@
+
 ###----- That's all, folks --------------------------------------------------
 
 all:: $(TARGETS)

diff --git a/algol68-fringe.a68 b/algol68-fringe.a68
new file mode 100644 (file)
index 0000000..fdea7c8
--- /dev/null
+++ b/algol68-fringe.a68
@@ -0,0 +1,161 @@
+COMMENT -*-algol-68-*-
+
+       Algol 68 implementation of a `same-fringe' solver.
+
+COMMENT
+BEGIN
+
+###--------------------------------------------------------------------------
+# # Reporting errors.
+# #
+# # This stuff is specific to Algol 68 Genie.
+###
+
+[] CHAR program name =
+  BEGIN [] CHAR prog = argv(3);
+  INT i := UPB prog;
+  WHILE (i >= LWB prog | prog[i] /= "/" | FALSE) DO i -:= 1 OD;
+  prog[i + 1:]
+  END;
+
+PROC fail = ([] CHAR message) VOID:
+  ### Mournfully announce an error and quit. 
+  #
+  BEGIN put(stand error, (program name, ": ", message, new line));
+    execve("/bin/false", "false", ())  # Can this be any worse? #
+  END;
+
+###--------------------------------------------------------------------------
+# # Nodes and trees.
+###
+
+MODE NODE = STRUCT (REF NODE left, right, CHAR data);
+
+PROC tree is not empty = (REF NODE node) BOOL: node :/=: NIL;
+
+PROC parse tree = ([] CHAR string) REF NODE:
+  ### Parse STRING, and return the tree described.
+  ##
+  ## The syntax is simple:
+  ##
+  ##     tree ::= empty | `(' tree char tree `)'
+  ##
+  ## The amiguity is resolved by always treating `(' as a tree when a tree
+  ## is expected.
+  #
+  BEGIN INT i := LWB string;
+  PROC parse = REF NODE:
+    BEGIN IF i > UPB string THEN NIL
+      ELIF string[i] /= "(" THEN NIL
+      ELSE i +:= 1;
+        REF NODE left = parse;
+       IF i > UPB string THEN fail("no data") FI;
+       CHAR data = string[i]; i +:= 1;
+       REF NODE right = parse;
+       IF (i > UPB string | TRUE | string[i] /= ")") 
+         THEN fail("missing )") FI;
+       i +:= 1;
+       HEAP NODE := (left, right, data)
+      FI
+    END;
+    REF NODE tree = parse;
+    IF i <= UPB string THEN fail("trailing junk") FI;
+    tree
+  END;
+
+###--------------------------------------------------------------------------
+# # Iteration.
+###
+
+MODE NODEITER = STRUCT (REF [] REF NODE stack, INT sp);
+
+PROC push nodes = (REF NODEITER iter, REF NODE node) VOID:
+  ### Helper function for iteration.
+  ##
+  ## If NODE is not null, push it onto ITER's stack, and then do the same
+  ## for NODE's left child.
+  #
+  BEGIN REF NODE n := node;
+  WHILE tree is not empty(n)
+    DO IF sp OF iter > UPB (stack OF iter)
+      THEN INT max = UPB (stack OF iter);
+       HEAP [2 * max] REF NODE new stack;
+       FOR i FROM 1 TO max DO new stack[i] := (stack OF iter)[i] OD;
+       stack OF iter := new stack
+      FI;
+      (stack OF iter)[sp OF iter] := n;
+      n := left OF n;
+      sp OF iter +:= 1
+    OD
+  END;
+
+PROC next node = (REF NODEITER iter) REF NODE:
+  ### Return the next node in order for the tree being traversed by ITER.
+  ##
+  ## Returns NIL if the iteration is complete.
+  #
+  IF sp OF iter = 1 THEN NIL
+  ELSE sp OF iter -:= 1;
+    REF NODE node = (stack OF iter)[sp OF iter];
+    push nodes(iter, right OF node);
+    node
+  FI;
+
+PROC node iterator = (REF NODE node) REF NODEITER:
+  ### Return a new iterator traversing the tree rooted at NODE.
+  #
+  BEGIN REF NODEITER iter = HEAP NODEITER := (HEAP [1] REF NODE, 1);
+  push nodes(iter, node);
+  iter
+  END;
+
+###--------------------------------------------------------------------------
+# # Fringe operations.
+###
+
+PROC print fringe = (REF NODE tree) VOID:
+  ### Print the characters stored in the tree headed by TREE in order.
+  #
+  BEGIN REF NODEITER iter = node iterator(tree);
+    WHILE REF NODE n = next node(iter); tree is not empty(n)
+    DO print(data OF n) OD;
+    print(new line)
+  END;
+
+PROC same fringes = (REF NODE n, REF NODE nn) BOOL:
+  ### Answer whether traversing the trees rooted at N and NN yields the same
+  ##  items in the same order.
+  #
+  BEGIN REF NODEITER i = node iterator(n), ii = node iterator(nn);
+    BOOL win := FALSE;
+    DO REF NODE n = next node(i), nn = next node(ii); 
+      IF tree is not empty(n)
+      THEN IF tree is not empty(nn)
+        THEN IF data OF n = data OF nn THEN SKIP ELSE done FI
+        ELSE done
+       FI
+      ELIF tree is not empty(nn) THEN done
+      ELSE win := TRUE; done
+      FI
+    OD;
+  done: win
+  END;
+
+###--------------------------------------------------------------------------
+# # Main program.
+# #
+# # Argument fetching is specific to Algol 68 Genie.
+###
+
+CASE argc - 3 IN
+  BEGIN REF NODE tree = parse tree(argv(4));
+    print fringe(tree)
+  END,
+  BEGIN REF NODE t = parse tree(argv(4)), tt = parse tree(argv(5));
+    print(((same fringes(t, tt) | "match" | "no match"), new line))
+  END
+OUT fail("bad args")
+ESAC
+END
+
+###----- That's all, folks -------------------------------------------------#