// ### %set-documentation object doctype new-value => new-value Value SYS_set_documentation_internal(Value object, Value doctype, Value new_value) { Value alist = DOCUMENTATION_HASH_TABLE->get(object); Value entry; if (alist == NULL_VALUE) { // no alist if (new_value != NIL) { entry = make_cons(doctype, new_value); alist = make_cons(entry, NIL); DOCUMENTATION_HASH_TABLE->put(object, alist); } } else { entry = EXT_assq(doctype, alist); if (consp(entry)) the_cons(entry)->setcdr(new_value); else if (new_value != NIL) { // no entry entry = make_cons(doctype, new_value); alist = make_cons(entry, alist); DOCUMENTATION_HASH_TABLE->put(object, alist); } } return new_value; }
// ### fasl-read-backquote stream character => value Value SYS_fasl_read_backquote(Value streamarg, Value ignored) { // Stream * stream = check_ansi_stream(streamarg); // return make_cons(S_backquote, // make_cons(stream->read(true, NIL, true, current_thread(), FASL_READTABLE))); return make_cons(S_backquote, make_cons(stream_read(streamarg, true, NIL, true, current_thread(), FASL_READTABLE))); }
Value merge_directories(Value dir, Value default_dir) { if (dir == NIL) return default_dir; if (car(dir) == K_relative && default_dir != NIL) { Value temp = NIL; while (default_dir != NIL) { temp = make_cons(car(default_dir), temp); default_dir = xcdr(default_dir); } dir = cdr(dir); // Skip :RELATIVE. while (dir != NIL) { temp = make_cons(car(dir), temp); dir = xcdr(dir); } // Value[] array = result.copyToArray(); // for (long i = 0; i < array.length - 1; i++) // { // if (array[i] == Keyword.BACK) // { // if (array[i+1] instanceof AbstractString || array[i+1] == Keyword.WILD) // { // array[i] = null; // array[i+1] = null; // } // } // } // result = NIL; // for (long i = 0; i < array.length; i++) // { // if (array[i] != null) // result = new Cons(array[i], result); // } Value result = NIL; while (temp != NIL) { Value first = car(temp); if (first == K_back) { Value second = CL_cadr(temp); if (stringp(second) || second == K_wild) { temp = CL_cddr(temp); continue; } } result = make_cons(first, result); temp = xcdr(temp); } return result; } else return dir; }
// ### multiple-value-call Value CL_multiple_value_call(Value args, Environment * env, Thread * thread) { const unsigned long numargs = length(args); if (numargs == 0) return wrong_number_of_arguments(S_multiple_value_call, numargs, 1, MANY); Function * function; Value value = eval(car(args), env, thread); args = xcdr(args); if (symbolp(value)) { Symbol * sym = the_symbol(value); if (sym->is_special_operator() || sym->is_macro() || (function = (Function *) sym->function()) == NULL) { String * string = new String("The symbol "); string->append(sym->prin1_to_string()); string->append(" does not designate a function."); return signal_lisp_error(new Error(string)); } } else if (functionp(value)) function = the_function(value); else { String * string = new String("The value "); string->append(::prin1_to_string(value)); string->append(" does not designate a function."); return signal_lisp_error(new Error(string)); } Value list = NIL; while (args != NIL) { Value result = eval(car(args), env, thread); if (thread->values_length() >= 0) { Value * values = thread->values(); const long limit = thread->values_length(); for (long i = 0; i < limit; i++) list = make_cons(values[i], list); } else list = make_cons(result, list); args = xcdr(args); } unsigned long len = length(list); Value * funcall_args = new (GC) Value[len + 1]; funcall_args[0] = make_value(function); if (list != NIL) { for (long i = len; i > 0; i--) { funcall_args[i] = xcar(list); list = xcdr(list); } } return CL_funcall(len + 1, funcall_args); }
cons_t split(cons_t *ls, int n){ if(n == 0){ return (cons_t){.car = NULL, .cdr = ls}; } cons_t *ret = make_cons(POP(ls), NULL); cons_t *ptr = ret; while(--n && ls){ XSETCDR(ptr, make_cons(POP(ls), NULL)); ptr = XCDR(ptr); } return (cons_t){.car = ret, .cdr = ls}; }
static cons_t* mergesort_cons(cons_t *input, cmp_fun cmp){ if(!input || !XCDR(input)){ return input; } cons_t *head = NULL, *tail = NULL; while(input){ head = make_cons(POP(input, head)); if(!input){break;} tail = make_cons(POP(input, tail)); } head = mergesort_cons(head, cmp); tail = mergesort_cons(tail, cmp); return merge_cons(head, tail, cmp); }
Cons values2cons(Values vals) { Cons cur, head, pre; values_t v; pre = head = make_cons(lt_nil, lt_nil); v = theVALUES(vals); for (int i = 0; i < v->count; i++) { cur = make_cons(v->objs[i], lt_nil); set_cdr(pre, cur); pre = cur; } return CDR(head); }
// ### primitive-format Value SYS_primitive_format(unsigned int numargs, Value args[]) { if (numargs < 2) return wrong_number_of_arguments(S_format, numargs, 2, MANY); Value destination = args[0]; Value format_control = args[1]; Value format_arguments = NIL; for (long i = numargs; i-- > 2;) format_arguments = make_cons(args[i], format_arguments); String * string = format_to_string(format_control, format_arguments); if (destination == T) { AnsiStream * out = check_ansi_stream(current_thread()->symbol_value(S_standard_output)); out->write_string(string); return NIL; } if (destination == NIL) return make_value(string); // REVIEW if (ansi_stream_p(destination)) { the_ansi_stream(destination)->write_string(string); return NIL; } assert(false); return NIL; }
Value Array_T::dimensions() const { Value result = NIL; for (unsigned long i = _rank; i-- > 0;) result = make_cons(make_fixnum(_dimensions[i]), result); return result; }
CELL func_string_to_list(CELL frame) { CELL string = FV0; if (!STRINGP(string)) { return make_exception("expects string"); } CELL result = V_NULL; CELL pre_tail = V_EMPTY; gc_root_3("func_string_to_list", string, result, pre_tail); const size_t len = GET_STRING(string)->len; int i; for(i = 0; i < len; ++i) { const CELL next = make_cons(make_char(GET_STRING(string)->data[i]), V_NULL); if (i == 0) { result = next; } else { CDR(pre_tail) = next; } pre_tail = next; } gc_unroot(); return result; }
CELL func_append(CELL frame) { if (FC == 0) { return V_NULL; } CELL pre_tail = V_EMPTY; CELL result = V_EMPTY; CELL arg = V_EMPTY; gc_root_4("func_append", frame, pre_tail, result, arg); result = FV[FC-1]; int argi = 0; while(argi < FC-1) { arg = FV[argi++]; while(CONSP(arg)) { const CELL next = make_cons(CAR(arg), FV[FC-1]); if (EMPTYP(pre_tail)) { pre_tail = result = next; } else { pre_tail = CDR(pre_tail) = next; } arg = CDR(arg); } if (!NULLP(arg)) { gc_unroot(); return make_exception("expects a <proper list> for all but last argument"); } } gc_unroot(); return result; }
CELL make_name_counted(char* s, size_t len) { CELL list = g_interned_names; for( ; !NULLP(list); list = CDR(list)) { CELL name = CAR(list); NAME* p = GET_NAME(name); if (p->len == len && (opt_case_sensitive ? strncmp : strncasecmp)(p->data, s, len) == 0) { return name; } } CELL name = make_raw_name_counted(len); NAME* p = GET_NAME(name); if (opt_case_sensitive) { memcpy(p->data, s, len); } else { int i; for(i=0; i<len; ++i) { p->data[i] = tolower(s[i]); } } gc_root_1("make_name_counted", name); g_interned_names = make_cons(name, g_interned_names); gc_unroot(); return name; }
CELL make_keyword_counted(char* s, size_t len) { CELL list = g_interned_keywords; for( ; !NULLP(list); list = CDR(list)) { CELL keyword = CAR(list); KEYWORD* p = GET_KEYWORD(keyword); if (p->len == len && (opt_case_sensitive ? strncmp : strncasecmp)(p->data, s, len) == 0) { return keyword; } } CELL keyword = make_raw_keyword_counted(len); KEYWORD* p = GET_KEYWORD(keyword); if (opt_case_sensitive) { memcpy(p->data, s, len); } else { int i; for(i=0; i<len; ++i) { GET_KEYWORD(keyword)->data[i] = tolower(s[i]); } } gc_root_1("make_keyword_counted", keyword); g_interned_keywords = make_cons(keyword, g_interned_keywords); gc_unroot(); return keyword; }
// ### fasl-sharp-left-paren stream sub-char numarg => value Value SYS_fasl_sharp_left_paren(Value streamarg, Value subchar, Value numarg) { Thread * thread = current_thread(); if (thread->symbol_value(S_read_suppress) != NIL) { stream_read_list(streamarg, true, thread, FASL_READTABLE); return NIL; } if (numarg != NIL && thread->symbol_value(S_backquote_count) == FIXNUM_ZERO) return stream_read_vector(streamarg, check_index(numarg), thread, FASL_READTABLE); Value list = stream_read_list(streamarg, true, thread, FASL_READTABLE); if (thread->symbol_value(S_backquote_count) == FIXNUM_ZERO) { if (numarg != NIL) { INDEX len = check_index(numarg); SimpleVector * vector = new_simple_vector(len); for (INDEX i = 0; i < len; i++) { vector->inline_xaset(i, car(list)); if (cdr(list) != NIL) list = xcdr(list); } return make_value(vector); } return make_value(new_simple_vector(list)); } return make_cons(thread->symbol_value(S_backquote_vector_flag), list); }
Value parse_logical_pathname_directory(AbstractString * s) { Value result; unsigned long i; if (s->length() > 1 && s->char_at(0) == ';') { result = make_cons(K_relative); i = 1; } else { result = make_cons(K_absolute); i = 0; } const unsigned long limit = s->length(); while (i < limit) { String * token = new String(); while (i < limit) { char c = s->char_at(i++); if (is_separator_char(c)) break; else token->append_char(c); } Value value; if (token->equal("*")) value = K_wild; else if (token->equal("**")) value = K_wild_inferiors; else if (token->equal("..")) { if (stringp(car(result))) { result = cdr(result); continue; } value = K_up; } else value = make_value(token); result = make_cons(value, result); } return CL_nreverse(result); }
// returns a list static Value structure_class_instance_slots() { Value instance_slots = NIL; instance_slots = make_cons(S_direct_methods, instance_slots); instance_slots = make_cons(S_prototype, instance_slots); instance_slots = make_cons(S_name, instance_slots); instance_slots = make_cons(S_layout, instance_slots); instance_slots = make_cons(S_precedence_list, instance_slots); instance_slots = make_cons(S_direct_superclasses, instance_slots); instance_slots = make_cons(S_direct_subclasses, instance_slots); instance_slots = make_cons(S_direct_slots, instance_slots); instance_slots = make_cons(S_slots, instance_slots); return CL_nreverse(instance_slots); }
Cons parse_cons(char *string, int *offset) { Cons cur, head, pre; int step; pre = head = make_cons(lt_nil, lt_nil); for (int i = 0; string[i] != '\0'; i += step) { switch (string[i]) { case '(': cur = make_cons(parse_cons(string + i + 1, &step), lt_nil); break; case ' ': case '\n': step = 1; continue; case ')': *offset = i + 2; pre = CDR(head); free_cons(head); return pre; case '\'': { /* Symbol quote; */ LispObject obj; /* quote = S("QUOTE"); */ obj = parse_sexp(string + i + 1, &step); /* cur = make_cons(make_cons(S("QUOTE"), make_cons(obj, lt_nil)), lt_nil); */ cur = make_cons(make_list(S("QUOTE"), obj), lt_nil); step++; break; } default : cur = make_cons(parse_atom(string + i, &step), lt_nil); } set_cdr(pre, cur); pre = cur; } pre = CDR(head); free_cons(head); return pre; }
static cons_t* merge_cons(cons_t *A, cons_t *B, cmp_fun cmp){ cons_t *ret = NULL; while(A && B){ if(cmp(XCAR(A),XCAR(B))){ ret = make_cons(XCAR(A), ret); A = XCDR(A); } else { ret = make_cons(XCDR(B), ret); B = XCDR(B); } } //Only one of these loops will run while(A){ ret = make_cons(XCAR(A), ret); } while(B){ ret = make_cons(XCAR(B), ret); } }
// ### record-source-information Value SYS_record_source_information(Value name, Value source_position) { if (non_nil_symbol_p(name)) // FIXME support setf functions too { Thread * thread = current_thread(); Value source = thread->symbol_value(S_source_file); the_non_nil_symbol(name)->put(S_source_internal, source != NIL ? make_cons(source, source_position) : NIL); } return T; }
CELL func_list(CELL frame) { if (FC == 0) { return V_NULL; } CELL result = V_EMPTY; CELL pre_tail = V_EMPTY; gc_root_3("func_list", frame, result, pre_tail); int argi = 0; pre_tail = result = make_cons(FV[argi++], V_NULL); while(argi < FC) { const CELL next = make_cons(FV[argi++], V_NULL); pre_tail = CDR(pre_tail) = next; } gc_unroot(); return result; }
// ### make-structure-class name include slots => class Value SYS_make_structure_class(Value name, Value slots, Value include) { if (!symbolp(name)) return signal_type_error(name, S_symbol); if (!listp(slots)) return signal_type_error(name, S_list); StructureClass * c = new StructureClass(name, slots); if (include != NIL) { Value included_class = find_class(include); if (included_class == NULL_VALUE) { String * message = new String(::prin1_to_string(include)); message->append(" does not name a class."); return signal_lisp_error(message); } c->set_cpl(make_cons(make_value(c), the_class(included_class)->cpl())); } else c->set_cpl(make_cons(make_value(c), the_class(C_structure_object)->cpl())); return add_class(name, make_value(c)); }
CELL func_reverse(CELL frame) { CELL list = FV0; CELL result = V_NULL; gc_root_2("func_reverse", list, result); while(CONSP(list)) { result = make_cons(CAR(list), result); list = CDR(list); } if (!NULLP(list)) { gc_unroot(); return make_exception("expects a <proper list>"); } gc_unroot(); return result; }
static WispObject * find_date_matches (WispObject *database, char *key, char *string) { WispObject *result = NIL; while (database != NIL) { WispObject *entry; char *contents; entry = CAR (database); database = CDR (database); contents = sassoc (key, entry); if (contents != (char *)NULL) { char *buff = strdup (contents); char *temp = strchr (buff, '/'); if (temp != (char *)NULL) { char *temp1; char dstring[20]; int month, day; *temp = '\0'; month = atoi (buff); temp++; temp1 = strchr (temp, '/'); if (temp1 != (char *)NULL) *temp1 = '\0'; day = atoi (temp); sprintf (dstring, "%02d/%02d", month, day); if (strcasestr (dstring, string) != (char *)NULL) result = make_cons (entry, result); } free (buff); } } return (result); }
Value Function::parts() { String * description = new String(prin1_to_string()); description->append_char('\n'); Value elements = NIL; Value name = operator_name(); elements = make_cons(make_cons(make_simple_string("NAME"), name != NULL_VALUE ? name : NIL), elements); elements = make_cons(make_cons(make_simple_string("ARITY"), make_fixnum(arity())), elements); elements = make_cons(make_cons(make_simple_string("MINARGS"), make_fixnum(minargs())), elements); elements = make_cons(make_cons(make_simple_string("MAXARGS"), make_fixnum(maxargs())), elements); return current_thread()->set_values(make_value(description), T, CL_nreverse(elements)); }
object_t *parse_list(FILE *fp){ cons_t tmp_cons; char buf; buf=skip_space_getchar(fp); tmp_cons.car = parse_sexp(fp); buf=skip_space_getchar(fp); if(buf == ')'){ tmp_cons.cdr = NULL; } else{ ungetc(buf,fp); tmp_cons.cdr = parse_list_inner(fp); } return make_cons(tmp_cons.car,tmp_cons.cdr); }
sexp_t *prim_append(sexp_t *args) { sexp_t *lst, *ret; if (list_len(args) == 0) return nil; if (isnil(car(args))) return prim_append(cdr(args)); if (isnil(cdr(args))) return copy_list(car(args)); if (!iscons(car(args)) || list_len(car(args)) < 0) { fprintf(stderr, "error: proper list expected\n"); return NULL; } for (ret = lst = copy_list(car(args)); cdr(lst) != nil; lst = cdr(lst)) ; gc_push(&ret); lst->data = make_cons(car(lst), prim_append(cdr(args))); gc_pop(); return ret; }
static WispObject * find_matches (WispObject *database, char *key, char *string) { WispObject *result = NIL; while (database != NIL) { WispObject *entry; char *contents; entry = CAR (database); database = CDR (database); contents = sassoc (key, entry); if ((contents != (char *)NULL) && (strcasestr (contents, string) != (char *)NULL)) result = make_cons (entry, result); } return (result); }
CELL make_name_from_string(CELL string) { const char* data = GET_STRING(string)->data; const size_t len = GET_STRING(string)->len; CELL list = g_interned_names; for( ; !NULLP(list); list = CDR(list)) { CELL name = CAR(list); NAME* p = GET_NAME(name); if (p->len == len && memcmp(p->data, data, len) == 0) { return name; } } CELL name = V_EMPTY; gc_root_2("make_name_from_string", string, name); name = make_raw_name_counted(len); memcpy(GET_NAME(name)->data, GET_STRING(string)->data, len); g_interned_names = make_cons(name, g_interned_names); gc_unroot(); return name; }
CELL make_keyword_from_string(CELL string) { const char* data = GET_STRING(string)->data; const size_t len = GET_STRING(string)->len; CELL list = g_interned_keywords; for( ; !NULLP(list); list = CDR(list)) { CELL keyword = CAR(list); KEYWORD* p = GET_KEYWORD(keyword); if (p->len == len && memcmp(p->data, data, len) == 0) { return keyword; } } CELL keyword = V_EMPTY; gc_root_2("make_keyword_from_string", string, keyword); keyword = make_raw_keyword_counted(len); memcpy(GET_KEYWORD(keyword)->data, GET_STRING(string)->data, len); g_interned_keywords = make_cons(keyword, g_interned_keywords); gc_unroot(); return keyword; }
static void L16() {register object *base=vs_base; register object *sup=base+VM16; VC16 vs_check; {object V31; object V32; register object V33; check_arg(3); V31=(base[0]); V32=(base[1]); V33=(base[2]); vs_top=sup; goto TTL; TTL:; if(((VV[2]->s.s_dbind))!=Cnil){ goto T81;} if(((VV[3]->s.s_dbind))==Cnil){ goto T81;} base[3]= (V31); base[4]= (V32); base[5]= (V33); vs_top=(vs_base=base+3)+3; (void) (*Lnk179)(); return; goto T81; T81:; {register object V34; register object V35; object V36; object V37; object V38; object V39; V37= (*(LnkLI180))(VV[17]); V38= (((V31))==(VV[0])?Ct:Cnil); V39= (*(LnkLI181))((V33),VV[18],VV[19]); V34= Cnil; V35= Cnil; V36= Cnil; {object V41= V31; if((V41!= VV[0]))goto T93; V34= (*(LnkLI182))(small_fixnum(0)); V35= make_cons((V34),Cnil); goto T92; goto T93; T93:; if((V41!= VV[1]))goto T97; V34= (*(LnkLI182))(small_fixnum(1)); V42= (*(LnkLI182))(small_fixnum(0)); V35= list(2,/* INLINE-ARGS */V42,(V34)); goto T92; goto T97; T97:; base[3]= VV[20]; base[4]= VV[21]; base[5]= VV[22]; base[6]= VV[23]; base[7]= V31; base[8]= VV[24]; base[9]= VV[25]; base[10]= VV[26]; base[11]= VV[27]; vs_top=(vs_base=base+3)+9; (void) (*Lnk183)(); vs_top=sup;} goto T92; T92:; {object V44= V32; if(!eql(V44,VV[28]))goto T111; V36= VV[29]; goto T110; goto T111; T111:; if(!eql(V44,VV[30]))goto T113; V36= VV[31]; goto T110; goto T113; T113:; base[3]= VV[20]; base[4]= VV[21]; base[5]= VV[22]; base[6]= VV[23]; base[7]= V32; base[8]= VV[24]; base[9]= VV[32]; base[10]= VV[26]; base[11]= VV[33]; vs_top=(vs_base=base+3)+9; (void) (*Lnk183)(); vs_top=sup;} goto T110; T110:; base[3]= (V36); base[4]= (V35); if(((V33))!=Cnil){ goto T129;} V45= VV[35]; goto T127; goto T129; T129:; V45= Cnil; goto T127; T127:; V46= list(2,VV[38],(V34)); if(((V33))!=Cnil){ goto T133;} V48= list(3,VV[39],VV[19],list(2,VV[40],(V34))); V47= make_cons(/* INLINE-ARGS */V48,Cnil); goto T131; goto T133; T133:; V47= Cnil; goto T131; T131:; V49= list(2,VV[41],(V34)); V50= make_cons(/* INLINE-ARGS */V49,Cnil); V51= append(V47,/* INLINE-ARGS */V50); V52= make_cons(/* INLINE-ARGS */V46,/* INLINE-ARGS */V51); V53= list(2,VV[42],(V34)); if(((V33))!=Cnil){ goto T137;} V55= list(3,VV[39],VV[19],list(2,VV[43],(V34))); V54= make_cons(/* INLINE-ARGS */V55,Cnil); goto T135; goto T137; T137:; V54= Cnil; goto T135; T135:; V56= list(2,VV[44],(V34)); V57= make_cons(/* INLINE-ARGS */V56,Cnil); V58= append(V54,/* INLINE-ARGS */V57); V59= list(2,VV[36],list(3,VV[37],/* INLINE-ARGS */V52,make_cons(/* INLINE-ARGS */V53,/* INLINE-ARGS */V58))); if(((V38))==Cnil){ goto T141;} V60= VV[45]; goto T139; goto T141; T141:; V60= Cnil; goto T139; T139:; V61= make_cons(/* INLINE-ARGS */V59,V60); V62= append(V45,/* INLINE-ARGS */V61); V63= list(2,VV[49],list(3,VV[50],VV[36],(V37))); if(!(eql(small_fixnum(2),(V32)))){ goto T145;} V64= VV[53]; goto T143; goto T145; T145:; V64= Cnil; goto T143; T143:; V65= list(2,VV[51],listA(3,VV[47],VV[52],V64)); if(((V38))==Cnil){ goto T149;} V67= list(3,VV[54],VV[55],list(3,VV[39],VV[56],(V39))); V66= make_cons(/* INLINE-ARGS */V67,Cnil); goto T147; goto T149; T149:; V66= Cnil; goto T147; T147:; V68= listA(5,VV[47],VV[48],/* INLINE-ARGS */V63,/* INLINE-ARGS */V65,V66); V69= listA(3,VV[57],VV[11],(V35)); if(((V38))==Cnil){ goto T153;} V70= VV[56]; goto T151; goto T153; T153:; V70= list(3,VV[58],(V39),CMPcar((V35))); goto T151; T151:; base[5]= list(3,VV[34],/* INLINE-ARGS */V62,list(4,VV[46],/* INLINE-ARGS */V68,/* INLINE-ARGS */V69,V70)); vs_top=(vs_base=base+3)+3; (void) (*Lnk176)(); return;} } }