自学教程：C++ symbolp函数代码示例

static sexpr sx_join_work (sexpr a, sexpr b, sexpr c, char *g){    const char *s;    int i = 0, j = 0;    s = stringp (a) ? sx_string (a) : sx_symbol(a);    for (j = 0; s[j]; j++) {        g[i] = s[j];        i++;    }    if (stringp (b) || symbolp(b))    {        s = stringp (b) ? sx_string (b) : sx_symbol(b);        for (j = 0; s[j]; j++) {            g[i] = s[j];            i++;        }    }    if (stringp (c) || symbolp(c))    {        s = stringp (c) ? sx_string (c) : sx_symbol(c);        for (j = 0; s[j]; j++) {            g[i] = s[j];            i++;        }    }    g[i] = 0;    return stringp(a) ? make_string (g) : make_symbol (g);}

//--------eval---------------        int eval(int addr){    int res;        if(atomp(addr)){        if(numberp(addr))            return(addr);        if(symbolp(addr)){            res = findsym(addr);            if(res == -1)                error(CANT_FIND_ERR, "eval", addr);            else                return(res);        }    }    else     if(listp(addr)){        if((symbolp(car(addr))) &&(HAS_NAME(car(addr),"quote")))            return(cadr(addr));        if(numberp(car(addr)))            error(ARG_SYM_ERR, "eval", addr);        if(subrp(car(addr)))            return(apply(car(addr),evlis(cdr(addr))));        if(fsubrp(car(addr)))            return(apply(car(addr),cdr(addr)));        if(functionp(car(addr)))            return(apply(car(addr),evlis(cdr(addr))));        }    error(CANT_FIND_ERR, "eval", addr);    return(0);}

/* * (set-video-mode <width> <height> <bits per pixel>?) or * (set-video-mode <width> <height> <bits per pixel> <mode flags>+) * * where <symbols> are: *  swsurface *  hwsurface *  asyncblit *  anyformat *  hwpalette *  doublebuf *  fullscreen *  opengl *  openglblit *  resizable *  noframe * */cons_t* set_video_mode(cons_t* p, environment_t*){  assert_length_min(p, 2);  assert_type(INTEGER, car(p));  assert_type(INTEGER, cadr(p));  // dimension  int x = car(p)->integer;  int y = cadr(p)->integer;  // default values  int bits = 32;  uint32_t mode = 0;///////////////////  raise(runtime_exception("Testing"));///////////////////  // bits per pixel  if ( integerp(caddr(p)) )    bits = caddr(p)->integer;  // options  cons_t *opts = symbolp(caddr(p))? cddr(p) :                 symbolp(cadddr(p))? cdddr(p) : nil();;  for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {    assert_type(SYMBOL, car(s));    std::string sym = symbol_name(s);    int size = sizeof(sdl_flags) / sizeof(key_value_t<std::string, uint32_t>);    for ( int n=0; n < size; ++n )      if ( sym == sdl_flags[n].key ) {///////////////////printf("flag %s/n", sym.c_str());printf("value %d and %d/n", sdl_flags[n].value, SDL_HWSURFACE);///////////////////        mode |= sdl_flags[n].value;        goto NEXT_FLAG;      }    raise(runtime_exception("Unknown SDL video mode flag: " + sym));NEXT_FLAG:    continue;  }  mode = SDL_HWSURFACE;///////////////////  printf("video mode/n"); fflush(stdout);///////////////////  SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);  if ( screen == NULL )    raise(runtime_exception(SDL_GetError()));  return pointer(new pointer_t("sdl-surface", (void*)screen));}

Node* list_erase(Node* n, Node* pos) {  if (get_next(n) == NULL) {    std::cerr << "ERROR" << std::endl;    exit(1);  }  else if (n == pos) {    Node* next_node = get_next(n);    if (get_elem(n) && symbolp(get_elem(n))) {      free((n->elem_m)->symbol_m);    }    free(n->elem_m);    n->elem_m = get_elem(next_node);    n->next_m = get_next(next_node);    free(next_node);    return n;  }  else if (get_next(n) == pos) {    n->next_m = get_next(pos);    if (get_elem(pos) && symbolp(get_elem(pos))) {      free((pos->elem_m)->symbol_m);    }    free(pos->elem_m);    free(pos);    return n->next_m;  }  else {    return list_erase(get_next(n), pos);  }}

int test64(){    /* Bytecode is the same as in test32(), except that we use symbolp()     * to fill up some space to get the distance right for ia64 machines.     */    __FILE__->testcall(14, symbolp(symbolp(symbolp(symbolp(0)))), this_object());    return 1;}

sexpr sx_join (sexpr a, sexpr b, sexpr c){    unsigned int j = 0, k = 0;    const char *s;    if (integerp (a))    {        a = sx_to_string (a);    }    if (integerp (b))    {        b = sx_to_string (b);    }    if (integerp (c))    {        c = sx_to_string (c);    }    if (stringp (a) || symbolp(a))    {        s = stringp (a) ? sx_string (a) : sx_symbol(a);        for (j = 0; s[j]; j++) k++;    }    else    {        return sx_nil;    }    if (stringp (b) || symbolp(b))    {        s = stringp (b) ? sx_string (b) : sx_symbol(b);        for (j = 0; s[j]; j++) k++;    }    if (stringp (c) || symbolp(c))    {        s = stringp (c) ? sx_string (c) : sx_symbol(c);        for (j = 0; s[j]; j++) k++;    }    k++;    if (k < STACK_BUFFER_SIZE)    {        char buf[STACK_BUFFER_SIZE];        return sx_join_work (a, b, c, buf);    }    else    {        char *g = get_mem (k);        sexpr rv;        rv = sx_join_work (a, b, c, g);        free_mem (k, g);        return rv;    }}

int eqp(int addr1, int addr2){    if((numberp(addr1)) && (numberp(addr2))        && ((GET_NUMBER(addr1)) == (GET_NUMBER(addr2))))        return(1);    else if ((symbolp(addr1)) && (symbolp(addr2))        && (SAME_NAME(addr1,addr2)))        return(1);    else        return(0);}

// ### kernel-function-pValue SYS_kernel_function_p(Value arg){  if (symbolp(arg))    return the_symbol(arg)->is_kernel_function() ? T : NIL;  if (typed_object_p(arg))    {      Value name = the_typed_object(arg)->operator_name();      if (symbolp(name))        return the_symbol(name)->is_kernel_function() ? T : NIL;    }  return NIL;}

/* * (set-video-mode <width> <height> <bits per pixel>?) or * (set-video-mode <width> <height> <bits per pixel> <mode flags>+) * * where <symbols> are: *  swsurface *  hwsurface *  asyncblit *  anyformat *  hwpalette *  doublebuf *  fullscreen *  opengl *  openglblit *  resizable *  noframe * */cons_t* set_video_mode(cons_t* p, environment_t*){  assert_length_min(p, 2);  assert_type(INTEGER, car(p));  assert_type(INTEGER, cadr(p));  // dimension  int x = intval(car(p));  int y = intval(cadr(p));  // default values  int bits = 32;  uint32_t mode = 0;  // bits per pixel  if ( length(p) > 2 && integerp(caddr(p)) )    bits = intval(caddr(p));  // mode options  if ( length(p) > 3 ) {    cons_t *opts = symbolp(caddr(p))? cddr(p) :                   symbolp(cadddr(p))? cdddr(p) : nil();;    DPRINT(opts);    for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {      assert_type(SYMBOL, car(s));      std::string sym = symbol_name(car(s));      for ( size_t n=0; n < num_sdl_flags; ++n )        if ( sym == sdl_flags[n].key ) {          mode |= sdl_flags[n].value;          goto NEXT_FLAG;        }      raise(runtime_exception("Unknown SDL video mode flag: " + sym));  NEXT_FLAG:      continue;    }  }  SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);  if ( screen == NULL )    raise(runtime_exception(SDL_GetError()));  return pointer(    new pointer_t("sdl-surface",                  reinterpret_cast<void*>(screen)));}

/* xlgetfname - get a filename */LVAL xlgetfname(V){    LVAL name;    /* get the next argument */    name = xlgetarg();    /* get the filename string */#ifdef FILETABLE    if (streamp(name) && getfile(name) > CONSOLE)        /* "Steal" name from file stream */        name = cvstring(filetab[getfile(name)].tname);    else#endif    if (symbolp(name))	name = getpname(name);    else if (!stringp(name))	xlbadtype(name);    if (getslength(name) >= FNAMEMAX)        xlerror("file name too long", name);    /* return the name */    return (name);}

Cell* op_floor::eval_op(Cell* operand) const{  Cell* operand_ptr;  no_of_operands(operand,1,1,true,true);  operand_ptr = car(operand);  if (listp(operand_ptr))  {    operand_ptr = eval(operand_ptr);  }  else if (symbolp(operand_ptr))  {    operand_ptr = search_symbol(get_symbol(operand_ptr),true);  }  if (doublep(operand_ptr))  {    return make_int( int(floor(get_double(operand_ptr))) );  }  else  {    if (operand_ptr != NULL)       delete operand_ptr;    throw runtime_error("'floor' only operates with double.");  }}

oidtype read_partial_tuple(bindtype env, oidtype tag, oidtype x, oidtype stream) { // Standard reader	int size = 0, fills = 0, j = 0, k = 0;	oidtype res, x0;	struct ptcell *dres;		//Pass 1: compute sizes	x0 = x;	while (x0 != nil) {		if (hd(x) == nil) fills++;		size++;		x0 = tl(x0);	}	// Allocate PT	res = alloc_partial_tuple(size - fills, fills);	dres = dr(res, ptcell);	//Pass 2: fill PT with values and blanks	x0 = x;	while (x0 != nil) {		if (symbolp(hd(x0)) && strcmp(getpname(hd(x0)), "*") == 0) {						dres->fill[j].pos = k;			dres->fill[j].pendingOps = 0;			a_setelem(dres->tuple, k, nil, FALSE);			j++;		} else a_setelem(dres->tuple, k, hd(x0), FALSE);		k++;		x0 = tl(x0);	}	return res;}

/* x1macroexpand - expand a macro call */LVAL x1macroexpand(void){    LVAL form,fun,args;    /* protect some pointers */    xlstkcheck(2);    xlsave(fun);    xlsave(args);    /* get the form */    form = xlgetarg();    xllastarg();    /* expand until the form isn't a macro call */    if (consp(form)) {        fun = car(form);		/* get the macro name */        args = cdr(form);		/* get the arguments */        if (symbolp(fun) && fboundp(fun)) {            fun = xlgetfunction(fun);	/* get the expansion function */            macroexpand(fun,args,&form);        }    }    /* restore the stack and return the expansion */    xlpopn(2);    return (form);}

/* xleval - evaluate an xlisp expression (checking for *evalhook*) */NODE *xleval(NODE *expr){    /* check for control codes */    if (--xlsample <= 0) {	xlsample = SAMPLE;	oscheck();    }    /* check for *evalhook* */    if (getvalue(s_evalhook))	return (evalhook(expr));    /* add trace entry */    if (++xltrace < TDEPTH)	trace_stack[xltrace] = expr;    /* check type of value */    if (consp(expr))	expr = evform(expr);    else if (symbolp(expr))	expr = xlgetvalue(expr);    /* remove trace entry */    --xltrace;    /* return the value */    return (expr);}

int atomp(int x){    if(numberp(x) || symbolp(x) || charp(x) || stringp(x) || booleanp(x) || identifierp(x)                  || IS_SYNCLO(x))    	return(1);    else    	return(0);}

AbstractString * Function::write_to_string(){  Value name = operator_name();  Thread * thread = current_thread();  if (thread->symbol_value(S_print_readably) != NIL)    {      if (symbolp(name) || is_valid_setf_function_name(name))        {          String * s = new String();          s->append("#.(");          s->append(the_symbol(S_coerce_to_function)->prin1_to_string());          s->append(" '");          s->append(::prin1_to_string(name));          s->append_char(')');          return s;        }      signal_lisp_error(new PrintNotReadable(make_value(this)));      // not reached      return NULL;    }  String * s = new String();  s->append(the_symbol(S_function)->write_to_string());  if (name != NULL_VALUE)    {      s->append_char(' ');      void* last_special_binding = thread->last_special_binding();      thread->bind_special(S_print_length, NIL);      thread->bind_special(S_print_level, NIL);      s->append(::prin1_to_string(name));      thread->set_last_special_binding(last_special_binding);    }  return unreadable_string(s);}

/* xsymbolp - is this an symbol? */LVAL xsymbolp(void){    LVAL arg;    arg = xlgetarg();    xllastarg();    return (arg == NIL || symbolp(arg) ? s_true : NIL);}

static obj_t *lang_define(obj_t **frame, obj_t **tailp){    obj_t *expr = *frame_ref(frame, 0);    obj_t *first, *name, *result;    *tailp = NULL;    first = pair_car(expr);    if (symbolp(first)) {        // Binding an expression        // XXX: check for expr length?        obj_t *to_eval = pair_car(pair_cdr(expr));        // Get the value of the expression before binding.        obj_t **expr_frame = frame_extend(                frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV);        *frame_ref(expr_frame, 0) = to_eval;        result = eval_frame(expr_frame);        name = first;    }    else if (pairp(first)) {        // short hand for (define name (lambda ...))        // x: the formals, v: the body        obj_t *formals, *body;        name = pair_car(first);        formals = pair_cdr(first);        body = pair_cdr(expr);        result = closure_wrap(frame, frame_env(frame), formals, body);    }    else {        fatal_error("define -- first argument is neither a "                    "symbol nor a pair", frame);    }    environ_def(frame, frame_env(frame), name, result);    return unspec_wrap();}

/* check an item instance variable */static LVAL check_item_ivar P2C(int, which, LVAL, value){  int good=0;    switch (which) {  case 'T': good = (stringp(value) && strlen(getstring(value)) != 0); break;  case 'K': good = (charp(value) || value == NIL); break;  case 'M': good = (charp(value) || value == NIL || value == s_true); break;  case 'S': good = (symbolp(value) || listp(value)); break;  case 'A': good = (value == NIL || symbolp(value) || closurep(value) || subrp(value) || (bcclosurep(value))); break;  case 'E': good = TRUE; value = (value != NIL) ? s_true : NIL; break;  default:  xlfail("unknown item instance variable");  }  if (! good) xlerror("bad instance variable value", value);  return(value);}

/* xlexpandmacros - expand macros in a form */LVAL xlexpandmacros(LVAL form){    LVAL fun,args;        /* protect some pointers */    xlstkcheck(3);    xlprotect(form);    xlsave(fun);    xlsave(args);    /* expand until the form isn't a macro call */    while (consp(form)) {        fun = car(form);                /* get the macro name */        args = cdr(form);               /* get the arguments */        if (!symbolp(fun) || !fboundp(fun))            break;        fun = xlgetfunction(fun);       /* get the expansion function */        if (!macroexpand(fun,args,&form))            break;    }    /* restore the stack and return the expansion */    xlpopn(3);    return (form);}

bool Condition::typep(Value type) const{  if (symbolp(type))    return (type == S_condition || type == S_standard_object || type == S_atom || type == T);  else    return (type == C_condition || type == C_standard_object || type == C_t);}

LISPTR lisp_print(LISPTR x, FILE* out){	if (consp(x)) {		fputwc('(', out);		while (true) {			lisp_print(car(x), out);			x = cdr(x);			if (!consp(x)) {				if (x != NIL) {					fputws(L" . ", out);					lisp_print(x, out);				}				break;			}			fputwc(' ', out);		}		fputwc(')', out);	} else if (symbolp(x)) {		fputws(string_text(symbol_name(x)), out);	} else if (numberp(x)) {		fwprintf(out, L"%g", number_value(x));	} else if (stringp(x)) {		fputwc('"', out);		fputws(string_text(x), out);		fputwc('"', out);	} else {		fputws(L"*UNKOBJ*", out);	}	return x;}

bool SocketStream::typep(Value type) const{  if (symbolp(type))    return (type == S_socket_stream || type == S_ansi_stream || type == S_stream || type == S_atom || type == T);  else    return (type == C_socket_stream || type == C_ansi_stream || type == C_stream || type == C_t);}

// ### autoload-macroValue EXT_autoload_macro(unsigned int numargs, Value args[]){  switch (numargs)    {    case 1:      if (listp(args[0]))        {          Value list = args[0];          while (list != NIL)            {              Value name = car(list);              check_symbol(name)->set_autoload_macro(new Autoload(name));              list = xcdr(list);            }          return T;        }      else if (symbolp(args[0]))        {          the_symbol(args[0])->set_autoload_macro(new Autoload(args[0]));          return T;        }      else        return signal_type_error(args[0], list3(S_or, S_symbol, S_list));    case 2:      if (listp(args[0]))        {          AbstractString * filename = check_string(args[1]);          Value list = args[0];          while (list != NIL)            {              Value name = car(list);              check_symbol(name)->set_autoload_macro(new Autoload(name, filename));              list = xcdr(list);            }          return T;        }      else if (symbolp(args[0]))        {          the_symbol(args[0])->set_autoload_macro(new Autoload(args[0], check_string(args[1])));          return T;        }      else        return signal_type_error(args[0], list3(S_or, S_symbol, S_list));    default:      return wrong_number_of_arguments(S_autoload, numargs, 1, 2);    }}

bool Array_T::typep(Value type) const{  if (consp(type))    {      Value type_specifier_atom = xcar(type);      Value tail = xcdr(type);      if (type_specifier_atom == S_array)        {          if (consp(tail))            {              Value element_type = xcar(tail);              tail = xcdr(tail);              if (element_type == UNSPECIFIED || ::equal(element_type, _element_type)                  || (_element_type == S_bit && ::equal(element_type, BIT_TYPE)))                {                  if (tail == NIL)                    return true;                  if (::length(tail) == 1)                    {                      Value dimensions = xcar(tail);                      if (dimensions == UNSPECIFIED)                        return true;                      if (dimensions == make_fixnum(_rank))                        return true;                      if (consp(dimensions))                        {                          if (::length(dimensions) == _rank)                            {                              unsigned long i = 0;                              while (dimensions != NIL)                                {                                  Value dim = xcar(dimensions);                                  if (dim == UNSPECIFIED || dim == make_fixnum(_dimensions[i]))                                    ; // ok                                  else                                    return false;                                  dimensions = xcdr(dimensions);                                  ++i;                                }                              return true;                            }                        }                    }                }            }        }    }  else if (symbolp(type))    {      if (type == S_array || type == S_atom || type == T)        return true;    }  else    {      if (type == C_array || type == C_t)        return true;    }  return false;}

// ### function-name function-designatorValue SYS_function_name(Value arg){  if (symbolp(arg))    return arg;  if (functionp(arg))    return the_typed_object(arg)->operator_name();  return signal_type_error(arg, S_function_designator);}

bool StringOutputStream::typep(Value type) const{  if (symbolp(type))    return (type == S_string_output_stream || type == S_string_stream || type == S_ansi_stream            || type == S_stream || type == S_atom || type == T);  else    return (type == C_string_stream || type == C_ansi_stream || type == C_stream || type == C_t);}

bool SimpleArray_UB16_1::typep(Value type) const{  if (consp(type))    {      Value type_specifier_atom = xcar(type);      Value tail = xcdr(type);      if (type_specifier_atom == S_array || type_specifier_atom == S_simple_array)        {          if (consp(tail))            {              Value element_type = xcar(tail);              if (element_type == UNSPECIFIED)                ; // ok              else                {                  Value upgraded_element_type = upgraded_array_element_type(element_type);                  if (::equal(upgraded_element_type, UB16_TYPE))                    ; // ok                  else if (::equal(upgraded_element_type,                                   list3(S_integer, FIXNUM_ZERO, make_fixnum(65535))))                    ; // ok                  else if (::equal(upgraded_element_type,                                   list3(S_integer, FIXNUM_ZERO, list1(make_fixnum(65536)))))                    ; // ok                  else                    return false;                }              tail = xcdr(tail);              if (tail == NIL)                return true;              if (cdr(tail) == NIL) // i.e. length(tail) == 1                {                  Value dimensions = xcar(tail);                  if (dimensions == UNSPECIFIED)                    return true;                  if (dimensions == FIXNUM_ONE)                    return true;                  if (::equal(dimensions, list1(UNSPECIFIED)))                    return true;                  if (::equal(dimensions, list1(make_fixnum(_capacity))))                    return true;                }            }        }    }  else if (symbolp(type))    {      if (type == S_vector || type == S_sequence || type == S_simple_array          || type == S_array || type == S_atom || type == T)        return true;    }  else    {      if (type == C_vector || type == C_array || type == C_sequence || type == C_t)        return true;    }  return false;}

// ### multiple-value-callValue 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);}

LOCAL void test_one_env(LVAL environment, int i, char *s){    register LVAL fp,ep;    LVAL val;    /* check the environment list */    for (fp = environment; fp; fp = cdr(fp)) {            /* check that xlenv is good */            if (!consp(fp)) {                sprintf(buf,"%s: xlenv 0x%lx, frame 0x%lx, type(frame) %d/n",                        s, xlenv, fp, ntype(fp));            errputstr(buf);            report_exit("xlenv points to a bad list", i);        }                /* check for an instance variable */        if ((ep = car(fp)) && objectp(car(ep))) {            /* do nothing */        }        /* check an environment stack frame */        else {            for (; ep; ep = cdr(ep)) {                    /* check that ep is good */                    if (!consp(ep)) {                         sprintf(buf,"%s: fp 0x%lx, ep 0x%lx, type(ep) %d/n",                                s, fp, ep, ntype(ep));                    errputstr(buf);                    report_exit("car(fp) points to a bad list", i);                }                                    /* check that car(ep) is nonnull */                    if (!car(ep)) {                         sprintf(buf,"%s: ep 0x%lx, car(ep) 0x%lx/n",                                s, ep, car(ep));                    errputstr(buf);                    report_exit("car(ep) (an association) is NULL", i);                }                    /* check that car(ep) is a cons */                    if (!consp(car(ep))) {                         sprintf(buf,"%s: ep 0x%lx, car(ep) 0x%lx, type(car(ep)) %d/n",                                s, ep, car(ep), ntype(car(ep)));                    errputstr(buf);                    report_exit("car(ep) (an association) is not a cons", i);                }                    /* check that car(car(ep)) is a symbol */                    if (!symbolp(car(car(ep)))) {                         sprintf(buf,"%s: ep 0x%lx, car(ep) 0x%lx, car(car(ep)) 0x%lx, type(car(car(ep))) %d/n",                                s, ep, car(ep), car(car(ep)), ntype(car(car(ep))));                    errputstr(buf);                    report_exit("car(car(ep)) is not a symbol", i);                }            }        }    }}