diff --git a/LGPL/Makefile.in b/LGPL/Makefile.in index 9161b578a..73d95d5be 100644 --- a/LGPL/Makefile.in +++ b/LGPL/Makefile.in @@ -33,6 +33,7 @@ PROGRAMS= $(srcdir)/base64.pl \ $(srcdir)/prolog_source.pl \ $(srcdir)/prolog_xref.pl \ $(srcdir)/quintus.pl \ + $(srcdir)/record.pl \ $(srcdir)/settings.pl \ $(srcdir)/shlib.pl \ $(srcdir)/url.pl \ diff --git a/LGPL/record.pl b/LGPL/record.pl new file mode 100644 index 000000000..7924b5b54 --- /dev/null +++ b/LGPL/record.pl @@ -0,0 +1,405 @@ +/* $Id$ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 2007, University of Amsterdam + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module((record), + [ (record)/1, % +Record + current_record/2, % ?Name, ?Term + op(1150, fx, record) + ]). +:- use_module(library(error)). + +/** Access compound arguments by name + +This module creates a set of predicates to create a default instance, +access and modify records represented as a compound term. + +The full documentation is with record/1, which must be used as a +_directive_. Here is a simple example declaration and some calls. + +== +:- record point(x:integer=0, y:integer=0). + + default_point(Point), + point_x(Point, X), + set_x_of_point(10, Point, Point1), + + make_point([y(20)], YPoint), +== + +@author Jan Wielemaker +@author Richard O'Keefe +*/ + +:- multifile + error:has_type/2. + +error:has_type(record(M:Name), X) :- + current_record(Name, M, _, X, IsX), !, + call(M:IsX). + +%% record(+RecordDef) +% +% Define access predicates for a compound-term. RecordDef is of +% the form (, ...), where each argument +% is of the form: +% +% * [:][=] +% +% Used a directive, =|:- record Constructor(Arg, ...)|= is expanded +% info the following predicates: +% +% * _(Record, Value) +% * default_(-Record) +% * is_(@Term) +% * make_(+Fields, -Record) +% * make_(+Fields, -Record, -RestFields) +% * set__of_(+Value, +OldRecord, -New) +% * set__of_(+Value, !Record) +% * nb_set__of_(+Value, !Record) +% * set__fields(+Fields, +Record0, -Record). +% * set__fields(+Fields, +Record0, -Record, -RestFields). +% * set__field(+Field, +Record0, -Record). +% * user:current_record(:) + +record(Record) :- + throw(error(context_error(nodirective, record(Record)), _)). + + +%% compile_records(+RecordsDefs, -Clauses) is det. +% +% Compile a record specification into a list of clauses. + +compile_records(Spec, Clauses) :- + phrase(compile_records(Spec), Clauses). +% maplist(portray_clause, Clauses). + +compile_records(Var) --> + { var(Var), !, + instantiation_error(Var) + }. +compile_records((A,B)) --> + compile_record(A), + compile_records(B). +compile_records(A) --> + compile_record(A). + +%% compile_record(+Record)// is det. +% +% Create clauses for Record. + +compile_record(RecordDef) --> + { RecordDef =.. [Constructor|Args], + defaults(Args, Defs, TypedArgs), + types(TypedArgs, Names, Types), + atom_concat(default_, Constructor, DefName), + DefRecord =.. [Constructor|Defs], + DefClause =.. [DefName,DefRecord], + length(Names, Arity) + }, + [ DefClause ], + access_predicates(Names, 1, Arity, Constructor), + set_predicates(Names, 1, Arity, Types, Constructor), + set_field_predicates(Names, 1, Arity, Types, Constructor), + make_predicate(Constructor), + is_predicate(Constructor, Types), + current_clause(RecordDef). + +:- meta_predicate + current_record(:). +:- multifile + current_record/5. % Name, Module, Term, X, IsX + +%% current_record(?Name, :Term) +% +% True if Name is the name of a record defined in the module +% associated with Term and Term is the user-provided record +% declaration. + +current_record(Name, M:Term) :- + current_record(Name, M, Term, _, _). + +current_clause(RecordDef) --> + { prolog_load_context(module, M), + functor(RecordDef, Name, _), + atom_concat(is_, Name, IsName), + IsX =.. [IsName, X] + }, + [ (record):current_record(Name, M, RecordDef, X, IsX) + ]. + + +%% make_predicate(+Constructor)// is det. +% +% Creates the make_(+Fields, -Record) predicate. This +% looks like this: +% +% == +% make_(Fields, Record) :- +% make_(Fields, Record, []) +% +% make_(Fields, Record, RestFields) :- +% default_(Record0), +% set__fields(Fields, Record0, Record, RestFields). +% +% set__fields(Fields, Record0, Record) :- +% set__fields(Fields, Record0, Record, []). +% +% set__fields([], Record, Record, []). +% set__fields([H|T], Record0, Record, RestFields) :- +% ( set__field(H, Record0, Record1) +% -> set__fields(T, Record1, Record, RestFields) +% ; RestFields = [H|RF], +% set__fields(T, Record0, Record, RF) +% ). +% +% set__field((Value), Record0, Record). +% ... +% == + +make_predicate(Constructor) --> + { atomic_list_concat([make_, Constructor], MakePredName), + atomic_list_concat([default_, Constructor], DefPredName), + atomic_list_concat([set_, Constructor, '_fields'], SetFieldsName), + atomic_list_concat([set_, Constructor, '_field'], SetFieldName), + MakeHead3 =.. [MakePredName, Fields, Record], + MakeHead4 =.. [MakePredName, Fields, Record, []], + MakeClause3 = (MakeHead3 :- MakeHead4), + MakeHead =.. [MakePredName, Fields, Record, RestFields], + DefGoal =.. [DefPredName, Record0], + SetGoal =.. [SetFieldsName, Fields, Record0, Record, RestFields], + MakeClause = (MakeHead :- DefGoal, SetGoal), + SetHead3 =.. [SetFieldsName, Fields, R0, R], + SetHead4 =.. [SetFieldsName, Fields, R0, R, []], + SetClause0 = (SetHead3 :- SetHead4), + SetClause1 =.. [SetFieldsName, [], R, R, []], + SetHead2 =.. [SetFieldsName, [H|T], R0, R, RF], + SetGoal2a =.. [SetFieldName, H, R0, R1], + SetGoal2b =.. [SetFieldsName, T, R1, R, RF], + SetGoal2c =.. [SetFieldsName, T, R0, R, RF1], + SetClause2 = (SetHead2 :- (SetGoal2a -> SetGoal2b ; RF=[H|RF1], SetGoal2c)) + }, + [ MakeClause3, MakeClause, SetClause0, SetClause1, SetClause2 ]. + +%% is_predicate(+Constructor, +Types)// is det. +% +% Create a clause that tests for a given record type. + +is_predicate(Constructor, Types) --> + { type_checks(Types, Vars, Body0), + clean_body(Body0, Body), + Term =.. [Constructor|Vars], + atom_concat(is_, Constructor, Name), + Head1 =.. [Name,Var], + Head2 =.. [Name,Term] + }, + [ (Head1 :- var(Var), !, fail) ], + ( { Body == true } + -> [ Head2 ] + ; [ (Head2 :- Body) ] + ). + +type_checks([], [], true). +type_checks([any|T], [_|Vars], Body) :- + type_checks(T, Vars, Body). +type_checks([Type|T], [V|Vars], (Goal, Body)) :- + type_goal(Type, V, Goal), + type_checks(T, Vars, Body). + +%% type_goal(+Type, +Var, -BodyTerm) is det. +% +% Inline type checking calls. + +type_goal(Type, Var, Body) :- + defined_type(Type, Var, Body), !. +type_goal(record(Record), Var, Body) :- !, + atom_concat(is_, Record, Pred), + Body =.. [Pred,Var]. +type_goal(Record, Var, Body) :- + atom(Record), !, + atom_concat(is_, Record, Pred), + Body =.. [Pred,Var]. +type_goal(Type, _, _) :- + domain_error(type, Type). + +defined_type(Type, Var, error:Body) :- + clause(error:has_type(Type, Var), Body). + + +clean_body(M:(A0,B0), G) :- !, + clean_body(M:A0, A), + clean_body(M:B0, B), + clean_body((A,B), G). +clean_body((A0,true), A) :- !, + clean_body(A0, A). +clean_body((true,A0), A) :- !, + clean_body(A0, A). +clean_body((A0,B0), (A,B)) :- + clean_body(A0, A), + clean_body(B0, B). +clean_body(_:A, A) :- + predicate_property(A, built_in), !. +clean_body(A, A). + + +%% access_predicates(+Names, +Idx0, +Arity, +Constructor)// is det. +% +% Create the _(Record, Value) predicates. + +access_predicates([], _, _, _) --> + []. +access_predicates([Name|NT], I, Arity, Constructor) --> + { atomic_list_concat([Constructor, '_', Name], PredName), + functor(Record, Constructor, Arity), + arg(I, Record, Value), + Clause =.. [PredName, Record, Value], + I2 is I + 1 + }, + [Clause], + access_predicates(NT, I2, Arity, Constructor). + + +%% set_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det. +% +% Create the clauses +% +% * set__of_(Value, Old, New) +% * set__of_(Value, Record) + +set_predicates([], _, _, _, _) --> + []. +set_predicates([Name|NT], I, Arity, [Type|TT], Constructor) --> + { atomic_list_concat(['set_', Name, '_of_', Constructor], PredName), + atomic_list_concat(['nb_set_', Name, '_of_', Constructor], NBPredName), + length(Args, Arity), + replace_nth(I, Args, Value, NewArgs), + Old =.. [Constructor|Args], + New =.. [Constructor|NewArgs], + Head =.. [PredName, Value, Old, New], + SetHead =.. [PredName, Value, Term], + NBSetHead =.. [NBPredName, Value, Term], + ( Type == any + -> Clause = Head, + SetClause = (SetHead :- setarg(I, Term, Value)), + NBSetClause = (NBSetHead :- nb_setarg(I, Term, Value)) + ; type_check(Type, Value, MustBe), + Clause = (Head :- MustBe), + SetClause = (SetHead :- MustBe, + setarg(I, Term, Value)), + NBSetClause = (NBSetHead :- MustBe, + nb_setarg(I, Term, Value)) + ), + I2 is I + 1 + }, + [ Clause, SetClause, NBSetClause ], + set_predicates(NT, I2, Arity, TT, Constructor). + +type_check(Type, Value, must_be(Type, Value)) :- + defined_type(Type, Value, _), !. +type_check(record(Spec), Value, must_be(record(M:Name), Value)) :- !, + prolog_load_context(module, C), + strip_module(C:Spec, M, Name). +type_check(Atom, Value, Check) :- + atom(Atom), !, + type_check(record(Atom), Value, Check). + + +%% set_field_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det. +% +% Create the clauses +% +% * set__field((Value), Old, New) + +set_field_predicates([], _, _, _, _) --> + []. +set_field_predicates([Name|NT], I, Arity, [Type|TT], Constructor) --> + { atomic_list_concat(['set_', Constructor, '_field'], FieldPredName), + length(Args, Arity), + replace_nth(I, Args, Value, NewArgs), + Old =.. [Constructor|Args], + New =.. [Constructor|NewArgs], + NameTerm =.. [Name, Value], + SetFieldHead =.. [FieldPredName, NameTerm, Old, New], + ( Type == any + -> SetField = SetFieldHead + ; type_check(Type, Value, MustBe), + SetField = (SetFieldHead :- MustBe) + ), + I2 is I + 1 + }, + [ SetField ], + set_field_predicates(NT, I2, Arity, TT, Constructor). + + +%% replace_nth(+Index, +List, +Element, -NewList) is det. +% +% Replace the Nth (1-based) element of a list. + +replace_nth(1, [_|T], V, [V|T]) :- !. +replace_nth(I, [H|T0], V, [H|T]) :- + I2 is I - 1, + replace_nth(I2, T0, V, T). + + +%% defaults(+ArgsSpecs, -Defaults, -Args) +% +% Strip the default specification from the argument specification. + +defaults([], [], []). +defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :- !, + defaults(T0, TD, TA). +defaults([Arg|T0], [_|TD], [Arg|TA]) :- + defaults(T0, TD, TA). + + +%% types(+ArgsSpecs, -Defaults, -Args) +% +% Strip the default specification from the argument specification. + +types([], [], []). +types([Name:Type|T0], [Name|TN], [Type|TT]) :- !, + must_be(atom, Name), + types(T0, TN, TT). +types([Name|T0], [Name|TN], [any|TT]) :- + must_be(atom, Name), + types(T0, TN, TT). + + + /******************************* + * EXPANSION * + *******************************/ + +:- multifile + system:term_expansion/2. +:- dynamic + system:term_expansion/2. + +system:term_expansion((:- record(Record)), Clauses) :- + compile_records(Record, Clauses).