Data commit

Task/Exceptions/ALGOL-68/exceptions-1.alg

@@ -0,0 +1,119 @@
+COMMENT
+  Define an general event handling mechanism on MODE OBJ:
+  * try to parallel pythons exception handling flexibility
+END COMMENT
+
+COMMENT
+  REQUIRES:
+    MODE OBJ # These can be a UNION of REF types #
+    OP OBJIS
+  PROVIDES:
+    OP ON, RAISE, RESET
+    PROC obj on, obj raise, obj reset
+END COMMENT
+
+# define object related to OBJ EVENTS #
+MODE
+  RAISEOBJ = PROC(OBJ)VOID, RAWMENDOBJ = PROC(OBJ)BOOL,
+  MENDOBJ = UNION(RAWMENDOBJ, PROC VOID), # Generalise: Allow PROC VOID (a GOTO) as a short hand #
+  NEWSCOPEOBJ = STRUCT(REF NEWSCOPEOBJ up, FLEXOBJ obj flex, FLEXEVENTOBJ event flex, MENDOBJ mended),
+  SCOPEOBJ = REF NEWSCOPEOBJ;
+
+MODE FLEXOBJ=FLEX[0]OBJ;
+
+# Provide an INIT to convert a GO TO to a MEND ... useful for direct aborts #
+OP INITMENDOBJ = (PROC VOID go to)MENDOBJ: (go to; SKIP);
+
+SCOPEOBJ obj scope end = NIL;
+SCOPEOBJ obj scope begin := obj scope end; # INITialise stack #
+OBJ obj any = EMPTY;
+EVENTOBJ obj event any = NIL;
+
+# Some crude Singly Linked-List manipulations of the scopes, aka stack ... #
+# An event/mended can be shared for all OBJ of the same type: #
+PRIO INITAB = 1, +=: = 1;
+OP INITAB = (SCOPEOBJ lhs, MENDOBJ obj mend)SCOPEOBJ:
+  lhs := (obj scope end, obj any, obj event any, obj mend);
+
+OP INITSCOPE = (MENDOBJ obj mend)SCOPEOBJ: HEAP NEWSCOPEOBJ INITAB obj mend;
+OP +=: = (SCOPEOBJ item, REF SCOPEOBJ rhs)SCOPEOBJ: ( up OF item := rhs; rhs := item );
+OP +=: = (MENDOBJ mend, REF SCOPEOBJ rhs)SCOPEOBJ: INITSCOPE mend +=: rhs;
+#OP -=: = (REF SCOPEOBJ scope)SCOPEOBJ: scope := up OF scope;#
+
+COMMENT Restore the prio event scope: ~ END COMMENT
+PROC obj reset = (SCOPEOBJ up scope)VOID: obj scope begin := up scope;
+MENDOBJ obj unmendable = (OBJ obj)BOOL: FALSE;
+
+MODE NEWEVENTOBJ = STRUCT( # the is simple a typed place holder #
+  SCOPEOBJ scope,
+  STRING description,
+  PROC (OBJ #obj#, MENDOBJ #obj mend#)SCOPEOBJ on,
+  PROC (OBJ #obj#, STRING #msg#)VOID raise
+), EVENTOBJ = REF NEWEVENTOBJ;
+
+MODE FLEXEVENTOBJ = FLEX[0]EVENTOBJ;
+
+COMMENT Define how to catch an event:
+    obj - IF obj IS NIL then mend event on all OBJects
+    obj mend - PROC to call to repair the object
+    return the prior event scope
+END COMMENT
+PROC obj on = (FLEXOBJ obj flex, FLEXEVENTOBJ event flex, MENDOBJ mend)SCOPEOBJ: (
+  mend +=: obj scope begin;
+  IF obj any ISNTIN obj flex THEN obj flex OF obj scope begin := obj flex FI;
+  IF obj event any ISNTIN event flex THEN event flex OF obj scope begin := event flex FI;
+  up OF obj scope begin
+);
+
+PRIO OBJIS = 4, OBJISNT = 4; # pick the same PRIOrity as EQ and NE #
+OP OBJISNT = (OBJ a,b)BOOL: NOT(a OBJIS b);
+
+PRIO ISIN = 4, ISNTIN = 4;
+OP ISNTIN = (OBJ obj, FLEXOBJ obj flex)BOOL: (
+  BOOL isnt in := FALSE;
+  FOR i TO UPB obj flex WHILE isnt in := obj OBJISNT obj flex[i] DO SKIP OD;
+  isnt in
+);
+OP ISIN = (OBJ obj, FLEXOBJ obj flex)BOOL: NOT(obj ISNTIN obj flex);
+
+OP ISNTIN = (EVENTOBJ event, FLEXEVENTOBJ event flex)BOOL: (
+  BOOL isnt in := TRUE;
+  FOR i TO UPB event flex WHILE isnt in := event ISNT event flex[i] DO SKIP OD;
+  isnt in
+);
+OP ISIN = (EVENTOBJ event, FLEXEVENTOBJ event flex)BOOL: NOT(event ISNTIN event flex);
+
+COMMENT Define how to raise an event, once it is raised try and mend it:
+  if all else fails produce an error message and stop
+END COMMENT
+PROC obj raise = (OBJ obj, EVENTOBJ event, STRING msg)VOID:(
+  SCOPEOBJ this scope := obj scope begin;
+# until mended this event should cascade through scope event handlers/members #
+  FOR i WHILE this scope ISNT SCOPEOBJ(obj scope end) DO
+    IF (obj any ISIN obj flex OF this scope OR obj ISIN obj flex OF this scope ) AND
+       (obj event any ISIN event flex OF this scope OR event ISIN event flex OF this scope)
+    THEN
+      CASE mended OF this scope IN
+        (RAWMENDOBJ mend):IF mend(obj) THEN break mended FI,
+        (PROC VOID go to): (go to; stop)
+      OUT put(stand error, "undefined: raise stop"); stop
+      ESAC
+    FI;
+    this scope := up OF this scope
+  OD;
+  put(stand error, ("OBJ event: ",msg)); stop; FALSE
+EXIT
+  break mended: TRUE
+);
+
+CO define ON and some useful(?) RAISE OPs CO
+PRIO ON = 1, RAISE = 1;
+OP ON = (MENDOBJ mend, EVENTOBJ event)SCOPEOBJ: obj on(obj any, event, mend),
+   RAISE = (OBJ obj, EVENTOBJ event)VOID: obj raise(obj, event, "unnamed event"),
+   RAISE = (OBJ obj, MENDOBJ mend)VOID: ( mend ON obj event any; obj RAISE obj event any),
+   RAISE = (EVENTOBJ event)VOID: obj raise(obj any, event, "unnamed event"),
+   RAISE = (MENDOBJ mend)VOID: ( mend ON obj event any; RAISE obj event any),
+   RAISE = (STRING msg, EVENTOBJ event)VOID: obj raise(obj any, event, msg);
+OP (SCOPEOBJ #up scope#)VOID RESET = obj reset;
+
+SKIP

Task/Exceptions/ALGOL-68/exceptions-2.alg

@@ -0,0 +1,48 @@
+#!/usr/bin/a68g --script #
+
+MODE OBJ=UNION(REF INT, REF REAL, REF STRING,# etc # VOID);
+
+OP OBJIS = (OBJ a,b)BOOL: # Are a and b at the same address? #
+  CASE a IN # Ironically Algol68's STRONG typing means we cannot simply compare addresses #
+    (REF INT a): a IS (b|(REF INT b):b|NIL),
+    (REF REAL a): a IS (b|(REF REAL b):b|NIL),
+    (REF STRING a): a IS (b|(REF STRING b):b|NIL)
+  OUT FALSE
+  ESAC;
+
+PR READ "prelude/event_base(obj).a68" PR;
+NEWEVENTOBJ obj eventa := SKIP;
+NEWEVENTOBJ obj eventb := SKIP;
+NEWEVENTOBJ user defined exception := SKIP;
+
+# An event can be continued "mended" or break "unmended" #
+PROC found sum sqs continue = (OBJ obj)BOOL: ( print("."); TRUE); # mended #
+PROC found sum sqs break = (OBJ obj)BOOL: (found sq sum sqs; FALSE); # unmended #
+
+INT sum sqs:=0;
+REAL x:=111, y:=222, z:=333;
+
+SCOPEOBJ obj scope reset := obj on((sum sqs, x,y,z), (obj eventa,obj eventb), VOID:found sq sum sqs);
+
+# An event handler specific to the specific object instance: #
+#SCOPEOBJ obj scope reset := obj on eventb(sum sqs, VOID:found sq sum sqs);#
+
+# Or... An "obj any" event handler: #
+# SCOPEOBJ obj scope reset := found sum sqs break ON obj eventb; #
+
+# Raise the "event eventb" on an object: #
+  FOR i DO
+    sum sqs +:= i*i;
+    IF sum sqs = 70*70 THEN # 1st try to use an instance specific mend on the object #
+      obj raise(sum sqs, obj eventb, "Found a sq sum of sqs") FI; # OR ... #
+    IF sum sqs = 70*70 THEN "Found a sq sum of sqs" RAISE obj eventb FI; # OR ... #
+    IF sum sqs = 70*70 THEN RAISE found sum sqs break FI # simplest #
+  OD;
+  RESET obj scope reset # need to manually reset back to prior handlers #
+
+# Catch "event eventb": #
+EXIT found sq sum sqs:
+  print(("sum sqs:",sum sqs, new line)); # event eventb caught code here ... #
+  RESET obj scope reset;
+
+  "finally: raise the base unmendable event" RAISE obj eventb