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

basis/alien/parser/parser.factor

@@ -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 ]

basis/alien/syntax/syntax.factor

@@ -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:

basis/classes/struct/struct.factor

@@ -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 ;
 

basis/cocoa/application/application-docs.factor

@@ -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

basis/cocoa/application/application.factor

@@ -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"

basis/cocoa/callbacks/authors.txt

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

basis/cocoa/callbacks/callbacks.factor

@@ -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 ;

basis/cocoa/callbacks/platforms.txt

@@ -1 +0,0 @@
-macosx

basis/cocoa/callbacks/summary.txt

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

basis/cocoa/cocoa-tests.factor

@@ -4,15 +4,12 @@ tools.test memory compiler.units math core-graphics.types ;
 FROM: alien.c-types => int void ;
 IN: cocoa.tests
 
-CLASS: {
+CLASS: Foo < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "Foo" }
+    METHOD: void foo: NSRect rect [
-} {
+        gc rect "x" set
-    "foo:"
+    ]
-    void
+]
-    { id SEL NSRect }
-    [ gc "x" set 2drop ]
-} ;
 
 : 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: {
+CLASS: Bar < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "Bar" }
+    METHOD: NSRect bar [ test-foo "x" get ]
-} {
+]
-    "bar"
-    NSRect
-    { id SEL }
-    [ 2drop 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: {
+CLASS: Bar < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "Bar" }
+    METHOD: NSRect bar [ test-foo "x" get ]
-} {
+
-    "bar"
+    METHOD: int babb: int x [ x sq ]
-    NSRect
+]
-    { id SEL }
-    [ 2drop test-foo "x" get ]
-} {
-    "babb"
-    int
-    { id SEL int }
-    [ 2nip sq ]
-} ;
 
 [ 144 ] [
     Bar [
         -> alloc -> init
-        dup 12 -> babb
+        dup 12 -> babb:
         swap -> release
     ] compile-call
 ] unit-test

basis/cocoa/subclassing/subclassing-docs.factor

@@ -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... ;" }
+{ $syntax "CLASS: name < superclass protocols... [ imeth... ]" }
-{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions" } }
+{ $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 "A sugared form of the following:"
+{ $description "Defines a new Objective C class. Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
-    { $code "{ imeth... } \"spec\" define-objc-class" }
+$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:"
+"Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
-{ $subsections POSTPONE: CLASS: }
+{ $subsections POSTPONE: CLASS: POSTPONE: METHOD: }
-"This word is actually syntax sugar for an ordinary word:"
-{ $subsections define-objc-class }
 "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

basis/cocoa/subclassing/subclassing.factor

@@ -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
+USING: alien alien.c-types alien.parser alien.strings arrays
-combinators compiler hashtables kernel libc math namespaces
+assocs combinators compiler hashtables kernel lexer libc
-parser sequences words cocoa.messages cocoa.runtime locals
+locals.parser locals.types math namespaces parser sequences
-compiler.units io.encodings.utf8 continuations make fry ;
+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 |
+    method init-method :> ( sel imp types )
-        class sel class_getInstanceMethod [
+
-            imp method_setImplementation drop
+    class sel class_getInstanceMethod [
-        ] [
+        imp method_setImplementation drop
-            class sel imp types add-method
+    ] [
-        ] if*
+        class sel imp types add-method
-    ] call ;
+    ] 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+
+:: define-objc-class ( name superclass protocols methods -- )
-SYMBOL: +protocols+
+    methods prepare-methods :> methods
-SYMBOL: +superclass+
+    name "cocoa.classes" create drop
-
+    methods name redefine-objc-methods
-: define-objc-class ( imeth hash -- )
+    name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
-    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 ;
 
 SYNTAX: CLASS:
-    parse-definition unclip
+    scan-token
-    >hashtable define-objc-class ;
+    "<" 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! ;

basis/functors/backend/backend.factor

@@ -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 ;

basis/io/ports/ports.factor

@@ -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 ]
+    [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
-    [ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ;
+
+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*
     [
         {

basis/locals/parser/parser.factor

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

basis/tools/deploy/shaker/strip-cocoa.factor

@@ -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

basis/tools/deploy/test/14/14.factor

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

basis/ui/backend/cocoa/cocoa.factor

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

basis/ui/backend/cocoa/tools/tools.factor

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

basis/ui/backend/cocoa/views/views.factor

@@ -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
+cocoa.runtime cocoa.types cocoa.windows sequences
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
+io.encodings.utf8 locals ui ui.private ui.gadgets
-core-foundation.strings core-graphics core-graphics.types threads
+ui.gadgets.private ui.gadgets.worlds ui.gestures
-combinators math.rectangles ;
+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 )
+: send-action$ ( view event gesture -- )
-    [ drop window ] dip send-action f ;
+    [ 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: {
+CLASS: FactorView < NSOpenGLView NSTextInput
-    { +superclass+ "NSOpenGLView" }
+[
-    { +name+ "FactorView" }
+    ! Rendering
-    { +protocols+ { "NSTextInput" } }
+    METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ]
-}
 
-! Rendering
+    ! Events
-{ "drawRect:" void { id SEL NSRect }
+    METHOD: char acceptsFirstMouse: id event [ 1 ]
-    [ 2drop window draw-world ]
-}
 
-! Events
+    METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
-{ "acceptsFirstMouse:" char { id SEL id }
-    [ 3drop 1 ]
-}
 
-{ "mouseEntered:" void { id SEL id }
+    METHOD: void mouseExited: id event [ forget-rollover ]
-    [ nip send-mouse-moved ]
-}
 
-{ "mouseExited:" void { id SEL id }
+    METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
-    [ 3drop forget-rollover ]
-}
 
-{ "mouseMoved:" void { id SEL id }
+    METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
-    [ nip send-mouse-moved ]
-}
 
-{ "mouseDragged:" void { id SEL id }
+    METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
-    [ nip send-mouse-moved ]
-}
 
-{ "rightMouseDragged:" void { id SEL id }
+    METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
-    [ nip send-mouse-moved ]
-}
 
-{ "otherMouseDragged:" void { id SEL id }
+    METHOD: void mouseDown: id event [ self event send-button-down$ ]
-    [ nip send-mouse-moved ]
-}
 
-{ "mouseDown:" void { id SEL id }
+    METHOD: void mouseUp: id event [ self event send-button-up$ ]
-    [ nip send-button-down$ ]
-}
 
-{ "mouseUp:" void { id SEL id }
+    METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
-    [ nip send-button-up$ ]
-}
 
-{ "rightMouseDown:" void { id SEL id }
+    METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
-    [ nip send-button-down$ ]
-}
 
-{ "rightMouseUp:" void { id SEL id }
+    METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
-    [ nip send-button-up$ ]
-}
 
-{ "otherMouseDown:" void { id SEL id }
+    METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
-    [ nip send-button-down$ ]
-}
 
-{ "otherMouseUp:" void { id SEL id }
+    METHOD: void scrollWheel: id event [ self event send-scroll$ ]
-    [ nip send-button-up$ ]
-}
 
-{ "scrollWheel:" void { id SEL id }
+    METHOD: void keyDown: id event [ self event send-key-down-event ]
-    [ nip send-scroll$ ]
-}
 
-{ "keyDown:" void { id SEL id }
+    METHOD: void keyUp: id event [ self event send-key-up-event ]
-    [ nip send-key-down-event ]
-}
 
-{ "keyUp:" void { id SEL id }
+    METHOD: char validateUserInterfaceItem: id event
-    [ nip send-key-up-event ]
-}
-
-{ "validateUserInterfaceItem:" char { id SEL id }
     [
-        nip -> action
+        self window [
-        2dup [ window ] [ utf8 alien>string ] bi* validate-action
+            event -> action utf8 alien>string validate-action
-        [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
+            [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
+        ] [ 0 ] if*
     ]
-}
 
-{ "undo:" id { id SEL id }
+    METHOD: id undo: id event [ self event undo-action send-action$ f ]
-    [ nip undo-action send-action$ ]
-}
 
-{ "redo:" id { id SEL id }
+    METHOD: id redo: id event [ self event redo-action send-action$ f ]
-    [ nip redo-action send-action$ ]
-}
 
-{ "cut:" id { id SEL id }
+    METHOD: id cut: id event [ self event cut-action send-action$ f ]
-    [ nip cut-action send-action$ ]
-}
 
-{ "copy:" id { id SEL id }
+    METHOD: id copy: id event [ self event copy-action send-action$ f ]
-    [ nip copy-action send-action$ ]
-}
 
-{ "paste:" id { id SEL id }
+    METHOD: id paste: id event [ self event paste-action send-action$ f ]
-    [ nip paste-action send-action$ ]
-}
 
-{ "delete:" id { id SEL id }
+    METHOD: id delete: id event [ self event delete-action send-action$ f ]
-    [ nip delete-action send-action$ ]
-}
 
-{ "selectAll:" id { id SEL id }
+    METHOD: id selectAll: id event [ self event select-all-action send-action$ f ]
-    [ nip select-all-action send-action$ ]
-}
 
-{ "newDocument:" id { id SEL id }
+    METHOD: id newDocument: id event [ self event new-action send-action$ f ]
-    [ nip new-action send-action$ ]
-}
 
-{ "openDocument:" id { id SEL id }
+    METHOD: id openDocument: id event [ self event open-action send-action$ f ]
-    [ nip open-action send-action$ ]
-}
 
-{ "saveDocument:" id { id SEL id }
+    METHOD: id saveDocument: id event [ self event save-action send-action$ f ]
-    [ nip save-action send-action$ ]
-}
 
-{ "saveDocumentAs:" id { id SEL id }
+    METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ]
-    [ nip save-as-action send-action$ ]
-}
 
-{ "revertDocumentToSaved:" id { id SEL id }
+    METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ]
-    [ nip revert-action send-action$ ]
-}
 
-! Multi-touch gestures: this is undocumented.
+    ! Multi-touch gestures
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+    METHOD: void magnifyWithEvent: id event
-{ "magnifyWithEvent:" void { id SEL id }
     [
-        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 }
+    METHOD: char acceptsFirstResponder [ 1 ]
-    [ 2drop 1 ]
-}
 
-! Services
+    ! Services
-{ "validRequestorForSendType:returnType:" id { id SEL id id }
+    METHOD: id validRequestorForSendType: id sendType returnType: id returnType
     [
         ! We return either self or nil
-        [ over window-focus ] 2dip
+        self window [
-        valid-service? [ drop ] [ 2drop f ] if
+            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? [
+        NSStringPboardType types CF>string-array member? [
-            [ drop window-focus gadget-selection ] dip over
+            self window [
-            [ set-pasteboard-string 1 ] [ 2drop 0 ] if
+                world-focus gadget-selection
-        ] [ 3drop 0 ] if
+                [ pboard set-pasteboard-string 1 ] [ 0 ] if*
+            ] [ 0 ] if*
+        ] [ 0 ] if
     ]
-}
 
-{ "readSelectionFromPasteboard:" char { id SEL id }
+    METHOD: char readSelectionFromPasteboard: id pboard
     [
-        pasteboard-string dup [
+        self window :> window
-            [ drop window ] dip swap user-input 1
+        window [
-        ] [ 3drop 0 ] if
+            pboard pasteboard-string
+            [ window user-input 1 ] [ 0 ] if*
+        ] [ 0 ] if
     ]
-}
 
-! Text input
+    ! Text input
-{ "insertText:" void { id SEL id }
+    METHOD: void insertText: id text
-    [ 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 }
     [
-        [ drop ] 2dip
+        self window :> window
-        SUPER-> initWithFrame:pixelFormat:
+        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 }
+    METHOD: char isOpaque [ 0 ]
-    [
-        2drop 0
-    ]
-}
 
-{ "dealloc" void { id SEL }
+    METHOD: void dealloc
     [
-        drop
+        self remove-observer
-        [ remove-observer ]
+        self SUPER-> dealloc
-        [ SUPER-> dealloc ]
-        bi
     ]
-} ;
+]
 
 : 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: {
+CLASS: FactorWindowDelegate < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "FactorWindowDelegate" }
+    METHOD: void windowDidMove: id notification
-}
-
-{ "windowDidMove:" void { id SEL id }
     [
-        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
+        notification -> object -> contentView :> view
-        dup -> isInFullScreenMode 0 =
+        view window :> window
-        [ window [ unfocus-world ] when* ]
+        window [
-        [ drop ] if
+            view -> isInFullScreenMode 0 =
+            [ window unfocus-world ] when
+        ] when
     ]
-}
 
-{ "windowShouldClose:" char { id SEL id }
+    METHOD: char windowShouldClose: id notification [ 1 ]
-    [
-        3drop 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 ;

basis/ui/ui.factor

@@ -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

basis/urls/encoding/encoding-tests.factor

@@ -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

basis/urls/encoding/encoding.factor

@@ -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-full ] dip
-            [ [ url-encode "=" glue , ] with each ] [ , ] if*
+            [ [ url-encode-full "=" glue , ] with each ] [ , ] if*
         ] assoc-each
     ] { } make "&" join ;

core/classes/tuple/parser/parser.factor

@@ -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
+    ! Check for mistakes of this form:
-    #! to check for mistakes of this form:
+    !
-    #!
+    ! TUPLE: blahblah foo bing
-    #! 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 {
+    scan check-slot-name scan-object 2array , scan-token {
-        { f [ \ } unexpected-eof ] }
         { "}" [ ] }
         [ bad-literal-tuple ]
     } case ;
 
 : (parse-slot-values) ( class slots -- )
     2dup parse-slot-value
-    scan {
+    scan-token {
-        { f [ 2drop \ } unexpected-eof ] }
         { "{" [ (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 {
+    scan-token {
-        { f [ unexpected-eof ] }
         { "f" [ drop \ } parse-until boa>object ] }
         { "{" [ 2dup parse-slot-values assoc>object ] }
         { "}" [ drop new ] }

core/effects/parser/parser.factor

@@ -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 ;

core/io/files/files-tests.factor

@@ -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

core/lexer/authors.txt

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

core/lexer/lexer-docs.factor

@@ -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?

core/lexer/lexer.factor

@@ -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
+    swap >>word
-        lexer get [
+    lexer get [
-            [ line>>      >>line      ]
+        [ line>>      >>line      ]
-            [ line-text>> >>line-text ]
+        [ line-text>> >>line-text ]
-            [ column>>    >>column    ] tri
+        [ column>>    >>column    ] tri
-        ] [ parsing-words>> push ] bi ;
+    ] [ 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
+    scan-token 2dup = [ 2drop ] [ unexpected ] if ;
-    [ 2dup = [ 2drop ] [ unexpected ] if ]
-    [ unexpected-eof ]
-    if* ;
 
 : each-token ( ... end quot: ( ... token -- ... ) -- ... )
-    [ scan ] 2dip {
+    [ scan-token ] 2dip 2over =
-        { [ 2over = ] [ 3drop ] }
+    [ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
-        { [ pick not ] [ drop unexpected-eof ] }
-        [ [ nip call ] [ each-token ] 2bi ]
-    } cond ; 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 [
+    lexer get [
-            [ line>> >>line ]
+        [ line>> >>line ]
-            [ column>> >>column ] bi
+        [ column>> >>column ] bi
-        ] [ 
+    ] [
-            [ line-text>> >>line-text ]
+        [ line-text>> >>line-text ]
-            [ parsing-words>> clone >>parsing-words ] bi
+        [ parsing-words>> clone >>parsing-words ] bi
-        ] bi
+    ] bi
-        swap >>error ;
+    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

core/parser/parser-docs.factor

@@ -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 ;

core/syntax/syntax.factor

@@ -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:" [

vm/objects.hpp

@@ -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 */

vm/os-macosx.mm

@@ -8,23 +8,7 @@ namespace factor
 
 void factor_vm::c_to_factor_toplevel(cell quot)
 {
-	for(;;)
+	c_to_factor(quot);
-	{
-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
-	}
 }
 
 void early_init(void)