Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/INDUCE.ZIP/INDUCE.INC

Text File | 1986-06-04 | 20.0 KB | 621 lines

(* ----------------------------------------------------------------------
        Utility Routines
   ---------------------------------------------------------------------- *)

 FUNCTION open(VAR f : text_file ; f_name : string80) : boolean ;
  (* open a file - returns true if the file exists and was opened properly
     f      - file pointer
     f_name - external name of the file *)
  BEGIN
   assign(f,f_name) ;
   (*$I- *)
   reset(f) ;
   (*$I+ *)
   open := (ioresult = 0) ;
  END ; (* open *)


 FUNCTION is_console(VAR f : text_file) : boolean ;
  (* return true if f is open on the system console
     for details of fibs and fib_ptrs see the Turbo Pascal ver 3.0 reference
     manual chapter 20. This should work under CP/M-86 or 80, but we haven't
     tried it. *)
  TYPE
   fib = ARRAY [0 .. 75] OF byte ;
  VAR
   fib_ptr : ^fib ;
   dev_type : byte ;
  BEGIN
   fib_ptr := addr(f) ;
   dev_type := fib_ptr^[2] AND $07 ;
   is_console := (dev_type = 1) OR (dev_type = 2) ;
  END ; (* is_console *)


 PROCEDURE strip_leading_blanks(VAR s : string80) ;
  BEGIN
   IF length(s) > 0
    THEN
     IF (s[1] = ' ') OR (s[1] = tab)
      THEN
       BEGIN
        delete(s,1,1) ;
        strip_leading_blanks(s) ;
       END ;
  END ; (* strip_leading_blanks *)


 PROCEDURE strip_trailing_blanks(VAR s : string80) ;
  BEGIN
   IF length(s) > 0
    THEN
     IF (s[length(s)] = ' ') OR (s[length(s)] = tab)
      THEN
       BEGIN
        delete(s,length(s),1) ;
        strip_trailing_blanks(s) ;
       END ;
  END ; (* strip_trailing_blanks *)



 FUNCTION toupper(s : string80) : string80 ;
  (* returns s converted to upper case *)
  VAR
   i : byte ;
  BEGIN
   IF length(s) > 0
    THEN
     FOR i := 1 TO length(s) DO
      s[i] := upcase(s[i]) ;
   toupper := s ;
  END ; (* toupper *)


 FUNCTION toreal(s : string80) : real ;
  (* converts s to a real number
     This routine uses the Turbo intrinsic val to do the conversion.
     If s does not contain a legal representation of a number, it returns
     0.0  *)
  VAR
   num : real ;
   code : integer ;
  BEGIN
   strip_trailing_blanks(s) ;
   strip_leading_blanks(s) ;
   val(s,num,code) ;
   IF code = 0
    THEN toreal := num
    ELSE toreal := 0 ;
  END ; (* toreal *)


 FUNCTION is_number(s : string80) : boolean ;
  (* checks to see if s contains a legitimate numerical string.
     It ignores leading and trailing blanks *)
  VAR
   num : real ;
   code : integer ;
  BEGIN
   strip_trailing_blanks(s) ;
   strip_leading_blanks(s) ;
   IF s <> ''
    THEN val(s,num,code)
    ELSE code := -1 ;
   is_number := (code = 0) ;
  END ; (* is_number *)


 FUNCTION head(list : node_ptr) : node_ptr ;
  (* returns a pointer to the first item in the list.
     If the list is empty, it returns NIL.  *)
  BEGIN
   IF list = NIL
    THEN head := NIL
    ELSE head := list^.head_ptr ;
  END ; (* head *)


 FUNCTION tail(list : node_ptr) : node_ptr ;
  (* returns a pointer to a list starting at the second item in the list.
     Note - tail( (a b c) ) points to the list (b c), but
            tail( ((a b) c d) ) points to the list (c d) .  *)
  BEGIN
   IF list = NIL
    THEN tail := NIL
   ELSE
    CASE list^.tag OF
     cons_node : tail := list^.tail_ptr ;
     free_node : tail := list^.next_free ;
     ELSE        tail := NIL ;
    END ;
  END ; (* tail *)


 FUNCTION element(list : node_ptr ; elem_no : counter) : node_ptr ;
  (* returns a pointer to the element number elem_no in the list.
     element(list,1) points to list.
     element(list,2) is the same as tail(list).    *)
  VAR
   i : counter ;
  BEGIN
   FOR i := 1 TO elem_no - 1 DO
    list := tail(list) ;
   element := list ;
  END ; (* element *)


 FUNCTION allocation_size(x : counter) : counter ;
  (* Turbo 3.0 allocates memory in 8 byte blocks, this routine calculates the
     actual number of bytes returned for a request of x bytes.  *)
  BEGIN
   allocation_size := (((x - 1) DIV 8) + 1) * 8 ;
  END ; (* allocation_size *)


 FUNCTION node_size : counter ;
  (* calculates the base size of a node. Add the rest of the node to this
     to get the actual size of a node *)
  BEGIN
   node_size := 2 * sizeof(node_ptr) + sizeof(boolean) + sizeof(node_type) ;
  END ; (* node_size *)


 FUNCTION normalize(pt : node_ptr) : node_ptr ;
  (* returns a normalized pointer. Pointers are 32 bit addresses. The first
     16 bits contain the segment number and the second 16 bits contain the
     offset within the segment. Normalized pointers have offsets in the range
     $0 to $F (0 .. 15)    *)
  VAR
   pt_seg,pt_ofs : integer ;
  BEGIN
   pt_seg := seg(pt^) + (ofs(pt^) DIV 16) ;
   pt_ofs := ofs(pt^) MOD 16 ;
   normalize := ptr(pt_seg,pt_ofs) ;
  END ; (* normalize *)


 FUNCTION string_val(list : node_ptr) : string80 ;
  (* returns the string pointed to by list. If list points to a number
     node, it returns a string representing that number *)
  VAR
   s : string[15] ;
  BEGIN
   IF list = NIL
    THEN string_val := ''
   ELSE IF list^.tag = symbol
    THEN string_val := list^.string_data
   ELSE IF list^.tag = number
    THEN
     BEGIN
      str(list^.num_data : 14,s) ;
      string_val := s ;
     END
   ELSE string_val := '' ;
  END ; (* string_val *)


 FUNCTION num_val(list : node_ptr) : real ;
  (* returns the number pointed to by list. If list points to a string,
     it returns the numerical value of the string.   *)
  VAR
   s : string80 ;
   code : integer ;
   r : real ;
  BEGIN
   IF list = NIL
    THEN num_val := 0.0
   ELSE IF list^.tag = number
    THEN num_val := list^.num_data
   ELSE IF list^.tag = symbol
    THEN num_val := toreal(list^.string_data)
   ELSE num_val := 0.0 ;
  END ; (* num_val *)


 FUNCTION attrib_value(p : node_ptr) : string80 ;
  (* This routine is used by print_rule and print_tree to strip off
     ':number' from an attribute name.   *)
  BEGIN
   IF pos(':NUMBER',toupper(string_val(p))) > 0
    THEN attrib_value := copy(string_val(p),
                 1,pos(':NUMBER',toupper(string_val(p))) - 1)
    ELSE attrib_value := string_val(p) ;
  END ; (* attrib_value *)


 FUNCTION tag_value(list : node_ptr) : node_type ;
  (* returns the value of the tag for a node.     *)
  BEGIN
   IF list = NIL
    THEN tag_value := free_node
    ELSE tag_value := list^.tag ;
  END ; (* tag_value *)


 FUNCTION match_lists(list1,list2 : node_ptr) : boolean ;
  (* returns true if list1 and list2 are identical.
     Two lists are identical if they are both NIL or if their heads match
     and match_lists returns true for thier tails. *)
  BEGIN
   IF (list1 = NIL) AND (list2 = NIL)
    THEN match_lists := true
   ELSE IF (list1 = NIL) OR (list2 = NIL)
    THEN match_lists := false
   ELSE IF tag_value(head(list1)) <> tag_value(head(list2))
    THEN match_lists := false
   ELSE
    CASE tag_value(head(list1)) OF
     symbol    : IF string_val(head(list1)) = string_val(head(list2))
                  THEN match_lists := match_lists(tail(list1),tail(list2))
                  ELSE match_lists := false ;
     number    : IF num_val(head(list1)) = num_val(head(list2))
                  THEN match_lists := match_lists(tail(list1),tail(list2))
                  ELSE match_lists := false ;
     cons_node : IF match_lists(head(list1),head(list2))
                  THEN match_lists := match_lists(tail(list1),tail(list2))
                  ELSE match_lists := false ;
    END ;
  END ; (* match_lists *)


 FUNCTION on_list(s : string80 ; list : node_ptr) : boolean ;
  (* checks to see if s is on the list, list. s is on the list if it
     matches the head of the list or if on_list(tail(list)) returns true.  *)
  BEGIN
   IF list = NIL
    THEN on_list := false
   ELSE IF s = string_val(head(list))
    THEN on_list := true
   ELSE on_list := on_list(s,tail(list)) ;
  END ; (* on_list *)


 PROCEDURE print_list(list : node_ptr) ;
  (* recursively traverses the list and prints its elements. This is
     not a pretty printer, so the lists may look a bit messy.  *)
  VAR
   p : node_ptr ;
  BEGIN
   IF list <> NIL
    THEN
     CASE list^.tag OF
      symbol    : write(string_val(list),' ') ;
      number    : write(num_val(list) : 6,' ') ;
      cons_node : BEGIN
                   write('(') ;
                   p := list ;
                   WHILE p <> NIL DO
                    BEGIN
                     print_list(head(p)) ;
                     p := tail(p) ;
                    END ;
                   write(') ') ;
                  END ;
     END ;
  END ; (* print_list *)


 PROCEDURE get_memory(VAR p : node_ptr ; size : counter) ;
  (* On exit p contains a pointer to a block of allocation_size(size) bytes.
     If possible this routine tries to get memory from the free list before
     requesting it from the heap *)
  VAR
   blks : counter ;
   allocated : boolean ;

  PROCEDURE get_from_free(VAR list : node_ptr) ;
   (* Try and get need memory from the free list. This routine uses a
      first-fit algorithm to get the space. It takes the first free block it
      finds with enough storage. If the free block has more storage than was
      requested, the block is shrunk by the requested amount.  *)
   BEGIN
    IF list <> NIL
     THEN
      IF list^.block_cnt >= (blks - 1)
       THEN
        BEGIN
         p := normalize(ptr(seg(list^),ofs(list^) +
                                       (list^.block_cnt - blks + 1) * 8)) ;
         IF list^.block_cnt = blks - 1
          THEN list := list^.next_free
          ELSE list^.block_cnt := list^.block_cnt - blks ;
         allocated := true ;
         total_free := total_free - (blks * 8.0) ;
        END
       ELSE get_from_free(list^.next_free) ;
   END ; (* get_from_free *)

  BEGIN
   blks := ((size - 1) DIV 8) + 1 ;
   allocated := false ;
   get_from_free(free) ;
   IF NOT allocated
    THEN getmem(p,blks * 8) ;
  END ; (* get_memory *)


 FUNCTION alloc_str(s : string80) : node_ptr ;
  (* Allocate storage for a string and return a pointer to the new node.
     This routine only allocates enough storage for the actual number of
     characters in the string plus one for the length. Because of this,
     concatenating anything to the end of a string stored in a symbol node
     will lead to disaster. Copy the string to a new string do the
     concatenation and then allocate a new node.  *)
  VAR
   pt : node_ptr ;
  BEGIN
   get_memory(pt,allocation_size(sizeof(node_type) + sizeof(boolean) +
                                 length(s) + 1)) ;
   pt^.tag := symbol   ;
   pt^.string_data := s ;
   alloc_str := pt ;
  END ; (* alloc_str *)


 FUNCTION alloc_num(r : real) : node_ptr ;
  (* Allocate storage for a real number and return a pointer to the new node. *)
  VAR
   pt : node_ptr ;
  BEGIN
   get_memory(pt,allocation_size(sizeof(node_type) + sizeof(boolean) +
                                 sizeof(real))) ;
   pt^.tag := number ;
   pt^.num_data := r ;
   alloc_num := pt ;
  END ; (* alloc_num *)


 FUNCTION cons(new_node,list : node_ptr) : node_ptr ;
  (* Construct a list. This routine allocates storage for a new cons node.
     new_node points to the new head of the list. The tail pointer of the
     new node points to list. This routine adds the new cons node to the
     beginning of the list and returns a pointer to it. The list described
     in the comments at the beginning of the program could be constructed
     as cons(alloc_str('A'),cons(alloc_str('B'),cons(alloc_str('C'),NIL))). *)
  VAR
   p : node_ptr ;
  BEGIN
   get_memory(p,allocation_size(node_size)) ;
   p^.tag := cons_node ;
   p^.head_ptr := new_node ;
   p^.tail_ptr := list ;
   cons := p ;
  END ; (* cons *)


 FUNCTION append_list(list1,list2 : node_ptr) : node_ptr ;
  (* Append list2 to list1. This routine returns a pointer to the
     combined list. Appending is done by consing each item on the first
     list to the second list. This routine is one of the major sources of
     garbage so if garbage collection becomes a problem, you may want to
     rewrite it. *)
  BEGIN
   IF list1 = NIL
    THEN append_list := list2
    ELSE append_list := cons(head(list1),append_list(tail(list1),list2)) ;
  END ; (* append_list *)


 FUNCTION list_length(list : node_ptr) : counter ;
  (* returns the length of a list.
     Note - both (A B C) and ( (A B) C D) have length 3.   *)
  BEGIN
   IF list = NIL
    THEN list_length := 0
    ELSE list_length := 1 + list_length(list^.tail_ptr) ;
  END ; (* list_length *)


 FUNCTION copy_list(list : node_ptr) : node_ptr ;
  (* Returns a pointer to a copy of list. This routine allocates new nodes
     for each item in the original list *)
  BEGIN
   IF list = NIL
    THEN copy_list := NIL
    ELSE
     CASE tag_value(list) OF
      cons_node : copy_list := cons(copy_list(head(list)),copy_list(tail(list))) ;
      number    : copy_list := alloc_num(num_val(list)) ;
      symbol    : copy_list := alloc_str(string_val(list)) ;
     END ;
  END ; (* copy_list *)


 PROCEDURE collect_garbage ;
  (* This routine is specific to Turbo Pascal Ver 3.01
     It depends upon the fact that Turbo allocates memory in 8 byte blocks
     on the PC. If you recompile this program on another system be very
     careful with this routine.
     Garbage collection proceeds in three phases:
      unmark  - free all memory between the initial_heap^ and the current
                top of the heap.
      mark    - mark everything on the saved_list as being in ues.
      release - gather all unmarked blocks and put them on the free list.
     The collector displays a '*' on the screen to let you know it is
      operating.  *)

  FUNCTION lower(p1,p2 : node_ptr) : boolean ;
   (* returns true if p1 points to a lower memory address than p2 *)
   BEGIN
    p1 := normalize(p1) ;
    p2 := normalize(p2) ;
    lower := (seg(p1^) < seg(p2^)) OR
              ((seg(p1^) = seg(p2^)) AND (ofs(p1^) < ofs(p2^))) ;
   END ; (* lower *)

  PROCEDURE mark(list : node_ptr) ;
   (* Mark the blocks on list as being in use. Since a node may be on several
      lists at one time, if it is already marked we don't continue processing
      the tail of the list. *)
   BEGIN
    IF list <> NIL
     THEN
      BEGIN
       IF NOT list^.in_use
        THEN
         BEGIN
          list^.in_use := true ;
          IF list^.tag = cons_node
           THEN
            BEGIN
             mark(head(list)) ;
             mark(tail(list)) ;
            END ;
         END ;
      END ;
   END ; (* mark *)

  PROCEDURE unmark_mem ;
   (* Go through memory from initial_heap^ to HeapPtr^ and mark each node
      as not in use. The tricky part here is updating the pointer p to point
      to the next cell. *)
   VAR
    p : node_ptr ;
    string_base,node_allocation : counter ;
   BEGIN
    string_base := sizeof(node_type) + sizeof(boolean) ;
    p := normalize(initial_heap) ;
    node_allocation := allocation_size(node_size) ;
    WHILE lower(p,HeapPtr) DO
     BEGIN
      p^.in_use := false ;
      CASE p^.tag OF
       cons_node : p := normalize(ptr(seg(p^),ofs(p^) + node_allocation)) ;
       free_node : p := normalize(ptr(seg(p^),ofs(p^) + (p^.block_cnt + 1) * 8)) ;
       number    : p := normalize(ptr(seg(p^),
                                  ofs(p^) +
                                  allocation_size(string_base + sizeof(real)))) ;
       symbol    : p := normalize(ptr(seg(p^),
                                  ofs(p^) +
                                  allocation_size(string_base +
                                                  length(p^.string_data) + 1))) ;
      END ;
     END ;
   END ; (* unmark_mem *)

  PROCEDURE release_mem ;
   (* This procedure does the actual collection and compaction of nodes.
      This is the slow phase of garbage collection because of all the pointer
      manipulation.  *)
   VAR
    heap_top : node_ptr ;
    string_base,node_allocation,string_allocation,block_allocation : counter ;

   PROCEDURE free_memory(pt : node_ptr ; size : counter) ;
    (* return size bytes pointed to by pt to the free list. If pt points to
       a block next to the head of the free list combine it with the top
       free node. total_free keeps track of the total number of free bytes. *)
    VAR
     blks : counter ;
    BEGIN
     blks := ((size - 1) DIV 8) + 1 ;
     pt^.tag := free_node ;
     IF normalize(ptr(seg(pt^),ofs(pt^) + 8 * blks)) = free
      THEN
       BEGIN
        pt^.next_free := free^.next_free ;
        pt^.block_cnt := free^.block_cnt + blks ;
        free := pt ;
       END
     ELSE IF normalize(ptr(seg(free^),ofs(free^) + 8 * (free^.block_cnt + 1))) =
             normalize(pt)
      THEN free^.block_cnt := free^.block_cnt + blks
     ELSE
      BEGIN
       pt^.next_free := free ;
       pt^.block_cnt := blks - 1 ;
       free := pt ;
      END ;
     total_free := total_free + (blks * 8.0) ;
    END ; (* free_memory *)

   PROCEDURE do_release ;
    (* This routine sweeps through memory and checks for nodes with
       in_use = false. *)
    VAR
     p : node_ptr ;
    BEGIN
     p := normalize(initial_heap) ;
     WHILE lower(p,heap_top) DO
      CASE p^.tag OF
       cons_node : BEGIN
                    IF NOT p^.in_use
                     THEN free_memory(p,node_size) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + node_allocation)) ;
                   END ;
       free_node : BEGIN
                    block_allocation := (p^.block_cnt + 1) * 8 ;
                    free_memory(p,block_allocation) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + block_allocation)) ;
                   END ;
       number    : BEGIN
                    block_allocation := allocation_size(string_base +
                                                        sizeof(real)) ;
                    IF NOT p^.in_use
                     THEN free_memory(p,block_allocation) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + block_allocation)) ;
                   END ;
       symbol    : BEGIN
                    string_allocation := allocation_size(string_base +
                                                length(p^.string_data) + 1) ;
                    IF NOT p^.in_use
                     THEN free_memory(p,string_base + length(p^.string_data)
                                      + 1) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + string_allocation)) ;
                   END ;
      END ;
    END ; (* do_release *)

   BEGIN
    free := NIL ;
    total_free := 0.0 ;
    heap_top := HeapPtr ;
    string_base := sizeof(node_type) + sizeof(boolean) ;
    node_allocation := allocation_size(node_size) ;
    do_release ;
   END ; (* release_mem *)

  BEGIN
   write('*') ;
   unmark_mem ;
   mark(saved_list) ;
   release_mem ;
   write(back_space) ;
   clreol ;
  END ; (* collect_garbage *)


 PROCEDURE test_memory ;
  (* This routine activates the garbage collector, if the the total available
     memory (free_list + heap) is less than a specified amount. Lowering the
     minimum causes garbage collection to be called less often, but if you
     make it too small you may not have enough room left for recursion or any
     temporary lists you need. Using 10000 is probably being overly
     cautious.   *)
  BEGIN
   IF (memavail * 16.0) + total_free < 10000
    THEN collect_garbage ;
  END ; (* test_memory *)


 PROCEDURE wait ;
  (* Just like it says. It waits for the user to press a key before
     continuing. *)
  VAR
   ch : char ;
  BEGIN
   writeln ;
   writeln ;
   write('Press any key to continue. ') ;
   read(kbd,ch) ;
   write(return) ;
   clreol ;
  END ; (* wait *)


(* ------------------------------------------------------------------------
        End of utility routines
   ------------------------------------------------------------------------ *)