CC = gcc
-DEFAULT_CFLAGS = -Wall -g $(SITE_CFLAGS)
+DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS)
DEFAULT_LIBS = -lm
STRIP = strip
f: $(OBJS)
$(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS)
- #$(STRIP) $@
+ $(STRIP) $@
clean:
rm -f $(OBJS)
\r
+ ffi:\r
\r
+- value type structs\r
+- unicode strings\r
+- out parameters\r
- figure out how to load an image referring to missing libraries\r
- is signed -vs- unsigned pointers an issue?\r
- bitfields in C structs\r
+ kernel:\r
\r
- ppc register decls\r
-- do partial objects cause problems?\r
-- remove sbufs\r
- cat, reverse-cat primitives\r
- first-class hashtables\r
\r
+ misc:\r
\r
+- make-vector and make-string should not need a reverse step\r
- perhaps /i should work with all numbers\r
- jedit ==> jedit-word, jedit takes a file name\r
- browser responder for word links in HTTPd\r
--- /dev/null
+! Gradient rendering demo.
+!
+! To run this code, bootstrap Factor like so:
+!
+! ./f boot.image.le32
+! -libraries:sdl:name=libSDL.so
+! -libraries:sdl-gfx:name=libSDL_gfx.so
+! -libraries:sdl-ttf:name=libSDL_ttf.so
+!
+! (But all on one line)
+!
+! Then, start Factor as usual (./f factor.image) and enter this
+! at the listener:
+!
+! "examples/grad-demo.factor" run-file
+
+IN: grad-demo
+USE: streams
+USE: sdl
+USE: sdl-event
+USE: sdl-gfx
+USE: sdl-video
+USE: sdl-ttf
+USE: namespaces
+USE: math
+USE: kernel
+USE: test
+USE: compiler
+USE: strings
+USE: alien
+USE: prettyprint
+USE: lists
+
+: draw-grad ( -- )
+ [ over rgb ] with-pixels ; compiled
+
+: grad-demo ( -- )
+ 640 480 0 SDL_HWSURFACE [
+ TTF_Init
+ [ draw-grad ] with-surface
+ <event> event-loop
+ SDL_Quit
+ ] with-screen ;
+
+grad-demo
: scale 255 * >fixnum ;
-: scale-rgb ( r g b -- n )
+: scale-rgb ( r g b a -- n )
scale
swap scale 8 shift bitor
swap scale 16 shift bitor
: <color-map> ( nb-cols -- map )
[
dup [
- dup 360 * over 1 + / 360 / sat val
+ dup 360 * pick 1 + / 360 / sat val
hsv>rgb 1.0 scale-rgb ,
] repeat
- ] make-list list>vector nip ;
+ ] make-vector nip ;
: absq >rect swap sq swap sq + ; inline
height get 150000 zoom-fact get * / y-inc set
nb-iter get max-color min <color-map> cols set ;
-: c ( #{ i j }# -- c )
+: c ( i j -- c )
>r
x-inc get * center get real x-inc get width get 2 / * - + >float
r>
] with-pixels ; compiled
: mandel ( -- )
- 640 480 32 SDL_HWSURFACE [
+ 640 480 0 SDL_HWSURFACE [
[
0.8 zoom-fact set
-0.65 center set
--- /dev/null
+! :folding=none:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2005 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: kernel-internals
+USE: generic
+USE: math-internals
+USE: kernel
+
+! An array is a range of memory storing pointers to other
+! objects. Arrays are not used directly, and their access words
+! are not bounds checked. Examples of abstractions built on
+! arrays include vectors, hashtables, and tuples.
+
+! These words are unsafe. I'd say "do not call them", but that
+! Java-esque. By all means, do use arrays if you need something
+! low-level... but be aware that vectors are usually a better
+! choice.
+
+BUILTIN: array 8
+
+: array-capacity ( array -- n ) 1 integer-slot ; inline
+: vector-array ( vec -- array ) 2 slot ; inline
+: set-vector-array ( array vec -- ) 2 set-slot ; inline
+
+: array-nth ( n array -- obj )
+ swap 2 fixnum+ slot ; inline
+
+: set-array-nth ( obj n array -- )
+ swap 2 fixnum+ set-slot ; inline
"/version.factor"\r
"/library/stack.factor"\r
"/library/combinators.factor"\r
+ "/library/arrays.factor"\r
"/library/kernel.factor"\r
"/library/cons.factor"\r
"/library/assoc.factor"\r
"/version.factor" parse-resource append,
"/library/stack.factor" parse-resource append,
"/library/combinators.factor" parse-resource append,
+ "/library/arrays.factor" parse-resource append,
"/library/kernel.factor" parse-resource append,
"/library/cons.factor" parse-resource append,
"/library/assoc.factor" parse-resource append,
! Save a bit of space
global [ stdio off ] bind
-garbage-collection
"factor.image" save-image
0 exit*
[[ "kernel" "ifte" ]]
[[ "lists" "cons" ]]
[[ "vectors" "<vector>" ]]
- [[ "vectors" "vector-nth" ]]
- [[ "vectors" "set-vector-nth" ]]
[[ "strings" "str-nth" ]]
[[ "strings" "str-compare" ]]
[[ "strings" "str=" ]]
! $Id$
!
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: hashtables
+IN: kernel-internals
USE: generic
USE: kernel
USE: lists
USE: math
USE: vectors
+: hash-array vector-array ; inline
+: bucket-count >vector hash-array array-capacity ; inline
+
+: hash-bucket ( n hash -- alist )
+ swap >fixnum swap >vector hash-array array-nth ; inline
+
+: set-hash-bucket ( obj n hash -- )
+ >r >fixnum r> hash-array set-array-nth ; inline
+
+IN: hashtables
+
! Note that the length of a hashtable vector must not change
! for the lifetime of the hashtable, otherwise problems will
! occur. Do not use vector words with hashtables.
: (hashcode) ( key table -- index )
#! Compute the index of the bucket for a key.
- >r hashcode r> vector-length rem ; inline
+ >r hashcode r> bucket-count rem ; inline
: hash* ( key table -- [[ key value ]] )
#! Look up a value in the hashtable. First the bucket is
#! determined using the hash function, then the association
#! list therein is searched linearly.
- 2dup (hashcode) swap vector-nth assoc* ;
+ 2dup (hashcode) swap hash-bucket assoc* ;
: hash ( key table -- value )
#! Unlike hash*, this word cannot distinglish between an
2dup (hashcode)
r> pick >r
over >r
- >r swap vector-nth r> call
+ >r swap hash-bucket r> call
r>
- r> set-vector-nth ; inline
+ r> set-hash-bucket ; inline
: set-hash ( value key table -- )
#! Store the value in the hashtable. Either replaces an
#! Apply the code to each key/value pair of the hashtable.
swap [ swap dup >r each r> ] vector-each drop ; inline
-: hash-subset ( hash code -- hash )
- #! Return a new hashtable containing all key/value pairs
- #! for which the predicate yielded a true value. The
- #! predicate must have stack effect ( obj -- ? ).
- swap [ swap dup >r subset r> swap ] vector-map nip ; inline
-
: hash-keys ( hash -- list )
#! Push a list of keys in a hashtable.
[ ] swap [ car swons ] hash-each ;
: unify-stacks ( list -- stack )
#! Replace differing literals in stacks with unknown
#! results.
- unify-lengths vector-transpose [ unify-results ] vector-map ;
+ unify-lengths vector-transpose [ unify-results ] vector-map ;
: balanced? ( list -- ? )
#! Check if a list of [[ instack outstack ]] pairs is
] unless* ;
: unify-effects ( list -- )
- filter-terminators dup datastack-effect callstack-effect ;
+ filter-terminators dup datastack-effect callstack-effect ;
SYMBOL: cloned
\ >string \ string infer-check
] "infer" set-word-property
-\ slot [
- [ object fixnum ] ensure-d
- dataflow-drop, pop-d literal-value
- peek-d value-class builtin-supertypes dup length 1 = [
- cons \ slot [ [ object ] [ object ] ] (consume/produce)
- ] [
- "slot called without static type knowledge" throw
- ] ifte
-] "infer" set-word-property
+! \ slot [
+! [ object fixnum ] ensure-d
+! dataflow-drop, pop-d literal-value
+! peek-d value-class builtin-supertypes dup length 1 = [
+! cons \ slot [ [ object ] [ object ] ] (consume/produce)
+! ] [
+! "slot called without static type knowledge" throw
+! ] ifte
+! ] "infer" set-word-property
: type-value-map ( value -- )
num-types [ dup builtin-type pick swons cons ] project
USE: vectors
: dispatch ( n vtable -- )
- #! This word is unsafe in compiled code since n is not
- #! bounds-checked. Do not call it directly.
- vector-nth call ;
+ #! This word is unsafe since n is not bounds-checked. Do not
+ #! call it directly.
+ vector-array array-nth call ;
IN: kernel
#! was called.
make-rlist reverse ; inline
+: make-vector ( quot -- list )
+ #! Return a vector whose entries are in the same order that
+ #! , was called.
+ make-list list>vector ; inline
+
: , ( obj -- )
#! Append an object to the currently constructing list.
list-buffer cons@ ;
[ ifte [ [ object general-list general-list ] [ ] ] ]
[ cons [ [ object object ] [ cons ] ] ]
[ <vector> [ [ integer ] [ vector ] ] ]
- [ vector-nth [ [ integer vector ] [ object ] ] ]
- [ set-vector-nth [ [ object integer vector ] [ ] ] ]
[ str-nth [ [ integer string ] [ integer ] ] ]
[ str-compare [ [ string string ] [ integer ] ] ]
[ str= [ [ string string ] [ boolean ] ] ]
[ set-slot [ [ object object fixnum ] [ ] ] ]
[ integer-slot [ [ object fixnum ] [ integer ] ] ]
[ set-integer-slot [ [ integer object fixnum ] [ ] ] ]
- [ grow-array [ [ integer array ] [ integer ] ] ]
+ [ grow-array [ [ integer array ] [ object ] ] ]
] [
2unlist dup string? [
"stack-effect" set-word-property
USE: vectors
USE: strings
USE: namespaces
+USE: kernel-internals
[ [ t f t ] vector-length ] unit-test-fails
[ 3 ] [ { t f t } vector-length ] unit-test
+[ -3 { } vector-nth ] unit-test-fails
[ 3 { } vector-nth ] unit-test-fails
[ 3 #{ 1 2 }# vector-nth ] unit-test-fails
[ "funny-stack" get vector-pop ] unit-test-fails
[ ] [ "funky" "funny-stack" get vector-push ] unit-test
[ "funky" ] [ "funny-stack" get vector-pop ] unit-test
+
+[ t ] [
+ 10 <vector> dup vector-array array-capacity
+ >r vector-clone vector-array array-capacity r>
+ =
+] unit-test
SYMBOL: console-font
#! Font height.
SYMBOL: line-height
+#! If this is on, the console will be redrawn on the next event
+#! refresh cycle.
+SYMBOL: redraw-console
#! The font size is hardcoded here.
: char-width 8 ;
0 y set
clear-display
draw-lines
- draw-current
- draw-input
+ height get y get - line-height get >= [
+ draw-current
+ draw-input
+ ] when
draw-scrollbar
] with-surface ;
lines get vector-push scroll-to-bottom ;
: console-write ( text -- )
- "\n" split1 [
+ "\n" split1 [
swap output-line get sbuf-append
output-line get empty-buffer add-line
] when*
M: console-stream fauto-flush ( stream -- )
[
- console get [ draw-console ] bind
+ console get [ redraw-console on ] bind
] bind ;
M: console-stream freadln ( stream -- line )
M: key-down-event handle-event ( event -- ? )
dup keyboard-event>binding keymap get hash [
- call draw-console
+ call redraw-console on
] [
dup input-key? [
- keyboard-event-unicode user-input draw-console
+ keyboard-event-unicode user-input redraw-console on
] [
drop
] ifte
: scrollbar-click ( y -- )
dup scrollbar-top < [
- drop page-scroll-up draw-console
+ drop page-scroll-up redraw-console on
] [
dup scrollbar-bottom > [
- drop page-scroll-down draw-console
+ drop page-scroll-down redraw-console on
] [
drag-start-y set
first-line get drag-start-line set
motion-event-y drag-start-y get -
height get / total-lines * drag-start-line get +
>fixnum fix-first-line first-line set
- draw-console
+ redraw-console on
] [
drop
] ifte t ;
dup resize-event-w swap resize-event-h
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
scroll-to-bottom
- draw-console t ;
+ redraw-console on t ;
M: quit-event handle-event ( event -- ? )
drop f ;
SDL_EnableKeyRepeat drop ;
: console-loop ( -- )
+ redraw-console get [ draw-console redraw-console off ] when
check-event [ console-loop ] when ;
: console-quit ( -- )
] callcc0
console get [
- draw-console
+ redraw-console on
console-loop
console-quit
] bind
! $Id$
!
-! Copyright (C) 2004 Slava Pestov.
+! Copyright (C) 2004, 2005 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+IN: vectors
USE: generic
USE: kernel
USE: lists
USE: math
+USE: kernel-internals
+USE: errors
+USE: math-internals
+
+BUILTIN: vector 11
-IN: errors
-DEFER: throw
+: vector-length ( vec -- len ) >vector 1 integer-slot ; inline
IN: kernel-internals
-BUILTIN: array 8
+: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline
+
+: assert-positive ( fx -- )
+ 0 fixnum<
+ [ "Vector index must be positive" throw ] when ; inline
-! UNSAFE!
-: array-capacity ( array -- n ) 1 integer-slot ; inline
-: vector-array ( vec -- array ) 2 slot ; inline
-: set-vector-array ( array vec -- ) 2 set-slot ; inline
+: assert-bounds ( fx vec -- )
+ over assert-positive
+ vector-length fixnum>=
+ [ "Vector index out of bounds" throw ] when ; inline
-: grow-vector-array ( len vec -- )
+: grow-capacity ( len vec -- )
+ #! If the vector cannot accomodate len elements, resize it
+ #! to exactly len.
[ vector-array grow-array ] keep set-vector-array ; inline
-: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline
+: ensure-capacity ( n vec -- )
+ #! If n is beyond the vector's length, increase the length,
+ #! growing the array if necessary, with an optimistic
+ #! doubling of its size.
+ 2dup vector-length fixnum>= [
+ >r 1 fixnum+ r>
+ 2dup vector-array array-capacity fixnum> [
+ over 2 fixnum* over grow-capacity
+ ] when
+ (set-vector-length)
+ ] [
+ 2drop
+ ] ifte ; inline
IN: vectors
-BUILTIN: vector 11
+: vector-nth ( n vec -- obj )
+ swap >fixnum swap >vector
+ 2dup assert-bounds vector-array array-nth ;
-: vector-length ( vec -- len ) >vector 1 integer-slot ; inline
+: set-vector-nth ( obj n vec -- )
+ swap >fixnum dup assert-positive swap >vector
+ 2dup ensure-capacity vector-array
+ set-array-nth ;
: set-vector-length ( len vec -- )
- >vector over 0 < [
- "Vector length must be positive" throw 2drop
- ] [
- 2dup (set-vector-length) grow-vector-array
- ] ifte ; inline
+ swap >fixnum dup assert-positive swap >vector
+ 2dup grow-capacity (set-vector-length) ;
: empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike
#define ASIZE(pointer) align8(sizeof(F_ARRAY) + \
((F_ARRAY*)(pointer))->capacity * CELLS)
-/* untagged & unchecked */
-INLINE CELL array_nth(F_ARRAY* array, CELL index)
-{
- return get(AREF(array,index));
-}
-
-/* untagged & unchecked */
-INLINE void set_array_nth(F_ARRAY* array, CELL index, CELL value)
-{
- put(AREF(array,index),value);
-}
-
void fixup_array(F_ARRAY* array);
void collect_array(F_ARRAY* array);
fflush(stderr);
flip_zones();
- scan = active.here = active.base;
+ scan = active.base;
collect_roots();
collect_io_tasks();
/* collect literal objects referenced from compiled code */
void primitive_save_image(void)
{
- F_STRING* filename = untag_string(dpop());
+ F_STRING* filename;
+ primitive_gc();
+ filename = untag_string(dpop());
save_image(to_c_string(filename));
}
ZONE z = active;
active = prior;
prior = z;
+ active.here = active.base;
}
bool in_zone(ZONE* z, CELL pointer)
primitive_ifte,
primitive_cons,
primitive_vector,
- primitive_vector_nth,
- primitive_set_vector_nth,
primitive_string_nth,
primitive_string_compare,
primitive_string_eq,
extern void* primitives[];
-#define PRIMITIVE_COUNT 195
+#define PRIMITIVE_COUNT 194
CELL primitive_to_xt(CELL primitive);
fprintf(stderr,"active.here = %ld\n",active.here);
fprintf(stderr,"active.limit = %ld\n",active.limit);
fflush(stderr);
+ flip_zones();
+ dump_stacks();
exit(1);
}
else
type_check(VECTOR_TYPE,dpeek());
}
-void primitive_vector_nth(void)
-{
- F_VECTOR* vector = untag_vector(dpop());
- CELL index = to_fixnum(dpop());
-
- if(index < 0 || index >= vector->top)
- range_error(tag_object(vector),0,tag_fixnum(index),vector->top);
- dpush(array_nth(untag_array(vector->array),index));
-}
-
-void vector_ensure_capacity(F_VECTOR* vector, CELL index)
-{
- F_ARRAY* array = untag_array(vector->array);
- CELL capacity = array->capacity;
- if(index >= capacity)
- array = grow_array(array,index * 2 + 1,F);
- vector->top = index + 1;
- vector->array = tag_object(array);
-}
-
-void primitive_set_vector_nth(void)
-{
- F_VECTOR* vector;
- F_FIXNUM index;
- CELL value;
-
- maybe_garbage_collection();
-
- vector = untag_vector(dpop());
- index = to_fixnum(dpop());
- value = dpop();
-
- if(index < 0)
- range_error(tag_object(vector),0,tag_fixnum(index),vector->top);
- else if(index >= vector->top)
- vector_ensure_capacity(vector,index);
-
- /* the following does not check bounds! */
- set_array_nth(untag_array(vector->array),index,value);
-}
-
void fixup_vector(F_VECTOR* vector)
{
data_fixup(&vector->array);
void primitive_vector(void);
void primitive_to_vector(void);
-void primitive_vector_nth(void);
-void vector_ensure_capacity(F_VECTOR* vector, CELL index);
-void primitive_set_vector_nth(void);
void fixup_vector(F_VECTOR* vector);
void collect_vector(F_VECTOR* vector);
projects / factor.git / commitdiff