Merge git://factorcode.org/git/factor
Doug Coleman
commit
79725888b4
|
|
@ -22,7 +22,7 @@ $nl
|
|||
ABOUT: "quotations"
|
||||
|
||||
HELP: callable
|
||||
{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations, " { $link f } " (which behaves like an empty quotation), and composed quotations built up with " { $link curry } "." } ;
|
||||
{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations and composed quotations built up with " { $link curry } " or " { $link compose } "." } ;
|
||||
|
||||
HELP: quotation
|
||||
{ $description "The class of quotations. See " { $link "syntax-quots" } " for syntax and " { $link "quotations" } " for general information." } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel parser namespaces quotations vectors strings
|
||||
sequences assocs tuples math combinators ;
|
||||
USING: kernel parser namespaces quotations arrays vectors strings
|
||||
sequences assocs tuples math combinators ;
|
||||
|
||||
IN: bake
|
||||
|
||||
|
|
@ -22,6 +22,10 @@ C: <splice-quot> splice-quot
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: ,u ( seq -- seq ) unclip building get push ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: exemplar
|
||||
|
||||
: reset-building ( -- ) 1024 <vector> building set ;
|
||||
|
|
@ -35,6 +39,7 @@ DEFER: bake
|
|||
: bake-item ( item -- )
|
||||
{ { [ dup \ , = ] [ drop , ] }
|
||||
{ [ dup \ % = ] [ drop % ] }
|
||||
{ [ dup \ ,u = ] [ drop ,u ] }
|
||||
{ [ dup insert-quot? ] [ insert-quot-expr call , ] }
|
||||
{ [ dup splice-quot? ] [ splice-quot-expr call % ] }
|
||||
{ [ dup integer? ] [ , ] }
|
||||
|
|
@ -48,4 +53,9 @@ DEFER: bake
|
|||
: bake-items ( seq -- ) [ bake-item ] each ;
|
||||
|
||||
: bake ( seq -- seq )
|
||||
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
|
||||
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
|
||||
|
||||
|
|
|
|||
|
|
@ -167,6 +167,12 @@ M: char-elt prev-elt
|
|||
M: char-elt next-elt
|
||||
drop [ drop 1 +col ] (next-char) ;
|
||||
|
||||
TUPLE: one-char-elt ;
|
||||
|
||||
M: one-char-elt prev-elt 2drop ;
|
||||
|
||||
M: one-char-elt next-elt 2drop ;
|
||||
|
||||
: (word-elt) ( loc document quot -- loc )
|
||||
pick >r
|
||||
>r >r first2 swap r> doc-line r> call
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ IN: macros
|
|||
: MACRO:
|
||||
(:) (MACRO:) ; parsing
|
||||
|
||||
PREDICATE: word macro
|
||||
PREDICATE: compound macro
|
||||
"macro" word-prop >boolean ;
|
||||
|
||||
M: macro definer drop \ MACRO: \ ; ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
|
||||
USING: namespaces unix.linux.if unix.linux.ifreq unix.linux.route ;
|
||||
USING: namespaces threads
|
||||
unix.process unix.linux.if unix.linux.ifreq unix.linux.route
|
||||
raptor.cron ;
|
||||
|
||||
IN: raptor
|
||||
|
||||
|
|
@ -24,9 +26,20 @@ IN: raptor
|
|||
configure-route
|
||||
] networking-hook set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Filesystems
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
"/dev/hda1" root-device set-global
|
||||
|
||||
{ "/dev/hda5" } swap-devices set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! boot-hook
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
[
|
||||
start-wait-loop
|
||||
|
||||
! rcS.d
|
||||
|
||||
|
|
@ -38,7 +51,12 @@ IN: raptor
|
|||
"mountdevsubfs" start-service
|
||||
"module-init-tools" start-service
|
||||
"procps.sh" start-service
|
||||
"checkroot.sh" start-service
|
||||
|
||||
! "checkroot.sh" start-service
|
||||
|
||||
activate-swap
|
||||
mount-root
|
||||
|
||||
"mtab" start-service
|
||||
"checkfs.sh" start-service
|
||||
"mountall.sh" start-service
|
||||
|
|
@ -76,11 +94,17 @@ IN: raptor
|
|||
"rmnologin" start-service
|
||||
|
||||
schedule-cron-jobs
|
||||
start-listeners
|
||||
start-gettys
|
||||
|
||||
|
||||
[ [ "/dev/tty2" tty-listener ] forever ] in-thread
|
||||
[ [ "/dev/tty3" tty-listener ] forever ] in-thread
|
||||
[ [ "/dev/tty4" tty-listener ] forever ] in-thread
|
||||
[ [ "/dev/tty5" getty ] forever ] in-thread
|
||||
[ [ "/dev/tty6" getty ] forever ] in-thread
|
||||
|
||||
] boot-hook set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! reboot-hook
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
[
|
||||
|
|
@ -108,6 +132,8 @@ IN: raptor
|
|||
"reboot" stop-service
|
||||
] reboot-hook set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! shutdown-hook
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
|
||||
USING: kernel threads sequences calendar combinators.cleave combinators.lib ;
|
||||
USING: kernel namespaces threads sequences calendar
|
||||
combinators.cleave combinators.lib ;
|
||||
|
||||
IN: raptor.cron
|
||||
|
||||
|
|
@ -46,3 +47,16 @@ C: <when> when
|
|||
|
||||
: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: cron-jobs-hourly
|
||||
SYMBOL: cron-jobs-daily
|
||||
SYMBOL: cron-jobs-weekly
|
||||
SYMBOL: cron-jobs-monthly
|
||||
|
||||
: schedule-cron-jobs ( -- )
|
||||
{ 17 } f f f f <when> [ cron-jobs-hourly get call ] schedule
|
||||
{ 25 } { 6 } f f f <when> [ cron-jobs-daily get call ] schedule
|
||||
{ 47 } { 6 } f f { 7 } <when> [ cron-jobs-weekly get call ] schedule
|
||||
{ 52 } { 6 } { 1 } f f <when> [ cron-jobs-monthly get call ] schedule ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
|
||||
USING: kernel threads arrays sequences combinators.cleave raptor raptor.cron ;
|
||||
USING: kernel namespaces threads arrays sequences combinators.cleave
|
||||
raptor raptor.cron ;
|
||||
|
||||
IN: raptor
|
||||
|
||||
|
|
@ -7,41 +8,33 @@ IN: raptor
|
|||
|
||||
: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
|
||||
|
||||
: run-script ( path -- ) 1array [ fork-exec-args-wait ] curry in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: cron-hourly ( -- ) ;
|
||||
|
||||
: cron-daily ( -- )
|
||||
{ "/etc/cron.daily/apt"
|
||||
"/etc/cron.daily/aptitude"
|
||||
"/etc/cron.daily/bsdmainutils"
|
||||
"/etc/cron.daily/find.notslocate"
|
||||
"/etc/cron.daily/logrotate"
|
||||
"/etc/cron.daily/man-db"
|
||||
"/etc/cron.daily/ntp-server"
|
||||
"/etc/cron.daily/slocate"
|
||||
"/etc/cron.daily/standard"
|
||||
"/etc/cron.daily/sysklogd"
|
||||
"/etc/cron.daily/tetex-bin" }
|
||||
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
|
||||
[
|
||||
"/etc/cron.daily/apt" run-script
|
||||
"/etc/cron.daily/aptitude" run-script
|
||||
"/etc/cron.daily/bsdmainutils" run-script
|
||||
"/etc/cron.daily/find.notslocate" run-script
|
||||
"/etc/cron.daily/logrotate" run-script
|
||||
"/etc/cron.daily/man-db" run-script
|
||||
"/etc/cron.daily/ntp-server" run-script
|
||||
"/etc/cron.daily/slocate" run-script
|
||||
"/etc/cron.daily/standard" run-script
|
||||
"/etc/cron.daily/sysklogd" run-script
|
||||
"/etc/cron.daily/tetex-bin" run-script
|
||||
] cron-jobs-daily set-global
|
||||
|
||||
: cron-weekly ( -- )
|
||||
{ "/etc/cron.weekly/cvs"
|
||||
"/etc/cron.weekly/man-db"
|
||||
"/etc/cron.weekly/ntp-server"
|
||||
"/etc/cron.weekly/popularity-contest"
|
||||
"/etc/cron.weekly/sysklogd" }
|
||||
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
|
||||
[
|
||||
"/etc/cron.weekly/cvs" run-script
|
||||
"/etc/cron.weekly/man-db" run-script
|
||||
"/etc/cron.weekly/ntp-server" run-script
|
||||
"/etc/cron.weekly/popularity-contest" run-script
|
||||
"/etc/cron.weekly/sysklogd" run-script
|
||||
] cron-jobs-weekly set-global
|
||||
|
||||
: cron-monthly ( -- )
|
||||
{ "/etc/cron.monthly/scrollkeeper"
|
||||
"/etc/cron.monthly/standard" }
|
||||
[ 1array [ fork-exec-args-wait ] in-thread drop ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: schedule-cron-jobs ( -- )
|
||||
{ 17 } f f f f <when> [ cron-hourly ] schedule
|
||||
{ 25 } { 6 } f f f <when> [ cron-daily ] schedule
|
||||
{ 47 } { 6 } f f { 7 } <when> [ cron-weekly ] schedule
|
||||
{ 52 } { 6 } { 1 } f f <when> [ cron-monthly ] schedule ;
|
||||
[
|
||||
"/etc/cron.monthly/scrollkeeper" run-script
|
||||
"/etc/cron.monthly/standard" run-script
|
||||
] cron-jobs-monthly set-global
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
|
||||
USING: kernel parser namespaces threads unix.process combinators.cleave ;
|
||||
USING: kernel parser namespaces threads sequences unix unix.process
|
||||
combinators.cleave bake ;
|
||||
|
||||
IN: raptor
|
||||
|
||||
|
|
@ -10,29 +11,29 @@ SYMBOL: reboot-hook
|
|||
SYMBOL: shutdown-hook
|
||||
SYMBOL: networking-hook
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: reload-raptor-config ( -- )
|
||||
"/etc/raptor/config.factor" run-file
|
||||
"/etc/raptor/cronjobs.factor" run-file ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USING: sequences unix ;
|
||||
: fork-exec-wait ( pathname args -- )
|
||||
fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid drop ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: forever ( quot -- ) [ call ] [ forever ] bi ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ;
|
||||
: stop-service ( name -- ) "/etc/init.d/" swap " stop" 3append system drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: fork-exec-wait ( pathname args -- )
|
||||
fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: respawn ( pathname args -- ) [ fork-exec-wait ] [ respawn ] 2bi ;
|
||||
|
||||
: start-gettys ( -- )
|
||||
[ "/sbin/getty" { "getty" "38400" "tty5" } respawn ] in-thread
|
||||
[ "/sbin/getty" { "getty" "38400" "tty6" } respawn ] in-thread ;
|
||||
: getty ( tty -- ) `{ "/sbin/getty" "38400" , } fork-exec-args-wait ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -40,16 +41,19 @@ USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
|
|||
listener ;
|
||||
|
||||
: tty-listener ( tty -- )
|
||||
[ <file-reader> <line-reader> ]
|
||||
[ <file-writer> <plain-writer> ]
|
||||
bi <duplex-stream> [ listener ] with-stream ;
|
||||
[ <file-reader> ] [ <file-writer> ] bi <duplex-stream>
|
||||
[ listener ] with-stream ;
|
||||
|
||||
: forever ( quot -- ) [ call ] [ forever ] bi ;
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: start-listeners ( -- )
|
||||
[ [ "/dev/tty2" tty-listener ] forever ] in-thread
|
||||
[ [ "/dev/tty3" tty-listener ] forever ] in-thread
|
||||
[ [ "/dev/tty4" tty-listener ] forever ] in-thread ;
|
||||
USING: unix.linux.swap unix.linux.fs ;
|
||||
|
||||
SYMBOL: root-device
|
||||
SYMBOL: swap-devices
|
||||
|
||||
: activate-swap ( -- ) swap-devices get [ 0 swapon drop ] each ;
|
||||
|
||||
: mount-root ( -- ) root-device get "/" "ext3" MS_REMOUNT f mount drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -60,3 +64,4 @@ USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
|
|||
: shutdown ( -- ) shutdown-hook get call ;
|
||||
|
||||
MAIN: boot
|
||||
|
||||
|
|
|
|||
|
|
@ -8,9 +8,22 @@ Raptor Linux is a mod of Ubuntu 6.06 (Dapper Drake)
|
|||
This is unlikely to work on another version of Ubuntu, much less
|
||||
another Linux distribution.
|
||||
|
||||
*** Features ***
|
||||
|
||||
* /sbin/init is replaced with Factor
|
||||
* Virtual terminals managed by Factor
|
||||
* Listeners run on virtual terminals
|
||||
* Native support for static ip networking
|
||||
* Crontab replacement
|
||||
|
||||
*** Install ***
|
||||
|
||||
# mkdir -v /etc/raptor
|
||||
|
||||
# cp -v /scratch/factor/extra/raptor/{config,cronjobs}.factor /etc/raptor
|
||||
|
||||
( scratchpad ) USE: raptor
|
||||
( scratchpad ) reload-raptor-config
|
||||
( scratchpad ) save
|
||||
|
||||
# mv -v /sbin/{init,init.orig}
|
||||
|
|
@ -19,10 +32,6 @@ another Linux distribution.
|
|||
|
||||
# cp -v /scratch/factor/factor.image /sbin/init.image
|
||||
|
||||
# mkdir -v /etc/raptor
|
||||
|
||||
# cp -v /scratch/factor/extra/raptor/config.factor /etc/raptor/config.factor
|
||||
|
||||
*** Static IP networking ***
|
||||
|
||||
If you use a static IP in your network then Factor can take care of
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: dlists ui.gadgets kernel ui namespaces io.streams.string
|
||||
io ui.private ;
|
||||
io ;
|
||||
IN: tools.test.ui
|
||||
|
||||
! We can't print to stdio here because that might be a pane
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: ui.gadgets.editors tools.test kernel io io.streams.plain
|
||||
definitions namespaces ui.gadgets ui.private
|
||||
definitions namespaces ui.gadgets
|
||||
ui.gadgets.grids prettyprint documents ui.gestures
|
||||
tools.test.inference tools.test.ui models ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays documents ui.clipboards ui.commands ui.gadgets
|
|||
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
|
||||
kernel math models namespaces opengl opengl.gl sequences strings
|
||||
io.styles math.vectors sorting colors combinators ;
|
||||
io.styles math.vectors sorting colors combinators assocs ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
TUPLE: editor
|
||||
|
|
@ -94,8 +94,11 @@ M: editor ungraft*
|
|||
rot editor-line x>offset ,
|
||||
] { } make ;
|
||||
|
||||
: clicked-loc ( editor -- loc )
|
||||
[ hand-rel ] keep point>loc ;
|
||||
|
||||
: click-loc ( editor model -- )
|
||||
>r [ hand-rel ] keep point>loc r> set-model ;
|
||||
>r clicked-loc r> set-model ;
|
||||
|
||||
: focus-editor ( editor -- )
|
||||
t over set-editor-focused? relayout-1 ;
|
||||
|
|
@ -244,11 +247,37 @@ M: editor user-input*
|
|||
|
||||
M: editor gadget-text* editor-string % ;
|
||||
|
||||
: start-selection ( editor -- )
|
||||
dup editor-caret click-loc ;
|
||||
|
||||
: extend-selection ( editor -- )
|
||||
dup request-focus start-selection ;
|
||||
dup request-focus dup editor-caret click-loc ;
|
||||
|
||||
: mouse-elt ( -- elelement )
|
||||
hand-click# get {
|
||||
{ 2 T{ one-word-elt } }
|
||||
{ 3 T{ one-line-elt } }
|
||||
} at T{ one-char-elt } or ;
|
||||
|
||||
: drag-direction? ( loc editor -- ? )
|
||||
editor-mark* <=> 0 < ;
|
||||
|
||||
: drag-selection-caret ( loc editor element -- loc )
|
||||
>r [ drag-direction? ] 2keep
|
||||
gadget-model
|
||||
r> prev/next-elt ? ;
|
||||
|
||||
: drag-selection-mark ( loc editor element -- loc )
|
||||
>r [ drag-direction? not ] 2keep
|
||||
nip dup editor-mark* swap gadget-model
|
||||
r> prev/next-elt ? ;
|
||||
|
||||
: drag-caret&mark ( editor -- caret mark )
|
||||
dup clicked-loc swap mouse-elt
|
||||
[ drag-selection-caret ] 3keep
|
||||
drag-selection-mark ;
|
||||
|
||||
: drag-selection ( editor -- )
|
||||
dup drag-caret&mark
|
||||
pick editor-mark set-model
|
||||
swap editor-caret set-model ;
|
||||
|
||||
: editor-cut ( editor clipboard -- )
|
||||
dupd gadget-copy remove-selection ;
|
||||
|
|
@ -296,17 +325,10 @@ M: editor gadget-text* editor-string % ;
|
|||
dup T{ one-word-elt } select-elt
|
||||
] unless gadget-selection ;
|
||||
|
||||
: (position-caret) ( editor -- )
|
||||
dup extend-selection
|
||||
dup editor-mark click-loc ;
|
||||
|
||||
: position-caret ( editor -- )
|
||||
hand-click# get {
|
||||
{ 1 [ (position-caret) ] }
|
||||
{ 2 [ T{ one-word-elt } select-elt ] }
|
||||
{ 3 [ T{ one-line-elt } select-elt ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
mouse-elt dup T{ one-char-elt } =
|
||||
[ drop dup extend-selection dup editor-mark click-loc ]
|
||||
[ select-elt ] if ;
|
||||
|
||||
: insert-newline "\n" swap user-input ;
|
||||
|
||||
|
|
@ -408,7 +430,7 @@ editor "caret-motion" f {
|
|||
|
||||
editor "selection" f {
|
||||
{ T{ button-down f { S+ } } extend-selection }
|
||||
{ T{ drag } start-selection }
|
||||
{ T{ drag } drag-selection }
|
||||
{ T{ gain-focus } focus-editor }
|
||||
{ T{ lose-focus } unfocus-editor }
|
||||
{ T{ delete-action } remove-selection }
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ IN: temporary
|
|||
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
|
||||
namespaces models kernel tools.test.inference dlists math
|
||||
math.parser ui sequences hashtables assocs io arrays
|
||||
prettyprint io.streams.string ui.private ;
|
||||
prettyprint io.streams.string ;
|
||||
|
||||
[ T{ rect f { 10 10 } { 20 20 } } ]
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: ui.gadgets ui.gadgets.scrollers ui.private
|
||||
USING: ui.gadgets ui.gadgets.scrollers
|
||||
namespaces tools.test kernel models ui.gadgets.viewports
|
||||
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
|
||||
ui.gadgets.sliders math math.vectors arrays sequences
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs kernel math models namespaces
|
||||
sequences words strings system hashtables math.parser
|
||||
math.vectors tuples classes ui.gadgets timers ;
|
||||
math.vectors tuples classes ui.gadgets timers combinators.lib ;
|
||||
IN: ui.gestures
|
||||
|
||||
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
|
||||
|
|
@ -176,9 +176,22 @@ drag-timer construct-empty drag-timer set-global
|
|||
: hand-click-rel ( gadget -- loc )
|
||||
hand-click-loc get-global swap screen-loc v- ;
|
||||
|
||||
: multi-click-timeout? ( -- ? )
|
||||
millis hand-last-time get - double-click-timeout get <= ;
|
||||
|
||||
: multi-click-button? ( button -- button ? )
|
||||
dup hand-last-button get = ;
|
||||
|
||||
: multi-click-position? ( -- ? )
|
||||
hand-loc get hand-click-loc get v- norm 10 <= ;
|
||||
|
||||
: multi-click? ( button -- ? )
|
||||
millis hand-last-time get - double-click-timeout get <=
|
||||
swap hand-last-button get = and ;
|
||||
{
|
||||
[ multi-click-timeout? ]
|
||||
[ multi-click-button? ]
|
||||
[ multi-click-position? ]
|
||||
[ multi-click-position? ]
|
||||
} && nip ;
|
||||
|
||||
: update-click# ( button -- )
|
||||
global [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: tools.test tools.test.ui ui.tools.browser
|
||||
tools.test.inference ui.private ;
|
||||
tools.test.inference ;
|
||||
|
||||
{ 0 1 } [ <browser-gadget> ] unit-test-effect
|
||||
[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: continuations documents ui.tools.interactor
|
||||
ui.tools.listener hashtables kernel namespaces parser sequences
|
||||
timers tools.test ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.panes vocabs words tools.test.ui ui.private ;
|
||||
ui.gadgets.panes vocabs words tools.test.ui ;
|
||||
IN: temporary
|
||||
|
||||
timers [ init-timers ] unless
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: assocs ui.tools.search help.topics io.files io.styles
|
||||
kernel namespaces sequences source-files threads timers
|
||||
tools.test ui.gadgets ui.gestures ui.private vocabs
|
||||
tools.test ui.gadgets ui.gestures vocabs
|
||||
vocabs.loader words tools.test.ui debugger ;
|
||||
IN: temporary
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
|
|||
ui.tools.search ui.tools.workspace kernel models namespaces
|
||||
sequences timers tools.test ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.labelled ui.gadgets.presentations
|
||||
ui.gadgets.scrollers vocabs tools.test.ui ui ui.private ;
|
||||
ui.gadgets.scrollers vocabs tools.test.ui ui ;
|
||||
IN: temporary
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays continuations ui.tools.listener ui.tools.walker
|
||||
ui.tools.workspace inspector kernel namespaces sequences threads
|
||||
listener tools.test ui ui.gadgets ui.gadgets.worlds ui.private
|
||||
listener tools.test ui ui.gadgets ui.gadgets.worlds
|
||||
ui.gadgets.packs vectors ui.tools tools.interpreter
|
||||
tools.interpreter.debug tools.test.inference tools.test.ui ;
|
||||
IN: temporary
|
||||
|
|
|
|||
|
|
@ -28,8 +28,6 @@ SYMBOL: windows
|
|||
: unregister-window ( handle -- )
|
||||
windows global [ [ first = not ] curry* subset ] change-at ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: raised-window ( world -- )
|
||||
windows get-global [ second eq? ] curry* find drop
|
||||
windows get-global [ length 1- ] keep exchange ;
|
||||
|
|
@ -67,8 +65,6 @@ M: world ungraft*
|
|||
dup world-handle (close-window)
|
||||
reset-world ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: open-world-window ( world -- )
|
||||
dup pref-dim over set-gadget-dim dup relayout graft ;
|
||||
|
||||
|
|
@ -90,8 +86,6 @@ SYMBOL: ui-hook
|
|||
<dlist> \ layout-queue set-global
|
||||
V{ } clone windows set-global ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: restore-gadget-later ( gadget -- )
|
||||
dup gadget-graft-state {
|
||||
{ { f f } [ ] }
|
||||
|
|
@ -133,7 +127,7 @@ SYMBOL: ui-hook
|
|||
] { } make ;
|
||||
|
||||
: redraw-worlds ( seq -- )
|
||||
[ dup update-hand draw-world ] each ;
|
||||
[ dup update-hand [ draw-world ] time ] each ;
|
||||
|
||||
: notify ( gadget -- )
|
||||
dup gadget-graft-state {
|
||||
|
|
@ -146,8 +140,6 @@ SYMBOL: ui-hook
|
|||
: notify-queued ( -- )
|
||||
graft-queue [ notify ] dlist-slurp ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ui-step ( -- )
|
||||
[
|
||||
do-timers
|
||||
|
|
|
|||
|
|
@ -397,8 +397,10 @@ M: windows-ui-backend (close-window)
|
|||
GetDoubleClickTime double-click-timeout set-global ;
|
||||
|
||||
: cleanup-win32-ui ( -- )
|
||||
class-name-ptr get-global f UnregisterClass drop
|
||||
class-name-ptr get-global [ free ] when*
|
||||
class-name-ptr get-global [
|
||||
dup f UnregisterClass drop
|
||||
free
|
||||
] when*
|
||||
f class-name-ptr set-global ;
|
||||
|
||||
: setup-pixel-format ( hdc -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,25 @@
|
|||
|
||||
USING: alien.syntax ;
|
||||
|
||||
IN: unix.linux.fs
|
||||
|
||||
: MS_RDONLY 1 ; ! Mount read-only.
|
||||
: MS_NOSUID 2 ; ! Ignore suid and sgid bits.
|
||||
: MS_NODEV 4 ; ! Disallow access to device special files.
|
||||
: MS_NOEXEC 8 ; ! Disallow program execution.
|
||||
: MS_SYNCHRONOUS 16 ; ! Writes are synced at once.
|
||||
: MS_REMOUNT 32 ; ! Alter flags of a mounted FS.
|
||||
: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS.
|
||||
: S_WRITE 128 ; ! Write on file/directory/symlink.
|
||||
: S_APPEND 256 ; ! Append-only file.
|
||||
: S_IMMUTABLE 512 ; ! Immutable file.
|
||||
: MS_NOATIME 1024 ; ! Do not update access times.
|
||||
: MS_NODIRATIME 2048 ; ! Do not update directory access times.
|
||||
: MS_BIND 4096 ; ! Bind directory at different place.
|
||||
|
||||
FUNCTION: int mount
|
||||
( char* special_file, char* dir, char* fstype, ulong options, void* data ) ;
|
||||
|
||||
! FUNCTION: int umount2 ( char* file, int flags ) ;
|
||||
|
||||
FUNCTION: int umount ( char* file ) ;
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
|
||||
USING: alien.syntax ;
|
||||
|
||||
IN: unix.linux.swap
|
||||
|
||||
: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified.
|
||||
: SWAP_FLAG_PRIO_MASK HEX: 7fff ;
|
||||
: SWAP_FLAG_PRIO_SHIFT 0 ;
|
||||
|
||||
FUNCTION: int swapon ( char* path, int flags ) ;
|
||||
|
||||
FUNCTION: int swapoff ( char* path ) ;
|
||||
|
|
@ -31,11 +31,23 @@ IN: unix.process
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! This is kludgy. We need a better implementation.
|
||||
USING: kernel alien.c-types namespaces continuations threads assocs unix
|
||||
combinators.cleave ;
|
||||
|
||||
USE: threads
|
||||
SYMBOL: pid-wait
|
||||
|
||||
: wait-for-pid ( pid -- )
|
||||
dup "int" <c-object> WNOHANG waitpid
|
||||
0 = [ 100 sleep wait-for-pid ] [ drop ] if ;
|
||||
! KEY | VALUE
|
||||
! -----------
|
||||
! pid | continuation
|
||||
|
||||
: init-pid-wait ( -- ) H{ } clone pid-wait set-global ;
|
||||
|
||||
: wait-for-pid ( pid -- status ) [ pid-wait get set-at stop ] curry callcc1 ;
|
||||
|
||||
: wait-loop ( -- )
|
||||
-1 0 <int> tuck WNOHANG waitpid ! &status return
|
||||
[ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
|
||||
dup [ schedule-thread-with ] [ 2drop ] if
|
||||
250 sleep wait-loop ;
|
||||
|
||||
: start-wait-loop ( -- ) init-pid-wait [ wait-loop ] in-thread ;
|
||||
|
|
@ -166,6 +166,10 @@ FUNCTION: time_t time ( time_t* t ) ;
|
|||
FUNCTION: int unlink ( char* path ) ;
|
||||
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! wait and waitpid
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Flags for waitpid
|
||||
|
||||
: WNOHANG 1 ;
|
||||
|
|
@ -176,7 +180,27 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
|
|||
: WCONTINUED 8 ;
|
||||
: WNOWAIT HEX: 1000000 ;
|
||||
|
||||
! Examining status
|
||||
|
||||
: WTERMSIG ( status -- value ) HEX: 7f bitand ;
|
||||
|
||||
: WIFEXITED ( status -- ? ) WTERMSIG zero? ;
|
||||
|
||||
: WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ;
|
||||
|
||||
: WIFSIGNALED ( status -- ? ) HEX: 7f bitand 1+ -1 shift 0 > ;
|
||||
|
||||
: WCOREFLAG ( -- value ) HEX: 80 ;
|
||||
|
||||
: WCOREDUMP ( status -- ? ) WCOREFLAG bitand zero? not ;
|
||||
|
||||
: WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ;
|
||||
|
||||
: WSTOPSIG ( status -- value ) WEXITSTATUS ;
|
||||
|
||||
FUNCTION: pid_t wait ( int* status ) ;
|
||||
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database ; %>
|
||||
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
|
||||
<div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
|
||||
<% f "navigation" render-template %>
|
||||
<div id="article">
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager ; %>
|
||||
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
|
||||
|
||||
<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
|
||||
<% f "navigation" render-template %>
|
||||
|
|
|
|||
|
|
@ -166,6 +166,9 @@
|
|||
(beginning-of-line)
|
||||
(insert "! "))
|
||||
|
||||
(defun factor-refresh-all ()
|
||||
(interactive)
|
||||
(comint-send-string "*factor*" "refresh-all\n"))
|
||||
|
||||
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
|
||||
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
|
||||
|
|
|
|||
Loading…
Reference in New Issue