\r
+ misc:\r
\r
+- stream server can hang because of exception handler limitations\r
- each-with map-with\r
- step: print NEXT word to execute, not word that JUST executed\r
- perhaps /i should work with all numbers\r
Cons pair = FactorPlugin.getExternalInstance()
.parseObject(w.getText());
- String write = (String)pair.car;
- AttributeSet attrs = new ListenerAttributeSet(
- (Cons)pair.next().car);
-
- output.writeAttrs(attrs,write);
+ if(pair.car instanceof String)
+ {
+ String write = (String)pair.car;
+ AttributeSet attrs = new ListenerAttributeSet(
+ (Cons)pair.next().car);
+
+ output.writeAttrs(attrs,write);
+ }
+ else
+ Log.log(Log.ERROR,this,"Malformed write packet: " + pair);
}
void packetLoop(Output output) throws Exception
FactorWord word = def.word;
/* word lines are indexed from 1 */
- int startLine = Math.min(
+ int startLine = Math.max(0,Math.min(
buffer.getLineCount() - 1,
- word.line - 1);
+ word.line - 1));
int startLineLength = buffer.getLineLength(startLine);
int startCol = Math.min(word.col,startLineLength);
+ startCol;
if(last != null)
- last.end = buffer.createPosition(start - 1);
+ last.end = buffer.createPosition(Math.max(0,start - 1));
last = new FactorAsset(word,buffer.createPosition(start));
d.root.add(new DefaultMutableTreeNode(last));
if(type == null)
return;
- FactorWord generic = reader.nextWord(true);
+ FactorWord generic = reader.nextWord(false);
if(generic == null)
return;
: type-name ( n -- string )
builtin-type word-name ;
+: class ( obj -- class )
+ #! Analogous to the type primitive. Pushes the builtin
+ #! class of an object.
+ type builtin-type ;
+
global [ num-types <vector> types set ] bind
USE: words
USE: hashtables
-: unify-d-in ( list -- d-in )
- 0 swap [ [ d-in get ] bind [ max ] when* ] each ;
-
-: balanced? ( list -- ? )
- [ [ d-in get meta-d get and ] bind ] subset
- [ [ d-in get meta-d get vector-length - ] bind ] map all=? ;
-
: longest-vector ( list -- length )
[ vector-length ] map [ > ] top ;
-: unify-result ( obj obj -- obj )
+: unify-lengths ( list -- list )
+ #! Pad all vectors to the same length. If one vector is
+ #! shorter, pad it with unknown results at the bottom.
+ dup longest-vector swap [ dupd ensure nip ] map nip ;
+
+: unify-classes ( class class -- class )
+ #! Return a class that both classes are subclasses of.
+ 2dup = [ drop ] [ 2drop object ] ifte ;
+
+: unify-results ( obj obj -- obj )
#! Replace values with unknown result if they differ,
#! otherwise retain them.
- 2dup = [ drop ] [ 2drop <computed-value> ] ifte ;
+ 2dup = [
+ drop
+ ] [
+ value-class swap value-class unify-classes <computed>
+ ] ifte ;
: unify-stacks ( list -- stack )
#! Replace differing literals in stacks with unknown
#! results.
- uncons [ [ unify-result ] vector-2map ] each ;
+ uncons [ [ unify-results ] vector-2map ] each ;
-: unify-lengths ( list -- list )
- #! Pad all vectors to the same length. If one vector is
- #! shorter, pad it with unknown results at the bottom.
- dup longest-vector swap [ dupd ensure nip ] map nip ;
+: unify-d-in ( list -- d-in )
+ [ [ d-in get ] bind ] map unify-lengths unify-stacks ;
+
+: filter-terminators ( list -- list )
+ [ [ d-in get meta-d get and ] bind ] subset ;
+
+: balanced? ( list -- ? )
+ [
+ [
+ d-in get vector-length
+ meta-d get vector-length -
+ ] bind
+ ] map all=? ;
: unify-datastacks ( list -- datastack )
- [ [ meta-d get ] bind ] map [ ] subset
+ [ [ meta-d get ] bind ] map
unify-lengths unify-stacks ;
: check-lengths ( list -- )
] unless ;
: unify-callstacks ( list -- datastack )
- [ [ meta-r get ] bind ] map [ ] subset
+ [ [ meta-r get ] bind ] map
dup check-lengths unify-stacks ;
: unify ( list -- )
- dup balanced? [
+ filter-terminators dup balanced? [
dup unify-d-in d-in set
dup unify-datastacks meta-d set
unify-callstacks meta-r set
save-effect set
dup value-recursion recursive-state set
copy-interpreter
+ d-in [ vector-clone ] change
dataflow-graph off
- literal infer-quot
+ literal-value infer-quot
#values values-node
] extend ;
#! This is a hack. undefined-method has a stack effect that
#! probably does not match any other branch of the generic,
#! so we handle it specially.
- literal \ undefined-method swap tree-contains? ;
+ literal-value \ undefined-method swap tree-contains? ;
: recursive-branch ( value -- )
#! Set base case if inference didn't fail.
[
f infer-branch [
- d-in get meta-d get vector-length cons
- recursive-state get set-base
+ effect recursive-state get set-base
] bind
] [
[ drop ] when
\ ifte [ infer-ifte ] "infer" set-word-property
: vtable>list ( value -- list )
- dup value-recursion swap literal vector>list
- [ over <literal-value> ] map nip ;
+ dup value-recursion swap literal-value vector>list
+ [ over <literal> ] map nip ;
: infer-dispatch ( -- )
#! Infer effects for all branches, unify.
! A value has the following slots:
-! the literal object, if any.
-SYMBOL: value
-
-! value-type -- the type, if known.
-SYMBOL: value-type
-
-GENERIC: literal ( value -- obj )
+GENERIC: literal-value ( value -- obj )
GENERIC: value= ( literal value -- ? )
+GENERIC: value-class ( value -- class )
-TRAITS: computed-value
-C: computed-value ( -- value )
- [ gensym value set ] extend ;
-M: computed-value literal ( value -- obj )
+TRAITS: computed
+C: computed ( class -- value )
+ [
+ \ value-class set
+ gensym \ literal-value set
+ ] extend ;
+M: computed literal-value ( value -- obj )
"Cannot use a computed value literally." throw ;
-M: computed-value value= ( literal value -- ? )
+M: computed value= ( literal value -- ? )
2drop f ;
-
-TRAITS: literal-value
-C: literal-value ( obj rstate -- value )
- [ recursive-state set value set ] extend ;
-M: literal-value literal ( value -- obj )
- [ value get ] bind ;
-M: literal-value value= ( literal value -- ? )
- literal = ;
+M: computed value-class ( value -- class )
+ [ \ value-class get ] bind ;
+
+TRAITS: literal
+C: literal ( obj rstate -- value )
+ [ recursive-state set \ literal-value set ] extend ;
+M: literal literal-value ( value -- obj )
+ [ \ literal-value get ] bind ;
+M: literal value= ( literal value -- ? )
+ literal-value = ;
+M: literal value-class ( value -- class )
+ literal-value class ;
: value-recursion ( value -- rstate )
[ recursive-state get ] bind ;
-: computed-value-vector ( n -- vector )
- [ drop <computed-value> ] vector-project ;
+: computed-value-vector ( n -- vector )
+ [ drop object <computed> ] vector-project ;
: add-inputs ( count stack -- stack )
#! Add this many inputs to the given stack.
: ensure-d ( count -- )
#! Ensure count of unknown results are on the stack.
- meta-d [ ensure ] change d-in [ + ] change ;
-
-: consume-d ( count -- )
- #! Remove count of elements.
- [ pop-d drop ] times ;
-
-: produce-d ( count -- )
- #! Push count of unknown results.
- [ <computed-value> push-d ] times ;
+ meta-d [ ensure ] change
+ d-in get swap [ object <computed> over vector-push ] times
+ drop ;
: effect ( -- [ in | out ] )
#! After inference is finished, collect information.
- d-in get meta-d get vector-length cons ;
+ d-in get vector-length meta-d get vector-length cons ;
: <recursive-state> ( -- state )
<namespace> [
: init-inference ( recursive-state -- )
init-interpreter
- 0 d-in set
+ 0 <vector> d-in set
recursive-state set
dataflow-graph off
save-effect on ;
: apply-literal ( obj -- )
#! Literals are annotated with the current recursive
#! state.
- dup recursive-state get <literal-value> push-d
+ dup recursive-state get <literal> push-d
#push dataflow, [ 1 0 node-outputs ] bind ;
: apply-object ( obj -- )
: dataflow ( quot -- dataflow )
#! Data flow of a quotation.
[ (infer) get-dataflow ] with-scope ;
+
+: type-infer ( quot -- [ in-types out-types ] )
+ [
+ (infer)
+ d-in get [ value-class ] vector-map
+ meta-d get [ value-class ] vector-map 2list
+ ] with-scope ;
IN: inference
USE: errors
+USE: generic
USE: interpreter
USE: kernel
USE: lists
[ pick swap dataflow-inputs ] keep
pick 2slip swap dataflow-outputs ; inline
+: consume-d ( count -- )
+ #! Remove count of elements.
+ [ pop-d drop ] times ;
+
+: produce-d ( count -- )
+ #! Push count of unknown results.
+ [ object <computed> push-d ] times ;
+
: (consume/produce) ( param op effect -- )
- [ unswons consume-d produce-d ] with-dataflow ;
+ [
+ dup cdr cons? [
+ ( new style )
+
+ ] [
+ ( old style, will go away shortly )
+ unswons consume-d produce-d
+ ] ifte
+ ] with-dataflow ;
: consume/produce ( word [ in | out ] -- )
#! Add a node to the dataflow graph that consumes and
#! If at the location of the recursive call, we're taking
#! more items from the stack than producing, we have a
#! diverging recursion.
- d-in get meta-d get vector-length > [
+ d-in get vector-length
+ meta-d get vector-length > [
current-word word-name " diverges." cat2 throw
] when ;
gensym dup [
drop pop-d dup
value-recursion recursive-state set
- literal infer-quot
+ literal-value infer-quot
] with-block ;
\ call [ infer-call ] "infer" set-word-property
GENERIC: fwrite-attr ( string style stream -- )
GENERIC: fclose ( stream -- )
-: fread1 ( stream -- string )
- 1 swap fread# dup f-or-"" [ 0 swap str-nth ] unless ;
+: fread1 ( stream -- char/f )
+ 1 swap fread#
+ dup f-or-"" [ drop f ] [ 0 swap str-nth ] ifte ;
: fwrite ( string stream -- )
f swap fwrite-attr ;
"!!! The following error is part of the test" print
[ [ "2 car" ] parse ] [ default-error-handler ] catch
+
+[ [ "\"\" { } vector-nth" ] parse ] [ type-check-error ] catch
+
+[ "cons" ] [ [ 1 2 ] type type-error-name ] unit-test
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
+
+[ -1 read# ] unit-test-fails
: type-error-name ( n -- string )
#! These values are only used by the kernel for error
#! reporting.
- [
+ dup [
[ 100 | "fixnum/bignum" ]
[ 101 | "fixnum/bignum/ratio" ]
[ 102 | "fixnum/bignum/ratio/float" ]
[ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ]
- ] assoc [ type-name ] unless* ;
+ ] assoc dup [
+ nip
+ ] [
+ drop type-name
+ ] ifte ;
: type-check-error ( list -- )
"Type check error" print
"Object type: " write type type-error-name print
"Expected type: " write type-error-name print ;
-: array-range-error ( list -- )
- "Array range check error" print
- unswons "Object: " write .
- uncons car "Maximum index: " write .
- "Requested index: " write . ;
+: range-error ( list -- )
+ "Range check error" print
+ unswons [ "Object: " write . ] when*
+ unswons "Minimum index: " write .
+ unswons "Requested index: " write .
+ car "Maximum index: " write . ;
: float-format-error ( list -- )
"Invalid floating point literal format: " write . ;
io-error
undefined-word-error
type-check-error
- array-range-error
+ range-error
float-format-error
signal-error
negative-array-size-error
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: vectors
+IN: kernel-internals
USE: generic
+
+BUILTIN: array 8
+
+IN: vectors
USE: kernel
USE: lists
USE: math
-BUILTIN: vector 11
+BUILTIN: vector 11
: empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike
return to_integer(dpop());
}
+CELL to_cell(CELL x)
+{
+ F_FIXNUM fixnum;
+ F_ARRAY* bignum;
+
+ switch(type_of(x))
+ {
+ case FIXNUM_TYPE:
+ fixnum = untag_fixnum_fast(x);
+ if(fixnum < 0)
+ {
+ range_error(F,0,tag_fixnum(fixnum),FIXNUM_MAX);
+ return -1;
+ }
+ else
+ return (CELL)fixnum;
+ break;
+ case BIGNUM_TYPE:
+ bignum = to_bignum(dpop());
+ if(BIGNUM_NEGATIVE_P(bignum))
+ {
+ range_error(F,0,tag_object(bignum),FIXNUM_MAX);
+ return -1;
+ }
+ else
+ return s48_bignum_to_long(untag_bignum(x));
+ default:
+ type_error(INTEGER_TYPE,x);
+ return 0;
+ }
+}
/* FFI calls this */
CELL unbox_cell(void)
{
- return to_integer(dpop());
+ return to_cell(dpop());
}
F_ARRAY* to_bignum(CELL tagged)
}
F_FIXNUM to_integer(CELL x);
+CELL to_cell(CELL x);
+
DLLEXPORT void box_integer(F_FIXNUM integer);
DLLEXPORT void box_cell(CELL cell);
DLLEXPORT F_FIXNUM unbox_integer(void);
+CELL to_cell(CELL x);
DLLEXPORT CELL unbox_cell(void);
F_ARRAY* to_bignum(CELL tagged);
void primitive_to_bignum(void);
void check_compiled_offset(CELL offset)
{
if(offset < compiling.base || offset >= compiling.limit)
- range_error(F,offset,compiling.limit);
+ range_error(F,0,to_integer(offset),compiling.limit);
}
void primitive_set_compiled_byte(void)
general_error(ERROR_TYPE,c);
}
-void range_error(CELL tagged, F_FIXNUM index, CELL max)
+/* index must be tagged */
+void range_error(CELL tagged, CELL min, CELL index, CELL max)
{
- CELL c = cons(tagged,cons(tag_integer(index),cons(tag_cell(max),F)));
+ CELL c = cons(tagged,cons(tag_cell(min),
+ cons(index,cons(tag_cell(max),F))));
general_error(ERROR_RANGE,c);
}
void signal_error(int signal);
void type_error(CELL type, CELL tagged);
void primitive_throw(void);
-void range_error(CELL tagged, F_FIXNUM index, CELL max);
+/* index must be tagged */
+void range_error(CELL tagged, CELL min, CELL index, CELL max);
{
F_FIXNUM e = to_fixnum(dpeek());
if(e < 0 || e >= USER_ENV)
- range_error(F,e,USER_ENV);
+ range_error(F,0,tag_fixnum(e),USER_ENV);
drepl(userenv[e]);
}
F_FIXNUM e = to_fixnum(dpop());
CELL value = dpop();
if(e < 0 || e >= USER_ENV)
- range_error(F,e,USER_ENV);
+ range_error(F,0,tag_fixnum(e),USER_ENV);
userenv[e] = value;
}
str = untag_string(sbuf->string);
length = to_fixnum(dpop());
if(length < 0)
- range_error(tag_object(sbuf),length,sbuf->top);
+ range_error(tag_object(sbuf),0,to_fixnum(length),sbuf->top);
sbuf->top = length;
if(length > str->capacity)
sbuf->string = tag_object(grow_string(str,length,F));
CELL index = to_fixnum(dpop());
if(index < 0 || index >= sbuf->top)
- range_error(tag_object(sbuf),index,sbuf->top);
+ range_error(tag_object(sbuf),0,to_fixnum(index),sbuf->top);
dpush(string_nth(untag_string(sbuf->string),index));
}
void set_sbuf_nth(F_SBUF* sbuf, CELL index, uint16_t value)
{
if(index < 0)
- range_error(tag_object(sbuf),index,sbuf->top);
+ range_error(tag_object(sbuf),0,to_fixnum(index),sbuf->top);
else if(index >= sbuf->top)
sbuf_ensure_capacity(sbuf,index + 1);
CELL index = to_fixnum(dpop());
if(index < 0 || index >= string->capacity)
- range_error(tag_object(string),index,string->capacity);
+ range_error(tag_object(string),0,to_fixnum(index),string->capacity);
dpush(tag_fixnum(string_nth(string,index)));
}
index = to_fixnum(dpop());
if(index < 0 || index > string->capacity)
{
- range_error(tag_object(string),index,string->capacity);
+ range_error(tag_object(string),0,to_fixnum(index),string->capacity);
result = -1; /* can't happen */
}
else if(TAG(ch) == FIXNUM_TYPE)
F_STRING* result;
if(start < 0)
- range_error(tag_object(string),start,string->capacity);
+ range_error(tag_object(string),0,to_fixnum(start),string->capacity);
if(end < start || end > string->capacity)
- range_error(tag_object(string),end,string->capacity);
+ range_error(tag_object(string),0,to_fixnum(end),string->capacity);
result = allot_string(end - start);
memcpy(result + 1,
void primitive_can_read_count(void)
{
F_PORT* port;
- F_FIXNUM len;
+ CELL len;
maybe_garbage_collection();
port = untag_port(dpop());
- len = to_fixnum(dpop());
+ len = to_cell(dpop());
box_boolean(can_read_count(port,len));
}
{
CELL callback;
F_PORT* port;
- F_FIXNUM count;
+ CELL count;
maybe_garbage_collection();
callback = dpop();
port = untag_port(dpop());
- count = to_fixnum(dpop());
+ count = to_cell(dpop());
add_io_task(IO_TASK_READ_COUNT,
tag_object(port),F,callback,
read_io_tasks,&read_fd_count);
void primitive_read_count_8(void)
{
F_PORT* port;
- F_FIXNUM len;
+ CELL len;
maybe_garbage_collection();
port = untag_port(dpop());
- len = to_fixnum(dpop());
+ len = to_cell(dpop());
if(port->count != len)
critical_error("read# counts don't match",tag_object(port));
array = untag_array(vector->array);
if(length < 0)
- range_error(tag_object(vector),length,vector->top);
+ range_error(tag_object(vector),0,to_fixnum(length),vector->top);
vector->top = length;
if(length > array->capacity)
vector->array = tag_object(grow_array(array,length,F));
CELL index = to_fixnum(dpop());
if(index < 0 || index >= vector->top)
- range_error(tag_object(vector),index,vector->top);
+ range_error(tag_object(vector),0,to_fixnum(index),vector->top);
dpush(array_nth(untag_array(vector->array),index));
}
value = dpop();
if(index < 0)
- range_error(tag_object(vector),index,vector->top);
+ range_error(tag_object(vector),0,to_fixnum(index),vector->top);
else if(index >= vector->top)
vector_ensure_capacity(vector,index);
projects / factor.git / commitdiff