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

Merge branch 'master' of http://factorcode.org/git/factor into native-image-loader

db4
Joe Groff 2010-07-07 13:09:41 -07:00
parent 8a7979da13 a7384d5de6
commit e2237afd61
33 changed files with 387 additions and 560 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/parser/parser.factor
View File

@ -32,7 +32,7 @@ SYMBOL: current-library
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
scan {
scan-token {
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
[ parse-c-type ]

2
basis/alien/syntax/syntax.factor
View File

@ -19,7 +19,7 @@ SYNTAX: FUNCTION:
(FUNCTION:) make-function define-declared ;
SYNTAX: FUNCTION-ALIAS:
scan create-function
scan-token create-function
(FUNCTION:) (make-function) define-declared ;
SYNTAX: CALLBACK:

3
basis/classes/struct/struct.factor
View File

@ -334,10 +334,9 @@ PRIVATE>
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
scan {
scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot suffix! t ] }
{ f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;

3
basis/cocoa/application/application-docs.factor
View File

@ -36,9 +36,6 @@ HELP: install-delegate
{ $values { "receiver" "an " { $snippet "NSObject" } } { "delegate" "an Objective C class" } }
{ $description "Sets the receiver's delegate to a new instance of the delegate class." } ;
HELP: objc-error
{ $error-description "Thrown by the Objective C runtime when an error occurs, for example, sending a message to an object with an unrecognized selector." } ;
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
"Utilities:"
{ $subsections

12
basis/cocoa/application/application.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2008 Slava Pestov
! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.strings cocoa.messages cocoa cocoa.classes
@ -40,16 +40,6 @@ FUNCTION: void NSBeep ( ) ;
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
TUPLE: objc-error alien reason ;
: objc-error ( alien -- * )
dup -> reason CF>string \ objc-error boa throw ;
M: objc-error summary ( error -- )
drop "Objective C exception" ;
[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
: running.app? ( -- ? )
#! Test if we're running a .app.
".app"

1
basis/cocoa/callbacks/authors.txt
View File

@ -1 +0,0 @@
Kevin P. Reid

33
basis/cocoa/callbacks/callbacks.factor
View File

@ -1,33 +0,0 @@
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types assocs kernel namespaces cocoa
cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
IN: cocoa.callbacks
SYMBOL: callbacks
: reset-callbacks ( -- )
H{ } clone callbacks set-global ;
reset-callbacks
CLASS: {
{ +name+ "FactorCallback" }
{ +superclass+ "NSObject" }
}
{ "perform:" void { id SEL id }
[ 2drop callbacks get at try ]
}
{ "dealloc" void { id SEL }
[
drop
dup callbacks get delete-at
SUPER-> dealloc
]
} ;
: <FactorCallback> ( quot -- id )
FactorCallback -> alloc -> init
[ callbacks get set-at ] keep ;

1
basis/cocoa/callbacks/platforms.txt
View File

@ -1 +0,0 @@
macosx

1
basis/cocoa/callbacks/summary.txt
View File

@ -1 +0,0 @@
Allows you to use Factor quotations as Cocoa actions

50
basis/cocoa/cocoa-tests.factor
View File

@ -4,15 +4,12 @@ tools.test memory compiler.units math core-graphics.types ;
FROM: alien.c-types => int void ;
IN: cocoa.tests
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "Foo" }
} {
"foo:"
void
{ id SEL NSRect }
[ gc "x" set 2drop ]
} ;
CLASS: Foo < NSObject
[
METHOD: void foo: NSRect rect [
gc rect "x" set
]
]
: test-foo ( -- )
Foo -> alloc -> init
@ -26,15 +23,10 @@ test-foo
[ 101.0 ] [ "x" get CGRect-w ] unit-test
[ 102.0 ] [ "x" get CGRect-h ] unit-test
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "Bar" }
} {
"bar"
NSRect
{ id SEL }
[ 2drop test-foo "x" get ]
} ;
CLASS: Bar < NSObject
[
METHOD: NSRect bar [ test-foo "x" get ]
]
Bar [
-> alloc -> init
@ -48,25 +40,17 @@ Bar [
[ 102.0 ] [ "x" get CGRect-h ] unit-test
! Make sure that we can add methods
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "Bar" }
} {
"bar"
NSRect
{ id SEL }
[ 2drop test-foo "x" get ]
} {
"babb"
int
{ id SEL int }
[ 2nip sq ]
} ;
CLASS: Bar < NSObject
[
METHOD: NSRect bar [ test-foo "x" get ]
METHOD: int babb: int x [ x sq ]
]
[ 144 ] [
Bar [
-> alloc -> init
dup 12 -> babb
dup 12 -> babb:
swap -> release
] compile-call
] unit-test

46
basis/cocoa/subclassing/subclassing-docs.factor
View File

@ -1,45 +1,23 @@
USING: help.markup help.syntax strings alien hashtables ;
IN: cocoa.subclassing
HELP: define-objc-class
{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
{ $list
{ { $link +name+ } " - a string naming the new class. Required." }
{ { $link +superclass+ } " - a string naming the superclass. Required." }
{ { $link +protocols+ } " - an array of strings naming protocols implemented by the superclass. Optional." }
}
"Every element of " { $snippet "imeth" } " defines an instance method, and is an array having the shape "
{ $snippet "{ name return args quot }" }
".:"
{ $table
{ "name" { "a selector name" } }
{ "name" { "a C type name; see " { $link "c-data" } } }
{ "args" { "a sequence of C type names; see " { $link "c-data" } } }
{ "quot" { "a quotation to be run as a callback when the method is invoked; see " { $link alien-callback } } }
}
"The quotation is run with the following values on the stack:"
{ $list
{ "the receiver of the message; an " { $link alien } " pointing to an instance of this class" }
{ "the selector naming the message; in most cases this value can be ignored" }
"arguments passed to the message, if any"
}
"There is no way to define instance variables or class methods using this mechanism. However, instance variables can be simulated by using the receiver to key into a hashtable." } ;
HELP: CLASS:
{ $syntax "CLASS: spec imeth... ;" }
{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions" } }
{ $description "A sugared form of the following:"
{ $code "{ imeth... } \"spec\" define-objc-class" }
{ $syntax "CLASS: name < superclass protocols... [ imeth... ]" }
{ $values { "name" "a new class name" } { "superclass" "a superclass name" } { "protocols" "zero or more protocol names" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
{ $description "Defines a new Objective C class. Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
$nl
"This word is preferred to calling " { $link define-objc-class } ", because it creates a class word in the " { $vocab-link "cocoa.classes" } " vocabulary at parse time, allowing code to refer to the class word in the same source file where the class is defined." } ;
{ define-objc-class POSTPONE: CLASS: } related-words
{ define-objc-class POSTPONE: CLASS: POSTPONE: METHOD: } related-words
HELP: METHOD:
{ $syntax "METHOD: return foo: type1 arg1 bar: type2 arg2 baz: ... [ body ]" }
{ $values { "return" "a C type name" } { "type1" "a C type name" } { "arg1" "a local variable name" } { "body" "arbitrary code" } }
{ $description "Defines a method inside of a " { $link POSTPONE: CLASS: } " form." } ;
ARTICLE: "objc-subclassing" "Subclassing Objective C classes"
"Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:"
{ $subsections POSTPONE: CLASS: }
"This word is actually syntax sugar for an ordinary word:"
{ $subsections define-objc-class }
"Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
{ $subsections POSTPONE: CLASS: POSTPONE: METHOD: }
"Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ;
IN: cocoa.subclassing

87
basis/cocoa/subclassing/subclassing.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime locals
compiler.units io.encodings.utf8 continuations make fry ;
USING: alien alien.c-types alien.parser alien.strings arrays
assocs combinators compiler hashtables kernel lexer libc
locals.parser locals.types math namespaces parser sequences
words cocoa.messages cocoa.runtime locals compiler.units
io.encodings.utf8 continuations make fry effects stack-checker
stack-checker.errors ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
@ -27,7 +29,7 @@ IN: cocoa.subclassing
: add-protocols ( protocols class -- )
'[ [ _ ] dip objc-protocol add-protocol ] each ;
: (define-objc-class) ( imeth protocols superclass name -- )
: (define-objc-class) ( methods protocols superclass name -- )
[ objc-class ] dip 0 objc_allocateClassPair
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
@ -49,33 +51,60 @@ IN: cocoa.subclassing
] with-compilation-unit ;
:: (redefine-objc-method) ( class method -- )
method init-method [| sel imp types |
class sel class_getInstanceMethod [
imp method_setImplementation drop
] [
class sel imp types add-method
] if*
] call ;
method init-method :> ( sel imp types )
class sel class_getInstanceMethod [
imp method_setImplementation drop
] [
class sel imp types add-method
] if* ;
: redefine-objc-methods ( imeth name -- )
: redefine-objc-methods ( methods name -- )
dup class-exists? [
objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
] [ 2drop ] if ;
SYMBOL: +name+
SYMBOL: +protocols+
SYMBOL: +superclass+
: define-objc-class ( imeth hash -- )
clone [
prepare-methods
+name+ get "cocoa.classes" create drop
+name+ get 2dup redefine-objc-methods swap
+protocols+ get +superclass+ get +name+ get
'[ _ _ _ _ (define-objc-class) ]
import-objc-class
] bind ;
:: define-objc-class ( name superclass protocols methods -- )
methods prepare-methods :> methods
name "cocoa.classes" create drop
methods name redefine-objc-methods
name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
SYNTAX: CLASS:
parse-definition unclip
>hashtable define-objc-class ;
scan-token
"<" expect
scan-token
"[" parse-tokens
\ ] parse-until define-objc-class ;
: (parse-selector) ( -- )
scan-token {
{ [ dup "[" = ] [ drop ] }
{ [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
[ f f 3array , "[" expect ]
} cond ;
: parse-selector ( -- selector types names )
[ (parse-selector) ] { } make
flip first3
[ concat ]
[ sift { id SEL } prepend ]
[ sift { "self" "selector" } prepend ] tri* ;
: parse-method-body ( names -- quot )
[ [ make-local ] map ] H{ } make-assoc
(parse-lambda) <lambda> ?rewrite-closures first ;
: method-effect ( quadruple -- effect )
[ third ] [ second void? { } { "x" } ? ] bi <effect> ;
: check-method ( quadruple -- )
[ fourth infer ] [ method-effect ] bi
2dup effect<= [ 2drop ] [ effect-error ] if ;
SYNTAX: METHOD:
scan-c-type
parse-selector
parse-method-body [ swap ] 2dip 4array
dup check-method
suffix! ;

2
basis/functors/backend/backend.factor
View File

@ -20,7 +20,7 @@ SYNTAX: FUNCTOR-SYNTAX:
dup search dup lexical? [ nip ] [ drop ] if ;
: scan-string-param ( -- name/param )
scan >string-param ;
scan-token >string-param ;
: scan-c-type-param ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;

27
basis/io/ports/ports.factor
View File

@ -105,7 +105,8 @@ TUPLE: output-port < buffered-port ;
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
M: output-port stream-element-type stream>> stream-element-type ; inline
M: output-port stream-element-type
stream>> stream-element-type ; inline
M: output-port stream-write1
dup check-disposed
@ -128,13 +129,24 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- )
: port-flush ( port -- )
dup buffer>> buffer-empty?
[ drop ] [ dup (wait-to-write) port-flush ] if ;
M: output-port stream-flush ( port -- )
[ check-disposed ] [ port-flush ] bi ;
HOOK: tell-handle os ( handle -- n )
HOOK: seek-handle os ( n seek-type handle -- )
M: buffered-port stream-tell ( stream -- n )
M: input-port stream-tell ( stream -- n )
[ check-disposed ]
[ handle>> tell-handle ]
[ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ;
[ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
M: output-port stream-tell ( stream -- n )
[ check-disposed ]
[ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi + ] bi ;
M: input-port stream-seek ( n seek-type stream -- )
[ check-disposed ]
@ -150,13 +162,6 @@ GENERIC: shutdown ( handle -- )
M: object shutdown drop ;
: port-flush ( port -- )
dup buffer>> buffer-empty?
[ drop ] [ dup (wait-to-write) port-flush ] if ;
M: output-port stream-flush ( port -- )
[ check-disposed ] [ port-flush ] bi ;
M: output-port dispose*
[
{

3
basis/locals/parser/parser.factor
View File

@ -55,8 +55,7 @@ M: lambda-parser parse-quotation ( -- quotation )
H{ } clone (parse-lambda) ;
: parse-binding ( end -- pair/f )
scan {
{ [ dup not ] [ unexpected-eof ] }
scan-token {
{ [ 2dup = ] [ 2drop f ] }
[ nip scan-object 2array ]
} cond ;

6
basis/tools/deploy/shaker/strip-cocoa.factor
View File

@ -13,12 +13,6 @@ IN: tools.deploy.shaker.cocoa
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
IN: cocoa.application
: objc-error ( error -- ) die ;
[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook
H{ } clone \ pool [
global [
! Only keeps those methods that we actually call

19
basis/tools/deploy/test/14/14.factor
View File

@ -6,19 +6,14 @@ kernel math ;
FROM: alien.c-types => float ;
IN: tools.deploy.test.14
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "Bar" }
} {
"bar:"
float
{ id SEL NSRect }
[
[ origin>> [ x>> ] [ y>> ] bi + ]
[ size>> [ w>> ] [ h>> ] bi + ]
bi +
CLASS: Bar < NSObject
[
METHOD: float bar: NSRect rect [
rect origin>> [ x>> ] [ y>> ] bi +
rect size>> [ w>> ] [ h>> ] bi +
+
]
} ;
]
: main ( -- )
Bar -> alloc -> init

13
basis/ui/backend/cocoa/cocoa.factor
View File

@ -228,14 +228,11 @@ M: cocoa-ui-backend system-alert
] [ 2drop ] if*
init-thread-timer ;
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "FactorApplicationDelegate" }
}
{ "applicationDidUpdate:" void { id SEL id }
[ 3drop reset-run-loop ]
} ;
CLASS: FactorApplicationDelegate < NSObject
[
METHOD: void applicationDidUpdate: id obj
[ reset-run-loop ]
]
: install-app-delegate ( -- )
NSApp FactorApplicationDelegate install-delegate ;

75
basis/ui/backend/cocoa/tools/tools.factor
View File

@ -21,50 +21,28 @@ IN: ui.backend.cocoa.tools
image save-panel [ save-image ] when* ;
! Handle Open events from the Finder
CLASS: {
{ +superclass+ "FactorApplicationDelegate" }
{ +name+ "FactorWorkspaceApplicationDelegate" }
}
CLASS: FactorWorkspaceApplicationDelegate < FactorApplicationDelegate
[
METHOD: void application: id app openFiles: id files [ files finder-run-files ]
{ "application:openFiles:" void { id SEL id id }
[ [ 3drop ] dip finder-run-files ]
}
METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
}
METHOD: id factorListener: id app [ show-listener f ]
{ "factorListener:" id { id SEL id }
[ 3drop show-listener f ]
}
METHOD: id factorBrowser: id app [ show-browser f ]
{ "factorBrowser:" id { id SEL id }
[ 3drop show-browser f ]
}
METHOD: id newFactorListener: id app [ listener-window f ]
{ "newFactorListener:" id { id SEL id }
[ 3drop listener-window f ]
}
METHOD: id newFactorBrowser: id app [ browser-window f ]
{ "newFactorBrowser:" id { id SEL id }
[ 3drop browser-window f ]
}
METHOD: id runFactorFile: id app [ menu-run-files f ]
{ "runFactorFile:" id { id SEL id }
[ 3drop menu-run-files f ]
}
METHOD: id saveFactorImage: id app [ save f ]
{ "saveFactorImage:" id { id SEL id }
[ 3drop save f ]
}
METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
{ "saveFactorImageAs:" id { id SEL id }
[ 3drop menu-save-image f ]
}
{ "refreshAll:" id { id SEL id }
[ 3drop [ refresh-all ] \ refresh-all call-listener f ]
} ;
METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ]
]
: install-app-delegate ( -- )
NSApp FactorWorkspaceApplicationDelegate install-delegate ;
@ -75,28 +53,17 @@ CLASS: {
dup [ quot call( string -- result/f ) ] when
[ pboard set-pasteboard-string ] when* ;
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "FactorServiceProvider" }
} {
"evalInListener:userData:error:"
void
{ id SEL id id id }
CLASS: FactorServiceProvider < NSObject
[
METHOD: void evalInListener: id pboard userData: id userData error: id error
[ pboard error [ eval-listener f ] do-service ]
METHOD: void evalToString: id pboard userData: id userData error: id error
[
nip
[ eval-listener f ] do-service
2drop
]
} {
"evalToString:userData:error:"
void
{ id SEL id id id }
[
nip
pboard error
[ [ (eval>string) ] with-interactive-vocabs ] do-service
2drop
]
} ;
]
: register-services ( -- )
NSApp

377
basis/ui/backend/cocoa/views/views.factor
View File

@ -3,14 +3,16 @@
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8
ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
core-foundation.strings core-graphics core-graphics.types threads
combinators math.rectangles ;
cocoa.runtime cocoa.types cocoa.windows sequences
io.encodings.utf8 locals ui ui.private ui.gadgets
ui.gadgets.private ui.gadgets.worlds ui.gestures
core-foundation.strings core-graphics core-graphics.types
threads combinators math.rectangles ;
IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- )
[ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
[ mouse-location ] [ drop window ] 2bi
dup [ move-hand fire-motion yield ] [ 2drop ] if ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
@ -62,7 +64,7 @@ CONSTANT: key-codes
[ event-modifiers ] [ key-code ] bi ;
: send-key-event ( view gesture -- )
swap window propagate-key-gesture ;
swap window dup [ propagate-key-gesture ] [ 2drop ] if ;
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
@ -82,22 +84,25 @@ CONSTANT: key-codes
[ nip mouse-event>gesture <button-down> ]
[ mouse-location ]
[ drop window ]
2tri send-button-down ;
2tri
dup [ send-button-down ] [ 3drop ] if ;
: send-button-up$ ( view event -- )
[ nip mouse-event>gesture <button-up> ]
[ mouse-location ]
[ drop window ]
2tri send-button-up ;
2tri
dup [ send-button-up ] [ 3drop ] if ;
: send-scroll$ ( view event -- )
[ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
[ mouse-location ]
[ drop window ]
2tri send-scroll ;
2tri
dup [ send-scroll ] [ 3drop ] if ;
: send-action$ ( view event gesture -- junk )
[ drop window ] dip send-action f ;
: send-action$ ( view event gesture -- )
[ drop window ] dip over [ send-action ] [ 2drop ] if ;
: add-resize-observer ( observer object -- )
[
@ -141,154 +146,90 @@ CONSTANT: selector>action H{
selector>action at
[ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
CLASS: {
{ +superclass+ "NSOpenGLView" }
{ +name+ "FactorView" }
{ +protocols+ { "NSTextInput" } }
}
CLASS: FactorView < NSOpenGLView NSTextInput
[
! Rendering
METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ]
! Rendering
{ "drawRect:" void { id SEL NSRect }
[ 2drop window draw-world ]
}
! Events
METHOD: char acceptsFirstMouse: id event [ 1 ]
! Events
{ "acceptsFirstMouse:" char { id SEL id }
[ 3drop 1 ]
}
METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
{ "mouseEntered:" void { id SEL id }
[ nip send-mouse-moved ]
}
METHOD: void mouseExited: id event [ forget-rollover ]
{ "mouseExited:" void { id SEL id }
[ 3drop forget-rollover ]
}
METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
{ "mouseMoved:" void { id SEL id }
[ nip send-mouse-moved ]
}
METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
{ "mouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
{ "rightMouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
{ "otherMouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
METHOD: void mouseDown: id event [ self event send-button-down$ ]
{ "mouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
METHOD: void mouseUp: id event [ self event send-button-up$ ]
{ "mouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
{ "rightMouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
{ "rightMouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
{ "otherMouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
{ "otherMouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
METHOD: void scrollWheel: id event [ self event send-scroll$ ]
{ "scrollWheel:" void { id SEL id }
[ nip send-scroll$ ]
}
METHOD: void keyDown: id event [ self event send-key-down-event ]
{ "keyDown:" void { id SEL id }
[ nip send-key-down-event ]
}
METHOD: void keyUp: id event [ self event send-key-up-event ]
{ "keyUp:" void { id SEL id }
[ nip send-key-up-event ]
}
{ "validateUserInterfaceItem:" char { id SEL id }
METHOD: char validateUserInterfaceItem: id event
[
nip -> action
2dup [ window ] [ utf8 alien>string ] bi* validate-action
[ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
self window [
event -> action utf8 alien>string validate-action
[ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
] [ 0 ] if*
]
}
{ "undo:" id { id SEL id }
[ nip undo-action send-action$ ]
}
METHOD: id undo: id event [ self event undo-action send-action$ f ]
{ "redo:" id { id SEL id }
[ nip redo-action send-action$ ]
}
METHOD: id redo: id event [ self event redo-action send-action$ f ]
{ "cut:" id { id SEL id }
[ nip cut-action send-action$ ]
}
METHOD: id cut: id event [ self event cut-action send-action$ f ]
{ "copy:" id { id SEL id }
[ nip copy-action send-action$ ]
}
METHOD: id copy: id event [ self event copy-action send-action$ f ]
{ "paste:" id { id SEL id }
[ nip paste-action send-action$ ]
}
METHOD: id paste: id event [ self event paste-action send-action$ f ]
{ "delete:" id { id SEL id }
[ nip delete-action send-action$ ]
}
METHOD: id delete: id event [ self event delete-action send-action$ f ]
{ "selectAll:" id { id SEL id }
[ nip select-all-action send-action$ ]
}
METHOD: id selectAll: id event [ self event select-all-action send-action$ f ]
{ "newDocument:" id { id SEL id }
[ nip new-action send-action$ ]
}
METHOD: id newDocument: id event [ self event new-action send-action$ f ]
{ "openDocument:" id { id SEL id }
[ nip open-action send-action$ ]
}
METHOD: id openDocument: id event [ self event open-action send-action$ f ]
{ "saveDocument:" id { id SEL id }
[ nip save-action send-action$ ]
}
METHOD: id saveDocument: id event [ self event save-action send-action$ f ]
{ "saveDocumentAs:" id { id SEL id }
[ nip save-as-action send-action$ ]
}
METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ]
{ "revertDocumentToSaved:" id { id SEL id }
[ nip revert-action send-action$ ]
}
METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ]
! Multi-touch gestures: this is undocumented.
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
{ "magnifyWithEvent:" void { id SEL id }
! Multi-touch gestures
METHOD: void magnifyWithEvent: id event
[
nip
self event
dup -> deltaZ sgn {
{ 1 [ zoom-in-action send-action$ ] }
{ -1 [ zoom-out-action send-action$ ] }
{ 0 [ 2drop ] }
} case
]
}
{ "swipeWithEvent:" void { id SEL id }
METHOD: void swipeWithEvent: id event
[
nip
self event
dup -> deltaX sgn {
{ 1 [ left-action send-action$ ] }
{ -1 [ right-action send-action$ ] }
@ -303,114 +244,92 @@ CLASS: {
}
} case
]
}
{ "acceptsFirstResponder" char { id SEL }
[ 2drop 1 ]
}
METHOD: char acceptsFirstResponder [ 1 ]
! Services
{ "validRequestorForSendType:returnType:" id { id SEL id id }
! Services
METHOD: id validRequestorForSendType: id sendType returnType: id returnType
[
! We return either self or nil
[ over window-focus ] 2dip
valid-service? [ drop ] [ 2drop f ] if
self window [
world-focus sendType returnType
valid-service? [ self ] [ f ] if
] [ f ] if*
]
}
{ "writeSelectionToPasteboard:types:" char { id SEL id id }
METHOD: char writeSelectionToPasteboard: id pboard types: id types
[
CF>string-array NSStringPboardType swap member? [
[ drop window-focus gadget-selection ] dip over
[ set-pasteboard-string 1 ] [ 2drop 0 ] if
] [ 3drop 0 ] if
NSStringPboardType types CF>string-array member? [
self window [
world-focus gadget-selection
[ pboard set-pasteboard-string 1 ] [ 0 ] if*
] [ 0 ] if*
] [ 0 ] if
]
}
{ "readSelectionFromPasteboard:" char { id SEL id }
METHOD: char readSelectionFromPasteboard: id pboard
[
pasteboard-string dup [
[ drop window ] dip swap user-input 1
] [ 3drop 0 ] if
self window :> window
window [
pboard pasteboard-string
[ window user-input 1 ] [ 0 ] if*
] [ 0 ] if
]
}
! Text input
{ "insertText:" void { id SEL id }
[ nip CF>string swap window user-input ]
}
{ "hasMarkedText" char { id SEL }
[ 2drop 0 ]
}
{ "markedRange" NSRange { id SEL }
[ 2drop 0 0 <NSRange> ]
}
{ "selectedRange" NSRange { id SEL }
[ 2drop 0 0 <NSRange> ]
}
{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
[ 2drop 2drop ]
}
{ "unmarkText" void { id SEL }
[ 2drop ]
}
{ "validAttributesForMarkedText" id { id SEL }
[ 2drop NSArray -> array ]
}
{ "attributedSubstringFromRange:" id { id SEL NSRange }
[ 3drop f ]
}
{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
[ 3drop 0 ]
}
{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
[ 3drop 0 0 0 0 <CGRect> ]
}
{ "conversationIdentifier" NSInteger { id SEL }
[ drop alien-address ]
}
! Initialization
{ "updateFactorGadgetSize:" void { id SEL id }
[ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
}
{ "doCommandBySelector:" void { id SEL SEL }
[ 3drop ]
}
{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
! Text input
METHOD: void insertText: id text
[
[ drop ] 2dip
SUPER-> initWithFrame:pixelFormat:
self window :> window
window [
text CF>string window user-input
] when
]
METHOD: char hasMarkedText [ 0 ]
METHOD: NSRange markedRange [ 0 0 <NSRange> ]
METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
METHOD: void unmarkText [ ]
METHOD: id validAttributesForMarkedText [ NSArray -> array ]
METHOD: id attributedSubstringFromRange: NSRange range [ f ]
METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
METHOD: NSInteger conversationIdentifier [ self alien-address ]
! Initialization
METHOD: void updateFactorGadgetSize: id notification
[
self window :> window
window [
self view-dim window dim<< yield
] when
]
METHOD: void doCommandBySelector: SEL selector [ ]
METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
[
self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
dup dup add-resize-observer
]
}
{ "isOpaque" char { id SEL }
[
2drop 0
]
}
METHOD: char isOpaque [ 0 ]
{ "dealloc" void { id SEL }
METHOD: void dealloc
[
drop
[ remove-observer ]
[ SUPER-> dealloc ]
bi
self remove-observer
self SUPER-> dealloc
]
} ;
]
: sync-refresh-to-screen ( GLView -- )
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
@ -422,45 +341,39 @@ CLASS: {
: save-position ( world window -- )
-> frame CGRect-top-left 2array >>window-loc drop ;
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "FactorWindowDelegate" }
}
{ "windowDidMove:" void { id SEL id }
CLASS: FactorWindowDelegate < NSObject
[
METHOD: void windowDidMove: id notification
[
2nip -> object [ -> contentView window ] keep save-position
notification -> object -> contentView window
[ notification -> object save-position ] when*
]
}
{ "windowDidBecomeKey:" void { id SEL id }
METHOD: void windowDidBecomeKey: id notification
[
2nip -> object -> contentView window focus-world
notification -> object -> contentView window
[ focus-world ] when*
]
}
{ "windowDidResignKey:" void { id SEL id }
METHOD: void windowDidResignKey: id notification
[
forget-rollover
2nip -> object -> contentView
dup -> isInFullScreenMode 0 =
[ window [ unfocus-world ] when* ]
[ drop ] if
notification -> object -> contentView :> view
view window :> window
window [
view -> isInFullScreenMode 0 =
[ window unfocus-world ] when
] when
]
}
{ "windowShouldClose:" char { id SEL id }
[
3drop 1
]
}
METHOD: char windowShouldClose: id notification [ 1 ]
{ "windowWillClose:" void { id SEL id }
METHOD: void windowWillClose: id notification
[
2nip -> object -> contentView
notification -> object -> contentView
[ window ungraft ] [ unregister-window ] bi
]
} ;
]
: install-window-delegate ( window -- )
FactorWindowDelegate install-delegate ;

2
basis/ui/ui.factor
View File

@ -16,8 +16,6 @@ SYMBOL: windows
: window ( handle -- world ) windows get-global at ;
: window-focus ( handle -- gadget ) window world-focus ;
: register-window ( world handle -- )
#! Add the new window just below the topmost window. Why?
#! So that if the new window doesn't actually receive focus

8
basis/urls/encoding/encoding-tests.factor
View File

@ -11,6 +11,12 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "~foo" ] [ "~foo" url-encode ] unit-test
[ "~foo" ] [ "~foo" url-encode-full ] unit-test
[ ":foo" ] [ ":foo" url-encode ] unit-test
[ "%3Afoo" ] [ ":foo" url-encode-full ] unit-test
[ "hello world" ] [ "hello+world" query-decode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
@ -25,6 +31,8 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
[ "foo=%3A" ] [ { { "foo" ":" } } assoc>query ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
[ "a" ] [ { { "a" f } } assoc>query ] unit-test

8
basis/urls/encoding/encoding.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
sequences splitting fry namespaces make assocs arrays strings
@ -11,7 +11,7 @@ IN: urls.encoding
[ letter? ]
[ LETTER? ]
[ digit? ]
[ "/_-.:" member? ]
[ "-._~/:" member? ]
} 1|| ; foldable
! see http://tools.ietf.org/html/rfc3986#section-2.2
@ -120,7 +120,7 @@ PRIVATE>
: assoc>query ( assoc -- str )
[
assoc-strings [
[ url-encode ] dip
[ [ url-encode "=" glue , ] with each ] [ , ] if*
[ url-encode-full ] dip
[ [ url-encode-full "=" glue , ] with each ] [ , ] if*
] assoc-each
] { } make "&" join ;

23
core/classes/tuple/parser/parser.factor
View File

@ -34,21 +34,19 @@ ERROR: invalid-slot-name name ;
[ scan , \ } parse-until % ] { } make ;
: parse-slot-name-delim ( end-delim string/f -- ? )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
#! TUPLE: blahblah foo bing
#!
#! : ...
! Check for mistakes of this form:
!
! TUPLE: blahblah foo bing
!
! : ...
{
{ [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond nip ;
: parse-tuple-slots-delim ( end-delim -- )
dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
: parse-slot-name ( string/f -- ? )
";" swap parse-slot-name-delim ;
@ -74,16 +72,14 @@ ERROR: bad-slot-name class slot ;
2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ;
: parse-slot-value ( class slots -- )
scan check-slot-name scan-object 2array , scan {
{ f [ \ } unexpected-eof ] }
scan check-slot-name scan-object 2array , scan-token {
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
: (parse-slot-values) ( class slots -- )
2dup parse-slot-value
scan {
{ f [ 2drop \ } unexpected-eof ] }
scan-token {
{ "{" [ (parse-slot-values) ] }
{ "}" [ 2drop ] }
[ 2nip bad-literal-tuple ]
@ -109,8 +105,7 @@ M: tuple-class boa>object
assoc-union! seq>> boa>object ;
: parse-tuple-literal-slots ( class slots -- tuple )
scan {
{ f [ unexpected-eof ] }
scan-token {
{ "f" [ drop \ } parse-until boa>object ] }
{ "{" [ 2dup parse-slot-values assoc>object ] }
{ "}" [ drop new ] }

3
core/effects/parser/parser.factor
View File

@ -26,9 +26,8 @@ SYMBOL: effect-var
: parse-effect-value ( token -- value )
":" ?tail [
scan {
scan-token {
{ [ dup "(" = ] [ drop ")" parse-effect ] }
{ [ dup f = ] [ ")" unexpected-eof ] }
[ parse-word dup class? [ bad-effect ] unless ]
} cond 2array
] when ;

28
core/io/files/files-tests.factor
View File

@ -161,8 +161,12 @@ CONSTANT: pt-array-1
"seek-test1" unique-file binary
[
[
B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
B{ 1 2 3 4 5 } write
tell-output 5 assert=
0 seek-absolute seek-output
tell-output 0 assert=
B{ 3 } write
tell-output 1 assert=
] with-file-writer
] [
file-contents
@ -174,8 +178,12 @@ CONSTANT: pt-array-1
"seek-test2" unique-file binary
[
[
B{ 1 2 3 4 5 } write -1 seek-relative seek-output
B{ 1 2 3 4 5 } write
tell-output 5 assert=
-1 seek-relative seek-output
tell-output 4 assert=
B{ 3 } write
tell-output 5 assert=
] with-file-writer
] [
file-contents
@ -187,8 +195,12 @@ CONSTANT: pt-array-1
"seek-test3" unique-file binary
[
[
B{ 1 2 3 4 5 } write 1 seek-relative seek-output
B{ 1 2 3 4 5 } write
tell-output 5 assert=
1 seek-relative seek-output
tell-output 6 assert=
B{ 3 } write
tell-output 7 assert=
] with-file-writer
] [
file-contents
@ -201,7 +213,11 @@ CONSTANT: pt-array-1
set-file-contents
] [
[
-3 seek-end seek-input 1 read
tell-input 0 assert=
-3 seek-end seek-input
tell-input 2 assert=
1 read
tell-input 3 assert=
] with-file-reader
] 2bi
] unit-test
@ -212,9 +228,13 @@ CONSTANT: pt-array-1
set-file-contents
] [
[
tell-input 0 assert=
3 seek-absolute seek-input
tell-input 3 assert=
-2 seek-relative seek-input
tell-input 1 assert=
1 read
tell-input 2 assert=
] with-file-reader
] 2bi
] unit-test

1
core/lexer/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Joe Groff

7
core/lexer/lexer-docs.factor
View File

@ -59,7 +59,12 @@ HELP: parse-token
HELP: scan
{ $values { "str/f" { $maybe string } } }
{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word outputs " { $link f } " on end of input. To throw an error on end of input, use " { $link scan-token } " instead." }
$parsing-note ;
HELP: scan-token
{ $values { "str" string } }
{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word throws " { $link unexpected-eof } " on end of input. To output " { $link f } " on end of input, use " { $link scan } " instead." }
$parsing-note ;
HELP: still-parsing?

50
core/lexer/lexer.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings
io vectors arrays math.parser combinators continuations
@ -18,12 +18,12 @@ TUPLE: lexer-parsing-word word line line-text column ;
: push-parsing-word ( word -- )
lexer-parsing-word new
swap >>word
lexer get [
[ line>> >>line ]
[ line-text>> >>line-text ]
[ column>> >>column ] tri
] [ parsing-words>> push ] bi ;
swap >>word
lexer get [
[ line>> >>line ]
[ line-text>> >>line-text ]
[ column>> >>column ] tri
] [ parsing-words>> push ] bi ;
: pop-parsing-word ( -- )
lexer get parsing-words>> pop drop ;
@ -77,7 +77,7 @@ M: lexer skip-word ( lexer -- )
[ line-text>> ]
} cleave subseq ;
: parse-token ( lexer -- str/f )
: parse-token ( lexer -- str/f )
dup still-parsing? [
dup skip-blank
dup still-parsing-line?
@ -90,18 +90,14 @@ PREDICATE: unexpected-eof < unexpected got>> not ;
: unexpected-eof ( word -- * ) f unexpected ;
: scan-token ( -- str ) scan [ "token" unexpected-eof ] unless* ;
: expect ( token -- )
scan
[ 2dup = [ 2drop ] [ unexpected ] if ]
[ unexpected-eof ]
if* ;
scan-token 2dup = [ 2drop ] [ unexpected ] if ;
: each-token ( ... end quot: ( ... token -- ... ) -- ... )
[ scan ] 2dip {
{ [ 2over = ] [ 3drop ] }
{ [ pick not ] [ drop unexpected-eof ] }
[ [ nip call ] [ each-token ] 2bi ]
} cond ; inline recursive
[ scan-token ] 2dip 2over =
[ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
collector [ each-token ] dip { } like ; inline
@ -117,14 +113,14 @@ M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
: <lexer-error> ( msg -- error )
\ lexer-error new
lexer get [
[ line>> >>line ]
[ column>> >>column ] bi
] [
[ line-text>> >>line-text ]
[ parsing-words>> clone >>parsing-words ] bi
] bi
swap >>error ;
lexer get [
[ line>> >>line ]
[ column>> >>column ] bi
] [
[ line-text>> >>line-text ]
[ parsing-words>> clone >>parsing-words ] bi
] bi
swap >>error ;
: simple-lexer-dump ( error -- )
[ line>> number>string ": " append ]
@ -148,7 +144,9 @@ M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
[ (parsing-word-lexer-dump) ] if ;
: lexer-dump ( error -- )
dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ;
dup parsing-words>>
[ simple-lexer-dump ]
[ last parsing-word-lexer-dump ] if-empty ;
: with-lexer ( lexer quot -- newquot )
[ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline

10
core/parser/parser-docs.factor
View File

@ -7,6 +7,11 @@ IN: parser
ARTICLE: "reading-ahead" "Reading ahead"
"Parsing words can consume input:"
{ $subsections
scan-token
scan-object
}
"Lower-level words:"
{ $subsections
scan
scan-word
@ -249,3 +254,8 @@ HELP: staging-violation
HELP: auto-use?
{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "word-search-errors" } "." } ;
HELP: scan-object
{ $values { "object" object } }
{ $description "Parses a literal representation of an object." }
$parsing-note ;

24
core/syntax/syntax.factor
View File

@ -41,32 +41,32 @@ IN: bootstrap.syntax
"#!" [ POSTPONE: ! ] define-core-syntax
"IN:" [ scan set-current-vocab ] define-core-syntax
"IN:" [ scan-token set-current-vocab ] define-core-syntax
"<PRIVATE" [ begin-private ] define-core-syntax
"PRIVATE>" [ end-private ] define-core-syntax
"USE:" [ scan use-vocab ] define-core-syntax
"USE:" [ scan-token use-vocab ] define-core-syntax
"UNUSE:" [ scan unuse-vocab ] define-core-syntax
"UNUSE:" [ scan-token unuse-vocab ] define-core-syntax
"USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
"QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
"QUALIFIED:" [ scan-token dup add-qualified ] define-core-syntax
"QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax
"QUALIFIED-WITH:" [ scan-token scan-token add-qualified ] define-core-syntax
"FROM:" [
scan "=>" expect ";" parse-tokens add-words-from
scan-token "=>" expect ";" parse-tokens add-words-from
] define-core-syntax
"EXCLUDE:" [
scan "=>" expect ";" parse-tokens add-words-excluding
scan-token "=>" expect ";" parse-tokens add-words-excluding
] define-core-syntax
"RENAME:" [
scan scan "=>" expect scan add-renamed-word
scan-token scan-token "=>" expect scan-token add-renamed-word
] define-core-syntax
"HEX:" [ 16 parse-base ] define-core-syntax
@ -79,7 +79,7 @@ IN: bootstrap.syntax
"t" "syntax" lookup define-singleton-class
"CHAR:" [
scan {
scan-token {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape >string "" assert= ] }
[ name>char-hook get call( name -- char ) ]
@ -133,7 +133,7 @@ IN: bootstrap.syntax
] define-core-syntax
"DEFER:" [
scan current-vocab create
scan-token current-vocab create
[ fake-definition ] [ set-word ] [ undefined-def define ] tri
] define-core-syntax
@ -190,7 +190,7 @@ IN: bootstrap.syntax
"PREDICATE:" [
CREATE-CLASS
scan "<" assert=
"<" expect
scan-word
parse-definition define-predicate-class
] define-core-syntax
@ -208,7 +208,7 @@ IN: bootstrap.syntax
] define-core-syntax
"SLOT:" [
scan define-protocol-slot
scan-token define-protocol-slot
] define-core-syntax
"C:" [

2
vm/objects.hpp
View File

@ -26,8 +26,6 @@ enum special_object {
OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
OBJ_STARTUP_QUOT = 20, /* startup quotation */
OBJ_GLOBAL, /* global namespace */
OBJ_SHUTDOWN_QUOT, /* shutdown quotation */

18
vm/os-macosx.mm
View File

@ -8,23 +8,7 @@ namespace factor
void factor_vm::c_to_factor_toplevel(cell quot)
{
for(;;)
{
NS_DURING
c_to_factor(quot);
NS_VOIDRETURN;
NS_HANDLER
ctx->push(allot_alien(false_object,(cell)localException));
quot = special_objects[OBJ_COCOA_EXCEPTION];
if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
{
/* No Cocoa exception handler was registered, so
basis/cocoa/ is not loaded. So we pass the exception
along. */
[localException raise];
}
NS_ENDHANDLER
}
c_to_factor(quot);
}
void early_init(void)