13.2 Betaenv Interface

LIB_DEF 'betaenv' '../lib';
BODY 'private/betaenvbody';
(*
 * COPYRIGHT
 *       Copyright (C) Mjolner Informatics, 1984-96
 *       All rights reserved.
 *
 * This fragment implements the very basic patterns, utilized by most
 * BETA programs
 *)
-- betaenv: descriptor --
(# <<SLOT lib: attributes>>;
   (******************************************************************)
   (* The simple patterns for simple values and variables.  These
    * simple patterns are treated special by the compiler.
    *)
   integer: (* 32 bit signed long *) (# #);
   shortInt: (* 16 bit unsigned half *) (# #); (* do not use shortInt anymore,
                                                * use int16u instead.
                                                *)
   char: (* 8 bit unsigned byte *) (# #);
   boolean: (* 8 bit unsigned byte, values 0 or 1 *) (# #);
   false: boolean (* 8 bit unsigned byte with value 0 *) (# #);
   true: boolean (* 8 bit unsigned byte with value 1 *) (# #);
   real: (* double precision floating point number *) (# #);
   
   int8: (* 8 bit signed integer *) (# #); 
   int8u: (* 8 bit unsigned integer *) (# #);
   int16: (* 16 bit signed integer *) (# #);
   int16u: (* 16 bit unsigned integer.
            * int16u will eventually replace shortInt *) (# #);
   int32: (* 32 bit signed integer
           * int32 is semantically identical to integer *) (# #);
   int32u: (* 32 bit unsigned integer *) (# #);
   
   (* int64 and int64u are NOT yet implemented;
    * the compiler allows variables of these types,
    * but no operations, including assignment,
    * are implemented, so don't use them.
    *)
   int64: (* 64 bit signed integer *) (# #); 
   int64u: (* 64 bit unsigned integer *) (# #);
   
   (* The pattern wchar is for experimenting with implementing
    * support for the UniCode character set. The name wchar
    * is preliminary. wchar is semantically identical to int16u.
    * Patterns wcharValue and wcharObject have also been introduced below
    *)
   wchar: (# #); (* 16 bit unsigend integer *)
   
   (* The pattern COM is a general super pattern for
    * objects that may used with Microsoft COM
    *)
   COM: (# #); 
    
   (* Holder is general superpattern for holder-patterns used for 
    * parameters in COM.
    *)
   Holder: (# adr: @integer #);   
   
   object: (* General superpattern *)
     (# _struc: 
          (* Exit a pattern reference for THIS(Object).
           * Is now obsolete: the new form obj## is preferred
           * to the old form obj.struc
           *)
          (#
          exit this(object)##
          #);
        _new: 
          (* returns a new object, that is qualified exactly
           * as THIS(object)
           *)
          (# newObj: ^object; oType: ##object
          do this(object)##->oType##; &oType[]->newObj[]; INNER _new
          exit newObj[]
          #);
        _state: 
          (* Pattern _state is for experimental purpose only
           * and using it may give undefined results 
           *)
          (# S: ##object
          enter S##
          ...
          #)
     do INNER object
     #);
   (* idx *)
   
   (* The following patterns define 'real' patterns corresponding to
    * the predefined simple patterns
    *)
   integerValue: (# value: @integer do INNER integerValue exit value #);
   integerObject: integerValue(# enter value do INNER integerObject #);
   charValue: (# value: @char do INNER charValue exit value #);
   charObject: charValue(# enter value do INNER charObject #);
   wcharValue: (# value: @wchar do INNER wcharValue exit value #);
   wcharObject: wcharValue(# enter value do INNER wcharObject #);
   booleanValue: (# value: @boolean do INNER booleanValue exit value #);
   booleanObject: booleanValue(# enter value do INNER booleanObject #);
   trueObject: booleanObject(# do true->value; INNER trueObject #);
   falseObject: booleanObject(# do INNER falseObject #);
   realValue: (# value: @real do INNER realValue exit value #);
   realObject: realValue(# enter value do INNER realObject #);
   
   (****  Integer limits *********************************************) 
   MaxInt8:   (# exit 0x7f #);
   MinInt8:   (# exit 0x80 #);
   MaxInt8u:  (# exit 0xff #);
   MinInt8u:  (# exit 0x00 #);
   
   MaxInt16:  (# exit 0x7fff #);
   MinInt16:  (# exit 0x8000 #);
   MaxInt16u: (# exit 0xffff #);
   MinInt16u: (# exit 0x0000 #);
   
   MaxInt32:  (# exit 0x7fffffff #);
   MinInt32:  (# exit 0x80000000 #);
   MaxInt32u: (# exit 0xffffffff #);
   MinInt32u: (# exit 0x00000000 #);
   
   MaxInt:    (# exit MaxInt32 #);
   MinInt:    (# exit MinInt32 #);
   
   MaxReal:   (# exit 1.797693134862315E+308 #);
   MinReal:   (# exit 2.225073858507201E-308 #);

   (****  Implementation dependent constants *************************) 
   infReal: (* Returns the real value 'Infinity' *)
     realValue(# ... #);
   
   (*****  Functional patterns ***************************************)
   min: (* Returns the minimum of 2 integers *)
     (# a,b: @integer
     enter (a,b)
     do (if (a < b) then a->b if)
     exit b
     #);
   max: (* Returns the maximum of 2 integers *)
     (# a,b: @integer
     enter (a,b)
     do (if (a < b) then b->a if)
     exit a
     #);
   abs: (* Returns the absolute value of an integer *)
     (# n: @integer
     enter n
     do (if (n < 0) then -n->n if)
     exit n
     #);
   
   (*****  Simple standard input/output patterns *********************)
   keyboard, screen: ^stream;
   get:
     (# ch: @char; getC: @keyboard.get do getC->ch; INNER get exit ch #);
   put:
     (# ch: @char; putC: @screen.put enter ch do INNER put; ch->putC #);
   newline:
     screen.newline(# #);
   putint:
     screen.putint(# do INNER putint #);
   getint:
     keyBoard.getint(# do INNER getint #);
   puttext:
     (# t: ^text; putT: @screen.puttext
     enter t[]
     do INNER puttext; t[]->putT
     #);
   putline:
     screen.putline(# do INNER putline #);
   getNonBlank:
     keyBoard.getNonBlank(# do INNER getNonBlank #);
   scanAtom:
     keyBoard.scanAtom(# do INNER scanAtom #);
   getAtom:
     (# t: ^text; getA: @keyBoard.getAtom
     do getA->t[]; INNER getAtom
     exit t[]
     #);
   getline:
     (# t: ^text; getL: @keyBoard.getline
     do getL->t[]; INNER getline
     exit t[]
     #);
   
   (*****  Control patterns ******************************************)
   forTo: (* for 'inx' in [low:high] do INNER forTo *)
     (# low, high, inx: @integer;
     enter (low, high)
     ...  
     #);
   cycle: (* Executes INNER forever *)
     (# ... #);
   loop: 
     (# while:< booleanValue(# do true->value; INNER while #);
        until:< booleanValue;
        whilecondition: @while;
        untilcondition: @until;
     ...
     #);
   qua:
     (* Pattern replacing the BETA language construct QUA.  To be
      * used as 't1[]->qua(# as::< Tn #)->t2[]'.  The 'qua' pattern
      * checks, whether 't1' is qualified by 'Tn'.  If not, the
      * 'quaError' exception is invoked.  Otherwise, a reference
      * qualified by 'Tn', and referring to the same object as 't1[]'
      * is referring, is returned.
      *)
     (# as:< object; R: ^object; thisObj: ^as;
        quaError:< exception
          (# do 'Qualification error'->msg.append; INNER quaError #)
     enter R[]
     ...  
     exit thisObj[]
     #);
   
   (*****  Stream patterns *******************************************)
   stream: 
     (# <<SLOT streamLib: attributes>>;
        length:< integerValue (* returns the length of THIS(stream) *)
          (#
          do -1->value; INNER length
          #);
        position: (* current position of THIS(stream) *)
          (# 
          enter setPos
          exit getPos
          #);
        eos:< (* returns 'true' if THIS(stream) is at end-of-stream *)
          booleanValue;
        reset: (* sets 'position' to zero *)
          (#
          do 0->setPos
          exit THIS(stream)[]
          #);
        peek:< (* looks at the next character of THIS(stream) *)
          (# ch: @char
          do INNER peek
          exit ch
          #);
        get:< (* reads a character from THIS(stream) *)
          (# ch: @char
          do INNER get
          exit ch
          #);
        getNonBlank: 
          (* Reads first non-whitespace character from THIS(stream).
           * If called at end-of-stream the character 'ascii.fs' is
           * returned
           *)
          (# ch: @char;
             skipblanks: @scanWhiteSpace;
             testEOS: @EOS;
             getCh: @get;
          ...
          exit ch
          #);
        getint: integerValue
          (* Reads an integer: skips whitespace characters and
           * returns the following digits.
           * 
           * See numberio.bet for more numerical output operations
           *)
          (# syntaxError:< streamException
               (# 
               ...
               #);
             geti: @... 
          do geti; INNER getint
          #);
        getAtom:<
          (* Returns the next atom (i.e. sequence of non-white
           * characters - skipping leading blanks)
           *)
          (# txt: ^text;
          do &text[]->txt[]; INNER getAtom;
          exit txt[]
          #);
        getline:<
          (* Reads a sequence of characters until nl-character
           * appears and returns the characters read.
           *)
          (# txt: ^text;
             missing_newline:< Object
               (* Called if last line of THIS(Stream) is
                * not terminated by a newline character.
                *);
          do &text[]->txt[]; INNER getline
          exit txt[]
          #);
        asInt:
          (* converts THIS(text) to an integer value, ignoring
           * leading and trailing whitespace.  See numberio.bet for
           * more numerical conversion operations.
           *)
          (# i: @integer;
             syntaxError:< streamException
               (# 
               ...
               #);
          ...
          exit i
          #);
        put:< (* writes a character to THIS(stream) *)
          (# ch: @char
          enter ch
          do INNER put
          exit THIS(stream)[]
          #);
        newline: (* writes the nl-character *) 
          (#
          do ascii.newline->put
          exit THIS(stream)[]
          #);
        putint: 
          (* Writes an integer to THIS(stream); The format may be
           * controlled by the 'signed', 'blankSign', 'width',
           * 'adjustLeft' and 'zeroPadding' variable attributes.
           * 'width' is extended if it is too small.  Examples:
           * '10->putint' yields: '10'; '10*pi->putint(# do 10->width;
           * true->adjustLeft #)' yields: '10 '; and '10->putint(# do
           * 10->width; true->zeroPadding #)' yields: '0000000010'.
           * 
           * See numberio.bet for more numerical output operations
           *)
          (# n: @integer;
             signed: @boolean
               (* If integer is positive, a '+' will always be
                * displayed
                *);
             blankSign: @boolean 
               (* If integer is positive, a ' ' space is displayed as
                * the sign.  Ignored if 'signed=true'
                *);
             width: @integer
               (* Minimum width *);
             adjustLeft: @boolean
               (* Specifies if the number is to be aligned left or
                * right, if padding of spaces is necessary to fill up
                * the specified width.
                *);
             zeroPadding: @boolean
               (* width is padded with leading zero instead of
                * spaces.  Ignored if 'adjustLeft=true'
                *);
             format:< (# do INNER format #);
             puti: @...
          enter n
          do 1->width; format; INNER putint; puti
          exit THIS(stream)[]
          #);
        puttext:< (* Writes a text to THIS(stream). *)
          (# txt: ^text
          enter txt[]
          do (if txt[]<>NONE then INNER puttext if)
          exit THIS(stream)[]
          #);
        putline: 
          (* 'puttext' followed by 'newline' *)
          (# T: ^text; putT: @puttext; newL: @newline
          enter T[]
          do INNER putline; T[]->putT; newL
          exit THIS(stream)[]
          #);
        scan: 
          (* Scan chars from current position in THIS(stream) while
           * '(ch->while)=true'; perform INNER for each char being
           * scanned
           *)
          (# while:<
               (# ch: @char; value: @boolean
               enter ch
               do true->value; INNER while
               exit value
               #);
             ch: @char;
             whilecondition: @while;
             testEOS: @EOS;
             getPeek: @peek;
             getCh: @get;
          ...
          exit THIS(stream)[]
          #);
        scanWhiteSpace: scan 
          (* Scan whitespace characters *)
          (# while::< (# do ch->ascii.isWhiteSpace->value #)
          do INNER scanWhiteSpace
          exit THIS(stream)[]
          #);
        scanAtom: 
          (* Scan until first non-whitespace char.  Scan the next
           * sequence of non-whitespace chars.  Stop at first
           * whitespace char.  For each non-whitespace char an INNER
           * is performed. Usage: 'scanAtom(# do ch-><destination> #)'
           *)
          (# ch: @char;
          ...
          exit THIS(stream)[]
          #);
        scanToNl: 
          (* Scan all chars in current line including newline char *)
          (# ch: @char; getCh: @get;
             missing_newline:< Object
               (* Called if last line of THIS(Stream) is
                * not terminated by a newline character.
                *);
          ...
          exit THIS(stream)[]
          #);
        streamException: exception
          (# do INNER streamException #);
        EOSerror:< streamException
          (* Raised from 'get' and 'peek' when attempted to read past
           * the end of the stream.
           *)
          (# 
          do 'Attempt to read past end-of-stream'->msg.putline; 
             INNER EOSerror
          #);
        otherError:< streamException
          (* Raised when some other kind of stream error apart from
           * the one mentioned above occurs.
           *);
        getPos:< (* returns current position of THIS(Stream) *)
          integerValue;
        setPos:< (* sets current position in THIS(stream) to 'p' *)
          (# p: @integer
          enter p
          do INNER setPos
          exit THIS(stream)[]
          #)
     #); (* pattern stream *)
   
   (*****  Text pattern **********************************************)
   text: stream
     (* A text is a sequence of characters.  Let 'T: @text'. The
      * range of 'T' is '[1,T.length]'.  A text can be initialized by
      * executing 'T.clear' or by assigning it another (initialized)
      * text.  A text-constant has the form 'foo'.  The 'text' pattern
      * is primarily intended for small texts but there is no upper
      * limit in the size. However, most of the operations becomes
      * less efficient with larger texts.
      *)
     (# <<SLOT textLib: attributes>>;
        length::< (* Returns the length of THIS(text) *) 
          (# do lgth->value; INNER length #);
        eos::<
          (# ... #);
        empty: 
          (# exit (lgth = 0) #);
        clear: (* Sets the length and position of THIS(text) to zero *)
          (#
          do 0->pos->lgth
          exit THIS(text)[]
          #);
        equal: booleanValue
          (* Tests if THIS(text) is equal to the entered text.  If
           * 'NCS' is further bound to 'trueObject', the comparison
           * will be done Non Case Sensitive.
           *)
          (# txt: ^text;
             NCS:< booleanObject
          enter txt[]
          ...
          #);
        equalNCS: equal
          (* As 'equal', except the the comparison will be done Non
           * Case Sensitive
           *)
          (# NCS:: trueObject #);
        less: booleanValue
          (* Tests whether the entered text 'T1[1: length]' is less
           * than 'THIS(text)[1: T1.length]'.  The lexicographical
           * ordering is used.
           *)
          (# T1: ^text
          enter T1[]
          ...
          #);
        greater: booleanValue
          (* Tests whether the entered text 'T1[1: length]' is
           * greater than 'THIS(text)[1: T1.length]'.  The
           * lexicographical ordering is used.
           *)
          (# T1: ^text
          enter T1[]
          ...
          #);
        peek::<
          (* Returns the character at current position; does not
           * update 'position'
           *)
          (# ... #);
        get::<
          (* Returns the character at current position; increments
           * 'position'
           *) 
          (# ... #);
        inxGet: charValue
          (* Returns the character at position 'i' *)
          (# i: @integer;
             iget: @...
          enter i
          do iget
          #);
        getAtom::<
          (* Returns the next atom (i.e. sequence of non-white
           * characters - skipping leading blanks)
           *)
          (# ... #);
        getline::<
          (* Reads a sequence of characters until nl-character
           * appears and returns the characters read.
           *)
          (# ... #);
        put::<
          (* writes the character 'ch' at current position in
           * THIS(text); increments 'position'
           *) 
          (# ... #);
        inxPut: 
          (* Replaces the character at position 'i' *)
          (# ch: @char;
             i: @integer;
             iput: @...
          enter (ch,i)
          do iput
          exit THIS(text)[]
          #);
        puttext::<
          (# ... #);
        append: 
          (* Appends a text to THIS(text); does not change 'position'
           *)
          (# T1: ^text
          enter T1[]
          ...
          exit THIS(text)[]
          #);
        prepend: 
          (* Inserts the text in 'T1' in front of THIS(text); updates
           * current position to 'position+T1.length' if 'position>0'
           *)
          (# T1: ^text
          enter T1[]
          ...
          exit THIS(text)[]
          #);
        insert: 
          (* Inserts a text before the character at position 'inx'.
           * Note: inx<1 means inx=1; inx>length means inx=length+1.
           * If 'position>=inx' then 'position+T1.length->position'.
           *)
          (# T1: ^text;
             inx: @integer
          enter (T1[],inx)
          ...
          exit THIS(text)[]
          #);
        delete: 
          (* Deletes THIS(text)[i: j]; updates current position:
           *      i<=position<j => i-1->position
           *      j<=position   => position-(j-i+1)->position
           *)
          (# i,j: @integer; 
             deleteT: @...
          enter (i,j)
          do deleteT
          exit THIS(text)[]
          #);
        makeLC: (* Converts all characters to lower case *)
          (# ...
          exit THIS(text)[]
          #);
        makeUC: 
          (* Converts all characters to upper case *)
          (# ...
          exit THIS(text)[]
          #);
        sub:
          (* Returns a copy of THIS(text)[i:j].  If 'i<1', 'i' is
           * adjusted to 1. If 'j>length', 'j' is adjusted to
           * 'length'.  If (after adjustment) 'i>j', an empty text is
           * returned.
           *)
          (# i,j: @integer; T1: ^text;
             subI: @...
          enter (i,j)
          do subI
          exit T1[]
          #);
        copy: 
          (# T1: ^text;
             copyI: @...
          do copyI
          exit T1[]
          #);
        scanAll: 
          (* Scans all the elements in THIS(text).  For 'ch' in '[1:
           * THIS(text).length]' do INNER
           *)
          (# ch: @char
          do (for i: lgth repeat T[i]->ch; INNER scanAll for)
          exit THIS(text)[]
          #);
        find:
          (* find all occurrences of the character 'ch' in
           * THIS(text), executing INNER for each occurrence found,
           * beginning at 'THIS(text).position'.  'inx' will contain
           * the position of each 'ch' in THIS(text).  If 'NCS' is
           * further bound to 'trueObject', the comparison will be
           * done Non Case Sensitive.  If 'from' is further bound, the
           * search will begin at position 'from'.
           *)
          (# ch: @char;
             inx: @integer;
             NCS:< booleanObject;
             from:< integerObject(# do pos->value; INNER from #)
          enter ch
          ...
          exit THIS(text)[]
          #);
        findAll: find
          (* As 'find', except that the entire text will be searched.
           * Replaces 'findCh' in previous versions of betaenv (v1.4
           * and earlier)
           *)
          (# from:: (# do 0->value #)
          do INNER findAll
          #);
        findText:
          (* find all occurrences of the 'txt' in THIS(text),
           * executing INNER for each occurrence found, beginning at
           * 'THIS(text).position'.  'inx' will contain the position
           * of the first character of each occurrence found
           * THIS(text).  If 'NCS' is further bound to 'trueObject',
           * the comparison will be done Non Case Sensitive.  If
           * 'from' is further bound, the search will begin at
           * position 'from'.
           *)
          (# txt: ^text;
             inx: @integer;
             NCS:< booleanObject;
             from:< integerObject(# do pos->value; INNER from #)
          enter txt[]
          ...
          exit THIS(text)[]
          #);
        findTextAll: findText
          (* As 'findText', except that the entire text will be
           * searched
           *)
          (# from:: (# do 0->value #)
          do INNER findTextAll
          #);
        extend: 
          (* Extend THIS(text) with 'L' (undefined) chars. Notice
           * that it is only the representation of the THIS(text),
           * that is extended, the 'length' and 'position' are not
           * changed.
           *)
          (# L: @integer
          enter L do L->T.extend
          exit THIS(text)[]
          #);
        indexError:< streamException
          (* Raised from 'Check' when the index goes outside the
           * range of the text. Message: "Index error in text!".
           *)
          (# inx: @integer 
          enter inx
          ...
          #);
        EOSerror::<
          (* Raised from 'get' and 'peek' when the end of the stream is
           * passed.
           *) 
          (# ... #);
        otherError::<
          (* Raised when an error other than the Index-/EOSerror
           * occurs.
           *) 
          (# ... #);
        setPos::<
         (# ... #);
        getPos::<
          (# do pos->value; INNER getPos #);
        (* Private attributes: !!OBS!! The 3 attributes 'T', 'lgth'
         * and 'pos' declared below MUST be the first data items
         * declared in 'stream' and 'text' since their addresses are
         * hardcoded into the compiler.
         *)
        T: [16] @char;
        lgth,pos: (* 16 is default size *) @integer;
        setT: (# enter T do T.range->lgth->pos #)
     enter setT
     exit T[1: lgth]
     #) (* Pattern text *); 
   
   (*****  ASCII character constants and attributes ******************)
   ascii: @
     (# <<SLOT asciiLib: attributes>>;
        nul: (# exit 0 #);
        soh: (# exit 1 #);
        stx: (# exit 2 #);
        etx: (# exit 3 #);
        eot: (# exit 4 #);
        enq: (# exit 5 #);
        ack: (# exit 6 #);
        bel: (# exit 7 #);
        bs: (# exit 8 #);
        ht: (# exit 9 #);
        nl: (# exit 10 #);
        vt: (# exit 11 #);
        np: (# exit 12 #);
        cr: (# exit 13 #);
        so: (# exit 14 #);
        si: (# exit 15 #);
        dle: (# exit 16 #);
        dc1: (# exit 17 #);
        dc2: (# exit 18 #);
        dc3: (# exit 19 #);
        dc4: (# exit 20 #);
        nak: (# exit 21 #);
        syn: (# exit 22 #);
        etb: (# exit 23 #);
        can: (# exit 24 #);
        em: (# exit 25 #);
        sub: (# exit 26 #);
        esc: (# exit 27 #);
        fs: (# exit 28 #);
        gs: (# exit 29 #);
        rs: (# exit 30 #);
        us: (# exit 31 #);
        sp: (# exit 32 #);
        capA: (# exit 65 #);
        smalla: (# exit 97 #);
        del: (# exit 127 #);
        newline: @char; (* either 'lf' or 'cr' *)
        
        init: ...;
        upCase: @charObject
          (# ... #);
        lowCase: @charObject
          (# ... #);
        testChar: booleanValue
          (# ch: @char
          enter ch
          do INNER testchar
          #);
        isUpper: @testChar
          (# ... #);
        isLower: @testChar
          (# ... #);
        isDigit: @testChar
          (# ... #);
        isLetter: @testChar
          (# ... #);
        isSpace: @testChar
          (* True if 'ch' in {sp,cr,nl,np,ht,vt} *) 
          (# ... #);
        isWhiteSpace: @testChar
          (* True if 'ch' is a whitespace char *) 
          (# ... #);
        private: @...
     #);
   (*****  Exception Patterns ****************************************)
   stop: 
     (* Terminates program execution: 
      *   termCode=normal       : normal termination; 
      *   termCode=failure      : abnormal termination;
      *   termCode=failureTrace : abnormal termination with trace of
      *                           run-time stack on dump-file; 
      *   termCode=dumpStack    : Trace of run-time stack on console 
      *                           without termination.
      * 
      * 'T' will be printed on the screen.
      *)
     (# termCode: @integer; T: ^text
     enter (termCode,T[])
     ...
     #);
   normal: (# exit 0 #);
   failure: (# exit -1 #);
   failureTrace: (# exit -2 #);
   dumpStack: (# exit -3 #);
   exception:
     (# <<SLOT exceptionLib: attributes>>;
        msg:
          (* append text to this 'msg' vatiable to specify the
           * exception error message for this(exception)
           *)
          @text;
        continue: @boolean
          (* the valur of this variable determines the control-flow
           * behaviour of this(exception): 
           *    true:  continue execution after exception
           *    false: terminate execution by calling 'stop'; default
           *);
        propagate:<
          (* if further bound to trueObject, this(exception) allows
           * propagation (i.e. this(exception will _not_ terminate)
           *)
          booleanValue;
        error:
          (* used to define local exception conditions which can be
           * handled separately.  All 'error's that are not handled
           * separately will be handled by this(exception)
           *)
          (# <<SLOT errorLib: attributes>>
          do false->continue;
             INNER;
             '**** Error processing\n'->msg.prepend;
             (if not propagate and not continue then this(exception) if)
          exit propagate
          #);
        notify: error
          (* used to define local notification conditions which can be
           * handled separately.  All 'notify's that are not handled
           * separately will be handled by this(exception)
           *)
          (# do true->continue; INNER #);
        termCode: @integer
          (* Arg. to pattern 'stop'; initial failureTrace *);
     do failureTrace->termCode;
        INNER exception;
        (if not continue and not propagate then
            '**** Exception processing\n'->msg.prepend;
            (termCode,msg[])->stop
        if)
     #);
   notification: exception
     (# do true->continue; INNER notification #);
   (*****  Object Pool ***********************************************)
   objectPool: @
     (# <<SLOT objectPoolLib: attributes>>;
        get: 
          (# type:< object;
             obj: ^type;
             exact:< booleanValue;
             init:< object(* Called if an object was created *)
          ...
          exit obj[]
          #);
        strucGet: 
          (# type: ##object;
             obj: ^object;
             exact:< booleanValue;
             init:< object(* Called if an object was created *);
          enter type##
          ...
          exit obj[]
          #);
        scan: 
          (* Scan through all objects in 'objectPool', (at least)
           * qualified by 'type'.
           *)
          (# type:< object;
             current: ^type;
             exact:< booleanValue;
          ...
          #);
        strucScan: 
          (* Scan through all objects in 'objectPool', (at least)
           * qualified by 'type'
           *)
          (# type: ##object;
             current: ^object;
             exact:< booleanValue
          enter type##
          ...
          #);
        put: 
          (* Puts a given object into 'objectPool'. If an object with
           * (at least) the qualification of the given object is
           * already present in 'objectPool', the exception
           * 'alreadyThere' is raised.
           *)
          (# obj: ^object;
             exact:< booleanValue;
             alreadyThere:< exception;
             putObj: @...
          enter obj[]
          do putObj
          #);
        private: @...;
     #);
   
   (*****  Command line arguments ************************************)
   argumentHandlerType:
     (# 
        noOfArguments:< 
          (* Return the number of arguments on command line.
           * The number includes the program name.
           *)
          integervalue;
        
        getArgByNumber:<
          (* Returns argument number argNo.  
           * Number 1 is the program name, 
           * number 2 is the first program argument, etc.
           *)
          (# argNo: @integer; theArg: ^text;
          enter argNo
          do INNER
          exit theArg[]
          #);
     #);
   
   rawArgumentHandler: argumentHandlerType
     (# 
        noOfArguments::
          (# ... #);
        getArgByNumber::
          (# ... #);
     #);
   
   expandWildcardsArgumentHandler: argumentHandlerType
     (# private: @...;
        noOfArguments::
          (# ... #);
        getArgByNumber::
          (# ... #);
     #);
   
   argumentHandler: ^argumentHandlerType;
   
   (* Backwards compatible interface *)
   noOfArguments: integervalue(# do argumentHandler.noOfArguments -> value #);
   arguments: 
     (# argNo: @integer; theArg: ^text;
     enter argNo
     do argNo -> argumentHandler.getArgByNumber -> theArg[]
     exit theArg[]
     #);
   (******************************************************************)
   (* External language interface: See file 'external.bet' for further
    * patterns.
    *)
   External:
     (* Is only meaningful with interface to externals *)
     (# callC,callPascal,pascal,pascalTrap,callStd,
        cExternalEntry,pascalExternalEntry,stdExternalEntry: @text
     #);
   cStruct: 
     (* Super-pattern for describing structures which can be given
      * 'by refererence' (using the usual [] notation) to an external
      * function (e.g. a C function described as a specialization
      * of the above External pattern). See file external.bet for
      * supported operations on cStruct.
      *)
     (# <<SLOT cStructLib: attributes>>;
        (* 'R' is the bytestream containing THIS(cStruct).  
         * MUST be declared as the first attribute
         *);
        R: [(byteSize-1) div 4 + 1] @integer;
        byteSize:< 
          (* Number of bytes in THIS(cStruct) *)
          IntegerObject;
          
        BoundsExceeded:< Exception
          (* Raised if indexing outside range of R *)
          (# inx: @integer; 
          enter inx
          ...
          #);
        chk: @(# inx: @integer enter inx ... #);
     #);
   data:
     (* The 'data' pattern may be used for definining simple data
      * objects.  Data-objects have no 'type' information. They can
      * thus NOT be allocated dynamically in the BETA heap. They do
      * not have the overhead of extra attributes used for virtual
      * dispatch and garbage collection. One main use of data-objects
      * is as interface to external data such as 'cstruct'.  For
      * details see the manuals
      *)
     (# #);
   doGC: (* will force a garbage collection to happen *)
     (# ... #);
   machine_type:
     (* Exits a reference to a copy of a text indicating the machine
      * type in lowercase, e.g. 'sun4s', 'linux', 'nti'.
      *)
     (# T: @Text;
     do machine_typeexternal->T;
     exit T.copy
     #);
   machine_typeexternal: external
     (# T: [1]@Char; do 'machine_type'->callC; exit T #);
   program: (* descriptor executed by this environment *)
     ...;
   theProgram: ^|program;
   theScheduler: ^|object
     (* Scheduler installed by 'basicSystemEnv' (if used in program) *);
   (******************************************************************)
   (* The following patterns are only used by the compiler and should
    * NOT be used for other purposes.
    *)
   repetition: 
     (# range: (* Returns the range of THIS(repetition) *)
          (# n: @integer
          exit n
          #);
        new: 
          (* Allocates a new repetition of 'n' elements. The previous
           * elements in THIS(repetition) become inaccessible
           * hereafter
           *)
          (# n: @integer
          enter n
          #);
        extend:
          (* Extends THIS(repetition) by 'n' elements.  The existing
           * elements are retained.  The new elements are allocated
           * after the existing elements (i.e. with index from the
           * 'range+1')
           *)
          (# n: @integer
          enter n
          #)
     #);
   state: (# #); (* Pattern STATE is for experimental purpose only
                  * and using it may give undefined results 
                  *)
   errorName: (# #)
   
   (******************************************************************)
do ...;
   &|program[]->theProgram[];
   theProgram;
   (if theScheduler[]<>NONE then theScheduler if);
   ... ;
#)


13.2 Betaenv Interface
© 1990-2002 Mjølner Informatics
[Modified: Wednesday August 16th 2000 at 23:09]