13.5 External Interface

ORIGIN 'betaenv';
LIB_DEF 'external' '../lib';
-- CStructLib: attributes---
(*
 * COPYRIGHT
 *       Copyright Mjolner Informatics, 1992-99
 *       All rights reserved.
 *
 ****** Patterns for external interface *****
 * 
 * In CStructLib, the operations on a cStruct are defined.
 * The pattern ExternalRecord is an interface to e.g. CStruct objects
 * allocated from C or other external languages.
 *)
GetByte: 
  (# byteno: @int32;
  enter byteno->chk
  exit byteNo -> R.%getByte
  #);
PutByte: 
  (# val: @int8;
     byteno: @int32;
  enter(byteno,val) 
  do byteno->chk;
     (val,byteno) ->R.%putbyte
  #);
GetShort: 
  (# byteno: @int32;
  enter byteno->chk 
  exit (byteno div 2) ->R.%getShort
  #);
PutShort: 
  (# val: @int16;
     byteno: @int32;
  enter (byteno,val) 
  do byteno->chk;
     (val,byteno div 2) -> R.%putShort
  #);
GetSignedShort: 
  (# byteno: @int32;
  enter byteno->chk 
  exit (byteno div 2) ->R.%getSignedShort
  #);
GetLong: 
  (# byteno: @int32;
  enter byteno->chk
  exit (byteno div 4) ->R.%getLong
  #);
PutLong: 
  (# val: @int32;
     byteno: @int32
  enter (byteno,val)
  do byteno->chk; 
     (val,byteno div 4) ->R.%putLong
  #);


CStructField: 
  (* Used for declaring CStruct fields *)
  (# pos:< IntegerObject; 
     p: @pos; 
  #);
Byte: CStructField
  (# set: @(# val: @int8 enter val do (val,p) ->R.%putByte #);
  enter set
  exit p ->R.%getByte
  #);
Short: CStructField
  (# set: @(# val: @int16 enter val do (val,p div 2) ->R.%putShort #);
  enter set
  exit (p div 2) ->R.%getShort
  #);
SignedShort: CStructField
  (# set: @(# val: @int16 enter val do (val,p div 2) ->R.%putShort #);
  enter set
  exit (p div 2) ->R.%getSignedShort
  #);
Long: CStructField
  (# set: @(# val: @int32 enter val do (val,p div 4) ->R.%putLong #);
  enter set
  exit (p div 4)->R.%getLong
  #);


--LIB: attributes--

(* Various C functions *)
malloc: External
  (# size: @integer;
     ptr: @integer;
  enter size
  exit ptr
  #);
memcpy: external
  (# s1, s2, nbytes: @int32;
  enter (s1, s2, nbytes)
  exit s1
  #);

ExternalRecord: 
  (* Super-pattern for describing externally allocated record-structures.
   * A call to e.g. a C routine may often return a pointer to a CStruct.
   * By assigning such a pointer to the ptr-field of an externalRecord 
   * object it is possible to interface to such an external CStruct.
   * Notice the difference to the CStruct pattern, which is typically used
   * to *provide* external code with a structure allocated in BETA.
   *)
  (# ptr: @int32; (* pointer to the externally allocated record *)
     GetByte: 
       (# byteno: @int32;
       enter byteno
       exit %getByteAt (ptr+byteno)
       #);
     PutByte: 
       (# val: @int8;
          byteno: @int32;
       enter(byteno,val)
       do val %putByteAt (ptr+byteno)
       #);
     GetShort: 
       (# byteno: @int32;
       enter byteno
       exit %getShortAt (ptr+byteno)
       #);
     GetSignedShort: 
       (# byteno: @int32;
       enter byteno
       exit %getSignedShortAt (ptr+byteno)
       #);
     PutShort: 
       (# val: @int16;
          byteno: @int32;
       enter(byteno,val)
       do val %putShortAt (ptr+byteno)
       #);
     GetLong: 
       (# byteno: @int32
       enter byteno
       exit %getLongAt (ptr+byteno)
       #);
     PutLong: 
       (# val: @int32;
          byteno: @int32
       enter(byteno,val)
       do val %putLongAt (ptr+byteno)
       #);
     
     ExternalRecordField: 
       (* For declaring fields in ExternalRecords *)
       (# pos:< IntegerValue; 
          p: @pos;
       #);
     Byte: ExternalRecordField
       (# set: @(# val: @int8 enter val do val %putByteAt (ptr+p) #)
       enter set
       exit %getByteAt (ptr+p)
       #);
     Short: ExternalRecordField
       (# set: @(# val: @int16 enter val do val %putShortAt (ptr+p) #);
       enter set
       exit %getShortAt (ptr+p)
       #);
     SignedShort: ExternalRecordField
       (# set: @(# val: @int16 enter val do val %putShortAt (ptr+p) #);
       enter set
       exit %getSignedShortAt (ptr+p)
       #);
     Long: ExternalRecordField
       (# val: @int32;
          set: @(# enter val do val %putLongAt (ptr+p) #);
       enter set
       exit %getLongAt (ptr+p)
       #);
     DoubleLong: ExternalRecordField
       (# v1,v2: @int32; 
          set: @(# enter(v1,v2) 
                do v1 %putLongAt (ptr+p);
                   v2 %putLongAt (ptr+p+4);
                #);
       enter set
       exit (%getLongAt (ptr+p), %getLongAt (ptr+p+4))
       #);
  enter ptr
  do INNER
  exit ptr
  #) (* ExternalRecord *);

ExternalRepetition: ExternalRecord
  (# elementSize:<integerValue;
     init:
       (# enter new #);
     new: 
       (# newrange: @int32
       enter newrange
       do free;
          newrange->range;
       #);
     extend:
       (# extra: @int32;
          newptr, newrange, size: @int32;
          
       enter extra
       do (* is realloc available on all platforms? *)
          elementSize->size;
          (*'EXTEND: elementsize: ' -> puttext;
           * elementsize -> putint; ', range.r: ' -> puttext;
           * range.r->putint; newline;
           *)
          range.r+extra -> newrange;
          size*newrange -> malloc -> newptr;
          (if newPtr=0 then
              'ExternalRepetition.extend: malloc failed' -> screen.putline;
           else
              (if ptr<>0 then
                  (* 'memcpy ' -> puttext; size*range.r->putint; 
                   * ' bytes.'->putline;
                   *)
                  (newptr, ptr, size*range.r) -> memcpy;
                  free;
              if);
              newptr->ptr;
              newrange -> range.r;
          if);
       #);
     range: @
       (# r: @int32;
       enter (# r2: @int32 enter r2 do r2-r->extend #)
       exit r
       #);
     free:
       (# cfree: External
            (# ptr: @integer
            enter ptr
            do 'free' -> callC;
            #);
       do (if ptr<>0 then ptr -> cfree; 0->ptr; if);
          0 -> range.r;
       #);
     inxPut:
       (* Only for elementSize in {1,2,4}. Inx zero based. No index check *)
       (# elm, inx: @int32;
       enter (elm, inx)
       do (if elementSize
           // 1 then elm %putByteAt (ptr+inx) 
           // 2 then elm %putShortAt (ptr+2*inx) 
           // 4 then elm %putLongAt (ptr+4*inx) 
           else
              'ExternalRepetition.inxPut: Not for elementSize='->screen.puttext;
              elementSize->screen.putInt; 
              screen.newline;
          if);
       #);
     inxCopy:
       (* Copy elementSize bytes from "element" (which is assumed to 
        * point to data of the same type as the external repetition elements)
        * to index number inx (counting from zero) in the external 
        * repetition. 
        * Can be used for any elementSize.
        *)
       (# inx: @int32;
          element: ^data;
          n: @integer;
       enter (inx, element[])
       do elementSize -> n;
          (ptr+inx*n, %getLongAt(@@element), n) -> memcpy
       #);
     inxGet:
       (* Only for elementSize in {1,2,4}. Inx zero based. No index check *)
       (# elm, inx: @int32;
       enter (inx)
       do (if elementSize
           // 1 then (%getByteAt (ptr+inx)) -> elm
           // 2 then (%getShortAt (ptr+2*inx)) -> elm;
           // 4 then (%getLongAt (ptr+4*inx)) -> elm;
           else
              'ExternalRepetition.inxGet: Not for elementSize='->screen.puttext;
              elementSize->screen.putInt; 
              screen.newline;
          if);
       exit elm
       #);
  #);

makeCBF: External
  (* Call this external to install a callback and get
   * an int32 pointer to it.
   *)
  (# pat: ##External;
     cb: @int32;
  enter pat##
  exit cb
  #);

freeCBF: External
  (* Call this external with an int32 pointer to an installed
   * callback (obtained via MakeCBF) when it is certain that the
   * callback will NOT be called again.
   * This will free BETA heap space associated with the callback.
   *)
  (# cbf: @int32;
  enter cbf
  #)