array refactoring; started hashtable refactoring
parent
4a6f404cc2
commit
0dfb0cf01e
4
Makefile
4
Makefile
|
@ -1,5 +1,5 @@
|
||||||
CC = gcc
|
CC = gcc
|
||||||
DEFAULT_CFLAGS = -Wall -g $(SITE_CFLAGS)
|
DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS)
|
||||||
DEFAULT_LIBS = -lm
|
DEFAULT_LIBS = -lm
|
||||||
|
|
||||||
STRIP = strip
|
STRIP = strip
|
||||||
|
@ -68,7 +68,7 @@ solaris:
|
||||||
|
|
||||||
f: $(OBJS)
|
f: $(OBJS)
|
||||||
$(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS)
|
$(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS)
|
||||||
#$(STRIP) $@
|
$(STRIP) $@
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -f $(OBJS)
|
rm -f $(OBJS)
|
||||||
|
|
|
@ -17,6 +17,9 @@
|
||||||
|
|
||||||
+ ffi:
|
+ ffi:
|
||||||
|
|
||||||
|
- value type structs
|
||||||
|
- unicode strings
|
||||||
|
- out parameters
|
||||||
- figure out how to load an image referring to missing libraries
|
- figure out how to load an image referring to missing libraries
|
||||||
- is signed -vs- unsigned pointers an issue?
|
- is signed -vs- unsigned pointers an issue?
|
||||||
- bitfields in C structs
|
- bitfields in C structs
|
||||||
|
@ -49,13 +52,12 @@
|
||||||
+ kernel:
|
+ kernel:
|
||||||
|
|
||||||
- ppc register decls
|
- ppc register decls
|
||||||
- do partial objects cause problems?
|
|
||||||
- remove sbufs
|
|
||||||
- cat, reverse-cat primitives
|
- cat, reverse-cat primitives
|
||||||
- first-class hashtables
|
- first-class hashtables
|
||||||
|
|
||||||
+ misc:
|
+ misc:
|
||||||
|
|
||||||
|
- make-vector and make-string should not need a reverse step
|
||||||
- perhaps /i should work with all numbers
|
- perhaps /i should work with all numbers
|
||||||
- jedit ==> jedit-word, jedit takes a file name
|
- jedit ==> jedit-word, jedit takes a file name
|
||||||
- browser responder for word links in HTTPd
|
- browser responder for word links in HTTPd
|
||||||
|
|
|
@ -0,0 +1,45 @@
|
||||||
|
! 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
|
|
@ -32,7 +32,7 @@ USE: test
|
||||||
|
|
||||||
: scale 255 * >fixnum ;
|
: scale 255 * >fixnum ;
|
||||||
|
|
||||||
: scale-rgb ( r g b -- n )
|
: scale-rgb ( r g b a -- n )
|
||||||
scale
|
scale
|
||||||
swap scale 8 shift bitor
|
swap scale 8 shift bitor
|
||||||
swap scale 16 shift bitor
|
swap scale 16 shift bitor
|
||||||
|
@ -44,10 +44,10 @@ USE: test
|
||||||
: <color-map> ( nb-cols -- map )
|
: <color-map> ( nb-cols -- map )
|
||||||
[
|
[
|
||||||
dup [
|
dup [
|
||||||
dup 360 * over 1 + / 360 / sat val
|
dup 360 * pick 1 + / 360 / sat val
|
||||||
hsv>rgb 1.0 scale-rgb ,
|
hsv>rgb 1.0 scale-rgb ,
|
||||||
] repeat
|
] repeat
|
||||||
] make-list list>vector nip ;
|
] make-vector nip ;
|
||||||
|
|
||||||
: absq >rect swap sq swap sq + ; inline
|
: absq >rect swap sq swap sq + ; inline
|
||||||
|
|
||||||
|
@ -72,7 +72,7 @@ SYMBOL: center
|
||||||
height get 150000 zoom-fact get * / y-inc set
|
height get 150000 zoom-fact get * / y-inc set
|
||||||
nb-iter get max-color min <color-map> cols set ;
|
nb-iter get max-color min <color-map> cols set ;
|
||||||
|
|
||||||
: c ( #{ i j }# -- c )
|
: c ( i j -- c )
|
||||||
>r
|
>r
|
||||||
x-inc get * center get real x-inc get width get 2 / * - + >float
|
x-inc get * center get real x-inc get width get 2 / * - + >float
|
||||||
r>
|
r>
|
||||||
|
@ -89,7 +89,7 @@ SYMBOL: center
|
||||||
] with-pixels ; compiled
|
] with-pixels ; compiled
|
||||||
|
|
||||||
: mandel ( -- )
|
: mandel ( -- )
|
||||||
640 480 32 SDL_HWSURFACE [
|
640 480 0 SDL_HWSURFACE [
|
||||||
[
|
[
|
||||||
0.8 zoom-fact set
|
0.8 zoom-fact set
|
||||||
-0.65 center set
|
-0.65 center set
|
||||||
|
|
|
@ -0,0 +1,53 @@
|
||||||
|
! :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
|
|
@ -48,6 +48,7 @@ USE: namespaces
|
||||||
"/version.factor"
|
"/version.factor"
|
||||||
"/library/stack.factor"
|
"/library/stack.factor"
|
||||||
"/library/combinators.factor"
|
"/library/combinators.factor"
|
||||||
|
"/library/arrays.factor"
|
||||||
"/library/kernel.factor"
|
"/library/kernel.factor"
|
||||||
"/library/cons.factor"
|
"/library/cons.factor"
|
||||||
"/library/assoc.factor"
|
"/library/assoc.factor"
|
||||||
|
|
|
@ -42,6 +42,7 @@ USE: hashtables
|
||||||
"/version.factor" parse-resource append,
|
"/version.factor" parse-resource append,
|
||||||
"/library/stack.factor" parse-resource append,
|
"/library/stack.factor" parse-resource append,
|
||||||
"/library/combinators.factor" parse-resource append,
|
"/library/combinators.factor" parse-resource append,
|
||||||
|
"/library/arrays.factor" parse-resource append,
|
||||||
"/library/kernel.factor" parse-resource append,
|
"/library/kernel.factor" parse-resource append,
|
||||||
"/library/cons.factor" parse-resource append,
|
"/library/cons.factor" parse-resource append,
|
||||||
"/library/assoc.factor" parse-resource append,
|
"/library/assoc.factor" parse-resource append,
|
||||||
|
|
|
@ -114,6 +114,5 @@ unparse write " words total" print
|
||||||
! Save a bit of space
|
! Save a bit of space
|
||||||
global [ stdio off ] bind
|
global [ stdio off ] bind
|
||||||
|
|
||||||
garbage-collection
|
|
||||||
"factor.image" save-image
|
"factor.image" save-image
|
||||||
0 exit*
|
0 exit*
|
||||||
|
|
|
@ -59,8 +59,6 @@ vocabularies get [
|
||||||
[[ "kernel" "ifte" ]]
|
[[ "kernel" "ifte" ]]
|
||||||
[[ "lists" "cons" ]]
|
[[ "lists" "cons" ]]
|
||||||
[[ "vectors" "<vector>" ]]
|
[[ "vectors" "<vector>" ]]
|
||||||
[[ "vectors" "vector-nth" ]]
|
|
||||||
[[ "vectors" "set-vector-nth" ]]
|
|
||||||
[[ "strings" "str-nth" ]]
|
[[ "strings" "str-nth" ]]
|
||||||
[[ "strings" "str-compare" ]]
|
[[ "strings" "str-compare" ]]
|
||||||
[[ "strings" "str=" ]]
|
[[ "strings" "str=" ]]
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
! $Id$
|
! $Id$
|
||||||
!
|
!
|
||||||
! Copyright (C) 2004 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
!
|
!
|
||||||
! Redistribution and use in source and binary forms, with or without
|
! Redistribution and use in source and binary forms, with or without
|
||||||
! modification, are permitted provided that the following conditions are met:
|
! modification, are permitted provided that the following conditions are met:
|
||||||
|
@ -25,13 +25,24 @@
|
||||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
|
||||||
IN: hashtables
|
IN: kernel-internals
|
||||||
USE: generic
|
USE: generic
|
||||||
USE: kernel
|
USE: kernel
|
||||||
USE: lists
|
USE: lists
|
||||||
USE: math
|
USE: math
|
||||||
USE: vectors
|
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
|
! Note that the length of a hashtable vector must not change
|
||||||
! for the lifetime of the hashtable, otherwise problems will
|
! for the lifetime of the hashtable, otherwise problems will
|
||||||
! occur. Do not use vector words with hashtables.
|
! occur. Do not use vector words with hashtables.
|
||||||
|
@ -48,13 +59,13 @@ PREDICATE: vector hashtable ( obj -- ? )
|
||||||
|
|
||||||
: (hashcode) ( key table -- index )
|
: (hashcode) ( key table -- index )
|
||||||
#! Compute the index of the bucket for a key.
|
#! 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 ]] )
|
: hash* ( key table -- [[ key value ]] )
|
||||||
#! Look up a value in the hashtable. First the bucket is
|
#! Look up a value in the hashtable. First the bucket is
|
||||||
#! determined using the hash function, then the association
|
#! determined using the hash function, then the association
|
||||||
#! list therein is searched linearly.
|
#! list therein is searched linearly.
|
||||||
2dup (hashcode) swap vector-nth assoc* ;
|
2dup (hashcode) swap hash-bucket assoc* ;
|
||||||
|
|
||||||
: hash ( key table -- value )
|
: hash ( key table -- value )
|
||||||
#! Unlike hash*, this word cannot distinglish between an
|
#! Unlike hash*, this word cannot distinglish between an
|
||||||
|
@ -67,9 +78,9 @@ PREDICATE: vector hashtable ( obj -- ? )
|
||||||
2dup (hashcode)
|
2dup (hashcode)
|
||||||
r> pick >r
|
r> pick >r
|
||||||
over >r
|
over >r
|
||||||
>r swap vector-nth r> call
|
>r swap hash-bucket r> call
|
||||||
r>
|
r>
|
||||||
r> set-vector-nth ; inline
|
r> set-hash-bucket ; inline
|
||||||
|
|
||||||
: set-hash ( value key table -- )
|
: set-hash ( value key table -- )
|
||||||
#! Store the value in the hashtable. Either replaces an
|
#! Store the value in the hashtable. Either replaces an
|
||||||
|
@ -85,12 +96,6 @@ PREDICATE: vector hashtable ( obj -- ? )
|
||||||
#! Apply the code to each key/value pair of the hashtable.
|
#! Apply the code to each key/value pair of the hashtable.
|
||||||
swap [ swap dup >r each r> ] vector-each drop ; inline
|
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 )
|
: hash-keys ( hash -- list )
|
||||||
#! Push a list of keys in a hashtable.
|
#! Push a list of keys in a hashtable.
|
||||||
[ ] swap [ car swons ] hash-each ;
|
[ ] swap [ car swons ] hash-each ;
|
||||||
|
|
|
@ -63,15 +63,15 @@ USE: prettyprint
|
||||||
\ >string \ string infer-check
|
\ >string \ string infer-check
|
||||||
] "infer" set-word-property
|
] "infer" set-word-property
|
||||||
|
|
||||||
\ slot [
|
! \ slot [
|
||||||
[ object fixnum ] ensure-d
|
! [ object fixnum ] ensure-d
|
||||||
dataflow-drop, pop-d literal-value
|
! dataflow-drop, pop-d literal-value
|
||||||
peek-d value-class builtin-supertypes dup length 1 = [
|
! peek-d value-class builtin-supertypes dup length 1 = [
|
||||||
cons \ slot [ [ object ] [ object ] ] (consume/produce)
|
! cons \ slot [ [ object ] [ object ] ] (consume/produce)
|
||||||
] [
|
! ] [
|
||||||
"slot called without static type knowledge" throw
|
! "slot called without static type knowledge" throw
|
||||||
] ifte
|
! ] ifte
|
||||||
] "infer" set-word-property
|
! ] "infer" set-word-property
|
||||||
|
|
||||||
: type-value-map ( value -- )
|
: type-value-map ( value -- )
|
||||||
num-types [ dup builtin-type pick swons cons ] project
|
num-types [ dup builtin-type pick swons cons ] project
|
||||||
|
|
|
@ -31,9 +31,9 @@ USE: kernel
|
||||||
USE: vectors
|
USE: vectors
|
||||||
|
|
||||||
: dispatch ( n vtable -- )
|
: dispatch ( n vtable -- )
|
||||||
#! This word is unsafe in compiled code since n is not
|
#! This word is unsafe since n is not bounds-checked. Do not
|
||||||
#! bounds-checked. Do not call it directly.
|
#! call it directly.
|
||||||
vector-nth call ;
|
vector-array array-nth call ;
|
||||||
|
|
||||||
IN: kernel
|
IN: kernel
|
||||||
|
|
||||||
|
|
|
@ -153,6 +153,11 @@ SYMBOL: list-buffer
|
||||||
#! was called.
|
#! was called.
|
||||||
make-rlist reverse ; inline
|
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 -- )
|
: , ( obj -- )
|
||||||
#! Append an object to the currently constructing list.
|
#! Append an object to the currently constructing list.
|
||||||
list-buffer cons@ ;
|
list-buffer cons@ ;
|
||||||
|
|
|
@ -55,8 +55,6 @@ USE: words
|
||||||
[ ifte [ [ object general-list general-list ] [ ] ] ]
|
[ ifte [ [ object general-list general-list ] [ ] ] ]
|
||||||
[ cons [ [ object object ] [ cons ] ] ]
|
[ cons [ [ object object ] [ cons ] ] ]
|
||||||
[ <vector> [ [ integer ] [ vector ] ] ]
|
[ <vector> [ [ integer ] [ vector ] ] ]
|
||||||
[ vector-nth [ [ integer vector ] [ object ] ] ]
|
|
||||||
[ set-vector-nth [ [ object integer vector ] [ ] ] ]
|
|
||||||
[ str-nth [ [ integer string ] [ integer ] ] ]
|
[ str-nth [ [ integer string ] [ integer ] ] ]
|
||||||
[ str-compare [ [ string string ] [ integer ] ] ]
|
[ str-compare [ [ string string ] [ integer ] ] ]
|
||||||
[ str= [ [ string string ] [ boolean ] ] ]
|
[ str= [ [ string string ] [ boolean ] ] ]
|
||||||
|
@ -222,7 +220,7 @@ USE: words
|
||||||
[ set-slot [ [ object object fixnum ] [ ] ] ]
|
[ set-slot [ [ object object fixnum ] [ ] ] ]
|
||||||
[ integer-slot [ [ object fixnum ] [ integer ] ] ]
|
[ integer-slot [ [ object fixnum ] [ integer ] ] ]
|
||||||
[ set-integer-slot [ [ integer object fixnum ] [ ] ] ]
|
[ set-integer-slot [ [ integer object fixnum ] [ ] ] ]
|
||||||
[ grow-array [ [ integer array ] [ integer ] ] ]
|
[ grow-array [ [ integer array ] [ object ] ] ]
|
||||||
] [
|
] [
|
||||||
2unlist dup string? [
|
2unlist dup string? [
|
||||||
"stack-effect" set-word-property
|
"stack-effect" set-word-property
|
||||||
|
|
|
@ -6,10 +6,12 @@ USE: test
|
||||||
USE: vectors
|
USE: vectors
|
||||||
USE: strings
|
USE: strings
|
||||||
USE: namespaces
|
USE: namespaces
|
||||||
|
USE: kernel-internals
|
||||||
|
|
||||||
[ [ t f t ] vector-length ] unit-test-fails
|
[ [ t f t ] vector-length ] unit-test-fails
|
||||||
[ 3 ] [ { t f t } vector-length ] unit-test
|
[ 3 ] [ { t f t } vector-length ] unit-test
|
||||||
|
|
||||||
|
[ -3 { } vector-nth ] unit-test-fails
|
||||||
[ 3 { } vector-nth ] unit-test-fails
|
[ 3 { } vector-nth ] unit-test-fails
|
||||||
[ 3 #{ 1 2 }# vector-nth ] unit-test-fails
|
[ 3 #{ 1 2 }# vector-nth ] unit-test-fails
|
||||||
|
|
||||||
|
@ -74,3 +76,9 @@ unit-test
|
||||||
[ "funny-stack" get vector-pop ] unit-test-fails
|
[ "funny-stack" get vector-pop ] unit-test-fails
|
||||||
[ ] [ "funky" "funny-stack" get vector-push ] unit-test
|
[ ] [ "funky" "funny-stack" get vector-push ] unit-test
|
||||||
[ "funky" ] [ "funny-stack" get vector-pop ] 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
|
||||||
|
|
|
@ -83,6 +83,9 @@ SYMBOL: input-line
|
||||||
SYMBOL: console-font
|
SYMBOL: console-font
|
||||||
#! Font height.
|
#! Font height.
|
||||||
SYMBOL: line-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.
|
#! The font size is hardcoded here.
|
||||||
: char-width 8 ;
|
: char-width 8 ;
|
||||||
|
@ -174,8 +177,10 @@ SYMBOL: line-height
|
||||||
0 y set
|
0 y set
|
||||||
clear-display
|
clear-display
|
||||||
draw-lines
|
draw-lines
|
||||||
|
height get y get - line-height get >= [
|
||||||
draw-current
|
draw-current
|
||||||
draw-input
|
draw-input
|
||||||
|
] when
|
||||||
draw-scrollbar
|
draw-scrollbar
|
||||||
] with-surface ;
|
] with-surface ;
|
||||||
|
|
||||||
|
@ -215,7 +220,7 @@ M: console-stream fflush ( stream -- )
|
||||||
|
|
||||||
M: console-stream fauto-flush ( stream -- )
|
M: console-stream fauto-flush ( stream -- )
|
||||||
[
|
[
|
||||||
console get [ draw-console ] bind
|
console get [ redraw-console on ] bind
|
||||||
] bind ;
|
] bind ;
|
||||||
|
|
||||||
M: console-stream freadln ( stream -- line )
|
M: console-stream freadln ( stream -- line )
|
||||||
|
@ -280,10 +285,10 @@ SYMBOL: keymap
|
||||||
|
|
||||||
M: key-down-event handle-event ( event -- ? )
|
M: key-down-event handle-event ( event -- ? )
|
||||||
dup keyboard-event>binding keymap get hash [
|
dup keyboard-event>binding keymap get hash [
|
||||||
call draw-console
|
call redraw-console on
|
||||||
] [
|
] [
|
||||||
dup input-key? [
|
dup input-key? [
|
||||||
keyboard-event-unicode user-input draw-console
|
keyboard-event-unicode user-input redraw-console on
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] ifte
|
] ifte
|
||||||
|
@ -296,10 +301,10 @@ SYMBOL: drag-start-line
|
||||||
|
|
||||||
: scrollbar-click ( y -- )
|
: scrollbar-click ( y -- )
|
||||||
dup scrollbar-top < [
|
dup scrollbar-top < [
|
||||||
drop page-scroll-up draw-console
|
drop page-scroll-up redraw-console on
|
||||||
] [
|
] [
|
||||||
dup scrollbar-bottom > [
|
dup scrollbar-bottom > [
|
||||||
drop page-scroll-down draw-console
|
drop page-scroll-down redraw-console on
|
||||||
] [
|
] [
|
||||||
drag-start-y set
|
drag-start-y set
|
||||||
first-line get drag-start-line set
|
first-line get drag-start-line set
|
||||||
|
@ -323,7 +328,7 @@ M: motion-event handle-event ( event -- ? )
|
||||||
motion-event-y drag-start-y get -
|
motion-event-y drag-start-y get -
|
||||||
height get / total-lines * drag-start-line get +
|
height get / total-lines * drag-start-line get +
|
||||||
>fixnum fix-first-line first-line set
|
>fixnum fix-first-line first-line set
|
||||||
draw-console
|
redraw-console on
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] ifte t ;
|
] ifte t ;
|
||||||
|
@ -332,7 +337,7 @@ M: resize-event handle-event ( event -- ? )
|
||||||
dup resize-event-w swap resize-event-h
|
dup resize-event-w swap resize-event-h
|
||||||
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
|
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
|
||||||
scroll-to-bottom
|
scroll-to-bottom
|
||||||
draw-console t ;
|
redraw-console on t ;
|
||||||
|
|
||||||
M: quit-event handle-event ( event -- ? )
|
M: quit-event handle-event ( event -- ? )
|
||||||
drop f ;
|
drop f ;
|
||||||
|
@ -366,6 +371,7 @@ M: alien handle-event ( event -- ? )
|
||||||
SDL_EnableKeyRepeat drop ;
|
SDL_EnableKeyRepeat drop ;
|
||||||
|
|
||||||
: console-loop ( -- )
|
: console-loop ( -- )
|
||||||
|
redraw-console get [ draw-console redraw-console off ] when
|
||||||
check-event [ console-loop ] when ;
|
check-event [ console-loop ] when ;
|
||||||
|
|
||||||
: console-quit ( -- )
|
: console-quit ( -- )
|
||||||
|
@ -395,7 +401,7 @@ IN: shells
|
||||||
] callcc0
|
] callcc0
|
||||||
|
|
||||||
console get [
|
console get [
|
||||||
draw-console
|
redraw-console on
|
||||||
console-loop
|
console-loop
|
||||||
console-quit
|
console-quit
|
||||||
] bind
|
] bind
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
! $Id$
|
! $Id$
|
||||||
!
|
!
|
||||||
! Copyright (C) 2004 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
!
|
!
|
||||||
! Redistribution and use in source and binary forms, with or without
|
! Redistribution and use in source and binary forms, with or without
|
||||||
! modification, are permitted provided that the following conditions are met:
|
! modification, are permitted provided that the following conditions are met:
|
||||||
|
@ -25,41 +25,66 @@
|
||||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
|
||||||
|
IN: vectors
|
||||||
USE: generic
|
USE: generic
|
||||||
USE: kernel
|
USE: kernel
|
||||||
USE: lists
|
USE: lists
|
||||||
USE: math
|
USE: math
|
||||||
|
USE: kernel-internals
|
||||||
IN: errors
|
USE: errors
|
||||||
DEFER: throw
|
USE: math-internals
|
||||||
|
|
||||||
IN: kernel-internals
|
|
||||||
|
|
||||||
BUILTIN: array 8
|
|
||||||
|
|
||||||
! 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
|
|
||||||
|
|
||||||
: grow-vector-array ( len vec -- )
|
|
||||||
[ vector-array grow-array ] keep set-vector-array ; inline
|
|
||||||
|
|
||||||
: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline
|
|
||||||
|
|
||||||
IN: vectors
|
|
||||||
|
|
||||||
BUILTIN: vector 11
|
BUILTIN: vector 11
|
||||||
|
|
||||||
: vector-length ( vec -- len ) >vector 1 integer-slot ; inline
|
: vector-length ( vec -- len ) >vector 1 integer-slot ; inline
|
||||||
|
|
||||||
: set-vector-length ( len vec -- )
|
IN: kernel-internals
|
||||||
>vector over 0 < [
|
|
||||||
"Vector length must be positive" throw 2drop
|
: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline
|
||||||
|
|
||||||
|
: assert-positive ( fx -- )
|
||||||
|
0 fixnum<
|
||||||
|
[ "Vector index must be positive" throw ] when ; inline
|
||||||
|
|
||||||
|
: assert-bounds ( fx vec -- )
|
||||||
|
over assert-positive
|
||||||
|
vector-length fixnum>=
|
||||||
|
[ "Vector index out of bounds" throw ] when ; inline
|
||||||
|
|
||||||
|
: 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
|
||||||
|
|
||||||
|
: 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)
|
||||||
] [
|
] [
|
||||||
2dup (set-vector-length) grow-vector-array
|
2drop
|
||||||
] ifte ; inline
|
] ifte ; inline
|
||||||
|
|
||||||
|
IN: vectors
|
||||||
|
|
||||||
|
: vector-nth ( n vec -- obj )
|
||||||
|
swap >fixnum swap >vector
|
||||||
|
2dup assert-bounds vector-array array-nth ;
|
||||||
|
|
||||||
|
: 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 -- )
|
||||||
|
swap >fixnum dup assert-positive swap >vector
|
||||||
|
2dup grow-capacity (set-vector-length) ;
|
||||||
|
|
||||||
: empty-vector ( len -- vec )
|
: empty-vector ( len -- vec )
|
||||||
#! Creates a vector with 'len' elements set to f. Unlike
|
#! Creates a vector with 'len' elements set to f. Unlike
|
||||||
#! <vector>, which gives an empty vector with a certain
|
#! <vector>, which gives an empty vector with a certain
|
||||||
|
|
|
@ -21,17 +21,5 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);
|
||||||
#define ASIZE(pointer) align8(sizeof(F_ARRAY) + \
|
#define ASIZE(pointer) align8(sizeof(F_ARRAY) + \
|
||||||
((F_ARRAY*)(pointer))->capacity * CELLS)
|
((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 fixup_array(F_ARRAY* array);
|
||||||
void collect_array(F_ARRAY* array);
|
void collect_array(F_ARRAY* array);
|
||||||
|
|
|
@ -119,7 +119,7 @@ void primitive_gc(void)
|
||||||
fflush(stderr);
|
fflush(stderr);
|
||||||
|
|
||||||
flip_zones();
|
flip_zones();
|
||||||
scan = active.here = active.base;
|
scan = active.base;
|
||||||
collect_roots();
|
collect_roots();
|
||||||
collect_io_tasks();
|
collect_io_tasks();
|
||||||
/* collect literal objects referenced from compiled code */
|
/* collect literal objects referenced from compiled code */
|
||||||
|
|
|
@ -115,6 +115,8 @@ bool save_image(char* filename)
|
||||||
|
|
||||||
void primitive_save_image(void)
|
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));
|
save_image(to_c_string(filename));
|
||||||
}
|
}
|
||||||
|
|
|
@ -87,6 +87,7 @@ void flip_zones()
|
||||||
ZONE z = active;
|
ZONE z = active;
|
||||||
active = prior;
|
active = prior;
|
||||||
prior = z;
|
prior = z;
|
||||||
|
active.here = active.base;
|
||||||
}
|
}
|
||||||
|
|
||||||
bool in_zone(ZONE* z, CELL pointer)
|
bool in_zone(ZONE* z, CELL pointer)
|
||||||
|
|
|
@ -9,8 +9,6 @@ void* primitives[] = {
|
||||||
primitive_ifte,
|
primitive_ifte,
|
||||||
primitive_cons,
|
primitive_cons,
|
||||||
primitive_vector,
|
primitive_vector,
|
||||||
primitive_vector_nth,
|
|
||||||
primitive_set_vector_nth,
|
|
||||||
primitive_string_nth,
|
primitive_string_nth,
|
||||||
primitive_string_compare,
|
primitive_string_compare,
|
||||||
primitive_string_eq,
|
primitive_string_eq,
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
extern void* primitives[];
|
extern void* primitives[];
|
||||||
#define PRIMITIVE_COUNT 195
|
#define PRIMITIVE_COUNT 194
|
||||||
|
|
||||||
CELL primitive_to_xt(CELL primitive);
|
CELL primitive_to_xt(CELL primitive);
|
||||||
|
|
|
@ -9,6 +9,8 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap)
|
||||||
fprintf(stderr,"active.here = %ld\n",active.here);
|
fprintf(stderr,"active.here = %ld\n",active.here);
|
||||||
fprintf(stderr,"active.limit = %ld\n",active.limit);
|
fprintf(stderr,"active.limit = %ld\n",active.limit);
|
||||||
fflush(stderr);
|
fflush(stderr);
|
||||||
|
flip_zones();
|
||||||
|
dump_stacks();
|
||||||
exit(1);
|
exit(1);
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
|
|
|
@ -22,47 +22,6 @@ void primitive_to_vector(void)
|
||||||
type_check(VECTOR_TYPE,dpeek());
|
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)
|
void fixup_vector(F_VECTOR* vector)
|
||||||
{
|
{
|
||||||
data_fixup(&vector->array);
|
data_fixup(&vector->array);
|
||||||
|
|
|
@ -17,8 +17,5 @@ F_VECTOR* vector(F_FIXNUM capacity);
|
||||||
|
|
||||||
void primitive_vector(void);
|
void primitive_vector(void);
|
||||||
void primitive_to_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 fixup_vector(F_VECTOR* vector);
|
||||||
void collect_vector(F_VECTOR* vector);
|
void collect_vector(F_VECTOR* vector);
|
||||||
|
|
Loading…
Reference in New Issue