PageRenderTime 57ms CodeModel.GetById 27ms RepoModel.GetById 0ms app.codeStats 0ms

/pl-6.0.2/src/pl-list.c

#
C | 473 lines | 305 code | 77 blank | 91 comment | 59 complexity | 0bd599055f9a41816e78f3c610a98fb4 MD5 | raw file
Possible License(s): AGPL-3.0, LGPL-2.1, GPL-2.0, LGPL-2.0, BSD-3-Clause
  1. /* $Id$
  2. Part of SWI-Prolog
  3. Author: Jan Wielemaker
  4. E-mail: jan@swi.psy.uva.nl
  5. WWW: http://www.swi-prolog.org
  6. Copyright (C): 1985-2002, University of Amsterdam
  7. This library is free software; you can redistribute it and/or
  8. modify it under the terms of the GNU Lesser General Public
  9. License as published by the Free Software Foundation; either
  10. version 2.1 of the License, or (at your option) any later version.
  11. This library is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. Lesser General Public License for more details.
  15. You should have received a copy of the GNU Lesser General Public
  16. License along with this library; if not, write to the Free Software
  17. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18. */
  19. #include "pl-incl.h"
  20. #undef LD
  21. #define LD LOCAL_LD
  22. static
  23. PRED_IMPL("is_list", 1, is_list, 0)
  24. { if ( lengthList(A1, FALSE) >= 0 )
  25. succeed;
  26. fail;
  27. }
  28. /** $length(-List, +Len) is semidet.
  29. Implements `known-length' generation path of length/2. Fails if Len < 0.
  30. */
  31. static
  32. PRED_IMPL("$length", 2, dlength, 0)
  33. { PRED_LD
  34. intptr_t len;
  35. if ( PL_get_intptr(A2, &len) )
  36. { if ( len > 0 )
  37. { Word p;
  38. term_t list = PL_new_term_ref();
  39. if ( !hasGlobalSpace(len*3) )
  40. { int rc;
  41. if ( (rc=ensureGlobalSpace(len*3, ALLOW_GC)) != TRUE )
  42. return raiseStackOverflow(rc);
  43. }
  44. p = gTop;
  45. *valTermRef(list) = consPtr(p, TAG_COMPOUND|STG_GLOBAL);
  46. while(len-- > 0)
  47. { p[0] = FUNCTOR_dot2;
  48. setVar(p[1]);
  49. p[2] = consPtr(&p[3], TAG_COMPOUND|STG_GLOBAL);
  50. p += 3;
  51. }
  52. p[-1] = ATOM_nil;
  53. gTop = p;
  54. return PL_unify(A1, list);
  55. } else if ( len == 0 )
  56. { return PL_unify_nil(A1);
  57. } else
  58. { return FALSE;
  59. }
  60. } else if ( PL_is_integer(A2) )
  61. { number i;
  62. Word p = valTermRef(A2);
  63. deRef(p);
  64. get_integer(*p, &i);
  65. if ( ar_sign_i(&i) < 0 )
  66. return FALSE;
  67. return outOfStack((Stack)&LD->stacks.global, STACK_OVERFLOW_RAISE);
  68. }
  69. return PL_error("length", 2, NULL, ERR_TYPE, ATOM_integer, A2);
  70. }
  71. static
  72. PRED_IMPL("memberchk", 2, memberchk, 0)
  73. { GET_LD
  74. term_t h = PL_new_term_ref();
  75. term_t l = PL_copy_term_ref(A2);
  76. fid_t fid;
  77. if ( !(fid=PL_open_foreign_frame()) )
  78. return FALSE;
  79. for(;;)
  80. { if ( !PL_unify_list(l, h, l) )
  81. { PL_close_foreign_frame(fid);
  82. fail;
  83. }
  84. if ( PL_unify(A1, h) )
  85. { term_t ex = 0;
  86. if ( foreignWakeup(&ex PASS_LD) )
  87. { PL_close_foreign_frame(fid);
  88. succeed;
  89. } else
  90. { if ( ex )
  91. return PL_raise_exception(ex);
  92. PL_rewind_foreign_frame(fid);
  93. }
  94. } else
  95. { PL_rewind_foreign_frame(fid);
  96. }
  97. }
  98. }
  99. /*******************************
  100. * SORTING *
  101. *******************************/
  102. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  103. Natural merge sort. Code contributed by Richard O'Keefe and integrated
  104. into SWI-Prolog by Jan Wielemaker. The nice point about this code is
  105. that it uses no extra space and is pretty stable in performance.
  106. Richards claim it that many qsort() implementations in libc are very
  107. slow. This isn't the case for glibc 2.2, where this performs about the
  108. same as the previous qsort() based implementation. However, it
  109. integrated keysort/2 in the set and here the difference is huge.
  110. Here is C code implementing a bottom-up natural merge sort on lists; it
  111. has remove_dups and compare_keys options. (Actually I wouldn't handle
  112. the compare_keys option quite like this.) The difference between this
  113. and sam-sort is the way runs are built:
  114. natural merge:
  115. add new node r after last node q of run if item(q) <= item(r)
  116. otherwise end this run.
  117. sam-sort:
  118. add new node r after last node q of run if item(q) <= item(r)
  119. otherwise
  120. add new new r before first node p of run if item(r) < item(p)
  121. otherwise end this run.
  122. The natural merge has the nice property that if the list is already
  123. sorted it takes O(N) time. In general if you have a list made of M
  124. already sorted pieces S1++S2++...++SM it will take no more than O(N.log
  125. M). Sam-sort (for "Smooth Applicative Merge sort") has the nice property
  126. that it likes the reverse order almost as much as forward order, so \ /\
  127. and \/ patterns are sorted (nearly) as fast as / // and // patterns
  128. respectively.
  129. I've been using a variant of this code in a sorting utility since about
  130. 1988. It leaves the UNIX sort(1) program in the dust. As you may know,
  131. sort(1) breaks the input into blocks that fit in memory, sorts the
  132. blocks using qsort(), and writes the blocks out to disc, then merges the
  133. blocks. For files that fit into memory, the variant of this code runs
  134. about twice as fast as sort(1). Part of that is better I/O, but part is
  135. just plain not using qsort().
  136. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  137. /* Things in capital letters should be replaced for different applications */
  138. /* ITEM The type of an individual item.
  139. COMPARE Compares two items given their addresses (allows ITEM to be
  140. large and avoids pass by copy). Return <0, =0, or >0.
  141. COMPARE_KEY Compares the keys of two items given the addresses of the
  142. entire items.
  143. FREE Frees a List_Record including its ITEM.
  144. */
  145. typedef struct
  146. { Word term;
  147. Word key;
  148. } ITEM;
  149. /* TBD: handle CMP_ERROR */
  150. #ifndef COMPARE
  151. #define COMPARE(x,y) compareStandard((x)->term, (y)->term, FALSE PASS_LD)
  152. #endif
  153. #ifndef COMPARE_KEY
  154. #define COMPARE_KEY(x,y) compareStandard((x)->key, (y)->key, FALSE PASS_LD)
  155. #endif
  156. #ifndef FREE
  157. #define FREE(x) \
  158. { x->next = NULL; \
  159. x->item.term = NULL; \
  160. x->item.key = NULL; \
  161. }
  162. #endif
  163. typedef struct List_Record *list;
  164. struct List_Record {
  165. list next;
  166. ITEM item;
  167. };
  168. #define NIL (list)0
  169. #define compare(c, x, y) \
  170. int c = compare_keys ? COMPARE_KEY(&(x)->item, &(y)->item) \
  171. : COMPARE( &(x)->item, &(y)->item)
  172. static list
  173. nat_sort(list data, int remove_dups, int compare_keys)
  174. { GET_LD
  175. list stack[64]; /* enough for biggest machine */
  176. list *sp = stack;
  177. int runs = 0; /* total number of runs processed */
  178. list p, q, r, s;
  179. struct List_Record header;
  180. int k;
  181. remove_dups = !remove_dups; /* 0 -> do, 1 -> don't */
  182. while ((p = data) != NIL)
  183. { /* pick up a run from the front of data, setting */
  184. /* p = (pointer to beginning of run), data = (rest of data) */
  185. if ((q = p->next) != NIL)
  186. { compare(c, p, q);
  187. data = q->next;
  188. if (c > 0)
  189. { r = q, q = p, p = r;
  190. p->next = q;
  191. } else if (c == remove_dups)
  192. { /* c < 0 or = 0, so c = 1 impossible */
  193. p->next = q->next;
  194. FREE(q);
  195. q = p;
  196. }
  197. for (r = data; r != NIL; )
  198. { compare(c, q, r);
  199. if (c > 0)
  200. break;
  201. if (c == remove_dups)
  202. { s = r->next;
  203. FREE(r);
  204. r = s;
  205. } else
  206. { q->next = r, q = r, r = r->next;
  207. }
  208. }
  209. q->next = NIL;
  210. data = r;
  211. } else
  212. { data = NIL;
  213. }
  214. runs++;
  215. /* merge this run with 0 or more runs off the top of the stack */
  216. for (k = runs; 1 &~ k; k >>= 1)
  217. { q = *--sp;
  218. r = &header;
  219. while (q && p)
  220. { /* q precedes p */
  221. compare(c, q, p);
  222. if (c <= 0)
  223. { r->next = q, r = q, q = q->next;
  224. if (c == remove_dups)
  225. { s = p->next;
  226. FREE(p);
  227. p = s;
  228. }
  229. } else
  230. { r->next = p, r = p, p = p->next;
  231. }
  232. }
  233. r->next = q ? q : p;
  234. p = header.next;
  235. }
  236. /* push the merged run onto the stack */
  237. *sp++ = p;
  238. }
  239. if (sp == stack)
  240. return NIL;
  241. /* merge all the runs on the stack */
  242. p = *--sp;
  243. while (sp != stack)
  244. { q = *--sp;
  245. r = &header;
  246. while (q && p)
  247. { /* q precedes p */
  248. compare(c, q, p);
  249. if (c <= 0)
  250. { r->next = q, r = q, q = q->next;
  251. if (c == remove_dups)
  252. { s = p->next;
  253. FREE(p);
  254. p = s;
  255. }
  256. } else
  257. { r->next = p, r = p, p = p->next;
  258. }
  259. }
  260. r->next = q ? q : p;
  261. p = header.next;
  262. }
  263. return p;
  264. }
  265. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  266. Create a list on the global stack, just at the place the final result
  267. will be.
  268. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  269. static int
  270. prolog_list_to_sort_list(term_t t, int remove_dups, int key,
  271. list *lp, Word *end)
  272. { GET_LD
  273. Word l, tail;
  274. list p;
  275. intptr_t len;
  276. int rc;
  277. l = valTermRef(t);
  278. len = skip_list(l, &tail PASS_LD);
  279. if ( !(isNil(*tail) || /* proper list */
  280. (isList(*tail) && remove_dups)) ) /* sort/2 on cyclic list */
  281. {
  282. if ( isVar(*tail) )
  283. return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
  284. else
  285. return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, t);
  286. }
  287. if ( !hasGlobalSpace(len*3) )
  288. { if ( (rc=ensureGlobalSpace(len*3, ALLOW_GC)) != TRUE )
  289. return raiseStackOverflow(rc);
  290. l = valTermRef(t); /* may be shifted */
  291. deRef(l);
  292. }
  293. p = (list)gTop;
  294. *lp = p;
  295. while(len-- > 0)
  296. { p->item.term = HeadList(l);
  297. deRef(p->item.term);
  298. if ( key )
  299. { word w = *p->item.term;
  300. if ( hasFunctor(w, FUNCTOR_minus2) )
  301. { p->item.key = argTermP(w, 0);
  302. deRef(p->item.key);
  303. } else
  304. { PL_error("keysort", 2, NULL, ERR_TYPE,
  305. ATOM_pair, pushWordAsTermRef(p->item.term));
  306. popTermRef();
  307. return FALSE;
  308. }
  309. }
  310. l = TailList(l);
  311. deRef(l);
  312. if ( len > 0 )
  313. { assert(isList(*l));
  314. p->next = p+1;
  315. p++;
  316. }
  317. }
  318. p->next = NULL;
  319. *end = (Word)(p+1);
  320. succeed;
  321. }
  322. static void
  323. put_sort_list(term_t l, list sl)
  324. { GET_LD
  325. *valTermRef(l) = consPtr(sl, TAG_COMPOUND|STG_GLOBAL);
  326. for(;;)
  327. { list n = sl->next;
  328. Word p = (Word)sl;
  329. n = sl->next;
  330. /* see also linkVal() */
  331. p[1] = (needsRef(*sl->item.term) ? makeRef(sl->item.term)
  332. : *sl->item.term);
  333. p[0] = FUNCTOR_dot2;
  334. if ( n )
  335. { p[2] = consPtr(n, TAG_COMPOUND|STG_GLOBAL);
  336. sl = n;
  337. } else
  338. { p[2] = ATOM_nil;
  339. return;
  340. }
  341. }
  342. }
  343. static int
  344. pl_nat_sort(term_t in, term_t out, int remove_dups, int compare_keys ARG_LD)
  345. { if ( PL_get_nil(in) )
  346. return PL_unify_atom(out, ATOM_nil);
  347. else
  348. { list l = 0;
  349. term_t tmp = PL_new_term_ref();
  350. Word top = NULL;
  351. if ( prolog_list_to_sort_list(in, remove_dups, compare_keys, &l, &top) )
  352. { l = nat_sort(l, remove_dups, compare_keys);
  353. put_sort_list(tmp, l);
  354. gTop = top;
  355. return PL_unify(out, tmp);
  356. }
  357. fail;
  358. }
  359. }
  360. static
  361. PRED_IMPL("sort", 2, sort, PL_FA_ISO)
  362. { PRED_LD
  363. return pl_nat_sort(A1, A2, TRUE, FALSE PASS_LD);
  364. }
  365. static
  366. PRED_IMPL("msort", 2, msort, 0)
  367. { PRED_LD
  368. return pl_nat_sort(A1, A2, FALSE, FALSE PASS_LD);
  369. }
  370. static
  371. PRED_IMPL("keysort", 2, keysort, PL_FA_ISO)
  372. { PRED_LD
  373. return pl_nat_sort(A1, A2, FALSE, TRUE PASS_LD);
  374. }
  375. /*******************************
  376. * PUBLISH PREDICATES *
  377. *******************************/
  378. BeginPredDefs(list)
  379. PRED_DEF("is_list", 1, is_list, 0)
  380. PRED_DEF("$length", 2, dlength, 0)
  381. PRED_DEF("memberchk", 2, memberchk, 0)
  382. PRED_DEF("sort", 2, sort, PL_FA_ISO)
  383. PRED_DEF("msort", 2, msort, 0)
  384. PRED_DEF("keysort", 2, keysort, PL_FA_ISO)
  385. EndPredDefs