steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

fixed compiler; UI work

cvs
Slava Pestov 2005-01-31 19:02:09 +00:00
parent 330db0497d
commit c35f6f9f44
15 changed files with 258 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

@ -8,6 +8,7 @@
- goal: to compile hash* optimally
- type check/not-check entry points for compiled words
- getenv/setenv: if literal arg, compile as a load/store
- empty ifte: wrong input type.
+ oop:
@ -40,6 +41,7 @@
- completion in the listener
- special completion for USE:/IN:
- support USING:
- command to prettyprint word def at caret, or selection
+ i/o:

3
library/bootstrap/boot-stage2.factor
View File

@ -108,6 +108,9 @@ USING: kernel lists parser stdio words namespaces ;
"/library/ui/line-editor.factor"
"/library/ui/console.factor"
"/library/ui/shapes.factor"
"/library/ui/paint.factor"
"/library/ui/gadgets.factor"
"/library/bootstrap/image.factor"

8
library/compiler/alien.factor
View File

@ -96,10 +96,10 @@ SYMBOL: alien-parameters
: infer-alien ( -- )
[ object object object object ] ensure-d
dataflow-drop, pop-d value-literal
dataflow-drop, pop-d value-literal >r
dataflow-drop, pop-d value-literal
dataflow-drop, pop-d value-literal -rot
dataflow-drop, pop-d literal-value
dataflow-drop, pop-d literal-value >r
dataflow-drop, pop-d literal-value
dataflow-drop, pop-d literal-value -rot
r> swap alien-node ;
: box-parameter

24
library/generic/tuple.factor
View File

@ -98,6 +98,30 @@ kernel-internals math hashtables errors ;
>r unit [ car tuple-dispatch call ] cons tuple r>
set-vtable ;
M: tuple clone ( tuple -- tuple )
dup array-capacity dup <tuple> [ -rot copy-array ] keep ;
: tuple>list ( tuple -- list )
dup array-capacity swap array>list ;
M: tuple = ( obj tuple -- ? )
over tuple? [
over class over class = [
swap tuple>list swap tuple>list =
] [
2drop f
] ifte
] [
2drop f
] ifte ;
M: tuple hashcode ( vec -- n )
dup array-capacity 1 number= [
drop 0
] [
1 swap array-nth hashcode
] ifte ;
M: tuple class ( obj -- class ) 2 slot ;
tuple [

6
library/inference/branches.factor
View File

@ -113,7 +113,7 @@ SYMBOL: cloned
uncons propagate-type
dup value-recursion recursive-state set
copy-inference
value-literal dup infer-quot
literal-value dup infer-quot
#values values-node
handle-terminator
] extend ;
@ -177,7 +177,7 @@ SYMBOL: cloned
dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
gensym [
dup value-recursion recursive-state set
value-literal infer-quot
literal-value infer-quot
] (with-block) drop ;
: dynamic-ifte ( true false -- )
@ -204,7 +204,7 @@ SYMBOL: cloned
\ ifte [ infer-ifte ] "infer" set-word-property
: vtable>list ( value -- list )
dup value-recursion swap value-literal vector>list
dup value-recursion swap literal-value vector>list
[ over <literal> ] map nip ;
USE: kernel-internals

26
library/inference/inference.factor
View File

@ -63,20 +63,16 @@ SYMBOL: recursive-state
GENERIC: value= ( literal value -- ? )
GENERIC: value-class-and ( class value -- )
! A value has the following slots in addition to those relating
! to generics above:
TUPLE: value class type-prop recursion ;
TUPLE: value literal class type-prop recursion ;
C: value ;
C: value ( recursion -- value )
[ set-value-recursion ] keep ;
TUPLE: computed delegate ;
C: computed ( class -- value )
<value> over set-computed-delegate
[ set-value-class ] keep ;
M: computed value-literal ( value -- obj )
"Cannot use a computed value literally." throw ;
swap recursive-state get <value> [ set-value-class ] keep
over set-computed-delegate ;
M: computed value= ( literal value -- ? )
2drop f ;
@ -84,15 +80,17 @@ M: computed value= ( literal value -- ? )
M: computed value-class-and ( class value -- )
[ value-class class-and ] keep set-value-class ;
TUPLE: literal delegate ;
TUPLE: literal value delegate ;
C: literal ( obj rstate -- value )
<value> over set-literal-delegate
[ set-value-recursion ] keep
[ set-value-literal ] keep ;
[
>r <value> [ >r dup class r> set-value-class ] keep
r> set-literal-delegate
] keep
[ set-literal-value ] keep ;
M: literal value= ( literal value -- ? )
value-literal = ;
literal-value = ;
M: literal value-class-and ( class value -- )
value-class class-and drop ;

4
library/inference/types.factor
View File

@ -29,7 +29,7 @@ lists math namespaces strings vectors words stdio prettyprint ;
! \ slot [
! [ object fixnum ] ensure-d
! dataflow-drop, pop-d value-literal
! dataflow-drop, pop-d literal-value
! peek-d value-class builtin-supertypes dup length 1 = [
! cons \ slot [ [ object ] [ object ] ] (consume/produce)
! ] [
@ -48,7 +48,7 @@ lists math namespaces strings vectors words stdio prettyprint ;
1 0 node-inputs
[ object ] consume-d
[ fixnum ] produce-d
r> peek-d value-type-prop
r> peek-d set-value-type-prop
1 0 node-outputs
] bind
] "infer" set-word-property

21
library/inference/words.factor
View File

@ -87,23 +87,6 @@ M: promise (apply-word) ( word -- )
M: symbol (apply-word) ( word -- )
apply-literal ;
: current-word ( -- word )
#! Push word we're currently inferring effect of.
recursive-state get car car ;
: check-recursion ( word -- )
#! If at the location of the recursive call, we're taking
#! more items from the stack than producing, we have a
#! diverging recursion. Note that this check is not done for
#! mutually-recursive words. Generally they should be
#! avoided.
current-word = [
d-in get vector-length
meta-d get vector-length > [
current-word word-name " diverges." cat2 throw
] when
] when ;
: with-recursion ( quot -- )
[
inferring-base-case inc
@ -143,7 +126,7 @@ M: symbol (apply-word) ( word -- )
: apply-word ( word -- )
#! Apply the word's stack effect to the inferencer state.
dup recursive-state get assoc [
dup check-recursion recursive-word
recursive-word
] [
dup "infer-effect" word-property [
apply-effect
@ -158,7 +141,7 @@ M: symbol (apply-word) ( word -- )
gensym dup [
drop pop-d dup
value-recursion recursive-state set
value-literal infer-quot
literal-value infer-quot
] with-block drop ;
\ call [ infer-call ] "infer" set-word-property

3
library/lists.factor
View File

@ -11,6 +11,9 @@ IN: lists USING: generic kernel math ;
: 3list ( a b c -- [ a b c ] )
2list cons ;
: 3unlist ( [ a b c ] -- a b c )
uncons uncons car ;
: append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
over [ >r uncons r> append cons ] [ nip ] ifte ;

2
library/sdl/sdl-utils.factor
View File

@ -57,7 +57,7 @@ SYMBOL: surface
#! Set up SDL graphics and call the quotation.
[ >r init-screen r> call SDL_Quit ] with-scope ; inline
: rgb ( r g b a -- n )
: rgb ( r g b -- n )
255
swap 8 shift bitor
swap 16 shift bitor

1
library/test/test.factor
View File

@ -67,6 +67,7 @@ USE: unparser
"strings"
"namespaces"
"generic"
"tuple"
"files"
"parser"
"parse-number"

18
library/test/tuple.factor Normal file
View File

@ -0,0 +1,18 @@
IN: scratchpad
USING: generic kernel test math ;
TUPLE: rect x y w h ;
C: rect
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
: move ( x rect -- )
[ rect-x + ] keep set-rect-x ;
[ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test

82
library/ui/gadgets.factor Normal file
View File

@ -0,0 +1,82 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic hashtables kernel lists namespaces ;
! Gadget protocol.
GENERIC: pick-up ( point gadget -- gadget )
! A gadget is a shape together with paint, and a reference to
! the gadget's parent. A gadget delegates to its shape.
TUPLE: gadget paint parent delegate ;
C: gadget ( shape -- gadget )
[ set-gadget-delegate ] keep
[ <namespace> swap set-gadget-paint ] keep ;
: paint-property ( gadget key -- value )
swap gadget-paint hash ;
: set-paint-property ( gadget value key -- )
rot gadget-paint set-hash ;
: with-gadget ( gadget quot -- )
#! All drawing done inside the quotation is done with the
#! gadget's paint. If the gadget does not have any custom
#! paint, just call the quotation.
>r gadget-paint r> bind ;
M: gadget draw ( gadget -- )
dup [ gadget-delegate draw ] with-gadget ;
M: gadget pick-up tuck inside? [ drop f ] unless ;
! An invisible gadget.
WRAPPER: ghost
M: ghost draw drop ;
M: ghost pick-up 2drop f ;
! A box is a gadget holding other gadgets.
TUPLE: box contents delegate ;
C: box ( gadget -- box )
[ set-box-delegate ] keep ;
M: general-list draw ( list -- )
[ draw ] each ;
M: box draw ( box -- )
dup [
dup [
dup box-contents draw
box-delegate draw
] with-gadget
] with-translation ;
M: general-list pick-up ( point list -- gadget )
dup [
2dup car pick-up dup [
2nip
] [
drop cdr pick-up
] ifte
] [
2drop f
] ifte ;
M: box pick-up ( point box -- )
#! The logic is thus. If the point is definately outside the
#! box, return f. Otherwise, see if the point is contained
#! in any subgadget. If not, see if it is contained in the
#! box delegate.
dup [
2dup gadget-delegate inside? [
2dup box-contents pick-up dup [
2nip
] [
drop box-delegate pick-up
] ifte
] [
2drop f
] ifte
] with-translation ;

35
library/ui/paint.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic kernel lists math namespaces sdl sdl-gfx ;
! The painting protocol. Painting is controlled by various
! dynamically-scoped variables.
! "Paint" is a namespace containing some or all of these values.
SYMBOL: color ! a list of three integers, 0..255.
SYMBOL: font ! a list of two elements, a font name and size.
SYMBOL: filled ! is the interior of the shape filled?
: shape>screen ( shape -- x1 y1 x2 y2 )
[ shape-x x get + ] keep
[ shape-y y get + ] keep
[ dup shape-x swap shape-w + x get + ] keep
dup shape-y swap shape-h + y get + ;
: rgb-color ( -- rgba ) color get 3unlist rgb ;
GENERIC: draw ( obj -- )
M: rect draw ( rect -- )
>r surface get r> shape>screen rgb-color
filled get [ boxColor ] [ rectangleColor ] ifte ;
: default-paint ( -- paint )
{{
[[ x 0 ]]
[[ y 0 ]]
[[ color [ 0 0 0 ] ]]
[[ filled f ]]
[[ font [ "Monospaced" 12 ] ]]
}} ;

66
library/ui/shapes.factor Normal file
View File

@ -0,0 +1,66 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic kernel math namespaces ;
! Shape protocol.
! These dynamically-bound variables affect the generic word
! inside?.
SYMBOL: x ! x translation
SYMBOL: y ! y translation
! A shape is an object with a defined bounding
! box, and a notion of interior.
GENERIC: shape-x
GENERIC: shape-y
GENERIC: shape-w
GENERIC: shape-h
GENERIC: inside? ( point shape -- ? )
: with-translation ( shape quot -- )
#! All drawing done inside the quotation is translated
#! relative to the shape's origin.
[
>r dup
shape-x x [ + ] change
shape-y y [ + ] change
r> call
] with-scope ; inline
! A point, represented as a complex number, is the simplest type
! of shape.
M: number shape-x real ;
M: number shape-y imaginary ;
M: number shape-w drop 0 ;
M: number shape-h drop 0 ;
M: number inside? = ;
! A rectangle maps trivially to the shape protocol.
TUPLE: rect x y w h ;
M: rect shape-x rect-x ;
M: rect shape-y rect-y ;
M: rect shape-w rect-w ;
M: rect shape-h rect-h ;
: fix-neg ( a b c -- a+c b -c )
dup 0 < [ neg tuck >r >r + r> r> ] when ;
C: rect ( x y w h -- rect )
#! We handle negative w/h for convinience.
>r fix-neg >r fix-neg r> r>
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
: rect-x-extents ( rect -- x1 x2 )
dup rect-x x get + swap rect-w dupd + ;
: rect-y-extents ( rect -- x1 x2 )
dup rect-y y get + swap rect-h dupd + ;
M: rect inside? ( point rect -- ? )
over real over rect-x-extents between? >r
swap imaginary swap rect-y-extents between? r> and ;