new predicates atom_concat and list_concat
prolog_flag(version,X). 0'\ escape sequences first try at profiling early reset (garbage collector is broken now). git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@9 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
parent
da817ebbe5
commit
71c18ef912
@ -22,6 +22,7 @@ static char SccsId[] = "%W% %G%";
|
||||
#include "yapio.h"
|
||||
|
||||
|
||||
/* #define EARLY_RESET 1 */
|
||||
/* #define SIMPLE_SHUNTING 1 */
|
||||
|
||||
#ifdef MULTI_ASSIGNMENT_VARIABLES
|
||||
@ -1025,6 +1026,7 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
|
||||
we must use gc_H to avoid trouble with dangling variables
|
||||
in the heap */
|
||||
if (((hp < gc_H && hp >= H0) || (hp > (CELL *)gc_B && hp < LCL0) ) && !MARKED(*hp)) {
|
||||
#ifdef EARLY_RESET
|
||||
/* reset to be a variable */
|
||||
RESET_VARIABLE(hp);
|
||||
discard_trail_entries++;
|
||||
@ -1032,6 +1034,10 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
|
||||
#ifdef FROZEN_REGS
|
||||
RESET_VARIABLE(&TrailVal(trail_ptr));
|
||||
#endif
|
||||
#else
|
||||
/* if I have no early reset I have to follow the trail chain */
|
||||
mark_external_reference(&TrailTerm(trail_ptr));
|
||||
#endif /* EARLY_RESET */
|
||||
} else {
|
||||
if (hp < (CELL *)HeapTop) {
|
||||
/* I decided to allow pointers from the Heap back into the trail.
|
||||
|
||||
212
C/scanner.c
212
C/scanner.c
@ -269,6 +269,111 @@ get_num(void)
|
||||
if (base == 0) {
|
||||
Int ascii = ch;
|
||||
|
||||
if (ch == '\\' &&
|
||||
yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) {
|
||||
/* escape sequence */
|
||||
ch = my_get_quoted_ch();
|
||||
switch (ch) {
|
||||
case 'a':
|
||||
ascii = '\a';
|
||||
break;
|
||||
case 'b':
|
||||
ascii = '\b';
|
||||
break;
|
||||
case 'r':
|
||||
ascii = '\r';
|
||||
break;
|
||||
case 'f':
|
||||
ascii = '\f';
|
||||
break;
|
||||
case 't':
|
||||
ascii = '\t';
|
||||
break;
|
||||
case 'n':
|
||||
ascii = '\n';
|
||||
break;
|
||||
case 'v':
|
||||
ascii = '\v';
|
||||
break;
|
||||
case '\\':
|
||||
ascii = '\\';
|
||||
break;
|
||||
case '\'':
|
||||
ascii = '\'';
|
||||
break;
|
||||
case '"':
|
||||
ascii = '"';
|
||||
break;
|
||||
case '`':
|
||||
ascii = '`';
|
||||
break;
|
||||
case '0':
|
||||
case '1':
|
||||
case '2':
|
||||
case '3':
|
||||
case '4':
|
||||
case '5':
|
||||
case '6':
|
||||
case '7':
|
||||
/* character in octal: maximum of 3 digits, terminates with \ */
|
||||
{
|
||||
unsigned char so_far = ch-'0';
|
||||
my_get_quoted_ch();
|
||||
if (ch >= '0' && ch < '8') {/* octal */
|
||||
so_far = so_far*8+(ch-'0');
|
||||
my_get_quoted_ch();
|
||||
if (ch >= '0' && ch < '8') { /* octal */
|
||||
ascii = so_far*8+(ch-'0');
|
||||
my_get_quoted_ch();
|
||||
if (ch != '\\') {
|
||||
ErrorMessage = "invalid octal escape sequence";
|
||||
}
|
||||
} else if (ch == '\\') {
|
||||
ascii = so_far;
|
||||
} else {
|
||||
ErrorMessage = "invalid octal escape sequence";
|
||||
}
|
||||
} else if (ch == '\\') {
|
||||
ascii = so_far;
|
||||
} else {
|
||||
ErrorMessage = "invalid octal escape sequence";
|
||||
}
|
||||
}
|
||||
break;
|
||||
case 'x':
|
||||
/* hexadecimal character (YAP allows empty hexadecimal */
|
||||
{
|
||||
unsigned char so_far = 0;
|
||||
my_get_quoted_ch();
|
||||
if (my_isxdigit(ch,'f','F')) {/* hexa */
|
||||
so_far = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
|
||||
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
|
||||
my_get_quoted_ch();
|
||||
if (my_isxdigit(ch,'f','F')) { /* hexa */
|
||||
ascii = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
|
||||
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
|
||||
my_get_quoted_ch();
|
||||
if (ch != '\\') {
|
||||
ErrorMessage = "invalid hexadecimal escape sequence";
|
||||
}
|
||||
} else if (ch == '\\') {
|
||||
ascii = so_far;
|
||||
} else {
|
||||
ErrorMessage = "invalid hexadecimal escape sequence";
|
||||
}
|
||||
} else if (ch == '\\') {
|
||||
ascii = so_far;
|
||||
my_get_quoted_ch();
|
||||
}
|
||||
}
|
||||
break;
|
||||
default:
|
||||
/* accept sequence. Note that the ISO standard does not
|
||||
consider this sequence legal, whereas SICStus would
|
||||
eat up the escape sequence. */
|
||||
ErrorMessage = "invalid escape sequence";
|
||||
}
|
||||
}
|
||||
/* a quick way to represent ASCII */
|
||||
my_getch();
|
||||
return (MkIntTerm(ascii));
|
||||
@ -886,6 +991,113 @@ fast_tokenizer(void)
|
||||
* a quick way to
|
||||
* represent ASCII
|
||||
*/
|
||||
if (ch == '\\' &&
|
||||
yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES) {
|
||||
/* escape sequence */
|
||||
ch = my_fgetch();
|
||||
switch (ch) {
|
||||
case 'a':
|
||||
ascii = '\a';
|
||||
break;
|
||||
case 'b':
|
||||
ascii = '\b';
|
||||
break;
|
||||
case 'r':
|
||||
ascii = '\r';
|
||||
break;
|
||||
case 'f':
|
||||
ascii = '\f';
|
||||
break;
|
||||
case 't':
|
||||
ascii = '\t';
|
||||
break;
|
||||
case 'n':
|
||||
ascii = '\n';
|
||||
break;
|
||||
case 'v':
|
||||
ascii = '\v';
|
||||
break;
|
||||
case '\\':
|
||||
ascii = '\\';
|
||||
break;
|
||||
case '\'':
|
||||
ascii = '\'';
|
||||
break;
|
||||
case '"':
|
||||
ascii = '"';
|
||||
break;
|
||||
case '`':
|
||||
ascii = '`';
|
||||
break;
|
||||
case '0':
|
||||
case '1':
|
||||
case '2':
|
||||
case '3':
|
||||
case '4':
|
||||
case '5':
|
||||
case '6':
|
||||
case '7':
|
||||
/* character in octal: maximum of 3 digits, terminates with \ */
|
||||
{
|
||||
unsigned char so_far = ch-'0';
|
||||
my_fgetch();
|
||||
if (ch >= '0' && ch < '8') {/* octal */
|
||||
so_far = so_far*8+(ch-'0');
|
||||
my_fgetch();
|
||||
if (ch >= '0' && ch < '8') { /* octal */
|
||||
ascii = so_far*8+(ch-'0');
|
||||
my_fgetch();
|
||||
if (ch != '\\') {
|
||||
ErrorMessage = "invalid octal escape sequence";
|
||||
}
|
||||
} else if (ch == '\\') {
|
||||
ascii = so_far;
|
||||
} else {
|
||||
ErrorMessage = "invalid octal escape sequence";
|
||||
}
|
||||
} else if (ch == '\\') {
|
||||
ascii = so_far;
|
||||
} else {
|
||||
ErrorMessage = "invalid octal escape sequence";
|
||||
}
|
||||
}
|
||||
break;
|
||||
case 'x':
|
||||
/* hexadecimal character (YAP allows empty hexadecimal */
|
||||
{
|
||||
unsigned char so_far = 0;
|
||||
my_fgetch();
|
||||
if (my_isxdigit(ch,'f','F')) {/* hexa */
|
||||
so_far = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
|
||||
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
|
||||
my_fgetch();
|
||||
if (my_isxdigit(ch,'f','F')) { /* hexa */
|
||||
ascii = so_far * 16 + (chtype[ch] == NU ? ch - '0' :
|
||||
(my_isupper(ch) ? ch - 'A' : ch - 'a') + 10);
|
||||
my_fgetch();
|
||||
if (ch != '\\') {
|
||||
ErrorMessage = "invalid hexadecimal escape sequence";
|
||||
}
|
||||
} else if (ch == '\\') {
|
||||
ascii = so_far;
|
||||
} else {
|
||||
ErrorMessage = "invalid hexadecimal escape sequence";
|
||||
}
|
||||
} else if (ch == '\\') {
|
||||
ascii = so_far;
|
||||
my_fgetch();
|
||||
} else {
|
||||
ErrorMessage = "invalid hexadecimal escape sequence";
|
||||
}
|
||||
}
|
||||
break;
|
||||
default:
|
||||
/* accept sequence. Note that the ISO standard does not
|
||||
consider this sequence legal, whereas SICStus would
|
||||
eat up the escape sequence. */
|
||||
ErrorMessage = "invalid escape sequence";
|
||||
}
|
||||
}
|
||||
my_fgetch();
|
||||
TokenInfo = (CELL) MkIntTerm(ascii);
|
||||
goto end_of_read_number;
|
||||
|
||||
66
C/stdpreds.c
66
C/stdpreds.c
@ -629,6 +629,67 @@ p_atom_chars(void)
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
p_atom_concat(void)
|
||||
{
|
||||
Term t1 = Deref(ARG1);
|
||||
char *cptr = (char *)PreAllocCodeSpace(), *cpt0;
|
||||
char *top = (char *)AuxSp;
|
||||
char *atom_str;
|
||||
UInt sz;
|
||||
|
||||
restart:
|
||||
cpt0 = cptr;
|
||||
/* we need to have a list */
|
||||
if (IsVarTerm(t1)) {
|
||||
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
||||
Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
|
||||
return(FALSE);
|
||||
}
|
||||
while (IsPairTerm(t1)) {
|
||||
Term thead = HeadOfTerm(t1);
|
||||
if (IsVarTerm(thead)) {
|
||||
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
||||
Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
|
||||
return(FALSE);
|
||||
}
|
||||
if (!IsAtomTerm(thead)) {
|
||||
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
||||
Error(TYPE_ERROR_ATOM, ARG1, "atom_concat/2");
|
||||
return(FALSE);
|
||||
}
|
||||
atom_str = RepAtom(AtomOfTerm(thead))->StrOfAE;
|
||||
/* check for overflows */
|
||||
sz = strlen(atom_str);
|
||||
if (cptr+sz >= top-1024) {
|
||||
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
||||
if (!growheap(FALSE)) {
|
||||
Abort("[ SYSTEM ERROR: YAP could not grow heap in recorda/3 ]\n");
|
||||
return(FALSE);
|
||||
}
|
||||
goto restart;
|
||||
}
|
||||
memcpy((void *)cptr, (void *)atom_str, sz);
|
||||
cptr += sz;
|
||||
t1 = TailOfTerm(t1);
|
||||
if (IsVarTerm(t1)) {
|
||||
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
||||
Error(INSTANTIATION_ERROR, ARG1, "atom_concat/2");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
if (t1 == TermNil) {
|
||||
Term tout;
|
||||
cptr[0] = '\0';
|
||||
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
||||
tout = MkAtomTerm(LookupAtom(cpt0));
|
||||
return(unify(ARG2, tout));
|
||||
}
|
||||
ReleasePreAllocCodeSpace((ADDR)cpt0);
|
||||
Error(TYPE_ERROR_LIST, ARG1, "atom_concat/2");
|
||||
return(FALSE);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_atom_codes(void)
|
||||
{
|
||||
@ -2090,7 +2151,9 @@ p_set_yap_flags(void)
|
||||
yap_flags[SOURCE_MODE_FLAG] = value;
|
||||
break;
|
||||
case CHARACTER_ESCAPE_FLAG:
|
||||
if (value != ISO_CHARACTER_ESCAPES && value != CPROLOG_CHARACTER_ESCAPES)
|
||||
if (value != ISO_CHARACTER_ESCAPES
|
||||
&& value != CPROLOG_CHARACTER_ESCAPES
|
||||
&& value != SICSTUS_CHARACTER_ESCAPES)
|
||||
return(FALSE);
|
||||
yap_flags[CHARACTER_ESCAPE_FLAG] = value;
|
||||
break;
|
||||
@ -2161,6 +2224,7 @@ InitCPreds(void)
|
||||
InitCPred("number_chars", 2, p_number_chars, SafePredFlag);
|
||||
InitCPred("number_atom", 2, p_number_atom, SafePredFlag);
|
||||
InitCPred("number_codes", 2, p_number_codes, SafePredFlag);
|
||||
InitCPred("atom_concat", 2, p_atom_concat, SafePredFlag);
|
||||
InitCPred("=..", 2, p_univ, SafePredFlag);
|
||||
InitCPred("$statistics_trail_max", 1, p_statistics_trail_max, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("$statistics_heap_max", 1, p_statistics_heap_max, SafePredFlag|SyncPredFlag);
|
||||
|
||||
@ -6,6 +6,11 @@
|
||||
|
||||
<H2 ALIGN=CENTER>Yap-4.3.19:</H2>
|
||||
<UL>
|
||||
<LI> NEW: prolog_flag(version,X).
|
||||
<LI> FIXED: understand 0'\ escape sequences.
|
||||
<LI> NEW: atom_concat/2 (idea from ciao).
|
||||
<LI> NEW: list_concat/2 in library(lists) (idea from ciao).
|
||||
<LI> NEW: allow profile early reset in garbage collector.
|
||||
<LI> FIXED: call_residue should *unify* back constraints *after*
|
||||
restoring original suspension lists.
|
||||
<LI> FIXED: include Mandrake's $(DESTDIR) patches in Makefiles
|
||||
|
||||
26
docs/yap.tex
26
docs/yap.tex
@ -2393,6 +2393,14 @@ The predicate holds when at least one of the arguments is ground
|
||||
be unified with an atom and @var{L} with the list of the ASCII
|
||||
codes for the characters of the external representation of @var{A}.
|
||||
|
||||
@item atom_concat(+@var{As},?@var{A})
|
||||
@findex atom_concat/2
|
||||
@snindex atom_concat/2
|
||||
@cnindex atom_concat/2
|
||||
The predicate holds when the first argument is a list of atoms, and the
|
||||
second unifies with the atom obtained by concatenating all the atoms in
|
||||
the first list.
|
||||
|
||||
@item atom_length(+@var{A},?@var{I}) [ISO]
|
||||
@findex atom_length/2
|
||||
@snindex atom_length/2
|
||||
@ -5676,6 +5684,12 @@ reading terms. The default value for this flag is @code{off} except in
|
||||
@code{on}, or disabled, @code{off}. The default value for this flag is
|
||||
@code{on}.
|
||||
|
||||
@c You can also use @code{cprolog} mode, which corresponds to @code{off},
|
||||
@c @code{iso} mode, which corresponds to @code{on}, and @code{sicstus}
|
||||
@c mode, which corresponds to the mode traditionally used in SICStus
|
||||
@c Prolog. In this mode back-quoted escape sequences should not close with
|
||||
@c a backquote and unrecognised escape codes do not result in error.
|
||||
|
||||
@item debug [ISO]
|
||||
@findex debug (yap_flag/2 option)
|
||||
@*
|
||||
@ -5947,6 +5961,11 @@ the current @code{user_output} stream.
|
||||
By default, the @code{user_output} stream is set to a stream
|
||||
corresponding to the Unix @code{stdout} stream.
|
||||
|
||||
@item version
|
||||
@findex version (yap_flag/2 option)
|
||||
@*
|
||||
Read-only flag that giving the current version of Yap.
|
||||
|
||||
@item write_strings
|
||||
@findex write_strings (yap_flag/2 option)
|
||||
@* Writable flag telling whether the system should write lists of
|
||||
@ -6335,6 +6354,13 @@ is bound to the empty list (nil) or a term with functor '.' and arity 2.
|
||||
@cnindex last/2
|
||||
True when @var{List} is a list and @var{Last} is identical to its last element.
|
||||
|
||||
@item list_concat(+@var{Lists},?@var{List})
|
||||
@findex list_concat/2
|
||||
@snindex list_concat/2
|
||||
@cnindex list_concat/2
|
||||
True when @var{Lists} is a list of lists and @var{List} is the
|
||||
concatenation of @var{Lists}.
|
||||
|
||||
@item member(?@var{Element}, ?@var{Set})
|
||||
@findex member/2
|
||||
@syindex member/2
|
||||
|
||||
@ -23,7 +23,8 @@
|
||||
sublist/2,
|
||||
substitute/4,
|
||||
suffix/2,
|
||||
sumlist/2
|
||||
sumlist/2,
|
||||
list_concat/2
|
||||
]).
|
||||
|
||||
|
||||
@ -267,3 +268,22 @@ sumlist([Head|Tail], Sofar, Total) :-
|
||||
sumlist(Tail, Next, Total).
|
||||
|
||||
|
||||
% list_concat(Lists, List)
|
||||
% is true when Lists is a list of lists, and List is the
|
||||
% concatenation of these lists.
|
||||
|
||||
list_concat(Lists, List) :-
|
||||
list_concat(Lists, [], List).
|
||||
|
||||
list_concat([], []).
|
||||
list_concat([H|T], L) :-
|
||||
list_concat(H, L, Li),
|
||||
list_concat(T, Li).
|
||||
|
||||
list_concat([], L, L).
|
||||
list_concat([H|T], [H|Lf], Li) :-
|
||||
list_concat(T, Lf, Li).
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -10,7 +10,7 @@
|
||||
* File: Yap.h.m4 *
|
||||
* mods: *
|
||||
* comments: main header file for YAP *
|
||||
* version: $Id: Yap.h.m4,v 1.2 2001-04-16 16:41:04 vsc Exp $ *
|
||||
* version: $Id: Yap.h.m4,v 1.3 2001-04-17 21:07:41 vsc Exp $ *
|
||||
*************************************************************************/
|
||||
|
||||
#include "config.h"
|
||||
@ -477,6 +477,7 @@ typedef enum {
|
||||
|
||||
#define CPROLOG_CHARACTER_ESCAPES 0
|
||||
#define ISO_CHARACTER_ESCAPES 1
|
||||
#define SICSTUS_CHARACTER_ESCAPES 2
|
||||
|
||||
#define NUMBER_OF_YAP_FLAGS HALT_AFTER_CONSULT_FLAG+1
|
||||
|
||||
|
||||
@ -192,6 +192,12 @@ yap_flag(max_arity,X) :-
|
||||
yap_flag(max_arity,X) :-
|
||||
throw(error(domain_error(flag_value,max_arity+X),yap_flag(max_arity,X))).
|
||||
|
||||
yap_flag(version,X) :-
|
||||
var(X), !,
|
||||
'$get_value'('$version_name',X).
|
||||
yap_flag(version,X) :-
|
||||
throw(error(permission_error(modify,flag,version),yap_flag(version,X))).
|
||||
|
||||
yap_flag(max_integer,X) :-
|
||||
var(X), !,
|
||||
'$access_yap_flags'(0, 1),
|
||||
@ -401,13 +407,19 @@ yap_flag(to_chars_mode,X) :-
|
||||
yap_flag(character_escapes,X) :-
|
||||
var(X), !,
|
||||
'$access_yap_flags'(12,Y),
|
||||
'$transl_to_on_off'(Y,X).
|
||||
'$transl_to_character_escape_modes'(Y,X).
|
||||
yap_flag(character_escapes,X) :- !,
|
||||
'$transl_to_on_off'(Y,X), !,
|
||||
'$transl_to_character_escape_modes'(Y,X), !,
|
||||
'$set_yap_flags'(12,Y).
|
||||
yap_flag(character_escapes,X) :-
|
||||
throw(error(domain_error(flag_value,character_escapes+X),yap_flag(to_chars_mode,X))).
|
||||
|
||||
'$transl_to_character_escape_modes'(0,off) :- !.
|
||||
'$transl_to_character_escape_modes'(0,cprolog).
|
||||
'$transl_to_character_escape_modes'(1,on) :- !.
|
||||
'$transl_to_character_escape_modes'(1,iso).
|
||||
'$transl_to_character_escape_modes'(2,sicstus).
|
||||
|
||||
yap_flag(update_semantics,X) :-
|
||||
var(X), !,
|
||||
( '$log_upd'(I) -> '$convert_upd_sem'(I,X) ).
|
||||
@ -547,6 +559,7 @@ yap_flag(host_type,X) :-
|
||||
V = user_error ;
|
||||
V = user_input ;
|
||||
V = user_output ;
|
||||
V = version ;
|
||||
V = write_strings
|
||||
),
|
||||
yap_flag(V, Out).
|
||||
|
||||
Reference in New Issue
Block a user