Quotation syntax changed from :[ ]: to [: ;] (286018ee) · Commits · Bernd Paysan / bigforth

Estyle-ShinyMetal.fs

+4 −4

Original line number	Diff line number	Diff line
		@@ -356,8 +356,8 @@ hscaler implements
		: subbox ( -- )
		^ M[ slide ]M ['] part0a ['] part5 arule new
		^ R[ lpage ]R ['] part1 ['] part0b hslider-p Eside new
		^ M[ slide ]M :[ part4 swap 2* xS + swap ]:
		:[ part0a swap xS 2* + swap ]:
		^ M[ slide ]M [: part4 swap 2* xS + swap ;]
		[: part0a swap xS 2* + swap ;]
		hslider-f hslider-d Erule new
		arule with $01000003 assign ^ endwith
		^ R[ rpage ]R ['] part3 ['] part0b hslider-p Eside new
		@@ -369,8 +369,8 @@ vscaler implements
		: subbox ( -- )
		^ M[ slide ]M ['] part5 ['] part0a arule new
		^ R[ rpage ]R ['] part0b ['] part3 vslider-p Eside new
		^ M[ slide ]M :[ part0a swap xS 2* + swap ]:
		:[ part4 swap 2* xS + swap ]:
		^ M[ slide ]M [: part0a swap xS 2* + swap ;]
		[: part4 swap 2* xS + swap ;]
		vslider-f vslider-d Erule new
		arule with $01000003 assign ^ endwith
		^ R[ lpage ]R ['] part0b ['] part1 vslider-p Eside new

Estyle-wood.fs

+8 −8

Original line number	Diff line number	Diff line
		@@ -422,7 +422,7 @@ hslider implements
		: part0b xN 0 ;
		: init ( callback -- ) >callback
		^ R[ lstep ]R 0 slidetri new \ 1 ^ habox new fixbox
		^ R[ lpage ]R :[ part1 part0 drop 2/ 0 p+ ]: ['] part0
		^ R[ lpage ]R [: part1 part0 drop 2/ 0 p+ ;] ['] part0
		hslider-pl hslider-pms hslider-fl hslider-dl Eleft new
		^ M[ slide ]M ['] part2' ['] part0 hslider-fls hslider-dls Erule new
		arule with $02000003 assign ^ endwith
		@@ -430,7 +430,7 @@ hslider implements
		arule with $01000003 assign ^ endwith
		^ M[ slide ]M ['] part2' ['] part0 hslider-frs hslider-dls Erule new
		arule with $02000003 assign ^ endwith
		^ R[ rpage ]R :[ part3 part0 drop 2/ 0 p+ ]: ['] part0
		^ R[ rpage ]R [: part3 part0 drop 2/ 0 p+ ;] ['] part0
		hslider-pr hslider-pms hslider-fr hslider-dr Eright new
		^ R[ rstep ]R 2 slidetri new \ 1 ^ habox new fixbox
		7 super init ;
		@@ -447,7 +447,7 @@ hscaler implements
		: part4' ( -- glue ) part4 swap xM xS 2* - 2/ - 1 max swap ;
		: init ( callback -- ) >callback
		^ M[ slide ]M ['] part0a ['] part5 arule new
		^ R[ lpage ]R :[ part1 part0c drop 2/ 0 p+ ]: ['] part0c
		^ R[ lpage ]R [: part1 part0c drop 2/ 0 p+ ;] ['] part0c
		hslider-pl hslider-pms hslider-fl hslider-dl Eleft new
		arule with $01000003 assign ^ endwith
		^ M[ slide ]M ['] part4' ['] part0c hslider-fls hslider-dls Erule new
		@@ -457,7 +457,7 @@ hscaler implements
		^ M[ slide ]M ['] part4' ['] part0c hslider-frs hslider-drs Erule new
		arule with $01000003 assign ^ endwith
		3 hbox new
		^ R[ rpage ]R :[ part3 part0c drop 2/ 0 p+ ]: ['] part0c
		^ R[ rpage ]R [: part3 part0c drop 2/ 0 p+ ;] ['] part0c
		hslider-pr hslider-pms hslider-fr hslider-dr Eright new
		arule with $01000003 assign ^ endwith
		3 hbox new
		@@ -470,7 +470,7 @@ vscaler implements
		: part4'v ( -- glue ) part4 swap xM xS 2* - 2/ - 1 max swap ;
		: init ( callback -- ) >callback
		^ M[ slide ]M ['] part5 ['] part0a arule new
		^ R[ rpage ]R ['] part0cv :[ part3 part0cv drop 2/ 0 p+ ]:
		^ R[ rpage ]R ['] part0cv [: part3 part0cv drop 2/ 0 p+ ;]
		vslider-pt vslider-pms vslider-ft vslider-dt Etop new
		arule with $01000003 assign ^ endwith
		^ M[ slide ]M ['] part0cv ['] part4'v vslider-fts vslider-dts Erule new
		@@ -480,7 +480,7 @@ vscaler implements
		^ M[ slide ]M ['] part0cv ['] part4'v vslider-fbs vslider-dbs Erule new
		arule with $01000003 assign ^ endwith
		3 vbox new
		^ R[ lpage ]R ['] part0cv :[ part1 part0cv drop 2/ 0 p+ ]:
		^ R[ lpage ]R ['] part0cv [: part1 part0cv drop 2/ 0 p+ ;]
		vslider-pb vslider-pms vslider-fb vslider-db Ebot new
		arule with $01000003 assign ^ endwith
		3 vbox new
		@@ -493,7 +493,7 @@ vslider implements
		: part0bv xN 0 ;
		: init ( callback -- ) >callback
		^ R[ lstep ]R 1 slidetri new \ 1 ^ habox new fixbox
		^ R[ lpage ]R ['] part0 :[ part1 part0 drop 2/ 0 p+ ]:
		^ R[ lpage ]R ['] part0 [: part1 part0 drop 2/ 0 p+ ;]
		vslider-pt vslider-pms vslider-ft vslider-dt Etop new
		^ M[ slide ]M ['] part0 ['] part2'v vslider-fts vslider-dts Erule new
		arule with $02000003 assign ^ endwith
		@@ -501,7 +501,7 @@ vslider implements
		arule with $02000003 assign ^ endwith
		^ M[ slide ]M ['] part0 ['] part2'v vslider-fbs vslider-dbs Erule new
		arule with $02000003 assign ^ endwith
		^ R[ rpage ]R ['] part0 :[ part3 part0 drop 2/ 0 p+ ]:
		^ R[ rpage ]R ['] part0 [: part3 part0 drop 2/ 0 p+ ;]
		vslider-pb vslider-pms vslider-fb vslider-db Ebot new
		^ R[ rstep ]R 3 slidetri new \ 1 ^ habox new fixbox
		7 super init ;

actors.fs

+19 −19

Original line number	Diff line number	Diff line
		@@ -157,37 +157,37 @@ class;
		\ actor simplification 05mar07py

		: noop-i ; immediate
		synonym S[ :[
		synonym DT[ :[
		synonym T[ :[
		synonym TS[ :[
		synonym CK[ :[
		synonym SC[ :[
		synonym SL[ :[
		synonym ]T[ :[
		synonym S[ [:
		synonym DT[ [:
		synonym T[ [:
		synonym TS[ [:
		synonym CK[ [:
		synonym SC[ [:
		synonym SL[ [:
		synonym ]T[ [:
		synonym CP[ noop-i
		synonym ]CP noop-i

		: ]S postpone ]: simple postpone new ; immediate restrict
		: ]DT postpone ]: data-act postpone new ; immediate restrict
		: ]T postpone ]: toggle postpone new ; immediate restrict
		: ]CK postpone ]: click postpone new ; immediate restrict
		: ][ postpone ]: postpone :[ ; immediate restrict
		: ]TS postpone ]: toggle-state postpone new ;
		: ]S postpone ;] simple postpone new ; immediate restrict
		: ]DT postpone ;] data-act postpone new ; immediate restrict
		: ]T postpone ;] toggle postpone new ; immediate restrict
		: ]CK postpone ;] click postpone new ; immediate restrict
		: ][ postpone ;] postpone [: ; immediate restrict
		: ]TS postpone ;] toggle-state postpone new ;
		immediate restrict
		: ]N ; immediate
		: ]TERM ; immediate

		\ other simplifications 05mar07py
		: C[ ; immediate restrict
		: ]SC postpone ]: scale-do postpone new ; immediate restrict
		: ]SL postpone ]: slider-do postpone new ; immediate restrict
		: ]SC postpone ;] scale-do postpone new ; immediate restrict
		: ]SL postpone ;] slider-do postpone new ; immediate restrict
		: TV[ ; immediate restrict
		: TB[ ; immediate restrict
		: TN[ ; immediate restrict
		: ]TV postpone ]: toggle-var postpone new ; immediate restrict
		: ]TB postpone ]: toggle-bit postpone new ; immediate restrict
		: ]TN postpone ]: toggle-num postpone new ; immediate restrict
		: ]TV postpone ;] toggle-var postpone new ; immediate restrict
		: ]TB postpone ;] toggle-bit postpone new ; immediate restrict
		: ]TN postpone ;] toggle-num postpone new ; immediate restrict
		: DF[ postpone dup postpone >o ; immediate restrict
		: ]DF postpone o> ; immediate restrict

displays.fs

+63 −63

Original line number	Diff line number	Diff line
		@@ -97,7 +97,7 @@ how: : dispose clicks HandleOff
		: .catch-rest ( n -- ) ." Error " . cr ;
		: handle-events ( -- ) events-lock @ ?EXIT
		events-lock on
		:[ handle-event invoke drop ]: catch
		[: handle-event invoke drop ;] catch
		events-lock off throw ;
		: do-event pass^ @ op!
		up@ TO event-task'
		@@ -461,9 +461,9 @@ how: : dispose clicks HandleOff

		\ Display 04aug05py
		[defined] x11 [IF]
		:[ event XMotionEvent time @ event-time !
		:noname event XMotionEvent time @ event-time !
		event XMotionEvent x @+ @ mxy!
		event XMotionEvent state @ 8 >> mb ! moved! ]:
		event XMotionEvent state @ 8 >> mb ! moved! ;
		MotionNotify cells Handlers + !
		\| 2Variable comp_stat
		\| Variable look_key
		@@ -471,7 +471,7 @@ how: : dispose clicks HandleOff

		\ Display 04jan07py

		:[ ( -- ) \ cr 'd emit 'o emit
		:noname ( -- ) \ cr 'd emit 'o emit
		do-exposed
		event XKeyEvent time @ event-time !
		[defined] has-utf8 [IF] xrc ic @ ?dup >r [THEN]
		@@ -483,13 +483,13 @@ how: : dispose clicks HandleOff
		?dup IF look_chars swap bounds ?DO
		I xc@+ swap >r event XKeyEvent state @ $3F and keyed
		r> I - +LOOP EXIT THEN
		look_key @ event XKeyEvent state @ $3F and $80 or keyed ]:
		look_key @ event XKeyEvent state @ $3F and $80 or keyed ;
		KeyPress cells Handlers + !

		\ Display 11sep05py

		:[ \ cr ." mapping notify"
		event XRefreshKeyboardMapping drop ]:
		:noname \ cr ." mapping notify"
		event XRefreshKeyboardMapping drop ;
		MappingNotify cells Handlers + !
		: click^ ( -- event ) clicks @ @+ swap 8* + ;
		: transclick ( x y -- x' y' ) ;
		@@ -524,7 +524,7 @@ how: : dispose clicks HandleOff
		: .button cr base push hex event XButtonEvent window
		@+ @+ @ swap rot xwin @ 9 .r 9 .r 9 .r 9 .r
		space event XButtonEvent x @+ swap . @ . ;
		:[ ( -- )
		:noname ( -- )
		do-exposed
		event XButtonEvent time @ event-time !
		event XButtonEvent time @ dup true in-time?
		@@ -536,11 +536,11 @@ how: : dispose clicks HandleOff
		lastclick on
		THEN EXIT THEN event !xyclick flags #pending -bit
		THEN flags #pending bit@ IF moreclicks THEN
		1 event sendclick lastclick on ]:
		1 event sendclick lastclick on ;
		ButtonPress cells Handlers + !

		\ Display 09mar99py
		:[ ( -- )
		:noname ( -- )
		do-exposed
		event XButtonEvent time @ event-time !
		event XButtonEvent time @ dup 0 in-time?
		@@ -556,7 +556,7 @@ how: : dispose clicks HandleOff
		IF event !xyclick +clicks moreclicks THEN
		flags #pending bit@ 0= >r
		2 event sendclick lastclick off
		r> IF flags #pending -bit THEN ]:
		r> IF flags #pending -bit THEN ;
		ButtonRelease cells Handlers + !

		\ Display 28jun98py
		@@ -571,32 +571,32 @@ how: : dispose clicks HandleOff

		\ Display 04aug05py

		:[
		:noname
		event XExposeEvent x @+ @+ @+ @ add-region
		\ event XExposeEvent count @ 0= IF ." draw" draw THEN
		flags #exposed +bit ]:
		flags #exposed +bit ;
		dup Expose cells Handlers + !
		GraphicsExpose cells Handlers + !
		:[ do-exposed pointed self
		IF mx @ my @ pointed moved THEN ]:
		:noname do-exposed pointed self
		IF mx @ my @ pointed moved THEN ;
		EnterNotify cells Handlers + !
		:[ do-exposed pointed self
		IF pointed leave 0 bind pointed moved? drop THEN ]:
		:noname do-exposed pointed self
		IF pointed leave 0 bind pointed moved? drop THEN ;
		LeaveNotify cells Handlers + !

		\ Display 23apr06py

		Create xev here sizeof XEvent dup allot erase

		:[ \ cr ." Selection Notify "
		:noname \ cr ." Selection Notify "
		event XSelectionRequestEvent time @ event-time !
		event XSelectionEvent property @
		event XSelectionEvent requestor @
		xrc dpy @ fetch-property ]:
		xrc dpy @ fetch-property ;
		SelectionNotify cells Handlers + !

		:[ \ cr ." Selection Clear "
		own-selection off ]:
		:noname \ cr ." Selection Clear "
		own-selection off ;
		SelectionClear cells Handlers + !

		\ Display 16jan05py
		@@ -622,7 +622,7 @@ how: : dispose clicks HandleOff
		'string 2 PropModeReplace #32 4 rest-request ;

		\ Display 16jan05py
		:[ \ cr ." Selection Request "
		:noname \ cr ." Selection Request "
		event XSelectionRequestEvent time @ event-time !
		event xev 4 cells move
		event XSelectionRequestEvent requestor
		@@ -642,51 +642,51 @@ how: : dispose clicks HandleOff

		xrc dpy @
		event XSelectionRequestEvent requestor @
		0 0 xev XSendEvent drop ]:
		0 0 xev XSendEvent drop ;
		SelectionRequest cells Handlers + !

		\ Display 07jan07py

		:[ flags #exposed +bit ]: NoExpose cells Handlers + !
		:[ ( -- ) \ resize request
		:noname flags #exposed +bit ; NoExpose cells Handlers + !
		:noname ( -- ) \ resize request
		event XConfigureEvent x @ x !
		event XConfigureEvent y @ y !
		event XConfigureEvent width @ rw !
		event XConfigureEvent height @ rh ! ]:
		event XConfigureEvent height @ rh ! ;
		ConfigureNotify cells Handlers + !
		:[ do-exposed focus ]:
		:noname do-exposed focus ;
		FocusIn cells Handlers + !
		:[ do-exposed defocus ]:
		:noname do-exposed defocus ;
		FocusOut cells Handlers + !
		: >exposed ( -- ) sync flags #exposed -bit
		BEGIN ( ExposureMask ) 0 get-event
		pause flags #exposed bit@ UNTIL ;

		\ Display 02aug98py
		:[ ( -- )
		event sizeof XClientMessageEvent dump ]:
		:noname ( -- )
		event sizeof XClientMessageEvent dump ;
		ClientMessage cells Handlers + !

		[THEN]

		\ Display 19jan00py
		[defined] win32 [IF] Create paint $40 allot
		:[ ( lparam wparam msg win -- ret )
		:noname ( lparam wparam msg win -- ret )
		xrc dc @ >r paint xwin @ BeginPaint xrc dc !
		Xform0 xrc dc @ SetWorldTransform drop
		draw paint xwin @ EndPaint drop r> xrc dc !
		2drop 2drop 0 flags #exposed +bit ]: WM_PAINT Handler@ !
		:[ 3 pick >lohi y ! x ! DefWindowProc ]:
		2drop 2drop 0 flags #exposed +bit ; WM_PAINT Handler@ !
		:noname 3 pick >lohi y ! x ! DefWindowProc ;
		WM_MOVE Handler@ !
		:[ 2drop 2drop close 0 ]: WM_CLOSE Handler@ !
		:[ 3 pick WINDOWPOS flags @ SWP_NOSIZE and
		:noname 2drop 2drop close 0 ; WM_CLOSE Handler@ !
		:noname 3 pick WINDOWPOS flags @ SWP_NOSIZE and
		IF DefWindowProc EXIT THEN 2drop drop
		WINDOWPOS cx 2@ 0. 0. sp@ 0 style @ rot
		AdjustWindowRect drop p- p- rw ! rh !
		size-event 0 ]: WM_WINDOWPOSCHANGED Handler@ !
		size-event 0 ; WM_WINDOWPOSCHANGED Handler@ !

		\ Display 28jul07py
		:[ 2drop drop { rect \|
		:noname 2drop drop { rect \|
		vglue >r hglue >r 0 0 sp@ >r 0 style @ r>
		AdjustWindowRect drop p- rect 2@ p+
		dup r> + 2 pick r> + >r >r
		@@ -696,11 +696,11 @@ how: : dispose clicks HandleOff
		AdjustWindowRect drop p- rect 2@ p+
		rot over - r@ 2/ + r@ / r> * + -rot swap
		over - r@ 2/ + r@ / r> * + swap
		rect 2 cells + 2! 0 } ]: WM_SIZING Handler@ !
		\ :[ ( lparam wparam msg win -- ret )
		\ DefWindowProc ]: WM_INPUTLANGCHANGE Handler@ !
		\ :[ ( lparam wparam msg win -- ret )
		\ DefWindowProc ]: WM_INPUTLANGCHANGEREQUEST Handler@ !
		rect 2 cells + 2! 0 } ; WM_SIZING Handler@ !
		\ :noname ( lparam wparam msg win -- ret )
		\ DefWindowProc ; WM_INPUTLANGCHANGE Handler@ !
		\ :noname ( lparam wparam msg win -- ret )
		\ DefWindowProc ; WM_INPUTLANGCHANGEREQUEST Handler@ !

		\ Display 19jan00py

		@@ -723,15 +723,15 @@ private:
		$FF51 , $FF52 , $FF53 , $FF54 ,
		0 , 0 , 0 , 0 ,
		$0000 , $007F ,
		:[ 2drop nip dup $21 $2F within
		:noname 2drop nip dup $21 $2F within
		IF $21 - cells xkeys + @ ?dup
		IF shift@ ?keyed THEN
		ELSE drop THEN 0 ]: WM_KEYDOWN Handler@ !
		:[ 2drop nip shift@ ?keyed 0 ]:
		ELSE drop THEN 0 ; WM_KEYDOWN Handler@ !
		:noname 2drop nip shift@ ?keyed 0 ;
		WM_CHAR Handler@ !
		\ :[ 2drop nip shift@ ?keyed 0 ]:
		\ :noname 2drop nip shift@ ?keyed 0 ;
		\ WM_IME_CHAR Handler@ !
		:[ 2drop nip shift@ ( 8 or ) ?keyed 0 ]:
		:noname 2drop nip shift@ ( 8 or ) ?keyed 0 ;
		WM_SYSCHAR Handler@ !

		\ Display 12aug00py
		@@ -768,7 +768,7 @@ private:
		: +clicks ( -- ) click^ 6+ dup w@ 2+ -2 and swap w! ;

		\ Display 19jan00py
		:[ ( lparam wparam msg win -- 0 ) ?grab \ add press
		:noname ( lparam wparam msg win -- 0 ) ?grab \ add press
		SetCapture 2drop 2drop
		event MSG time @ dup true in-time?
		swap lasttime !
		@@ -779,13 +779,13 @@ private:
		lastclick on
		THEN 0 EXIT THEN event !xyclick flags #pending -bit
		THEN flags #pending bit@ IF moreclicks THEN
		1 event sendclick lastclick on 0 ]:
		1 event sendclick lastclick on 0 ;
		dup WM_LBUTTONDOWN Handler@ !
		dup WM_RBUTTONDOWN Handler@ !
		WM_MBUTTONDOWN Handler@ !

		\ Display 19jan00py
		:[ 2drop $13 and 0= IF ReleaseCapture drop THEN
		:noname 2drop $13 and 0= IF ReleaseCapture drop THEN
		?grab drop event MSG time @ dup 0 in-time?
		swap lasttime !
		IF event samepos? IF lastclick @
		@@ -798,7 +798,7 @@ private:
		IF event !xyclick +clicks moreclicks THEN
		flags #pending bit@ 0= >r
		2 event sendclick lastclick off 0
		r> IF flags #pending -bit THEN ]:
		r> IF flags #pending -bit THEN ;
		dup WM_LBUTTONUP Handler@ !
		dup WM_RBUTTONUP Handler@ ! WM_MBUTTONUP Handler@ !

		@@ -813,10 +813,10 @@ private:
		click^ w!+ w!+ w!+ w!
		moreclicks
		2 +LOOP drop ;
		:[ ( lparam wparam msg win -- ) moved!
		:noname ( lparam wparam msg win -- ) moved!
		flags #pending bit@ IF moreclicks flags #pending -bit THEN
		event MSG time @ lasttime !
		2drop 2drop event sendwheel 0 ]:
		2drop 2drop event sendwheel 0 ;
		WM_MOUSEWHEEL Handler@ !

		\ Display 12aug00py
		@@ -829,25 +829,25 @@ private:
		clicks @ $C + dup 8 - clicks @ @ 8* move
		( 2over 2over cr . . . . ) ;

		:[ 2drop drop >r
		:noname 2drop drop >r
		vglue + hglue +
		0. sp@ 0 style @ rot AdjustWindowRect drop p-
		r> $8 + 2! 0 ]:
		r> $8 + 2! 0 ;
		WM_GETMINMAXINFO Handler@ !

		\ Display 29jul07py
		:[ ( lparam wparam msg win -- ) ?grab moved!
		2drop >mshift $FF and mb ! >lohi mxy! 0 ]:
		:noname ( lparam wparam msg win -- ) ?grab moved!
		2drop >mshift $FF and mb ! >lohi mxy! 0 ;
		WM_MOUSEMOVE Handler@ !
		:[ opointed self
		:noname opointed self
		IF pointed leave 0 bind pointed THEN
		DefWindowProc ]: WM_NCMOUSEMOVE Handler@ !
		DefWindowProc ; WM_NCMOUSEMOVE Handler@ !

		:[ focus 2drop 2drop 0 ]: WM_SETFOCUS Handler@ !
		:[ defocus 2drop 2drop 0 ]: WM_KILLFOCUS Handler@ !
		:[ ( lparam wparam msg win -- )
		:noname focus 2drop 2drop 0 ; WM_SETFOCUS Handler@ !
		:noname defocus 2drop 2drop 0 ; WM_KILLFOCUS Handler@ !
		:noname ( lparam wparam msg win -- )
		2drop 2drop get-sys-colors xrc free-colors
		xrc colors 0 ]: WM_SYSCOLORCHANGE Handler@ !
		xrc colors 0 ; WM_SYSCOLORCHANGE Handler@ !
		: >exposed ;
		[THEN]
		class;

lambda.fs

+4 −4

Original line number	Diff line number	Diff line
		\ anonymous definitions in a definition

		: :[ ( compile-time: -- orig colon-sys )
		: [: ( compile-time: -- orig colon-sys )
		state @ IF loffset @ last @ POSTPONE AHEAD true ELSE false THEN
		:noname ; immediate

		: ]: ( compile-time: orig colon-sys -- ; run-time: -- xt )
		: ;] ( compile-time: orig colon-sys -- ; run-time: -- xt )
		POSTPONE ; >r IF ] POSTPONE THEN r> POSTPONE ALiteral last ! loffset !
		ELSE r> THEN ( xt ) ; immediate
		\\\
		@@ -18,8 +18,8 @@
		execute ;

		: test ( f -- )
		:[ ." true" ]:
		:[ ." false" ]:
		[: ." true" ;]
		[: ." false" ;]
		if-else ;

		1 test cr \ writes "true"