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