1/*
2 * Copyright (c) 2001 by The XFree86 Project, Inc.
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a
5 * copy of this software and associated documentation files (the "Software"),
6 * to deal in the Software without restriction, including without limitation
7 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 * and/or sell copies of the Software, and to permit persons to whom the
9 * Software is furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20 * SOFTWARE.
21 *
22 * Except as contained in this notice, the name of the XFree86 Project shall
23 * not be used in advertising or otherwise to promote the sale, use or other
24 * dealings in this Software without prior written authorization from the
25 * XFree86 Project.
26 *
27 * Author: Paulo César Pereira de Andrade
28 */
29
30/* $XFree86: xc/programs/xedit/lisp/helper.c,v 1.50 2003/05/27 22:27:03 tsi Exp $ */
31
32#include "lisp/helper.h"
33#include "lisp/pathname.h"
34#include "lisp/package.h"
35#include "lisp/read.h"
36#include "lisp/stream.h"
37#include "lisp/write.h"
38#include "lisp/hash.h"
39#include <ctype.h>
40#include <fcntl.h>
41#include <errno.h>
42#include <math.h>
43#include <sys/stat.h>
44
45/*
46 * Prototypes
47 */
48static LispObj *LispReallyDo(LispBuiltin*, int);
49static LispObj *LispReallyDoListTimes(LispBuiltin*, int);
50
51/* in math.c */
52extern LispObj *LispFloatCoerce(LispBuiltin*, LispObj*);
53
54/*
55 * Implementation
56 */
57LispObj *
58LispObjectCompare(LispObj *left, LispObj *right, int function)
59{
60    LispType ltype, rtype;
61    LispObj *result = left == right ? T : NIL;
62
63    /* If left and right are the same object, or if function is EQ */
64    if (result == T || function == FEQ)
65	return (result);
66
67    ltype = OBJECT_TYPE(left);
68    rtype = OBJECT_TYPE(right);
69
70    /* Equalp requires that numeric objects be compared by value, and
71     * strings or characters comparison be case insenstive */
72    if (function == FEQUALP) {
73	switch (ltype) {
74	    case LispFixnum_t:
75	    case LispInteger_t:
76	    case LispBignum_t:
77	    case LispDFloat_t:
78	    case LispRatio_t:
79	    case LispBigratio_t:
80	    case LispComplex_t:
81		switch (rtype) {
82		    case LispFixnum_t:
83		    case LispInteger_t:
84		    case LispBignum_t:
85		    case LispDFloat_t:
86		    case LispRatio_t:
87		    case LispBigratio_t:
88		    case LispComplex_t:
89			result = APPLY2(Oequal_, left, right);
90			break;
91		    default:
92			break;
93		}
94		goto compare_done;
95	    case LispSChar_t:
96		if (rtype == LispSChar_t &&
97		    toupper(SCHAR_VALUE(left)) == toupper(SCHAR_VALUE(right)))
98		    result = T;
99		goto compare_done;
100	    case LispString_t:
101		if (rtype == LispString_t && STRLEN(left) == STRLEN(right)) {
102		    long i = STRLEN(left);
103		    char *sl = THESTR(left), *sr = THESTR(right);
104
105		    for (--i; i >= 0; i--)
106			if (toupper(sl[i]) != toupper(sr[i]))
107			    break;
108		    if (i < 0)
109			result = T;
110		}
111		goto compare_done;
112	    case LispArray_t:
113		if (rtype == LispArray_t &&
114		    left->data.array.type == right->data.array.type &&
115		    left->data.array.rank == right->data.array.rank &&
116		    LispObjectCompare(left->data.array.dim,
117				      right->data.array.dim,
118				      FEQUAL) != NIL) {
119		    LispObj *llist = left->data.array.list,
120		    	    *rlist = right->data.array.list;
121
122		    for (; CONSP(llist); llist = CDR(llist), rlist = CDR(rlist))
123			if (LispObjectCompare(CAR(llist), CAR(rlist),
124					      FEQUALP) == NIL)
125			    break;
126		    if (!CONSP(llist))
127			result = T;
128		}
129		goto compare_done;
130	    case LispStruct_t:
131		if (rtype == LispStruct_t &&
132		    left->data.struc.def == right->data.struc.def) {
133		    LispObj *lfield = left->data.struc.fields,
134		    	    *rfield = right->data.struc.fields;
135
136		    for (; CONSP(lfield);
137			 lfield = CDR(lfield), rfield = CDR(rfield)) {
138			if (LispObjectCompare(CAR(lfield), CAR(rfield),
139					      FEQUALP) != T)
140			    break;
141		    }
142		    if (!CONSP(lfield))
143			result = T;
144		}
145		goto compare_done;
146	    case LispHashTable_t:
147		if (rtype == LispHashTable_t &&
148		    left->data.hash.table->count ==
149		    right->data.hash.table->count &&
150		    left->data.hash.test == right->data.hash.test) {
151		    unsigned long i;
152		    LispObj *test = left->data.hash.test;
153		    LispHashEntry *lentry = left->data.hash.table->entries,
154				  *llast = lentry +
155					   left->data.hash.table->num_entries,
156				  *rentry = right->data.hash.table->entries;
157
158		    for (; lentry < llast; lentry++, rentry++) {
159			if (lentry->count != rentry->count)
160			    break;
161			for (i = 0; i < lentry->count; i++) {
162			    if (APPLY2(test,
163				       lentry->keys[i],
164				       rentry->keys[i]) == NIL ||
165				LispObjectCompare(lentry->values[i],
166						  rentry->values[i],
167						  FEQUALP) == NIL)
168				break;
169			}
170			if (i < lentry->count)
171			    break;
172		    }
173		    if (lentry == llast)
174			result = T;
175		}
176		goto compare_done;
177	    default:
178		break;
179	}
180    }
181
182    /* Function is EQL or EQUAL, or EQUALP on arguments with the same rules */
183    if (ltype == rtype) {
184	switch (ltype) {
185	    case LispFixnum_t:
186	    case LispSChar_t:
187		if (FIXNUM_VALUE(left) == FIXNUM_VALUE(right))
188		    result = T;
189		break;
190	    case LispInteger_t:
191		if (INT_VALUE(left) == INT_VALUE(right))
192		    result = T;
193		break;
194	    case LispDFloat_t:
195		if (DFLOAT_VALUE(left) == DFLOAT_VALUE(right))
196		    result = T;
197		break;
198	    case LispRatio_t:
199		if (left->data.ratio.numerator ==
200		    right->data.ratio.numerator &&
201		    left->data.ratio.denominator ==
202		    right->data.ratio.denominator)
203		    result = T;
204		break;
205	    case LispComplex_t:
206		if (LispObjectCompare(left->data.complex.real,
207				      right->data.complex.real,
208				      function) == T &&
209		    LispObjectCompare(left->data.complex.imag,
210				      right->data.complex.imag,
211				      function) == T)
212		    result = T;
213		break;
214	    case LispBignum_t:
215		if (mpi_cmp(left->data.mp.integer, right->data.mp.integer) == 0)
216		    result = T;
217		break;
218	    case LispBigratio_t:
219		if (mpr_cmp(left->data.mp.ratio, right->data.mp.ratio) == 0)
220		    result = T;
221		break;
222	    default:
223		break;
224	}
225
226	/* Next types must be the same object for EQL */
227	if (function == FEQL)
228	    goto compare_done;
229
230	switch (ltype) {
231	    case LispString_t:
232		if (STRLEN(left) == STRLEN(right) &&
233		    memcmp(THESTR(left), THESTR(right), STRLEN(left)) == 0)
234		    result = T;
235		break;
236	    case LispCons_t:
237		if (LispObjectCompare(CAR(left), CAR(right), function) == T &&
238		    LispObjectCompare(CDR(left), CDR(right), function) == T)
239		    result = T;
240		break;
241	    case LispQuote_t:
242	    case LispBackquote_t:
243	    case LispPathname_t:
244		result = LispObjectCompare(left->data.pathname,
245					   right->data.pathname, function);
246		break;
247	    case LispLambda_t:
248		result = LispObjectCompare(left->data.lambda.name,
249					   right->data.lambda.name,
250					   function);
251		break;
252	    case LispOpaque_t:
253		if (left->data.opaque.data == right->data.opaque.data)
254		    result = T;
255		break;
256	    case LispRegex_t:
257		/* If the regexs are guaranteed to generate the same matches */
258		if (left->data.regex.options == right->data.regex.options)
259		    result = LispObjectCompare(left->data.regex.pattern,
260					       right->data.regex.pattern,
261					       function);
262		break;
263	    default:
264		break;
265	}
266    }
267
268compare_done:
269    return (result);
270}
271
272void
273LispCheckSequenceStartEnd(LispBuiltin *builtin,
274			  LispObj *sequence, LispObj *start, LispObj *end,
275			  long *pstart, long *pend, long *plength)
276{
277    /* Calculate length of sequence and check it's type */
278    *plength = LispLength(sequence);
279
280    /* Check start argument */
281    if (start == UNSPEC || start == NIL)
282	*pstart = 0;
283    else {
284	CHECK_INDEX(start);
285	*pstart = FIXNUM_VALUE(start);
286    }
287
288    /* Check end argument */
289    if (end == UNSPEC || end == NIL)
290	*pend = *plength;
291    else {
292	CHECK_INDEX(end);
293	*pend = FIXNUM_VALUE(end);
294    }
295
296    /* Check start argument */
297    if (*pstart > *pend)
298	LispDestroy("%s: :START %ld is larger than :END %ld",
299		    STRFUN(builtin), *pstart, *pend);
300
301    /* Check end argument */
302    if (*pend > *plength)
303	LispDestroy("%s: :END %ld is larger then sequence length %ld",
304		    STRFUN(builtin), *pend, *plength);
305}
306
307long
308LispLength(LispObj *sequence)
309{
310    long length;
311
312    if (sequence == NIL)
313	return (0);
314    switch (OBJECT_TYPE(sequence)) {
315	case LispString_t:
316	    length = STRLEN(sequence);
317	    break;
318	case LispArray_t:
319	    if (sequence->data.array.rank != 1)
320		goto not_a_sequence;
321	    sequence = sequence->data.array.list;
322	    /*FALLTROUGH*/
323	case LispCons_t:
324	    for (length = 0;
325		 CONSP(sequence);
326		 length++, sequence = CDR(sequence))
327		;
328	    break;
329	default:
330not_a_sequence:
331	    LispDestroy("LENGTH: %s is not a sequence", STROBJ(sequence));
332	    /*NOTREACHED*/
333	    length = 0;
334    }
335
336    return (length);
337}
338
339LispObj *
340LispCharacterCoerce(LispBuiltin *builtin, LispObj *object)
341{
342    if (SCHARP(object))
343	return (object);
344    else if (STRINGP(object) && STRLEN(object) == 1)
345	return (SCHAR(THESTR(object)[0]));
346    else if (SYMBOLP(object) && ATOMID(object)->value[1] == '\0')
347	return (SCHAR(ATOMID(object)->value[0]));
348    else if (INDEXP(object)) {
349	int c = FIXNUM_VALUE(object);
350
351	if (c <= 0xff)
352	    return (SCHAR(c));
353    }
354    else if (object == T)
355	return (SCHAR('T'));
356
357    LispDestroy("%s: cannot convert %s to character",
358		STRFUN(builtin), STROBJ(object));
359    /*NOTREACHED*/
360    return (NIL);
361}
362
363LispObj *
364LispStringCoerce(LispBuiltin *builtin, LispObj *object)
365{
366    if (STRINGP(object))
367	return (object);
368    else if (SYMBOLP(object))
369	return (LispSymbolName(object));
370    else if (SCHARP(object)) {
371	char string[1];
372
373	string[0] = SCHAR_VALUE(object);
374	return (LSTRING(string, 1));
375    }
376    else if (object == NIL)
377	return (LSTRING(Snil->value, 3));
378    else if (object == T)
379	return (LSTRING(St->value, 1));
380    else
381	LispDestroy("%s: cannot convert %s to string",
382		    STRFUN(builtin), STROBJ(object));
383    /*NOTREACHED*/
384    return (NIL);
385}
386
387LispObj *
388LispCoerce(LispBuiltin *builtin,
389	   LispObj *object, LispObj *result_type)
390{
391    LispObj *result = NIL;
392    LispType type = LispNil_t;
393
394    if (result_type == NIL)
395	/* not even NIL can be converted to NIL? */
396	LispDestroy("%s: cannot convert %s to NIL",
397		    STRFUN(builtin), STROBJ(object));
398
399    else if (result_type == T)
400	/* no conversion */
401	return (object);
402
403    else if (!SYMBOLP(result_type))
404	/* only know about simple types */
405	LispDestroy("%s: bad argument %s",
406		    STRFUN(builtin), STROBJ(result_type));
407
408    else {
409	/* check all known types */
410
411	Atom_id atom = ATOMID(result_type);
412
413	if (atom == Satom) {
414	    if (CONSP(object))
415		goto coerce_fail;
416	    return (object);
417	}
418	/* only convert ATOM to SYMBOL */
419
420	if (atom == Sfloat)
421	    type = LispDFloat_t;
422	else if (atom == Sinteger)
423	    type = LispInteger_t;
424	else if (atom == Scons || atom == Slist) {
425	    if (object == NIL)
426		return (object);
427	    type = LispCons_t;
428	}
429	else if (atom == Sstring)
430	    type = LispString_t;
431	else if (atom == Scharacter)
432	    type = LispSChar_t;
433	else if (atom == Scomplex)
434	    type = LispComplex_t;
435	else if (atom == Svector || atom == Sarray)
436	    type = LispArray_t;
437	else if (atom == Sopaque)
438	    type = LispOpaque_t;
439	else if (atom == Srational)
440	    type = LispRatio_t;
441	else if (atom == Spathname)
442	    type = LispPathname_t;
443	else
444	    LispDestroy("%s: invalid type specification %s",
445			STRFUN(builtin), ATOMID(result_type)->value);
446    }
447
448    if (OBJECT_TYPE(object) == LispOpaque_t) {
449	switch (type) {
450	    case LispAtom_t:
451		result = ATOM(object->data.opaque.data);
452		break;
453	    case LispString_t:
454		result = STRING(object->data.opaque.data);
455		break;
456	    case LispSChar_t:
457		result = SCHAR((unsigned long)object->data.opaque.data);
458		break;
459	    case LispDFloat_t:
460		result = DFLOAT((double)((long)object->data.opaque.data));
461		break;
462	    case LispInteger_t:
463		result = INTEGER(((long)object->data.opaque.data));
464		break;
465	    case LispOpaque_t:
466		result = OPAQUE(object->data.opaque.data, 0);
467		break;
468	    default:
469		goto coerce_fail;
470		break;
471	}
472    }
473
474    else if (OBJECT_TYPE(object) != type) {
475	switch (type) {
476	    case LispInteger_t:
477		if (INTEGERP(object))
478		    result = object;
479		else if (DFLOATP(object)) {
480		    if ((long)DFLOAT_VALUE(object) == DFLOAT_VALUE(object))
481			result = INTEGER((long)DFLOAT_VALUE(object));
482		    else {
483			mpi *integer = LispMalloc(sizeof(mpi));
484
485			mpi_init(integer);
486			mpi_setd(integer, DFLOAT_VALUE(object));
487			if (mpi_getd(integer) != DFLOAT_VALUE(object)) {
488			    mpi_clear(integer);
489			    LispFree(integer);
490			    goto coerce_fail;
491			}
492			result = BIGNUM(integer);
493		    }
494		}
495		else
496		    goto coerce_fail;
497		break;
498	    case LispRatio_t:
499		if (DFLOATP(object)) {
500		    mpr *ratio = LispMalloc(sizeof(mpr));
501
502		    mpr_init(ratio);
503		    mpr_setd(ratio, DFLOAT_VALUE(object));
504		    if (mpr_fiti(ratio)) {
505			result = RATIO(mpi_geti(mpr_num(ratio)),
506				       mpi_geti(mpr_den(ratio)));
507			mpr_clear(ratio);
508			LispFree(ratio);
509		    }
510		    else
511			result = BIGRATIO(ratio);
512		}
513		else if (RATIONALP(object))
514		    result = object;
515		else
516		    goto coerce_fail;
517		break;
518	    case LispDFloat_t:
519		result = LispFloatCoerce(builtin, object);
520	    	break;
521	    case LispComplex_t:
522		if (NUMBERP(object))
523		    result = object;
524		else
525		    goto coerce_fail;
526		break;
527	    case LispString_t:
528		if (object == NIL)
529		    result = STRING("");
530		else
531		    result = LispStringCoerce(builtin, object);
532		break;
533	    case LispSChar_t:
534		result = LispCharacterCoerce(builtin, object);
535		break;
536	    case LispArray_t:
537		if (LISTP(object))
538		    result = VECTOR(object);
539		else
540		    goto coerce_fail;
541		break;
542	    case LispCons_t:
543		if (ARRAYP(object) && object->data.array.rank == 1)
544		    result = object->data.array.list;
545		else
546		    goto coerce_fail;
547		break;
548	    case LispPathname_t:
549		result = APPLY1(Oparse_namestring, object);
550		break;
551	    default:
552		goto coerce_fail;
553	}
554    }
555    else
556	result = object;
557
558    return (result);
559
560coerce_fail:
561    LispDestroy("%s: cannot convert %s to %s",
562		STRFUN(builtin), STROBJ(object), ATOMID(result_type)->value);
563    /* NOTREACHED */
564    return (NIL);
565}
566
567static LispObj *
568LispReallyDo(LispBuiltin *builtin, int refs)
569/*
570 do init test &rest body
571 do* init test &rest body
572 */
573{
574    GC_ENTER();
575    int stack, lex, head;
576    LispObj *list, *symbol, *value, *values, *cons;
577
578    LispObj *init, *test, *body;
579
580    body = ARGUMENT(2);
581    test = ARGUMENT(1);
582    init = ARGUMENT(0);
583
584    if (!CONSP(test))
585	LispDestroy("%s: end test condition must be a list, not %s",
586		    STRFUN(builtin), STROBJ(init));
587
588    CHECK_LIST(init);
589
590    /* Save state */
591    stack = lisp__data.stack.length;
592    lex = lisp__data.env.lex;
593    head = lisp__data.env.length;
594
595    values = cons = NIL;
596    for (list = init; CONSP(list); list = CDR(list)) {
597	symbol = CAR(list);
598	if (!SYMBOLP(symbol)) {
599	    CHECK_CONS(symbol);
600	    value = CDR(symbol);
601	    symbol = CAR(symbol);
602	    CHECK_SYMBOL(symbol);
603	    CHECK_CONS(value);
604	    value = EVAL(CAR(value));
605	}
606	else
607	    value = NIL;
608
609	CHECK_CONSTANT(symbol);
610
611	LispAddVar(symbol, value);
612
613	/* Bind variable now */
614	if (refs) {
615	    ++lisp__data.env.head;
616	}
617	else {
618	    if (values == NIL) {
619		values = cons = CONS(NIL, NIL);
620		GC_PROTECT(values);
621	    }
622	    else {
623		RPLACD(cons, CONS(NIL, NIL));
624		cons = CDR(cons);
625	    }
626	}
627    }
628    if (!refs)
629	lisp__data.env.head = lisp__data.env.length;
630
631    for (;;) {
632	if (EVAL(CAR(test)) != NIL)
633	    break;
634
635	/* TODO Run this code in an implicit tagbody */
636	for (list = body; CONSP(list); list = CDR(list))
637	    (void)EVAL(CAR(list));
638
639	/* Error checking already done in the initialization */
640	for (list = init, cons = values; CONSP(list); list = CDR(list)) {
641	    symbol = CAR(list);
642	    if (CONSP(symbol)) {
643		value = CDDR(symbol);
644		symbol = CAR(symbol);
645		if (CONSP(value))
646		    value = EVAL(CAR(value));
647		else
648		    value = NIL;
649	    }
650	    else
651		value = NIL;
652
653	    if (refs)
654		LispSetVar(symbol, value);
655	    else {
656		RPLACA(cons, value);
657		cons = CDR(cons);
658	    }
659	}
660	if (!refs) {
661	    for (list = init, cons = values;
662		 CONSP(list);
663		 list = CDR(list), cons = CDR(cons)) {
664		symbol = CAR(list);
665		if (CONSP(symbol)) {
666		    if (CONSP(CDR(symbol)))
667			LispSetVar(CAR(symbol), CAR(cons));
668		}
669	    }
670	}
671    }
672
673    if (CONSP(CDR(test)))
674	value = EVAL(CADR(test));
675    else
676	value = NIL;
677
678    /* Restore state */
679    lisp__data.stack.length = stack;
680    lisp__data.env.lex = lex;
681    lisp__data.env.head = lisp__data.env.length = head;
682    GC_LEAVE();
683
684    return (value);
685}
686
687LispObj *
688LispDo(LispBuiltin *builtin, int refs)
689/*
690 do init test &rest body
691 do* init test &rest body
692 */
693{
694    int jumped;
695    LispObj *result;
696    LispBlock *block;
697
698    jumped = 1;
699    result = NIL;
700    block = LispBeginBlock(NIL, LispBlockTag);
701    if (setjmp(block->jmp) == 0) {
702	result = LispReallyDo(builtin, refs);
703	jumped = 0;
704    }
705    LispEndBlock(block);
706    if (jumped)
707	result = lisp__data.block.block_ret;
708
709    return (result);
710}
711
712static LispObj *
713LispReallyDoListTimes(LispBuiltin *builtin, int times)
714/*
715 dolist init &rest body
716 dotimes init &rest body
717 */
718{
719    GC_ENTER();
720    int head = lisp__data.env.length;
721    long count = 0, end = 0;
722    LispObj *symbol, *value = NIL, *result = NIL, *init, *body, *object;
723
724    body = ARGUMENT(1);
725    init = ARGUMENT(0);
726
727    /* Parse arguments */
728    CHECK_CONS(init);
729    symbol = CAR(init);
730    CHECK_SYMBOL(symbol);
731    init = CDR(init);
732
733    if (init == NIL) {
734	if (times)
735	    LispDestroy("%s: NIL is not a number", STRFUN(builtin));
736    }
737    else {
738	CHECK_CONS(init);
739	value = CAR(init);
740	init = CDR(init);
741	if (init != NIL) {
742	    CHECK_CONS(init);
743	    result = CAR(init);
744	}
745
746	value = EVAL(value);
747
748	if (times) {
749	    CHECK_INDEX(value);
750	    end = FIXNUM_VALUE(value);
751	}
752	else {
753	    CHECK_LIST(value);
754	    /* Protect iteration control from gc */
755	    GC_PROTECT(value);
756	}
757    }
758
759    /* The variable is only bound inside the loop, so it is safe to optimize
760     * it out if there is no code to execute. But the result form may reference
761     * the bound variable. */
762    if (!CONSP(body)) {
763	if (times)
764	    count = end;
765	else
766	    value = NIL;
767    }
768
769    /* Initialize counter */
770    CHECK_CONSTANT(symbol);
771    if (times)
772	LispAddVar(symbol, FIXNUM(count));
773    else
774	LispAddVar(symbol, CONSP(value) ? CAR(value) : value);
775    ++lisp__data.env.head;
776
777    if (!CONSP(body) || (times && count >= end) || (!times && !CONSP(value)))
778	goto loop_done;
779
780    /* Execute iterations */
781    for (;;) {
782	for (object = body; CONSP(object); object = CDR(object))
783	    (void)EVAL(CAR(object));
784
785	/* Update symbols and check exit condition */
786	if (times) {
787	    ++count;
788	    LispSetVar(symbol, FIXNUM(count));
789	    if (count >= end)
790		break;
791	}
792	else {
793	    value = CDR(value);
794	    if (!CONSP(value)) {
795		LispSetVar(symbol, NIL);
796		break;
797	    }
798	    LispSetVar(symbol, CAR(value));
799	}
800    }
801
802loop_done:
803    result = EVAL(result);
804    lisp__data.env.head = lisp__data.env.length = head;
805    GC_LEAVE();
806
807    return (result);
808}
809
810LispObj *
811LispDoListTimes(LispBuiltin *builtin, int times)
812/*
813 dolist init &rest body
814 dotimes init &rest body
815 */
816{
817    int did_jump, *pdid_jump = &did_jump;
818    LispObj *result, **presult = &result;
819    LispBlock *block;
820
821    *presult = NIL;
822    *pdid_jump = 1;
823    block = LispBeginBlock(NIL, LispBlockTag);
824    if (setjmp(block->jmp) == 0) {
825	result = LispReallyDoListTimes(builtin, times);
826	did_jump = 0;
827    }
828    LispEndBlock(block);
829    if (did_jump)
830	result = lisp__data.block.block_ret;
831
832    return (result);
833}
834
835LispObj *
836LispLoadFile(LispObj *filename, int verbose, int print, int ifdoesnotexist)
837{
838    LispObj *stream, *cod, *obj, *result;
839    int ch;
840
841    LispObj *savepackage;
842    LispPackage *savepack;
843
844    if (verbose)
845	LispMessage("; Loading %s", THESTR(filename));
846
847    if (ifdoesnotexist) {
848	GC_ENTER();
849	result = CONS(filename, CONS(Kif_does_not_exist, CONS(Kerror, NIL)));
850	GC_PROTECT(result);
851	stream = APPLY(Oopen, result);
852	GC_LEAVE();
853    }
854    else
855	stream = APPLY1(Oopen, filename);
856
857    if (stream == NIL)
858	return (NIL);
859
860    result = NIL;
861    LispPushInput(stream);
862    ch = LispGet();
863    if (ch != '#')
864	LispUnget(ch);
865    else if ((ch = LispGet()) == '!') {
866	for (;;) {
867	    ch = LispGet();
868	    if (ch == '\n' || ch == EOF)
869		break;
870	}
871    }
872    else {
873	LispUnget(ch);
874	LispUnget('#');
875    }
876
877    /* Save package environment */
878    savepackage = PACKAGE;
879    savepack = lisp__data.pack;
880
881    cod = COD;
882
883    /*CONSTCOND*/
884    while (1) {
885	if ((obj = LispRead()) != NULL) {
886	    result = EVAL(obj);
887	    COD = cod;
888	    if (print) {
889		int i;
890
891		if (RETURN_COUNT >= 0)
892		    LispPrint(result, NIL, 1);
893		for (i = 0; i < RETURN_COUNT; i++)
894		    LispPrint(RETURN(i), NIL, 1);
895	    }
896	}
897	if (lisp__data.eof)
898	    break;
899    }
900    LispPopInput(stream);
901
902    /* Restore package environment */
903    PACKAGE = savepackage;
904    lisp__data.pack = savepack;
905
906    APPLY1(Oclose, stream);
907
908    return (T);
909}
910
911void
912LispGetStringArgs(LispBuiltin *builtin,
913		  char **string1, char **string2,
914		  long *start1, long *end1, long *start2, long *end2)
915{
916    long length1, length2;
917    LispObj *ostring1, *ostring2, *ostart1, *oend1, *ostart2, *oend2;
918
919    oend2 = ARGUMENT(5);
920    ostart2 = ARGUMENT(4);
921    oend1 = ARGUMENT(3);
922    ostart1 = ARGUMENT(2);
923    ostring2 = ARGUMENT(1);
924    ostring1 = ARGUMENT(0);
925
926    CHECK_STRING(ostring1);
927    *string1 = THESTR(ostring1);
928    length1 = STRLEN(ostring1);
929
930    CHECK_STRING(ostring2);
931    *string2 = THESTR(ostring2);
932    length2 = STRLEN(ostring2);
933
934    if (ostart1 == UNSPEC)
935	*start1 = 0;
936    else {
937	CHECK_INDEX(ostart1);
938	*start1 = FIXNUM_VALUE(ostart1);
939    }
940    if (oend1 == UNSPEC)
941	*end1 = length1;
942    else {
943	CHECK_INDEX(oend1);
944	*end1 = FIXNUM_VALUE(oend1);
945    }
946
947    if (ostart2 == UNSPEC)
948	*start2 = 0;
949    else {
950	CHECK_INDEX(ostart2);
951	*start2 = FIXNUM_VALUE(ostart2);
952    }
953
954    if (oend2 == UNSPEC)
955	*end2 = length2;
956    else {
957	CHECK_INDEX(oend2);
958	*end2 = FIXNUM_VALUE(oend2);
959    }
960
961    if (*start1 > *end1)
962	LispDestroy("%s: :START1 %ld larger than :END1 %ld",
963		    STRFUN(builtin), *start1, *end1);
964    if (*start2 > *end2)
965	LispDestroy("%s: :START2 %ld larger than :END2 %ld",
966		    STRFUN(builtin), *start2, *end2);
967    if (*end1 > length1)
968	LispDestroy("%s: :END1 %ld larger than string length %ld",
969		    STRFUN(builtin), *end1, length1);
970    if (*end2 > length2)
971	LispDestroy("%s: :END2 %ld larger than string length %ld",
972		    STRFUN(builtin), *end2, length2);
973}
974
975LispObj *
976LispPathnameField(int field, int string)
977{
978    int offset = field;
979    LispObj *pathname, *result, *object;
980
981    pathname = ARGUMENT(0);
982
983    if (!PATHNAMEP(pathname))
984	pathname = APPLY1(Oparse_namestring, pathname);
985
986    result = pathname->data.pathname;
987    while (offset) {
988	result = CDR(result);
989	--offset;
990    }
991    object = result;
992    result = CAR(result);
993
994    if (string) {
995	if (!STRINGP(result)) {
996	    if (result == NIL)
997		result = STRING("");
998	    else if (field == PATH_DIRECTORY) {
999		char *name = THESTR(CAR(pathname->data.pathname)), *ptr;
1000
1001		ptr = strrchr(name, PATH_SEP);
1002		if (ptr) {
1003		    int length = ptr - name + 1;
1004		    char data[PATH_MAX];
1005
1006		    if (length > PATH_MAX - 1)
1007			length = PATH_MAX - 1;
1008		    strncpy(data, name, length);
1009		    data[length] = '\0';
1010		    result = STRING(data);
1011		}
1012		else
1013		    result = STRING("");
1014	    }
1015	    else
1016		result = Kunspecific;
1017	}
1018	else if (field == PATH_NAME) {
1019	    object = CAR(CDR(object));
1020	    if (STRINGP(object)) {
1021		int length;
1022		char name[PATH_MAX + 1];
1023
1024		strcpy(name, THESTR(result));
1025		length = STRLEN(result);
1026		if (length + 1 < sizeof(name)) {
1027		    name[length++] = PATH_TYPESEP;
1028		    name[length] = '\0';
1029		}
1030		if (STRLEN(object) + length < sizeof(name))
1031		    strcpy(name + length, THESTR(object));
1032		/* else LispDestroy ... */
1033		result = STRING(name);
1034	    }
1035	}
1036    }
1037
1038    return (result);
1039}
1040
1041LispObj *
1042LispProbeFile(LispBuiltin *builtin, int probe)
1043{
1044    GC_ENTER();
1045    LispObj *result;
1046    char *name = NULL, resolved[PATH_MAX + 1];
1047    struct stat st;
1048
1049    LispObj *pathname;
1050
1051    pathname = ARGUMENT(0);
1052
1053    if (!POINTERP(pathname))
1054	goto bad_pathname;
1055
1056    if (XSTRINGP(pathname))
1057	name = THESTR(pathname);
1058    else if (XPATHNAMEP(pathname))
1059	name = THESTR(CAR(pathname->data.pathname));
1060    else if (STREAMP(pathname) && pathname->data.stream.type == LispStreamFile)
1061	name = THESTR(CAR(pathname->data.stream.pathname->data.pathname));
1062
1063    if (realpath(name, &resolved[0]) == NULL ||
1064	stat(resolved, &st)) {
1065	if (probe)
1066	    return (NIL);
1067	LispDestroy("%s: realpath(\"%s\"): %s",
1068		    STRFUN(builtin), name, strerror(errno));
1069    }
1070
1071    if (S_ISDIR(st.st_mode)) {
1072	int length = strlen(resolved);
1073
1074	if (!length || resolved[length - 1] != PATH_SEP) {
1075	    resolved[length++] = PATH_SEP;
1076	    resolved[length] = '\0';
1077	}
1078    }
1079
1080    result = STRING(resolved);
1081    GC_PROTECT(result);
1082    result = APPLY1(Oparse_namestring, result);
1083    GC_LEAVE();
1084
1085    return (result);
1086
1087bad_pathname:
1088    LispDestroy("%s: bad pathname %s", STRFUN(builtin), STROBJ(pathname));
1089    /*NOTREACHED*/
1090    return (NIL);
1091}
1092
1093LispObj *
1094LispWriteString_(LispBuiltin *builtin, int newline)
1095/*
1096 write-line string &optional output-stream &key start end
1097 write-string string &optional output-stream &key start end
1098 */
1099{
1100    char *text;
1101    long start, end, length;
1102
1103    LispObj *string, *output_stream, *ostart, *oend;
1104
1105    oend = ARGUMENT(3);
1106    ostart = ARGUMENT(2);
1107    output_stream = ARGUMENT(1);
1108    string = ARGUMENT(0);
1109
1110    CHECK_STRING(string);
1111    LispCheckSequenceStartEnd(builtin, string, ostart, oend,
1112			      &start, &end, &length);
1113    if (output_stream == UNSPEC)
1114	output_stream = NIL;
1115    text = THESTR(string);
1116    if (end > start)
1117	LispWriteStr(output_stream, text + start, end - start);
1118    if (newline)
1119	LispWriteChar(output_stream, '\n');
1120
1121    return (string);
1122}
1123