/* Copyright 2009-2014
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
*
* BSD License:
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in
* the documentation and/or other materials provided with the
* distribution.
* 3. The name of the author may not be used to endorse or promote
* products derived from this software without specific prior
* written permission.
*
* THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
* IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <wctype.h>
#include <limits.h>
#include <stdarg.h>
#include <dirent.h>
#include <setjmp.h>
#include <errno.h>
#include <wchar.h>
#include <math.h>
#include <time.h>
#include <signal.h>
#include <sys/time.h>
#include <assert.h>
#include "config.h"
#ifdef HAVE_GETENVIRONMENTSTRINGS
#define NOMINMAX
#include <windows.h>
#endif
#include "lib.h"
#include "gc.h"
#include "arith.h"
#include "rand.h"
#include "hash.h"
#include "signal.h"
#include "unwind.h"
#include "stream.h"
#include "utf8.h"
#include "filter.h"
#include "eval.h"
#include "regex.h"
#define max(a, b) ((a) > (b) ? (a) : (b))
#define min(a, b) ((a) < (b) ? (a) : (b))
#if !HAVE_POSIX_SIGS
int async_sig_enabled = 0;
#endif
val packages;
val system_package_var, keyword_package_var, user_package_var;
val system_package_s, keyword_package_s, user_package_s;
val null_s, t, cons_s, str_s, chr_s, fixnum_s, sym_s, pkg_s, fun_s, vec_s;
val lit_s, stream_s, hash_s, hash_iter_s, lcons_s, lstr_s, cobj_s, cptr_s;
val env_s, bignum_s, float_s;
val var_s, expr_s, regex_s, chset_s, set_s, cset_s, wild_s, oneplus_s;
val nongreedy_s, compiled_regex_s;
val quote_s, qquote_s, unquote_s, splice_s;
val sys_qquote_s, sys_unquote_s, sys_splice_s;
val zeroplus_s, optional_s, compl_s, compound_s, or_s, and_s, quasi_s;
val skip_s, trailer_s, block_s, next_s, freeform_s, fail_s, accept_s;
val all_s, some_s, none_s, maybe_s, cases_s, collect_s, until_s, coll_s;
val define_s, output_s, single_s, first_s, last_s, empty_s;
val repeat_s, rep_s, flatten_s, forget_s;
val local_s, merge_s, bind_s, rebind_s, cat_s;
val try_s, catch_s, finally_s, throw_s, defex_s, deffilter_s;
val eof_s, eol_s, assert_s;
val error_s, type_error_s, internal_error_s;
val numeric_error_s, range_error_s;
val query_error_s, file_error_s, process_error_s;
val gensym_counter_s;
val nothrow_k, args_k, colon_k, auto_k;
val null_string;
val nil_string;
val null_list;
val identity_f, equal_f, eql_f, eq_f, car_f, cdr_f, null_f;
val prog_string;
static val env_list;
mem_t *(*oom_realloc)(mem_t *, size_t);
val identity(val obj)
{
return obj;
}
static val code2type(int code)
{
switch ((type_t) code) {
case NIL: return null_s;
case CONS: return cons_s;
case STR: return str_s;
case LIT: return lit_s;
case CHR: return chr_s;
case NUM: return fixnum_s;
case SYM: return sym_s;
case PKG: return pkg_s;
case FUN: return fun_s;
case VEC: return vec_s;
case LCONS: return lcons_s;
case LSTR: return lstr_s;
case COBJ: return cobj_s;
case ENV: return env_s;
case BGNUM: return bignum_s;
case FLNUM: return float_s;
}
return nil;
}
val typeof(val obj)
{
switch (tag(obj)) {
case TAG_NUM:
return fixnum_s;
case TAG_CHR:
return chr_s;
case TAG_LIT:
return lit_s;
case TAG_PTR:
{
int typecode = type(obj);
if (typecode == COBJ) {
return obj->co.cls;
} else {
val typesym = code2type(typecode);
if (!typesym)
internal_error("corrupt type field");
return typesym;
}
}
default:
internal_error("invalid type tag");
}
}
val type_check(val obj, int typecode)
{
if (type(obj) != typecode)
type_mismatch(lit("~s is not of type ~s"), obj, code2type(typecode), nao);
return t;
}
val type_check2(val obj, int t1, int t2)
{
if (!is_ptr(obj) || (obj->t.type != t1 && obj->t.type != t2))
type_mismatch(lit("~s is not of type ~s or ~s"), obj,
code2type(t1), code2type(t2), nao);
return t;
}
val type_check3(val obj, int t1, int t2, int t3)
{
if (!is_ptr(obj) || (obj->t.type != t1 && obj->t.type != t2
&& obj->t.type != t3))
type_mismatch(lit("~s is not of type ~s, ~s nor ~s"), obj,
code2type(t1), code2type(t2), code2type(t3), nao);
return t;
}
val class_check(val cobj, val class_sym)
{
type_assert (is_ptr(cobj) && cobj->t.type == COBJ &&
cobj->co.cls == class_sym,
(lit("~a is not of type ~a"), cobj, class_sym, nao));
return t;
}
val car(val cons)
{
switch (type(cons)) {
case NIL:
return nil;
case CONS:
return cons->c.car;
case LCONS:
if (cons->lc.func == nil) {
return cons->lc.car;
} else {
funcall1(cons->lc.func, cons);
cons->lc.func = nil;
return cons->lc.car;
}
case VEC:
if (zerop(cons->v.vec[vec_length]))
return nil;
return cons->v.vec[0];
case STR:
case LIT:
case LSTR:
if (zerop(length_str(cons)))
return nil;
return chr_str(cons, zero);
default:
type_mismatch(lit("~s is not a cons"), cons, nao);
}
}
val cdr(val cons)
{
switch (type(cons)) {
case NIL:
return nil;
case CONS:
return cons->c.cdr;
case LCONS:
if (cons->lc.func == nil) {
return cons->lc.cdr;
} else {
funcall1(cons->lc.func, cons);
cons->lc.func = nil;
return cons->lc.cdr;
}
case VEC:
case STR:
case LIT:
case LSTR:
if (le(length(cons), one))
return nil;
return sub(cons, one, t);
default:
type_mismatch(lit("~s is not a cons"), cons, nao);
}
}
val rplaca(val cons, val new_car)
{
switch (type(cons)) {
case CONS:
return set(cons->c.car, new_car);
case LCONS:
return set(cons->lc.car, new_car);
default:
type_mismatch(lit("~s is not a cons"), cons, nao);
}
}
val rplacd(val cons, val new_cdr)
{
switch (type(cons)) {
case CONS:
return set(cons->c.cdr, new_cdr);
case LCONS:
return set(cons->lc.cdr, new_cdr);
default:
type_mismatch(lit("~s is not a cons"), cons, nao);
}
}
val *car_l(val cons)
{
switch (type(cons)) {
case CONS:
return &cons->c.car;
case LCONS:
if (cons->lc.func) {
funcall1(cons->lc.func, cons);
cons->lc.func = nil;
}
return &cons->lc.car;
default:
type_mismatch(lit("~s is not a cons"), cons, nao);
}
}
val *cdr_l(val cons)
{
switch (type(cons)) {
case CONS:
return &cons->c.cdr;
case LCONS:
if (cons->lc.func) {
funcall1(cons->lc.func, cons);
cons->lc.func = nil;
}
return &cons->lc.cdr;
default:
type_mismatch(lit("~s is not a cons"), cons, nao);
}
}
val first(val cons)
{
return car(cons);
}
val rest(val cons)
{
return cdr(cons);
}
val second(val cons)
{
return car(cdr(cons));
}
val third(val cons)
{
return car(cdr(cdr(cons)));
}
val fourth(val cons)
{
return car(cdr(cdr(cdr(cons))));
}
val fifth(val cons)
{
return car(cdr(cdr(cdr(cdr(cons)))));
}
val sixth(val cons)
{
return car(cdr(cdr(cdr(cdr(cdr(cons))))));
}
val conses(val list)
{
list_collect_decl (out, ptail);
for (; consp(list); list = cdr(list))
ptail = list_collect(ptail, list);
return out;
}
static val lazy_conses_func(val env, val lcons)
{
val fun = lcons_fun(lcons);
rplaca(lcons, env);
func_set_env(fun, env = cdr(env));
if (env)
rplacd(lcons, make_lazy_cons(fun));
else
rplacd(lcons, nil);
return nil;
}
val lazy_conses(val list)
{
if (!list)
return nil;
return make_lazy_cons(func_f1(list, lazy_conses_func));
}
val listref(val list, val ind)
{
if (lt(ind, zero))
ind = plus(ind, length_list(list));
for (; gt(ind, zero); ind = minus(ind, one))
list = cdr(list);
return car(list);
}
val *listref_l(val list, val ind)
{
val olist = list;
val oind = ind;
if (lt(ind, zero))
ind = plus(ind, length_list(list));
for (; gt(ind, zero) && list; ind = minus(ind, one))
list = cdr(list);
if (consp(list))
return car_l(list);
uw_throwf(error_s, lit("~s has no assignable location at ~s"),
olist, oind, nao);
}
val *tail(val cons)
{
while (cdr(cons))
cons = cdr(cons);
return cdr_l(cons);
}
val *lastcons(val list)
{
val *ret = 0;
while (consp(cdr(list))) {
ret = cdr_l(list);
list = cdr(list);
}
return ret;
}
val *ltail(val *cons)
{
while (cdr(*cons))
cons = cdr_l(*cons);
return cons;
}
val pop(val *plist)
{
val ret = car(*plist);
*plist = cdr(*plist);
return ret;
}
val upop(val *plist, val *pundo)
{
*pundo = *plist;
return pop(plist);
}
val push(val value, val *plist)
{
/* Unsafe for mutating object fields: use mpush macro. */
return *plist = cons(value, *plist);
}
val copy_list(val list)
{
list_collect_decl (out, ptail);
while (consp(list)) {
ptail = list_collect(ptail, car(list));
list = cdr(list);
}
ptail = list_collect_nconc(ptail, list);
return out;
}
val make_like(val list, val thatobj)
{
if (list != thatobj) {
switch (type(thatobj)) {
case VEC:
return vector_list(list);
case STR:
case LIT:
case LSTR:
if (is_chr(car(list)))
return cat_str(list, nil);
break;
case NIL:
case CONS:
case LCONS:
default:
break;
}
}
return list;
}
val to_seq(val seq)
{
switch (type(seq)) {
case VEC:
case STR:
case LIT:
case LSTR:
case NIL:
case CONS:
case LCONS:
return seq;
default:
return cons(seq, nil);
}
}
val tolist(val seq)
{
switch (type(seq)) {
case VEC:
return list_vector(seq);
case STR:
case LIT:
case LSTR:
return list_str(seq);
case NIL:
case CONS:
case LCONS:
default:
return seq;
}
}
val *list_collect(val *ptail, val obj)
{
switch (type(*ptail)) {
case NIL:
set(*ptail, cons(obj, nil));
return ptail;
case CONS:
case LCONS:
ptail = tail(*ptail);
set(*ptail, cons(obj, nil));
return ptail;
case VEC:
replace_vec(*ptail, cons(obj, nil), t, t);
return ptail;
case STR:
case LIT:
case LSTR:
replace_str(*ptail, cons(obj, nil), t, t);
return ptail;
default:
uw_throwf(error_s, lit("cannot append ~s to ~s"), obj, *ptail, nao);
}
}
val *list_collect_nconc(val *ptail, val obj)
{
switch (type(*ptail)) {
case NIL:
set(*ptail, obj);
return ptail;
case CONS:
case LCONS:
ptail = tail(*ptail);
set(*ptail, obj);
return ptail;
case VEC:
replace_vec(*ptail, obj, t, t);
return ptail;
case STR:
case LIT:
case LSTR:
replace_str(*ptail, obj, t, t);
return ptail;
default:
uw_throwf(error_s, lit("cannot nconc ~s to ~s"), obj, *ptail, nao);
}
}
val *list_collect_append(val *ptail, val obj)
{
switch (type(*ptail)) {
case NIL:
set(*ptail, obj);
return ptail;
case CONS:
case LCONS:
set(*ptail, copy_list(*ptail));
ptail = tail(*ptail);
set(*ptail, obj);
return ptail;
case VEC:
set(*ptail, copy_vec(*ptail));
replace_vec(*ptail, obj, t, t);
return ptail;
case STR:
case LIT:
case LSTR:
set(*ptail, copy_str(*ptail));
replace_str(*ptail, obj, t, t);
return ptail;
default:
uw_throwf(error_s, lit("cannot append ~s to ~s"), obj, *ptail, nao);
}
}
val nreverse(val in)
{
val rev = nil;
while (in) {
val temp = cdr(in);
*cdr_l(in) = rev;
rev = in;
in = temp;
}
return rev;
}
val reverse(val in)
{
val in_orig = in;
val rev = nil;
while (in) {
rev = cons(car(in), rev);
in = cdr(in);
}
return make_like(rev, in_orig);
}
val append2(val list1, val list2)
{
list_collect_decl (out, ptail);
ptail = list_collect_append (ptail, list1);
ptail = list_collect_append (ptail, list2);
return out;
}
val appendv(val lists)
{
list_collect_decl (out, ptail);
for (; lists; lists = cdr(lists)) {
val item = car(lists);
ptail = list_collect_append(ptail, item);
}
return out;
}
val nappend2(val list1, val list2)
{
list_collect_decl (out, ptail);
ptail = list_collect_nconc (ptail, list1);
ptail = list_collect_nconc (ptail, list2);
return out;
}
val sub_list(val list, val from, val to)
{
val len = nil;
if (!list)
return nil;
if (null_or_missing_p(from))
from = zero;
else if (from == t)
from = nil;
else if (lt(from, zero)) {
from = plus(from, len = length(list));
if (to == zero)
to = nil;
}
if (to == t || null_or_missing_p(to))
to = nil;
else if (!null_or_missing_p(to) && lt(to, zero))
to = plus(to, if3(len, len, len = length(list)));
if (to && from && gt(from, to)) {
return nil;
} else if (!to || (len && ge(to, len))) {
val iter, i;
for (i = zero, iter = list; iter; iter = cdr(iter), i = plus(i, one)) {
if (from && ge(i, from))
break;
}
return iter;
} else {
val iter, i;
list_collect_decl (out, ptail);
for (i = zero, iter = list; iter; iter = cdr(iter), i = plus(i, one)) {
if (ge(i, to))
break;
if (from && ge(i, from))
ptail = list_collect(ptail, car(iter));
}
return out;
}
}
val replace_list(val list, val items, val from, val to)
{
val len = nil;
if (vectorp(items))
items = list_vector(items);
else if (stringp(items))
items = list_str(items);
else if (!listp(items))
uw_throwf(error_s, lit("replace-list: cannot replace with ~s"), items, nao);
if (!list)
return items;
if (null_or_missing_p(from))
from = zero;
else if (from == t)
from = nil;
else if (lt(from, zero)) {
from = plus(from, len ? len : (len = length(list)));
if (to == zero)
to = len;
}
if (to == t || null_or_missing_p(to))
to = nil;
if (to && lt(to, zero))
to = plus(to, len ? len : (len = length(list)));
if (!to || (len && ge(to, len))) {
if (from && zerop(from)) {
return (listp(items)) ? items : list_vector(items);
} else {
val iter, i;
list_collect_decl (out, ptail);
for (i = zero, iter = list; iter; iter = cdr(iter), i = plus(i, one)) {
if (from && ge(i, from))
break;
ptail = list_collect(ptail, car(iter));
}
ptail = list_collect_nconc(ptail, if3(listp(items),
items, list_vector(items)));
return out;
}
} else {
val iter, i;
list_collect_decl (out, ptail);
for (i = zero, iter = list; iter; iter = cdr(iter), i = plus(i, one)) {
if (ge(i, to))
break;
if (from && lt(i, from))
ptail = list_collect(ptail, car(iter));
}
ptail = list_collect_nconc(ptail, append2(if3(listp(items), items,
list_vector(items)),
iter));
return out;
}
}
static val lazy_appendv_func(val env, val lcons)
{
cons_bind (last, lists, env);
val nonempty = nil;
while (lists) {
nonempty = pop(&lists);
if (nonempty)
break;
}
rplaca(lcons, last);
if (atom(nonempty)) {
rplacd(lcons, nonempty);
return nil;
}
rplacd(env, lists);
{
val *ptail = ltail(&nonempty);
rplaca(env, car(*ptail));
*ptail = make_lazy_cons(lcons_fun(lcons));
rplacd(lcons, nonempty);
}
return nil;
}
val lazy_appendv(val lists)
{
val nonempty = nil;
while (lists) {
nonempty = pop(&lists);
if (nonempty)
break;
}
if (atom(nonempty))
return nonempty;
{
val *ptail = ltail(&nonempty);
*ptail = make_lazy_cons(func_f1(cons(car(*ptail), lists),
lazy_appendv_func));
return nonempty;
}
}
val ldiff(val list1, val list2)
{
list_collect_decl (out, ptail);
switch (type(list2)) {
case STR:
case LIT:
case LSTR:
case VEC:
while (list1 && !equal(list1, list2)) {
ptail = list_collect(ptail, car(list1));
list1 = cdr(list1);
}
break;
default:
while (list1 && list1 != list2) {
ptail = list_collect(ptail, car(list1));
list1 = cdr(list1);
}
break;
}
return out;
}
val memq(val obj, val list)
{
while (list && car(list) != obj)
list = cdr(list);
return list;
}
val memql(val obj, val list)
{
while (list && !eql(car(list), obj))
list = cdr(list);
return list;
}
val memqual(val obj, val list)
{
while (list && !equal(car(list), obj))
list = cdr(list);
return list;
}
val remq(val obj, val list)
{
list_collect_decl (out, ptail);
val list_orig = list;
val lastmatch = cons(nil, list);
for (; list; list = cdr(list)) {
if (car(list) == obj) {
ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
lastmatch = list;
}
}
ptail = list_collect_nconc(ptail, cdr(lastmatch));
return make_like(out, list_orig);
}
val remql(val obj, val list)
{
list_collect_decl (out, ptail);
val list_orig = list;
val lastmatch = cons(nil, list);
for (; list; list = cdr(list)) {
if (eql(car(list), obj)) {
ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
lastmatch = list;
}
}
ptail = list_collect_nconc(ptail, cdr(lastmatch));
return make_like(out, list_orig);
}
val remqual(val obj, val list)
{
list_collect_decl (out, ptail);
val list_orig = list;
val lastmatch = cons(nil, list);
for (; list; list = cdr(list)) {
if (equal(car(list), obj)) {
ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
lastmatch = list;
}
}
ptail = list_collect_nconc(ptail, cdr(lastmatch));
return make_like(out, list_orig);
}
val remove_if(val pred, val list, val key)
{
list_collect_decl (out, ptail);
val list_orig = list;
val lastmatch = cons(nil, list);
key = default_arg(key, identity_f);
for (; list; list = cdr(list)) {
val subj = funcall1(key, car(list));
val satisfies = funcall1(pred, subj);
if (satisfies) {
ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
lastmatch = list;
}
}
ptail = list_collect_nconc(ptail, cdr(lastmatch));
return make_like(out, list_orig);
}
val keep_if(val pred, val list, val key)
{
list_collect_decl (out, ptail);
val list_orig = list;
val lastmatch = cons(nil, list);
key = default_arg(key, identity_f);
for (; list; list = cdr(list)) {
val subj = funcall1(key, car(list));
val satisfies = funcall1(pred, subj);
if (!satisfies) {
ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
lastmatch = list;
}
}
ptail = list_collect_nconc(ptail, cdr(lastmatch));
return make_like(out, list_orig);
}
static val rem_lazy_rec(val obj, val list, val env, val func);
static val rem_lazy_func(val env, val lcons)
{
cons_bind (pred, list, env);
return rplacd(lcons, rem_lazy_rec(pred, list, env, lcons_fun(lcons)));
}
static val rem_lazy_rec(val pred, val list, val env, val func)
{
while (list && funcall1(pred, car(list)))
list = cdr(list);
if (!list)
return nil;
if (!env)
func = func_f1(cons(pred, cdr(list)), rem_lazy_func);
else
rplacd(env, cdr(list));
return make_half_lazy_cons(func, car(list));
}
val remq_lazy(val obj, val list)
{
return rem_lazy_rec(curry_12_1(eq_f, obj), list, nil, nil);
}
val remql_lazy(val obj, val list)
{
return rem_lazy_rec(curry_12_1(eql_f, obj), list, nil, nil);
}
val remqual_lazy(val obj, val list)
{
return rem_lazy_rec(curry_12_1(equal_f, obj), list, nil, nil);
}
val remove_if_lazy(val pred, val list, val key)
{
val pred_key = chain(default_arg(key, identity_f), pred, nao);
return rem_lazy_rec(pred_key, list, nil, nil);
}
val keep_if_lazy(val pred, val list, val key)
{
val pred_key = chain(default_arg(key, identity_f), pred, null_f, nao);
return rem_lazy_rec(pred_key, list, nil, nil);
}
val tree_find(val obj, val tree, val testfun)
{
if (funcall2(default_arg(testfun, equal_f), obj, tree))
return t;
else if (consp(tree))
return some_satisfy(tree, curry_123_2(func_n3(tree_find),
obj, testfun), nil);
return nil;
}
val countqual(val obj, val list)
{
val count = zero;
for (; list; list = cdr(list))
if (equal(car(list), obj))
count = plus(count, one);
return count;
}
val countql(val obj, val list)
{
val count = zero;
for (; list; list = cdr(list))
if (eql(car(list), obj))
count = plus(count, one);
return count;
}
val countq(val obj, val list)
{
val count = zero;
for (; list; list = cdr(list))
if (car(list) == obj)
count = plus(count, one);
return count;
}
val count_if(val pred, val list, val key)
{
val count = zero;
key = default_arg(key, identity_f);
for (; list; list = cdr(list)) {
val subj = funcall1(key, car(list));
val satisfies = funcall1(pred, subj);
if (satisfies)
count = plus(count, one);
}
return count;
}
val some_satisfy(val list, val pred, val key)
{
pred = default_arg(pred, identity_f);
key = default_arg(key, identity_f);
for (; list; list = cdr(list)) {
val item;
if ((item = funcall1(pred, funcall1(key, car(list)))) != nil)
return item;
}
return nil;
}
val all_satisfy(val list, val pred, val key)
{
val item = t;
pred = default_arg(pred, identity_f);
key = default_arg(key, identity_f);
for (; list; list = cdr(list)) {
if ((item = funcall1(pred, funcall1(key, car(list)))) == nil)
return nil;
}
return item;
}
val none_satisfy(val list, val pred, val key)
{
pred = default_arg(pred, identity_f);
key = default_arg(key, identity_f);
for (; list; list = cdr(list)) {
if (funcall1(pred, funcall1(key, car(list))))
return nil;
}
return t;
}
val flatten(val list)
{
if (list == nil)
return nil;
if (atom(list))
return cons(list, nil);
return mappend(func_n1(flatten), list);
}
/*
* Return the embedded list whose car is the non-nil atom in the given nested
* list, updating the escape stack in the process. If no such atom is found in
* the list, try to retreate up the stack to find it in the surrounding
* structure, finally returning nil if nothing is found.
*/
static val lazy_flatten_scan(val list, val *escape)
{
for (;;) {
if (list) {
val a = car(list);
if (nilp(a)) {
list = cdr(list);
} else if (atom(a)) {
return list;
} else do {
push(cdr(list), escape); /* safe mutation: *escape is a local var */
list = a;
a = car(list);
} while (consp(a));
return list;
} else if (*escape) {
list = pop(escape);
} else {
return nil;
}
}
}
static val lazy_flatten_func(val env, val lcons)
{
cons_bind (list, escape, env);
val atom = car(list);
val next = lazy_flatten_scan(cdr(list), &escape);
rplaca(lcons, atom);
rplaca(env, next);
rplacd(env, escape);
if (next)
rplacd(lcons, make_lazy_cons(lcons_fun(lcons)));
return nil;
}
val lazy_flatten(val list)
{
if (atom(list)) {
return cons(list, nil);
} else {
val escape = nil;
val next = lazy_flatten_scan(list, &escape);
if (!next)
return nil;
return make_lazy_cons(func_f1(cons(next, escape), lazy_flatten_func));
}
}
cnum c_num(val num);
val eql(val left, val right)
{
/* eql is same as eq for now, but when we get bignums,
eql will compare different bignum objects which are
the same number as equal. */
if (type(left) == BGNUM)
return equal(left, right);
return eq(left, right);
}
val equal(val left, val right)
{
if (left == right)
return t;
switch (type(left)) {
case NIL:
case CHR:
case NUM:
return nil;
case CONS:
case LCONS:
if ((type(right) == CONS || type(right) == LCONS) &&
equal(car(left), car(right)) &&
equal(cdr(left), cdr(right)))
{
return t;
}
return nil;
case LIT:
switch (type(right)) {
case LIT:
return wcscmp(litptr(left), litptr(right)) == 0 ? t : nil;
case STR:
return wcscmp(litptr(left), right->st.str) == 0 ? t : nil;
case LSTR:
lazy_str_force(right);
return equal(left, right->ls.prefix);
default:
break;
}
return nil;
case STR:
switch (type(right)) {
case LIT:
return wcscmp(left->st.str, litptr(right)) == 0 ? t : nil;
case STR:
return wcscmp(left->st.str, right->st.str) == 0 ? t : nil;
case LSTR:
lazy_str_force(right);
return equal(left, right->ls.prefix);
default:
break;
}
return nil;
case SYM:
case PKG:
case ENV:
return right == left ? t : nil;
case FUN:
if (type(right) == FUN &&
left->f.functype == right->f.functype &&
equal(left->f.env, right->f.env))
{
switch (left->f.functype) {
case FINTERP: return (equal(left->f.f.interp_fun, right->f.f.interp_fun));
case F0: return (left->f.f.f0 == right->f.f.f0) ? t : nil;
case F1: return (left->f.f.f1 == right->f.f.f1) ? t : nil;
case F2: return (left->f.f.f2 == right->f.f.f2) ? t : nil;
case F3: return (left->f.f.f3 == right->f.f.f3) ? t : nil;
case F4: return (left->f.f.f4 == right->f.f.f4) ? t : nil;
case N0: return (left->f.f.n0 == right->f.f.n0) ? t : nil;
case N1: return (left->f.f.n1 == right->f.f.n1) ? t : nil;
case N2: return (left->f.f.n2 == right->f.f.n2) ? t : nil;
case N3: return (left->f.f.n3 == right->f.f.n3) ? t : nil;
case N4: return (left->f.f.n4 == right->f.f.n4) ? t : nil;
case N5: return (left->f.f.n5 == right->f.f.n5) ? t : nil;
case N6: return (left->f.f.n6 == right->f.f.n6) ? t : nil;
case N7: return (left->f.f.n7 == right->f.f.n7) ? t : nil;
}
return nil;
}
return nil;
case VEC:
if (type(right) == VEC) {
cnum i, length;
if (!equal(left->v.vec[vec_length], right->v.vec[vec_length]))
return nil;
length = c_num(left->v.vec[vec_length]);
for (i = 0; i < length; i++) {
if (!equal(left->v.vec[i], right->v.vec[i]))
return nil;
}
return t;
}
return nil;
case LSTR:
switch (type(right)) {
case LIT:
case STR:
case LSTR:
lazy_str_force(left);
return equal(left->ls.prefix, right);
default:
break;
}
return nil;
case BGNUM:
if (type(right) == BGNUM && mp_cmp(mp(left), mp(right)) == MP_EQ)
return t;
return nil;
case FLNUM:
if (type(right) == FLNUM && left->fl.n == right->fl.n)
return t;
return nil;
case COBJ:
if (type(right) == COBJ)
return left->co.ops->equal(left, right);
return nil;
}
internal_error("unhandled case in equal function");
}
static mem_t *malloc_low_bound, *malloc_high_bound;
mem_t *chk_malloc(size_t size)
{
mem_t *ptr = (mem_t *) malloc(size);
assert (!async_sig_enabled);
if (size && ptr == 0)
ptr = (mem_t *) oom_realloc(0, size);
if (ptr < malloc_low_bound)
malloc_low_bound = ptr;
else if (ptr + size > malloc_high_bound)
malloc_high_bound = ptr + size;
return ptr;
}
mem_t *chk_calloc(size_t n, size_t size)
{
mem_t *ptr = (mem_t *) calloc(n, size);
assert (!async_sig_enabled);
if (size && ptr == 0) {
ptr = (mem_t *) oom_realloc(0, size);
memset(ptr, 0, n * size);
}
if (ptr < malloc_low_bound)
malloc_low_bound = ptr;
else if (ptr + size > malloc_high_bound)
malloc_high_bound = ptr + size;
return ptr;
}
mem_t *chk_realloc(mem_t *old, size_t size)
{
mem_t *newptr = (mem_t *) realloc(old, size);
assert (!async_sig_enabled);
if (size != 0 && newptr == 0)
newptr = oom_realloc(old, size);
if (newptr < malloc_low_bound)
malloc_low_bound = newptr;
else if (newptr + size > malloc_high_bound)
malloc_high_bound = newptr + size;
return newptr;
}
int in_malloc_range(mem_t *ptr)
{
return ptr >= malloc_low_bound && ptr < malloc_high_bound;
}
wchar_t *chk_strdup(const wchar_t *str)
{
size_t nchar = wcslen(str) + 1;
wchar_t *copy = (wchar_t *) chk_malloc(nchar * sizeof *copy);
assert (!async_sig_enabled);
wmemcpy(copy, str, nchar);
return copy;
}
val cons(val car, val cdr)
{
val obj = make_obj();
obj->c.type = CONS;
obj->c.car = car;
obj->c.cdr = cdr;
return obj;
}
val make_lazy_cons(val func)
{
val obj = make_obj();
obj->lc.type = LCONS;
obj->lc.car = obj->lc.cdr = nil;
obj->lc.func = func;
return obj;
}
val make_half_lazy_cons(val func, val car)
{
val obj = make_obj();
obj->lc.type = LCONS;
obj->lc.car = car;
obj->lc.cdr = nil;
obj->lc.func = func;
return obj;
}
val lcons_fun(val lcons)
{
type_check(lcons, LCONS);
return lcons->lc.func;
}
val list(val first, ...)
{
va_list vl;
val list = nil;
val array[32], *ptr = array;
if (first != nao) {
val next = first;
va_start (vl, first);
do {
*ptr++ = next;
if (ptr == array + 32)
internal_error("runaway arguments in list function");
next = va_arg(vl, val);
} while (next != nao);
va_end (vl);
while (ptr > array)
list = cons(*--ptr, list);
}
return list;
}
val consp(val obj)
{
type_t ty = type(obj);
return (ty == CONS || ty == LCONS) ? t : nil;
}
val atom(val obj)
{
return if3(consp(obj), nil, t);
}
val listp(val obj)
{
return if2(obj == nil || consp(obj), t);
}
val proper_listp(val obj)
{
while (consp(obj))
obj = cdr(obj);
return (obj == nil) ? t : nil;
}
val length_list(val list)
{
cnum len = 0;
while (consp(list)) {
len++;
list = cdr(list);
}
return num(len);
}
val getplist(val list, val key)
{
for (; list; list = cdr(cdr(list))) {
val ind = first(list);
if (ind == key)
return second(list);
}
return nil;
}
val getplist_f(val list, val key, val *found)
{
for (; list; list = cdr(cdr(list))) {
val ind = first(list);
if (ind == key) {
*found = t;
return second(list);
}
}
*found = nil;
return nil;
}
val proper_plist_to_alist(val list)
{
list_collect_decl (out, ptail);
for (; list; list = cdr(cdr(list))) {
val ind = first(list);
val prop = second(list);
ptail = list_collect(ptail, cons(ind, prop));
}
return out;
}
val improper_plist_to_alist(val list, val boolean_keys)
{
list_collect_decl (out, ptail);
for (; list; list = cdr(list)) {
val ind = first(list);
if (memqual(ind, boolean_keys)) {
ptail = list_collect(ptail, cons(ind, t));
} else {
val prop = second(list);
ptail = list_collect(ptail, cons(ind, prop));
list = cdr(list);
}
}
return out;
}
val num(cnum n)
{
if (n >= NUM_MIN && n <= NUM_MAX)
return (val) ((n << TAG_SHIFT) | TAG_NUM);
return bignum(n);
}
cnum c_num(val num)
{
switch (type(num)) {
case CHR: case NUM:
return ((cnum) num) >> TAG_SHIFT;
case BGNUM:
if (in_int_ptr_range(num)) {
int_ptr_t out;
mp_get_intptr(mp(num), &out);
return out;
}
uw_throwf(error_s, lit("~s is out of cnum range"), num, nao);
default:
type_mismatch(lit("~s is not an integer"), num, nao);
}
}
val flo(double n)
{
val obj = make_obj();
obj->fl.type = FLNUM;
obj->fl.n = n;
return obj;
}
double c_flo(val num)
{
type_check(num, FLNUM);
return num->fl.n;
}
val fixnump(val num)
{
return (is_num(num)) ? t : nil;
}
val bignump(val num)
{
return (type(num) == BGNUM) ? t : nil;
}
val integerp(val num)
{
switch (tag(num)) {
case TAG_NUM:
return t;
case TAG_PTR:
if (num == nil)
return nil;
if (num->t.type == BGNUM)
return t;
/* fallthrough */
default:
return nil;
}
}
val floatp(val num)
{
return (type(num) == FLNUM) ? t : nil;
}
val numberp(val num)
{
switch (tag(num)) {
case TAG_NUM:
return t;
case TAG_PTR:
if (num == nil)
return nil;
if (num->t.type == BGNUM || num->t.type == FLNUM)
return t;
/* fallthrough */
default:
return nil;
}
}
val plusv(val nlist)
{
if (!nlist)
return num(0);
else if (!cdr(nlist))
return car(nlist);
return reduce_left(func_n2(plus), cdr(nlist), car(nlist), nil);
}
val minusv(val minuend, val nlist)
{
if (nlist)
return reduce_left(func_n2(minus), nlist, minuend, nil);
return neg(minuend);
}
val mulv(val nlist)
{
if (!nlist)
return one;
else if (!cdr(nlist))
return car(nlist);
return reduce_left(func_n2(mul), cdr(nlist), car(nlist), nil);
}
val logandv(val nlist)
{
if (!nlist)
return negone;
else if (!cdr(nlist))
return car(nlist);
return reduce_left(func_n2(logand), cdr(nlist), car(nlist), nil);
}
val logiorv(val nlist)
{
if (!nlist)
return zero;
else if (!cdr(nlist))
return car(nlist);
return reduce_left(func_n2(logior), cdr(nlist), car(nlist), nil);
}
val gtv(val first, val rest)
{
val iter;
for (iter = rest; iter; iter = cdr(iter)) {
val elem = car(iter);
if (!gt(first, elem))
return nil;
first = elem;
}
return t;
}
val ltv(val first, val rest)
{
val iter;
for (iter = rest; iter; iter = cdr(iter)) {
val elem = car(iter);
if (!lt(first, elem))
return nil;
first = elem;
}
return t;
}
val gev(val first, val rest)
{
val iter;
for (iter = rest; iter; iter = cdr(iter)) {
val elem = car(iter);
if (!ge(first, elem))
return nil;
first = elem;
}
return t;
}
val lev(val first, val rest)
{
val iter;
for (iter = rest; iter; iter = cdr(iter)) {
val elem = car(iter);
if (!le(first, elem))
return nil;
first = elem;
}
return t;
}
val numeqv(val first, val rest)
{
val iter;
for (iter = rest; iter; iter = cdr(iter)) {
val elem = car(iter);
if (!numeq(first, elem))
return nil;
first = elem;
}
return t;
}
val numneqv(val list)
{
val i, j;
for (i = list; i; i = cdr(i))
for (j = cdr(i); j; j = cdr(j))
if (numeq(car(i), car(j)))
return nil;
return t;
}
val max2(val anum, val bnum)
{
return if3(ge(anum, bnum), anum, bnum);
}
val min2(val anum, val bnum)
{
return if3(le(anum, bnum), anum, bnum);
}
val maxv(val first, val rest)
{
return reduce_left(func_n2(max2), rest, first, nil);
}
val minv(val first, val rest)
{
return reduce_left(func_n2(min2), rest, first, nil);
}
val exptv(val nlist)
{
return reduce_right(func_n2(expt), nlist, one, nil);
}
val string_own(wchar_t *str)
{
val obj = make_obj();
obj->st.type = STR;
obj->st.str = str;
obj->st.len = nil;
obj->st.alloc = nil;
return obj;
}
val string(const wchar_t *str)
{
val obj = make_obj();
obj->st.type = STR;
obj->st.str = (wchar_t *) chk_strdup(str);
obj->st.len = nil;
obj->st.alloc = nil;
return obj;
}
val string_utf8(const char *str)
{
val obj = make_obj();
obj->st.type = STR;
obj->st.str = utf8_dup_from(str);
obj->st.len = nil;
obj->st.alloc = nil;
return obj;
}
val mkstring(val len, val ch)
{
size_t nchar = c_num(len) + 1;
wchar_t *str = (wchar_t *) chk_malloc(nchar * sizeof *str);
val s = string_own(str);
wmemset(str, c_chr(ch), nchar);
s->st.len = len;
s->st.alloc = plus(len, one);
return s;
}
val mkustring(val len)
{
cnum l = c_num(len);
wchar_t *str = (wchar_t *) chk_malloc((l + 1) * sizeof *str);
val s = string_own(str);
str[l] = 0;
s->st.len = len;
s->st.alloc = plus(len, one);
return s;
}
val init_str(val str, const wchar_t *data)
{
wmemcpy(str->st.str, data, c_num(str->st.len));
return str;
}
val copy_str(val str)
{
return string(c_str(str));
}
val upcase_str(val str)
{
val len = length_str(str);
wchar_t *dst = (wchar_t *) chk_malloc((c_num(len) + 1) * sizeof *dst);
const wchar_t *src = c_str(str);
val out = string_own(dst);
while ((*dst++ = towupper(*src++)))
;
return out;
}
val downcase_str(val str)
{
val len = length_str(str);
wchar_t *dst = (wchar_t *) chk_malloc((c_num(len) + 1) * sizeof *dst);
const wchar_t *src = c_str(str);
val out = string_own(dst);
while ((*dst++ = towlower(*src++)))
;
return out;
}
val string_extend(val str, val tail)
{
type_check(str, STR);
{
cnum len = c_num(length_str(str));
cnum alloc = c_num(str->st.alloc);
val needed;
val room = zero;
if (stringp(tail))
needed = length_str(tail);
else if (chrp(tail))
needed = one;
else if (fixnump(tail))
needed = tail;
else
uw_throwf(error_s, lit("string-extend: tail ~s bad type"), str, nao);
room = num(alloc - len - 1);
while (gt(needed, room) && alloc < NUM_MAX) {
if (alloc > NUM_MAX / 2) {
alloc = NUM_MAX;
} else {
alloc *= 2;
}
room = num(alloc - len - 1);
}
if (gt(needed, room))
uw_throwf(error_s, lit("string-extend: overflow"), nao);
str->st.str = (wchar_t *) chk_realloc((mem_t *) str->st.str,
alloc * sizeof *str->st.str);
set(str->st.alloc, num(alloc));
set(str->st.len, plus(str->st.len, needed));
if (stringp(tail)) {
wmemcpy(str->st.str + len, c_str(tail), c_num(needed) + 1);
} else if (chrp(tail)) {
str->st.str[len] = c_chr(tail);
str->st.str[len + 1] = 0;
}
}
return str;
}
val stringp(val str)
{
switch (type(str)) {
case LIT:
case STR:
case LSTR:
return t;
default:
return nil;
}
}
val lazy_stringp(val str)
{
return type(str) == LSTR ? t : nil;
}
val length_str(val str)
{
if (tag(str) == TAG_LIT) {
return num(wcslen(c_str(str)));
} else {
type_check2 (str, STR, LSTR);
if (str->ls.type == LSTR) {
lazy_str_force(str);
return length_str(str->ls.prefix);
}
if (!str->st.len) {
set(str->st.len, num(wcslen(str->st.str)));
set(str->st.alloc, plus(str->st.len, one));
}
return str->st.len;
}
}
const wchar_t *c_str(val obj)
{
if (tag(obj) == TAG_LIT)
return litptr(obj);
type_check3(obj, STR, SYM, LSTR);
switch (obj->t.type) {
case STR:
return obj->st.str;
case SYM:
return c_str(symbol_name(obj));
case LSTR:
lazy_str_force(obj);
return c_str(obj->ls.prefix);
default:
abort();
}
}
val search_str(val haystack, val needle, val start_num, val from_end)
{
from_end = default_bool_arg(from_end);
start_num = default_arg(start_num, zero);
if (length_str_lt(haystack, start_num)) {
return nil;
} else {
val h_is_lazy = lazy_stringp(haystack);
cnum start = c_num(start_num);
cnum good = -1, pos = -1;
const wchar_t *n = c_str(needle), *h;
if (!h_is_lazy) {
do {
const wchar_t *f;
h = c_str(haystack);
f = wcsstr(h + start, n);
if (f)
pos = f - h;
else
pos = -1;
} while (pos != -1 && (good = pos) != -1 && from_end && h[start++]);
} else {
size_t ln = c_num(length_str(needle));
do {
lazy_str_force_upto(haystack, plus(num(start + 1), length_str(needle)));
h = c_str(haystack->ls.prefix);
if (!wcsncmp(h + start, n, ln))
good = start;
} while (h[start++] && (from_end || good == -1));
}
return (good == -1) ? nil : num(good);
}
}
val search_str_tree(val haystack, val tree, val start_num, val from_end)
{
if (stringp(tree)) {
val result = search_str(haystack, tree, start_num, from_end);
if (result)
return cons(result, length_str(tree));
} else if (consp(tree)) {
val it = nil, minpos = nil, maxlen = nil;
for (; tree; tree = cdr(tree)) {
val result = search_str_tree(haystack, car(tree), start_num, from_end);
if (result) {
cons_bind (pos, len, result);
if (!it || lt(pos, minpos) || (pos == minpos && gt(len, maxlen))) {
minpos = pos;
maxlen = len;
it = result;
}
}
}
return it;
}
return nil;
}
val match_str(val bigstr, val str, val pos)
{
val i, p;
pos = default_arg(pos, zero);
for (i = zero;
length_str_gt(bigstr, p = plus(pos, i)) && length_str_gt(str, i);
i = plus(i, one))
{
if (chr_str(bigstr, p) != chr_str(str, i))
return nil;
}
return length_str_le(str, i) ? t : nil;
}
val match_str_tree(val bigstr, val tree, val pos)
{
pos = default_arg(pos, zero);
if (stringp(tree)) {
if (match_str(bigstr, tree, pos))
return length_str(tree);
} else if (consp(tree)) {
val maxlen = nil;
for (; tree; tree = cdr(tree)) {
val result = match_str_tree(bigstr, car(tree), pos);
if (result && (!maxlen || gt(result, maxlen)))
maxlen = result;
}
return maxlen;
}
return nil;
}
static val lazy_sub_str(val lstr, val from, val to)
{
val len = nil;
val len_pfx = length_str(lstr->ls.prefix);
if (from == nil) {
from = zero;
} else if (from == t) {
return null_string;
} else {
if (lt(from, zero)) {
from = plus(from, len = length_str(lstr));
from = max2(zero, from);
if (to == zero)
to = t;
}
if (ge(from, len_pfx)) {
if (!lazy_str_force_upto(lstr, from))
return null_string;
}
}
if (to == nil || to == t) {
to = t;
} else {
if (lt(to, zero)) {
to = plus(to, len = length_str(lstr));
to = max(zero, to);
}
if (ge(to, len_pfx))
if (!lazy_str_force_upto(lstr, minus(to, one)))
to = t;
}
{
val pfxsub = sub_str(lstr->ls.prefix, from, to);
if (to != t) {
return pfxsub;
} else {
val lsub = make_obj();
lsub->ls.type = LSTR;
lsub->ls.prefix = pfxsub;
lsub->ls.list = lstr->ls.list;
lsub->ls.opts = lstr->ls.opts;
return lsub;
}
}
}
val sub_str(val str_in, val from, val to)
{
val len = nil;
if (lazy_stringp(str_in))
return lazy_sub_str(str_in, from, to);
len = length_str(str_in);
if (null_or_missing_p(from))
from = zero;
else if (from == t)
return null_string;
else if (lt(from, zero)) {
from = plus(from, len);
if (to == zero)
to = len;
}
if (null_or_missing_p(to) || to == t)
to = len;
else if (lt(to, zero))
to = plus(to, len);
from = max2(zero, min2(from, len));
to = max2(zero, min2(to, len));
if (ge(from, to)) {
return null_string;
} else {
size_t nchar = c_num(to) - c_num(from) + 1;
wchar_t *sub = (wchar_t *) chk_malloc(nchar * sizeof (wchar_t));
const wchar_t *str = c_str(str_in);
wcsncpy(sub, str + c_num(from), nchar);
sub[nchar-1] = 0;
return string_own(sub);
}
}
val replace_str(val str_in, val items, val from, val to)
{
val itseq = to_seq(items);
val len = length_str(str_in);
val len_it = length(itseq);
val len_rep;
if (type(str_in) != STR) {
uw_throwf(error_s, lit("replace-str: ~s of type ~s is not "
"a modifiable string"),
str_in, typeof(str_in), nao);
}
if (null_or_missing_p(from))
from = zero;
else if (from == t)
from = len;
else if (lt(from, zero)) {
from = plus(from, len);
if (to == zero)
to = len;
}
if (null_or_missing_p(to) || to == t)
to = len;
else if (lt(to, zero))
to = plus(to, len);
from = max2(zero, min2(from, len));
to = max2(zero, min2(to, len));
len_rep = minus(to, from);
if (gt(len_rep, len_it)) {
val len_diff = minus(len_rep, len_it);
cnum t = c_num(to);
cnum l = c_num(len);
wmemmove(str_in->st.str + t - c_num(len_diff),
str_in->st.str + t, (l - t) + 1);
set(str_in->st.len, minus(len, len_diff));
to = plus(from, len_it);
} else if (lt(len_rep, len_it)) {
val len_diff = minus(len_it, len_rep);
cnum t = c_num(to);
cnum l = c_num(len);
string_extend(str_in, plus(len, len_diff));
wmemmove(str_in->st.str + t + c_num(len_diff),
str_in->st.str + t, (l - t) + 1);
to = plus(from, len_it);
}
if (zerop(len_it))
return str_in;
if (stringp(itseq)) {
wmemcpy(str_in->st.str + c_num(from), c_str(itseq), c_num(len_it));
} else {
val iter;
cnum f = c_num(from);
cnum t = c_num(to);
cnum s;
if (listp(itseq)) {
for (iter = itseq; iter && f != t; iter = cdr(iter), f++)
str_in->st.str[f] = c_chr(car(iter));
} else if (vectorp(itseq)) {
for (s = 0; f != t; f++, s++)
str_in->st.str[f] = c_chr(vecref(itseq, num(s)));
} else {
uw_throwf(error_s, lit("replace-str: source object ~s not supported"),
itseq, nao);
}
}
return str_in;
}
val cat_str(val list, val sep)
{
cnum total = 0;
val iter;
wchar_t *str, *ptr;
cnum len_sep = (!null_or_missing_p(sep)) ? c_num(length_str(sep)) : 0;
for (iter = list; iter != nil; iter = cdr(iter)) {
val item = car(iter);
if (!item)
continue;
if (stringp(item)) {
total += c_num(length_str(item));
if (len_sep && cdr(iter))
total += len_sep;
continue;
}
if (chrp(item)) {
total += 1;
if (len_sep && cdr(iter))
total += len_sep;
continue;
}
uw_throwf(error_s, lit("cat-str: ~s is not a character or string"),
item, nao);
}
str = (wchar_t *) chk_malloc((total + 1) * sizeof *str);
for (ptr = str, iter = list; iter != nil; iter = cdr(iter)) {
val item = car(iter);
cnum len;
if (!item)
continue;
if (stringp(item)) {
len = c_num(length_str(item));
wmemcpy(ptr, c_str(item), len);
ptr += len;
} else {
*ptr++ = c_chr(item);
}
if (len_sep && cdr(iter)) {
wmemcpy(ptr, c_str(sep), len_sep);
ptr += len_sep;
}
}
*ptr = 0;
return string_own(str);
}
val split_str(val str, val sep)
{
if (regexp(sep)) {
list_collect_decl (out, iter);
val pos = zero;
do {
cons_bind (new_pos, len, search_regex(str, sep, pos, 0));
if (eql(pos, new_pos) && len == zero)
new_pos = plus(new_pos, one);
iter = list_collect(iter, sub_str(str, pos, new_pos));
pos = new_pos;
if (len) {
pos = plus(pos, len);
continue;
}
break;
} while (le(pos, length_str(str)));
return out;
} else {
size_t len_sep = c_num(length_str(sep));
if (len_sep == 0) {
return list_str(str);
} else {
const wchar_t *cstr = c_str(str);
const wchar_t *csep = c_str(sep);
list_collect_decl (out, iter);
prot1(&str);
prot1(&sep);
for (;;) {
const wchar_t *psep = wcsstr(cstr, csep);
size_t span = (psep != 0) ? psep - cstr : wcslen(cstr);
val piece = mkustring(num(span));
init_str(piece, cstr);
iter = list_collect(iter, piece);
cstr += span;
if (psep != 0) {
cstr += len_sep;
continue;
}
break;
}
rel1(&sep);
rel1(&str);
return out;
}
}
}
val split_str_set(val str, val set)
{
const wchar_t *cstr = c_str(str);
const wchar_t *cset = c_str(set);
list_collect_decl (out, iter);
prot1(&str);
prot1(&set);
for (;;) {
size_t span = wcscspn(cstr, cset);
val piece = mkustring(num(span));
init_str(piece, cstr);
iter = list_collect(iter, piece);
cstr += span;
if (*cstr) {
cstr++;
continue;
}
break;
}
rel1(&set);
rel1(&str);
return out;
}
val tok_str(val str, val tok_regex, val keep_sep)
{
list_collect_decl (out, iter);
val pos = zero;
keep_sep = default_bool_arg(keep_sep);
for (;;) {
cons_bind (new_pos, len, search_regex(str, tok_regex, pos, nil));
val end;
if (!len) {
if (keep_sep)
iter = list_collect(iter, sub_str(str, pos, t));
break;
}
end = plus(new_pos, len);
if (keep_sep)
iter = list_collect(iter, sub_str(str, pos, new_pos));
iter = list_collect(iter, sub_str(str, new_pos, end));
pos = end;
if (len == zero)
pos = plus(pos, one);
}
return out;
}
val list_str(val str)
{
const wchar_t *cstr = c_str(str);
list_collect_decl (out, iter);
while (*cstr)
iter = list_collect(iter, chr(*cstr++));
return out;
}
val trim_str(val str)
{
const wchar_t *start = c_str(str);
const wchar_t *end = start + c_num(length_str(str));
while (start[0] && iswspace(start[0]))
start++;
while (end > start && iswspace(end[-1]))
end--;
if (end == start) {
return null_string;
} else {
size_t len = end - start;
wchar_t *buf = (wchar_t *) chk_malloc((len + 1) * sizeof *buf);
wmemcpy(buf, start, len);
buf[len] = 0;
return string_own(buf);
}
}
val string_cmp(val astr, val bstr)
{
switch (TYPE_PAIR(tag(astr), tag(bstr))) {
case TYPE_PAIR(LIT, LIT):
case TYPE_PAIR(STR, STR):
case TYPE_PAIR(LIT, STR):
case TYPE_PAIR(STR, LIT):
return num_fast(wcscmp(c_str(astr), c_str(bstr)));
case TYPE_PAIR(LSTR, LIT):
case TYPE_PAIR(LSTR, STR):
case TYPE_PAIR(LIT, LSTR):
case TYPE_PAIR(STR, LSTR):
case TYPE_PAIR(LSTR, LSTR):
{
val i;
for (i = zero;
length_str_lt(astr, i) && length_str_lt(bstr, i);
i = plus(i, one))
{
val ach = chr_str(astr, i);
val bch = chr_str(bstr, i);
if (ach < bch)
return num_fast(-1);
else if (ach < bch)
return num_fast(1);
}
if (length_str_lt(bstr, i))
return num_fast(-1);
if (length_str_lt(astr, i))
return num_fast(1);
return zero;
}
default:
uw_throwf(error_s, lit("string-cmp: invalid operands ~s ~s"),
astr, bstr, nao);
}
}
val string_lt(val astr, val bstr)
{
return wcscmp(c_str(astr), c_str(bstr)) < 0 ? t : nil;
}
val int_str(val str, val base)
{
const wchar_t *wcs = c_str(str);
wchar_t *ptr;
cnum b = c_num(default_arg(base, num_fast(10)));
/* TODO: detect if we have wcstoll */
long value = wcstol(wcs, &ptr, b ? b : 10);
if (value == 0 && ptr == wcs)
return nil;
if ((value == LONG_MAX || value == LONG_MIN) && errno == ERANGE) {
val bignum = make_bignum();
unsigned char *ucs = utf8_dup_to_uc(wcs);
mp_err err = mp_read_radix(mp(bignum), ucs, b);
free(ucs); /* TODO: make wchar_t version of mp_read_radix. */
if (err != MP_OKAY)
return nil;
/* If wcstol overflowed, but the range of long is smaller than
that of fixnums, that means that the value might not
actually be a bignum, and so we must normalize.
We do not need this on our usual target platforms, where NUM_MAX is
never larger than LONG_MAX. */
return (LONG_MAX < NUM_MAX) ? normalize(bignum) : bignum;
}
if (value >= NUM_MIN && value <= NUM_MAX)
return num(value);
return bignum_from_long(value);
}
val flo_str(val str)
{
const wchar_t *wcs = c_str(str);
wchar_t *ptr;
/* TODO: detect if we have wcstod */
double value = wcstod(wcs, &ptr);
if (value == 0 && ptr == wcs)
return nil;
if ((value == HUGE_VAL || value == -HUGE_VAL) && errno == ERANGE)
return nil;
return flo(value);
}
val num_str(val str)
{
const wchar_t *wcs = c_str(str);
const wchar_t *nws = wcs + wcsspn(wcs, L"\f\n\r\t\v");
const wchar_t *dig = nws + wcsspn(wcs, L"+-");
if (wcsspn(dig, L"0123456789") == wcsspn(dig, L"0123456789eE."))
return int_str(str, nil);
return flo_str(str);
}
val chrp(val chr)
{
return (is_chr(chr)) ? t : nil;
}
wchar_t c_chr(val chr)
{
if (!is_chr(chr))
type_mismatch(lit("~s is not a character"), chr, nao);
return (wchar_t) ((cnum) chr >> TAG_SHIFT);
}
val chr_isalnum(val ch)
{
return c_true(iswalnum(c_chr(ch)));
}
val chr_isalpha(val ch)
{
return c_true(iswalpha(c_chr(ch)));
}
val chr_isascii(val ch)
{
return c_true(c_chr(ch) >= 0 && c_chr(ch) < 128);
}
val chr_iscntrl(val ch)
{
return c_true(iswcntrl(c_chr(ch)));
}
val chr_isdigit(val ch)
{
return c_true(iswdigit(c_chr(ch)));
}
val chr_isgraph(val ch)
{
return c_true(iswgraph(c_chr(ch)));
}
val chr_islower(val ch)
{
return c_true(iswlower(c_chr(ch)));
}
val chr_isprint(val ch)
{
return c_true(iswprint(c_chr(ch)));
}
val chr_ispunct(val ch)
{
return c_true(iswpunct(c_chr(ch)));
}
val chr_isspace(val ch)
{
return c_true(iswspace(c_chr(ch)));
}
val chr_isupper(val ch)
{
return c_true(iswupper(c_chr(ch)));
}
val chr_isxdigit(val ch)
{
return c_true(iswxdigit(c_chr(ch)));
}
val chr_toupper(val ch)
{
return chr(towupper(c_chr(ch)));
}
val chr_tolower(val ch)
{
return chr(towlower(c_chr(ch)));
}
val num_chr(val ch)
{
return num_fast(c_chr(ch));
}
val chr_num(val num)
{
cnum n = c_num(num);
if (n < 0 || n > 0x10FFFF)
uw_throwf(numeric_error_s,
lit("chr-num: ~s is out of character range"), num, nao);
return chr(n);
}
val chr_str(val str, val ind)
{
cnum index = c_num(ind);
if (index < 0) {
ind = plus(length_str(str), ind);
index = c_num(ind);
}
if (index < 0 || !length_str_gt(str, ind))
uw_throwf(error_s, lit("chr-str: ~s is out of range for string ~s"),
ind, str, nao);
if (lazy_stringp(str)) {
lazy_str_force_upto(str, ind);
return chr(c_str(str->ls.prefix)[index]);
} else {
return chr(c_str(str)[index]);
}
}
val chr_str_set(val str, val ind, val chr)
{
cnum index = c_num(ind);
if (index < 0) {
ind = plus(length_str(str), ind);
index = c_num(ind);
}
if (index < 0 || !length_str_gt(str, ind))
uw_throwf(error_s, lit("chr-str-set: ~s is out of range for string ~s"),
ind, str, nao);
if (lazy_stringp(str)) {
lazy_str_force_upto(str, ind);
str->ls.prefix->st.str[index] = c_chr(chr);
} else {
str->st.str[index] = c_chr(chr);
}
return chr;
}
val span_str(val str, val set)
{
const wchar_t *cstr = c_str(str);
const wchar_t *cset = c_str(set);
size_t span = wcsspn(cstr, cset);
return num(span);
}
val compl_span_str(val str, val set)
{
const wchar_t *cstr = c_str(str);
const wchar_t *cset = c_str(set);
size_t span = wcscspn(cstr, cset);
return num(span);
}
val break_str(val str, val set)
{
const wchar_t *cstr = c_str(str);
const wchar_t *cset = c_str(set);
const wchar_t *brk = wcspbrk(cstr, cset);
if (!brk)
return nil;
return num(brk - cstr);
}
val symbol_name(val sym)
{
if (sym)
type_check(sym, SYM);
return sym ? sym->s.name : nil_string;
}
val symbol_package(val sym)
{
if (sym == nil)
return user_package;
type_check(sym, SYM);
return sym->s.package;
}
val make_sym(val name)
{
val obj = make_obj();
obj->s.type = SYM;
obj->s.name = name;
obj->s.package = nil;
obj->s.value = nil;
return obj;
}
val gensym(val prefix)
{
prefix = default_arg(prefix, lit("g"));
val *gs_loc = &gensym_counter;
val name = format(nil, lit("~a~,04a"), prefix,
set(*gs_loc, plus(*gs_loc, one)), nao);
return make_sym(name);
}
val make_package(val name)
{
if (find_package(name)) {
uw_throwf(error_s, lit("make-package: ~s exists already"), name, nao);
} else {
val obj = make_obj();
obj->pk.type = PKG;
obj->pk.name = name;
obj->pk.symhash = make_hash(nil, nil, lit("t")); /* don't have t yet! */
push(cons(name, obj), &packages);
return obj;
}
}
val packagep(val obj)
{
return type(obj) == PKG ? t : nil;
}
val find_package(val name)
{
return cdr(assoc(name, packages));
}
val delete_package(val package)
{
if (stringp(package)) {
val p = find_package(package);
if (!p)
uw_throwf(error_s, lit("delete-package: no such package: ~s"), package, nao);
package = p;
}
type_check (package, PKG);
packages = alist_nremove(packages, package->pk.name);
return nil;
}
val intern(val str, val package)
{
val new_p;
val *place;
if (null_or_missing_p(package)) {
package = user_package;
} else if (stringp(package)) {
val p = find_package(package);
if (!p)
uw_throwf(error_s, lit("intern: ~s no such package"), package, nao);
package = p;
}
type_check (package, PKG);
place = gethash_l(package->pk.symhash, str, &new_p);
if (!new_p) {
return *place;
} else {
val newsym = make_sym(str);
newsym->s.package = package;
return set(*place, newsym);
}
}
val rehome_sym(val sym, val package)
{
if (!sym)
return nil;
if (null_or_missing_p(package)) {
package = user_package;
} else if (stringp(package)) {
val p = find_package(package);
if (!p)
uw_throwf(error_s, lit("rehome-sym: no such package: ~s"), package, nao);
package = p;
}
type_check (package, PKG);
type_check (sym, SYM);
if (sym->s.package)
remhash(sym->s.package->pk.symhash, symbol_name(sym));
set(sym->s.package, package);
sethash(package->pk.symhash, symbol_name(sym), sym);
return sym;
}
val symbolp(val sym)
{
switch (type(sym)) {
case NIL:
case SYM:
return t;
default:
return nil;
}
}
val keywordp(val sym)
{
return (symbolp(sym) && symbol_package(sym) == keyword_package) ? t : nil;
}
val *get_user_package(void)
{
if (nilp(user_package_s))
return &user_package_var;
return lookup_var_l(nil, user_package_s);
}
val *get_system_package(void)
{
if (nilp(system_package_s))
return &system_package_var;
return lookup_var_l(nil, system_package_s);
}
val *get_keyword_package(void)
{
if (nilp(keyword_package_s))
return &keyword_package_var;
return lookup_var_l(nil, keyword_package_s);
}
val func_f0(val env, val (*fun)(val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F0;
obj->f.env = env;
obj->f.f.f0 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 0;
obj->f.optargs = 0;
return obj;
}
val func_f1(val env, val (*fun)(val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F1;
obj->f.env = env;
obj->f.f.f1 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 1;
obj->f.optargs = 0;
return obj;
}
val func_f2(val env, val (*fun)(val, val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F2;
obj->f.env = env;
obj->f.f.f2 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 2;
obj->f.optargs = 0;
return obj;
}
val func_f3(val env, val (*fun)(val, val, val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F3;
obj->f.env = env;
obj->f.f.f3 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 3;
obj->f.optargs = 0;
return obj;
}
val func_f4(val env, val (*fun)(val, val, val, val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F4;
obj->f.env = env;
obj->f.f.f4 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 4;
obj->f.optargs = 0;
return obj;
}
val func_n0(val (*fun)(void))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N0;
obj->f.env = nil;
obj->f.f.n0 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 0;
obj->f.optargs = 0;
return obj;
}
val func_n1(val (*fun)(val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N1;
obj->f.env = nil;
obj->f.f.n1 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 1;
obj->f.optargs = 0;
return obj;
}
val func_n2(val (*fun)(val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N2;
obj->f.env = nil;
obj->f.f.n2 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 2;
obj->f.optargs = 0;
return obj;
}
val func_n3(val (*fun)(val, val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N3;
obj->f.env = nil;
obj->f.f.n3 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 3;
obj->f.optargs = 0;
return obj;
}
val func_n4(val (*fun)(val, val, val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N4;
obj->f.env = nil;
obj->f.f.n4 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 4;
obj->f.optargs = 0;
return obj;
}
val func_n5(val (*fun)(val, val, val, val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N5;
obj->f.env = nil;
obj->f.f.n5 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 5;
obj->f.optargs = 0;
return obj;
}
val func_n6(val (*fun)(val, val, val, val, val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N6;
obj->f.env = nil;
obj->f.f.n6 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 6;
obj->f.optargs = 0;
return obj;
}
val func_n7(val (*fun)(val, val, val, val, val, val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N7;
obj->f.env = nil;
obj->f.f.n7 = fun;
obj->f.variadic = 0;
obj->f.fixparam = 7;
obj->f.optargs = 0;
return obj;
}
val func_f0v(val env, val (*fun)(val, val))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F0;
obj->f.env = env;
obj->f.f.f0v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 0;
obj->f.optargs = 0;
return obj;
}
val func_f1v(val env, val (*fun)(val env, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F1;
obj->f.env = env;
obj->f.f.f1v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 1;
obj->f.optargs = 0;
return obj;
}
val func_f2v(val env, val (*fun)(val env, val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F2;
obj->f.env = env;
obj->f.f.f2v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 2;
obj->f.optargs = 0;
return obj;
}
val func_f3v(val env, val (*fun)(val env, val, val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F3;
obj->f.env = env;
obj->f.f.f3v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 3;
obj->f.optargs = 0;
return obj;
}
val func_f4v(val env, val (*fun)(val env, val, val, val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = F4;
obj->f.env = env;
obj->f.f.f4v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 4;
obj->f.optargs = 0;
return obj;
}
val func_n0v(val (*fun)(val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N0;
obj->f.env = nil;
obj->f.f.n0v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 0;
obj->f.optargs = 0;
return obj;
}
val func_n1v(val (*fun)(val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N1;
obj->f.env = nil;
obj->f.f.n1v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 1;
obj->f.optargs = 0;
return obj;
}
val func_n2v(val (*fun)(val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N2;
obj->f.env = nil;
obj->f.f.n2v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 2;
obj->f.optargs = 0;
return obj;
}
val func_n3v(val (*fun)(val, val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N3;
obj->f.env = nil;
obj->f.f.n3v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 3;
obj->f.optargs = 0;
return obj;
}
val func_n4v(val (*fun)(val, val, val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N4;
obj->f.env = nil;
obj->f.f.n4v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 4;
obj->f.optargs = 0;
return obj;
}
val func_n5v(val (*fun)(val, val, val, val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N5;
obj->f.env = nil;
obj->f.f.n5v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 5;
obj->f.optargs = 0;
return obj;
}
val func_n6v(val (*fun)(val, val, val, val, val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N6;
obj->f.env = nil;
obj->f.f.n6v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 6;
obj->f.optargs = 0;
return obj;
}
val func_n7v(val (*fun)(val, val, val, val, val, val, val, val rest))
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = N7;
obj->f.env = nil;
obj->f.f.n7v = fun;
obj->f.variadic = 1;
obj->f.fixparam = 7;
obj->f.optargs = 0;
return obj;
}
val func_n0o(val (*fun)(void), int reqargs)
{
val obj = func_n0(fun);
obj->f.optargs = 0 - reqargs;
return obj;
}
val func_n1o(val (*fun)(val), int reqargs)
{
val obj = func_n1(fun);
obj->f.optargs = 1 - reqargs;
return obj;
}
val func_n2o(val (*fun)(val, val), int reqargs)
{
val obj = func_n2(fun);
obj->f.optargs = 2 - reqargs;
return obj;
}
val func_n3o(val (*fun)(val, val, val), int reqargs)
{
val obj = func_n3(fun);
obj->f.optargs = 3 - reqargs;
return obj;
}
val func_n4o(val (*fun)(val, val, val, val), int reqargs)
{
val obj = func_n4(fun);
obj->f.optargs = 4 - reqargs;
return obj;
}
val func_interp(val env, val form)
{
val obj = make_obj();
obj->f.type = FUN;
obj->f.functype = FINTERP;
obj->f.env = env;
obj->f.f.interp_fun = form;
obj->f.variadic = 1;
obj->f.fixparam = 0;
obj->f.optargs = 0;
return obj;
}
val func_get_form(val fun)
{
type_check(fun, FUN);
if (fun->f.functype != FINTERP)
uw_throwf(error_s, lit("func-get-form: ~a is not an interpreted function"),
fun, nao);
return fun->f.f.interp_fun;
}
val func_get_env(val fun)
{
type_check(fun, FUN);
return fun->f.env;
}
val func_set_env(val fun, val env)
{
type_check(fun, FUN);
set(fun->f.env, env);
return env;
}
val functionp(val obj)
{
return type(obj) == FUN ? t : nil;
}
val interp_fun_p(val obj)
{
return (functionp(obj) && obj->f.functype == FINTERP) ? t : nil;
}
val generic_funcall(val fun, val arg[], int nargs)
{
int variadic, fixparam, reqargs;
switch (type(fun)) {
case FUN:
break;
case NIL:
case CONS:
case LCONS:
case VEC:
case STR:
case LIT:
case LSTR:
switch (nargs) {
case 0:
uw_throw(error_s, lit("call: missing required arguments"));
case 1:
if (consp(arg[0]))
return sub(fun, car(arg[0]), cdr(arg[0]));
return ref(fun, arg[0]);
case 2:
return sub(fun, arg[0], arg[1]);
default:
uw_throw(error_s, lit("call: too many arguments"));
}
case COBJ:
if (fun->co.cls == hash_s) {
switch (nargs) {
case 0:
uw_throw(error_s, lit("call: missing required arguments"));
case 1:
return gethash(fun, arg[0]);
case 2:
return gethash_n(fun, arg[0], arg[1]);
default:
uw_throw(error_s, lit("call: too many arguments"));
}
}
/* fallthrough */
default:
type_mismatch(lit("call: ~s is not callable"), fun, nao);
}
variadic = fun->f.variadic;
fixparam = fun->f.fixparam;
reqargs = fixparam - fun->f.optargs;
if (!variadic) {
if (nargs < reqargs)
uw_throw(error_s, lit("call: missing required arguments"));
if (nargs > fixparam)
uw_throw(error_s, lit("call: too many arguments"));
for (; nargs < fixparam; )
arg[nargs++] = colon_k;
switch (fun->f.functype) {
case F0:
return fun->f.f.f0(fun->f.env);
case F1:
return fun->f.f.f1(fun->f.env, arg[0]);
case F2:
return fun->f.f.f2(fun->f.env, arg[0], arg[1]);
case F3:
return fun->f.f.f3(fun->f.env, arg[0], arg[1], arg[2]);
case F4:
return fun->f.f.f4(fun->f.env, arg[0], arg[1], arg[2], arg[3]);
case N0:
return fun->f.f.n0();
case N1:
return fun->f.f.n1(arg[0]);
case N2:
return fun->f.f.n2(arg[0], arg[1]);
case N3:
return fun->f.f.n3(arg[0], arg[1], arg[2]);
case N4:
return fun->f.f.n4(arg[0], arg[1], arg[2], arg[3]);
case N5:
return fun->f.f.n5(arg[0], arg[1], arg[2], arg[3], arg[4]);
case N6:
return fun->f.f.n6(arg[0], arg[1], arg[2], arg[3], arg[4], arg[5]);
case N7:
return fun->f.f.n7(arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6]);
case FINTERP:
internal_error("unsupported function type");
}
} else {
val arglist = nil;
if (nargs > fixparam)
nargs = fixparam;
if (nargs < reqargs)
uw_throw(error_s, lit("call: missing required arguments"));
for (; nargs < fixparam; )
arg[nargs++] = colon_k;
for (; nargs > fixparam; )
arglist = cons(arg[--nargs], arglist);
switch (fun->f.functype) {
case FINTERP:
return interp_fun(fun->f.env, fun->f.f.interp_fun, arglist);
case F0:
return fun->f.f.f0v(fun->f.env, arglist);
case F1:
return fun->f.f.f1v(fun->f.env, arg[0], arglist);
case F2:
return fun->f.f.f2v(fun->f.env, arg[0], arg[1], arglist);
case F3:
return fun->f.f.f3v(fun->f.env, arg[0], arg[1], arg[2], arglist);
case F4:
return fun->f.f.f4v(fun->f.env, arg[0], arg[1], arg[2], arg[3], arglist);
case N0:
return fun->f.f.n0v(arglist);
case N1:
return fun->f.f.n1v(arg[0], arglist);
case N2:
return fun->f.f.n2v(arg[0], arg[1], arglist);
case N3:
return fun->f.f.n3v(arg[0], arg[1], arg[2], arglist);
case N4:
return fun->f.f.n4v(arg[0], arg[1], arg[2], arg[3], arglist);
case N5:
return fun->f.f.n5v(arg[0], arg[1], arg[2], arg[3], arg[4], arglist);
case N6:
return fun->f.f.n6v(arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arglist);
case N7:
return fun->f.f.n7v(arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arglist);
}
}
internal_error("corrupt function type field");
}
val funcall(val fun)
{
if (fun->f.optargs || type(fun) != FUN) {
val arg[32] = { nil };
return generic_funcall(fun, arg, 0);
}
if (fun->f.variadic) {
switch (fun->f.functype) {
case FINTERP:
return interp_fun(fun->f.env, fun->f.f.interp_fun, nil);
case F0:
return fun->f.f.f0v(fun->f.env, nil);
case N0:
return fun->f.f.n0v(nil);
default:
break;
}
} else {
switch (fun->f.functype) {
case F0:
return fun->f.f.f0(fun->f.env);
case N0:
return fun->f.f.n0();
default:
break;
}
}
uw_throw(error_s, lit("call: wrong number of arguments"));
}
val funcall1(val fun, val arg)
{
if (fun->f.optargs || type(fun) != FUN) {
val args[32];
args[0] = arg;
return generic_funcall(fun, args, 1);
}
if (fun->f.variadic) {
switch (fun->f.functype) {
case FINTERP:
return interp_fun(fun->f.env, fun->f.f.interp_fun, cons(arg, nil));
case F0:
return fun->f.f.f0v(fun->f.env, cons(arg, nil));
case N0:
return fun->f.f.n0v(cons(arg, nil));
case F1:
return fun->f.f.f1v(fun->f.env, arg, nil);
case N1:
return fun->f.f.n1v(arg, nil);
default:
break;
}
} else {
switch (fun->f.functype) {
case F1:
return fun->f.f.f1(fun->f.env, arg);
case N1:
return fun->f.f.n1(arg);
default:
break;
}
}
uw_throw(error_s, lit("call: wrong number of arguments"));
}
val funcall2(val fun, val arg1, val arg2)
{
if (fun->f.optargs || type(fun) != FUN) {
val arg[32];
arg[0] = arg1;
arg[1] = arg2;
return generic_funcall(fun, arg, 2);
}
if (fun->f.variadic) {
switch (fun->f.functype) {
case FINTERP:
return interp_fun(fun->f.env, fun->f.f.interp_fun,
cons(arg1, cons(arg2, nil)));
case F0:
return fun->f.f.f0v(fun->f.env, cons(arg1, cons(arg2, nil)));
case N0:
return fun->f.f.n0v(cons(arg1, cons(arg2, nil)));
case F1:
return fun->f.f.f1v(fun->f.env, arg1, cons(arg2, nil));
case N1:
return fun->f.f.n1v(arg1, cons(arg2, nil));
case F2:
return fun->f.f.f2v(fun->f.env, arg1, arg2, nil);
case N2:
return fun->f.f.n2v(arg1, arg2, nil);
default:
break;
}
} else {
switch (fun->f.functype) {
case F2:
return fun->f.f.f2(fun->f.env, arg1, arg2);
case N2:
return fun->f.f.n2(arg1, arg2);
default:
break;
}
}
uw_throw(error_s, lit("call: wrong number of arguments"));
}
val funcall3(val fun, val arg1, val arg2, val arg3)
{
if (fun->f.optargs || type(fun) != FUN) {
val arg[32];
arg[0] = arg1;
arg[1] = arg2;
arg[2] = arg3;
return generic_funcall(fun, arg, 3);
}
if (fun->f.variadic) {
switch (fun->f.functype) {
case FINTERP:
return interp_fun(fun->f.env, fun->f.f.interp_fun,
cons(arg1, cons(arg2, cons(arg3, nil))));
case F0:
return fun->f.f.f0v(fun->f.env, cons(arg1, cons(arg2, cons(arg3, nil))));
case N0:
return fun->f.f.n0v(cons(arg1, cons(arg2, cons(arg3, nil))));
case F1:
return fun->f.f.f1v(fun->f.env, arg1, cons(arg2, cons(arg3, nil)));
case N1:
return fun->f.f.n1v(arg1, cons(arg2, cons(arg3, nil)));
case F2:
return fun->f.f.f2v(fun->f.env, arg1, arg2, cons(arg3, nil));
case N2:
return fun->f.f.n2v(arg1, arg2, cons(arg3, nil));
case F3:
return fun->f.f.f3v(fun->f.env, arg1, arg2, arg3, nil);
case N3:
return fun->f.f.n3v(arg1, arg2, arg3, nil);
default:
break;
}
} else {
switch (fun->f.functype) {
case F3:
return fun->f.f.f3(fun->f.env, arg1, arg2, arg3);
case N3:
return fun->f.f.n3(arg1, arg2, arg3);
default:
break;
}
}
uw_throw(error_s, lit("call: wrong number of arguments"));
}
val funcall4(val fun, val arg1, val arg2, val arg3, val arg4)
{
if (fun->f.optargs || type(fun) != FUN) {
val arg[32];
arg[0] = arg1;
arg[1] = arg2;
arg[2] = arg3;
arg[3] = arg4;
return generic_funcall(fun, arg, 4);
}
if (fun->f.variadic) {
switch (fun->f.functype) {
case FINTERP:
return interp_fun(fun->f.env, fun->f.f.interp_fun,
cons(arg1, cons(arg2, cons(arg3, cons(arg4, nil)))));
case F0:
return fun->f.f.f0v(fun->f.env, cons(arg1, cons(arg2, cons(arg3, cons(arg4, nil)))));
case N0:
return fun->f.f.n0v(cons(arg1, cons(arg2, cons(arg3, cons(arg4, nil)))));
case F1:
return fun->f.f.f1v(fun->f.env, arg1, cons(arg2, cons(arg3, cons(arg4, nil))));
case N1:
return fun->f.f.n1v(arg1, cons(arg2, cons(arg3, cons(arg4, nil))));
case F2:
return fun->f.f.f2v(fun->f.env, arg1, arg2, cons(arg3, cons(arg4, nil)));
case N2:
return fun->f.f.n2v(arg1, arg2, cons(arg3, cons(arg4, nil)));
case F3:
return fun->f.f.f3v(fun->f.env, arg1, arg2, arg3, cons(arg4, nil));
case N3:
return fun->f.f.n3v(arg1, arg2, arg3, cons(arg4, nil));
case F4:
return fun->f.f.f4v(fun->f.env, arg1, arg2, arg3, arg4, nil);
case N4:
return fun->f.f.n4v(arg1, arg2, arg3, arg4, nil);
default:
break;
}
} else {
switch (fun->f.functype) {
case F4:
return fun->f.f.f4(fun->f.env, arg1, arg2, arg3, arg4);
case N4:
return fun->f.f.n4(arg1, arg2, arg3, arg4);
default:
break;
}
}
uw_throw(error_s, lit("call: wrong number of arguments"));
}
val reduce_left(val fun, val list, val init, val key)
{
if (null_or_missing_p(key))
key = identity_f;
if (missingp(init)) {
if (list)
init = pop(&list);
else
return funcall(fun);
}
for (; list; list = cdr(list))
init = funcall2(fun, init, funcall1(key, car(list)));
return init;
}
val reduce_right(val fun, val list, val init, val key)
{
if (null_or_missing_p(key))
key = identity_f;
if (list) {
if (missingp(init)) {
if (!rest(list))
return funcall1(key, first(list));
if (!rest(rest(list)))
return funcall2(fun, funcall1(key, first(list)),
funcall1(key, second(list)));
/* fall through: no init, three or more items in list */
} else {
if (!rest(list))
return funcall2(fun, funcall1(key, first(list)), init);
/* fall through: init, and two or more items in list */
}
} else if (!missingp(init)) {
return init;
} else {
return funcall(fun);
}
return funcall2(fun, funcall1(key, car(list)),
if3(cdr(list), reduce_right(fun, cdr(list), init, key),
init));
}
static val do_curry_12_2(val fcons, val arg2)
{
return funcall2(car(fcons), cdr(fcons), arg2);
}
val curry_12_2(val fun2, val arg)
{
return func_f1(cons(fun2, arg), do_curry_12_2);
}
static val do_curry_12_1(val fcons, val arg1)
{
return funcall2(car(fcons), arg1, cdr(fcons));
}
val curry_12_1(val fun2, val arg2)
{
return func_f1(cons(fun2, arg2), do_curry_12_1);
}
static val do_curry_123_3(val fcons, val arg3)
{
return funcall3(car(fcons), car(cdr(fcons)), cdr(cdr(fcons)), arg3);
}
val curry_123_3(val fun3, val arg1, val arg2)
{
return func_f1(cons(fun3, cons(arg1, arg2)), do_curry_123_3);
}
static val do_curry_123_2(val fcons, val arg2)
{
return funcall3(car(fcons), car(cdr(fcons)), arg2, cdr(cdr(fcons)));
}
val curry_123_2(val fun3, val arg1, val arg3)
{
return func_f1(cons(fun3, cons(arg1, arg3)), do_curry_123_2);
}
static val do_curry_123_1(val fcons, val arg1)
{
return funcall3(car(fcons), arg1, car(cdr(fcons)), cdr(cdr(fcons)));
}
val curry_123_1(val fun3, val arg2, val arg3)
{
return func_f1(cons(fun3, cons(arg2, arg3)), do_curry_123_1);
}
static val do_curry_123_23(val fcons, val arg2, val arg3)
{
return funcall3(car(fcons), cdr(fcons), arg2, arg3);
}
val curry_123_23(val fun3, val arg1)
{
return func_f2(cons(fun3, arg1), do_curry_123_23);
}
static val do_curry_1234_34(val fcons, val arg3, val arg4)
{
return funcall4(car(fcons), car(cdr(fcons)), cdr(cdr(fcons)), arg3, arg4);
}
val curry_1234_34(val fun4, val arg1, val arg2)
{
return func_f2(cons(fun4, cons(arg1, arg2)), do_curry_1234_34);
}
static val do_chain(val fun1_list, val args)
{
val arg = nil;
if (fun1_list) {
arg = apply(car(fun1_list), args, nil);
fun1_list = cdr(fun1_list);
}
for (; fun1_list; fun1_list = cdr(fun1_list))
arg = funcall1(car(fun1_list), arg);
return arg;
}
val chain(val first_fun, ...)
{
va_list vl;
list_collect_decl (out, iter);
if (first_fun != nao) {
val next_fun;
va_start (vl, first_fun);
iter = list_collect(iter, first_fun);
while ((next_fun = va_arg(vl, val)) != nao)
iter = list_collect(iter, next_fun);
va_end (vl);
}
return func_f0v(out, do_chain);
}
val chainv(val funlist)
{
return func_f0v(funlist, do_chain);
}
static val do_and(val fun1_list, val args)
{
for (; fun1_list; fun1_list = cdr(fun1_list))
if (nilp(apply(car(fun1_list), args, nil)))
return nil;
return t;
}
val andf(val first_fun, ...)
{
va_list vl;
list_collect_decl (out, iter);
if (first_fun != nao) {
val next_fun;
va_start (vl, first_fun);
iter = list_collect(iter, first_fun);
while ((next_fun = va_arg(vl, val)) != nao)
iter = list_collect(iter, next_fun);
va_end (vl);
}
return func_f0v(out, do_and);
}
val andv(val funlist)
{
return func_f0v(funlist, do_and);
}
static val do_swap_12_21(val fun, val left, val right)
{
return funcall2(fun, right, left);
}
val swap_12_21(val fun)
{
return func_f2(fun, do_swap_12_21);
}
static val do_or(val fun1_list, val args)
{
for (; fun1_list; fun1_list = cdr(fun1_list))
if (apply(car(fun1_list), args, nil))
return t;
return nil;
}
val orf(val first_fun, ...)
{
va_list vl;
list_collect_decl (out, iter);
if (first_fun != nao) {
val next_fun;
va_start (vl, first_fun);
iter = list_collect(iter, first_fun);
while ((next_fun = va_arg(vl, val)) != nao)
iter = list_collect(iter, next_fun);
va_end (vl);
}
return func_f0v(out, do_or);
}
val orv(val funlist)
{
return func_f0v(funlist, do_or);
}
static val do_iff(val env, val args)
{
cons_bind (condfun, choices, env);
cons_bind (thenfun, elsefun, choices);
return if3(apply(condfun, args, nil),
if2(thenfun, apply(thenfun, args, nil)),
if2(elsefun, apply(elsefun, args, nil)));
}
val iff(val condfun, val thenfun, val elsefun)
{
return func_f0v(cons(condfun, cons(thenfun, elsefun)), do_iff);
}
val iffi(val condfun, val thenfun, val elsefun)
{
if (!elsefun)
elsefun = identity_f;
return func_f0v(cons(condfun, cons(thenfun, elsefun)), do_iff);
}
val vector(val length, val initval)
{
int i;
cnum alloc_plus = c_num(length) + 2;
size_t size = alloc_plus * sizeof (val);
val *v = ((cnum) (size / sizeof *v) == alloc_plus)
? (val *) chk_malloc(size)
: (val *) uw_throwf(error_s, lit("vector: length ~a is too large"),
length, nao);
val vec = make_obj();
initval = default_bool_arg(initval);
#if HAVE_VALGRIND
vec->v.vec_true_start = v;
#endif
v += 2;
vec->v.type = VEC;
vec->v.vec = v;
v[vec_alloc] = length;
v[vec_length] = length;
for (i = 0; i < alloc_plus - 2; i++)
vec->v.vec[i] = initval;
return vec;
}
val vectorp(val vec)
{
return type(vec) == VEC ? t : nil;
}
val vec_set_length(val vec, val length)
{
type_check(vec, VEC);
{
cnum new_length = c_num(length);
cnum old_length = c_num(vec->v.vec[vec_length]);
cnum old_alloc = c_num(vec->v.vec[vec_alloc]);
cnum length_delta = new_length - old_length;
cnum alloc_delta = new_length - old_alloc;
if (new_length > (cnum) ((size_t) -1/sizeof (val) - 2))
uw_throwf(error_s, lit("vec-set-length: cannot extend to length ~s"),
length, nao);
if (alloc_delta > 0) {
cnum new_alloc = max(new_length, 2*old_alloc);
val *newvec = (val *) chk_realloc((mem_t *) (vec->v.vec - 2),
(new_alloc + 2) * sizeof *newvec);
vec->v.vec = newvec + 2;
set(vec->v.vec[vec_alloc], num(new_alloc));
#if HAVE_VALGRIND
vec->v.vec_true_start = newvec;
#endif
}
if (length_delta > 0) {
cnum i;
for (i = old_length; i < new_length; i++)
vec->v.vec[i] = nil;
}
set(vec->v.vec[vec_length], length);
}
return vec;
}
val vecref(val vec, val ind)
{
cnum index = c_num(ind);
cnum len = c_num(length_vec(vec));
if (index < 0)
index = len + index;
if (index < 0 || index >= len)
uw_throwf(error_s, lit("vecref: ~s is out of range for vector ~s"),
ind, vec, nao);
return vec->v.vec[index];
}
val *vecref_l(val vec, val ind)
{
cnum index = c_num(ind);
cnum len = c_num(length_vec(vec));
if (index < 0)
index = len + index;
if (index < 0 || index >= len)
uw_throwf(error_s, lit("vecref: ~s is out of range for vector ~s"),
ind, vec, nao);
return vec->v.vec + index;
}
val vec_push(val vec, val item)
{
val length = length_vec(vec);
vec_set_length(vec, plus(length, one));
*vecref_l(vec, length) = item;
return length;
}
val length_vec(val vec)
{
type_check(vec, VEC);
return vec->v.vec[vec_length];
}
val size_vec(val vec)
{
type_check(vec, VEC);
return vec->v.vec[vec_alloc];
}
val vector_list(val list)
{
val vec = vector(zero, nil);
if (!listp(list))
uw_throwf(error_s, lit("vector-list: list expected, not ~s"), list, nao);
for (; consp(list); list = cdr(list))
vec_push(vec, car(list));
return vec;
}
val list_vector(val vec)
{
list_collect_decl (list, ptail);
int i, len;
type_check(vec, VEC);
len = c_num(vec->v.vec[vec_length]);
for (i = 0; i < len; i++)
ptail = list_collect(ptail, vec->v.vec[i]);
return list;
}
val copy_vec(val vec_in)
{
val length = length_vec(vec_in);
cnum alloc_plus = c_num(length) + 2;
val vec = make_obj();
val *v = (val *) chk_malloc(alloc_plus * sizeof *v);
#if HAVE_VALGRIND
vec->v.vec_true_start = v;
#endif
v += 2;
vec->v.type = VEC;
vec->v.vec = v;
v[vec_alloc] = length;
v[vec_length] = length;
memcpy(vec->v.vec, vec_in->v.vec, (alloc_plus - 2) * sizeof *vec->v.vec);
return vec;
}
val sub_vec(val vec_in, val from, val to)
{
val len = length_vec(vec_in);
if (null_or_missing_p(from))
from = zero;
else if (from == t)
from = len;
else if (lt(from, zero)) {
from = plus(from, len);
if (to == zero)
to = len;
}
if (null_or_missing_p(to) || to == t)
to = len;
else if (lt(to, zero))
to = plus(to, len);
from = max2(zero, min2(from, len));
to = max2(zero, min2(to, len));
if (ge(from, to)) {
return vector(zero, nil);
} else {
cnum cfrom = c_num(from);
size_t nelem = c_num(to) - cfrom;
val vec = make_obj();
val *v = (val *) chk_malloc((nelem + 2) * sizeof *v);
#if HAVE_VALGRIND
vec->v.vec_true_start = v;
#endif
v += 2;
vec->v.type = VEC;
vec->v.vec = v;
v[vec_length] = v[vec_alloc] = num(nelem);
memcpy(vec->v.vec, vec_in->v.vec + cfrom, nelem * sizeof *vec->v.vec);
return vec;
}
}
val replace_vec(val vec_in, val items, val from, val to)
{
val it_seq = to_seq(items);
val len = length_vec(vec_in);
val len_it = length(it_seq);
val len_rep;
if (null_or_missing_p(from))
from = zero;
else if (from == t)
from = len;
else if (lt(from, zero)) {
from = plus(from, len);
if (to == zero)
to = len;
}
if (null_or_missing_p(to) || to == t)
to = len;
else if (lt(to, zero))
to = plus(to, len);
from = max2(zero, min2(from, len));
to = max2(zero, min2(to, len));
len_rep = minus(to, from);
if (gt(len_rep, len_it)) {
val len_diff = minus(len_rep, len_it);
cnum t = c_num(to);
cnum l = c_num(len);
memmove(vec_in->v.vec + t - c_num(len_diff),
vec_in->v.vec + t,
(l - t) * sizeof vec_in->v.vec);
vec_in->v.vec[vec_length] = minus(len, len_diff);
to = plus(from, len_it);
} else if (lt(len_rep, len_it)) {
val len_diff = minus(len_it, len_rep);
cnum t = c_num(to);
cnum l = c_num(len);
vec_set_length(vec_in, plus(len, len_diff));
memmove(vec_in->v.vec + t + c_num(len_diff),
vec_in->v.vec + t,
(l - t) * sizeof vec_in->v.vec);
to = plus(from, len_it);
}
if (zerop(len_it))
return vec_in;
if (vectorp(it_seq)) {
memcpy(vec_in->v.vec + c_num(from), it_seq->v.vec,
sizeof *vec_in->v.vec * c_num(len_it));
mut(vec_in);
} else if (stringp(it_seq)) {
cnum f = c_num(from);
cnum t = c_num(to);
cnum s;
const wchar_t *str = c_str(it_seq);
for (s = 0; f != t; f++, s++)
vec_in->v.vec[f] = chr(str[s]);
} else {
val iter;
cnum f = c_num(from);
cnum t = c_num(to);
for (iter = it_seq; iter && f != t; iter = cdr(iter), f++)
vec_in->v.vec[f] = car(iter);
mut(vec_in);
}
return vec_in;
}
val cat_vec(val list)
{
size_t total = 0;
val iter;
val vec, *v;
for (iter = list; iter != nil; iter = cdr(iter)) {
size_t newtot = total + c_num(length_vec(car(iter)));
if (newtot < total)
goto toobig;
total = newtot;
}
if (total > ((size_t) -1)/(sizeof (val)) - 2)
goto toobig;
vec = make_obj();
v = (val *) chk_malloc((total + 2) * sizeof *v);
#if HAVE_VALGRIND
vec->v.vec_true_start = v;
#endif
v += 2;
vec->v.type = VEC;
vec->v.vec = v;
v[vec_length] = v[vec_alloc] = num(total);
for (iter = list; iter != nil; iter = cdr(iter)) {
val item = car(iter);
cnum len = c_num(item->v.vec[vec_length]);
memcpy(v, item->v.vec, len * sizeof *v);
v += len;
}
return vec;
toobig:
uw_throwf(error_s, lit("cat-vec: resulting vector too large"), nao);
}
static val simple_lazy_stream_func(val stream, val lcons)
{
if (set(lcons->lc.car, get_line(stream)) != nil)
set(lcons->lc.cdr, make_lazy_cons(lcons->lc.func));
else
lcons->lc.cdr = nil;
return nil;
}
static val lazy_stream_cont(val stream, val func, val env)
{
val next = get_line(stream);
if (!next) {
close_stream(stream, t);
return nil;
}
rplacd(env, next);
return make_lazy_cons(func);
}
static val lazy_stream_func(val env, val lcons)
{
val stream = car(env);
val prefetched_line = cdr(env);
set(lcons->lc.car, prefetched_line);
set(lcons->lc.cdr, lazy_stream_cont(stream, lcons->lc.func, env));
return prefetched_line;
}
val lazy_stream_cons(val stream)
{
if (real_time_stream_p(stream)) {
return make_lazy_cons(func_f1(stream, simple_lazy_stream_func));
} else {
val first = get_line(stream);
if (!first) {
close_stream(stream, t);
return nil;
}
return make_lazy_cons(func_f1(cons(stream, first),
lazy_stream_func));
}
}
val lazy_str(val lst, val term, val limit)
{
val obj = make_obj();
obj->ls.type = LSTR;
/* Must init before calling something that can gc! */
obj->ls.opts = obj->ls.list = obj->ls.prefix = nil;
term = default_arg(term, lit("\n"));
limit = default_bool_arg(limit);
if (nilp(lst)) {
obj->ls.prefix = null_string;
obj->ls.list = nil;
} else {
set(obj->ls.prefix, cat_str(list(first(lst), term, nao), nil));
set(obj->ls.list, rest(lst));
limit = if2(limit, minus(limit, one));
}
set(obj->ls.opts, cons(term, limit));
return obj;
}
val lazy_str_force(val lstr)
{
val lim;
type_check(lstr, LSTR);
lim = cdr(lstr->ls.opts);
while ((!lim || gt(lim, zero)) && lstr->ls.list) {
val next = pop(&lstr->ls.list);
val term = car(lstr->ls.opts);
set(lstr->ls.prefix, cat_str(list(lstr->ls.prefix, next, term, nao), nil));
if (lim)
lim = minus(lim, one);
}
if (lim)
set(*cdr_l(lstr->ls.opts), lim);
return lstr->ls.prefix;
}
val lazy_str_force_upto(val lstr, val index)
{
uses_or2;
val lim;
type_check(lstr, LSTR);
lim = cdr(lstr->ls.opts);
while (ge(index, length_str(lstr->ls.prefix)) && lstr->ls.list &&
or2(null(lim),gt(lim,zero)))
{
val next = pop(&lstr->ls.list);
val term = car(lstr->ls.opts);
set(lstr->ls.prefix, cat_str(list(lstr->ls.prefix, next, term, nao), nil));
if (lim)
lim = minus(lim, one);
}
if (lim)
set(*cdr_l(lstr->ls.opts), lim);
return lt(index, length_str(lstr->ls.prefix));
}
val length_str_gt(val str, val len)
{
if (is_lit(str)) {
const wchar_t *cstr = c_str(str);
size_t clen = c_num(len);
const wchar_t *nult = wmemchr(cstr, 0, clen + 1);
return nult == 0 ? t : nil;
} else {
type_check2 (str, STR, LSTR);
switch (str->t.type) {
case STR:
return gt(length_str(str), len);
case LSTR:
lazy_str_force_upto(str, len);
return gt(length_str(str->ls.prefix), len);
default:
internal_error("unexpected type value");
}
}
}
val length_str_ge(val str, val len)
{
if (is_lit(str)) {
const wchar_t *cstr = c_str(str);
size_t clen = c_num(len);
const wchar_t *nult = wmemchr(cstr, 0, clen);
return nult == 0 ? t : nil;
} else {
type_check2 (str, STR, LSTR);
switch (str->t.type) {
case STR:
return ge(length_str(str), len);
case LSTR:
lazy_str_force_upto(str, len);
return ge(length_str(str->ls.prefix), len);
default:
internal_error("unexpected type value");
}
}
}
val length_str_lt(val str, val len)
{
if (is_lit(str)) {
const wchar_t *cstr = c_str(str);
size_t clen = c_num(len);
const wchar_t *nult = wmemchr(cstr, 0, clen);
return nult != 0 ? t : nil;
} else {
type_check2 (str, STR, LSTR);
switch (str->t.type) {
case STR:
return lt(length_str(str), len);
case LSTR:
lazy_str_force_upto(str, len);
return lt(length_str(str->ls.prefix), len);
default:
internal_error("unexpected type value");
}
}
}
val length_str_le(val str, val len)
{
if (is_lit(str)) {
const wchar_t *cstr = c_str(str);
size_t clen = c_num(len);
const wchar_t *nult = wmemchr(cstr, 0, clen + 1);
return nult != 0 ? t : nil;
} else {
type_check2 (str, STR, LSTR);
switch (str->t.type) {
case STR:
return le(length_str(str), len);
case LSTR:
lazy_str_force_upto(str, len);
return le(length_str(str->ls.prefix), len);
default:
internal_error("unexpected type value");
}
}
}
val lazy_str_get_trailing_list(val lstr, val index)
{
type_check(lstr, LSTR);
/* Force lazy string up through the index position */
if (ge(index, length_str(lstr->ls.prefix)))
lazy_str_force_upto(lstr, index);
{
uses_or2;
val split_suffix = split_str(sub_str(lstr->ls.prefix, index, nil),
or2(car(lstr->ls.opts), lit("\n")));
return nappend2(split_suffix, lstr->ls.list);
}
}
val cobj(mem_t *handle, val cls_sym, struct cobj_ops *ops)
{
val obj = make_obj();
obj->co.type = COBJ;
obj->co.handle = handle;
obj->co.ops = ops;
obj->co.cls = cls_sym;
return obj;
}
val cobjp(val obj)
{
return type(obj) == COBJ ? t : nil;
}
mem_t *cobj_handle(val cobj, val cls_sym)
{
class_check(cobj, cls_sym);
return cobj->co.handle;
}
void cobj_print_op(val obj, val out)
{
put_string(lit("#<"), out);
obj_print(obj->co.cls, out);
format(out, lit(": ~p>"), obj->co.handle, nao);
}
static val cptr_equal_op(val left, val right)
{
return (left->co.handle == right->co.handle) ? t : nil;
}
static struct cobj_ops cptr_ops = {
cptr_equal_op,
cobj_print_op,
cobj_destroy_stub_op,
cobj_mark_op,
cobj_hash_op
};
val cptr(mem_t *ptr)
{
return cobj(ptr, cptr_s, &cptr_ops);
}
mem_t *cptr_get(val cptr)
{
return cobj_handle(cptr, cptr_s);
}
val assoc(val key, val list)
{
while (list) {
val elem = car(list);
if (equal(car(elem), key))
return elem;
list = cdr(list);
}
return nil;
}
val assql(val key, val list)
{
while (list) {
val elem = car(list);
if (eql(car(elem), key))
return elem;
list = cdr(list);
}
return nil;
}
val acons(val car, val cdr, val list)
{
return cons(cons(car, cdr), list);
}
val acons_new(val key, val value, val list)
{
val existing = assoc(key, list);
if (existing) {
set(*cdr_l(existing), value);
return list;
} else {
return cons(cons(key, value), list);
}
}
val acons_new_c(val key, val *new_p, val *list)
{
val existing = assoc(key, *list);
if (existing) {
if (new_p)
*new_p = nil;
return existing;
} else {
val nc = cons(key, nil);
set(*list, cons(nc, *list));
if (new_p)
*new_p = t;
return nc;
}
}
val aconsql_new(val key, val value, val list)
{
val existing = assql(key, list);
if (existing) {
set(*cdr_l(existing), value);
return list;
} else {
return cons(cons(key, value), list);
}
}
val aconsql_new_c(val key, val *new_p, val *list)
{
val existing = assql(key, *list);
if (existing) {
if (new_p)
*new_p = nil;
return existing;
} else {
val nc = cons(key, nil);
set(*list, cons(nc, *list));
if (new_p)
*new_p = t;
return nc;
}
}
static val alist_remove_test(val item, val key)
{
return equal(car(item), key);
}
val alist_remove(val list, val keys)
{
return set_diff(list, keys, func_n2(alist_remove_test), nil);
}
val alist_remove1(val list, val key)
{
return alist_remove(list, cons(key, nil));
}
val alist_nremove(val list, val keys)
{
val *plist = &list;
while (*plist) {
if (memqual(car(car(*plist)), keys))
*plist = cdr(*plist);
else
plist = cdr_l(*plist);
}
return list;
}
val alist_nremove1(val list, val key)
{
val *plist = &list;
while (*plist) {
if (equal(car(car(*plist)), key))
*plist = cdr(*plist);
else
plist = cdr_l(*plist);
}
return list;
}
val copy_cons(val c)
{
return cons(car(c), cdr(c));
}
val copy_alist(val list)
{
return mapcar(func_n1(copy_cons), list);
}
val mapcar(val fun, val list)
{
list_collect_decl (out, iter);
val list_orig = list;
for (; list; list = cdr(list))
iter = list_collect(iter, funcall1(fun, car(list)));
return make_like(out, list_orig);
}
val mapcon(val fun, val list)
{
list_collect_decl (out, iter);
val list_orig = list;
for (; list; list = cdr(list))
iter = list_collect_nconc(iter, funcall1(fun, list));
return make_like(out, list_orig);
}
val mappend(val fun, val list)
{
list_collect_decl (out, iter);
val list_orig = list;
for (; list; list = cdr(list))
iter = list_collect_append(iter, funcall1(fun, car(list)));
return make_like(out, list_orig);
}
val merge(val list1, val list2, val lessfun, val keyfun)
{
list_collect_decl (out, ptail);
while (list1 && list2) {
val el1 = funcall1(keyfun, first(list1));
val el2 = funcall1(keyfun, first(list2));
if (funcall2(lessfun, el1, el2)) {
val next = cdr(list1);
*cdr_l(list1) = nil;
ptail = list_collect_nconc(ptail, list1);
list1 = next;
} else {
val next = cdr(list2);
*cdr_l(list2) = nil;
ptail = list_collect_nconc(ptail, list2);
list2 = next;
}
}
if (list1)
ptail = list_collect_nconc(ptail, list1);
else
ptail = list_collect_nconc(ptail, list2);
return out;
}
static val sort_list(val list, val lessfun, val keyfun)
{
if (list == nil)
return nil;
if (!cdr(list))
return list;
if (!cdr(cdr(list))) {
if (funcall2(lessfun, funcall1(keyfun, first(list)),
funcall1(keyfun, second(list))))
{
return list;
} else {
val cons2 = cdr(list);
/* This assignent is a dangerous mutation since the list
may contain mixtures of old and new objects, and
so we could be reversing a newer->older pointer
relationship. */
set(*cdr_l(cons2), list);
*cdr_l(list) = nil;
return cons2;
}
}
{
val bisect, iter;
val list2;
for (iter = cdr(cdr(list)), bisect = list; iter;
bisect = cdr(bisect), iter = cdr(cdr(iter)))
; /* empty */
list2 = cdr(bisect);
*cdr_l(bisect) = nil;
return merge(sort_list(list, lessfun, keyfun),
sort_list(list2, lessfun, keyfun),
lessfun, keyfun);
}
}
static void swap(val vec, val i, val j)
{
if (i != j) {
val temp = ref(vec, i);
refset(vec, i, ref(vec, j));
refset(vec, j, temp);
}
}
static void quicksort(val vec, val lessfun, val keyfun, cnum from, cnum to)
{
if (to - from >= 2) {
cnum pivot = from + (to - from) / 2;
cnum i, j;
val pval = ref(vec, num_fast(pivot));
val pkval = funcall1(keyfun, pval);
swap(vec, num_fast(pivot), num_fast(to - 1));
for (j = from, i = from; i < to - 1; i++)
if (funcall2(lessfun, funcall1(keyfun, ref(vec, num_fast(i))), pkval))
swap(vec, num_fast(i), num_fast(j++));
swap(vec, num_fast(j), num_fast(to - 1));
quicksort(vec, lessfun, keyfun, from, j);
quicksort(vec, lessfun, keyfun, j + 1, to);
}
}
static void sort_vec(val vec, val lessfun, val keyfun)
{
cnum len = c_num(length(vec));
quicksort(vec, lessfun, keyfun, 0, len);
}
val sort(val seq, val lessfun, val keyfun)
{
if (!seq)
return nil;
keyfun = default_arg(keyfun, identity_f);
if (consp(seq)) {
/* The list could have a mixture of generation 0 and 1
objects. Sorting the list could reverse some of the
pointers between the generations resulting in a backpointer.
Thus we better inform the collector about this object. */
return sort_list(seq, lessfun, keyfun);
}
sort_vec(seq, lessfun, keyfun);
return seq;
}
static val multi_sort_less(val funcs_cons, val llist, val rlist)
{
cons_bind (funcs, key_funcs, funcs_cons);
val less = t;
while (funcs) {
val func = pop(&funcs);
val test = pop(&key_funcs);
val left = if3(test, funcall1(test, pop(&llist)), pop(&llist));
val right = if3(test, funcall1(test, pop(&rlist)), pop(&rlist));
if (funcall2(func, left, right))
break;
if (funcall2(func, right, left)) {
less = nil;
break;
}
}
return less;
}
val multi_sort(val lists, val funcs, val key_funcs)
{
val tuples = mapcarv(func_n0v(identity), lists);
key_funcs = default_bool_arg(key_funcs);
if (functionp(funcs))
funcs = cons(funcs, nil);
tuples = sort_list(tuples, func_f2(cons(funcs, key_funcs),
multi_sort_less), identity_f);
return mapcarv(func_n0v(identity), tuples);
}
val find(val item, val list, val testfun, val keyfun)
{
testfun = default_arg(testfun, equal_f);
keyfun = default_arg(keyfun, identity_f);
for (; list; list = cdr(list)) {
val elem = car(list);
val key = funcall1(keyfun, elem);
if (funcall2(testfun, item, key))
return elem;
}
return nil;
}
val find_if(val pred, val list, val key)
{
key = default_arg(key, identity_f);
for (; list; list = cdr(list)) {
val item = car(list);
val subj = funcall1(key, item);
if (funcall1(pred, subj))
return item;
}
return nil;
}
val posqual(val obj, val list)
{
val pos = zero;
for (; list; list = cdr(list), pos = plus(pos, one))
if (equal(car(list), obj))
return pos;
return nil;
}
val posql(val obj, val list)
{
val pos = zero;
for (; list; list = cdr(list), pos = plus(pos, one))
if (eql(car(list), obj))
return pos;
return nil;
}
val posq(val obj, val list)
{
val pos = zero;
for (; list; list = cdr(list), pos = plus(pos, one))
if (car(list) == obj)
return pos;
return nil;
}
val pos(val item, val list, val testfun, val keyfun)
{
val pos = zero;
testfun = default_arg(testfun, equal_f);
keyfun = default_arg(keyfun, identity_f);
for (; list; list = cdr(list), pos = plus(pos, one)) {
val elem = car(list);
val key = funcall1(keyfun, elem);
if (funcall2(testfun, item, key))
return pos;
}
return nil;
}
val pos_if(val pred, val list, val key)
{
val pos = zero;
key = default_arg(key, identity_f);
for (; list; list = cdr(list), pos = plus(pos, one)) {
val item = car(list);
val subj = funcall1(key, item);
if (funcall1(pred, subj))
return pos;
}
return nil;
}
val set_diff(val list1, val list2, val testfun, val keyfun)
{
list_collect_decl (out, ptail);
val list_orig = list1;
testfun = default_arg(testfun, equal_f);
keyfun = default_arg(keyfun, identity_f);
for (; list1; list1 = cdr(list1)) {
/* optimization: list2 is a tail of list1, and so we
are done, unless the application has a weird test function. */
if (list1 == list2) {
break;
} else {
val item = car(list1);
val list1_key = funcall1(keyfun, item);
if (!find(list1_key, list2, testfun, keyfun))
ptail = list_collect(ptail, item);
}
}
return make_like(out, list_orig);
}
val copy(val seq)
{
switch (type(seq)) {
case NIL:
return nil;
case CONS:
case LCONS:
return copy_list(seq);
case LIT:
case STR:
return copy_str(seq);
case VEC:
return copy_vec(seq);
default:
type_mismatch(lit("copy: ~s is not a sequence"), seq, nao);
}
}
val length(val seq)
{
switch (type(seq)) {
case NIL:
return num(0);
case CONS:
case LCONS:
return length_list(seq);
case LIT:
case STR:
return length_str(seq);
case VEC:
return length_vec(seq);
default:
type_mismatch(lit("length: ~s is not a sequence"), seq, nao);
}
}
val sub(val seq, val from, val to)
{
switch (type(seq)) {
case NIL:
return nil;
case CONS:
case LCONS:
return sub_list(seq, from, to);
case LIT:
case STR:
return sub_str(seq, from, to);
case VEC:
return sub_vec(seq, from, to);
default:
type_mismatch(lit("sub: ~s is not a sequence"), cons, nao);
}
}
val ref(val seq, val ind)
{
switch (type(seq)) {
case NIL:
return nil;
case CONS:
case LCONS:
return listref(seq, ind);
case LIT:
case STR:
return chr_str(seq, ind);
case VEC:
return vecref(seq, ind);
default:
type_mismatch(lit("ref: ~s is not a sequence"), cons, nao);
}
}
val refset(val seq, val ind, val newval)
{
switch (type(seq)) {
case NIL:
case CONS:
case LCONS:
return *listref_l(seq, ind) = newval;
case LIT:
case STR:
return chr_str_set(seq, ind, newval);
case VEC:
return *vecref_l(seq, ind) = newval;
default:
type_mismatch(lit("ref: ~s is not a sequence"), cons, nao);
}
return newval;
}
val replace(val seq, val items, val from, val to)
{
switch (type(seq)) {
case NIL:
case CONS:
case LCONS:
return replace_list(seq, items, from, to);
case LIT:
case STR:
return replace_str(seq, items, from, to);
case VEC:
return replace_vec(seq, items, from, to);
default:
type_mismatch(lit("replace: ~s is not a sequence"), cons, nao);
}
}
val update(val seq, val fun)
{
switch (type(seq)) {
case NIL:
break;
case CONS:
case LCONS:
{
val iter = seq;
while (consp(iter)) {
rplaca(iter, funcall1(fun, car(iter)));
iter = cdr(iter);
}
}
break;
case LIT:
case STR:
case VEC:
{
val len = length(seq);
val i;
for (i = zero; lt(i, len); i = plus(i, one))
refset(seq, i, funcall1(fun, ref(seq, i)));
}
break;
case COBJ:
if (hashp(seq))
return hash_update(seq, fun);
/* fallthrough */
default:
type_mismatch(lit("replace: ~s is not a sequence"), cons, nao);
}
return seq;
}
val env(void)
{
if (env_list) {
return env_list;
} else {
list_collect_decl (out, ptail);
#if HAVE_ENVIRON
extern char **environ;
char **iter = environ;
for (; *iter != 0; iter++)
ptail = list_collect(ptail, string_utf8(*iter));
return env_list = out;
#elif HAVE_GETENVIRONMENTSTRINGS
wchar_t *env = GetEnvironmentStringsW();
wchar_t *iter = env;
if (iter == 0)
uw_throwf(error_s, lit("out of memory"), nao);
for (; *iter; iter += wcslen(iter) + 1)
ptail = list_collect(ptail, string(iter));
FreeEnvironmentStringsW(env);
return env_list = out;
#else
uw_throwf(error_s, lit("environment strings not available"), nao);
#endif
}
}
static void obj_init(void)
{
/*
* No need to GC-protect the convenience variables which hold the interned
* symbols, because the interned_syms list holds a reference to all the
* symbols.
*/
protect(&packages, &system_package_var, &keyword_package_var,
&user_package_var, &null_string, &nil_string,
&null_list, &equal_f, &eq_f, &eql_f, &car_f, &cdr_f, &null_f,
&identity_f, &prog_string, &env_list,
(val *) 0);
nil_string = lit("nil");
null_string = lit("");
null_list = cons(nil, nil);
hash_s = make_sym(lit("hash"));
system_package = make_package(lit("sys"));
keyword_package = make_package(lit("keyword"));
user_package = make_package(lit("usr"));
rehome_sym(hash_s, user_package);
/* nil can't be interned because it's not a SYM object;
it works as a symbol because the nil case is handled by
symbol-manipulating function. */
rplacd(gethash_c(user_package->pk.symhash, nil_string, 0), nil);
/* t can't be interned, because intern needs t in order to do its job. */
t = rplacd(gethash_c(user_package->pk.symhash,
lit("t"), 0), make_sym(lit("t")));
set(t->s.package, user_package);
null_s = intern(lit("null"), user_package);
cons_s = intern(lit("cons"), user_package);
str_s = intern(lit("str"), user_package);
lit_s = intern(lit("lit"), user_package);
chr_s = intern(lit("chr"), user_package);
fixnum_s = intern(lit("fixnum"), user_package);
sym_s = intern(lit("sym"), user_package);
pkg_s = intern(lit("pkg"), user_package);
fun_s = intern(lit("fun"), user_package);
vec_s = intern(lit("vec"), user_package);
stream_s = intern(lit("stream"), user_package);
hash_s = intern(lit("hash"), user_package);
hash_iter_s = intern(lit("hash-iter"), user_package);
lcons_s = intern(lit("lcons"), user_package);
lstr_s = intern(lit("lstr"), user_package);
cobj_s = intern(lit("cobj"), user_package);
cptr_s = intern(lit("cptr"), user_package);
env_s = intern(lit("env"), user_package);
bignum_s = intern(lit("bignum"), user_package);
float_s = intern(lit("float"), user_package);
var_s = intern(lit("var"), system_package);
expr_s = intern(lit("expr"), system_package);
regex_s = intern(lit("regex"), system_package);
nongreedy_s = intern(lit("ng0+"), user_package);
compiled_regex_s = intern(lit("compiled-regex"), system_package);
quote_s = intern(lit("quote"), user_package);
qquote_s = intern(lit("qquote"), user_package);
unquote_s = intern(lit("unquote"), user_package);
splice_s = intern(lit("splice"), user_package);
sys_qquote_s = intern(lit("qquote"), system_package);
sys_unquote_s = intern(lit("unquote"), system_package);
sys_splice_s = intern(lit("splice"), system_package);
chset_s = intern(lit("chset"), system_package);
set_s = intern(lit("set"), user_package);
cset_s = intern(lit("cset"), user_package);
wild_s = intern(lit("wild"), user_package);
oneplus_s = intern(lit("1+"), user_package);
zeroplus_s = intern(lit("0+"), user_package);
optional_s = intern(lit("?"), user_package);
compl_s = intern(lit("~"), user_package);
compound_s = intern(lit("compound"), user_package);
or_s = intern(lit("or"), user_package);
and_s = intern(lit("and"), user_package);
quasi_s = intern(lit("quasi"), system_package);
skip_s = intern(lit("skip"), user_package);
trailer_s = intern(lit("trailer"), user_package);
block_s = intern(lit("block"), user_package);
next_s = intern(lit("next"), user_package);
freeform_s = intern(lit("freeform"), user_package);
fail_s = intern(lit("fail"), user_package);
accept_s = intern(lit("accept"), user_package);
all_s = intern(lit("all"), user_package);
some_s = intern(lit("some"), user_package);
none_s = intern(lit("none"), user_package);
maybe_s = intern(lit("maybe"), user_package);
cases_s = intern(lit("cases"), user_package);
collect_s = intern(lit("collect"), user_package);
until_s = intern(lit("until"), user_package);
coll_s = intern(lit("coll"), user_package);
define_s = intern(lit("define"), user_package);
output_s = intern(lit("output"), user_package);
single_s = intern(lit("single"), user_package);
first_s = intern(lit("first"), user_package);
last_s = intern(lit("last"), user_package);
empty_s = intern(lit("empty"), user_package);
repeat_s = intern(lit("repeat"), user_package);
rep_s = intern(lit("rep"), user_package);
flatten_s = intern(lit("flatten"), user_package);
forget_s = intern(lit("forget"), user_package);
local_s = intern(lit("local"), user_package);
merge_s = intern(lit("merge"), user_package);
bind_s = intern(lit("bind"), user_package);
rebind_s = intern(lit("rebind"), user_package);
cat_s = intern(lit("cat"), user_package);
try_s = intern(lit("try"), user_package);
catch_s = intern(lit("catch"), user_package);
finally_s = intern(lit("finally"), user_package);
throw_s = intern(lit("throw"), user_package);
defex_s = intern(lit("defex"), user_package);
deffilter_s = intern(lit("deffilter"), user_package);
eof_s = intern(lit("eof"), user_package);
eol_s = intern(lit("eol"), user_package);
error_s = intern(lit("error"), user_package);
type_error_s = intern(lit("type_error"), user_package);
internal_error_s = intern(lit("internal_error"), user_package);
numeric_error_s = intern(lit("numeric_error"), user_package);
range_error_s = intern(lit("range_error"), user_package);
query_error_s = intern(lit("query_error"), user_package);
file_error_s = intern(lit("file_error"), user_package);
process_error_s = intern(lit("process_error"), user_package);
assert_s = intern(lit("assert"), user_package);
args_k = intern(lit("args"), keyword_package);
nothrow_k = intern(lit("nothrow"), keyword_package);
colon_k = intern(lit(""), keyword_package);
auto_k = intern(lit("auto"), keyword_package);
equal_f = func_n2(equal);
eq_f = func_n2(eq);
eql_f = func_n2(eql);
identity_f = func_n1(identity);
car_f = func_n1(car);
cdr_f = func_n1(cdr);
null_f = func_n1(null);
prog_string = string(progname);
}
val obj_print(val obj, val out)
{
out = default_arg(out, std_output);
switch (type(obj)) {
case NIL:
put_string(lit("nil"), out);
return obj;
case CONS:
case LCONS:
{
val sym = car(obj);
if (sym == quote_s) {
put_char(chr('\''), out);
obj_print(second(obj), out);
} else if (sym == sys_qquote_s) {
put_char(chr('^'), out);
obj_print(second(obj), out);
} else if (sym == sys_unquote_s) {
put_char(chr(','), out);
obj_print(second(obj), out);
} else if (sym == sys_splice_s) {
put_string(lit(",*"), out);
obj_print(second(obj), out);
} else if (sym == vector_lit_s) {
put_string(lit("#"), out);
obj_print(second(obj), out);
} else if (sym == hash_lit_s) {
put_string(lit("#H"), out);
obj_print(rest(obj), out);
} else if (sym == var_s && (symbolp(second(obj)) || integerp(second(obj)))
&& !cdr(cdr(obj)))
{
put_char(chr('@'), out);
obj_print(second(obj), out);
} else if (sym == expr_s) {
put_char(chr('@'), out);
obj_print(rest(obj), out);
} else {
val iter;
val closepar = chr(')');
if (sym == dwim_s && consp(cdr(obj))) {
put_char(chr('['), out);
obj = cdr(obj);
closepar = chr(']');
} else {
put_char(chr('('), out);
}
if (sym == lambda_s && cdr(obj) && symbolp(second(obj))) {
obj_print(sym, out);
if (second(obj)) {
put_string(lit(" (. "), out);
obj_print(second(obj), out);
put_char(chr(')'), out);
} else {
put_string(lit(" ()"), out);
}
iter = (cdr(obj));
goto finish;
}
for (iter = obj; consp(iter); iter = cdr(iter)) {
obj_print(car(iter), out);
finish:
if (nilp(cdr(iter))) {
put_char(closepar, out);
} else if (consp(cdr(iter))) {
put_char(chr(' '), out);
} else {
put_string(lit(" . "), out);
obj_print(cdr(iter), out);
put_char(closepar, out);
}
}
}
}
return obj;
case LIT:
case STR:
{
const wchar_t *ptr;
int semi_flag = 0;
put_char(chr('"'), out);
for (ptr = c_str(obj); *ptr; ptr++) {
if (semi_flag && iswxdigit(*ptr))
put_char(chr(';'), out);
semi_flag = 0;
switch (*ptr) {
case '\a': put_string(lit("\\a"), out); break;
case '\b': put_string(lit("\\b"), out); break;
case '\t': put_string(lit("\\t"), out); break;
case '\n': put_string(lit("\\n"), out); break;
case '\v': put_string(lit("\\v"), out); break;
case '\f': put_string(lit("\\f"), out); break;
case '\r': put_string(lit("\\r"), out); break;
case '"': put_string(lit("\\\""), out); break;
case '\\': put_string(lit("\\\\"), out); break;
case 27: put_string(lit("\\e"), out); break;
default:
if (*ptr >= ' ') {
put_char(chr(*ptr), out);
} else {
format(out, lit("\\x~,02X"), num(*ptr), nao);
semi_flag = 1;
}
}
}
put_char(chr('"'), out);
}
return obj;
case CHR:
{
wchar_t ch = c_chr(obj);
put_string(lit("#\\"), out);
switch (ch) {
case '\0': put_string(lit("nul"), out); break;
case '\a': put_string(lit("alarm"), out); break;
case '\b': put_string(lit("backspace"), out); break;
case '\t': put_string(lit("tab"), out); break;
case '\n': put_string(lit("newline"), out); break;
case '\v': put_string(lit("vtab"), out); break;
case '\f': put_string(lit("page"), out); break;
case '\r': put_string(lit("return"), out); break;
case 27: put_string(lit("esc"), out); break;
case ' ': put_string(lit("space"), out); break;
default:
if (ch >= ' ')
put_char(chr(ch), out);
else
format(out, lit("x~,02x"), num(ch), nao);
}
}
return obj;
case NUM:
case BGNUM:
case FLNUM:
format(out, lit("~s"), obj, nao);
return obj;
case SYM:
if (obj->s.package != user_package) {
if (!obj->s.package)
put_char(chr('#'), out);
else if (obj->s.package != keyword_package)
put_string(obj->s.package->pk.name, out);
put_char(chr(':'), out);
}
put_string(symbol_name(obj), out);
return obj;
case PKG:
format(out, lit("#<package: ~s>"), obj->pk.name, nao);
return obj;
case FUN:
format(out, lit("#<function: type ~a>"), num(obj->f.functype), nao);
return obj;
case VEC:
{
cnum i, length = c_num(obj->v.vec[vec_length]);
put_string(lit("#("), out);
for (i = 0; i < length; i++) {
obj_print(obj->v.vec[i], out);
if (i < length - 1)
put_char(chr(' '), out);
}
put_char(chr(')'), out);
}
return obj;
case LSTR:
if (obj->ls.list)
format(out, lit("#<lazy-string: ~s (~s ...)>"), obj->ls.prefix,
obj->ls.list, nao);
else
obj_print(obj->ls.prefix, out);
return obj;
case COBJ:
obj->co.ops->print(obj, out);
return obj;
case ENV:
format(out, lit("#<environment: ~p>"), (void *) obj, nao);
return obj;
}
format(out, lit("#<garbage: ~p>"), (void *) obj, nao);
return obj;
}
val obj_pprint(val obj, val out)
{
out = default_arg(out, std_output);
switch (type(obj)) {
case NIL:
put_string(lit("nil"), out);
return obj;
case CONS:
case LCONS:
{
val sym = car(obj);
if (sym == quote_s) {
put_char(chr('\''), out);
obj_print(second(obj), out);
} else if (sym == sys_qquote_s) {
put_char(chr('^'), out);
obj_print(second(obj), out);
} else if (sym == sys_unquote_s) {
put_char(chr(','), out);
obj_pprint(second(obj), out);
} else if (sym == sys_splice_s) {
put_string(lit(",*"), out);
obj_pprint(second(obj), out);
} else if (sym == vector_lit_s) {
put_string(lit("#"), out);
obj_print(second(obj), out);
} else if (sym == hash_lit_s) {
put_string(lit("#H"), out);
obj_print(rest(obj), out);
} else if (sym == var_s && (symbolp(second(obj)) || integerp(second(obj)))
&& !cdr(cdr(obj)))
{
put_char(chr('@'), out);
obj_print(second(obj), out);
} else if (sym == expr_s) {
put_char(chr('@'), out);
obj_print(rest(obj), out);
} else {
val iter;
val closepar = chr(')');
if (sym == dwim_s && consp(cdr(obj))) {
put_char(chr('['), out);
obj = cdr(obj);
closepar = chr(']');
} else {
put_char(chr('('), out);
}
if (sym == lambda_s && cdr(obj) && symbolp(second(obj))) {
obj_print(sym, out);
if (second(obj)) {
put_string(lit(" (. "), out);
obj_pprint(second(obj), out);
put_char(chr(')'), out);
} else {
put_string(lit(" ()"), out);
}
iter = (cdr(obj));
goto finish;
}
for (iter = obj; consp(iter); iter = cdr(iter)) {
obj_pprint(car(iter), out);
finish:
if (nilp(cdr(iter))) {
put_char(closepar, out);
} else if (consp(cdr(iter))) {
put_char(chr(' '), out);
} else {
put_string(lit(" . "), out);
obj_pprint(cdr(iter), out);
put_char(closepar, out);
}
}
}
}
return obj;
case LIT:
case STR:
put_string(obj, out);
return obj;
case CHR:
put_char(obj, out);
return obj;
case NUM:
case BGNUM:
case FLNUM:
format(out, lit("~s"), obj, nao);
return obj;
case SYM:
put_string(symbol_name(obj), out);
return obj;
case PKG:
format(out, lit("#<package: ~s>"), obj->pk.name, nao);
return obj;
case FUN:
format(out, lit("#<function: type ~a>"), num(obj->f.functype), nao);
return obj;
case VEC:
{
cnum i, length = c_num(obj->v.vec[vec_length]);
put_string(lit("#("), out);
for (i = 0; i < length; i++) {
obj_pprint(obj->v.vec[i], out);
if (i < length - 1)
put_char(chr(' '), out);
}
put_char(chr(')'), out);
}
return obj;
case LSTR:
if (obj->ls.list)
format(out, lit("#<lazy-string: ~s (~s ...)>"), obj->ls.prefix,
obj->ls.list, nao);
else
obj_pprint(obj->ls.prefix, out);
return obj;
case COBJ:
obj->co.ops->print(obj, out);
return obj;
case ENV:
format(out, lit("#<environment: ~p>"), (void *) obj, nao);
return obj;
}
format(out, lit("#<garbage: ~p>"), (void *) obj, nao);
return obj;
}
val tostring(val obj)
{
val ss = make_string_output_stream();
obj_print(obj, ss);
return get_string_from_stream(ss);
}
val tostringp(val obj)
{
val ss = make_string_output_stream();
obj_pprint(obj, ss);
return get_string_from_stream(ss);
}
val time_sec(void)
{
struct timeval tv;
if (gettimeofday(&tv, 0) == -1)
return nil;
return num(tv.tv_sec);
}
val time_sec_usec(void)
{
struct timeval tv;
if (gettimeofday(&tv, 0) == -1)
return nil;
return cons(num(tv.tv_sec), num(tv.tv_usec));
}
#if !HAVE_GMTIME_R
/*
* Ugly hacks for MingW, which uses the Microsft C Run Time Library,
* whic in turn is stuck in the Dark Ages * without _r functions.
*/
struct tm *gmtime_r(const time_t *timep, struct tm *result);
struct tm *localtime_r(const time_t *timep, struct tm *result);
struct tm *gmtime_r(const time_t *timep, struct tm *result)
{
struct tm *hack = gmtime(timep);
*result = *hack;
return hack;
}
struct tm *localtime_r(const time_t *timep, struct tm *result)
{
struct tm *hack = localtime(timep);
*result = *hack;
return hack;
}
#endif
static val string_time(struct tm *(*break_time_fn)(const time_t *, struct tm *),
char *format, time_t time)
{
char buffer[512] = "";
struct tm broken_out_time;
if (break_time_fn(&time, &broken_out_time) == 0)
return nil;
if (strftime(buffer, sizeof buffer, format, &broken_out_time) == 0)
buffer[0] = 0;
{
wchar_t *wctime = utf8_dup_from(buffer);
return string_own(wctime);
}
}
val time_string_local(val time, val format)
{
time_t secs = c_num(time);
const wchar_t *wcfmt = c_str(format);
char *u8fmt = utf8_dup_to(wcfmt);
val timestr = string_time(localtime_r, u8fmt, secs);
free(u8fmt);
return timestr;
}
val time_string_utc(val time, val format)
{
time_t secs = c_num(time);
const wchar_t *wcfmt = c_str(format);
char *u8fmt = utf8_dup_to(wcfmt);
val timestr = string_time(gmtime_r, u8fmt, secs);
free(u8fmt);
return timestr;
}
static val broken_time_list(struct tm *tms)
{
return list(num(tms->tm_year + 1900),
num_fast(tms->tm_mon + 1),
num_fast(tms->tm_mday),
num_fast(tms->tm_hour),
num_fast(tms->tm_min),
num_fast(tms->tm_sec),
tms->tm_isdst ? t : nil,
nao);
}
val time_fields_local(val time)
{
struct tm tms;
time_t secs = c_num(time);
if (localtime_r(&secs, &tms) == 0)
return nil;
return broken_time_list(&tms);
}
val time_fields_utc(val time)
{
struct tm tms;
time_t secs = c_num(time);
if (gmtime_r(&secs, &tms) == 0)
return nil;
return broken_time_list(&tms);
}
static val make_time_impl(time_t (*pmktime)(struct tm *),
val year, val month, val day,
val hour, val minute, val second,
val isdst)
{
struct tm local = { 0 };
time_t time;
local.tm_year = c_num(year) - 1900;
local.tm_mon = c_num(month) - 1;
local.tm_mday = c_num(day);
local.tm_hour = c_num(hour);
local.tm_min = c_num(minute);
local.tm_sec = c_num(second);
if (!isdst)
local.tm_isdst = 0;
else if (isdst == auto_k)
local.tm_isdst = -1;
else
local.tm_isdst = 1;
time = pmktime(&local);
return time == -1 ? nil : num(time);
}
val make_time(val year, val month, val day,
val hour, val minute, val second,
val isdst)
{
return make_time_impl(mktime, year, month, day, hour, minute, second, isdst);
}
#if !HAVE_TIMEGM
#if !HAVE_SETENV
static void
setenv(const char *name, const char *value, int overwrite)
{
int len = strlen(name)+1+strlen(value)+1;
char *str = (char *) chk_malloc(len);
(void) overwrite;
sprintf(str, "%s=%s", name, value);
putenv(str);
}
static void
unsetenv(const char *name)
{
setenv(name, "", 1);
}
#endif
static time_t timegm_hack(struct tm *tm)
{
time_t ret;
char *tz;
tz = getenv("TZ");
setenv("TZ", "UTC", 1);
#if HAVE_TZSET
tzset();
#endif
ret = mktime(tm);
if (tz)
setenv("TZ", tz, 1);
else
unsetenv("TZ");
#if HAVE_TZSET
tzset();
#endif
env_list = nil;
return ret;
}
#endif
val make_time_utc(val year, val month, val day,
val hour, val minute, val second,
val isdst)
{
#if HAVE_TIMEGM
time_t (*pmktime)(struct tm *) = timegm;
#else
time_t (*pmktime)(struct tm *) = timegm_hack;
#endif
return make_time_impl(pmktime, year, month, day, hour, minute, second, isdst);
}
void init(const wchar_t *pn, mem_t *(*oom)(mem_t *, size_t),
val *stack_bottom)
{
int gc_save;
progname = pn;
gc_save = gc_state(0);
oom_realloc = oom;
gc_init(stack_bottom);
obj_init();
arith_init();
uw_init();
eval_init();
rand_init();
stream_init();
#if HAVE_POSIX_SIGS
sig_init();
#endif
filter_init();
hash_init();
regex_init();
gc_state(gc_save);
}
void dump(val obj, val out)
{
obj_print(obj, out);
put_char(chr('\n'), out);
}
/*
* Handy function for debugging in gdb,
* so we don't have to keep typing:
* (gdb) p dump(something, stdout)
*/
void d(val obj)
{
int save = gc_state(0);
dump(obj, std_output);
gc_state(save);
}
/*
* Function for software breakpoints.
* Debugging routines call here when a breakpoint
* is requested. For this to work, set a breakpoint
* on this function.
*/
void breakpt(void)
{
}