] with-scope ;
: label-called? ( label linear -- ? )
- [ unswons #label = [ drop f ] [ over = ] ifte ] some? nip ;
+ [ uncons pick = swap #label = not and ] some? nip ;
+
+#label [
+ [
+ dup car cdr simplifying get label-called?
+ [ f ] [ cdr t ] ifte
+ ]
+] "simplifiers" set-word-property
: next-physical? ( op linear -- ? )
cdr dup [ car car = ] [ 2drop f ] ifte ;
#! its param.
over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
-#label [
- [
- dup car cdr simplifying get
- label-called? [ f ] [ cdr t ] ifte
- ]
-] "simplifiers" set-word-property
-
\ >r [ [ \ r> cancel nip ] ] "simplifiers" set-word-property
\ r> [ [ \ >r cancel nip ] ] "simplifiers" set-word-property
\ dup [ [ \ drop cancel nip ] ] "simplifiers" set-word-property
\ swap [ [ \ swap cancel nip ] ] "simplifiers" set-word-property
+\ drop [
+ [
+ #push-immediate cancel [
+ #replace-immediate swons swons t
+ ] when
+ ] [
+ #push-indirect cancel [
+ #replace-indirect swons swons t
+ ] when
+ ]
+] "simplifiers" set-word-property
+
+: find-label ( label -- rest )
+ simplifying get [
+ uncons pick = swap #label = and
+ ] some? nip ;
+
: next-logical ( linear -- linear )
dup car car "next-logical" word-property call ;
cdr next-logical
] "next-logical" set-word-property
-: find-label ( label -- rest )
- simplifying get [
- uncons pick = swap #label = and
- ] some? nip ;
-
#jump-label [
car cdr find-label cdr
] "next-logical" set-word-property
] ifte ;
#call [
- [
- #return #jump reduce
- ]
+ [ #return #jump reduce ]
] "simplifiers" set-word-property
#call-label [
- [
- #return #jump-label reduce
- ]
+ [ #return #jump-label reduce ]
] "simplifiers" set-word-property
: double-jump ( linear op1 op2 -- linear ? )
uncons (dead-code) >r cons r> ;
#jump-label [
- [
- #return #return double-jump
- ] [
- #jump-label #jump-label double-jump
- ] [
- #jump #jump double-jump
- ] [
- useless-jump
- ] [
- dead-code
- ]
+ [ #return #return double-jump ]
+ [ #jump-label #jump-label double-jump ]
+ [ #jump #jump double-jump ]
+ [ useless-jump ]
+ [ dead-code ]
] "simplifiers" set-word-property
#target-label [
- [
- #jump-label #target-label double-jump
- ] [
- #jump #target double-jump
- ]
+ [ #jump-label #target-label double-jump ]
+ [ #jump #target double-jump ]
] "simplifiers" set-word-property
#jump [ [ dead-code ] ] "simplifiers" set-word-property
#return [ [ dead-code ] ] "simplifiers" set-word-property
#end-dispatch [ [ dead-code ] ] "simplifiers" set-word-property
-
-\ drop [
- [
- #push-immediate cancel [
- #replace-immediate swons swons t
- ] when
- ] [
- #push-indirect cancel [
- #replace-indirect swons swons t
- ] when
- ]
-] "simplifiers" set-word-property
! $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:
IN: sdl-event
USE: alien
+USE: generic
+USE: kernel
BEGIN-ENUM: 0
ENUM: SDL_NOEVENT ! Unused (do not remove)
FIELD: ushort unicode
END-STRUCT
+PREDICATE: alien key-down-event
+ keyboard-event-type SDL_KEYDOWN = ;
+
+PREDICATE: alien key-up-event
+ keyboard-event-type SDL_KEYUP = ;
+
BEGIN-STRUCT: motion-event
FIELD: uchar type ! SDL_MOUSEMOTION
FIELD: uchar which ! The mouse device index
FIELD: ushort y
FIELD: short xrel ! The relative motion in the X direction
FIELD: short yrel ! The relative motion in the Y direction
-END-STRUCT
+END-STRUCT
+
+PREDICATE: alien motion-event
+ motion-event-type SDL_MOUSEMOTION = ;
BEGIN-STRUCT: button-event
FIELD: uchar type ! SDL_MOUSEBUTTONDOWN or SDL_MOUSEBUTTONUP
FIELD: ushort y ! The X/Y coordinates of the mouse at press time
END-STRUCT
+PREDICATE: alien button-down-event
+ button-event-type SDL_MOUSEBUTTONDOWN = ;
+
+PREDICATE: alien button-up-event
+ button-event-type SDL_MOUSEBUTTONUP = ;
+
BEGIN-STRUCT: joy-axis-event
FIELD: uchar type ! SDL_JOYAXISMOTION
FIELD: uchar which ! The joystick device index
FIELD: short value ! The axis value
END-STRUCT
+PREDICATE: alien joy-axis-event
+ joy-axis-event-type SDL_JOYAXISMOTION = ;
+
BEGIN-STRUCT: joy-ball-event
FIELD: uchar type ! SDL_JOYBALLMOTION
FIELD: uchar which ! The joystick device index
FIELD: short yrel ! The relative motion in the Y direction
END-STRUCT
+PREDICATE: alien joy-ball-event
+ joy-ball-event-type SDL_JOYBALLMOTION = ;
+
BEGIN-STRUCT: joy-hat-event
FIELD: uchar type ! SDL_JOYHATMOTION
FIELD: uchar which ! The joystick device index
! Note that zero means the POV is centered.
END-STRUCT
+PREDICATE: alien joy-hat-event
+ joy-hat-event-type SDL_JOYHATMOTION = ;
+
BEGIN-STRUCT: joy-button-event
FIELD: uchar type ! SDL_JOYBUTTONDOWN or SDL_JOYBUTTONUP
FIELD: uchar which ! The joystick device index
FIELD: uchar state ! SDL_PRESSED or SDL_RELEASED
END-STRUCT
+PREDICATE: alien joy-button-down-event
+ joy-button-event-type SDL_JOYBUTTONDOWN = ;
+
+PREDICATE: alien joy-button-up-event
+ joy-button-event-type SDL_JOYBUTTONUP = ;
+
BEGIN-STRUCT: resize-event
FIELD: uchar type ! SDL_VIDEORESIZE
FIELD: int w ! New width
FIELD: uchar type ! SDL_VIDEOEXPOSE
END-STRUCT
+PREDICATE: alien resize-event
+ resize-event-type SDL_VIDEORESIZE = ;
+
BEGIN-STRUCT: quit-event
FIELD: uchar type ! SDL_QUIT
END-STRUCT
+PREDICATE: alien quit-event
+ quit-event-type SDL_QUIT = ;
+
BEGIN-STRUCT: user-event
FIELD: uchar type ! SDL_USREVENT through SDL_NUMEVENTS-1
FIELD: int code
FIELD: void* data2
END-STRUCT
+PREDICATE: alien user-event
+ user-event-type SDL_QUIT = ;
+
BEGIN-STRUCT: event
FIELD: uchar type
END-STRUCT
! Then, start Factor as usual (./f factor.image) and enter this
! at the listener:
!
-! USE: console
-! start-console
+! USE: shells
+! sdl
IN: console
USE: generic
USE: errors
USE: line-editor
USE: hashtables
+USE: lists
#! A namespace holding console state.
SYMBOL: console
#! A line editor object.
SYMBOL: input-line
+! Scrolling
+: visible-lines ( -- n ) height get line-height /i ;
+: total-lines ( -- n ) lines get vector-length ;
+: available-lines ( -- ) total-lines first-line get - ;
+
+: fix-first-line ( line -- line )
+ total-lines visible-lines - 1 + min 0 max ;
+
+: change-first-line ( quot -- )
+ first-line get
+ swap call fix-first-line
+ first-line set ; inline
+
+: line-scroll-up ( -- ) [ 1 - ] change-first-line ;
+: line-scroll-down ( -- ) [ 1 + ] change-first-line ;
+: page-scroll-up ( -- ) [ visible-lines - ] change-first-line ;
+: page-scroll-down ( -- ) [ visible-lines + ] change-first-line ;
+
+: scroll-to-bottom ( -- )
+ total-lines fix-first-line first-line set ;
+
! Rendering
-: background HEX: 0000dbff ;
-: foreground HEX: 6d92ffff ;
-: cursor HEX: ffff24ff ;
+: background white ;
+: foreground black ;
+: cursor red ;
#! The font size is hardcoded here.
: line-height 8 ;
: clear-display ( -- )
surface get 0 0 width get height get background boxColor ;
-: visible-lines ( -- n )
- height get line-height /i ;
-
-: available-lines ( -- )
- lines get vector-length first-line get - ;
-
: draw-lines ( -- )
visible-lines available-lines min [
first-line get +
input-line get [ line-text get ] bind draw-line
r> draw-cursor ;
+: scrollbar-width 16 ;
+: scroll-y ( line -- y ) total-lines 1 + / height get * ;
+: scrollbar-top ( -- y ) first-line get scroll-y ;
+: scrollbar-bottom ( -- y ) first-line get visible-lines + scroll-y ;
+
+: draw-scrollbar ( -- )
+ surface get
+ width get scrollbar-width -
+ scrollbar-top
+ width get
+ scrollbar-bottom
+ black boxColor ;
+
: draw-console ( -- )
[
0 x set
draw-lines
draw-current
draw-input
+ draw-scrollbar
] with-surface ;
: empty-buffer ( sbuf -- str )
dup sbuf>str 0 rot set-sbuf-length ;
: add-line ( text -- )
- lines get vector-push
- lines get vector-length 1 + first-line get - visible-lines -
- dup 0 >= [
- first-line [ + ] change
- ] [
- drop
- ] ifte ;
+ lines get vector-push scroll-to-bottom ;
: console-write ( text -- )
"\n" split1 [
GENERIC: handle-event ( event -- ? )
-PREDICATE: alien key-down-event
- keyboard-event-type SDL_KEYDOWN = ;
-
SYMBOL: keymap
{{
- [[ [ "RETURN" ] [ return-key ] ]]
- [[ [ "BACKSPACE" ] [ input-line get [ backspace ] bind ] ]]
- [[ [ "LEFT" ] [ input-line get [ left ] bind ] ]]
- [[ [ "RIGHT" ] [ input-line get [ right ] bind ] ]]
- [[ [ "UP" ] [ input-line get [ history-prev ] bind ] ]]
- [[ [ "DOWN" ] [ input-line get [ history-next ] bind ] ]]
- [[ [ "CTRL" "k" ] [ input-line get [ line-clear ] bind ] ]]
+ [[ [ "RETURN" ] [ return-key ] ]]
+ [[ [ "BACKSPACE" ] [ input-line get [ backspace ] bind ] ]]
+ [[ [ "LEFT" ] [ input-line get [ left ] bind ] ]]
+ [[ [ "RIGHT" ] [ input-line get [ right ] bind ] ]]
+ [[ [ "UP" ] [ input-line get [ history-prev ] bind ] ]]
+ [[ [ "SHIFT" "DOWN" ] [ line-scroll-down ] ]]
+ [[ [ "SHIFT" "UP" ] [ line-scroll-up ] ]]
+ [[ [ "PAGEDOWN" ] [ page-scroll-down ] ]]
+ [[ [ "PAGEUP" ] [ page-scroll-up ] ]]
+ [[ [ "DOWN" ] [ input-line get [ history-next ] bind ] ]]
+ [[ [ "CTRL" "k" ] [ input-line get [ line-clear ] bind ] ]]
}} keymap set
+: input-key? ( event -- ? )
+ #! Is this a keystroke that potentially inserts input, or
+ #! does it have modifiers?
+ keyboard-event-unicode valid-char? ;
+
+: user-input ( char -- )
+ input-line get [ insert-char ] bind scroll-to-bottom ;
+
M: key-down-event handle-event ( event -- ? )
dup keyboard-event>binding keymap get hash [
call draw-console
] [
- keyboard-event-unicode dup valid-char? [
- input-line get [ insert-char ] bind draw-console
+ dup input-key? [
+ keyboard-event-unicode user-input draw-console
] [
drop
] ifte
] ?ifte t ;
-PREDICATE: alien quit-event
- quit-event-type SDL_QUIT = ;
+! The y co-ordinate of the start of the drag.
+SYMBOL: drag-start-y
+! The first line at the time
+SYMBOL: drag-start-line
+
+: scrollbar-click ( y -- )
+ dup scrollbar-top < [
+ drop page-scroll-up draw-console
+ ] [
+ dup scrollbar-bottom > [
+ drop page-scroll-down draw-console
+ ] [
+ drag-start-y set
+ first-line get drag-start-line set
+ ] ifte
+ ] ifte ;
+
+M: button-down-event handle-event ( event -- ? )
+ dup button-event-x width get scrollbar-width - >= [
+ button-event-y scrollbar-click
+ ] [
+ drop
+ ] ifte t ;
+
+M: button-up-event handle-event ( event -- ? )
+ drop
+ drag-start-y off
+ drag-start-line off t ;
+
+M: motion-event handle-event ( event -- ? )
+ drag-start-y get [
+ motion-event-y drag-start-y get -
+ height get / total-lines * drag-start-line get +
+ >fixnum fix-first-line first-line set
+ draw-console
+ ] [
+ drop
+ ] ifte t ;
+
+M: resize-event handle-event ( event -- ? )
+ dup resize-event-w swap resize-event-h
+ 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
+ scroll-to-bottom
+ draw-console t ;
M: quit-event handle-event ( event -- ? )
drop f ;
: sdl ( -- )
<namespace> [
- 800 600 32 SDL_HWSURFACE init-screen
+ 640 480 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
init-console
] extend console set
#include "factor.h"
-F_FIXNUM to_integer(CELL x)
-{
- switch(TAG(x))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(x);
- case BIGNUM_TYPE:
- return s48_bignum_to_long(untag_bignum(x));
- default:
- type_error(BIGNUM_TYPE,x);
- return 0;
- }
-}
-
/* FFI calls this */
void box_integer(F_FIXNUM integer)
{
/* FFI calls this */
F_FIXNUM unbox_integer(void)
{
- return to_integer(dpop());
+ return to_fixnum(dpop());
}
CELL to_cell(CELL x)
return RETAG(bignum,BIGNUM_TYPE);
}
-F_FIXNUM to_integer(CELL x);
CELL to_cell(CELL x);
DLLEXPORT void box_integer(F_FIXNUM integer);
/* FFI calls this */
signed char unbox_signed_1(void)
{
- return to_integer(dpop());
+ return to_fixnum(dpop());
}
/* FFI calls this */
signed short unbox_signed_2(void)
{
- return to_integer(dpop());
+ return to_fixnum(dpop());
}
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
- F_FIXNUM value = to_integer(dpop());
+ F_FIXNUM value = to_fixnum(dpop());
put(SLOT(obj,slot),value);
}
projects / factor.git / commitdiff