Example #1
0
int missing_space(NODE *name) {
    NODE *str = strnode__caseobj(name);
    char *s = getstrptr(str);
    FIXNUM len = getstrlen(str);
    char *t;
    char ch;
    char alpha[100], numer[100];
    int i;
    NODE *first;

    t = s+len-1;
    ch = *t;
    if (!isdigit(ch)) return 0;
    i = 1;
    while ((t>s) && (isdigit(*--t))) i++;
    if (t<=s) return 0;
    strncpy(numer,t+1,i);
    numer[i] = '\0';
    strncpy(alpha,s,len-i);
    alpha[len-i] = '\0';
    first = intern(make_strnode(alpha, 0, len-i, STRING, strnzcpy));
    check_library(first);
    if (procnode__caseobj(first) == UNDEFINED) return 0;
    missing_alphabetic = first;
    missing_numeric = make_intnode(atoi(numer));
    err_logo(MISSING_SPACE,
	     cons_list(0, cons_list(0, missing_alphabetic, missing_numeric,
				    END_OF_LIST),
		          name, END_OF_LIST));
    return 1;
}
NODE *lreadchars(NODE *args)
{
    unsigned int c, i;
    char *strhead, *strptr;
    NODETYPES type = STRING;

    c = (unsigned int)getint(pos_int_arg(args));
    if (stopping_flag == THROWING) return UNBOUND;
    charmode_on();
    input_blocking++;
#ifndef TIOCSTI
    if (!setjmp(iblk_buf))
#endif
    {
	strhead = malloc((size_t)(c + 2));
	strptr = strhead + 1;
	fread(strptr, 1, (int)c, readstream);
	setstrrefcnt(strhead, 0);
    }
    input_blocking = 0;
#ifndef TIOCSTI
    if (stopping_flag == THROWING) return(UNBOUND);
#endif
    if (feof(readstream)) {
	free(strhead);
	return(NIL);
    }
    for (i = 0; i < c; i++)
	if (getparity(strptr[i])) type = BACKSLASH_STRING;
    return(make_strnode(strptr, strhead, (int)c, type, strnzcpy));
}
Example #3
0
void filesave(char *temp)
   {
   FILE *tmp;
   NODE *arg;
   int save_yield_flag;

   if (::FindWindow(NULL, "Editor"))
      {
      MainWindowx->CommandWindow->MessageBox("Did you know you have an edit session running?\n\nAny changes in this edit session are not being saved.", "Information", MB_OK | MB_ICONQUESTION);
      }

   arg = cons(make_strnode(temp, NULL, strlen(temp), STRING, strnzcpy), NIL);

   tmp = writestream;
   writestream = open_file(car(arg), "w+");
   if (writestream != NULL)
      {

      save_yield_flag = yield_flag;
      yield_flag = 0;
      lsetcursorwait();

      setcar(arg, cons(lcontents(), NIL));
      lpo(car(arg));
      fclose(writestream);
      IsDirty = 0;

      lsetcursorarrow();
      yield_flag = save_yield_flag;

      }
   else
      err_logo(FILE_ERROR, make_static_strnode("Could not open file"));
   writestream = tmp;
   }
Example #4
0
NODE *lclose(NODE *arg) {
    FILE *tmp;
    NODE *margs;

    if ((tmp = find_file(car(arg), TRUE)) == NULL)
	err_logo(NOT_OPEN_ERROR, car(arg));
    else if (is_list (car(arg))) {
	margs = cons(caar(arg),
		     cons(make_strnode((char *)tmp, NULL, strlen((char *)tmp),
				       STRING, strnzcpy),
			  NIL));
	lmake(margs);
	free((char *)tmp);
    } else
	fclose(tmp);
    if ((is_list(car(arg)) && car(arg) == writer_name) ||
	(!is_list(car(arg)) &&
	 (compare_node(car(arg), writer_name, FALSE) == 0))) {
	    writer_name = NIL;
	    writestream = stdout;
    }
    if ((is_list(car(arg)) && car(arg) == reader_name) ||
	(!is_list(car(arg)) &&
	 (compare_node(car(arg), reader_name, FALSE) == 0))) {
	    reader_name = NIL;
	    readstream = stdin;
    }
    return(UNBOUND);
}
Example #5
0
void silent_load(NODE *arg, char *prefix) {
    FILE *tmp_stream;
    NODE *tmp_line, *exec_list;
    char load_path[200];
    NODE *st = valnode__caseobj(Startup);

    /* This procedure is called three ways:
     *    silent_load(NIL,*argv)	loads *argv
     *    silent_load(proc,logolib)     loads logolib/proc
     *    silent_load(proc,NULL)	loads proc.lg
     * The "/" or ".lg" is supplied by this procedure as needed.
     */

    /*     [This is no longer true!  But for Windows we change FOO? to FOOQ.]
     * In the case that this procedure is called to load a procedure from the
     * logo library, it must first truncate the name of the procedure to
     * eight characters, to find the filename (so as to be compatible with
     * MS-DOS)
     */

    if (prefix == NULL && arg == NIL) return;
    strcpy(load_path, (prefix == NULL ? "" :
    			  (arg == NIL ? prefix : addsep(prefix))));
    if (arg != NIL) {
	arg = cnv_node_to_strnode(arg);
	if (arg == UNBOUND) return;
	if (!strncmp(getstrptr(arg), ".", getstrlen(arg))) return;
	if (!strncmp(getstrptr(arg), "..", 2)) return;
	if (getstrlen(arg) > 150) return;
	noparitylow_strnzcpy(load_path + (int)strlen(load_path),
			     getstrptr(arg), getstrlen(arg));
	if (prefix == NULL)
	  strcat(load_path, ".lg");
/* #ifdef WIN32 */
	else if (arg != NIL) {
	    char *cp;
	    for (cp = load_path; *cp != '\0'; cp++)
		if (*cp == '?') *cp = 'Q';
	}
	/*  strcpy(load_path, eight_dot_three(load_path));  */
/* #endif */
    }
    tmp_stream = loadstream;
    tmp_line = current_line;
    loadstream = fopen(load_path, "r");
    if (loadstream != NULL) {
	while (!(feof(loadstream)) && NOT_THROWING) {
	    current_line = reader(loadstream, "");
	    exec_list =parser(current_line, TRUE);
	    if (exec_list != NIL) eval_driver(exec_list);
	}
	fclose(loadstream);
	runstartup(st);
    } else if (arg == NIL || prefix == csls)
	err_logo(CANT_OPEN_ERROR,
		 make_strnode(load_path, NULL, strlen(load_path), STRING,
			      strnzcpy));
    loadstream = tmp_stream;
    current_line = tmp_line;
}
NODE *memberp_help(NODE *args, BOOLEAN notp, BOOLEAN substr) {
    NODE *obj1, *obj2, *val;
    int leng;
    int caseig = varTrue(Caseignoredp);

    val = FalseName();
    obj1 = car(args);
    obj2 = cadr(args);
    if (is_list(obj2)) {
	if (substr) return FalseName();
	while (obj2 != NIL && NOT_THROWING) {
	    if (equalp_help(obj1, car(obj2), caseig))
		return (notp ? obj2 : TrueName());
	    obj2 = cdr(obj2);
	    if (check_throwing) break;
	}
	return (notp ? NIL : FalseName());
    }
    else if (nodetype(obj2) == ARRAY) {
	int len = getarrdim(obj2);
	NODE **data = getarrptr(obj2);

	if (notp)
	    err_logo(BAD_DATA_UNREC,obj2);
	if (substr) return FalseName();
	while (--len >= 0 && NOT_THROWING) {
	    if (equalp_help(obj1, *data++, caseig)) return TrueName();
	}
	return FalseName();
    } else {
	NODE *tmp;
	int i;

	if (aggregate(obj1)) return (notp ? Null_Word : FalseName());
	setcar (cdr(args), cnv_node_to_strnode(obj2));
	obj2 = cadr(args);
	setcar (args, cnv_node_to_strnode(obj1));
	obj1 = car(args);
	tmp = NIL;
	if (obj1 != UNBOUND && obj2 != UNBOUND &&
	    getstrlen(obj1) <= getstrlen(obj2) &&
	    (substr || (getstrlen(obj1) == 1))) {
	    leng = getstrlen(obj2) - getstrlen(obj1);
	    setcar(cdr(args),make_strnode(getstrptr(obj2), getstrhead(obj2),
					  getstrlen(obj1), nodetype(obj2),
					  strnzcpy));
	    tmp = cadr(args);
	    for (i = 0; i <= leng; i++) {
		if (equalp_help(obj1, tmp, caseig)) {
		    if (notp) {
			setstrlen(tmp,leng+getstrlen(obj1)-i);
			return tmp;
		    } else return TrueName();
		}
		setstrptr(tmp, getstrptr(tmp) + 1);
	    }
	}
	return (notp ? Null_Word : FalseName());
    }
}
NODE *lbutlast(NODE *args) {
    NODE *val = UNBOUND, *lastnode = NIL, *tnode, *arg;

    arg = bfable_arg(args);
    if (NOT_THROWING) {
	if (is_list(arg)) {
	    args = arg;
	    val = NIL;
	    while (cdr(args) != NIL) {
		tnode = cons(car(args), NIL);
		if (val == NIL) {
		    val = tnode;
		    lastnode = tnode;
		} else {
		    setcdr(lastnode, tnode);
		    lastnode = tnode;
		}
		args = cdr(args);
		if (check_throwing) break;
	    }
	} else {
	    setcar(args, cnv_node_to_strnode(arg));
	    arg = car(args);
	    if (getstrlen(arg) > 1)
		val = make_strnode(getstrptr(arg),
			  getstrhead(arg),
			  getstrlen(arg) - 1,
			  nodetype(arg),
			  strnzcpy);
	    else
		val = Null_Word;
	}
    }
    return(val);
}
Example #8
0
NODE *cnv_node_to_strnode(NODE *nd)
   {
   char s[MAX_NUMBER];

   if (nd == UNBOUND || aggregate(nd))
      {
      return (UNBOUND);
      }
   switch (nodetype(nd))
      {
       case STRING:
       case BACKSLASH_STRING:
       case VBAR_STRING:
           return (nd);
       case CASEOBJ:
           return strnode__caseobj(nd);
       case QUOTE:
           nd = valref(cnv_node_to_strnode(node__quote(nd)));
           nd = reref(nd, make_strnode(getstrptr(nd),
                 (char *) NULL, getstrlen(nd) + 1,
                 nodetype(nd), quote_strnzcpy));
           unref(nd);
           return (nd);
       case COLON:
           nd = valref(cnv_node_to_strnode(node__colon(nd)));
           nd = reref(nd, make_strnode(getstrptr(nd),
                 (char *) NULL, getstrlen(nd) + 1,
                 nodetype(nd), colon_strnzcpy));
           unref(nd);
           return (nd);
       case INT:
           sprintf(s, "%ld", getint(nd));
           return (make_strnode(s, (char *) NULL, (int) strlen(s),
                 STRING, strnzcpy));
       case FLOAT:
           sprintf(s, "%0.15g", getfloat(nd));
           return (make_strnode(s, (char *) NULL, (int) strlen(s),
                 STRING, strnzcpy));
      }

   /*NOTREACHED*/
   return (NIL);
   }
Example #9
0
NODE *luppercase(NODE *args)
   {
   NODE *arg;

   arg = string_arg(args);
   if (NOT_THROWING)
      {
      return make_strnode(getstrptr(arg), (char *) NULL,
         getstrlen(arg), nodetype(arg), cap_strnzcpy);
      }
   return UNBOUND;
   }
NODE *lchar(NODE *args) {
    NODE *val = UNBOUND, *arg;
    char c;

    arg = pos_int_arg(args);
    if (NOT_THROWING) {
	c = (char)getint(arg);
	val = make_strnode(&c, (struct string_block *)NULL, 1,
		       STRING, strnzcpy);
    }
    return(val);
}
Example #11
0
NODE *lreadchar(NODE *args) {
#ifdef WIN32
    MSG msg;
#endif /* WIN32 */
    char c;

    if (readchar_lookahead_buf >= 0) {
	c = (char)readchar_lookahead_buf;
	readchar_lookahead_buf = -1;
	return(make_strnode((char *)&c, (struct string_block *)NULL, 1,
		(getparity(c) ? BACKSLASH_STRING : STRING), strnzcpy));
    }
    charmode_on();
    input_blocking++;
#ifdef HAVE_WX
	if (interactive && readstream==stdin) {
	    reading_char_now = 1;
	    c = getFromWX();
	    reading_char_now = 0;
	}
	else
	    c = (char)getc(readstream);
#else
#ifndef TIOCSTI
    if (!setjmp(iblk_buf))
#endif
    {
#ifdef mac
	csetmode(C_RAW, stdin);
	while ((c = (char)getc(readstream)) == EOF && readstream == stdin);
	csetmode(C_ECHO, stdin);
#else /* !mac */
#ifdef ibm
	if (interactive && readstream==stdin)
#ifndef WIN32
		c = (char)getch();
#else /* WIN32 */
	{
	  win32_update_text();
	  if (!char_avail)
	    while(GetMessage(&msg, NULL, 0, 0))
	    {
	      TranslateMessage(&msg);
	      DispatchMessage(&msg);
	      if (char_avail)
		break;
	    }
	  c = buffered_char;
	  char_avail = 0;
	}
#endif /* WIN32 */	
	else
NODE *litem(NODE *args) {
    int i;
    NODE *obj, *val;

    val = integer_arg(args);
    obj = cadr(args);
    while ((obj == NIL || obj == Null_Word) && NOT_THROWING) {
	setcar(cdr(args), err_logo(BAD_DATA, obj));
	obj = cadr(args);
    }
    if (NOT_THROWING) {
	i = getint(val);
	if (is_list(obj)) {
	    if (i <= 0) {
		err_logo(BAD_DATA_UNREC, val);
		return UNBOUND;
	    }
	    while (--i > 0) {
		obj = cdr(obj);
		if (obj == NIL) {
		    err_logo(BAD_DATA_UNREC, val);
		    return UNBOUND;
		}
	    }
	    return car(obj);
	}
	else if (nodetype(obj) == ARRAY) {
	    i -= getarrorg(obj);
	    if (i < 0 || i >= getarrdim(obj)) {
		err_logo(BAD_DATA_UNREC, val);
		return UNBOUND;
	    }
	    return (getarrptr(obj))[i];
	}
	else {
	    if (i <= 0) {
		err_logo(BAD_DATA_UNREC, val);
		return UNBOUND;
	    }
	    setcar (cdr(args), cnv_node_to_strnode(obj));
	    obj = cadr(args);
	    if (i > getstrlen(obj)) {
		err_logo(BAD_DATA_UNREC, val);
		return UNBOUND;
	    }
	    return make_strnode(getstrptr(obj) + i - 1, getstrhead(obj),
				1, nodetype(obj), strnzcpy);
	}
    }
    return(UNBOUND);
}
Example #13
0
void fileload(char *temp)
   {
   FILE *tmp;
   NODE *tmp_line, *exec_list, *arg;
   NODE *st = valnode__caseobj(Startup);
   int sv_val_status = val_status;
   int IsDirtySave;
   int save_yield_flag;

   arg = make_strnode(temp, NULL, strlen(temp), STRING, strnzcpy);

   IsDirtySave = IsDirty;
   tmp = loadstream;
   tmp_line = vref(current_line);
   loadstream = open_file(arg, "r");
   if (loadstream != NULL)
      {

      save_yield_flag = yield_flag;
      yield_flag = 0;
      lsetcursorwait();

      while (!feof(loadstream) && NOT_THROWING)
         {
         current_line = reref(current_line, reader(loadstream, ""));
         exec_list = parser(current_line, TRUE);
         val_status = 0;
         if (exec_list != NIL) eval_driver(exec_list);
         }
      fclose(loadstream);

      lsetcursorarrow();
      yield_flag = save_yield_flag;

      runstartup(st);
      val_status = sv_val_status;
      }
   else
      err_logo(FILE_ERROR, make_static_strnode("Could not open file"));
   loadstream = tmp;
   deref(current_line);
   current_line = tmp_line;
   IsDirty = IsDirtySave;
   }
NODE *lfirst(NODE *args) {
    NODE *val = UNBOUND, *arg;

    if (nodetype(car(args)) == ARRAY) {
	return make_intnode((FIXNUM)getarrorg(car(args)));
    }
    arg = bfable_arg(args);
    if (NOT_THROWING) {
	if (is_list(arg))
	    val = car(arg);
	else {
	    setcar(args, cnv_node_to_strnode(arg));
	    arg = car(args);
	    val = make_strnode(getstrptr(arg), getstrhead(arg), 1,
			       nodetype(arg), strnzcpy);
	}
    }
    return(val);
}
Example #15
0
NODE *lsetwrite(NODE *arg) {
    FILE *tmp;
    NODE *margs;

    if (writestream == NULL) {
	/* Any setwrite finishes earlier write to string */
	*print_stringptr = '\0';
	writestream = stdout;
	if (find_file(writer_name, FALSE) == NULL) {
	    /* pre-5.4 compatibility mode, implicitly close string */
	    margs = cons(car(writer_name),
			 cons(make_strnode(write_buf, NULL, strlen(write_buf),
					   STRING, strnzcpy),
			      NIL));
	    lmake(margs);
	    free(write_buf);
	}
	writer_name = NIL;
    }
    if (car(arg) == NIL) {
	writestream = stdout;
	writer_name = NIL;
    } else if (is_list(car(arg))) { /* print to string */
	FIXNUM i = int_arg(cdar(arg));
	if ((tmp = find_file(car(arg), FALSE)) != NULL) {
	    writestream = NULL;
	    writer_name = car(arg);
	    print_stringptr = (char *)tmp + strlen((char *)tmp);
	    print_stringlen = i - strlen((char *)tmp);
	} else if (NOT_THROWING && i > 0 && cddr(car(arg)) == NIL) {
	    writestream = NULL;
	    writer_name = copy_list(car(arg));
	    print_stringptr = write_buf = (char *)malloc(i);
	    print_stringlen = i;
	} else err_logo(BAD_DATA_UNREC, car(arg));
    } else if ((tmp = find_file(car(arg), FALSE)) != NULL) {
	writestream = tmp;
	writer_name = car(arg);
    } else
	err_logo(NOT_OPEN_ERROR, car(arg));
    return(UNBOUND);
}
Example #16
0
/* representation of an object */
NODE *lrepresentation(NODE *args) {
    NODE *license, *binding, *classbind;
    char buffer[200];
    char *old_stringptr = print_stringptr;
    int old_stringlen = print_stringlen;

    print_stringlen = 200;
    print_stringptr = buffer;

    license = assoc(theName(Name_licenseplate), getvars(current_object));

    ndprintf(NULL, "${Object %p", getobject(license));
    binding = assoc(theName(Name_name), getvars(current_object));
    if (binding != NIL && getobject(binding) != UNBOUND) {
	ndprintf(NULL, ": %p", getobject(binding));
    }
    classbind = assoc(theName(Name_class), getvars(current_object));
    if (classbind != NIL) {
	if (binding == NIL || getobject(binding) == UNBOUND) {
	    ndprintf(NULL, ":");
	}else {
	    ndprintf(NULL, ",");
	}
	ndprintf(NULL, " the class %p", getobject(classbind));
    } else {
        classbind = varInObjectHierarchy(theName(Name_class), FALSE);
        if (classbind != UNBOUND && classbind != (NODE *)(-1)) {
            if (binding == NIL) {
                ndprintf(NULL, ":");
            } else {
                ndprintf(NULL, ",");
            }
            ndprintf(NULL, " a %p", classbind);
        }
    }
    ndprintf(NULL, "}");
    print_stringptr* = '\0';
    print_stringptr = old_stringptr;
    print_stringlen = old_stringlen;
    return make_strnode(buffer, NULL, strlen(buffer), STRING, strnzcpy);
}
NODE *llast(NODE *args) {
    NODE *val = UNBOUND, *arg;

    arg = bfable_arg(args);
    if (NOT_THROWING) {
	if (is_list(arg)) {
	    args = arg;
	    while (cdr(args) != NIL) {
		args = cdr(args);
		if (check_throwing) break;
	    }
	    val = car(args);
	}
	else {
	    setcar(args, cnv_node_to_strnode(arg));
	    arg = car(args);
	    val = make_strnode(getstrptr(arg) + getstrlen(arg) - 1,
			       getstrhead(arg), 1, nodetype(arg), strnzcpy);
	}
    }
    return(val);
}
NODE *lreadchar()
{
    char c;

    charmode_on();
    input_blocking++;
#ifndef TIOCSTI
    if (!setjmp(iblk_buf))
#endif
#ifdef mac
    csetmode(C_RAW, stdin);
    while ((c = (char)getc(readstream)) == EOF && readstream == stdin);
    csetmode(C_ECHO, stdin);
#else
#ifdef ibm
    if (interactive && readstream==stdin)
	c = (char)getch();
    else
	c = (char)getc(readstream);

    if (c == 17) { /* control-q */
	to_pending = 0;
	err_logo(STOP_ERROR,NIL);
    }
    if (c == 23) { /* control-w */
	logo_pause();
	return(lreadchar());
    }
#else
    c = (char)getc(readstream);
#endif
#endif
    input_blocking = 0;
    if (feof(readstream)) {
	return(NIL);
    }
    return(make_strnode(&c, (char *)NULL, 1,
	    (getparity(c) ? STRING : BACKSLASH_STRING), strnzcpy));
}
NODE *lbutfirst(NODE *args) {
    NODE *val = UNBOUND, *arg;

    arg = bfable_arg(args);
    if (NOT_THROWING) {
	if (is_list(arg))
	    val = cdr(arg);
	else {
	    setcar(args, cnv_node_to_strnode(arg));
	    arg = car(args);
	    if (getstrlen(arg) > 1)
		val = make_strnode(getstrptr(arg) + 1,
			  getstrhead(arg),
			  getstrlen(arg) - 1,
			  nodetype(arg),
			  strnzcpy);
	    else
		val = Null_Word;
	}
    }
    return(val);
}
NODE *lword(NODE *args) {
    NODE *val = NIL, *arg = NIL;
    int cnt = 0;
    NODETYPES str_type = STRING;

    if (args == NIL) return Null_Word;
    val = args;
    while (val != NIL && NOT_THROWING) {
	arg = string_arg(val);
	val = cdr(val);
	if (NOT_THROWING) {
	    if (backslashed(arg))
		str_type = VBAR_STRING;
	    cnt += getstrlen(arg);
	}
    }
    if (NOT_THROWING)
	val = make_strnode((char *)args, (struct string_block *)NULL,
			   cnt, str_type, word_strnzcpy); /* kludge */
    else
	val = UNBOUND;
    return(val);
}
Example #21
0
NODE *reader(FILE *strm, char *prompt) {
    int c = 0, dribbling, vbar = 0, paren = 0;
    int bracket = 0, brace = 0, p_pos, contin=1, insemi=0, raw=0;
    char *phys_line, *lookfor = ender;
    NODETYPES this_type = STRING;
    NODE *ret;
    char *old_stringptr = print_stringptr;
    int old_stringlen = print_stringlen;

    fix_turtle_shownness();

    //readingInstruction = !strcmp(prompt, "? ");
    readingInstruction = (strm == stdin);
#ifdef HAVE_WX
    wx_refresh();
    if(readingInstruction) {
      wx_enable_scrolling();
    }
#endif

    print_stringptr = ender;
    print_stringlen = 99;
    ndprintf(NULL, "\n%p\n", theName(Name_end));
    *print_stringptr = '\0';
    print_stringptr = old_stringptr;
    print_stringlen = old_stringlen;

    if (!strcmp(prompt, "RW")) {	/* called by readword */
	    prompt = "";
	    contin = 0;
    }
    if (!strcmp(prompt, "RAW")) {	/* called by readrawline */
	    prompt = "";
	    contin = 0;
	    raw = 1;
    }
charmode_off();
#ifdef WIN32
    dribbling = 0;
#else
    dribbling = (dribblestream != NULL && strm == stdin);
#endif
    if (p_line == 0) {
    	p_line = malloc(MAX_PHYS_LINE);
	if (p_line == NULL) {
	    err_logo(OUT_OF_MEM, NIL);
		    return UNBOUND;
	}
    	p_end = &p_line[MAX_PHYS_LINE-1];
    }
    phys_line = p_line;
    if (strm == stdin && *prompt) {
	if (interactive) {
	  rd_print_prompt(prompt);
#ifdef WIN32
	  win32_update_text();
#endif
	}
    }
    if (strm == stdin) {
	input_blocking++;
	erract_errtype = FATAL;
    }

#ifndef TIOCSTI
    if (!setjmp(iblk_buf)) {
#endif
    c = rd_getc(strm);
/*    if ((c=='\b' || c=='\127') && strm==stdin && interactive) {
	silent_load(LogoLogo, logolib);
	c = rd_getc(strm);
    } */   /* 6.0 */
#ifdef mac
    if (c == '\r') c = '\n';	/* seen in raw mode by keyp, never read */
#endif
    while (c != EOF && (vbar || paren || bracket || brace || c != '\n')
		    && NOT_THROWING) {
	if (dribbling) rd_putc(c, dribblestream);
	if (!raw && c == '\\' && (c = rd_getc(strm)) != EOF) {
	    if (dribbling) rd_putc(c, dribblestream);
	    c = setparity(c);
	    this_type = BACKSLASH_STRING;
	    if (c == setparity('\n') && strm == stdin) {
		if (interactive) zrd_print_prompt("\\ ");
	    }
	}
	if (c != EOF) into_line(c);
	if (raw) {
	    c = rd_getc(strm);
	    continue;
	}
	if (*prompt && (c&0137) == ((*lookfor)&0137)) {
		lookfor++;
		if (*lookfor == 0) {
		    if (deepend_proc_name != NIL)
			err_logo(DEEPEND, deepend_proc_name);
		    else
			err_logo(DEEPEND_NONAME, NIL);
		    break;
		}
	} else lookfor = ender;
	if (c == '|' && !insemi) {
	    vbar = !vbar;
	    this_type = VBAR_STRING;
	} else if (contin && !vbar && !insemi) {
		if (c == '(') paren++;
		else if (paren && c == ')') paren--;
		else if (c == '[') bracket++;
		else if (bracket && c == ']') bracket--;
		else if (c == '{') brace++;
		else if (brace && c == '}') brace--;
		else if (c == ';') insemi++;
	}

	if (this_type == STRING && strchr(special_chars, c))
	    this_type = VBAR_STRING;
	if (/* (vbar || paren ...) && */ c == '\n') {
	    insemi = 0;
	    if (strm == stdin) {
		if (interactive) zrd_print_prompt(vbar ? "| " : "~ ");
	    }
	}
	while (!vbar && c == '~' && (c = rd_getc(strm)) != EOF) {
	    int gotspc = 0;
	    while (c == ' ' || c == '\t') {
		gotspc = 1;
		c = rd_getc(strm);
	    }
	    if (dribbling) rd_putc(c, dribblestream);
	    if (c != '\n' && gotspc) into_line(' ');
	    into_line(c);
	    if (c == '\n') {
		insemi = 0;
		if (interactive && strm == stdin) zrd_print_prompt("~ ");
	    }
	    else if (c == '(') paren++;
	    else if (paren && c == ')') paren--;
	    else if (c == '[') bracket++;
	    else if (bracket && c == ']') bracket--;
	    else if (c == '{') brace++;
	    else if (brace && c == '}') brace--;
	    else if (c == ';') insemi++;
	}
	if (c != EOF) c = rd_getc(strm);
    }
#ifndef TIOCSTI
    }
#endif
    *phys_line = '\0';
    input_blocking = 0;
#if defined(__RZTC__) && !defined(WIN32) /* sowings */
    fix_cursor();
    if (interactive && strm == stdin) newline_bugfix();
#endif
    if (dribbling)
	rd_putc('\n', dribblestream);
    if (c == EOF && strm == stdin) {
	if (interactive) clearerr(stdin);
	rd_print_prompt("\n");
    }
    if (phys_line == p_line) return(Null_Word); /* so emptyp works */
    ret = make_strnode(p_line, (struct string_block *)NULL, (int)strlen(p_line),
		       this_type, strnzcpy);
#if 0
    if (strm == stdin && !strcmp(prompt, "? ")){
	char *histline = malloc(1+strlen(p_line));
	strcpy(histline, p_line);
	*hist_inptr++ = histline;
	if (hist_inptr >= &cmdHistory[HIST_MAX]) {
	    hist_inptr = cmdHistory;
	}
	if (*hist_inptr) {
	    free(*hist_inptr);
	    *hist_inptr = 0;
	}
	hist_outptr = hist_inptr;
    }
#endif

    //added (evan)
    readingInstruction = 0;
    return(ret);
}
Example #22
0
NODE *parser_iterate(char **inln, char *inlimit, struct string_block *inhead,
		     BOOLEAN semi, int endchar) {
    char ch, *wptr = NULL;
    static char terminate = '\0';   /* KLUDGE */
    NODE *outline = NIL, *lastnode = NIL, *tnode = NIL;
    int windex = 0, vbar = 0;
    NODETYPES this_type = STRING;
    BOOLEAN broken = FALSE;

    do {
	/* get the current character and increase pointer */
	ch = **inln;
	if (!vbar && windex == 0) wptr = *inln;
	if (++(*inln) >= inlimit) *inln = &terminate;

	/* skip through comments and line continuations */
	while (!vbar && ((semi && ch == ';') ||
#ifdef WIN32
		(ch == '~' && (**inln == 012 || **inln == 015)))) {
	    while (ch == '~' && (**inln == 012 || **inln == 015)) {
#else
		(ch == '~' && **inln == '\n'))) {
	    while (ch == '~' && **inln == '\n') {
#endif
		if (++(*inln) >= inlimit) *inln = &terminate;
		ch = **inln;
		if (windex == 0) wptr = *inln;
		else {
		    if (**inln == ']' || **inln == '[' ||
		    			 **inln == '{' || **inln == '}') {
			ch = ' ';
			break;
		    } else {
			broken = TRUE;
		    }
		}
		if (++(*inln) >= inlimit) *inln = &terminate;
	    }

	    if (semi && ch == ';') {
#ifdef WIN32
		if (**inln != 012 && **inln != 015)
#else
		if (**inln != '\n')
#endif
		do {
		    ch = **inln;
		    if (windex == 0) wptr = *inln;
		    else broken = TRUE;
		    if (++(*inln) >= inlimit) *inln = &terminate;
		} 
#ifdef WIN32
		while (ch != '\0' && ch != '~' && **inln != 012 && **inln != 015);
#else /* !Win32 */
		while (ch != '\0' && ch != '~' && **inln != '\n');
#endif
		if (ch != '\0' && ch != '~') ch = '\n';
	    }
	}

	/* flag that this word will be of BACKSLASH_STRING type */
	if (getparity(ch)) this_type = BACKSLASH_STRING;

	if (ch == '|') {
	    vbar = !vbar;
	    this_type = VBAR_STRING;
	    broken = TRUE; /* so we'll copy the chars */
	}

	else if (vbar || (!white_space(ch) && ch != ']' &&
		    ch != '{' && ch != '}' && ch != '['))
	    windex++;

	if (vbar) continue;

	else if (ch == endchar) break;

	else if (ch == ']') err_logo(UNEXPECTED_BRACKET, NIL);
	else if (ch == '}') err_logo(UNEXPECTED_BRACE, NIL);

	/* if this is a '[', parse a new list */
	else if (ch == '[') {
	    tnode = cons(parser_iterate(inln,inlimit,inhead,semi,']'), NIL);
	    if (**inln == '\0') ch = '\0';
	}

	else if (ch == '{') {
	    tnode = cons(list_to_array
			 (parser_iterate(inln,inlimit,inhead,semi,'}')), NIL);
	    if (**inln == '@') {
		int i = 0, sign = 1;

		(*inln)++;
		if (**inln == '-') {
		    sign = -1;
		    (*inln)++;
		}
		while ((ch = **inln) >= '0' && ch <= '9') {
		    i = (i*10) + ch - '0';
		    (*inln)++;
		}
		setarrorg(car(tnode),sign*i);
	    }
	    if (**inln == '\0') ch = '\0';
	}

/* if this character or the next one will terminate string, make the word */
	else if (white_space(ch) || **inln == ']' || **inln == '[' ||
			    **inln == '{' || **inln == '}') {
		if (windex > 0 || this_type == VBAR_STRING) {
		    if (broken == FALSE)
			 tnode = cons(make_strnode(wptr, inhead, windex,
						   this_type, strnzcpy),
				      NIL);
		    else {
			 tnode = cons(make_strnode(wptr,
				 (struct string_block *)NULL, windex,
				 this_type, (semi ? mend_strnzcpy : mend_nosemi)),
				 NIL);
			 broken = FALSE;
		    }
		    this_type = STRING;
		    windex = 0;
		}
	}

	/* put the word onto the end of the return list */
	if (tnode != NIL) {
	    if (outline == NIL) outline = tnode;
	    else setcdr(lastnode, tnode);
	    lastnode = tnode;
	    tnode = NIL;
	}
    } while (ch);
    return(outline);
}

NODE *parser(NODE *nd, BOOLEAN semi) {
    NODE *rtn;
    int slen;
    char *lnsav;

    rtn = cnv_node_to_strnode(nd);
    slen = getstrlen(rtn);
    lnsav = getstrptr(rtn);
    rtn = parser_iterate(&lnsav,lnsav + slen,getstrhead(rtn),semi,-1);
    return(rtn);
}

NODE *lparse(NODE *args) {
    NODE *arg, *val = UNBOUND;

    arg = string_arg(args);
    if (NOT_THROWING) {
	val = parser(arg, FALSE);
    }
    return(val);
}
Example #23
0
NODE *runparse_node(NODE *nd, NODE **ndsptr) {
    NODE *outline = NIL, *tnode = NIL, *lastnode = NIL, *snd;
    char *wptr, *tptr;
    struct string_block *whead;
    int wlen, wcnt, tcnt, isnumb, gotdot;
    NODETYPES wtyp;
    BOOLEAN monadic_minus = FALSE;

    if (nd == Minus_Tight) return cons(nd, NIL);
    snd = cnv_node_to_strnode(nd);
    wptr = getstrptr(snd);
    wlen = getstrlen(snd);
    wtyp = nodetype(snd);
    wcnt = 0;
    whead = getstrhead(snd);

    while (wcnt < wlen) {
	if (*wptr == ';') {
	    *ndsptr = NIL;
	    break;
	}
	if (*wptr == '"') {
	    tcnt = 0;
	    tptr = ++wptr;
	    wcnt++;
	    while (wcnt < wlen && !parens(*wptr)) {
		if (wtyp == BACKSLASH_STRING && getparity(*wptr))
		    wtyp = PUNBOUND;    /* flag for "\( case */
		wptr++, wcnt++, tcnt++;
	    }
	    if (wtyp == PUNBOUND) {
		wtyp = BACKSLASH_STRING;
		tnode = cons(make_quote(intern(make_strnode(tptr, NULL,
					tcnt, wtyp, noparity_strnzcpy))), NIL);
	    } else
		tnode = cons(make_quote(intern(make_strnode(tptr, whead, tcnt,
				        wtyp, strnzcpy))), NIL);
	} else if (*wptr == ':') {
	    tcnt = 0;
	    tptr = ++wptr;
	    wcnt++;
	    while (wcnt < wlen && !parens(*wptr) && !infixs(*wptr))
		wptr++, wcnt++, tcnt++;
	    tnode = cons(make_colon(intern(make_strnode(tptr, whead, tcnt,
				    wtyp, strnzcpy))), NIL);
	} else if (wcnt == 0 && *wptr == '-' && monadic_minus == FALSE &&
		   wcnt+1 < wlen && !white_space(*(wptr+1))) {
	/* minus sign with space before and no space after is unary */
	    tnode = cons(make_intnode((FIXNUM)0), NIL);
	    monadic_minus = TRUE;
	} else if (parens(*wptr) || infixs(*wptr)) {
	    if (monadic_minus)
		tnode = cons(Minus_Tight, NIL);
	    else if (wcnt+1 < wlen && 
		     ((*wptr == '<' && (*(wptr+1) == '=' || *(wptr+1) == '>'))
		     || (*wptr == '>' && *(wptr+1) == '='))) {
		tnode = cons(intern(make_strnode(wptr, whead, 2,
						 STRING, strnzcpy)), NIL);
		wptr++, wcnt++;
	    } else
		tnode = cons(intern(make_strnode(wptr, whead, 1,
						 STRING, strnzcpy)), NIL);
	    monadic_minus = FALSE;
	    wptr++, wcnt++;
	} else {
	    tcnt = 0;
	    tptr = wptr;
	    /* isnumb 4 means nothing yet;
	     * 0 means digits so far, 1 means just saw
	     * 'e' so minus can be next, 2 means no longer
	     * eligible even if an 'e' comes along */
	    isnumb = 4;
	    gotdot = 0;
	    if (*wptr == '?') {
		isnumb = 3; /* turn ?5 to (? 5) */
		wptr++, wcnt++, tcnt++;
	    }
	    while (wcnt < wlen && !parens(*wptr) &&
		   (!infixs(*wptr) || (isnumb == 1 && (*wptr == '-' || *wptr == '+')))) {
		if (isnumb == 4 && isdigit(*wptr)) isnumb = 0;
		if (isnumb == 0 && tcnt > 0 && (*wptr == 'e' || *wptr == 'E'))
		    isnumb = 1;
		else if (!(isdigit(*wptr) || (!gotdot && *wptr == '.')) || isnumb == 1)
		    isnumb = 2;
		if (*wptr == '.') gotdot++;
		wptr++, wcnt++, tcnt++;
	    }
	    if (isnumb == 3 && tcnt > 1) {    /* ?5 syntax */
		NODE *qmtnode;

		qmtnode = cons_list(0, Left_Paren, Query,
				    cnv_node_to_numnode
					(make_strnode(tptr+1, whead,
						      tcnt-1, wtyp, strnzcpy)),
				    END_OF_LIST);
		if (outline == NIL) {
		    outline = qmtnode;
		} else {
		    setcdr(lastnode, qmtnode);
		}
		lastnode = cddr(qmtnode);
		tnode = cons(Right_Paren, NIL);
	    } else if (isnumb < 2 && tcnt > 0) {
		tnode = cons(cnv_node_to_numnode(make_strnode(tptr, whead, tcnt,
							      wtyp, strnzcpy)),
			     NIL);
	    } else
		tnode = cons(intern(make_strnode(tptr, whead, tcnt,
						 wtyp, strnzcpy)),
			     NIL);
	}

	if (outline == NIL) outline = tnode;
	else setcdr(lastnode, tnode);
	lastnode = tnode;
    }
    return(outline);
}
Example #24
0
/* Creates new license plate for object */
NODE *newplate(void) {
    char buffer[20];
    sprintf(buffer,"G%d", gensymnum++);
    return make_strnode(buffer, NULL, strlen(buffer), STRING, strnzcpy);
    return UNBOUND;
}