home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / EXAMPLES / SUPERLIN / SL_RULE_.LF < prev    next >
Text File  |  1996-06-04  |  14KB  |  770 lines
  1. %
  2. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  3. %
  4. %
  5. %                         SUPERLINT's RULE EXPANDER
  6. %                         -------------------------
  7. %
  8. %  
  9. %
  10. %
  11. %  AUTHOR : Arnaud Venet                     CREATION : September 8th 1993
  12. %  ------                                    --------
  13. %
  14. %
  15. %                             ---------------                        
  16. %
  17. %                    
  18. %                   Last modification : October 29th 1993 
  19. %
  20. %
  21. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  22. %
  23. %
  24. %  (C) Digital Equipment Corporation 1993
  25. %
  26. %
  27. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  28. %
  29.  
  30.  
  31.  
  32. module("sl_rule_expander") ?
  33.  
  34.  
  35. public(compile_rules) ?
  36.  
  37.  
  38. public(:->, ==, <>, &&, ||, if, then, else, switch, case, default,
  39.        entry_test, rule, function, procedure, return,
  40.        donothing, display_rules, error_msg, main) ?
  41.  
  42.  
  43. %
  44. % ------------------------------------------------------------------------------
  45. %
  46.  
  47.  
  48. load("sl_io_utils") ?
  49.  
  50.  
  51. load("slc_file_names") ?
  52.  
  53.  
  54. import("accumulators") ?
  55.  
  56.  
  57. %
  58. % ------------------------------------------------------------------------------
  59. %
  60.  
  61.  
  62. op(1200, xfy, :->)?
  63.  
  64. non_strict(:->) ?
  65.  
  66.  
  67. op(670, xfx, ==) ?
  68.  
  69. non_strict(==) ?
  70.  
  71.  
  72. op(670, xfx, <>) ?
  73.  
  74. non_strict(<>) ?
  75.  
  76.  
  77. op(680, yfx, &&) ?
  78.  
  79. non_strict(&&) ?
  80.  
  81.  
  82. op(690, yfx, ||) ?
  83.  
  84. non_strict(||) ?
  85.  
  86.  
  87. op(900, yfx, else) ?
  88.  
  89. non_strict(else) ?
  90.  
  91.  
  92. op(890, xfy, then) ?
  93.  
  94. non_strict(then) ?
  95.  
  96.  
  97. op(880, fy, if) ?
  98.  
  99. non_strict(if) ?
  100.  
  101.  
  102. op(500, fy, return) ?
  103.  
  104. non_strict(return) ?
  105.  
  106.  
  107. op(1200, fx, function) ?
  108.  
  109. non_strict(function) ?
  110.  
  111.  
  112. op(1200, fx, procedure) ?
  113.  
  114. non_strict(procedure) ?
  115.  
  116.  
  117. op(1200, fx, rule) ?
  118.  
  119. non_strict(rule) ?
  120.  
  121.  
  122. %
  123. % ------------------------------------------------------------------------------
  124. %
  125.  
  126.  
  127. acc_info(rules, X, In, Out, acc_pred => (In = [X | Out])) ?
  128.  
  129.  
  130. acc_info(local, X, In, Out, acc_pred => (In = [X | Out])) ?
  131.  
  132.  
  133. %
  134. % ------------------------------------------------------------------------------
  135. %
  136.  
  137.  
  138. pred_info([compile_the_rules,
  139.            compile_rules_in,
  140.            expand_declaration],
  141.           [rules, local]) ?
  142.  
  143.  
  144. %
  145. % ------------------------------------------------------------------------------
  146. %
  147.  
  148.  
  149. is_reserved(Name) -> Bool
  150.   | (
  151.       Name :== {"main"; "*rule*"; 
  152.                 "syntactic_tree"; "sl_parse"; "sl_init";
  153.                 "*protected_project*"; "*protected_has_feature*"},
  154.       !,
  155.       Bool = true
  156.     ;
  157.       Bool = false
  158.     ).
  159.  
  160.  
  161. %
  162. % ------------------------------------------------------------------------------
  163. %
  164.  
  165.  
  166. compile_rules(from => FilesList, in => ExpandedFile) :-
  167.   open_out(ExpandedFile, OutStream),
  168.   write_prelude(ExpandedFile),
  169.   (
  170.     compile_the_rules(FilesList, in_rules => Rules, out_rules => []),
  171.     !
  172.   ;
  173.     write_err("slc : abort"),
  174.     nl_err,
  175.     remove_file(ExpandedFile),
  176.     halt
  177.   ),
  178.   check_entry_point(Rules),
  179.   write_rules_list(Rules),
  180.   close(OutStream).
  181.  
  182.  
  183. %
  184. % ------------------------------------------------------------------------------
  185. %
  186.  
  187.  
  188. write_prelude(ModuleName) :-
  189.   write("module(""superlint"") ?"),
  190.   nl,
  191.   nl,
  192.   write("public(main) ?"),
  193.   nl,
  194.   nl,
  195.   write("D = getenv(""SLDIR""), chdir(D) ?"),
  196.   nl,
  197.   nl,
  198.   CPT = c_public_terms_file,
  199.   writeq(load(CPT), '?'),
  200.   nl,
  201.   SLPT = sl_public_terms_file,
  202.   writeq(load(SLPT), '?'),
  203.   nl,
  204.   SLU = sl_utils_file,
  205.   writeq(load(SLU), '?'),
  206.   nl,
  207.   SLP = sl_parser_file,
  208.   writeq(load(SLP), '?'),
  209.   nl,
  210.   nl,
  211.   writeq(open("c_public_terms"), '?'),
  212.   nl,
  213.   writeq(open("sl_public_terms"), '?'),
  214.   nl,
  215.   writeq(open("sl_parser"), '?'),
  216.   nl,
  217.   writeq(open("sl_utils"), '?'),
  218.   nl,  
  219.   RLO = rl_overload_file,
  220.   writeq(load(RLO), '?'),
  221.   nl,
  222.   nl.
  223.  
  224.  
  225. %
  226. % ------------------------------------------------------------------------------
  227. %
  228.  
  229.  
  230. check_entry_point(Rules) :-
  231.   (
  232.     member(main, Rules),
  233.     !
  234.   ;
  235.     pretty_write('M : main :- 
  236.                     sl_parse(strip(M)),',
  237.                     scan_tree, '.'),
  238.     nl,
  239.     nl
  240.   ).
  241.  
  242.  
  243. %
  244. % ------------------------------------------------------------------------------
  245. %
  246.  
  247.  
  248. compile_the_rules([File | Files]) :--
  249.   !,
  250.   { safe_open_in(File, InStream) },
  251.   compile_rules_in(InStream),
  252.   { close(InStream) },
  253.   compile_the_rules(Files).
  254.  
  255.  
  256. compile_the_rules([]) :--
  257.   { succeed }.
  258.  
  259.  
  260. %
  261. % ------------------------------------------------------------------------------
  262. %
  263.  
  264.  
  265. compile_rules_in(InStream) :--
  266.   { get_next_rule(Expression, Type, EOF) },
  267.   cond(EOF :== false,
  268.     (
  269.       cond(Type :== declaration,
  270.         expand_declaration(InStream, Expression),
  271.         cond(Type :== query,
  272.           { write_query(Expression) },
  273.           {
  274.             write_err("slc : syntax error in file ", 
  275.                       InStream.input_file_name),
  276.             nl_err,
  277.             halt
  278.           }
  279.         ) 
  280.       ),
  281.       compile_rules_in(InStream)
  282.     )
  283.   ).
  284.  
  285.  
  286. %
  287. % ------------------------------------------------------------------------------
  288. %
  289.  
  290.  
  291. write_rules_list(Rules) :-
  292.   RulesList = map(psi2str, Rules),
  293.   write("'*superlint_rules*' <<- "), 
  294.   pretty_writeq(RulesList), 
  295.   write(" ?"),
  296.   nl,
  297.   nl.
  298.  
  299.  
  300. %
  301. % ------------------------------------------------------------------------------
  302. %
  303.  
  304.  
  305. get_next_rule(Expression, Type, EOF) :-
  306.   read(Expression, Type),
  307.   EOF = (Expression :=< end_of_file).
  308.  
  309.  
  310. %
  311. % ------------------------------------------------------------------------------
  312. %
  313.  
  314.  
  315. non_strict(write_query) ?
  316.  
  317.  
  318. write_query(Expression) :-
  319.   pretty_writeq(Expression, '?'),
  320.   nl,
  321.   nl.
  322.  
  323.  
  324. %
  325. % ------------------------------------------------------------------------------
  326. %
  327.  
  328.  
  329. is_member(Name, List) -> Bool
  330.   | (
  331.       is_a_member(Name, List),
  332.       !,
  333.       Bool = true
  334.     ;
  335.       Bool = false
  336.     ).
  337.  
  338.  
  339. %
  340. % ------------------------------------------------------------------------------
  341. %
  342.  
  343.  
  344. is_a_member(Name, Top) :-
  345.   Top :== @,
  346.   !,
  347.   fail.
  348.  
  349.  
  350. is_a_member(Name, [Name | @]) :- !.
  351.  
  352.  
  353. is_a_member(Name, [@ | LNames]) :-
  354.   !,
  355.   is_a_member(Name, LNames).
  356.  
  357.  
  358. %
  359. % ------------------------------------------------------------------------------
  360. %
  361.  
  362.  
  363. non_strict(expand_declaration) ?
  364.  
  365.  
  366. expand_declaration(InStream, Expression) :--
  367.   {
  368.     Type = root_sort(Expression),
  369.     (
  370.       Type :== {:-; ->; :->},
  371.       !,
  372.       Head = root_sort(Expression.1),
  373.       (
  374.         Type :== (:->),
  375.         !,
  376.         (
  377.           Head :== {(function); (procedure); (rule)},
  378.           !,
  379.           Name = Head.1,
  380.           Interpretation = root_sort(Head)
  381.         ;
  382.           Name = Head,
  383.           Interpretation = (rule)
  384.         )
  385.       ;
  386.         Name = root_sort(Expression)
  387.       )
  388.     ;
  389.       Name = root_sort(Expression)
  390.     )
  391.   },
  392.   Rules is rules,
  393.   Local is local,
  394.   cond(Type :== (:->),
  395.     cond(Interpretation :== (rule),
  396.       cond(is_member(Name, Rules),
  397.         {
  398.           write_err("slc : error in file ", 
  399.                     InStream.input_file_name,
  400.                     " -- duplicate definition of ", Name),
  401.           nl_err
  402.         },
  403.         (
  404.           Name + rules,
  405.           { write_rule(InStream, Expression) }
  406.         )
  407.       ),
  408.       cond(is_member(Name, Local),
  409.         {
  410.           write_err("slc : error in file ", 
  411.                     InStream.input_file_name,
  412.                     " -- duplicate definition of ", Name),
  413.           nl_err
  414.         },
  415.         (
  416.           Name + local,
  417.           { write_local(InStream, Expression) }
  418.         )
  419.       )
  420.     ),
  421.     cond(is_reserved(psi2str(Name)),
  422.       { 
  423.         write_err("slc : error in file ", 
  424.                   InStream.input_file_name,
  425.                   " -- ", Name, " is a reserved name"),
  426.         nl_err
  427.       },
  428.       { write_declaration(Name, Expression) }
  429.     )
  430.   ).
  431.  
  432.  
  433. %
  434. % ------------------------------------------------------------------------------
  435. %
  436.  
  437.  
  438. non_strict(write_declaration) ?
  439.  
  440.  
  441. write_declaration(Name, Expression) :-
  442.   pretty_writeq(Expression),
  443.   cond(root_sort(Expression) :== display_rules,
  444.     writeq('?'),
  445.     writeq('.')
  446.   ),
  447.   nl,
  448.   nl.
  449.  
  450.  
  451. %
  452. % ------------------------------------------------------------------------------
  453. %
  454.  
  455.  
  456. non_strict(write_rule) ?
  457.  
  458.  
  459. write_rule(InStream, (main :-> { MainBody })) :-
  460.   !,
  461.   pretty_write('M : main :- 
  462.                   sl_parse(strip(M)),'),
  463.   pretty_writeq(MainBody, '.'),
  464.   nl,
  465.   nl.
  466.  
  467.  
  468. write_rule(InStream, (RuleHead :-> { entry_test(Test), RuleBody })) :-
  469.   !,
  470.   RuleName = psi2str(root_sort(RuleHead)),
  471.   Features = features(RuleHead),
  472.   (
  473.     Features = [1, 2]
  474.   ;
  475.     Features = [1]
  476.   ;
  477.     write_err("slc : error in file ", 
  478.               InStream.input_file_name,
  479.               " -- syntax error in rule ", RuleName),
  480.     nl_err,
  481.     halt
  482.   ),
  483.   RuleHead = @(Node, Domain),
  484.   cond(Domain :== @,
  485.     DomainName = "common",
  486.     DomainName = psi2str(Domain)
  487.   ),
  488.   rewrite_expression(Test, EntryTest),
  489.   RewrittenBody = 
  490.     rewrite_body(RuleBody, in => (rule), return_var => @),
  491.   !,
  492.   SetRule = `('*rule_name*' <<- ref(RuleName)),
  493.   ClauseBody = (
  494.     is_list_member(DomainName, RequestedDomain),
  495.     EntryTest,
  496.     !,
  497.     SetRule,
  498.     RewrittenBody
  499.   ;
  500.     succeed
  501.   ),
  502.   pretty_writeq(
  503.     '*rule*'(RuleName, Node, RequestedDomain) :-
  504.       ClauseBody, '.'
  505.   ),
  506.   nl,
  507.   nl.
  508.  
  509.  
  510. write_rule(InStream, (RuleHead :-> @)) :-
  511.   write_err("slc : error in file ", 
  512.             InStream.input_file_name,
  513.             " -- syntax error in rule ", root_sort(RuleHead)),
  514.   nl_err,
  515.   halt.
  516.  
  517.  
  518. %
  519. % ------------------------------------------------------------------------------
  520. %
  521.  
  522.  
  523. non_strict(write_local) ?
  524.  
  525.  
  526. write_local(InStream, ((procedure Head) :-> { Body })) :-
  527.   ProcedureBody = rewrite_body(Body, @, in => (procedure), return_var => @),
  528.   !,
  529.   pretty_writeq(Head :- ProcedureBody, '.'),
  530.   nl,
  531.   nl.
  532.  
  533.  
  534.  
  535. write_local(InStream, ((function Head) :-> { Body })) :-
  536.   FunctionBody = rewrite_body(Body, @, in => (function), return_var => Var),
  537.   !,
  538.   pretty_writeq(
  539.     Head -> `(Var 
  540.     | (FunctionBody,
  541.        cond(Var :== @,
  542.          Var = unknown
  543.        ))
  544.     ), '.'
  545.   ),
  546.   nl,
  547.   nl.
  548.  
  549.  
  550. write_local(InStream, (Head :-> @)) :-
  551.   write_err("slc : error in file ", InStream.input_file_name),
  552.   write_err(" -- syntax error in ", root_sort(Head), " '", Head.1, "'"),
  553.   nl_err,
  554.   halt.
  555.  
  556.  
  557. %
  558. % ------------------------------------------------------------------------------
  559. %
  560.  
  561.  
  562.  
  563. non_strict(rewrite_expression) ?
  564.  
  565.  
  566.  
  567. rewrite_expression(A, A) :-
  568.   A :== @,
  569.   !.
  570.  
  571.  
  572. rewrite_expression((A && B), (RewrittenA, RewrittenB)) :-
  573.   !,
  574.   rewrite_expression(A, RewrittenA),
  575.   rewrite_expression(B, RewrittenB).
  576.  
  577.  
  578. rewrite_expression((A || B), 
  579.   (
  580.     RewrittenA,
  581.     !
  582.   ;
  583.     RewrittenB
  584.   )) :-
  585.   !,
  586.   rewrite_expression(A, RewrittenA),
  587.   rewrite_expression(B, RewrittenB).
  588.  
  589.  
  590. rewrite_expression((A == B), (RewrittenA :== RewrittenB)) :-
  591.   !,
  592.   rewrite_expression(A, RewrittenA),
  593.   rewrite_expression(B, RewrittenB).
  594.  
  595.  
  596. rewrite_expression((A <> B), (RewrittenA :\== RewrittenB)) :-
  597.   !,
  598.   rewrite_expression(A, RewrittenA),
  599.   rewrite_expression(B, RewrittenB).
  600.  
  601.  
  602. rewrite_expression(A, A).
  603.  
  604.  
  605. %
  606. % ------------------------------------------------------------------------------
  607. %
  608.  
  609.  
  610. non_strict(rewrite_body) ?
  611.  
  612.  
  613. rewrite_body((A, B), in => What, return_var => Var) ->
  614.   (rewrite_body(A, in => What, return_var => Var), 
  615.    rewrite_body(B, in => What, return_var => Var)).
  616.  
  617.  
  618. rewrite_body(else(then(if(Condition), Then), Else), 
  619.              in => What, return_var => Var) ->
  620.   (
  621.     RewrittenCondition,
  622.     !,
  623.     rewrite_body(Then, in => What, return_var => Var)
  624.   ;
  625.     rewrite_body(Else, in => What, return_var => Var)
  626.   )
  627.   | rewrite_expression(Condition, RewrittenCondition).
  628.  
  629.  
  630. rewrite_body(then(if(Condition), Then), 
  631.              in => What, return_var => Var) ->
  632.   (
  633.     RewrittenCondition,
  634.     !,
  635.     rewrite_body(Then, in => What, return_var => Var)
  636.   ;
  637.     succeed
  638.   )
  639.   | rewrite_expression(Condition, RewrittenCondition).
  640.  
  641.  
  642. rewrite_body(switch(Expression, { Body }), 
  643.              in => What, return_var => Var) -> 
  644.   (Test = RewrittenExpression, Switch)
  645.   | rewrite_expression(Expression, RewrittenExpression),
  646.     Switch = rewrite_switch(Body, Test,
  647.                             in => What, return_var => Var).
  648.  
  649.  
  650. rewrite_body(donothing, in => What, return_var => Var) ->
  651.   succeed.
  652.  
  653.  
  654. rewrite_body({A}, in => What, return_var => Var) -> 
  655.   rewrite_body(A, in => What, return_var => Var).
  656.  
  657.  
  658. rewrite_body((return Value), in => (function), return_var => Var) ->
  659.   (Var = Value).
  660.  
  661.  
  662. rewrite_body(A, in => @, return_var => @) -> A.
  663.  
  664.  
  665. %
  666. % ------------------------------------------------------------------------------
  667. %
  668.  
  669.  
  670. non_strict(rewrite_switch) ?
  671.  
  672.  
  673. rewrite_switch((Case : case, Rest), Test,
  674.                in => What, return_var => Var) ->
  675.   (
  676.     RewrittenCase
  677.   ;
  678.     RewrittenRest
  679.   )
  680.   | RewrittenCase = rewrite_case(Case, Test,
  681.                                  in => What, return_var => Var),
  682.     RewrittenRest = rewrite_switch(Rest, Test,
  683.                                    in => What, return_var => Var).
  684.  
  685.  
  686. rewrite_switch(Case, Test,
  687.                in => What, return_var => Var) ->
  688.   (
  689.     RewrittenCase
  690.   ;
  691.     succeed
  692.   )
  693.   | RewrittenCase = rewrite_case(Case, Test,
  694.                                  in => What, return_var => Var).
  695.  
  696.  
  697. %
  698. % ------------------------------------------------------------------------------
  699. %
  700.  
  701.  
  702. non_strict(rewrite_case) ?
  703.  
  704.  
  705. rewrite_case(case(Choice, Body), Test,
  706.              in => What, return_var => Var) ->
  707.   (
  708.     `(Test :== RewrittenChoice),
  709.     !,
  710.     RewrittenBody
  711.   )
  712.   | RewrittenChoice = rewrite_choice(Choice),
  713.     RewrittenBody = rewrite_body(Body, 
  714.                                  in => What, return_var => Var).
  715.  
  716.  
  717. rewrite_case(default(Body), Test,
  718.              in => What, return_var => Var) -> RewrittenBody
  719.   |  RewrittenBody = rewrite_body(Body,
  720.                                   in => What, return_var => Var).
  721.  
  722.  
  723. %
  724. % ------------------------------------------------------------------------------
  725. %
  726.  
  727.  
  728. non_strict(rewrite_choice) ?
  729.  
  730.  
  731. rewrite_choice({ Choices }) -> rewrite_choices(Choices).
  732.  
  733.  
  734. rewrite_choice(Choice) -> RewrittenChoice
  735.   | rewrite_expression(Choice, RewrittenChoice).
  736.  
  737.  
  738. %
  739. % ------------------------------------------------------------------------------
  740. %
  741.  
  742.  
  743. non_strict(rewrite_choices) ?
  744.  
  745.  
  746. rewrite_choices((Choice, Choices)) -> `{RewrittenChoice ; OtherChoices}
  747.   | rewrite_expression(Choice, RewrittenChoice),
  748.     OtherChoices = rewrite_choices(Choices).
  749.  
  750.  
  751. rewrite_choices(Choice) -> RewrittenChoice
  752.   | rewrite_expression(Choice, RewrittenChoice).
  753.  
  754.  
  755. %
  756. % ------------------------------------------------------------------------------
  757. %
  758.  
  759.  
  760.  
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  
  768.  
  769.  
  770.