Another update from ingydotnet^djgoku

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

@@ -1,9 +1,119 @@
-# a user defined object #
-MODE FOO = STRUCT ( ... )
-  FOOOBJECTNEW = STRUCT (FOOMEND foo exception x mended, FOO instance),
-  FOOOBJECT = REF FOOOBJECTNEW,
-  FOOMEND = PROC (FOOOBJECT)BOOL;
+COMMENT
+  Define an general event handling mechanism on MODE OBJ:
+  * try to parallel pythons exception handling flexibility
+END COMMENT
 
-PROC on foo exception x = (FOOOBJECT foo, PROC (FOOOBJECT)BOOL foo exception x mend)VOID: (
-  foo exception x mended OF foo := foo exception x mend
+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

@@ -1,4 +1,48 @@
-PROC raise foo exception x = (FOOOBJECT foo)BOOL:
-  IF NOT (foo exception x mended OF foo instance)(foo instance) THEN
-    except foo exception x
-  FI
+#!/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

Task/Exceptions/Bracmat/exceptions.bracmat

@@ -0,0 +1,17 @@
+( ( MyFunction
+  =   someText XMLstuff
+    .   (   get$!arg:?someText
+          & get$("CorporateData.xml",X,ML):?XMLstuff
+        |     out
+            $ ( str
+              $ ( "Something went wrong when reading your file \""
+                  !arg
+                  "\". Or was it the Corporate Data? Hard to say. Anyhow, now I throw you out."
+                )
+              )
+          & ~
+        )
+      & contemplate$(!someText,!XMLstuff)
+  )
+& MyFunction$"Tralula.txt"
+);

Task/Exceptions/PL-pgSQL/exceptions-1.sql

@@ -0,0 +1,4 @@
+begin
+   raise exception 'this is a generic user exception';
+   raise exception division_by_zero;
+end;

Task/Exceptions/PL-pgSQL/exceptions-2.sql

@@ -0,0 +1,16 @@
+create function special_division(p_num double precision, p_den double precision) returns text
+as $body$
+begin
+   return p_num/p_den::text;
+EXCEPTION
+   when division_by_zero then
+      if p_num>0 then
+         return 'Inf';
+      ELSIF p_num<0 then
+         return '-Inf';
+      else
+         return 'INDEF';
+      end if;
+   when others then
+      raise;
+end;

Task/Exceptions/Perl-6/exceptions-1.pl6

@@ -0,0 +1,17 @@
+try {
+    die "Help I'm dieing!";
+    CATCH {
+        when X::AdHoc { note .Str.uc; say "Cough, Cough, Aiee!!" }
+        default { note "Unexpected exception, $_!" }
+    }
+}
+
+say "Yay. I'm alive.";
+
+die "I'm dead.";
+
+say "Arrgh.";
+
+CATCH {
+    default { note "No you're not."; say $_.Str; }
+}

Task/Exceptions/Perl-6/exceptions-2.pl6

@@ -0,0 +1,13 @@
+sub f(){
+        ENTER { note '1) f has been entered' }
+        LEAVE { note '2) f has been left' }
+        say '3) here be dragons';
+        die '4) that happend to be deadly';
+}
+
+f();
+say '5) am I alive?';
+
+CATCH {
+        when X::AdHoc { note q{6) no, I'm dead}; }
+}

Task/Exceptions/Perl-6/exceptions.pl6

@@ -1,9 +0,0 @@
-try { die "Help I'm dieing!"; CATCH { note $_.uc; say "Cough, Cough, Aiee!!" } }
-
-CATCH { note "No you're not."; say $_; }
-
-say "Yay. I'm alive.";
-
-die "I'm dead.";
-
-say "Arrgh.";

Task/Exceptions/REXX/exceptions.rexx

@@ -1,16 +1,15 @@
-/*REXX pgm to demonstrate handling an exception; catching is via a label*/
-          do j=9  by -5  for 100
+/*REXX program demonstrates handling an exception;   catching is via a label. */
+          do j=9  by -5
           say  'square root of'  j  "is"  sqrt(j)
           end   /*j*/
-exit                                   /*stick a fork in it, we're done.*/
+exit                                   /*stick a fork in it,  we're all done. */
 
 .sqrtNeg: say  'illegal SQRT argument (argument is negative):'  x
-exit                                   /*exit (terminate) this program. */
-
-/*─────────────────────────────────────SQRT subroutine──────────────────*/
-sqrt: procedure; parse arg x; if x=0 then return 0; d=digits();numeric dig
-      g=.sqrtGuess();       do j=0 while p>9;  m.j=p;  p=p%2+1;   end
-      do k=j+5 to 0 by -1; if m.k>11 then numeric digits m.k; g=.5*(g+x/g)
-      numeric digits d;  return g/1
-.sqrtGuess: if x<0  then signal .sqrtNeg;  numeric form;   m.=11;   p=d+d%
-      parse value format(x,2,1,,0) 'E0' with g 'E' _ .;   return g*.5'E'_%
+exit                                   /*stick a fork in it,  we're all done. */
+/*────────────────────────────────────────────────────────────────────────────*/
+sqrt: procedure; parse arg x;   if x=0  then return 0;  d=digits();  m.=9
+      numeric digits 9; numeric form; h=d+6;        if x<0  then signal .sqrtNeg
+      parse value format(x,2,1,,0) 'E0'  with  g 'E' _ .;       g=g*.5'e'_%2
+         do j=0  while h>9;      m.j=h;              h=h%2+1;         end  /*j*/
+         do k=j+5  to 0  by -1;  numeric digits m.k; g=(g+x/g)*.5;    end  /*k*/
+      numeric digits d;     return (g/1)             /*make complex if  X < 0.*/