fork download
  1. {$mode tp}(*$V-,R+,B- *)
  2.  
  3. Program very_tiny_prolog ;
  4.  
  5. uses Crt; (* necessary for ClrEol *)
  6.  
  7.  
  8. (* Copyright 1986 - MicroExpert Systems
  9.   Box 430 R.D. 2
  10.   Nassau, NY 12123 *)
  11.  
  12.  
  13. (* VTPROLOG implements the data base searching and pattern matching of
  14.   PROLOG. It is described in "PROLOG from the Bottom Up" in issues
  15.   1 and 2 of AI Expert.
  16.   This program has been tested using Turbo ver 3.01A on an IBM PC. It has
  17.   been run under both DOS 2.1 and Concurrent 4.1 .
  18.   We would be pleased to hear your comments, good or bad, or any applications
  19.   and modifications of the program. Contact us at:
  20.   AI Expert
  21.   CL Publications Inc.
  22.   650 Fifth St.
  23.   Suite 311
  24.   San Francisco, CA 94107
  25.   or on the AI Expert BBS. Our id is BillandBev Thompson. You can also
  26.   contact us on BIX, our id is bbt.
  27.   Bill and Bev Thompson *)
  28.  
  29. Const
  30. debug = false ;
  31. back_space = ^H ;
  32. tab = ^I ;
  33. eof_mark = ^Z ;
  34. esc = #27 ;
  35. quote_char = #39 ;
  36. left_arrow = #75 ;
  37. end_key = #79 ;
  38. del_line = ^X ;
  39. return = ^M ;
  40. bell = ^G ;
  41.  
  42. Type
  43. counter = 0 .. maxint ;
  44. string80 = string[80] ;
  45. string132 = string[132] ;
  46. string255 = string[255] ;
  47. text_file = text ;
  48. char_set = SET Of char ;
  49. node_type = (cons_node,func,variable,constant,free_node) ;
  50. node_ptr = ^node ;
  51. node = Record
  52. in_use : boolean ;
  53. Case tag : node_type Of
  54. cons_node : (tail_ptr : node_ptr ;
  55. head_ptr : node_ptr) ;
  56. func,
  57. constant,
  58. variable : (string_data : string80) ;
  59. free_node : (next_free : node_ptr ;
  60. block_cnt : counter) ;
  61. End ;
  62.  
  63.  
  64. (* node is the basic allocation unit for lists. The fields are used as
  65.   follows:
  66.   in_use - in_use = false tells the garbage collector that this node
  67.   is available for re-use.
  68.   tag - which kind of node this is.
  69.   cons_node - cons_nodes consist of two pointers. one to the head (first item)
  70.   the other to the rest of the list. They are the "glue" which
  71.   holds the list together. The list (A B C) would be stored as
  72.   ------- -------- --------
  73.   | .| . |-----> | .| . |------> | .| . |---> NIL
  74.   --|----- --|------ --|-----
  75.   | | |
  76.   V V V
  77.   A B C
  78.   The boxes are the cons nodes, the first part of the box
  79.   holds the head pointer, then second contains the tail.
  80.   constant - holds string values, we don't actually use the entire 80
  81.   characters in most cases.
  82.   variable - also conatins a string value, these nodes will be treated as
  83.   PROLOG variables rather than constants.
  84.   free_node - the garbage collector gathers all unused nodes and puts
  85.   them on a free list. It also compacts the free space into
  86.   contiguous blocks. next_free points to the next free block.
  87.   block_cnt contains a count of the number of contiguous 8 byte free
  88.   blocks which follow this one. *)
  89.  
  90.  
  91. Var
  92. line,saved_line : string132 ;
  93. token : string80 ;
  94. source_file : text_file ;
  95. error_flag,in_comment : boolean ;
  96. delim_set,text_chars : char_set ;
  97. data_base, initial_heap, free, saved_list, HeapPtr : node_ptr ;
  98. total_free : real ;
  99.  
  100.  
  101. (* The important globals are:
  102.   source_file - text file containing PROLOG statements.
  103.   line - line buffer for reading in the text file
  104.   saved_list - list of all items that absolutely must be saved if garbage
  105.   collection occurs. Usually has at least the data_base and
  106.   the currents query attached to it.
  107.   initial_heap - the value of the heap pointer at the start of the program.
  108.   used by the garbage collector
  109.   free - the list of free nodes.
  110.   total_free - total number of free blocks on the free list.
  111.   data_base - a pointer to the start of the data base. It points to a
  112.   node pointing to the first sentence in the data base. Nodes
  113.   pointing to sentences are linked together to form the data
  114.   base.
  115.   delim_set - set of characters which delimit tokens. *)
  116.  
  117.  
  118.  
  119. (* ----------------------------------------------------------------------
  120.   Utility Routines
  121.   ---------------------------------------------------------------------- *)
  122.  
  123. Procedure noise ;
  124. (* Make a noise on the terminal - used for warnings. *)
  125. Begin
  126. write(bell) ;
  127. End ;
  128. (* noise *)
  129.  
  130. Function open(Var f : text_file ; f_name : string80) : boolean ;
  131.  
  132. (* open a file - returns true if the file exists and was opened properly
  133.   f - file pointer
  134.   f_name - external name of the file *)
  135. Begin
  136. assign(f,f_name) ;
  137. (*$I- *)
  138. reset(f) ;
  139. (*$I+ *)
  140. open := (ioresult = 0) ;
  141. End ;
  142. (* open *)
  143.  
  144.  
  145. Function is_console(Var f : text_file) : boolean ;
  146.  
  147. (* return true if f is open on the system console
  148.   for details of fibs and fib_ptrs see the Turbo Pascal ver 3.0 reference
  149.   manual chapter 20. This should work under CP/M-86 or 80, but we haven't
  150.   tried it. *)
  151.  
  152. Type
  153. fib = ARRAY [0 .. 75] Of byte ;
  154.  
  155. Var
  156. fib_ptr : ^fib ;
  157. dev_type : byte ;
  158. Begin
  159. fib_ptr := addr(f) ;
  160. dev_type := fib_ptr^[2] And $07 ;
  161. is_console := (dev_type = 1) Or (dev_type = 2) ;
  162. End ;
  163. (* is_console *)
  164.  
  165.  
  166. Procedure strip_leading_blanks(Var s : string80) ;
  167. Begin
  168. If length(s) > 0
  169. Then
  170. If (s[1] = ' ') Or (s[1] = tab)
  171. Then
  172. Begin
  173. delete(s,1,1) ;
  174. strip_leading_blanks(s) ;
  175. End ;
  176. End ;
  177. (* strip_leading_blanks *)
  178.  
  179.  
  180. Procedure strip_trailing_blanks(Var s : string80) ;
  181. Begin
  182. If length(s) > 0
  183. Then
  184. If (s[length(s)] = ' ') Or (s[length(s)] = tab)
  185. Then
  186. Begin
  187. delete(s,length(s),1) ;
  188. strip_trailing_blanks(s) ;
  189. End ;
  190. End ;
  191. (* strip_trailing_blanks *)
  192.  
  193.  
  194.  
  195. Function toupper(s : string80) : string80 ;
  196. (* returns s converted to upper case *)
  197.  
  198. Var
  199. i : byte ;
  200. Begin
  201. If length(s) > 0
  202. Then
  203. For i := 1 To length(s) Do
  204. s[i] := upcase(s[i]) ;
  205. toupper := s ;
  206. End ;
  207. (* toupper *)
  208.  
  209.  
  210. Function is_number(s : string80) : boolean ;
  211.  
  212. (* checks to see if s contains a legitimate numerical string.
  213.   It ignores leading and trailing blanks *)
  214.  
  215. Var
  216. num : real ;
  217. code : integer ;
  218. Begin
  219. strip_trailing_blanks(s) ;
  220. strip_leading_blanks(s) ;
  221. If s <> ''
  222. Then val(s,num,code)
  223. Else code := -1 ;
  224. is_number := (code = 0) ;
  225. End ;
  226. (* is_number *)
  227.  
  228.  
  229. Function head(list : node_ptr) : node_ptr ;
  230. (* returns a pointer to the first item in the list.
  231.   If the list is empty, it returns NIL. *)
  232. Begin
  233. If list = Nil
  234. Then head := Nil
  235. Else head := list^.head_ptr ;
  236. End ;
  237. (* head *)
  238.  
  239.  
  240. Function tail(list : node_ptr) : node_ptr ;
  241.  
  242. (* returns a pointer to a list starting at the second item in the list.
  243.   Note - tail( (a b c) ) points to the list (b c), but
  244.   tail( ((a b) c d) ) points to the list (c d) . *)
  245. Begin
  246. If list = Nil
  247. Then tail := Nil
  248. Else
  249. Case list^.tag Of
  250. cons_node : tail := list^.tail_ptr ;
  251. free_node : tail := list^.next_free ;
  252. Else tail := Nil ;
  253. End ;
  254. End ;
  255. (* tail *)
  256.  
  257.  
  258. Function allocation_size(x : counter) : counter ;
  259.  
  260. (* Turbo 3.0 allocates memory in 8 byte blocks, this routine calculates the
  261.   actual number of bytes returned for a request of x bytes. *)
  262. Begin
  263. allocation_size := (((x - 1) Div 8) + 1) * 8 ;
  264. End ;
  265. (* allocation_size *)
  266.  
  267.  
  268. Function node_size : counter ;
  269.  
  270. (* calculates the base size of a node. Add the rest of the node to this
  271.   to get the actual size of a node *)
  272. Begin
  273. node_size := 2 * sizeof(node_ptr) + sizeof(boolean) + sizeof(node_type) ;
  274. End ;
  275. (* node_size *)
  276.  
  277.  
  278. Function normalize(pt : node_ptr) : node_ptr ;
  279.  
  280. (* returns a normalized pointer. Pointers are 32 bit addresses. The first
  281.   16 bits contain the segment number and the second 16 bits contain the
  282.   offset within the segment. Normalized pointers have offsets in the range
  283.   $0 to $F (0 .. 15) *)
  284.  
  285. Var
  286. pt_seg,pt_ofs : integer ;
  287. Begin
  288. pt_seg := seg(pt^) + (ofs(pt^) Div 16) ;
  289. pt_ofs := ofs(pt^) Mod 16 ;
  290.  
  291. (* Johnicholas says: so ptr is some primitive that builds a (32-bit) pointer from a pair of (16-bit) ints?
  292.   * Maybe I just need to cast the FarPointer to the appropriate type? *)
  293. normalize := node_ptr(ptr(pt_seg, pt_ofs)) ;
  294. End ;
  295. (* normalize *)
  296.  
  297.  
  298. Function string_val(list : node_ptr) : string80 ;
  299.  
  300. (* returns the string pointed to by list. If list points to a number
  301.   node, it returns a string representing that number *)
  302.  
  303. Var
  304. s : string[15] ;
  305. Begin
  306. If list = Nil
  307. Then string_val := ''
  308. Else If list^.tag In [constant,variable,func]
  309. Then string_val := list^.string_data
  310. Else string_val := '' ;
  311. End ;
  312. (* string_val *)
  313.  
  314.  
  315. Function tag_value(list : node_ptr) : node_type ;
  316. (* returns the value of the tag for a node. *)
  317. Begin
  318. If list = Nil
  319. Then tag_value := free_node
  320. Else tag_value := list^.tag ;
  321. End ;
  322. (* tag_value *)
  323.  
  324.  
  325. Procedure print_list(list : node_ptr) ;
  326.  
  327. (* recursively traverses the list and prints its elements. This is
  328.   not a pretty printer, so the lists may look a bit messy. *)
  329.  
  330. Var
  331. p : node_ptr ;
  332. Begin
  333. If list <> Nil
  334. Then
  335. Case list^.tag Of
  336. constant,
  337. func,
  338. variable : write(string_val(list),' ') ;
  339. cons_node :
  340. Begin
  341. write('(') ;
  342. p := list ;
  343. While p <> Nil Do
  344. Begin
  345. print_list(head(p)) ;
  346. p := tail(p) ;
  347. End ;
  348. write(') ') ;
  349. End ;
  350. End ;
  351. End ;
  352. (* print_list *)
  353.  
  354.  
  355. Procedure get_memory(Var p : node_ptr ; size : counter) ;
  356.  
  357. (* On exit p contains a pointer to a block of allocation_size(size) bytes.
  358.   If possible this routine tries to get memory from the free list before
  359.   requesting it from the heap *)
  360.  
  361. Var
  362. blks : counter ;
  363. allocated : boolean ;
  364.  
  365. Procedure get_from_free(Var list : node_ptr) ;
  366.  
  367. (* Try and get need memory from the free list. This routine uses a
  368.   first-fit algorithm to get the space. It takes the first free block it
  369.   finds with enough storage. If the free block has more storage than was
  370.   requested, the block is shrunk by the requested amount. *)
  371. Begin
  372. If list <> Nil
  373. Then
  374. If list^.block_cnt >= (blks - 1)
  375. Then
  376. Begin
  377. p := normalize(node_ptr(ptr(seg(list^), ofs(list^) +
  378. (list^.block_cnt - blks + 1) * 8))) ;
  379. If list^.block_cnt = blks - 1
  380. Then list := list^.next_free
  381. Else list^.block_cnt := list^.block_cnt - blks ;
  382. allocated := true ;
  383. total_free := total_free - (blks * 8.0) ;
  384. End
  385. Else get_from_free(list^.next_free) ;
  386. End ;
  387. (* get_from_free *)
  388.  
  389. Begin
  390. blks := ((size - 1) Div 8) + 1 ;
  391. allocated := false ;
  392. get_from_free(free) ;
  393. If Not allocated
  394. Then getmem(p,blks * 8) ;
  395. End ;
  396. (* get_memory *)
  397.  
  398.  
  399. Function alloc_str(typ : node_type ; s : string80) : node_ptr ;
  400.  
  401. (* Allocate storage for a string and return a pointer to the new node.
  402.   This routine only allocates enough storage for the actual number of
  403.   characters in the string plus one for the length. Because of this,
  404.   concatenating anything to the end of a string stored in a symbol node
  405.   will lead to disaster. Copy the string to a new string do the
  406.   concatenation and then allocate a new node. *)
  407.  
  408. Var
  409. pt : node_ptr ;
  410. Begin
  411. get_memory(pt,allocation_size(sizeof(node_type) + sizeof(boolean) +
  412. length(s) + 1)) ;
  413. pt^.tag := typ ;
  414. pt^.string_data := s ;
  415. alloc_str := pt ;
  416. End ;
  417. (* alloc_str *)
  418.  
  419.  
  420. Function cons(new_node,list : node_ptr) : node_ptr ;
  421.  
  422. (* Construct a list. This routine allocates storage for a new cons node.
  423.   new_node points to the new head of the list. The tail pointer of the
  424.   new node points to list. This routine adds the new cons node to the
  425.   beginning of the list and returns a pointer to it. The list described
  426.   in the comments at the beginning of the program could be constructed
  427.   as cons(alloc_str('A'),cons(alloc_str('B'),cons(alloc_str('C'),NIL))). *)
  428.  
  429. Var
  430. p : node_ptr ;
  431. Begin
  432. get_memory(p,allocation_size(node_size)) ;
  433. p^.tag := cons_node ;
  434. p^.head_ptr := new_node ;
  435. p^.tail_ptr := list ;
  436. cons := p ;
  437. End ;
  438. (* cons *)
  439.  
  440.  
  441. Function append_list(list1,list2 : node_ptr) : node_ptr ;
  442.  
  443. (* Append list2 to list1. This routine returns a pointer to the
  444.   combined list. Appending is done by consing each item on the first
  445.   list to the second list. This routine is one of the major sources of
  446.   garbage so if garbage collection becomes a problem, you may want to
  447.   rewrite it. *)
  448. Begin
  449. If list1 = Nil
  450. Then append_list := list2
  451. Else append_list := cons(head(list1),append_list(tail(list1),list2)) ;
  452. End ;
  453. (* append_list *)
  454.  
  455.  
  456. Function list_length(list : node_ptr) : counter ;
  457. (* returns the length of a list.
  458.   Note - both (A B C) and ( (A B) C D) have length 3. *)
  459. Begin
  460. If list = Nil
  461. Then list_length := 0
  462. Else list_length := 1 + list_length(list^.tail_ptr) ;
  463. End ;
  464. (* list_length *)
  465.  
  466.  
  467. Procedure collect_garbage ;
  468.  
  469. (* This routine is specific to Turbo Pascal Ver 3.01
  470.   It depends upon the fact that Turbo allocates memory in 8 byte blocks
  471.   on the PC. If you recompile this program on another system be very
  472.   careful with this routine.
  473.   Garbage collection proceeds in three phases:
  474.   unmark - free all memory between the initial_heap^ and the current
  475.   top of the heap.
  476.   mark - mark everything on the saved_list as being in ues.
  477.   release - gather all unmarked blocks and put them on the free list.
  478.   The collector displays a '*' on the screen to let you know it is
  479.   operating. *)
  480.  
  481. Function lower(p1,p2 : node_ptr) : boolean ;
  482. (* returns true if p1 points to a lower memory address than p2 *)
  483. Begin
  484. p1 := normalize(p1) ;
  485. p2 := normalize(p2) ;
  486. lower := (seg(p1^) < seg(p2^)) Or
  487. ((seg(p1^) = seg(p2^)) And (ofs(p1^) < ofs(p2^))) ;
  488. End ;
  489. (* lower *)
  490.  
  491. Procedure mark(list : node_ptr) ;
  492.  
  493. (* Mark the blocks on list as being in use. Since a node may be on several
  494.   lists at one time, if it is already marked we don't continue processing
  495.   the tail of the list. *)
  496. Begin
  497. If list <> Nil
  498. Then
  499. Begin
  500. If Not list^.in_use
  501. Then
  502. Begin
  503. list^.in_use := true ;
  504. If list^.tag = cons_node
  505. Then
  506. Begin
  507. mark(head(list)) ;
  508. mark(tail(list)) ;
  509. End ;
  510. End ;
  511. End ;
  512. End ;
  513. (* mark *)
  514.  
  515. Procedure unmark_mem ;
  516.  
  517. (* Go through memory from initial_heap^ to HeapPtr^ and mark each node
  518.   as not in use. The tricky part here is updating the pointer p to point
  519.   to the next cell. *)
  520.  
  521. Var
  522. p : node_ptr ;
  523. string_base,node_allocation : counter ;
  524. Begin
  525. string_base := sizeof(node_type) + sizeof(boolean) ;
  526. p := normalize(initial_heap) ;
  527. node_allocation := allocation_size(node_size) ;
  528.  
  529. (* Johnicholas says: HeapPtr is something from the TP runtime - is there something analogous in the fpc runtime?
  530.  * Are we walking over all of memory, or just some specific region? *)
  531. While lower(p, HeapPtr) Do
  532. Begin
  533. p^.in_use := false ;
  534. Case p^.tag Of
  535. cons_node : p := normalize(node_ptr(ptr(seg(p^),ofs(p^) + node_allocation))) ;
  536. free_node : p := normalize(node_ptr(ptr(seg(p^),ofs(p^) + (p^.block_cnt + 1) * 8))) ;
  537. func,
  538. constant,
  539. variable : p := normalize(node_ptr(ptr(seg(p^),
  540. ofs(p^) +
  541. allocation_size(string_base +
  542. length(p^.string_data) + 1)))) ;
  543. End ;
  544. End ;
  545. End ;
  546. (* unmark_mem *)
  547.  
  548. Procedure release_mem ;
  549.  
  550. (* This procedure does the actual collection and compaction of nodes.
  551.   This is the slow phase of garbage collection because of all the pointer
  552.   manipulation. *)
  553.  
  554. Var
  555. heap_top : node_ptr ;
  556. string_base,node_allocation,string_allocation,block_allocation : counter ;
  557.  
  558. Procedure free_memory(pt : node_ptr ; size : counter) ;
  559.  
  560. (* return size bytes pointed to by pt to the free list. If pt points to
  561.   a block next to the head of the free list combine it with the top
  562.   free node. total_free keeps track of the total number of free bytes. *)
  563.  
  564. Var
  565. blks : counter ;
  566. Begin
  567. blks := ((size - 1) Div 8) + 1 ;
  568. pt^.tag := free_node ;
  569. If normalize(node_ptr(ptr(seg(pt^),ofs(pt^) + 8 * blks))) = free
  570. Then
  571. Begin
  572. pt^.next_free := free^.next_free ;
  573. pt^.block_cnt := free^.block_cnt + blks ;
  574. free := pt ;
  575. End
  576. Else If normalize(node_ptr(ptr(seg(free^),ofs(free^) + 8 * (free^.block_cnt + 1)))) =
  577. normalize(pt)
  578. Then free^.block_cnt := free^.block_cnt + blks
  579. Else
  580. Begin
  581. pt^.next_free := free ;
  582. pt^.block_cnt := blks - 1 ;
  583. free := pt ;
  584. End ;
  585. total_free := total_free + (blks * 8.0) ;
  586. End ;
  587. (* free_memory *)
  588.  
  589. Procedure do_release ;
  590. (* This routine sweeps through memory and checks for nodes with
  591.   in_use = false. *)
  592.  
  593. Var
  594. p : node_ptr ;
  595. Begin
  596. p := normalize(initial_heap) ;
  597. While lower(p,heap_top) Do
  598. Case p^.tag Of
  599. cons_node :
  600. Begin
  601. If Not p^.in_use
  602. Then free_memory(p,node_size) ;
  603. p := normalize(node_ptr(ptr(seg(p^),ofs(p^) + node_allocation))) ;
  604. End ;
  605. free_node :
  606. Begin
  607. block_allocation := (p^.block_cnt + 1) * 8 ;
  608. free_memory(p,block_allocation) ;
  609. p := normalize(node_ptr(ptr(seg(p^),ofs(p^) + block_allocation))) ;
  610. End ;
  611. func,
  612. constant,
  613. variable :
  614. Begin
  615. string_allocation := allocation_size(string_base +
  616. length(p^.string_data) + 1) ;
  617. If Not p^.in_use
  618. Then free_memory(p,string_base + length(p^.string_data)
  619. + 1) ;
  620. p := normalize(node_ptr(ptr(seg(p^),ofs(p^) + string_allocation))) ;
  621. End ;
  622. End ;
  623. End ;
  624. (* do_release *)
  625.  
  626. Begin
  627. free := Nil ;
  628. total_free := 0.0 ;
  629. heap_top := HeapPtr ;
  630. string_base := sizeof(node_type) + sizeof(boolean) ;
  631. node_allocation := allocation_size(node_size) ;
  632. do_release ;
  633. End ;
  634. (* release_mem *)
  635.  
  636. Begin
  637. write('*') ;
  638. unmark_mem ;
  639. mark(saved_list) ;
  640. release_mem ;
  641. write(back_space) ;
  642.  
  643. ClrEol ;
  644.  
  645. End ;
  646. (* collect_garbage *)
  647.  
  648.  
  649. Procedure test_memory ;
  650.  
  651. (* This routine activates the garbage collector, if the the total available
  652.   memory (free_list + heap) is less than a specified amount. Lowering the
  653.   minimum causes garbage collection to be called less often, but if you
  654.   make it too small you may not have enough room left for recursion or any
  655.   temporary lists you need. Using 10000 is probably being overly
  656.   cautious. *)
  657. Begin
  658. (* Johnicholas says: is memavail something in the legacy context? yes
  659.   * The fpc docs say: The MemAvail and MaxAvail functions are no longer available.
  660.   * On modern operating systems, the idea of "Available Free Memory" is not valid for an application.
  661.   * The reasons are:
  662.   * 1. One processor cycle after an application asked the OS how much memory was free, another application
  663.   * may have allocated everything.
  664.   * 2. It is not clear what "free memory" means [...snip...]
  665.   If (memavail * 16.0) + total_free < 10000
  666.   Then collect_garbage ;
  667.   *)
  668. End ;
  669. (* test_memory *)
  670.  
  671.  
  672. Procedure wait ;
  673. (* Just like it says. It waits for the user to press a key before
  674.   continuing. *)
  675.  
  676. Var
  677. ch : char ;
  678. Begin
  679. writeln ;
  680. writeln ;
  681. write('Press any key to continue. ') ;
  682. read(Input,ch) ;
  683. write(return) ;
  684.  
  685. ClrEol ;
  686.  
  687. End ;
  688. (* wait *)
  689.  
  690.  
  691.  
  692. (* ------------------------------------------------------------------------
  693.   End of utility routines
  694.   ------------------------------------------------------------------------ *)
  695.  
  696. Procedure read_kbd(Var s : string80) ;
  697. (* Read a line from the keyboard *)
  698. Begin
  699. write('-> ') ;
  700. readln(s) ;
  701. End ;
  702. (* read_kbd *)
  703.  
  704.  
  705. Procedure read_from_file(Var f : text_file) ;
  706.  
  707. (* Read a line from file f and store it in the global variable line.
  708.   It ignores blank lines and when the end of file is reached an
  709.   eof_mark is returned. *)
  710.  
  711. Procedure read_a_line ;
  712. Begin
  713. (*$I- *)
  714. readln(f,line) ;
  715. (*$I+ *)
  716. If ioresult <> 0
  717. Then line := eof_mark
  718. Else If eof(f)
  719. Then line := concat(line,eof_mark) ;
  720. End ;
  721. (* read_a_line *)
  722.  
  723. Begin
  724. line := '' ;
  725. If is_console(f)
  726. Then read_kbd(line)
  727. Else read_a_line ;
  728. If in_comment
  729. Then
  730. If pos('*)',line) > 0
  731. Then
  732. Begin
  733. delete(line,1,pos('*)',line) + 1) ;
  734. in_comment := false ;
  735. End
  736. Else read_from_file(f) ;
  737. saved_line := line ;
  738. End ;
  739. (* read_from_file *)
  740.  
  741.  
  742. Procedure get_token(Var t_line : string132 ; Var token : string80) ;
  743.  
  744. (* Extract a token from t_line. Comments are ignored. A token is
  745.   a string surrounded by delimiters or an end of line. Tokens may
  746.   contain embedded spaces if they are surrounded by quote marks *)
  747.  
  748. Procedure get_word ;
  749.  
  750. Var
  751. done : boolean ;
  752. cn : integer ;
  753. len : byte ;
  754. Begin
  755. cn := 1 ;
  756. len := length(t_line) ;
  757. done := false ;
  758. While Not done Do
  759. If cn > len
  760. Then done := true
  761. Else If t_line[cn] In delim_set
  762. Then done := true
  763. Else cn := cn + 1 ;
  764. token := copy(t_line,1,cn-1) ;
  765. delete(t_line,1,cn-1) ;
  766. End ;
  767. (* get_word *)
  768.  
  769. Procedure comment ;
  770. Begin
  771. If pos('*)',t_line) > 0
  772. Then
  773. Begin
  774. delete(t_line,1,pos('*)',t_line)+1) ;
  775. get_token(line,token) ;
  776. End
  777. Else
  778. Begin
  779. t_line := '' ;
  780. token := '' ;
  781. in_comment := true ;
  782. End ;
  783. End ;
  784. (* comment *)
  785.  
  786. Procedure get_quote ;
  787. Begin
  788. delete(t_line,1,1) ;
  789. If pos(quote_char,t_line) > 0
  790. Then
  791. Begin
  792. token := concat(quote_char,copy(t_line,1,pos(quote_char,t_line) - 1)) ;
  793. delete(t_line,1,pos(quote_char,t_line)) ;
  794. End
  795. Else
  796. Begin
  797. token := t_line ;
  798. t_line := '' ;
  799. End ;
  800. End ;
  801. (* get_quote *)
  802.  
  803. Begin
  804. strip_leading_blanks(t_line) ;
  805. If length(t_line) > 0
  806. Then
  807. Begin
  808. If copy(t_line,1,2) = '(*'
  809. Then comment
  810. Else If (copy(t_line,1,2) = ':-') Or (copy(t_line,1,2) = '?-')
  811. Then
  812. Begin
  813. token := copy(t_line,1,2) ;
  814. delete(t_line,1,2) ;
  815. End
  816. Else If t_line[1] = quote_char
  817. Then get_quote
  818. Else If t_line[1] In delim_set
  819. Then
  820. Begin
  821. token := t_line[1] ;
  822. delete(t_line,1,1) ;
  823. End
  824. Else get_word ;
  825. End
  826. Else token := '' ;
  827. End ;
  828. (* get_token *)
  829.  
  830.  
  831. Procedure scan(Var f : text_file ; Var token : string80) ;
  832.  
  833. (* Scan repeatedly calls get_token to retreive tokens. When the
  834.   end of a line has been reached, read_from_file is called to
  835.   get a new line. *)
  836. Begin
  837. If length(line) > 0
  838. Then
  839. Begin
  840. get_token(line,token) ;
  841. If token = ''
  842. Then scan(f,token) ;
  843. End
  844. Else
  845. Begin
  846. read_from_file(f) ;
  847. scan(f,token) ;
  848. End ;
  849. End ;
  850. (* scan *)
  851.  
  852.  
  853. Procedure compile(Var source : text_file) ;
  854.  
  855. (* The recursive descent compiler. It reads tokens until the token
  856.   'EXIT' is found. If the token is '?-', a query is performed, a '@' token
  857.   is the command to read a new file and source statements are read form that
  858.   file, otherwise the token is assumed to be part of a sentence and the rest
  859.   of the sentence is parsed. *)
  860.  
  861. Procedure error(error_msg : string80) ;
  862.  
  863. (* Signal an error. Prints saved_line to show where the error is located.
  864.   saved_line contains the current line being parsed. it is required,
  865.   because get_token chews up line as it reads tokens. *)
  866.  
  867. Procedure runout ;
  868. Begin
  869. While (token <> '.') And (token <> eof_mark) Do
  870. scan(source,token) ;
  871. End ;
  872. (* runout *)
  873.  
  874. Begin
  875. error_flag := true ;
  876. writeln ;
  877. writeln(error_msg) ;
  878. writeln ;
  879. writeln(saved_line) ;
  880. writeln('' : length(saved_line) - length(line) - 1,'^') ; ;
  881. runout ;
  882. wait ;
  883. End ;
  884. (* error *)
  885.  
  886. Procedure goal(Var l_ptr : node_ptr) ;
  887.  
  888. (* Read a goal. The new goal is appended to l_ptr. Each goal is appended
  889.   to l_ptr as a list. Thus, the sentence 'likes(john,X) :- likes(X,wine) .'
  890.   becomes the list ( (likes john X) (likes X wine) ) *)
  891.  
  892. Var
  893. goal_token : string80 ;
  894.  
  895. Procedure functor(Var f_ptr : node_ptr ; func_token : string80) ;
  896.  
  897. (* The current goal is a functor. This routine allocates a node
  898.   to store the functor and then processes the components of the
  899.   functor. On exit, f_ptr points to the list containing the functor
  900.   and its components. func_token contains the functor name. *)
  901.  
  902. Var
  903. c_ptr : node_ptr ;
  904.  
  905. Procedure components(Var cm_ptr : node_ptr) ;
  906.  
  907. (* Process the components of the functor. The components are terms
  908.   seperated by commas. On exit, cm_ptr points to the list of
  909.   components. *)
  910.  
  911. Procedure term(Var t_ptr : node_ptr) ;
  912. (* Process a single term. The new term is appended to t_ptr. *)
  913.  
  914. Var
  915. t_token : string80 ;
  916.  
  917. Procedure quoted_str(Var q_ptr : node_ptr) ;
  918. (* Process a quote *)
  919. Begin
  920. q_ptr := append_list(q_ptr,cons(alloc_str(constant,
  921. copy(token,2,length(token) - 1)),
  922. Nil)) ;
  923. scan(source,token) ;
  924. End ;
  925. (* quoted_str *)
  926.  
  927. Procedure varbl(Var v_ptr : node_ptr) ;
  928. (* The current token is a varaible, allocate a node and return
  929.   a pointer to it. *)
  930. Begin
  931. v_ptr := append_list(v_ptr,cons(alloc_str(variable,token),Nil)) ;
  932. scan(source,token) ;
  933. End ;
  934. (* varbl *)
  935.  
  936. Procedure number(Var n_ptr : node_ptr) ;
  937.  
  938. (* Numbers are treated as string constants. This isn't particularly
  939.   efficent, but it is easy. *)
  940. Begin
  941. n_ptr := append_list(n_ptr,cons(alloc_str(constant,token),Nil)) ;
  942. scan(source,token) ;
  943. End ;
  944. (* handle_number *)
  945.  
  946. Begin
  947. If token[1] In ['A' .. 'Z','_']
  948. Then varbl(t_ptr)
  949. Else If token[1] = quote_char
  950. Then quoted_str(t_ptr)
  951. Else If is_number(token)
  952. Then number(t_ptr)
  953. Else If token[1] In ['a' .. 'z']
  954. Then
  955. Begin
  956. t_token := token ;
  957. scan(source,token) ;
  958. If token = '('
  959. Then functor(t_ptr,t_token)
  960. Else t_ptr := append_list(t_ptr,
  961. cons(alloc_str(constant,t_token),Nil)) ;
  962. End
  963. Else error('Illegal Symbol.') ;
  964. End ;
  965. (* term *)
  966.  
  967. Begin
  968. term(cm_ptr) ;
  969. If token = ','
  970. Then
  971. Begin
  972. scan(source,token) ;
  973. components(cm_ptr) ;
  974. End ;
  975. End ;
  976. (* components *)
  977.  
  978. Begin
  979. c_ptr := cons(alloc_str(func,func_token),Nil) ;
  980. scan(source,token) ;
  981. components(c_ptr) ;
  982. If token = ')'
  983. Then
  984. Begin
  985. f_ptr := append_list(f_ptr,cons(c_ptr,Nil)) ;
  986. scan(source,token) ;
  987. End
  988. Else error('Missing '')''.') ;
  989. End ;
  990. (* functor *)
  991.  
  992. Begin
  993. If token[1] In ['a' .. 'z',quote_char]
  994. Then
  995. Begin
  996. If token[1] = quote_char
  997. Then
  998. Begin
  999. l_ptr := append_list(l_ptr,
  1000. cons(cons(alloc_str(constant,
  1001. copy(token,2,length(token) - 1)),Nil),Nil)) ;
  1002. scan(source,token) ;
  1003. End
  1004. Else
  1005. Begin
  1006. goal_token := token ;
  1007. scan(source,token) ;
  1008. If token = '('
  1009. Then functor(l_ptr,goal_token)
  1010. Else l_ptr := append_list(l_ptr,
  1011. cons(cons(alloc_str(constant,goal_token),
  1012. Nil),Nil)) ;
  1013. End
  1014. End
  1015. Else error('A goal must begin with ''a .. z'' or be a quoted string.') ;
  1016. End ;
  1017. (* goal *)
  1018.  
  1019. Procedure tail_list(Var t_ptr : node_ptr) ;
  1020.  
  1021. (* Process the tail of a rule. Since the a query is syntactically identical
  1022.   to the tail of a rule, this routine is used to compile queries.
  1023.   On exit, t_ptr points to the list containing the tail. *)
  1024. Begin
  1025. goal(t_ptr) ;
  1026. If token = ','
  1027. Then
  1028. Begin
  1029. scan(source,token) ;
  1030. tail_list(t_ptr) ;
  1031. End ;
  1032. End ;
  1033. (* tail *)
  1034.  
  1035. Procedure rule ;
  1036.  
  1037. (* Procees a rule, actually any sentence. If no error occurs the
  1038.   new sentence is appended to the data base. *)
  1039.  
  1040. Var
  1041. r_ptr : node_ptr ;
  1042.  
  1043. Procedure head_list(Var h_ptr : node_ptr) ;
  1044. Begin
  1045. goal(h_ptr) ;
  1046. End ;
  1047. (* head *)
  1048.  
  1049. Begin
  1050. saved_list := cons(data_base,Nil) ;
  1051. test_memory ;
  1052. r_ptr := Nil ;
  1053. head_list(r_ptr) ;
  1054. If token = ':-'
  1055. Then
  1056. Begin
  1057. scan(source,token) ;
  1058. tail_list(r_ptr) ;
  1059. End ;
  1060. If token <> '.'
  1061. Then error('''.'' expected.') ;
  1062. If Not error_flag
  1063. Then data_base := append_list(data_base,cons(r_ptr,Nil)) ;
  1064. End ;
  1065. (* rule *)
  1066.  
  1067. Procedure query ;
  1068.  
  1069. (* Process a query. Compile the query, and then call solve to search the
  1070.   data base. q_ptr points to the compiled query and solved is a boolean
  1071.   indicating whether the query was successfully solved. *)
  1072.  
  1073. Var
  1074. q_ptr : node_ptr ;
  1075. solved : boolean ;
  1076.  
  1077. Procedure solve(list,env : node_ptr ; level : counter) ;
  1078.  
  1079. (* This is where all the hard work is done. This routine follows the
  1080.   steps outlined in the article. list is the query to be soved, env is
  1081.   the current environment and level is the recursion level. level can
  1082.   only get to 32767, but you'll run out of stack space long before you
  1083.   get that far.
  1084.   solve saves list and env on the saved list so that they won't be
  1085.   destroyed by garbage collection. The data base is always on the
  1086.   saved list. At the end of solve, list and env are removed from
  1087.   saved_list. *)
  1088.  
  1089. Var
  1090. new_env,p : node_ptr ;
  1091.  
  1092. Function look_up(var_str : string80 ; environ : node_ptr) : node_ptr ;
  1093.  
  1094. (* Search the environment list pointed to by environ for the variable,
  1095.   var_str. If found return a pointer to var_str's binding, otherwise
  1096.   return NIL *)
  1097.  
  1098. Var
  1099. found : boolean ;
  1100. p : node_ptr ;
  1101. Begin
  1102. p := environ ;
  1103. found := false ;
  1104. While (p <> Nil) And (Not found) Do
  1105. Begin
  1106. If var_str = string_val(head(head(p)))
  1107. Then
  1108. Begin
  1109. found := true ;
  1110. look_up := tail(head(p)) ;
  1111. End
  1112. Else p := tail(p) ;
  1113. End ;
  1114. If Not found
  1115. Then look_up := Nil ;
  1116. End ;
  1117. (* look_up *)
  1118.  
  1119. Procedure check_continue ;
  1120.  
  1121. (* Print the bindings and see if the user is satisfied. If nothing
  1122.   is printed from the environment, then print 'Yes' to indicate
  1123.   that the query was successfully satisfied. *)
  1124.  
  1125. Var
  1126. printed : boolean ;
  1127. ch : char ;
  1128.  
  1129. Procedure print_bindings(list : node_ptr) ;
  1130.  
  1131. (* Print the bindings for level 0 variables only, intermediate variables
  1132.   aren't of interest. The routine recursivley searches for the
  1133.   end of the environments list and then prints the binding. This
  1134.   is so that variables bound first are printed first. *)
  1135.  
  1136. Procedure print_functor(l : node_ptr) ;
  1137. FORWARD ;
  1138.  
  1139. Procedure print_variable(var_str : string80) ;
  1140.  
  1141. (* The varaible in question was bound to another varaible, so look
  1142.   up that variable's binding and print it. If a match can't be found
  1143.   print '_' to tell the user that the variable is anonymous. *)
  1144.  
  1145. Var
  1146. var_ptr : node_ptr ;
  1147. Begin
  1148. var_ptr := look_up(var_str,env) ;
  1149. If var_ptr <> Nil
  1150. Then
  1151. Case tag_value(head(var_ptr)) Of
  1152. constant : write(string_val(head(var_ptr)),' ') ;
  1153. variable : print_variable(string_val(head(var_ptr))) ;
  1154. cons_node : print_functor(head(var_ptr)) ;
  1155. End
  1156. Else write('_ ') ;
  1157. End ;
  1158. (* print_variable *)
  1159.  
  1160. Procedure print_functor (l : node_ptr) ;
  1161. (* The variable was bound to a functor. Print the functor and its
  1162.   components. *)
  1163.  
  1164. Procedure print_components(p : node_ptr) ;
  1165.  
  1166. (* Print the components of a functor. These may be variables or
  1167.   other functors, so call the approriate routines to print them. *)
  1168. Begin
  1169. If p <> Nil
  1170. Then
  1171. Begin
  1172. Case tag_value(head(p)) Of
  1173. constant : write(string_val(head(p)),' ') ;
  1174. variable : print_variable(string_val(head(p))) ;
  1175. cons_node : print_functor(head(p)) ;
  1176. End ;
  1177. If tail(p) <> Nil
  1178. Then
  1179. Begin
  1180. write(',') ;
  1181. print_components(tail(p)) ;
  1182. End ;
  1183. End ;
  1184. End ;
  1185. (* print_components *)
  1186.  
  1187. Begin
  1188. If l <> Nil
  1189. Then
  1190. Begin
  1191. write(string_val(head(l))) ;
  1192. If tail(l) <> Nil
  1193. Then
  1194. Begin
  1195. write('(') ;
  1196. print_components(tail(l)) ;
  1197. write(')') ;
  1198. End ;
  1199. End ;
  1200. End ;
  1201. (* print_functor *)
  1202.  
  1203. Begin
  1204. If list <> Nil
  1205. Then
  1206. Begin
  1207. print_bindings(tail(list)) ;
  1208. If pos('#',string_val(head(head(list)))) = 0
  1209. Then
  1210. Begin
  1211. printed := true ;
  1212. writeln ;
  1213. write(string_val(head(head(list))),' = ') ;
  1214. Case tag_value(head(tail(head(list)))) Of
  1215. constant : write(string_val(head(tail(head(list)))),' ') ;
  1216. variable : print_variable(string_val(head(tail(head(list))))) ;
  1217. cons_node : print_functor(head(tail(head(list)))) ;
  1218. End ;
  1219. End ;
  1220. End ;
  1221. End ;
  1222. (* print_bindings *)
  1223.  
  1224. Begin
  1225. printed := false ;
  1226. print_bindings(env) ;
  1227. If Not printed
  1228. Then
  1229. Begin
  1230. writeln ;
  1231. write('Yes ') ;
  1232. End ;
  1233. Repeat
  1234. read(Input,ch) ;
  1235. Until ch In [return,';'] ;
  1236. solved := (ch = return) ;
  1237. writeln ;
  1238. End ;
  1239. (* check_continue *)
  1240.  
  1241. Function copy_list(list : node_ptr ; copy_level : counter) : node_ptr ;
  1242. (* Copy a list and append the copy_level (recursion level) to all
  1243.   variables. *)
  1244.  
  1245. Var
  1246. temp_list,p : node_ptr ;
  1247. level_str : string[6] ;
  1248.  
  1249. Procedure list_copy(from_list : node_ptr ; Var to_list : node_ptr) ;
  1250. Begin
  1251. If from_list <> Nil
  1252. Then
  1253. Case from_list^.tag Of
  1254. variable : to_list := alloc_str(variable,
  1255. concat(from_list^.string_data,
  1256. level_str)) ;
  1257. func,
  1258. constant : to_list := from_list ;
  1259. cons_node :
  1260. Begin
  1261. list_copy(tail(from_list),to_list) ;
  1262. to_list := cons(copy_list(head(from_list),copy_level),
  1263. to_list) ;
  1264. End ;
  1265. End ;
  1266. End ;
  1267. (* list_copy *)
  1268.  
  1269. Begin
  1270. str(copy_level,level_str) ;
  1271. level_str := concat('#',level_str) ;
  1272. temp_list := Nil ;
  1273. list_copy(list,temp_list) ;
  1274. copy_list := temp_list ;
  1275. End ;
  1276. (* copy_list *)
  1277.  
  1278. Function unify(list1,list2,environ : node_ptr ; Var new_environ : node_ptr) :
  1279. boolean ;
  1280.  
  1281. (* Unify two lists and return any new bindings at the front of the
  1282.   environment list. Returns true if the lists could be unified. This
  1283.   routine implements the unification table described in the article.
  1284.   Unification is straight forward, but the details of matching the
  1285.   lists get a little messy in this routine. There are better ways to
  1286.   do all of this, we just haven't gotten around to trying them. If
  1287.   you implement any other unification methods, we would be glad to
  1288.   hear about it.
  1289.   Unify checks to see if both lists are NIL, this is a successful
  1290.   unification. If one list is NIL, unification fails. Otherwise check
  1291.   what kind on node the head of list1 is and call the appropriate
  1292.   routine to perform the unification. Variables are unified by
  1293.   looking up the binding of the variable. If none is found, make
  1294.   a binding for the variable, otherwise try to unify the binding
  1295.   with list2. *)
  1296.  
  1297. Var
  1298. var_ptr : node_ptr ;
  1299.  
  1300. Procedure make_binding(l1,l2 : node_ptr) ;
  1301.  
  1302. (* Bind a variable to the environment. Anonymous variables are not bound.
  1303.   l1 points to the variable and l2 points to its binding. *)
  1304. Begin
  1305. If copy(string_val(head(l1)),1,1) <> '_'
  1306. Then new_environ := cons(cons(head(l1),l2),environ)
  1307. Else new_environ := environ ;
  1308. unify := true ;
  1309. End ;
  1310. (* make_binding *)
  1311.  
  1312. Procedure fail ;
  1313. (* Unification failed. *)
  1314. Begin
  1315. unify := false ;
  1316. new_environ := environ ;
  1317. End ;
  1318. (* fail *)
  1319.  
  1320. Procedure unify_constant ;
  1321.  
  1322. (* List1 contains a constant. Try to unify it with list2. The 4 cases
  1323.   are:
  1324.   list2 contains
  1325.   constant - unify if constants match
  1326.   variable - look up binding, if no current binding bind the
  1327.   constant to the variable, otherwise unify list1
  1328.   with the binding.
  1329.   cons_node,
  1330.   func - these can't be unified with a constant. A cons_node
  1331.   indicates an expression. *)
  1332. Begin
  1333. Case tag_value(head(list2)) Of
  1334. constant : If string_val(head(list1)) = string_val(head(list2))
  1335. Then
  1336. Begin
  1337. unify := true ;
  1338. new_environ := environ ;
  1339. End
  1340. Else fail ;
  1341. variable :
  1342. Begin
  1343. var_ptr := look_up(string_val(head(list2)),environ) ;
  1344. If var_ptr = Nil
  1345. Then make_binding(list2,list1)
  1346. Else unify := unify(list1,var_ptr,environ,new_environ) ;
  1347. End ;
  1348. cons_node,
  1349. func : fail ;
  1350. End ;
  1351. End ;
  1352. (* unify_constant *)
  1353.  
  1354. Procedure unify_func ;
  1355.  
  1356. (* List1 contains a functor. Try to unify it with list2. The 4 cases
  1357.   are:
  1358.   list2 contains
  1359.   constant - can't be unified.
  1360.   variable - look up binding, if no current binding bind the
  1361.   functor to the variable, otherwise unify list1
  1362.   with the binding.
  1363.   cons_node - fail
  1364.   func - if the functors match, then true to unify the component
  1365.   lists (tail of the list) term by term. *)
  1366.  
  1367. Procedure unify_tail ;
  1368. (* This routine does the term by term unification of the component
  1369.   lists *)
  1370.  
  1371. Var
  1372. p,q : node_ptr ;
  1373. unified : boolean ;
  1374. Begin
  1375. p := tail(list1) ;
  1376. q := tail(list2) ;
  1377. unified := true ;
  1378. new_environ := environ ;
  1379. While (p <> Nil) And unified Do
  1380. Begin
  1381. unified := unified And unify(cons(head(p),Nil),cons(head(q),Nil),
  1382. new_environ,new_environ) ;
  1383. p := tail(p) ;
  1384. q := tail(q) ;
  1385. End ;
  1386. If Not unified
  1387. Then fail ;
  1388. End ;
  1389. (* unify_tail *)
  1390.  
  1391. Begin
  1392. Case tag_value(head(list2)) Of
  1393. constant : fail ;
  1394. variable :
  1395. Begin
  1396. var_ptr := look_up(string_val(head(list2)),environ) ;
  1397. If var_ptr = Nil
  1398. Then make_binding(list2,list1)
  1399. Else unify := unify(list1,var_ptr,environ,new_environ) ;
  1400. End ;
  1401. func : If string_val(head(list1)) = string_val(head(list2))
  1402. Then
  1403. If list_length(tail(list1)) = list_length(tail(list2))
  1404. Then unify_tail
  1405. Else fail
  1406. Else fail ;
  1407. cons_node : fail ;
  1408. End ;
  1409. End ;
  1410. (* unify_func *)
  1411.  
  1412. Procedure unify_expr ;
  1413.  
  1414. (* List1 contains an expression. Try to unify it with list2. The 4 cases
  1415.   are:
  1416.   list2 contains
  1417.   constant - can't be unified.
  1418.   variable - look up binding, if no current binding bind the
  1419.   functor to the variable, otherwise unify list1
  1420.   with the binding.
  1421.   cons_node - If the heads can be unified, the unify the tails.
  1422.   func - fail *)
  1423. Begin
  1424. Case tag_value(head(list2)) Of
  1425. constant : fail ;
  1426. variable :
  1427. Begin
  1428. var_ptr := look_up(string_val(head(list2)),environ) ;
  1429. If var_ptr = Nil
  1430. Then make_binding(list2,list1)
  1431. Else unify := unify(list1,var_ptr,environ,new_environ) ;
  1432. End ;
  1433. func : fail ;
  1434. cons_node : If unify(head(list1),head(list2),environ,new_environ)
  1435. Then unify := unify(tail(list1),tail(list2),new_environ,
  1436. new_environ)
  1437. Else fail ;
  1438. End ;
  1439. End ;
  1440. (* unify_expr *)
  1441.  
  1442. Begin
  1443. If (list1 = Nil) And (list2 = Nil)
  1444. Then
  1445. Begin
  1446. unify := true ;
  1447. new_environ := environ ;
  1448. End
  1449. Else If list1 = Nil
  1450. Then fail
  1451. Else If list2 = Nil
  1452. Then fail
  1453. Else
  1454. Case tag_value(head(list1)) Of
  1455. constant : unify_constant ;
  1456. variable :
  1457. Begin
  1458. var_ptr := look_up(string_val(head(list1)),environ) ;
  1459. If var_ptr = Nil
  1460. Then make_binding(list1,list2)
  1461. Else unify := unify(var_ptr,list2,environ,new_environ) ;
  1462. End ;
  1463. func : unify_func ;
  1464. cons_node : unify_expr ;
  1465. End ;
  1466. End ;
  1467. (* unify *)
  1468.  
  1469. Begin
  1470. saved_list := cons(list,cons(env,saved_list)) ;
  1471. If list = Nil
  1472. Then check_continue
  1473. Else
  1474. Begin
  1475. p := data_base ;
  1476. While (p <> Nil) And (Not solved) Do
  1477. Begin
  1478. test_memory ;
  1479. If unify(copy_list(head(head(p)),level),head(list),env,new_env)
  1480. Then solve(append_list(copy_list(tail(head(p)),level),tail(list)),
  1481. new_env,level + 1) ;
  1482. p := tail(p) ;
  1483. End ;
  1484. End ;
  1485. saved_list := tail(tail(saved_list)) ;
  1486. End ;
  1487. (* solve *)
  1488.  
  1489. Begin
  1490. q_ptr := Nil ;
  1491. tail_list(q_ptr) ;
  1492. If token <> '.'
  1493. Then error('''.'' expected.')
  1494. Else If Not error_flag
  1495. Then
  1496. Begin
  1497. solved := false ;
  1498. saved_list := cons(data_base,Nil) ;
  1499. solve(q_ptr,Nil,0) ;
  1500. If Not solved
  1501. Then writeln('No') ;
  1502. End ;
  1503. End ;
  1504. (* query *)
  1505.  
  1506. Procedure read_new_file ;
  1507.  
  1508. (* Read source statements from a new file. When all done, close file
  1509.   and continue reading from the old file. Files may be nested, but you
  1510.   will run into trouble if you nest them deaper than 15 levels. This
  1511.   is Turbo's default for open files. *)
  1512.  
  1513. Var
  1514. new_file : text_file ;
  1515. old_line,old_save : string132 ;
  1516. f_name : string80 ;
  1517. Begin
  1518. If token[1] = quote_char
  1519. Then delete(token,1,1) ;
  1520. If pos('.',token) = 0
  1521. Then f_name := concat(token,'.PRO')
  1522. Else f_name := token ;
  1523. If open(new_file,f_name)
  1524. Then
  1525. Begin
  1526. old_line := line ;
  1527. old_save := saved_line ;
  1528. line := '' ;
  1529. compile(new_file) ;
  1530. close(new_file) ;
  1531. line := old_line ;
  1532. saved_line := old_save ;
  1533. scan(source,token) ;
  1534. If token <> '.'
  1535. Then error('''.'' expected.') ;
  1536. End
  1537. Else error(concat('Unable to open ',f_name)) ;
  1538. End ;
  1539. (* read_new_file *)
  1540.  
  1541. Procedure do_exit ;
  1542.  
  1543. (* Exit the program. This really should be a built-in function and handled
  1544.   in solve, but this does the trick. *)
  1545. Begin
  1546. scan(source,token) ;
  1547. If token <> '.'
  1548. Then error('''.'' expected.')
  1549. Else halt
  1550. End ;
  1551. (* do_exit *)
  1552.  
  1553. Begin
  1554. scan(source,token) ;
  1555. While token <> eof_mark Do
  1556. Begin
  1557. error_flag := false ;
  1558. If token = '?-'
  1559. Then
  1560. Begin
  1561. scan(source,token) ;
  1562. query ;
  1563. End
  1564. Else If token = '@'
  1565. Then
  1566. Begin
  1567. scan(source,token) ;
  1568. read_new_file ;
  1569. End
  1570. Else If toupper(token) = 'EXIT'
  1571. Then do_exit
  1572. Else rule ;
  1573. scan(source,token) ;
  1574. End ;
  1575. End ;
  1576. (* compile *)
  1577.  
  1578.  
  1579. Procedure initialize ;
  1580. (* Write a heading line and initialize the global variables *)
  1581. Begin
  1582. clrscr ;
  1583. writeln ;
  1584. writeln('Very Tiny Prolog - Version 1.0 [c] 1986 MicroExpert Systems') ;
  1585. writeln ;
  1586. in_comment := false ;
  1587. delim_set := [' ',')','(',',','[',']',eof_mark,tab,quote_char,':',
  1588. '@','.','?'] ;
  1589. text_chars := [' ' .. '~'] ;
  1590. line := '' ;
  1591. data_base := Nil ;
  1592. free := Nil ;
  1593. saved_list := Nil ;
  1594. total_free := 0.0 ;
  1595. initial_heap := HeapPtr ;
  1596. End ;
  1597. (* initialize *)
  1598.  
  1599.  
  1600. Begin
  1601. initialize ;
  1602. compile(Input) ;
  1603. End.
Success #stdin #stdout 0s 280KB
stdin
Standard input is empty
stdout
Very Tiny Prolog - Version 1.0     [c] 1986 MicroExpert Systems