Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!seismo!think!ames!ucbcad!ucbvax!decvax!decwrl!sun!imagen!turner
From: turner@imagen.UUCP (D'arc Angel)
Newsgroups: comp.ai
Subject: AI Expert Magazine source code posting for April (Part 02/05)
Message-ID: <1002@imagen.UUCP>
Date: Tue, 17-Mar-87 19:58:31 EST
Article-I.D.: imagen.1002
Posted: Tue Mar 17 19:58:31 1987
Date-Received: Thu, 19-Mar-87 04:40:46 EST
Organization: The Houses of the Holy
Lines: 606
Keywords: source


         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) : s_expr ;
  (* 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 : s_expr ;
  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) : s_expr ;
  (* Allocate storage for a number and return a pointer to the new node.
     All numbers are stored as reals. This isn't efficient, but it is
     easy. *)
  VAR
   pt : s_expr ;
  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 : s_expr) : s_expr ;
  (* Construct a list. This routine allocates storage for a new cons node.
     new_node points to the new car of the list. The cdr 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 : s_expr ;
  BEGIN
   get_memory(p,allocation_size(node_size)) ;
   p^.tag := cons_node ;
   p^.car_ptr := new_node ;
   p^.cdr_ptr := list ;
   cons := p ;
  END ; (* cons *)


 FUNCTION eq(item1,item2 : s_expr) : boolean ;
  (* test the equality of two atoms, if item1 and item2 are not atoms
      it returns false *)
  BEGIN
   IF (item1 = NIL) AND (item2 = NIL)
    THEN eq := true
   ELSE IF (tag_value(item1) IN [number,symbol]) AND
           (tag_value(item2) IN [number,symbol])
    THEN eq := (string_val(item1) = string_val(item2))
   ELSE eq := false ;
  END ; (* eq *)


 FUNCTION lt(item1,item2 : s_expr) : boolean ;
  (* tests if item1 < item2, if item1 and item2 are not atoms
      it returns false *)
  BEGIN
   IF (item1 = NIL) AND (item2 = NIL)
    THEN lt := false
   ELSE IF (tag_value(item1) IN [number,symbol]) AND
           (tag_value(item2) IN [number,symbol])
    THEN lt := (string_val(item1) < string_val(item2))
   ELSE lt := false ;
  END ; (* lt *)


 FUNCTION gt(item1,item2 : s_expr) : boolean ;
  (* tests if item1 > item2, if item1 and item2 are not atoms
      it returns false *)
  BEGIN
   IF (item1 = NIL) AND (item2 = NIL)
    THEN gt := false
   ELSE IF (tag_value(item1) IN [number,symbol]) AND
           (tag_value(item2) IN [number,symbol])
    THEN gt := (string_val(item1) > string_val(item2))
   ELSE gt := false ;
  END ; (* gt *)


 FUNCTION add(item1,item2 : s_expr) : s_expr ;
  (* add the values of two atoms, if item1 and item2 are not atoms
      it returns 0 *)
  VAR
    r1,r2 : real ;
  BEGIN
   IF tag_value(item1) = number
    THEN r1 := num_val(item1)
    ELSE r1 := toreal(string_val(item1)) ;
   IF tag_value(item2) = number
    THEN r2 := num_val(item2)
    ELSE r2 := toreal(string_val(item2)) ;
   add := alloc_num(r1 + r2) ;
  END ; (* add *)


 FUNCTION sub(item1,item2 : s_expr) : s_expr ;
  (* finds the difference between the values of two atoms,
     if item1 and item2 are not atoms it returns 0 *)
  VAR
    r1,r2 : real ;
  BEGIN
   IF tag_value(item1) = number
    THEN r1 := num_val(item1)
    ELSE r1 := toreal(string_val(item1)) ;
   IF tag_value(item2) = number
    THEN r2 := num_val(item2)
    ELSE r2 := toreal(string_val(item2)) ;
   sub := alloc_num(r1 - r2) ;
  END ; (* sub *)


 FUNCTION mul(item1,item2 : s_expr) : s_expr ;
  (* finds the product of the values of two atoms,
     if item1 and item2 are not atoms it returns 0 *)
  VAR
    r1,r2 : real ;
  BEGIN
   IF tag_value(item1) = number
    THEN r1 := num_val(item1)
    ELSE r1 := toreal(string_val(item1)) ;
   IF tag_value(item2) = number
    THEN r2 := num_val(item2)
    ELSE r2 := toreal(string_val(item2)) ;
   mul := alloc_num(r1 * r2) ;
  END ; (* mul *)


 FUNCTION div_f(item1,item2 : s_expr) : s_expr ;
  (* divides item1 by item2,
     if item1 and item2 are not atoms it returns 0 *)
  VAR
    r1,r2 : real ;
  BEGIN
   IF tag_value(item1) = number
    THEN r1 := num_val(item1)
    ELSE r1 := toreal(string_val(item1)) ;
   IF tag_value(item2) = number
    THEN r2 := num_val(item2)
    ELSE r2 := toreal(string_val(item2)) ;
   IF abs(r2) <= 1.0E-20
    THEN div_f := alloc_num(0.0)
    ELSE div_f := alloc_num(r1 / r2) ;
  END ; (* div_f *)


 FUNCTION mod_f(item1,item2 : s_expr) : s_expr ;
  (* finds the remainder of item1 divided by item2,
     if item1 and item2 are not atoms it returns 0 *)
  VAR
    r1,r2 : integer ;
  BEGIN
   r1 := tointeger(string_val(item1)) ;
   r2 := tointeger(string_val(item2)) ;
   mod_f := alloc_num(r1 MOD r2) ;
  END ; (* mod_f *)


 FUNCTION member(p,list : s_expr) : boolean ;
  (* returns true if p points to a member of list *)
  BEGIN
   IF list = NIL
    THEN member := false
   ELSE IF eq(p,car(list))
    THEN member := true
   ELSE member := member(p,cdr(list)) ;
  END ; (* member *)


 FUNCTION locate(p,list1,list2 : s_expr) : s_expr ;
  (* finds p on list1 and returns a pointer to the corresponding
     element of list2 *)
  BEGIN
   IF list1 = NIL
    THEN locate := NIL
   ELSE IF eq(p,car(list1))
    THEN locate := car(list2)
   ELSE locate := locate(p,cdr(list1),cdr(list2)) ;
  END ; (* locate *)


 FUNCTION assoc(p,list1,list2 : s_expr) : s_expr ;
  (* search each sublist of list1 for p. If found, return pointer to
     corresponding element of list2 *)
  BEGIN
   IF list1 = NIL
    THEN assoc := NIL
   ELSE IF member(p,car(list1))
    THEN assoc := locate(p,car(list1),car(list2))
   ELSE assoc := assoc(p,cdr(list1),cdr(list2)) ;
  END ; (* assoc *)


 FUNCTION tf_node(t : boolean) : s_expr ;
  (* allocates T or F nodes for boolean expressions *)
  BEGIN
   IF t
    THEN tf_node := alloc_str('T')
    ELSE tf_node := alloc_str('F') ;
  END ; (* tf_node *)


 FUNCTION rplaca(VAR list : s_expr ; item : s_expr) : s_expr ;
  (* replace the car of list with item, return a pointer to the new list *)
  BEGIN
   IF list <> NIL
    THEN
     IF tag_value(list) <> cons_node
      THEN list := item
      ELSE list^.car_ptr := item ;
   rplaca := list ;
  END ; (* rplaca *)


 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_mem    - 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 : s_expr) : boolean ;
   (* returns true if p1 points to a lower memory address than p2 *)
   BEGIN
    p1 := normalize(p1) ;
    p2 := normalize(p2) ;
    lower := (cardinal(seg(p1^)) < cardinal(seg(p2^))) OR
              ((seg(p1^) = seg(p2^)) AND
              (cardinal(ofs(p1^)) < cardinal(ofs(p2^)))) ;
   END ; (* lower *)

  PROCEDURE mark_mem(list : s_expr) ;
   (* 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 cdr 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_mem(car(list)) ;
             mark_mem(cdr(list)) ;
            END ;
         END ;
      END ;
   END ; (* mark_mem *)

  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 : s_expr ;
    string_base,node_allocation,number_allocation : integer ;
   BEGIN
    string_base := sizeof(node_type) + sizeof(boolean) ;
    p := normalize(initial_heap) ;
    node_allocation := allocation_size(node_size) ;
    number_allocation := allocation_size(sizeof(node_type) + sizeof(boolean) +
                                         sizeof(real)) ;
    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^) + number_allocation)) ;
       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 : s_expr ;
    string_base,node_allocation,string_allocation,block_allocation,
                number_allocation : integer ;

   PROCEDURE free_memory(pt : s_expr ; size : counter) ;
    (* return size bytes pointed to by pt to the free list. If pt points to
       a block next to the car 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 : s_expr ;
    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
                    IF NOT p^.in_use
                     THEN free_memory(p,number_allocation) ;
                    p := normalize(ptr(seg(p^),ofs(p^) + number_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) ;
    number_allocation := allocation_size(sizeof(node_type) + sizeof(boolean) +
                                         sizeof(real)) ;
    do_release ;
   END ; (* release_mem *)

  BEGIN
   write('*') ;
   unmark_mem ;
   mark_mem(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
   ------------------------------------------------------------------------ *)

 PROCEDURE read_kbd(VAR s : string80) ;
  (* Read a line from the keyboard. The number of unmatched parentheses are
     printed along with the prompt *)
  BEGIN
   IF paren_level > 0
    THEN write(paren_level,'>')
    ELSE write('-> ') ;
   readln(s) ;
  END ; (* read_kbd *)


 PROCEDURE read_from_file(VAR f : text_file) ;
  (* Read a line from file f and store it in the global variable line.
     It ignores blank lines and when the end of file is reached an
     eof_mark is returned. *)

  PROCEDURE read_a_line ;
   BEGIN
    (*$I- *)
    readln(f,line) ;
    (*$I+ *)
    IF ioresult <> 0
     THEN line := eof_mark
    ELSE IF eof(f)
     THEN line := concat(line,eof_mark) ;
   END ; (* read_a_line *)

  BEGIN
   line := '' ;
   IF is_console(f)
    THEN read_kbd(line)
    ELSE read_a_line ;
   saved_line := line ;
  END ; (* read_from_file *)


 PROCEDURE get_token(VAR t_line : string255 ; VAR token : string80) ;
  (* Get a token from t_line. A token is a string of text surrounded by
     blanks or a delimeter. Comments begin with ; and extend to the
     end of the line *)

  PROCEDURE get_word ;
   VAR
    done : boolean ;
    cn : integer ;
    len : byte ;
   BEGIN
    cn := 1 ;
    len := length(t_line) ;
    done := false ;
    WHILE NOT done DO
     IF cn > len
      THEN done := true
     ELSE IF t_line[cn] IN delim_set
      THEN done := true
     ELSE cn := cn + 1 ;
    token := copy(t_line,1,cn-1) ;
    delete(t_line,1,cn-1) ;
   END ; (* get_word *)

  PROCEDURE comment ;
   BEGIN
    t_line := '' ;
    get_token(t_line,token) ;
   END ; (* comment *)

  PROCEDURE get_number ;

   PROCEDURE get_digits ;
    BEGIN
     WHILE is_number(copy(t_line,1,1))
      BEGIN
       token := concat(token,t_line[1]) ;
       delete(t_line,1,1) ;
      END ;
    END ; (* get_digits *)

   PROCEDURE get_exponent ;
    BEGIN
     delete(t_line,1,1) ;
     IF length(t_line) > 0
      THEN
       BEGIN
        IF t_line[1] IN ['+','-']
         THEN
          BEGIN
           token := concat(token,'E',t_line[1]) ;
           delete(t_line,1,1) ;
          END
         ELSE token := concat(token,'E+') ;
        get_digits ;
       END
      ELSE token := concat(token,'E+00') ;
    END ; (* get_exponent *)

   BEGIN
    get_digits ;
    IF length(t_line) > 0
     THEN
      IF t_line[1] = '.'
       THEN
        IF is_number(copy(t_line,2,1))
         THEN
          BEGIN
           token := concat(token,t_line[1]) ;
           delete(t_line,1,1) ;
           get_digits ;
           IF toupper(copy(t_line,1,1)) = 'E'
            THEN get_exponent ;
          END ;
   END ; (* get_number *)

  PROCEDURE check_number ;
   VAR
    sgn : char ;
   BEGIN
    sgn := t_line[1] ;
    delete(t_line,1,1) ;
    IF length(t_line) > 0
     THEN
      IF t_line[1] IN ['0' .. '9']
       THEN
        BEGIN
         get_number ;
         token := concat(sgn,token) ;
        END
       ELSE token := sgn
     ELSE token := sgn ;
   END ; (* check_number *)

  BEGIN
   strip_leading_blanks(t_line) ;
   token := '' ;
   IF length(t_line) > 0
    THEN
     BEGIN
      IF t_line[1] = ';'
       THEN comment
      ELSE IF t_line[1] IN delim_set
       THEN
        BEGIN
         token := t_line[1] ;
         delete(t_line,1,1) ;
        END
      ELSE IF t_line[1] IN ['+','-']
       THEN check_number
      ELSE IF t_line[1] IN ['0' .. '9']
       THEN get_number
      ELSE get_word ;
     END ;
  END ; (* get_token *)


 PROCEDURE scan(VAR f : text_file ; VAR token : string80) ;
  (* Scan repeatedly calls get_token to retreive tokens. When the
     end of a line has been reached, read_from_file is called to
     get a new line. *)
  BEGIN
   IF length(line) > 0
    THEN
     BEGIN
      get_token(line,token) ;
      IF token = ''
-- 
---------------
C'est la vie, C'est la guerre, C'est la pomme de terre
Mail:	Imagen Corp. 2650 San Tomas Expressway Santa Clara, CA 95052-8101 
UUCP:	...{decvax,ucbvax}!decwrl!imagen!turner      AT&T: (408) 986-9400