home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / progtool / prolog / source / toyseq. < prev   
Encoding:
Text File  |  1994-09-22  |  13.0 KB  |  423 lines
  1.  
  2. % TOY Sequel (Relational database for TOY Prolog)
  3. % (c) 1983 Kluzniak/Szpakowicz, IIUW Warszawa
  4.  
  5. toysequel :- write('--- TOY-Sequel, IIUW Warszawa 1983 ---'), nl,
  6.       repeat, tag(getcommand(Cmd, Errflag)),
  7.       tag(docommand(Cmd, Errflag)),
  8.       Cmd = sequelstop, !.
  9.  
  10. getcommand(Cmd, Errflag) :-
  11.       readcmd(CmdString),
  12.       scan(CmdString, TList), compile(TList, Cmd).
  13.  
  14. docommand(Cmd, Errflag) :- var(Errflag), !, Cmd.
  15. docommand(_, _).
  16.  
  17. scan(CmdString, TList) :-
  18.       phrase(tokens(TList), CmdString), tracescan(TList).
  19.  
  20. compile(TList, Cmd) :-
  21.       phrase(command(Cmd), TList), !, tracecompile(Cmd).
  22. compile(_, error) :- synerr(badcommand).
  23.  
  24. tracescan(Cmd) :- tracescan, !, write('--- scanned '(Cmd)), nl.
  25. tracescan(_).
  26.  
  27. tracecompile(Cmd) :- tracecompile, !, write('--- compiled '(Cmd)), nl.
  28. tracecompile(_).
  29.  
  30. tracescan. tracecompile.
  31.  
  32.  
  33. readcmd(String) :- rdchsk(Ch), readcmd(Ch, String).
  34.  
  35. readcmd('.', []) :- !, rch.
  36. readcmd('"', ['"' | Rest]) :-
  37.       !, rdch(Ch), readstr(Ch, Rest, RestAfter),
  38.       rdch(Nextch), readcmd(Nextch, RestAfter).
  39. readcmd(Ch, [Ch | Rest]) :- rdch(Nextch), readcmd(Nextch, Rest).
  40.  
  41. readstr('"', ['"' | Rest], Rest) :- !.
  42. readstr(Ch, [Ch | Rest], RestAfter) :-
  43.       rdch(Nextch), readstr(Nextch, Rest, RestAfter).
  44.  
  45.  
  46. tokens([T | Ts]) --> token(T), !, sp, tokens(Ts).
  47. tokens([]) --> [].
  48.  
  49. token(n(Name)) -->
  50.       letter(L), namechars(NN), {pname(Name, [L | NN])}.
  51. token(s(String)) --> ['"'], stringchars(String).
  52. token(i(Integer)) -->
  53.       sign(S), digit(D), digits(DD),
  54.       {pnamei(I, [D | DD]), signed(S, I, Integer)}.
  55. token(Ch) --> [Ch].
  56.  
  57. letter(Ch) --> [Ch], {letter(Ch)}.
  58.  
  59. namechars([Ch | Chs]) --> letter(Ch), !, namechars(Chs).
  60. namechars([Ch | Chs]) --> digit(Ch), !, namechars(Chs).
  61. namechars([]) --> [].
  62.  
  63. stringchars(['"' | Chs]) --> ['"', '"'], !, stringchars(Chs).
  64. stringchars([]) --> ['"'], !.
  65. stringchars([Ch | Chs]) --> [Ch], stringchars(Chs).
  66.  
  67. digit(Ch) --> [Ch], {digit(Ch)}.
  68.  
  69. digits([D | DD]) --> digit(D), !, digits(DD).
  70. digits([]) --> [].
  71.  
  72. sign('-') --> ['-'].
  73. sign('+') --> ['+'].
  74. sign('+') --> [].
  75.  
  76. signed('+', I, I).
  77. signed('-', I, Integer) :- Integer is - I.
  78.  
  79. sp --> [' '], !, sp.
  80. sp --> [].
  81.  
  82.  
  83.  
  84. qname(Qual-Name) --> [n(Qual), '_', n(Name)], !.
  85. qname(Variable-Name) --> [n(Name)].
  86.  
  87. constant(Int, integer) --> [i(Int)].
  88. constant(Str, string ) --> [s(Str)].
  89.  
  90. :- op(100, xfx, ':').
  91.  
  92. newrelname(RelNm, Alias, Generator, OldST, [Alias : RelST | OldST]) :-
  93.       'r e l'(RelNm, Generator, RelST), !.
  94. newrelname(RelNm, _, fail, OldST, OldST) :- synerr(norelname(RelNm)).
  95.  
  96. findattr(Q-Nm, Var, Type, [Q : RelST | ST]) :-
  97.       member(attr(Nm, Type, Var), RelST), !.
  98. findattr(QNm, Var, Type, [_ | ST]) :- !, findattr(QNm, Var, Type, ST).
  99. findattr(QNm, _, _, []) :- synerr(noattribute(QNm)).
  100.  
  101.  
  102. command(Cmd) --> create(Cmd).
  103. command(Cmd) --> cancel(Cmd).
  104. command(Cmd) --> select(Cmd).
  105. command(Cmd) --> relations(Cmd).
  106. command(Cmd) --> relation(Cmd).
  107. command(Cmd) --> insert(Cmd).
  108. command(Cmd) --> delete(Cmd).
  109. command(Cmd) --> update(Cmd).
  110. command(Cmd) --> stop(Cmd).
  111. command(Cmd) --> dump(Cmd).
  112. command(Cmd) --> load(Cmd).
  113.  
  114.  
  115. create(newrel(RelName, [V | Vs], [attr(Nm, Type, V) | As])) -->
  116.       [n(create), n(RelName)],
  117.       ['<'], typnam(Type, Nm), typnams(Vs, As), ['>'].
  118.  
  119. typnams([V | Vs], [attr(Nm, Type, V) | As]) -->
  120.       [','], !, typnam(Type, Nm), typnams(Vs, As).
  121. typnams([], []) --> [].
  122.  
  123. typnam(string, Nm) --> [n(string), n(Nm)], !.
  124. typnam(integer, Nm) --> [n(integer), n(Nm)], !.
  125. typnam(notype, Nm) --> synerrc(typeexpected).
  126.  
  127. newrel(RelName, Vars, RelST) :-
  128.       not 'r e l'(RelName, _, _), !,
  129.       mkgen(RelName, Vars, Generator),
  130.       assert('r e l'(RelName, Generator, RelST)).
  131. newrel(RelName, _, _) :- namerr(duprelname(RelName)).
  132.  
  133. mkgen(RelName, Vars, Generator) :-
  134.       pname(RelName, Chars), pname(RelNm, [' ' | Chars]),
  135.       Generator =.. [RelNm | Vars].
  136.  
  137.  
  138. cancel(cancel(RelName)) --> [n(cancel), n(RelName)].
  139.  
  140. cancel(RelName) :- retract('r e l'(RelName, Generator, _)), !,
  141.       retract(Generator), fail.
  142. cancel(RelName) :- namerr(unknown(RelName)).
  143.  
  144.  
  145. select((Generators, Filter, writetuple(Tup), fail)) -->
  146.       selectexp(set(Generators, Filter, Tup, _), []).
  147.  
  148. writetuple([]) :- !, nl.
  149. writetuple([Val| Vals]) :-
  150.       writeval(Val), display('  '), writetuple(Vals).
  151.  
  152. writeval([FirstLetter | RestOfString]) :- display(FirstLetter),
  153.       writestring(RestOfString).
  154. writeval(Val) :- display(Val).
  155.  
  156. writestring([]) :- !.
  157. writestring([Ch | Chs]) :- display(Ch), writestring(Chs).
  158.  
  159. relations(('r e l'(RelNm, _, _), write(RelNm), nl, fail)) -->
  160.       [n(relations)].
  161.  
  162.  
  163. relation(relation(Name)) --> [n(relation), n(Name)].
  164.  
  165. relation(RelNm) :- 'r e l'(RelNm, _, Attrs), !, listattrs(Attrs).
  166. relation(RelNm) :- write(RelNm), write(' is not a relation !'), nl.
  167.  
  168. listattrs([]) :- !.
  169. listattrs([attr(Name, Type, _) | Attrs]) :-
  170.       write(Type), write('  '), write(Name), nl,
  171.       listattrs(Attrs).
  172.  
  173.  
  174. selectexp(set(Generators, Filter, Tuple, Types), InitST) -->
  175.       [n(select), n(from)], relnames(Generators, InitST, ST),
  176.       [n(tuples)], tuplepattern(Tuple, Types, ST),
  177.       whereclause(Filter, ST).
  178.  
  179. relnames((Gen, Gens), OldST, NewST) -->
  180.       relname(Name, Alias), [','], !, relnames(Gens, OldST, TempST),
  181.       { newrelname(Name, Alias, Gen, TempST, NewST) }.
  182. relnames(Gen, OldST, NewST) -->
  183.       relname(Name, Alias), { newrelname(Name, Alias, Gen, OldST, NewST) }.
  184.  
  185. relname(Name, Alias) --> [n(Alias), '=', n(Name)], !.
  186. relname(Name, Name) --> [n(Name)].
  187.  
  188. tuplepattern([A | As], [T | Ts], ST) -->
  189.       ['<'], attrpatt(A, T, ST), attrpatts(As, Ts, ST), ['>'].
  190.  
  191. attrpatts([A | As], [T | Ts], ST) -->
  192.       [','], !, attrpatt(A, T, ST), attrpatts(As, Ts, ST).
  193. attrpatts([], [], _) --> [].
  194.  
  195. attrpatt(Attribute, Type, _) --> constant(Attribute, Type), !.
  196. attrpatt(A, T, ST) --> qname(QN), {findattr(QN, A, T, ST) }.
  197.  
  198. whereclause(Filter, ST) --> [n(where)], !, boolexp(Filter, ST).
  199. whereclause(true, _) --> [].
  200.  
  201.  
  202. boolexp(E, ST) --> bterm(T, ST), rboolexp(T, E, ST).
  203.  
  204. rboolexp(L, (L ; R), ST) --> [n(or)], !, boolexp(R, ST).
  205. rboolexp(E, E, _) --> [].
  206.  
  207. bterm(T, ST) --> bfactor(F, ST), rbterm(F, T, ST).
  208.  
  209. rbterm(L, (L, R), ST) --> [n(and)], !, bterm(R, ST).
  210. rbterm(L, L, _) --> [].
  211.  
  212. bfactor(not F, ST) --> [n('not')], !, bfactor(F, ST).
  213. bfactor(E, ST) --> ['('], !, boolexp(E, ST), [')'].
  214. bfactor(E, ST) --> inexp(E, ST).
  215. bfactor(E, ST) --> relexp(E, ST).
  216.  
  217. inexp((Generator, Filter), ST) -->
  218.       tuplepattern(Patt, Type, ST), [n(in)],
  219.       setexp(set(Generator, Filter, Tuple, Types), ST),
  220.       matchpatterns(Patt, Type, Tuple, Types).
  221.  
  222. matchpatterns(Patt, Types, Patt, Types) --> !.
  223. matchpatterns(P1, T1, P2, T2) -->
  224.       synerrc(badinexppattern(T1, P1, T2, P2)).
  225.  
  226.  
  227. setexp(Set, ST) --> ['('], !, setexp(Set, ST), [')'].
  228. setexp(Set, ST) --> selectexp(Set, ST), !.
  229. setexp(set(member(Patt, [Tup | Tups]), true, Patt, Types), ST) -->
  230.       tuple(Tup, Types), tuples(Tups, Types),
  231.       { mkpattern(Types, Patt) }, !.
  232. setexp(set(fail, fail, [], []), _) --> synerrc(badsetexpression).
  233.  
  234. tuples([Tup | Tups], Types) --> [','], !, tuple(Tup, TupTypes),
  235.       { checktype(Types, TupTypes) }, tuples(Tups, Types).
  236. tuples([], _) --> [].
  237.  
  238. tuple([A | As], [T | Ts]) -->
  239.       ['<'], constant(A, T), constants(As, Ts), ['>'], !.
  240. tuple([], []) --> ['<'], synerrc(badtuple), { fail }.
  241.  
  242. constants([A | As], [T | Ts]) -->
  243.       [','], !, constant(A, T), constants(As, Ts).
  244. constants([], []) --> [].
  245.  
  246. checktype(Type, Type).
  247. checktype(T1, T2) :- synerr(inconsistent(T1, T2)).
  248.  
  249. mkpattern([], []) :- !.
  250. mkpattern([_ | Types], [V | Vs]) :- mkpattern(Types, Vs).
  251.  
  252.  
  253. relexp(E, ST) -->
  254.       simplexp(LeftE, LeftType, ST), relop(Op), !,
  255.       simplexp(RightE, RightType, ST),
  256.       { consrel(LeftE, LeftType, Op, RightE, RightType, E) }.
  257.  
  258. relop('=<') --> ['=', '<'].
  259. relop('=:=') --> ['='].
  260. relop('=\=') --> ['<', '>'].
  261. relop('<') --> ['<'].
  262. relop('>=') --> ['>', '='].
  263. relop('>') --> ['>'].
  264.  
  265. consrel(L, Type, Op, R, Type, E) :- consrel(L, Op, R, Type, E), !.
  266. consrel(L, LType, Op, R, RType, fail) :-
  267.       E =.. [Op, L, R], synerrc(typeconflict(LType, RType, E)).
  268.  
  269. consrel(Arg, '=:=', Arg, _, true).
  270. consrel(L, '=:=', R, string, fail).
  271. consrel(L, '=\=', R, string, not L = R).
  272. consrel(L, Op, R, integer, E) :- E =.. [Op, L, R].
  273. consrel(L, '<', R, string, lstr(L, R)).
  274. consrel(L, '=<', R, string, (lstr(L, R) ; L = R)).
  275. consrel(L, '>', R, string, lstr(R, L)).
  276. consrel(L, '>=', R, string, (lstr(R, L) ; R = L)).
  277.  
  278. lstr([], [_ | _]) :- !.
  279. lstr([Ch1 | _], [Ch2 | _]) :- Ch1 @< Ch2, !.
  280. lstr([Ch | Chs1], [Ch | Chs2]) :- lstr(Chs1, Chs2).
  281.  
  282.  
  283. simplexp(E, string, ST) --> stringexp(E, ST), !.
  284. simplexp(E, integer, ST) --> arithexp(E, ST).
  285.  
  286. stringexp(Str, _) --> [s(Str)], !.
  287. stringexp(Var, ST) -->
  288.       qname(QN), { findattr(QN, Var, Type, ST), Type = string }.
  289.  
  290. arithexp(E, ST) --> aterm(T, ST), rarithexp(T, E, ST).
  291.  
  292. rarithexp(L, E, ST) -->
  293.       ['+'], !, aterm(T, ST), rarithexp(L+T, E, ST).
  294. rarithexp(L, E, ST) -->
  295.       ['-'], !, aterm(T, ST), rarithexp(L-T, E, ST).
  296. rarithexp(E, E, _) --> [].
  297.  
  298. aterm(T, ST) --> afactor(F, ST), raterm(F, T, ST).
  299.  
  300. raterm(L, T, ST) -->
  301.       ['*'], !, afactor(F, ST), raterm(L*F, T, ST).
  302. raterm(L, T, ST) -->
  303.       ['/'], !, afactor(F, ST), raterm(L/F, T, ST).
  304. raterm(T, T, _) --> [].
  305.  
  306. afactor(E, ST) --> ['('], !, arithexp(E, ST), [')'].
  307. afactor(Int, _) --> [i(Int)], !.
  308. afactor(Var, ST) -->
  309.       qname(QN), { findattr(QN, Var, Type, ST), Type = integer }, !.
  310. afactor(0, _) --> qname(QN), !, synerrc(notinteger(QN)).
  311. afactor(0, _) --> synerrc(nointegerfactor).
  312.  
  313. insert((Generators, Filter, assertz(NewTuple), fail)) -->
  314.       [n(into), n(RelName)],
  315.       { 'r e l'(RelName, _, RelST) }, !, [n(insert)],
  316.       setexp(set(Generators, Filter, Tuple, Types), []),
  317.       { checktypes(Types, RelST),
  318.       mkgen(RelName, Tuple, NewTuple) }.
  319. insert(fail) --> [n(into), n(RelNm)],
  320.       synerrc(norelname(RelNm)).
  321.  
  322. checktypes([], []) :- !.
  323. checktypes([T | Ts], [attr(_, T, _) | As]) :- !, checktypes(Ts, As).
  324. checktypes(Types, Attributes) :- synerr(badsettype(Types, Attributes)).
  325.  
  326. delete((RelGen, RelFilter, retract(RelGen), fail)) -->
  327.       [n(from), n(RelNm)],
  328.       { newrelname(RelNm, RelNm, RelGen, [], ST) },
  329.       [n(delete)], delfilter(RelFilter, ST).
  330.  
  331. defilter(true, _) --> [n(all), n(tuples)], !.
  332. delfilter(RelFilter, ST) -->
  333.       [n(tuples), n(where)], boolexp(RelFilter, ST).
  334.  
  335.  
  336. update((OldTup, UseGens, Filter, Modifications,
  337.                          retract(OldTup), assert(NewTup), fail)) -->
  338.       [n(update), n(RelNm)],
  339.       { 'r e l'(RelNm, OldTup, OldST),
  340.       'r e l'(RelNm, NewTup, NewST), !,
  341.       makemodlist(OldST, NewST, MList) },
  342.       usingclause(UseGens, UseST), { ST = [RelNm : OldST | UseST] },
  343.       [n(so), n(that)],
  344.       modifier(Modification, MList, ST),
  345.       modifiers(Modification, Modifications, MList, ST),
  346.       { closemodlist(MList) }, whereclause(Filter, ST).
  347. update(fail) --> [n(update)], synerrc(noupdatedrelation).
  348.  
  349. usingclause(Gens, ST) --> [n(using)], relnames(Gens, [], ST).
  350. usingclause(true, ST) --> [].
  351.  
  352. modifiers(M, (M, Ms), MList, ST) -->
  353.       [','], !, modifier(MM, MList, ST),
  354.       modifiers(MM, Ms, MList, ST).
  355. modifiers(M, M, _, _) --> [].
  356.  
  357. modifier(AttrVar is Expr, MList, ST) -->
  358.       [n(Nm)], { findmname(Nm, AttrVar, Type, MList) },
  359.       ['='], simplexp(Expr, EType, ST),
  360.       { mtype(Type, EType, Nm) }.
  361.  
  362. makemodlist([Old | Olds], [attr(_, _, NewV) | NewVs],
  363.                           [modif(Old, NewV, Mod) | Mods]) :-
  364.       !, makemodlist(Olds, NewVs, Mods).
  365. makemodlist([], [], []).
  366.  
  367. closemodlist([Mod | Mods]) :- closemod(Mod), !, closemodlist(Mods).
  368. closemodlist([]).
  369.  
  370. closemod(modif(attr(_, _, OldV), OldV, Mod)) :- var(Mod).
  371. closemod(_).
  372.  
  373. findmname(Nm, NewV, T, MList) :-
  374.       member(modif(attr(Nm, T, _), NewV, Mod), MList), !,
  375.       mmod(Mod, Nm).
  376. findmname(Nm, _, _, _) :- synerr(notinupdatedrel(Nm)).
  377.  
  378. mmod(Mod, Nm) :- not var(Mod), !, synerr(updatedtwice(Nm)).
  379. mmod(true, _).
  380.  
  381. mtype(Type, Type, _) :- !.
  382. mtype(T1, T2, Nm) :- synerr(typeconflict(T1, Nm, T2)).
  383.  
  384.  
  385. stop(sequelstop) --> [n(stop)].
  386.  
  387. sequelstop.
  388.  
  389. load(consult(FileName)) --> [n(load), n(from), n(FileName)].
  390.  
  391. dump(dump(FileName)) --> [n(dump), n(to), n(FileName)].
  392.  
  393. dump(FileName) :- tell(FileName),
  394.       'r e l'(Nm, Gen, ST), wclause('r e l'(Nm, Gen, ST)),
  395.       Gen, wclause(Gen), fail.
  396. dump(_) :- write('end.'), nl, told.
  397.  
  398. wclause(Cl) :- writeq(Cl), wch('.'), nl.
  399.  
  400.  
  401.  
  402. synerr(Info) :- synmes(Info), ancestor(getcommand(_, error)).
  403.  
  404. synerrc(Info) --> { synmes(Info), write('Context : ') },
  405.                   context.
  406. synerrc(_) --> { nl, ancestor(getcommand(_, error)) }.
  407.  
  408. synmes(Info) :- nl, write('--- Syntactic error : '), write(Info), nl.
  409.  
  410. context --> [Token], { wtoken(Token) }, context.
  411.  
  412. wtoken(T) :- wt(T, RealT), write(RealT), write(' '), !.
  413. wt(n(Name), Name).
  414. wt(i(Integer), Integer).
  415. wt(s(String), String).
  416. wt(Char, Char).
  417.  
  418. namerr(Info) :- nl, write('*** Error : '), nl,
  419.       write(Info), nl, tagfail(docommand(_, _)).
  420.  
  421. end.
  422.  
  423.