Beispiel #1
0
static int load_vmstate(const VMStateDescription *desc,
                        void *obj, void *obj_clone,
                        void (*obj_copy)(void *, void*),
                        int version, uint8_t *wire, size_t size)
{
    /* We test with zero size */
    obj_copy(obj_clone, obj);
    FAILURE(load_vmstate_one(desc, obj, version, wire, 0));

    /* Stream ends with QEMU_EOF, so we need at least 3 bytes to be
     * able to test in the middle */

    if (size > 3) {

        /* We test with size - 2. We can't test size - 1 due to EOF tricks */
        obj_copy(obj, obj_clone);
        FAILURE(load_vmstate_one(desc, obj, version, wire, size - 2));

        /* Test with size/2, first half of real state */
        obj_copy(obj, obj_clone);
        FAILURE(load_vmstate_one(desc, obj, version, wire, size/2));

        /* Test with size/2, second half of real state */
        obj_copy(obj, obj_clone);
        FAILURE(load_vmstate_one(desc, obj, version, wire + (size/2), size/2));

    }
    obj_copy(obj, obj_clone);
    return load_vmstate_one(desc, obj, version, wire, size);
}
Beispiel #2
0
/*-------------------------------------------------------------------------
 * Function:    ptr_bind
 *
 * Purpose:     Binds array dimensions to numeric values.
 *
 * Return:      Success:        SELF
 *
 *              Failure:        NIL
 *
 * Programmer:  Robb Matzke
 *              [email protected]
 *              Jan 13 1997
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
static obj_t
ptr_bind (obj_t _self, void *mem) {

   obj_ptr_t    *self = MYCLASS(_self);
   obj_t        name=NIL, val=NIL, x=NIL;
   int          i;

   if (C_STR==self->sub->pub.cls) {
      name = obj_new (C_SYM, obj_name(self->sub));
      x = sym_vboundp (name);
      name = obj_dest (name);
      val = obj_copy (x, DEEP); /*so we can modify it*/
      x = obj_dest (x);

      /*
       * We're being tricky here.  By assigning a new value to the `sub'
       * field we're modifying all the expressions that share this cell.
       * We must insure that the correct reference count is imparted
       * to the new subtype.
       */
      for (i=1; i<self->pub.ref; i++) {
         x = obj_copy (val, SHALLOW);
         assert (x==val);
      }
      
      if (val) self->sub = val;
   }

   return obj_bind (self->sub, mem ? *((void**)mem) : NULL);
}
Beispiel #3
0
/*---------------------------------------------------------------------------
 * Purpose:     Determines if the specified symbol has a documentation value.
 *
 * Return:      A copy of the symbol's documentation value, or NIL if the
 *              symbol is not documented.
 *
 * Programmer:  Robb Matzke
 *              Friday, June  2, 2000
 *
 * Modifications:
 *---------------------------------------------------------------------------
 */
obj_t
sym_dboundp(obj_t _self)
{
    obj_sym_t   *self = MYCLASS(_self);
    if (self && C_SYM==self->pub.cls) return obj_copy(self->sym->doc, SHALLOW);
    return NIL;
}
Beispiel #4
0
/*-------------------------------------------------------------------------
 * Function:    sym_vboundp
 *
 * Purpose:     Determines if the specified object is a symbol with a
 *              variable value.
 *
 * Return:      Success:        A copy of the symbol's value as a variable.
 *
 *              Failure:        NIL if the SELF is not a symbol or is a
 *                              symbol without a value as a variable.
 *
 * Programmer:  Robb Matzke
 *              [email protected]
 *              Dec  5 1996
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
obj_t
sym_vboundp(obj_t _self)
{
    obj_sym_t   *self = MYCLASS(_self);

    if (!self || C_SYM!=self->pub.cls) return NIL;
    return obj_copy (self->sym->var, SHALLOW);
}
Beispiel #5
0
/*ARGSUSED*/
static obj_t
ptr_deref (obj_t _self, int argc, obj_t *argv) {

   if (0!=argc) {
      out_errorn ("ptr_deref: wrong number of arguments");
      return NIL;
   }
   return obj_copy (MYCLASS(_self)->sub, SHALLOW);
}
Beispiel #6
0
/*-------------------------------------------------------------------------
 * Function:    ptr_copy
 *
 * Purpose:     Copies a pointer type.
 *
 * Return:      Success:        Copy of SELF
 *
 *              Failure:        abort()
 *
 * Programmer:  Robb Matzke
 *              [email protected]
 *              Jan 22 1997
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
static obj_t
ptr_copy (obj_t _self, int flag) {

   obj_ptr_t    *self = MYCLASS(_self);
   obj_ptr_t    *retval = NULL;
   obj_t        x;

   if (SHALLOW==flag) {
      x = obj_copy (self->sub, SHALLOW);
      assert (x==self->sub);
      retval = self;

   } else {
      retval = (obj_ptr_t *)calloc (1, sizeof(obj_ptr_t));
      retval->sub = obj_copy (self->sub, DEEP);
   }

   return (obj_t)retval;
}
Beispiel #7
0
/*-------------------------------------------------------------------------
 * Function:    sym_fboundp
 *
 * Purpose:     Determines if the specified object is a symbol with a
 *              functional value.
 *
 * Return:      Success:        Ptr to a copy of the functional value.
 *
 *              Failure:        NIL if the SELF is not a symbol or is a
 *                              symbol with no functional value.
 *
 * Programmer:  Robb Matzke
 *              [email protected]
 *              Dec  4 1996
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
obj_t
sym_fboundp (obj_t _self) {

   obj_sym_t    *self = MYCLASS(_self);

   if (self && C_SYM==self->pub.cls && self->sym->func) {
      return obj_copy (self->sym->func, SHALLOW);
   }
   return NIL;
}
Beispiel #8
0
/*-------------------------------------------------------------------------
 * Function:    sym_eval
 *
 * Purpose:     Returns the variable value of a symbol if it has one.
 *
 * Return:      Success:        Ptr to a copy of the variable value.
 *
 *              Failure:        NIL
 *
 * Programmer:  Robb Matzke
 *              [email protected]
 *              Dec  4 1996
 *
 * Modifications:
 *      Robb Matzke, 4 Feb 1997
 *      Fixed the arguments for the obj_deref() call.
 *
 *      Robb Matzke, 2000-07-03
 *      The symbol `$*' evaluates to a list of all $N files for
 *      consecutive N beginning at 1.
 *-------------------------------------------------------------------------
 */
static obj_t
sym_eval (obj_t _self)
{
    obj_t       name_1=NIL, file_1=NIL, retval=NIL;
    obj_sym_t   *self = MYCLASS(_self);

    /* If the symbol has a variable value then return it. */    
    if (MYCLASS(_self)->sym->var) {
        return obj_copy (MYCLASS(_self)->sym->var, SHALLOW);
    }

    /* The symbol `$*' evaluates to a list of the first consecutive files
     * bound to the $N symbols. */
    if (!strcmp(self->sym->name, "$*")) {
        obj_t   opands[1024], retval;
        int     nopands, i;
        
        for (nopands=0; nopands<NELMTS(opands); nopands++) {
            obj_t symbol;
            char tmp[32];
            sprintf(tmp, "$%d", nopands+1);
            symbol = obj_new(C_SYM, tmp);
            opands[nopands] = sym_vboundp(symbol);
            obj_dest(symbol);
            if (!opands[nopands] || C_FILE!=opands[nopands]->pub.cls) {
                /* We reached the last file or something isn't a file */
                obj_dest(opands[nopands]);
                break;
            }
        }
        retval = V_make_list(nopands, opands);
        for (i=0; i<nopands; i++) {
            obj_dest(opands[i]);
        }
        return retval;
    }

    /* If the symbol exists in the first data file, then return
     * that SDO. */
    name_1 = obj_new (C_SYM, "$1");
    file_1 = MYCLASS(name_1)->sym->var;
    name_1 = obj_dest (name_1);

    if (file_1 && C_FILE==file_1->pub.cls) {
        retval = obj_deref (file_1, 1, &_self);
        return retval;
    }

    /* Symbol has no value. */    
    out_errorn ("eval: variable `%s' has no value", obj_name(_self));
    return NIL;
}
Beispiel #9
0
/*----------------------------------------------------------------------------------------*/
int16	tree_copy( OBJECT *dest, OBJECT *src )
{
	int16 i = -1;

	if( !dest || !src )
		return 0;

	do
	{
		i++;
		obj_copy( dest, i, src, i );
	}
	while( !(src[i].ob_flags & LASTOB) );
	
	return i;
}
Beispiel #10
0
void get_recording_header_data(
	short *number_of_players, 
	short *level_number, 
	uint32 *map_checksum,
	short *version, 
	struct player_start_data *starts, 
	struct game_data *game_information)
{
	assert(replay.valid);
	*number_of_players= replay.header.num_players;
	*level_number= replay.header.level_number;
	*map_checksum= replay.header.map_checksum;
	*version= replay.header.version;
	objlist_copy(starts, replay.header.starts, MAXIMUM_NUMBER_OF_PLAYERS);
	obj_copy(*game_information, replay.header.game_information);
}
Beispiel #11
0
void set_recording_header_data(
	short number_of_players, 
	short level_number, 
	uint32 map_checksum,
	short version, 
	struct player_start_data *starts, 
	struct game_data *game_information)
{
	assert(!replay.valid);
	obj_clear(replay.header);
	replay.header.num_players= number_of_players;
	replay.header.level_number= level_number;
	replay.header.map_checksum= map_checksum;
	replay.header.version= version;
	objlist_copy(replay.header.starts, starts, MAXIMUM_NUMBER_OF_PLAYERS);
	obj_copy(replay.header.game_information, *game_information);
	// Use the packed size here!!!
	replay.header.length= SIZEOF_recording_header;
}
Beispiel #12
0
bool Model3D::FindPositions_Sequence(bool UseModelTransform, GLshort SeqIndex,
                                     GLshort FrameIndex, GLfloat MixFrac,
                                     GLshort AddlFrameIndex)
{
  // Bad inputs: do nothing and return false

  GLshort NumSF = NumSeqFrames(SeqIndex);
  if (NumSF <= 0) {
    return false;
  }

  if (FrameIndex < 0 || FrameIndex >= NumSF) {
    return false;
  }

  Model3D_Transform TSF;

  Model3D_SeqFrame& SF = SeqFrames[SeqFrmPointers[SeqIndex] + FrameIndex];

  if (MixFrac != 0 && AddlFrameIndex != FrameIndex) {
    if (AddlFrameIndex < 0 || AddlFrameIndex >= NumSF) {
      return false;
    }

    Model3D_SeqFrame& ASF =
      SeqFrames[SeqFrmPointers[SeqIndex] + AddlFrameIndex];
    FindFrameTransform(TSF,SF,MixFrac,ASF);

    if (!FindPositions_Frame(false,SF.Frame,MixFrac,ASF.Frame)) {
      return false;
    }
  }
  else
  {
    if (!FindPositions_Frame(false,SF.Frame)) {
      return false;
    }
    FindFrameTransform(TSF,SF,0,SF);
  }

  Model3D_Transform TTot;
  if (UseModelTransform) {
    TMatMultiply(TTot,TransformPos,TSF);
  }
  else{
    obj_copy(TTot,TSF);
  }

  size_t NumVerts = Positions.size()/3;
  GLfloat *Pos = PosBase();
  for (size_t iv=0; iv<NumVerts; iv++)
  {
    GLfloat NewPos[3];
    TransformPoint(NewPos,Pos,TTot);
    VecCopy(NewPos,Pos);
    Pos += 3;
  }

  bool NormalsPresent = !NormSources.empty();
  if (NormalsPresent) {
    // OK, since the bones don't change bulk
    if (UseModelTransform) {
      TMatMultiply(TTot,TransformNorm,TSF);
    }
    else{
      obj_copy(TTot,TSF);
    }

    GLfloat *Norm = NormBase();
    for (size_t iv=0; iv<NumVerts; iv++)
    {
      GLfloat NewNorm[3];
      TransformVector(NewNorm,Norm,TTot);
      VecCopy(NewNorm,Norm);
      Norm += 3;
    }
  }

  return true;
}
Beispiel #13
0
// Frame case
bool Model3D::FindPositions_Frame(bool UseModelTransform,
                                  GLshort FrameIndex, GLfloat MixFrac,
                                  GLshort AddlFrameIndex)
{
  // Bad inputs: do nothing and return false

  if (Frames.empty()) {
    return false;
  }

  size_t NumBones = Bones.size();
  if (FrameIndex < 0 || NumBones*FrameIndex >= Frames.size()) {
    return false;
  }

  if (InverseVSIndices.empty()) {
    BuildInverseVSIndices();
  }

  size_t NumVertices = VtxSrcIndices.size();
  Positions.resize(3*NumVertices);

  // Set sizes:
  BoneMatrices.resize(NumBones);
  BoneStack.resize(NumBones);

  // Find which frame; remember that frame data comes in [NumBones] sets
  Model3D_Frame *FramePtr = &Frames[NumBones*FrameIndex];
  Model3D_Frame *AddlFramePtr = &Frames[NumBones*AddlFrameIndex];

  // Find the individual-bone transformation matrices:
  for (size_t ib=0; ib<NumBones; ib++)
    FindBoneTransform(BoneMatrices[ib],Bones[ib],
                      FramePtr[ib],MixFrac,AddlFramePtr[ib]);

  // Find the cumulative-bone transformation matrices:
  int StackIndx = -1;
  size_t Parent = UNONE;
  for (unsigned int ib=0; ib<NumBones; ib++)
  {
    Model3D_Bone& Bone = Bones[ib];

    // Do the pop-push with the stack
    // to get the bone's parent bone
    if (TEST_FLAG(Bone.Flags,Model3D_Bone::Pop)) {
      if (StackIndx >= 0) {
        Parent = BoneStack[StackIndx--];
      }
      else{
        Parent = UNONE;
      }
    }
    if (TEST_FLAG(Bone.Flags,Model3D_Bone::Push)) {
      StackIndx = MAX(StackIndx,-1);
      BoneStack[++StackIndx] = Parent;
    }

    // Do the transform!
    if (Parent != UNONE) {
      Model3D_Transform Res;
      TMatMultiply(Res,BoneMatrices[Parent],BoneMatrices[ib]);
      obj_copy(BoneMatrices[ib],Res);
    }

    // Default: parent of next bone is current bone
    Parent = ib;
  }

  bool NormalsPresent = !NormSources.empty();
  if (NormalsPresent) {
    Normals.resize(NormSources.size());
  }

  for (unsigned ivs=0; ivs<VtxSources.size(); ivs++)
  {
    Model3D_VertexSource& VS = VtxSources[ivs];
    GLfloat Position[3];

    if (VS.Bone0 >= 0) {
      Model3D_Transform& T0 = BoneMatrices[VS.Bone0];
      TransformPoint(Position,VS.Position,T0);

      if (NormalsPresent) {
        for (int iv=InvVSIPointers[ivs]; iv<InvVSIPointers[ivs+1]; iv++)
        {
          int Indx = 3*InverseVSIndices[iv];
          TransformVector(NormBase() + Indx, NormSrcBase() + Indx, T0);
        }
      }

      GLfloat Blend = VS.Blend;
      if (VS.Bone1 >= 0 && Blend != 0) {
        Model3D_Transform& T1 = BoneMatrices[VS.Bone1];
        GLfloat PosExtra[3];
        GLfloat PosDiff[3];
        TransformPoint(PosExtra,VS.Position,T1);
        VecSub(PosExtra,Position,PosDiff);
        VecScalarMultTo(PosDiff,Blend);
        VecAddTo(Position,PosDiff);

        if (NormalsPresent) {
          for (int iv=InvVSIPointers[ivs]; iv<InvVSIPointers[ivs+1]; iv++)
          {
            int Indx = 3*InverseVSIndices[iv];
            GLfloat NormExtra[3];
            GLfloat NormDiff[3];
            GLfloat *OrigNorm = NormSrcBase() + Indx;
            GLfloat *Norm = NormBase() + Indx;
            TransformVector(NormExtra,OrigNorm,T1);
            VecSub(NormExtra,Norm,NormDiff);
            VecScalarMultTo(NormDiff,Blend);
            VecAddTo(Norm,NormDiff);
          }
        }
      }
    }
    else                // The assumed root bone (identity transformation)
    {
      VecCopy(VS.Position,Position);
      if (NormalsPresent) {
        for (int iv=InvVSIPointers[ivs]; iv<InvVSIPointers[ivs+1]; iv++)
        {
          int Indx = 3*InverseVSIndices[iv];
          VecCopy(NormSrcBase() + Indx, NormBase() + Indx);
        }
      }
    }

    // Copy found position into vertex array!
    for (int iv=InvVSIPointers[ivs]; iv<InvVSIPointers[ivs+1]; iv++)
      VecCopy(Position,PosBase() + 3*InverseVSIndices[iv]);
  }

  if (UseModelTransform) {
    GLfloat *PP = PosBase();
    for (size_t k=0; k<Positions.size()/3; k++, PP+=3)
    {
      GLfloat Position[3];
      TransformPoint(Position,PP,TransformPos);
      VecCopy(Position,PP);
    }
    GLfloat *NP = NormBase();
    for (size_t k=0; k<Normals.size()/3; k++, NP+=3)
    {
      GLfloat Normal[3];
      TransformVector(Normal,NP,TransformNorm);
      VecCopy(Normal,NP);
    }
  }

  return true;
}
Beispiel #14
0
void apply(Process *process, Obj *function, Obj **args, int arg_count) {
  if(function->tag == 'L') {

//printf("Calling lambda "); obj_print_cout(function); printf(" with params: "); obj_print_cout(function->params); printf("\n");
//printf("Applying %s with arg count %d\n", obj_to_string(process, function)->s, arg_count);

#if BYTECODE_EVAL

    Obj *calling_env = obj_new_environment(function->env);

    bool allow_rest_args = true;
    env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args);

    //printf("calling_env: %s\n", obj_to_string(process, calling_env)->s);

    shadow_stack_push(process, function);
    shadow_stack_push(process, calling_env);

    /* printf("before\n"); */
    /* shadow_stack_print(process); */

    Obj *result = bytecode_sub_eval_internal(process, calling_env, function->body);

    if(eval_error) {
      return;
    }
    assert(result);

    //printf("result = %s\n", obj_to_string(process, result)->s);
    stack_push(process, result); // put it back on stack (TODO: fix this unnecessary work?)

    /* printf("after\n"); */
    /* shadow_stack_print(process); */

    Obj *pop1 = shadow_stack_pop(process);
    Obj *pop2 = shadow_stack_pop(process);
    assert(pop1 == calling_env);
    assert(pop2 == function);

#else

    Obj *calling_env = obj_new_environment(function->env);
    bool allow_rest_args = true;
    env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args);
    //printf("Lambda env: %s\n", obj_to_string(calling_env)->s);

    shadow_stack_push(process, function);
    shadow_stack_push(process, calling_env);

    if(function->body->tag == 'X') {
      eval_error = obj_new_string("Can't apply lambda with bytecode body.");
    }
    else {
      eval_internal(process, calling_env, function->body);
    }

    if(eval_error) {
      return;
    }

    Obj *pop1 = shadow_stack_pop(process);
    Obj *pop2 = shadow_stack_pop(process);
    assert(pop1 == calling_env);
    assert(pop2 == function);
#endif
  }
  else if(function->tag == 'P') {
    Obj *result = function->primop((struct Process *)process, args, arg_count);
    stack_push(process, result);
  }
  else if(function->tag == 'F') {
    call_foreign_function(process, function, args, arg_count);
  }
  else if(function->tag == 'K') {
    if(arg_count != 1) {
      eval_error = obj_new_string("Args to keyword lookup must be a single arg.");
    }
    else if(args[0]->tag != 'E') {
      eval_error = obj_new_string("Arg 0 to keyword lookup must be a dictionary: ");
      obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s);
    }
    else {
      Obj *value = env_lookup(process, args[0], function);
      if(value) {
        stack_push(process, value);
      }
      else {
        eval_error = obj_new_string("Failed to lookup keyword '");
        obj_string_mut_append(eval_error, obj_to_string(process, function)->s);
        obj_string_mut_append(eval_error, "'");
        obj_string_mut_append(eval_error, " in \n");
        obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s);
        obj_string_mut_append(eval_error, "\n");
      }
    }
  }
  else if(function->tag == 'E' && obj_eq(process, env_lookup(process, function, obj_new_keyword("struct")), lisp_true)) {
    //printf("Calling struct: %s\n", obj_to_string(process, function)->s);
    if(obj_eq(process, env_lookup(process, function, obj_new_keyword("generic")), lisp_true)) {
      //printf("Calling generic struct constructor.\n");
      Obj *function_call_symbol = obj_new_symbol("dynamic-generic-constructor-call");
      shadow_stack_push(process, function_call_symbol);

      Obj **copied_args = malloc(sizeof(Obj *) * arg_count);
      for(int i = 0; i < arg_count; i++) {
        copied_args[i] = obj_copy(process, args[i]);
        if(args[i]->meta) {
          copied_args[i]->meta = obj_copy(process, args[i]->meta);
        }
      }

      Obj *carp_array = obj_new_array(arg_count);
      carp_array->array = copied_args;

      Obj *call_to_concretize_struct = obj_list(function_call_symbol,
                                                function,
                                                carp_array);

      shadow_stack_push(process, call_to_concretize_struct);
      eval_internal(process, process->global_env, call_to_concretize_struct);

      shadow_stack_pop(process);
      shadow_stack_pop(process);
    }
    else {
      call_struct_constructor(process, function, args, arg_count);
    }
  }
  else {
    set_error("Can't call non-function: ", function);
  }
}
Beispiel #15
0
/*-------------------------------------------------------------------------
 * Function:    parse_stmt
 *
 * Purpose:     Parses a statement which is a function name followed by
 *              zero or more arguments.
 *
 * Return:      Success:        Ptr to parse tree.
 *
 *              Failure:        NIL, input consumed through end of line.
 *
 * Programmer:  Robb Matzke
 *              [email protected]
 *              Dec  4 1996
 *
 * Modifications:
 *
 *      Robb Matzke, 11 Dec 1996
 *      If IMPLIED_PRINT is true then wrap the input in a call to the
 *      `print' function if it isn't already obviously a call to `print'.
 *
 *      Robb Matzke, 20 Jan 1997
 *      Turn off handling of SIGINT during parsing.
 *
 *      Robb Matzke, 7 Feb 1997
 *      If the first thing on the line is a symbol which has a built in
 *      function (BIF) as its f-value, and the BIF has the lex_special
 *      property, then we call lex_special() to prepare the next token.
 *
 *      Robb Matzke, 2000-06-28
 *      Signal handlers are registered with sigaction() since its behavior
 *      is more consistent.
 *
 *-------------------------------------------------------------------------
 */
obj_t
parse_stmt (lex_t *f, int implied_print) {

   char         *lexeme, buf[1024], *s, *fmode;
   int          tok, i;
   obj_t        head=NIL, opstack=NIL, b1=NIL, retval=NIL, tmp=NIL;
   struct sigaction new_action, old_action;

   /* SIGINT should have the default action while we're parsing */
   new_action.sa_handler = SIG_DFL;
   sigemptyset(&new_action.sa_mask);
   new_action.sa_flags = SA_RESTART;
   sigaction(SIGINT, &new_action, &old_action);

   tok = lex_token (f, &lexeme, false);

   /*
    * At the end of the file, return `(exit)'.
    */
   if (TOK_EOF==tok) {
      lex_consume (f);
      if (f->f && isatty (fileno (f->f))) {
         printf ("exit\n");
         retval = obj_new (C_CONS,
                           obj_new (C_SYM, "exit"),
                           NIL);
         goto done;
      } else {
         retval = obj_new (C_SYM, "__END__");
         goto done;
      }
   }

   /*
    * For an empty line, eat the linefeed token and try again.
    */
   if (TOK_EOL==tok) {
      lex_consume (f);
      retval = parse_stmt (f, implied_print);
      goto done;
   }

   /*
    * A statement begins with a function name.  If the first token
    * is not a symbol then assume `print'.
    */
   if (implied_print && TOK_SYM==tok) {
      head = obj_new (C_SYM, lexeme);
      if ((tmp=sym_fboundp (head))) {
         tmp = obj_dest (tmp);
         lex_consume (f);
      } else {
         obj_dest (head);
         head = obj_new (C_SYM, "print");
      }
   } else if (implied_print) {
      head = obj_new (C_SYM, "print");
   } else {
      head = &ErrorCell ;       /*no function yet*/
   }

   /*
    * Some functions take a weird first argument that isn't really a
    * normal token.  Like `open' which wants the name of a file.  We
    * call lex_special() to try to get such a token if it appears
    * next.
    */
   if (head && &ErrorCell!=head && (tmp=sym_fboundp(head))) {
      if (bif_lex_special (tmp)) lex_special (f, false);
      tmp = obj_dest (tmp);
   }

   /*
    * Read the arguments...
    */
   while (&ErrorCell!=(b1=parse_expr(f, false))) {
      opstack = obj_new(C_CONS, b1, opstack);
   }

   /*
    * Construct a function call which is the HEAD applied to the
    * arguments on the operand stack.
    */
   b1 = F_reverse (opstack);
   opstack = obj_dest (opstack);

   if (&ErrorCell==head) {
      head = NIL;
      if (1==F_length(b1)) {
         retval = obj_copy (cons_head (b1), SHALLOW);
         b1 = obj_dest (b1);
      } else {
         retval = b1;
         b1 = NIL;
      }
   } else {
      retval = F_cons (head, b1);
      head = obj_dest (head);
      b1 = obj_dest (b1);
   }
      

   /*
    * A statement can end with `>' or `>>' followed by the name of
    * a file, or `|' followed by an unquoted shell command.  Leading
    * and trailing white space is stripped from the file or command.
    */
   tok = lex_token (f, &lexeme, false);
   if (TOK_RT==tok || TOK_RTRT==tok || TOK_PIPE==tok) {
      lex_consume (f);
      if (NULL==lex_gets (f, buf, sizeof(buf))) {
         out_errorn ("file name required after `%s' operator", lexeme);
         goto error;
      }
      lex_set (f, TOK_EOL, "\n");
      for (s=buf; isspace(*s); s++) /*void*/;
      for (i=strlen(s)-1; i>=0 && isspace(s[i]); --i) s[i] = '\0';
      if (!*s) {
         out_errorn ("file name required after `%s' operator", lexeme);
         goto error;
      }
      switch (tok) {
      case TOK_RT:
         lexeme = "Redirect";
         fmode = "w";
         break;
      case TOK_RTRT:
         lexeme = "Redirect";
         fmode = "a";
         break;
      case TOK_PIPE:
         lexeme = "Pipe";
         fmode = "w";
         break;
      default:
         abort();
      }
      retval = obj_new (C_CONS,
                        obj_new (C_SYM, lexeme),
                        obj_new (C_CONS,
                                 retval,
                                 obj_new (C_CONS,
                                          obj_new (C_STR, s),
                                          obj_new (C_CONS,
                                                    obj_new (C_STR, fmode),
                                                    NIL))));
   }

   /*
    * We should be at the end of a line.
    */
   tok = lex_token (f, &lexeme, false);
   if (TOK_EOL!=tok && TOK_EOF!=tok) {
      s = lex_gets (f, buf, sizeof(buf));
      if (s && strlen(s)>0 && '\n'==s[strlen(s)-1]) s[strlen(s)-1] = '\0';
      out_errorn ("syntax error before: %s%s", lexeme, s?s:"");
      lex_consume(f);
      goto error;
   } else {
      lex_consume(f);
   }

done:
   sigaction(SIGINT, &old_action, NULL);
   return retval;

error:
   if (head) head = obj_dest (head);
   if (opstack) opstack = obj_dest (opstack);
   if (retval) retval = obj_dest (retval);
   sigaction(SIGINT, &old_action, NULL);
   return NIL;
}
Beispiel #16
0
/*-------------------------------------------------------------------------
 * Function:    sym_feval
 *
 * Purpose:     Evaluates a symbol to obtain a function of some sort.
 *
 * Return:      Success:        Ptr to a copy of the function associated
 *                              with the specified symbol.
 *
 *              Failure:        
 *
 * Programmer:  Robb Matzke
 *              [email protected]
 *              Dec  4 1996
 *
 * Modifications:
 *
 *-------------------------------------------------------------------------
 */
static obj_t
sym_feval (obj_t _self) {

   return obj_copy (MYCLASS(_self)->sym->func, SHALLOW);
}