Merge branch 'master' of git://factorcode.org/git/factor
commit
30171f41df
|
@ -30,7 +30,8 @@ IN: cocoa.windows
|
|||
: <ViewWindow> ( view rect -- window )
|
||||
<NSWindow> [ swap -> setContentView: ] keep
|
||||
dup dup -> contentView -> setInitialFirstResponder:
|
||||
dup 1 -> setAcceptsMouseMovedEvents: ;
|
||||
dup 1 -> setAcceptsMouseMovedEvents:
|
||||
dup 0 -> setReleasedWhenClosed: ;
|
||||
|
||||
: window-content-rect ( window -- rect )
|
||||
NSWindow over -> frame rot -> styleMask
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel tools.test peg peg.ebnf ;
|
||||
USING: kernel tools.test peg peg.ebnf compiler.units ;
|
||||
IN: peg.ebnf.tests
|
||||
|
||||
{ T{ ebnf-non-terminal f "abc" } } [
|
||||
|
@ -15,11 +15,8 @@ IN: peg.ebnf.tests
|
|||
{
|
||||
T{ ebnf-rule f
|
||||
"digit"
|
||||
V{
|
||||
T{ ebnf-choice f
|
||||
V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
|
||||
}
|
||||
f
|
||||
T{ ebnf-choice f
|
||||
V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
|
||||
}
|
||||
}
|
||||
} [
|
||||
|
@ -29,11 +26,8 @@ IN: peg.ebnf.tests
|
|||
{
|
||||
T{ ebnf-rule f
|
||||
"digit"
|
||||
V{
|
||||
T{ ebnf-sequence f
|
||||
V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
|
||||
}
|
||||
f
|
||||
T{ ebnf-sequence f
|
||||
V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
|
||||
}
|
||||
}
|
||||
} [
|
||||
|
@ -83,7 +77,7 @@ IN: peg.ebnf.tests
|
|||
}
|
||||
}
|
||||
} [
|
||||
"one {(two | three) four}" 'choice' parse parse-result-ast
|
||||
"one ((two | three) four)*" 'choice' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{
|
||||
|
@ -95,5 +89,33 @@ IN: peg.ebnf.tests
|
|||
}
|
||||
}
|
||||
} [
|
||||
"one [ two ] three" 'choice' parse parse-result-ast
|
||||
"one ( two )? three" 'choice' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"\"foo\"" 'identifier' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"'foo'" 'identifier' parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"foo" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "b" } } [
|
||||
"foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 "b" } } [
|
||||
"foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 2 } } [
|
||||
"foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]]" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast
|
||||
] unit-test
|
|
@ -2,24 +2,31 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel parser words arrays strings math.parser sequences
|
||||
quotations vectors namespaces math assocs continuations peg
|
||||
peg.parsers unicode.categories ;
|
||||
peg.parsers unicode.categories multiline combinators.lib
|
||||
splitting ;
|
||||
IN: peg.ebnf
|
||||
|
||||
TUPLE: ebnf-non-terminal symbol ;
|
||||
TUPLE: ebnf-terminal symbol ;
|
||||
TUPLE: ebnf-any-character ;
|
||||
TUPLE: ebnf-ensure-not group ;
|
||||
TUPLE: ebnf-choice options ;
|
||||
TUPLE: ebnf-sequence elements ;
|
||||
TUPLE: ebnf-repeat0 group ;
|
||||
TUPLE: ebnf-repeat1 group ;
|
||||
TUPLE: ebnf-optional elements ;
|
||||
TUPLE: ebnf-rule symbol elements ;
|
||||
TUPLE: ebnf-action word ;
|
||||
TUPLE: ebnf-action parser code ;
|
||||
TUPLE: ebnf rules ;
|
||||
|
||||
C: <ebnf-non-terminal> ebnf-non-terminal
|
||||
C: <ebnf-terminal> ebnf-terminal
|
||||
C: <ebnf-any-character> ebnf-any-character
|
||||
C: <ebnf-ensure-not> ebnf-ensure-not
|
||||
C: <ebnf-choice> ebnf-choice
|
||||
C: <ebnf-sequence> ebnf-sequence
|
||||
C: <ebnf-repeat0> ebnf-repeat0
|
||||
C: <ebnf-repeat1> ebnf-repeat1
|
||||
C: <ebnf-optional> ebnf-optional
|
||||
C: <ebnf-rule> ebnf-rule
|
||||
C: <ebnf-action> ebnf-action
|
||||
|
@ -27,12 +34,10 @@ C: <ebnf> ebnf
|
|||
|
||||
SYMBOL: parsers
|
||||
SYMBOL: non-terminals
|
||||
SYMBOL: last-parser
|
||||
|
||||
: reset-parser-generation ( -- )
|
||||
V{ } clone parsers set
|
||||
H{ } clone non-terminals set
|
||||
f last-parser set ;
|
||||
H{ } clone non-terminals set ;
|
||||
|
||||
: store-parser ( parser -- number )
|
||||
parsers get [ push ] keep length 1- ;
|
||||
|
@ -50,7 +55,7 @@ SYMBOL: last-parser
|
|||
GENERIC: (generate-parser) ( ast -- id )
|
||||
|
||||
: generate-parser ( ast -- id )
|
||||
(generate-parser) dup last-parser set ;
|
||||
(generate-parser) ;
|
||||
|
||||
M: ebnf-terminal (generate-parser) ( ast -- id )
|
||||
ebnf-terminal-symbol token sp store-parser ;
|
||||
|
@ -61,6 +66,9 @@ M: ebnf-non-terminal (generate-parser) ( ast -- id )
|
|||
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
|
||||
] [ ] make delay sp store-parser ;
|
||||
|
||||
M: ebnf-any-character (generate-parser) ( ast -- id )
|
||||
drop [ drop t ] satisfy store-parser ;
|
||||
|
||||
M: ebnf-choice (generate-parser) ( ast -- id )
|
||||
ebnf-choice-options [
|
||||
generate-parser get-parser
|
||||
|
@ -71,9 +79,15 @@ M: ebnf-sequence (generate-parser) ( ast -- id )
|
|||
generate-parser get-parser
|
||||
] map seq store-parser ;
|
||||
|
||||
M: ebnf-ensure-not (generate-parser) ( ast -- id )
|
||||
ebnf-ensure-not-group generate-parser get-parser ensure-not store-parser ;
|
||||
|
||||
M: ebnf-repeat0 (generate-parser) ( ast -- id )
|
||||
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
|
||||
|
||||
M: ebnf-repeat1 (generate-parser) ( ast -- id )
|
||||
ebnf-repeat1-group generate-parser get-parser repeat1 store-parser ;
|
||||
|
||||
M: ebnf-optional (generate-parser) ( ast -- id )
|
||||
ebnf-optional-elements generate-parser get-parser optional store-parser ;
|
||||
|
||||
|
@ -83,15 +97,12 @@ M: ebnf-rule (generate-parser) ( ast -- id )
|
|||
swap [ parsers get set-nth ] keep ;
|
||||
|
||||
M: ebnf-action (generate-parser) ( ast -- id )
|
||||
ebnf-action-word search 1quotation
|
||||
last-parser get get-parser swap action store-parser ;
|
||||
[ ebnf-action-parser generate-parser get-parser ] keep
|
||||
ebnf-action-code string-lines parse-lines action store-parser ;
|
||||
|
||||
M: vector (generate-parser) ( ast -- id )
|
||||
[ generate-parser ] map peek ;
|
||||
|
||||
M: f (generate-parser) ( ast -- id )
|
||||
drop last-parser get ;
|
||||
|
||||
M: ebnf (generate-parser) ( ast -- id )
|
||||
ebnf-rules [
|
||||
generate-parser
|
||||
|
@ -99,67 +110,153 @@ M: ebnf (generate-parser) ( ast -- id )
|
|||
|
||||
DEFER: 'rhs'
|
||||
|
||||
: syntax ( string -- parser )
|
||||
#! Parses the string, ignoring white space, and
|
||||
#! does not put the result in the AST.
|
||||
token sp hide ;
|
||||
|
||||
: syntax-pack ( begin parser end -- parser )
|
||||
#! Parse 'parser' surrounded by syntax elements
|
||||
#! begin and end.
|
||||
[ syntax ] dipd syntax pack ;
|
||||
|
||||
: 'identifier' ( -- parser )
|
||||
#! Return a parser that parses an identifer delimited by
|
||||
#! a quotation character. The quotation can be single
|
||||
#! or double quotes. The AST produced is the identifier
|
||||
#! between the quotes.
|
||||
[
|
||||
[ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,
|
||||
[ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,
|
||||
] choice* [ >string ] action ;
|
||||
|
||||
: 'non-terminal' ( -- parser )
|
||||
CHAR: a CHAR: z range "-" token [ first ] action 2array choice repeat1 [ >string <ebnf-non-terminal> ] action ;
|
||||
#! A non-terminal is the name of another rule. It can
|
||||
#! be any non-blank character except for characters used
|
||||
#! in the EBNF syntax itself.
|
||||
[
|
||||
{
|
||||
[ dup blank? ]
|
||||
[ dup CHAR: " = ]
|
||||
[ dup CHAR: ' = ]
|
||||
[ dup CHAR: | = ]
|
||||
[ dup CHAR: { = ]
|
||||
[ dup CHAR: } = ]
|
||||
[ dup CHAR: = = ]
|
||||
[ dup CHAR: ) = ]
|
||||
[ dup CHAR: ( = ]
|
||||
[ dup CHAR: ] = ]
|
||||
[ dup CHAR: [ = ]
|
||||
[ dup CHAR: . = ]
|
||||
[ dup CHAR: ! = ]
|
||||
[ dup CHAR: * = ]
|
||||
[ dup CHAR: + = ]
|
||||
[ dup CHAR: ? = ]
|
||||
} || not nip
|
||||
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
|
||||
|
||||
: 'terminal' ( -- parser )
|
||||
"'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
|
||||
#! A terminal is an identifier enclosed in quotations
|
||||
#! and it represents the literal value of the identifier.
|
||||
'identifier' [ <ebnf-terminal> ] action ;
|
||||
|
||||
: 'any-character' ( -- parser )
|
||||
#! A parser to match the symbol for any character match.
|
||||
[ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
|
||||
|
||||
: 'element' ( -- parser )
|
||||
'non-terminal' 'terminal' 2array choice ;
|
||||
#! An element of a rule. It can be a terminal or a
|
||||
#! non-terminal but must not be followed by a "=".
|
||||
#! The latter indicates that it is the beginning of a
|
||||
#! new rule.
|
||||
[
|
||||
[
|
||||
'non-terminal' ,
|
||||
'terminal' ,
|
||||
'any-character' ,
|
||||
] choice* ,
|
||||
"=" syntax ensure-not ,
|
||||
] seq* [ first ] action ;
|
||||
|
||||
DEFER: 'choice'
|
||||
|
||||
: grouped ( quot suffix -- parser )
|
||||
#! Parse a group of choices, with a suffix indicating
|
||||
#! the type of group (repeat0, repeat1, etc) and
|
||||
#! an quot that is the action that produces the AST.
|
||||
"(" [ 'choice' sp ] delay ")" syntax-pack
|
||||
swap 2seq
|
||||
[ first ] rot compose action ;
|
||||
|
||||
: 'group' ( -- parser )
|
||||
"(" token sp hide
|
||||
[ 'choice' sp ] delay
|
||||
")" token sp hide
|
||||
3array seq [ first ] action ;
|
||||
#! A grouping with no suffix. Used for precedence.
|
||||
[ ] [
|
||||
"*" token sp ensure-not ,
|
||||
"+" token sp ensure-not ,
|
||||
"?" token sp ensure-not ,
|
||||
"[[" token sp ensure-not ,
|
||||
] seq* hide grouped ;
|
||||
|
||||
: 'repeat0' ( -- parser )
|
||||
"{" token sp hide
|
||||
[ 'choice' sp ] delay
|
||||
"}" token sp hide
|
||||
3array seq [ first <ebnf-repeat0> ] action ;
|
||||
[ <ebnf-repeat0> ] "*" syntax grouped ;
|
||||
|
||||
: 'repeat1' ( -- parser )
|
||||
[ <ebnf-repeat1> ] "+" syntax grouped ;
|
||||
|
||||
: 'optional' ( -- parser )
|
||||
"[" token sp hide
|
||||
[ 'choice' sp ] delay
|
||||
"]" token sp hide
|
||||
3array seq [ first <ebnf-optional> ] action ;
|
||||
[ <ebnf-optional> ] "?" syntax grouped ;
|
||||
|
||||
: 'factor-code' ( -- parser )
|
||||
[
|
||||
"]]" token ensure-not ,
|
||||
[ drop t ] satisfy ,
|
||||
] seq* [ first ] action repeat0 [ >string ] action ;
|
||||
|
||||
: 'action' ( -- parser )
|
||||
[
|
||||
"(" [ 'choice' sp ] delay ")" syntax-pack ,
|
||||
"[[" 'factor-code' "]]" syntax-pack ,
|
||||
] seq* [ first2 <ebnf-action> ] action ;
|
||||
|
||||
|
||||
: 'ensure-not' ( -- parser )
|
||||
#! Parses the '!' syntax to ensure that
|
||||
#! something that matches the following elements do
|
||||
#! not exist in the parse stream.
|
||||
[
|
||||
"!" syntax ,
|
||||
'group' sp ,
|
||||
] seq* [ first <ebnf-ensure-not> ] action ;
|
||||
|
||||
: 'sequence' ( -- parser )
|
||||
#! A sequence of terminals and non-terminals, including
|
||||
#! groupings of those.
|
||||
[
|
||||
'ensure-not' sp ,
|
||||
'element' sp ,
|
||||
'group' sp ,
|
||||
'repeat0' sp ,
|
||||
'repeat1' sp ,
|
||||
'optional' sp ,
|
||||
] { } make choice
|
||||
repeat1 [
|
||||
'action' sp ,
|
||||
] choice* repeat1 [
|
||||
dup length 1 = [ first ] [ <ebnf-sequence> ] if
|
||||
] action ;
|
||||
] action ;
|
||||
|
||||
: 'choice' ( -- parser )
|
||||
'sequence' sp "|" token sp list-of [
|
||||
dup length 1 = [ first ] [ <ebnf-choice> ] if
|
||||
] action ;
|
||||
|
||||
: 'action' ( -- parser )
|
||||
"=>" token hide
|
||||
[ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
|
||||
2array seq [ first <ebnf-action> ] action ;
|
||||
|
||||
: 'rhs' ( -- parser )
|
||||
'choice' 'action' sp optional 2array seq ;
|
||||
] action ;
|
||||
|
||||
: 'rule' ( -- parser )
|
||||
'non-terminal' [ ebnf-non-terminal-symbol ] action
|
||||
"=" token sp hide
|
||||
'rhs'
|
||||
3array seq [ first2 <ebnf-rule> ] action ;
|
||||
[
|
||||
'non-terminal' [ ebnf-non-terminal-symbol ] action ,
|
||||
"=" syntax ,
|
||||
'choice' ,
|
||||
] seq* [ first2 <ebnf-rule> ] action ;
|
||||
|
||||
: 'ebnf' ( -- parser )
|
||||
'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
|
||||
'rule' sp repeat1 [ <ebnf> ] action ;
|
||||
|
||||
: ebnf>quot ( string -- quot )
|
||||
'ebnf' parse [
|
||||
|
@ -182,4 +279,4 @@ DEFER: 'choice'
|
|||
f
|
||||
] if* ;
|
||||
|
||||
: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing
|
||||
: <EBNF "EBNF>" parse-multiline-string ebnf>quot call ; parsing
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Chris Double
|
|
@ -0,0 +1,30 @@
|
|||
! Copyright (C) 2008 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays strings math.parser sequences
|
||||
peg peg.ebnf peg.parsers memoize math ;
|
||||
IN: peg.expr
|
||||
|
||||
: operator-fold ( lhs seq -- value )
|
||||
#! Perform a fold of a lhs, followed by a sequence of pairs being
|
||||
#! { operator rhs } in to a tree structure of the correct precedence.
|
||||
swap [ first2 swap call ] reduce ;
|
||||
|
||||
<EBNF
|
||||
|
||||
times = ("*") [[ drop [ * ] ]]
|
||||
divide = ("/") [[ drop [ / ] ]]
|
||||
add = ("+") [[ drop [ + ] ]]
|
||||
subtract = ("-") [[ drop [ - ] ]]
|
||||
|
||||
digit = "0" | "1" | "2" | "3" | "4" |
|
||||
"5" | "6" | "7" | "8" | "9"
|
||||
number = ((digit)+) [[ concat string>number ]]
|
||||
|
||||
value = number | ("(" expr ")") [[ second ]]
|
||||
product = (value ((times | divide) value)*) [[ first2 operator-fold ]]
|
||||
sum = (product ((add | subtract) product)*) [[ first2 operator-fold ]]
|
||||
expr = sum
|
||||
EBNF>
|
||||
|
||||
: eval-expr ( string -- number )
|
||||
expr parse parse-result-ast ;
|
|
@ -0,0 +1 @@
|
|||
Simple expression evaluator using EBNF
|
|
@ -0,0 +1 @@
|
|||
parsing
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel tools.test peg peg.pl0 ;
|
||||
USING: kernel tools.test peg peg.pl0 multiline sequences ;
|
||||
IN: peg.pl0.tests
|
||||
|
||||
{ "abc" } [
|
||||
|
@ -11,3 +11,89 @@ IN: peg.pl0.tests
|
|||
{ 55 } [
|
||||
"55abc" number parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
<"
|
||||
VAR x, squ;
|
||||
|
||||
PROCEDURE square;
|
||||
BEGIN
|
||||
squ := x * x
|
||||
END;
|
||||
|
||||
BEGIN
|
||||
x := 1;
|
||||
WHILE x <= 10 DO
|
||||
BEGIN
|
||||
CALL square;
|
||||
x := x + 1;
|
||||
END
|
||||
END.
|
||||
"> program parse parse-result-remaining empty?
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
<"
|
||||
CONST
|
||||
m = 7,
|
||||
n = 85;
|
||||
|
||||
VAR
|
||||
x, y, z, q, r;
|
||||
|
||||
PROCEDURE multiply;
|
||||
VAR a, b;
|
||||
|
||||
BEGIN
|
||||
a := x;
|
||||
b := y;
|
||||
z := 0;
|
||||
WHILE b > 0 DO BEGIN
|
||||
IF ODD b THEN z := z + a;
|
||||
a := 2 * a;
|
||||
b := b / 2;
|
||||
END
|
||||
END;
|
||||
|
||||
PROCEDURE divide;
|
||||
VAR w;
|
||||
BEGIN
|
||||
r := x;
|
||||
q := 0;
|
||||
w := y;
|
||||
WHILE w <= r DO w := 2 * w;
|
||||
WHILE w > y DO BEGIN
|
||||
q := 2 * q;
|
||||
w := w / 2;
|
||||
IF w <= r THEN BEGIN
|
||||
r := r - w;
|
||||
q := q + 1
|
||||
END
|
||||
END
|
||||
END;
|
||||
|
||||
PROCEDURE gcd;
|
||||
VAR f, g;
|
||||
BEGIN
|
||||
f := x;
|
||||
g := y;
|
||||
WHILE f # g DO BEGIN
|
||||
IF f < g THEN g := g - f;
|
||||
IF g < f THEN f := f - g;
|
||||
END;
|
||||
z := f
|
||||
END;
|
||||
|
||||
BEGIN
|
||||
x := m;
|
||||
y := n;
|
||||
CALL multiply;
|
||||
x := 25;
|
||||
y := 3;
|
||||
CALL divide;
|
||||
x := 84;
|
||||
y := 36;
|
||||
CALL gcd;
|
||||
END.
|
||||
"> program parse parse-result-remaining empty?
|
||||
] unit-test
|
|
@ -1,30 +1,31 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays strings math.parser sequences
|
||||
peg peg.ebnf peg.parsers memoize ;
|
||||
peg peg.ebnf peg.parsers memoize namespaces ;
|
||||
IN: peg.pl0
|
||||
|
||||
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
|
||||
MEMO: ident ( -- parser )
|
||||
CHAR: a CHAR: z range
|
||||
CHAR: A CHAR: Z range 2array choice repeat1
|
||||
[ >string ] action ;
|
||||
[
|
||||
CHAR: a CHAR: z range ,
|
||||
CHAR: A CHAR: Z range ,
|
||||
] choice* repeat1 [ >string ] action ;
|
||||
|
||||
MEMO: number ( -- parser )
|
||||
CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ;
|
||||
|
||||
<EBNF
|
||||
program = block '.' .
|
||||
block = [ 'const' ident '=' number { ',' ident '=' number } ';' ]
|
||||
[ 'var' ident { ',' ident } ';' ]
|
||||
{ 'procedure' ident ';' [ block ';' ] } statement .
|
||||
statement = [ ident ':=' expression | 'call' ident |
|
||||
'begin' statement {';' statement } 'end' |
|
||||
'if' condition 'then' statement |
|
||||
'while' condition 'do' statement ] .
|
||||
condition = 'odd' expression |
|
||||
expression ('=' | '#' | '<=' | '<' | '>=' | '>') expression .
|
||||
expression = ['+' | '-'] term {('+' | '-') term } .
|
||||
term = factor {('*' | '/') factor } .
|
||||
factor = ident | number | '(' expression ')'
|
||||
program = block "."
|
||||
block = [ "CONST" ident "=" number { "," ident "=" number } ";" ]
|
||||
[ "VAR" ident { "," ident } ";" ]
|
||||
{ "PROCEDURE" ident ";" [ block ";" ] } statement
|
||||
statement = [ ident ":=" expression | "CALL" ident |
|
||||
"BEGIN" statement {";" statement } "END" |
|
||||
"IF" condition "THEN" statement |
|
||||
"WHILE" condition "DO" statement ]
|
||||
condition = "ODD" expression |
|
||||
expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression
|
||||
expression = ["+" | "-"] term {("+" | "-") term }
|
||||
term = factor {("*" | "/") factor }
|
||||
factor = ident | number | "(" expression ")"
|
||||
EBNF>
|
||||
|
|
|
@ -30,8 +30,6 @@ DEFER: start-walker-thread
|
|||
2dup start-walker-thread
|
||||
] if* ;
|
||||
|
||||
USING: io.streams.c prettyprint ;
|
||||
|
||||
: show-walker ( -- thread )
|
||||
get-walker-thread
|
||||
[ show-walker-hook get call ] keep ;
|
||||
|
@ -40,7 +38,7 @@ USING: io.streams.c prettyprint ;
|
|||
{
|
||||
{ [ dup continuation? ] [ (continue) ] }
|
||||
{ [ dup quotation? ] [ call ] }
|
||||
{ [ dup not ] [ "Single stepping abandoned" throw ] }
|
||||
{ [ dup not ] [ "Single stepping abandoned" rethrow ] }
|
||||
} cond ;
|
||||
|
||||
: break ( -- )
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math arrays cocoa cocoa.application command-line
|
||||
kernel memory namespaces cocoa.messages cocoa.runtime
|
||||
|
@ -8,6 +8,10 @@ ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views
|
|||
core-foundation threads ;
|
||||
IN: ui.cocoa
|
||||
|
||||
TUPLE: handle view window ;
|
||||
|
||||
C: <handle> handle
|
||||
|
||||
TUPLE: cocoa-ui-backend ;
|
||||
|
||||
SYMBOL: stop-after-last-window?
|
||||
|
@ -47,27 +51,30 @@ M: pasteboard set-clipboard-contents
|
|||
dup rot world>NSRect <ViewWindow>
|
||||
dup install-window-delegate
|
||||
over -> release
|
||||
2array
|
||||
<handle>
|
||||
] keep set-world-handle ;
|
||||
|
||||
M: cocoa-ui-backend set-title ( string world -- )
|
||||
world-handle second swap <NSString> -> setTitle: ;
|
||||
world-handle handle-window swap <NSString> -> setTitle: ;
|
||||
|
||||
: enter-fullscreen ( world -- )
|
||||
world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ;
|
||||
world-handle handle-view
|
||||
NSScreen -> mainScreen
|
||||
f -> enterFullScreenMode:withOptions:
|
||||
drop ;
|
||||
|
||||
: exit-fullscreen ( world -- )
|
||||
world-handle first f -> exitFullScreenModeWithOptions: ;
|
||||
world-handle handle-view f -> exitFullScreenModeWithOptions: ;
|
||||
|
||||
M: cocoa-ui-backend set-fullscreen* ( ? world -- )
|
||||
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
|
||||
|
||||
M: cocoa-ui-backend fullscreen* ( world -- ? )
|
||||
world-handle first -> isInFullScreenMode zero? not ;
|
||||
world-handle handle-view -> isInFullScreenMode zero? not ;
|
||||
|
||||
: auto-position ( world -- )
|
||||
dup world-loc { 0 0 } = [
|
||||
world-handle second -> center
|
||||
world-handle handle-window -> center
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
@ -75,27 +82,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
|
|||
M: cocoa-ui-backend (open-window) ( world -- )
|
||||
dup gadget-window
|
||||
dup auto-position
|
||||
world-handle second f -> makeKeyAndOrderFront: ;
|
||||
world-handle handle-window f -> makeKeyAndOrderFront: ;
|
||||
|
||||
M: cocoa-ui-backend (close-window) ( handle -- )
|
||||
first unregister-window ;
|
||||
handle-window -> release ;
|
||||
|
||||
M: cocoa-ui-backend close-window ( gadget -- )
|
||||
find-world [
|
||||
world-handle second f -> performClose:
|
||||
world-handle [
|
||||
handle-window f -> performClose:
|
||||
] when*
|
||||
] when* ;
|
||||
|
||||
M: cocoa-ui-backend raise-window* ( world -- )
|
||||
world-handle [
|
||||
second dup f -> orderFront: -> makeKeyWindow
|
||||
handle-window dup f -> orderFront: -> makeKeyWindow
|
||||
NSApp 1 -> activateIgnoringOtherApps:
|
||||
] when* ;
|
||||
|
||||
M: cocoa-ui-backend select-gl-context ( handle -- )
|
||||
first -> openGLContext -> makeCurrentContext ;
|
||||
handle-view -> openGLContext -> makeCurrentContext ;
|
||||
|
||||
M: cocoa-ui-backend flush-gl-context ( handle -- )
|
||||
first -> openGLContext -> flushBuffer ;
|
||||
handle-view -> openGLContext -> flushBuffer ;
|
||||
|
||||
SYMBOL: cocoa-init-hook
|
||||
|
||||
|
|
|
@ -313,6 +313,7 @@ CLASS: {
|
|||
{ "dealloc" "void" { "id" "SEL" }
|
||||
[
|
||||
drop
|
||||
dup unregister-window
|
||||
dup remove-observer
|
||||
SUPER-> dealloc
|
||||
]
|
||||
|
@ -349,7 +350,13 @@ CLASS: {
|
|||
|
||||
{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
|
||||
[
|
||||
2nip -> contentView window ungraft t
|
||||
3drop t
|
||||
]
|
||||
}
|
||||
|
||||
{ "windowWillClose:" "void" { "id" "SEL" "id" }
|
||||
[
|
||||
2nip -> object -> contentView window ungraft
|
||||
]
|
||||
} ;
|
||||
|
||||
|
|
|
@ -376,22 +376,6 @@ SYMBOL: trace-messages?
|
|||
|
||||
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
|
||||
|
||||
! ! ! !
|
||||
: set-world-dim ( dim world -- )
|
||||
swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
|
||||
SetWindowPos drop ;
|
||||
USE: random
|
||||
USE: arrays
|
||||
|
||||
: twiddle
|
||||
100 500 random +
|
||||
100 500 random +
|
||||
2array
|
||||
"x" get-global find-world
|
||||
set-world-dim
|
||||
yield ;
|
||||
! ! ! !
|
||||
|
||||
: event-loop ( msg -- )
|
||||
{
|
||||
{ [ windows get empty? ] [ drop ] }
|
||||
|
|
Loading…
Reference in New Issue