//two args: exp & tail_context
static cellpoint eval_and(void)
{
reg = cdr(args_ref(1));
if (is_true(is_null(reg))){
args_pop(2);
return a_true;
}
stack_push(&vars_stack, reg);
while (is_false(is_null(cdr(reg)))){
//evals the expressions which aren't the last expression
args_push(a_false);
args_push(car(reg));
reg = eval();
if (is_false(reg)){
args_pop(2);
return a_false;
}
//renews the remaining expressions
stack_push(&vars_stack, cdr(stack_pop(&vars_stack)));
reg = stack_top(&vars_stack);
}
//evals the last expression
args_push(args_ref(2));
args_push(car(stack_pop(&vars_stack)));
reg = eval();
args_pop(2);
return reg;
}
void
test_map_pairs (void* data)
{
Map* map = Map_new(runtime);
Map_put(map, hash_for(NIL), NIL, TRUE);
Map_put(map, hash_for(TRUE), TRUE, FALSE);
Map_put(map, hash_for(FALSE), FALSE, NIL);
Vector* pairs = Map_pairs(map);
for (uint64_t i = 0; i < Vector_length(pairs); i++) {
Tuple* pair = Vector_get(pairs, i);
if (is_nil(Tuple_get(pair, 0))) {
tt_assert(is_true(Tuple_get(pair, 1)));
}
else if (is_true(Tuple_get(pair, 0))) {
tt_assert(is_false(Tuple_get(pair, 1)));
}
else if (is_false(Tuple_get(pair, 0))) {
tt_assert(is_nil(Tuple_get(pair, 1)));
}
}
end:
Map_destroy(map);
}
/////////////////////////////////////////////////////////////
//apply
//requires three arguments:proc , args & tail_context
////////////////////////////////////////////////////////////
cellpoint apply(void)
{
if (is_true(is_prim_proc(args_ref(1)))){
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = apply_prim_proc();
}else if (is_true(is_compound_proc(args_ref(1)))){
//if this application isn't in a tail context,
//then store the current_env
if (is_false(args_ref(3))){
stack_push(&env_stack, current_env);
}
/*for test
test the tail recursion
*/
// printf("call ");
// write(args_ref(1));
// newline();
// args_push(env_stack);
// printf("the length of env_stack: %d\n", get_integer(list_len()));
//calls procedure_parameters
args_push(args_ref(1));
reg = procedure_parameters();
stack_push(&vars_stack, reg);
//calls procedure_env
args_push(args_ref(1));
reg = procedure_env();
//calls extend_env
stack_push(&vars_stack, args_ref(2));
args_push(reg);
args_push(stack_pop(&vars_stack));
args_push(stack_pop(&vars_stack));
current_env = extend_env();
//calls procedure_body
args_push(args_ref(1));
reg = procedure_body();
//calls eval_lambda_body
args_push(reg);
reg = eval_lambda_body();
//if this application isn't in tail context,
//then restore the stored current_env
if (is_false(args_ref(3))){
current_env = stack_pop(&env_stack);
}
}else {
printf("Unknown procedure : ");
write(args_ref(1));
newline();
error_handler();
}
args_pop(3);
return reg;
}
//one arg: body
static cellpoint eval_lambda_body(void)
{
stack_push(&vars_stack, args_ref(1));
args_push(stack_top(&vars_stack));
reg = last_exp();
while (is_false(reg)){
args_push(stack_top(&vars_stack));
reg = first_exp();
//eval the exp which isn't the last one with tail_context is a_false
args_push(a_false);
args_push(reg);
reg = eval();
//renew the remain exps
args_push(stack_pop(&vars_stack));
reg = rest_exps();
stack_push(&vars_stack, reg);
args_push(stack_top(&vars_stack));
reg = last_exp();
}
//get the last expression
args_push(stack_pop(&vars_stack));
reg = first_exp();
//eval the last expression with the tail_context is a_true
args_push(a_true);
args_push(reg);
reg = eval();
args_pop(1);
return reg;
}
//two args: exps & tail_context
static cellpoint eval_sequence(void)
{
stack_push(&vars_stack, args_ref(1));
args_push(stack_top(&vars_stack));
reg = last_exp();
while (is_false(reg)){
args_push(stack_top(&vars_stack));
reg = first_exp();
//eval the exp which isn't the last one with tail_context is a_false
args_push(a_false);
args_push(reg);
reg = eval();
//renew the remain exps
args_push(stack_pop(&vars_stack));
reg = rest_exps();
stack_push(&vars_stack, reg);
args_push(stack_top(&vars_stack));
reg = last_exp();
}
//get the last expression
args_push(stack_pop(&vars_stack));
reg = first_exp();
//eval the last expression with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
reg = eval();
args_pop(2);
return reg;
}
bool BreakPoint::enabled() const
{
return
(is_false(real_condition())) ?
false :
myenabled;
}
TAMObject *core_and (TAMObject *arguments, void *data, TAMEnv *env)
{
LispCoreData *d = data;
TAMObject *arg, *last = NULL;
ASSERT(arguments);
ASSERT(data);
ASSERT(env);
ASSERT(arguments == d->arg_list_cache_3);
arg = tam_env_symbol_lookup(env, d->rest);
ASSERT(arg);
while (!tam_object_istype_byname(arg, "nil"))
{
last = tam_object_pair_car(arg);
ASSERT(last);
if (tam_env_error_test(env))
return tam_env_nil_get(env);
if (is_false(last))
return last;
arg = tam_object_pair_cdr(arg);
}
if (last)
return last;
return tam_env_true_get(env);
}
char logic_not_pyobj(pyobj v)
{
if (is_false(v))
return 1;
else
return 0;
}
//two args: vec1 & vec2
cellpoint vector_eq(void)
{
int len1 = vector_len(args_ref(1));
int len2 = vector_len(args_ref(2));
int i;
if (args_ref(1) == args_ref(2)){
args_pop(2);
return a_true;
}
if (len1 != len2){
args_pop(2);
return a_false;
}
for (i=0; i < len1; ++i){
reg = vector_ref(args_ref(1), i);
args_push(vector_ref(args_ref(2), i));
args_push(reg);
reg = equal();
if (is_false(reg)){
args_pop(2);
return a_false;
}
}
args_pop(2);
return a_true;
}
TAMObject *core_or (TAMObject *arguments, void *data, TAMEnv *env)
{
LispCoreData *d = data;
TAMObject *arg;
ASSERT(arguments);
ASSERT(data);
ASSERT(env);
ASSERT(arguments == d->arg_list_cache_3);
arg = tam_env_symbol_lookup(env, d->rest);
ASSERT(arg);
while (!tam_object_istype_byname(arg, "nil"))
{
TAMObject *x;
x = tam_object_pair_car(arg);
ASSERT(x);
if (tam_env_error_test(env))
return tam_env_nil_get(env);
if (!is_false(x))
return x;
arg = tam_object_pair_cdr(arg);
}
return tam_env_false_get(env);
}
action_result assert_cc_action(hypothesis_idx hidx) {
if (!get_config().m_cc)
return action_result::failed();
congruence_closure & cc = get_cc();
if (has_expr_metavar(curr_state().get_hypothesis_decl(hidx).get_type()))
return action_result::failed();
cc.add(hidx);
// cc.display();
if (cc.is_inconsistent()) {
try {
app_builder & b = get_app_builder();
expr false_proof = *cc.get_inconsistency_proof();
trace_action("contradiction by congruence closure");
return action_result(b.mk_false_rec(curr_state().get_target(), false_proof));
} catch (app_builder_exception &) {
return action_result::failed();
}
} else {
expr const & target = curr_state().get_target();
name R; expr lhs, rhs;
if (is_relation_app(target, R, lhs, rhs) && cc.is_eqv(R, lhs, rhs)) {
expr proof = *cc.get_eqv_proof(R, lhs, rhs);
trace_action("equivalence by congruence closure");
return action_result(proof);
} else if (is_prop(target) && !is_false(target) && cc.proved(target)) {
expr proof = *cc.get_proof(target);
trace_action("equivalent to true by congruence closure");
return action_result(proof);
} else {
return action_result::new_branch();
}
}
}
/*
** If the "proxy" setting is defined, then change the URL settings
** (initialized by a prior call to url_parse()) so that the HTTP
** header will be appropriate for the proxy and so that the TCP/IP
** connection will be opened to the proxy rather than to the server.
**
** If zMsg is not NULL and a proxy is used, then print zMsg followed
** by the canonical name of the proxy (with userid and password suppressed).
*/
void url_enable_proxy(const char *zMsg){
const char *zProxy;
zProxy = zProxyOpt;
if( zProxy==0 ){
zProxy = db_get("proxy", 0);
if( zProxy==0 || zProxy[0]==0 || is_truth(zProxy) ){
zProxy = fossil_getenv("http_proxy");
}
}
if( zProxy && zProxy[0] && !is_false(zProxy) ){
char *zOriginalUrl = g.urlCanonical;
char *zOriginalHost = g.urlHostname;
char *zOriginalUser = g.urlUser;
char *zOriginalPasswd = g.urlPasswd;
g.urlUser = 0;
g.urlPasswd = "";
url_parse(zProxy);
if( zMsg ) fossil_print("%s%s\n", zMsg, g.urlCanonical);
g.urlPath = zOriginalUrl;
g.urlHostname = zOriginalHost;
if( g.urlUser ){
char *zCredentials1 = mprintf("%s:%s", g.urlUser, g.urlPasswd);
char *zCredentials2 = encode64(zCredentials1, -1);
g.urlProxyAuth = mprintf("Basic %z", zCredentials2);
free(zCredentials1);
}
g.urlUser = zOriginalUser;
g.urlPasswd = zOriginalPasswd;
}
}
//one arg: exp
static cellpoint letstar_2_nested_lets(void)
{
//get the reverse list of bindings list
args_push(args_ref(1));
reg = letstar_bindings();
args_push(reg);
reg = reverse();
stack_push(&vars_stack, reg);
//get body of let* expression
args_push(args_ref(1));
reg = letstar_body();
//create nested lets
if (is_true(is_null(stack_top(&vars_stack)))){
args_push(reg);
args_push(stack_pop(&vars_stack));
reg = make_let();
}else {
while (is_false(is_null(stack_top(&vars_stack)))){
check_bindings("let*", car(stack_top(&vars_stack)), args_ref(1));
args_push(reg);
args_push(cons(car(stack_top(&vars_stack)), NIL));
reg = make_let();
reg = cons(reg, NIL);
//renews bingdings
stack_push(&vars_stack, cdr(stack_pop(&vars_stack)));
}
stack_pop(&vars_stack);
reg = car(reg);
}
args_pop(1);
return reg;
}
void guardt::add(const exprt &expr)
{
assert(expr.type().id()==ID_bool);
if(is_false() || expr.is_true())
return;
else if(is_true() || expr.is_false())
{
*this=expr;
return;
}
else if(id()!=ID_and)
{
and_exprt a;
a.copy_to_operands(*this);
*this=a;
}
operandst &op=operands();
if(expr.id()==ID_and)
op.insert(op.end(),
expr.operands().begin(),
expr.operands().end());
else
op.push_back(expr);
}
/*
** Clearsign the given blob. Put the signed version in
** pOut.
*/
int clearsign(Blob *pIn, Blob *pOut){
char *zRand;
char *zIn;
char *zOut;
char *zBase = db_get("pgp-command", "gpg --clearsign -o ");
char *zCmd;
int rc;
if( is_false(zBase) ){
return 0;
}
zRand = db_text(0, "SELECT hex(randomblob(10))");
zOut = mprintf("out-%s", zRand);
zIn = mprintf("in-%z", zRand);
blob_write_to_file(pIn, zOut);
zCmd = mprintf("%s %s %s", zBase, zIn, zOut);
rc = fossil_system(zCmd);
free(zCmd);
if( rc==0 ){
if( pOut==pIn ){
blob_reset(pIn);
}
blob_zero(pOut);
blob_read_from_file(pOut, zIn);
}else{
if( pOut!=pIn ){
blob_copy(pOut, pIn);
}
}
file_delete(zOut);
file_delete(zIn);
free(zOut);
free(zIn);
return rc;
}
string BreakPoint::condition() const
{
return
(is_false(real_condition())) ?
real_condition().after(and_op()) :
real_condition();
}
result test_string_substring_EmptyStringNULL() {
int passed = 0;
char* description = "string_substring(char*, char*) : EmptyStringNULL CASE";
passed = is_false(string_substring("", 0));
return (result){passed, description};
}
result test_string_equals_StringWithOtherString() {
int passed = 0;
char* description = "string_equals(char*, char*) : StringWithOtherString CASE";
passed = is_false(string_equals("abc", "efg"));
return (result){passed, description};
}
result test_string_equals_NULL() {
int passed = 0;
char* description = "string_equals(char*, char*) : NULL CASE";
passed = is_false(string_equals(0, 0));
return (result){passed, description};
}
result test_string_substring_StringWithBiggerSuperstring() {
int passed = 0;
char* description = "string_substring(char*, char*) : StringWithBiggerSuperstring CASE";
passed = is_false(string_substring("abc", "abcdefg"));
return (result){passed, description};
}
// Make COND `false' or `false and COND'
string BreakPoint::make_false(const string& cond)
{
if (is_false(cond))
return cond;
else if (cond.empty())
return false_value();
else
return false_value() + and_op() + cond;
}
void
test_map_delete (void* data)
{
Map* map = Map_new(runtime);
Tuple* pair = Map_put(map, hash_for(TRUE), TRUE, FALSE);
tt_assert(is_true(Tuple_get(pair, 0)));
tt_assert(is_false(Tuple_get(pair, 1)));
pair = Map_delete(map, hash_for(TRUE));
tt_assert(is_true(Tuple_get(pair, 0)));
tt_assert(is_false(Tuple_get(pair, 1)));
tt_assert(!Map_has(map, hash_for(TRUE)));
end:
Map_destroy(map);
}
//three args: pred, consq & alter
static cellpoint make_if(void)
{
reg = NIL;
if (is_false(is_null(args_ref(3)))){
reg = cons(args_ref(3), NIL);
}
reg = cons(args_ref(2), reg);
reg = cons(args_ref(1), reg);
reg = cons(make_symbol("if"), reg);
args_pop(3);
return reg;
}
/*
** If the "proxy" setting is defined, then change the URL settings
** (initialized by a prior call to url_parse()) so that the HTTP
** header will be appropriate for the proxy and so that the TCP/IP
** connection will be opened to the proxy rather than to the server.
**
** If zMsg is not NULL and a proxy is used, then print zMsg followed
** by the canonical name of the proxy (with userid and password suppressed).
*/
void url_enable_proxy(const char *zMsg){
const char *zProxy;
zProxy = zProxyOpt;
if( zProxy==0 ){
zProxy = db_get("proxy", 0);
if( zProxy==0 || zProxy[0]==0 || is_false(zProxy) ){
zProxy = fossil_getenv("http_proxy");
}
}
if( zProxy && zProxy[0] && !is_false(zProxy)
&& !g.url.isSsh && !g.url.isFile ){
char *zOriginalUrl = g.url.canonical;
char *zOriginalHost = g.url.hostname;
int fOriginalIsHttps = g.url.isHttps;
char *zOriginalUser = g.url.user;
char *zOriginalPasswd = g.url.passwd;
char *zOriginalUrlPath = g.url.path;
int iOriginalPort = g.url.port;
unsigned uOriginalFlags = g.url.flags;
g.url.user = 0;
g.url.passwd = "";
url_parse(zProxy, 0);
if( zMsg ) fossil_print("%s%s\n", zMsg, g.url.canonical);
g.url.path = zOriginalUrl;
g.url.hostname = zOriginalHost;
if( g.url.user ){
char *zCredentials1 = mprintf("%s:%s", g.url.user, g.url.passwd);
char *zCredentials2 = encode64(zCredentials1, -1);
g.url.proxyAuth = mprintf("Basic %z", zCredentials2);
free(zCredentials1);
}
g.url.user = zOriginalUser;
g.url.passwd = zOriginalPasswd;
g.url.isHttps = fOriginalIsHttps;
g.url.useProxy = 1;
g.url.proxyUrlPath = zOriginalUrlPath;
g.url.proxyOrigPort = iOriginalPort;
g.url.flags = uOriginalFlags;
}
}
//one arg: exp
static cellpoint letstar_bindings(void)
{
reg = cdr(args_ref(1));
if (is_true(is_null(reg)) || is_false(is_list(car(reg)))){
printf("let*: Bad syntax in: ");
write(args_ref(1));
newline();
error_handler();
}
reg = car(reg);
args_pop(1);
return reg;
}
/* stack operator
**sel** (?)
> Selects one of the top two values on the stack:
> `{f} {X} {Y}| -> {X}|`
> `{t} {X} {Y}| -> {Y}|`
> `{f} [X] {Y}| -> [X]|`
> `{t} [X] {Y}| -> {Y}|`
> etc.
>
> Where f = 0 and t != 0
*/
bvm_cache *sel(bvm_cache *this_bvm){ // sel#
mword *temp = pop_udr_stack(this_bvm->dstack_ptr);
if(!is_false(icar(temp))){
popd(this_bvm);
}
else{
remove_from_udr_stack(this_bvm, this_bvm->dstack_ptr, 1);
}
return this_bvm;
}
static void check_bindings(char *proc, cellpoint binding, cellpoint exp)
{
if (is_true(is_list(binding))){
if (is_true(is_symbol(car(binding))) &&
is_false(is_null(cdr(binding))) &&
is_true(is_null(cdr(cdr(binding))))){
return;
}
}
printf("%s: Bad syntax (no an identifier and expression for binding) in: ", proc);
write(exp);
newline();
error_handler();
}
//one arg: exp
static cellpoint let_vals(void)
{
args_push(args_ref(1));
reg = let_bindings();
stack_push(&vars_stack, NIL);
while (is_false(is_null(reg))){
check_bindings("let", car(reg), args_ref(1));
stack_push(&vars_stack, cons(car(cdr(car(reg))), stack_pop(&vars_stack)));
reg = cdr(reg);
}
args_push(stack_pop(&vars_stack));
reg = reverse();
args_pop(1);
return reg;
}
//apply
static cellpoint combine_args(cellpoint arglst)
{
if (is_true(is_null(cdr(arglst)))){
cellpoint last_arg = car(arglst);
if (is_false(is_list(last_arg))){
printf("Error: the procedure \"apply\" expects the last argument must be a list, but given: ");
write(last_arg);
newline();
error_handler();
}
return last_arg;
}else {
return cons(car(arglst), combine_args(cdr(arglst)));
}
}
//one arg: exp
static cellpoint definition_variable(void)
{
reg = cdr(args_ref(1));
if (is_true(is_null(reg))){
printf("define: bad syntax in:");
write(args_ref(1));
newline();
error_handler();
}
reg = car(reg);
if (is_false(is_symbol(reg))){
reg = car(reg);
}
args_pop(1);
return reg;
}
