Merge branch 'master' of git://factorcode.org/git/factor

core/alien/alien.factor

@@ -65,21 +65,21 @@ TUPLE: library path abi dll ;
 
 TUPLE: alien-callback return parameters abi quot xt ;
 
-TUPLE: alien-callback-error ;
+ERROR: alien-callback-error ;
 
 : alien-callback ( return parameters abi quot -- alien )
-    \ alien-callback-error construct-empty throw ;
+    alien-callback-error ;
 
 TUPLE: alien-indirect return parameters abi ;
 
-TUPLE: alien-indirect-error ;
+ERROR: alien-indirect-error ;
 
 : alien-indirect ( ... funcptr return parameters abi -- )
-    \ alien-indirect-error construct-empty throw ;
+    alien-indirect-error ;
 
 TUPLE: alien-invoke library function return parameters ;
 
-TUPLE: alien-invoke-error library symbol ;
+ERROR: alien-invoke-error library symbol ;
 
 : alien-invoke ( ... return library function parameters -- ... )
-    2over \ alien-invoke-error construct-boa throw ;
+    2over alien-invoke-error ;

core/alien/c-types/c-types.factor

@@ -26,9 +26,7 @@ global [
     c-types [ H{ } assoc-like ] change
 ] bind
 
-TUPLE: no-c-type name ;
+ERROR: no-c-type name ;
-
-: no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
 
 : (c-type) ( name -- type/f )
     c-types get-global at dup [

core/alien/structs/structs-docs.factor

@@ -1,6 +1,65 @@
 IN: alien.structs
 USING: alien.c-types strings help.markup help.syntax
-alien.syntax sequences io arrays ;
+alien.syntax sequences io arrays slots.deprecated
+kernel words slots assocs namespaces ;
+
+! Deprecated code
+: ($spec-reader-values) ( slot-spec class -- element )
+    dup ?word-name swap 2array
+    over slot-spec-name
+    rot slot-spec-type 2array 2array
+    [ { $instance } swap add ] assoc-map ;
+
+: $spec-reader-values ( slot-spec class -- )
+    ($spec-reader-values) $values ;
+
+: $spec-reader-description ( slot-spec class -- )
+    [
+        "Outputs the value stored in the " ,
+        { $snippet } rot slot-spec-name add ,
+        " slot of " ,
+        { $instance } swap add ,
+        " instance." ,
+    ] { } make $description ;
+
+: $spec-reader ( reader slot-specs class -- )
+    >r slot-of-reader r>
+    over [
+        2dup $spec-reader-values
+        2dup $spec-reader-description
+    ] when 2drop ;
+
+GENERIC: slot-specs ( help-type -- specs )
+
+M: word slot-specs "slots" word-prop ;
+
+: $slot-reader ( reader -- )
+    first dup "reading" word-prop [ slot-specs ] keep
+    $spec-reader ;
+
+: $spec-writer-values ( slot-spec class -- )
+    ($spec-reader-values) reverse $values ;
+
+: $spec-writer-description ( slot-spec class -- )
+    [
+        "Stores a new value to the " ,
+        { $snippet } rot slot-spec-name add ,
+        " slot of " ,
+        { $instance } swap add ,
+        " instance." ,
+    ] { } make $description ;
+
+: $spec-writer ( writer slot-specs class -- )
+    >r slot-of-writer r>
+    over [
+        2dup $spec-writer-values
+        2dup $spec-writer-description
+        dup ?word-name 1array $side-effects
+    ] when 2drop ;
+
+: $slot-writer ( reader -- )
+    first dup "writing" word-prop [ slot-specs ] keep
+    $spec-writer ;
 
 M: string slot-specs c-type struct-type-fields ;
 

core/alien/structs/structs.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic hashtables kernel kernel.private math
 namespaces parser sequences strings words libc slots
-alien.c-types cpu.architecture ;
+slots.deprecated alien.c-types cpu.architecture ;
 IN: alien.structs
 
 : align-offset ( offset type -- offset )

core/bootstrap/compiler/compiler.factor

@@ -79,7 +79,7 @@ nl
 "." write flush
 
 {
-    malloc free memcpy
+    malloc calloc free memcpy
 } compile
 
 " done" print flush

core/bootstrap/primitives.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: bootstrap.primitives
 USING: alien arrays byte-arrays generic hashtables
 hashtables.private io kernel math namespaces parser sequences
 strings vectors words quotations assocs layouts classes tuples
 kernel.private vocabs vocabs.loader source-files definitions
-slots classes.union compiler.units bootstrap.image.private
+slots.deprecated classes.union compiler.units
-io.files ;
+bootstrap.image.private io.files ;
+IN: bootstrap.primitives
 
 "Creating primitives and basic runtime structures..." print flush
 
@@ -32,6 +32,9 @@ H{ } clone dictionary set
 H{ } clone changed-words set
 H{ } clone root-cache set
 
+! Vocabulary for slot accessors
+"accessors" create-vocab drop
+
 ! Trivial recompile hook. We don't want to touch the code heap
 ! during stage1 bootstrap, it would just waste time.
 [ drop { } ] recompile-hook set

core/combinators/combinators.factor

@@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors
 hashtables sorting ;
 
-TUPLE: no-cond ;
+ERROR: no-cond ;
-
-: no-cond ( -- * ) \ no-cond construct-empty throw ;
 
 : cond ( assoc -- )
     [ first call ] find nip dup [ second call ] [ no-cond ] if ;
 
-TUPLE: no-case ;
+ERROR: no-case ;
-
-: no-case ( -- * ) \ no-case construct-empty throw ;
 
 : case ( obj assoc -- )
     [ dup array? [ dupd first = ] [ quotation? ] if ] find nip

core/debugger/debugger.factor

@@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
 tuples continuations continuations.private combinators
 generic.math io.streams.duplex classes compiler.units
 generic.standard vocabs threads threads.private init
-kernel.private libc ;
+kernel.private libc io.encodings ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -75,9 +75,7 @@ SYMBOL: error-hook
 : try ( quot -- )
     [ error-hook get call ] recover ;
 
-TUPLE: assert got expect ;
+ERROR: assert got expect ;
-
-: assert ( got expect -- * ) \ assert construct-boa throw ;
 
 : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
 
@@ -86,28 +84,22 @@ TUPLE: assert got expect ;
 : trim-datastacks ( seq1 seq2 -- seq1' seq2' )
     2dup [ length ] 2apply min tuck tail >r tail r> ;
 
-TUPLE: relative-underflow stack ;
+ERROR: relative-underflow stack ;
-
-: relative-underflow ( before after -- * )
-    trim-datastacks nip \ relative-underflow construct-boa throw ;
 
 M: relative-underflow summary
     drop "Too many items removed from data stack" ;
 
-TUPLE: relative-overflow stack ;
+ERROR: relative-overflow stack ;
 
 M: relative-overflow summary
     drop "Superfluous items pushed to data stack" ;
 
-: relative-overflow ( before after -- * )
-    trim-datastacks drop \ relative-overflow construct-boa throw ;
-
 : assert-depth ( quot -- )
     >r datastack r> swap slip >r datastack r>
     2dup [ length ] compare sgn {
-        { -1 [ relative-underflow ] }
+        { -1 [ trim-datastacks nip relative-underflow ] }
         { 0 [ 2drop ] }
-        { 1 [ relative-overflow ] }
+        { 1 [ trim-datastacks drop relative-overflow ] }
     } case ; inline
 
 : expired-error. ( obj -- )
@@ -210,13 +202,13 @@ M: no-method error.
 M: no-math-method summary
     drop "No suitable arithmetic method" ;
 
-M: check-closed summary
+M: stream-closed-twice summary
     drop "Attempt to perform I/O on closed stream" ;
 
 M: check-method summary
     drop "Invalid parameters for create-method" ;
 
-M: check-tuple summary
+M: no-tuple-class summary
     drop "Invalid class for define-constructor" ;
 
 M: no-cond summary
@@ -254,7 +246,7 @@ M: no-compilation-unit error.
 M: no-vocab summary
     drop "Vocabulary does not exist" ;
 
-M: check-ptr summary
+M: bad-ptr summary
     drop "Memory allocation failed" ;
 
 M: double-free summary
@@ -282,6 +274,10 @@ M: thread error-in-thread ( error thread -- )
         ] bind
     ] if ;
 
+M: encode-error summary drop "Character encoding error" ;
+
+M: decode-error summary drop "Character decoding error" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

core/definitions/definitions.factor

@@ -3,10 +3,7 @@
 IN: definitions
 USING: kernel sequences namespaces assocs graphs ;
 
-TUPLE: no-compilation-unit definition ;
+ERROR: no-compilation-unit definition ;
-
-: no-compilation-unit ( definition -- * )
-    \ no-compilation-unit construct-boa throw ;
 
 GENERIC: where ( defspec -- loc )
 

core/generic/math/math.factor

@@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? )
     dup empty? [ [ dip ] curry [ ] like ] unless
     r> append ;
 
-TUPLE: no-math-method left right generic ;
+ERROR: no-math-method left right generic ;
-
-: no-math-method ( left right generic -- * )
-    \ no-math-method construct-boa throw ;
 
 : default-math-method ( generic -- quot )
     [ no-math-method ] curry [ ] like ;

core/generic/standard/standard.factor

@@ -26,10 +26,7 @@ SYMBOL: (dispatch#)
 
 : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
 
-TUPLE: no-method object generic ;
+ERROR: no-method object generic ;
-
-: no-method ( object generic -- * )
-    \ no-method construct-boa throw ;
 
 : error-method ( word --  quot )
     picker swap [ no-method ] curry append ;

core/inference/inference-tests.factor

@@ -514,10 +514,10 @@ DEFER: an-inline-word
 
 { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
 
-TUPLE: custom-error ;
+ERROR: custom-error ;
 
 [ T{ effect f 0 0 t } ] [
-    [ custom-error construct-boa throw ] infer
+    [ custom-error ] infer
 ] unit-test
 
 : funny-throw throw ; inline

core/inference/transforms/transforms.factor

@@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot )
 
 \ get-slots [ [get-slots] ] 1 define-transform
 
-TUPLE: duplicated-slots-error names ;
+ERROR: duplicated-slots-error names ;
 
 M: duplicated-slots-error summary
     drop "Calling set-slots with duplicate slot setters" ;
 
-: duplicated-slots-error ( names -- * )
-    \ duplicated-slots-error construct-boa throw ;
-
 \ set-slots [
     dup all-unique?
     [ <reversed> [get-slots] ] [ duplicated-slots-error ] if

core/io/encodings/encodings.factor

@@ -18,17 +18,13 @@ GENERIC: <decoder> ( stream decoding -- newstream )
 
 TUPLE: decoder stream code cr ;
 
-TUPLE: decode-error ;
+ERROR: decode-error ;
-
-: decode-error ( -- * ) \ decode-error construct-empty throw ;
 
 GENERIC: <encoder> ( stream encoding -- newstream )
 
 TUPLE: encoder stream code ;
 
-TUPLE: encode-error ;
+ERROR: encode-error ;
-
-: encode-error ( -- * ) \ encode-error construct-empty throw ;
 
 ! Decoding
 

core/io/files/files.factor

@@ -48,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
 
 : special-directory? ( name -- ? ) { "." ".." } member? ;
 
-TUPLE: no-parent-directory path ;
+ERROR: no-parent-directory path ;
-
-: no-parent-directory ( path -- * )
-    \ no-parent-directory construct-boa throw ;
 
 : parent-directory ( path -- parent )
     right-trim-separators {

core/io/streams/duplex/duplex.factor

@@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ;
 : <duplex-stream> ( in out -- stream )
     f duplex-stream construct-boa ;
 
-TUPLE: check-closed ;
+ERROR: stream-closed-twice ;
 
 : check-closed ( stream -- )
-    duplex-stream-closed?
+    duplex-stream-closed? [ stream-closed-twice ] when ;
-    [ \ check-closed construct-boa throw ] when ;
 
 : duplex-stream-in+ ( duplex -- stream )
     dup check-closed duplex-stream-in ;

core/libc/libc.factor

@@ -23,20 +23,14 @@ SYMBOL: mallocs
 
 PRIVATE>
 
-TUPLE: check-ptr ;
+ERROR: bad-ptr ;
 
 : check-ptr ( c-ptr -- c-ptr )
-    [ \ check-ptr construct-boa throw ] unless* ;
+    [ bad-ptr ] unless* ;
 
-TUPLE: double-free ;
+ERROR: double-free ;
 
-: double-free ( -- * )
+ERROR: realloc-error ptr size ;
-    \ double-free construct-empty throw ;
-
-TUPLE: realloc-error ptr size ;
-
-: realloc-error ( alien size -- * )
-    \ realloc-error construct-boa throw ;
 
 <PRIVATE
 

core/parser/parser.factor

@@ -98,10 +98,7 @@ M: lexer skip-word ( lexer -- )
 
 : scan ( -- str/f ) lexer get parse-token ;
 
-TUPLE: bad-escape ;
+ERROR: bad-escape ;
-
-: bad-escape ( -- * )
-    \ bad-escape construct-empty throw ;
 
 M: bad-escape summary drop "Bad escape code" ;
 
@@ -215,10 +212,7 @@ SYMBOL: in
 : set-in ( name -- )
     check-vocab-string dup in set create-vocab (use+) ;
 
-TUPLE: unexpected want got ;
+ERROR: unexpected want got ;
-
-: unexpected ( want got -- * )
-    \ unexpected construct-boa throw ;
 
 PREDICATE: unexpected unexpected-eof
     unexpected-got not ;
@@ -294,10 +288,7 @@ M: no-word summary
 : CREATE-METHOD ( -- method )
     scan-word bootstrap-word scan-word create-method-in ;
 
-TUPLE: staging-violation word ;
+ERROR: staging-violation word ;
-
-: staging-violation ( word -- * )
-    \ staging-violation construct-boa throw ;
 
 M: staging-violation summary
     drop
@@ -352,9 +343,7 @@ SYMBOL: lexer-factory
         ] if
     ] if ;
 
-TUPLE: bad-number ;
+ERROR: bad-number ;
-
-: bad-number ( -- * ) \ bad-number construct-boa throw ;
 
 : parse-base ( parsed base -- parsed )
     scan swap base> [ bad-number ] unless* parsed ;

core/sequences/sequences.factor

@@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
 : bounds-check? ( n seq -- ? )
     length 1- 0 swap between? ; inline
 
-TUPLE: bounds-error index seq ;
+ERROR: bounds-error index seq ;
-
-: bounds-error ( n seq -- * )
-    \ bounds-error construct-boa throw ;
 
 : bounds-check ( n seq -- n seq )
     2dup bounds-check? [ bounds-error ] unless ; inline
 
 MIXIN: immutable-sequence
 
-TUPLE: immutable seq ;
+ERROR: immutable seq ;
-
-: immutable ( seq -- * ) \ immutable construct-boa throw ;
 
 M: immutable-sequence set-nth immutable ;
 
@@ -190,8 +185,7 @@ TUPLE: slice from to seq ;
 : collapse-slice ( m n slice -- m' n' seq )
     dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
 
-TUPLE: slice-error reason ;
+ERROR: slice-error reason ;
-: slice-error ( str -- * ) \ slice-error construct-boa throw ;
 
 : check-slice ( from to seq -- from to seq )
     pick 0 < [ "start < 0" slice-error ] when

core/slots/deprecated/deprecated.factor

@@ -0,0 +1,95 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math namespaces
+sequences strings words effects generic generic.standard
+classes slots.private combinators slots ;
+IN: slots.deprecated
+
+: reader-effect ( class spec -- effect )
+    >r ?word-name 1array r> slot-spec-name 1array <effect> ;
+
+PREDICATE: word slot-reader "reading" word-prop >boolean ;
+
+: set-reader-props ( class spec -- )
+    2dup reader-effect
+    over slot-spec-reader
+    swap "declared-effect" set-word-prop
+    slot-spec-reader swap "reading" set-word-prop ;
+
+: define-reader ( class spec -- )
+    dup slot-spec-reader [
+        [ set-reader-props ] 2keep
+        dup slot-spec-offset
+        over slot-spec-reader
+        rot slot-spec-type reader-quot
+        define-slot-word
+    ] [
+        2drop
+    ] if ;
+
+: writer-effect ( class spec -- effect )
+    slot-spec-name swap ?word-name 2array 0 <effect> ;
+
+PREDICATE: word slot-writer "writing" word-prop >boolean ;
+
+: set-writer-props ( class spec -- )
+    2dup writer-effect
+    over slot-spec-writer
+    swap "declared-effect" set-word-prop
+    slot-spec-writer swap "writing" set-word-prop ;
+
+: define-writer ( class spec -- )
+    dup slot-spec-writer [
+        [ set-writer-props ] 2keep
+        dup slot-spec-offset
+        swap slot-spec-writer
+        [ set-slot ]
+        define-slot-word
+    ] [
+        2drop
+    ] if ;
+
+: define-slot ( class spec -- )
+    2dup define-reader define-writer ;
+
+: define-slots ( class specs -- )
+    [ define-slot ] with each ;
+
+: reader-word ( class name vocab -- word )
+    >r >r "-" r> 3append r> create ;
+
+: writer-word ( class name vocab -- word )
+    >r [ swap "set-" % % "-" % % ] "" make r> create ;
+
+: (simple-slot-word) ( class name -- class name vocab )
+    over word-vocabulary >r >r word-name r> r> ;
+
+: simple-reader-word ( class name -- word )
+    (simple-slot-word) reader-word ;
+
+: simple-writer-word ( class name -- word )
+    (simple-slot-word) writer-word ;
+
+: short-slot ( class name # -- spec )
+    >r object bootstrap-word over r> f f <slot-spec>
+    2over simple-reader-word over set-slot-spec-reader
+    -rot simple-writer-word over set-slot-spec-writer ;
+
+: long-slot ( spec # -- spec )
+    >r [ dup array? [ first2 create ] when ] map first4 r>
+    -rot <slot-spec> ;
+
+: simple-slots ( class slots base -- specs )
+    over length [ + ] with map [
+        {
+            { [ over not ] [ 2drop f ] }
+            { [ over string? ] [ >r dupd r> short-slot ] }
+            { [ over array? ] [ long-slot ] }
+        } cond
+    ] 2map [ ] subset nip ;
+
+: slot-of-reader ( reader specs -- spec/f )
+    [ slot-spec-reader eq? ] with find nip ;
+
+: slot-of-writer ( writer specs -- spec/f )
+    [ slot-spec-writer eq? ] with find nip ;

core/slots/slots-docs.factor

@@ -12,15 +12,11 @@ $nl
 "The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
 { $subsection slot-spec }
 "Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."
-{ $subsection slot-spec-reader }
+{ $subsection reader-word }
-{ $subsection slot-spec-writer }
+{ $subsection writer-word }
-"Given a reader or writer word and a class, it is possible to find the slot specifier corresponding to this word:"
+{ $subsection setter-word }
-{ $subsection slot-of-reader }
+{ $subsection changer-word }
-{ $subsection slot-of-writer }
+"Slot methods type check, then call unsafe primitives:"
-"Reader and writer words form classes:"
-{ $subsection slot-reader }
-{ $subsection slot-writer }
-"Slot readers and writers type check, then call unsafe primitives:"
 { $subsection slot }
 { $subsection set-slot } ;
 
@@ -59,17 +55,7 @@ $low-level-note ;
 
 HELP: reader-effect
 { $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
-{ $description "The stack effect of slot reader words is " { $snippet "( obj -- value )" } "." } ;
+{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
-
-HELP: reader-quot
-{ $values { "decl" class } { "quot" "a quotation with stack effect " { $snippet "( obj n -- value )" } } }
-{ $description "Outputs a quotation which reads the " { $snippet "n" } "th slot of an object and declares it as an instance of a class." } ;
-
-HELP: slot-reader
-{ $class-description "The class of slot reader words." }
-{ $examples
-    { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" }
-} ;
 
 HELP: define-reader
 { $values { "class" class } { "spec" slot-spec } }
@@ -80,32 +66,21 @@ HELP: writer-effect
 { $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
 { $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
 
-HELP: slot-writer
-{ $class-description "The class of slot writer words." }
-{ $examples
-    { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" }
-} ;
-
 HELP: define-writer
 { $values { "class" class } { "spec" slot-spec } }
 { $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
 $low-level-note ;
 
-HELP: define-slot
+HELP: define-slot-methods
 { $values { "class" class } { "spec" slot-spec } }
 { $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." }
 $low-level-note ;
 
-HELP: define-slots
+HELP: define-accessors
 { $values { "class" class } { "specs" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Defines a set of slot reader/writer words." }
+{ $description "Defines slot methods." }
 $low-level-note ;
 
-HELP: simple-slots
-{ $values { "class" class } { "slots" "a sequence of strings" } { "base" "a slot number" } { "specs" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." }
-{ $notes "This word is used by " { $link define-tuple-class } " and " { $link POSTPONE: TUPLE: } "." } ;
-
 HELP: slot ( obj m -- value )
 { $values { "obj" object } { "m" "a non-negative fixnum" } { "value" object } }
 { $description "Reads the object stored at the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
@@ -116,18 +91,6 @@ HELP: set-slot ( value obj n -- )
 { $description "Writes " { $snippet "value" } " to the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
 { $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ;
 
-HELP: slot-of-reader
+HELP: slot-named
-{ $values { "reader" slot-reader } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
+{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
-{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-reader } " is equal to " { $snippet "reader" } "." } ;
+{ $description "Outputs the " { $link slot-spec } " with the given name." } ;
-
-HELP: slot-of-writer
-{ $values { "writer" slot-writer } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
-{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-writer } " is equal to " { $snippet "writer" } "." } ;
-
-HELP: reader-word
-{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a word named " { $snippet { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
-
-HELP: writer-word
-{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a word named " { $snippet "set-" { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;

core/slots/slots.factor

@@ -16,9 +16,6 @@ C: <slot-spec> slot-spec
 : define-slot-word ( class slot word quot -- )
     rot >fixnum add* define-typecheck ;
 
-: reader-effect ( class spec -- effect )
-    >r ?word-name 1array r> slot-spec-name 1array <effect> ;
-
 : reader-quot ( decl -- quot )
     [
         \ slot ,
@@ -26,91 +23,62 @@ C: <slot-spec> slot-spec
         [ drop ] [ 1array , \ declare , ] if
     ] [ ] make ;
 
-PREDICATE: word slot-reader "reading" word-prop >boolean ;
-
-: set-reader-props ( class spec -- )
-    2dup reader-effect
-    over slot-spec-reader
-    swap "declared-effect" set-word-prop
-    slot-spec-reader swap "reading" set-word-prop ;
-
-: define-reader ( class spec -- )
-    dup slot-spec-reader [
-        [ set-reader-props ] 2keep
-        dup slot-spec-offset
-        over slot-spec-reader
-        rot slot-spec-type reader-quot
-        define-slot-word
-    ] [
-        2drop
-    ] if ;
-
-: writer-effect ( class spec -- effect )
-    slot-spec-name swap ?word-name 2array 0 <effect> ;
-
-PREDICATE: word slot-writer "writing" word-prop >boolean ;
-
-: set-writer-props ( class spec -- )
-    2dup writer-effect
-    over slot-spec-writer
-    swap "declared-effect" set-word-prop
-    slot-spec-writer swap "writing" set-word-prop ;
-
-: define-writer ( class spec -- )
-    dup slot-spec-writer [
-        [ set-writer-props ] 2keep
-        dup slot-spec-offset
-        swap slot-spec-writer
-        [ set-slot ]
-        define-slot-word
-    ] [
-        2drop
-    ] if ;
-
-: define-slot ( class spec -- )
-    2dup define-reader define-writer ;
-
-: define-slots ( class specs -- )
-    [ define-slot ] with each ;
-
-: reader-word ( class name vocab -- word )
-    >r >r "-" r> 3append r> create ;
-
-: writer-word ( class name vocab -- word )
-    >r [ swap "set-" % % "-" % % ] "" make r> create ;
-
-: (simple-slot-word) ( class name -- class name vocab )
-    over word-vocabulary >r >r word-name r> r> ;
-
-: simple-reader-word ( class name -- word )
-    (simple-slot-word) reader-word ;
-
-: simple-writer-word ( class name -- word )
-    (simple-slot-word) writer-word ;
-
-: short-slot ( class name # -- spec )
-    >r object bootstrap-word over r> f f <slot-spec>
-    2over simple-reader-word over set-slot-spec-reader
-    -rot simple-writer-word over set-slot-spec-writer ;
-
-: long-slot ( spec # -- spec )
-    >r [ dup array? [ first2 create ] when ] map first4 r>
-    -rot <slot-spec> ;
-
-: simple-slots ( class slots base -- specs )
-    over length [ + ] with map [
-        {
-            { [ over not ] [ 2drop f ] }
-            { [ over string? ] [ >r dupd r> short-slot ] }
-            { [ over array? ] [ long-slot ] }
-        } cond
-    ] 2map [ ] subset nip ;
-
-: slot-of-reader ( reader specs -- spec/f )
-    [ slot-spec-reader eq? ] with find nip ;
-
-: slot-of-writer ( writer specs -- spec/f )
-    [ slot-spec-writer eq? ] with find nip ;
-
 : slot-named ( string specs -- spec/f )
     [ slot-spec-name = ] with find nip ;
+
+: create-accessor ( name effect -- word )
+    >r "accessors" create dup r>
+    "declared-effect" set-word-prop ;
+
+: reader-effect T{ effect f { "object" } { "value" } } ; inline
+
+: reader-word ( name -- word )
+    ">>" append reader-effect create-accessor ;
+
+: define-reader ( class slot name -- )
+    reader-word object reader-quot define-slot-word ;
+
+: writer-effect T{ effect f { "value" "object" } { } } ; inline
+
+: writer-word ( name -- word )
+    "(>>" swap ")" 3append writer-effect create-accessor ;
+
+: define-writer ( class slot name -- )
+    writer-word [ set-slot ] define-slot-word ;
+
+: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
+
+: setter-word ( name -- word )
+    ">>" prepend setter-effect create-accessor ;
+
+: define-setter ( name -- )
+    dup setter-word dup deferred? [
+        [ \ over , swap writer-word , ] [ ] make define-inline
+    ] [ 2drop ] if ;
+
+: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
+
+: changer-word ( name -- word )
+    "change-" prepend changer-effect create-accessor ;
+
+: define-changer ( name -- )
+    dup changer-word dup deferred? [
+        [
+            [ over >r >r ] %
+            over reader-word ,
+            [ r> call r> swap ] %
+            swap setter-word ,
+        ] [ ] make define-inline
+    ] [ 2drop ] if ;
+
+: define-slot-methods ( class slot name -- )
+    dup define-changer
+    dup define-setter
+    3dup define-reader
+    define-writer ;
+
+: define-accessors ( class specs -- )
+    [
+        dup slot-spec-offset swap slot-spec-name
+        define-slot-methods
+    ] with each ;

core/syntax/syntax-docs.factor

@@ -560,6 +560,13 @@ HELP: TUPLE:
 $nl
 "Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
 
+HELP: ERROR:
+{ $syntax "ERROR: class slots... ;" }
+{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
+{ $description "Defines a new tuple class.  Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ;
+
+{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words
+
 HELP: C:
 { $syntax "C: constructor class" }
 { $values { "constructor" "a new word to define" } { "class" tuple-class } }

core/syntax/syntax.factor

@@ -165,6 +165,7 @@ IN: bootstrap.syntax
 
     "ERROR:" [
         CREATE-CLASS dup ";" parse-tokens define-tuple-class
+        dup save-location
         dup [ construct-boa throw ] curry define
     ] define-syntax
 

core/tuples/tuples-tests.factor

@@ -236,7 +236,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
 
 [
     "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ check-tuple? ] is? ] must-fail-with
+] [ [ no-tuple-class? ] is? ] must-fail-with
 
 ! Hardcore unit tests
 USE: threads

core/tuples/tuples.factor

@@ -3,7 +3,8 @@
 USING: arrays definitions hashtables kernel
 kernel.private math namespaces sequences sequences.private
 strings vectors words quotations memory combinators generic
-classes classes.private slots slots.private compiler.units ;
+classes classes.private slots slots.deprecated slots.private
+compiler.units ;
 IN: tuples
 
 M: tuple delegate 3 slot ;
@@ -85,13 +86,14 @@ PRIVATE>
     dupd 4 simple-slots
     2dup [ slot-spec-name ] map "slot-names" set-word-prop
     2dup delegate-slot-spec add* "slots" set-word-prop
-    define-slots ;
+    2dup define-slots
+    define-accessors ;
 
-TUPLE: check-tuple class ;
+ERROR: no-tuple-class class ;
 
 : check-tuple ( class -- )
     dup tuple-class?
-    [ drop ] [ \ check-tuple construct-boa throw ] if ;
+    [ drop ] [ no-tuple-class ] if ;
 
 : define-tuple-class ( class slots -- )
     2dup check-shape

core/vocabs/vocabs.factor

@@ -7,8 +7,7 @@ IN: vocabs
 SYMBOL: dictionary
 
 TUPLE: vocab
-name root
+name words
-words
 main help
 source-loaded? docs-loaded? ;
 
@@ -60,16 +59,13 @@ M: f vocab-help ;
 : create-vocab ( name -- vocab )
     dictionary get [ <vocab> ] cache ;
 
-TUPLE: no-vocab name ;
+ERROR: no-vocab name ;
-
-: no-vocab ( name -- * )
-    vocab-name \ no-vocab construct-boa throw ;
 
 SYMBOL: load-vocab-hook ! ( name -- )
 
 : load-vocab ( name -- vocab )
     dup load-vocab-hook get call
-    dup vocab [ ] [ no-vocab ] ?if ;
+    dup vocab [ ] [ vocab-name no-vocab ] ?if ;
 
 : vocabs ( -- seq )
     dictionary get keys natural-sort ;

core/words/words.factor

@@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ;
 
 M: word definition word-def ;
 
-TUPLE: undefined ;
+ERROR: undefined ;
-
-: undefined ( -- * ) \ undefined construct-empty throw ;
 
 PREDICATE: word deferred ( obj -- ? )
     word-def [ undefined ] = ;
@@ -189,12 +187,11 @@ M: word subwords drop f ;
     [ ] [ no-vocab ] ?if
     set-at ;
 
-TUPLE: check-create name vocab ;
+ERROR: bad-create name vocab ;
 
 : check-create ( name vocab -- name vocab )
-    2dup [ string? ] both? [
+    2dup [ string? ] both?
-        \ check-create construct-boa throw
+    [ bad-create ] unless ;
-    ] unless ;
 
 : create ( name vocab -- word )
     check-create 2dup lookup

extra/cairo/lib/lib.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types cairo.ffi continuations destructors
-kernel libc locals math combinators.cleave shuffle new-slots
+kernel libc locals math combinators.cleave shuffle
 accessors ;
 IN: cairo.lib
 

extra/cairo/png/png.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.cleave kernel new-slots
+USING: arrays combinators.cleave kernel
 accessors math ui.gadgets ui.render opengl.gl byte-arrays
 namespaces opengl cairo.ffi cairo.lib ;
 IN: cairo.png

extra/calendar/calendar.factor

@@ -3,7 +3,7 @@
 
 USING: arrays kernel math math.functions namespaces sequences
 strings tuples system vocabs.loader calendar.backend threads
-new-slots accessors combinators locals ;
+accessors combinators locals ;
 IN: calendar
 
 TUPLE: timestamp year month day hour minute second gmt-offset ;

extra/concurrency/distributed/distributed.factor

@@ -3,7 +3,7 @@
 USING: serialize sequences concurrency.messaging
 threads io io.server qualified arrays
 namespaces kernel io.encodings.binary combinators.cleave
-new-slots accessors ;
+accessors ;
 QUALIFIED: io.sockets
 IN: concurrency.distributed
 

extra/db/db.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes continuations kernel math
 namespaces sequences sequences.lib tuples words strings
-tools.walker new-slots accessors ;
+tools.walker accessors ;
 IN: db
 
 TUPLE: db

extra/db/postgresql/lib/lib.factor

@@ -4,7 +4,7 @@ USING: arrays continuations db io kernel math namespaces
 quotations sequences db.postgresql.ffi alien alien.c-types
 db.types tools.walker ascii splitting math.parser
 combinators combinators.cleave libc shuffle calendar.format
-byte-arrays destructors prettyprint new-slots accessors
+byte-arrays destructors prettyprint accessors
 strings serialize io.encodings.binary io.streams.byte-array ;
 IN: db.postgresql.lib
 

extra/digraphs/digraphs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel new-slots sequences vectors ;
+USING: accessors assocs kernel sequences vectors ;
 IN: digraphs
 
 TUPLE: digraph ;

extra/help/help.factor

@@ -25,10 +25,6 @@ GENERIC: word-help* ( word -- content )
 
 M: word word-help* drop f ;
 
-M: slot-reader word-help* drop \ $slot-reader ;
-
-M: slot-writer word-help* drop \ $slot-writer ;
-
 M: predicate word-help* drop \ $predicate ;
 
 : all-articles ( -- seq )

extra/help/markup/markup.factor

@@ -296,63 +296,6 @@ M: string ($instance)
         { $link with-pprint } " combinator."
     } $notes ;
 
-: ($spec-reader-values) ( slot-spec class -- element )
-    dup ?word-name swap 2array
-    over slot-spec-name
-    rot slot-spec-type 2array 2array
-    [ { $instance } swap add ] assoc-map ;
-
-: $spec-reader-values ( slot-spec class -- )
-    ($spec-reader-values) $values ;
-
-: $spec-reader-description ( slot-spec class -- )
-    [
-        "Outputs the value stored in the " ,
-        { $snippet } rot slot-spec-name add ,
-        " slot of " ,
-        { $instance } swap add ,
-        " instance." ,
-    ] { } make $description ;
-
-: $spec-reader ( reader slot-specs class -- )
-    >r slot-of-reader r>
-    over [
-        2dup $spec-reader-values
-        2dup $spec-reader-description
-    ] when 2drop ;
-
-GENERIC: slot-specs ( help-type -- specs )
-
-M: word slot-specs "slots" word-prop ;
-
-: $slot-reader ( reader -- )
-    first dup "reading" word-prop [ slot-specs ] keep
-    $spec-reader ;
-
-: $spec-writer-values ( slot-spec class -- )
-    ($spec-reader-values) reverse $values ;
-
-: $spec-writer-description ( slot-spec class -- )
-    [
-        "Stores a new value to the " ,
-        { $snippet } rot slot-spec-name add ,
-        " slot of " ,
-        { $instance } swap add ,
-        " instance." ,
-    ] { } make $description ;
-
-: $spec-writer ( writer slot-specs class -- )
-    >r slot-of-writer r>
-    over [
-        2dup $spec-writer-values
-        2dup $spec-writer-description
-        dup ?word-name 1array $side-effects
-    ] when 2drop ;
-
-: $slot-writer ( reader -- )
-    first dup "writing" word-prop [ slot-specs ] keep
-    $spec-writer ;
-
 GENERIC: elements* ( elt-type element -- )
 
 M: simple-element elements* [ elements* ] with each ;

extra/http/http.factor

@@ -3,7 +3,7 @@
 USING: fry hashtables io io.streams.string kernel math
 namespaces math.parser assocs sequences strings splitting ascii
 io.encodings.utf8 io.encodings.string namespaces unicode.case
-combinators vectors sorting new-slots accessors calendar
+combinators vectors sorting accessors calendar
 calendar.format quotations arrays combinators.cleave
 combinators.lib byte-arrays ;
 IN: http

extra/http/server/actions/actions.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors new-slots sequences kernel assocs combinators
+USING: accessors sequences kernel assocs combinators
 http.server http.server.validators http hashtables namespaces
 combinators.cleave fry continuations locals ;
 IN: http.server.actions

extra/http/server/auth/basic/basic.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors new-slots quotations assocs kernel splitting
+USING: accessors quotations assocs kernel splitting
 base64 html.elements io combinators http.server
 http.server.auth.providers http.server.auth.providers.null
 http sequences ;

extra/http/server/auth/login/login.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors new-slots quotations assocs kernel splitting
+USING: accessors quotations assocs kernel splitting
 base64 html.elements io combinators http.server
 http.server.auth.providers http.server.auth.providers.null
 http.server.actions http.server.components http.server.sessions

extra/http/server/auth/providers/assoc/assoc.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: http.server.auth.providers.assoc
-USING: new-slots accessors assocs kernel
+USING: accessors assocs kernel
 http.server.auth.providers ;
 
 TUPLE: users-in-memory assoc ;

extra/http/server/auth/providers/db/db.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: db db.tuples db.types new-slots accessors
+USING: db db.tuples db.types accessors
 http.server.auth.providers kernel continuations
 singleton ;
 IN: http.server.auth.providers.db

extra/http/server/auth/providers/providers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel new-slots accessors random math.parser locals
+USING: kernel accessors random math.parser locals
 sequences math crypto.sha2 ;
 IN: http.server.auth.providers
 

extra/http/server/callbacks/callbacks.factor

@@ -2,7 +2,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: html http http.server io kernel math namespaces
-continuations calendar sequences assocs new-slots hashtables
+continuations calendar sequences assocs hashtables
 accessors arrays alarms quotations combinators
 combinators.cleave fry assocs.lib ;
 IN: http.server.callbacks

extra/http/server/components/components-tests.factor

@@ -1,6 +1,6 @@
 IN: http.server.components.tests
 USING: http.server.components http.server.validators
-namespaces tools.test kernel accessors new-slots
+namespaces tools.test kernel accessors
 tuple-syntax mirrors http.server.actions ;
 
 validation-failed? off

extra/http/server/components/components.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: new-slots html.elements http.server.validators accessors
+USING: html.elements http.server.validators accessors
 namespaces kernel io math.parser assocs classes words tuples
 arrays sequences io.files http.server.templating.fhtml
 http.server.actions splitting mirrors hashtables

extra/http/server/db/db.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: db http.server kernel new-slots accessors
+USING: db http.server kernel accessors
 continuations namespaces destructors combinators.cleave ;
 IN: http.server.db
 

extra/http/server/server-tests.factor

@@ -1,5 +1,5 @@
 USING: http.server tools.test kernel namespaces accessors
-new-slots io http math sequences assocs ;
+io http math sequences assocs ;
 IN: http.server.tests
 
 [

extra/http/server/server.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel namespaces io io.timeouts strings splitting
 threads http sequences prettyprint io.server logging calendar
-new-slots html.elements accessors math.parser combinators.lib
+html.elements accessors math.parser combinators.lib
 tools.vocabs debugger html continuations random combinators
 destructors io.encodings.latin1 fry combinators.cleave ;
 IN: http.server

extra/http/server/sessions/sessions.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs calendar kernel math.parser namespaces random
-new-slots accessors http http.server
+accessors http http.server
 http.server.sessions.storage http.server.sessions.storage.assoc
 quotations hashtables sequences fry combinators.cleave
 html.elements symbols continuations destructors ;

extra/http/server/sessions/storage/assoc/assoc.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs assocs.lib new-slots accessors
+USING: assocs assocs.lib accessors
 http.server.sessions.storage combinators.cleave alarms kernel
 fry http.server ;
 IN: http.server.sessions.storage.assoc

extra/http/server/sessions/storage/db/db.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs new-slots accessors http.server.sessions.storage
+USING: assocs accessors http.server.sessions.storage
 alarms kernel http.server db.tuples db.types singleton
 combinators.cleave math.parser ;
 IN: http.server.sessions.storage.db

extra/http/server/static/static.factor

@@ -3,7 +3,7 @@
 USING: calendar html io io.files kernel math math.parser http
 http.server namespaces parser sequences strings assocs
 hashtables debugger http.mime sorting html.elements logging
-calendar.format new-slots accessors io.encodings.binary
+calendar.format accessors io.encodings.binary
 combinators.cleave fry ;
 IN: http.server.static
 

extra/http/server/validators/validators.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel continuations sequences math namespaces
-math.parser assocs new-slots regexp fry unicode.categories
+math.parser assocs regexp fry unicode.categories
 combinators.cleave sequences ;
 IN: http.server.validators
 

extra/io/encodings/utf16/utf16.factor

@@ -18,13 +18,13 @@ TUPLE: utf16 ;
     over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
 
 : double-be ( stream byte -- stream char )
-    over stream-read1 prepend-nums ;
+    over stream-read1 swap append-nums ;
 
 : quad-be ( stream byte -- stream char )
     double-be over stream-read1 [
         dup -2 shift BIN: 110111 number= [
             >r 2 shift r> BIN: 11 bitand bitor
-            over stream-read1 prepend-nums HEX: 10000 +
+            over stream-read1 swap append-nums HEX: 10000 +
         ] [ 2drop dup stream-read1 drop replacement-char ] if
     ] when* ;
 

extra/io/launcher/launcher.factor

@@ -3,7 +3,7 @@
 USING: io io.backend io.timeouts system kernel namespaces
 strings hashtables sequences assocs combinators vocabs.loader
 init threads continuations math io.encodings io.streams.duplex
-io.nonblocking new-slots accessors ;
+io.nonblocking accessors ;
 IN: io.launcher
 
 

extra/io/paths/paths.factor

@@ -1,4 +1,4 @@
-USING: io.files kernel sequences new-slots accessors
+USING: io.files kernel sequences accessors
 dlists arrays sequences.lib ;
 IN: io.paths
 

extra/io/unix/launcher/launcher.factor

@@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend
 io.unix.files io.nonblocking sequences kernel namespaces math
 system alien.c-types debugger continuations arrays assocs
 combinators unix.process strings threads unix
-io.unix.launcher.parser io.encodings.latin1 accessors new-slots ;
+io.unix.launcher.parser io.encodings.latin1 accessors ;
 IN: io.unix.launcher
 
 ! Search unix first

extra/io/windows/launcher/launcher.factor

@@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
 io.streams.duplex windows.types math windows.kernel32 windows
 namespaces io.launcher kernel sequences windows.errors assocs
 splitting system threads init strings combinators
-io.backend new-slots accessors concurrency.flags ;
+io.backend accessors concurrency.flags ;
 IN: io.windows.launcher
 
 TUPLE: CreateProcess-args

extra/io/windows/nt/pipes/pipes.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types arrays destructors io io.windows libc
 windows.types math windows.kernel32 windows namespaces kernel
 sequences windows.errors assocs math.parser system random
-combinators new-slots accessors ;
+combinators accessors ;
 IN: io.windows.nt.pipes
 
 ! This code is based on

extra/locals/locals.factor

@@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
 arrays macros splitting combinators prettyprint.backend
 definitions prettyprint hashtables combinators.lib
 prettyprint.sections sequences.private effects generic
-compiler.units combinators.cleave new-slots accessors ;
+compiler.units combinators.cleave accessors ;
 IN: locals
 
 ! Inspired by

extra/peg/ebnf/ebnf-tests.factor

@@ -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 compiler.units ;
+USING: kernel tools.test peg peg.ebnf ;
 IN: peg.ebnf.tests
 
 { T{ ebnf-non-terminal f "abc" } } [
@@ -109,13 +109,37 @@ IN: peg.ebnf.tests
 ] unit-test
 
 { V{ "a" "b" } } [
-  "foo='a' 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast 
+  "ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast 
 ] unit-test
 
 { V{ 1 "b" } } [
-  "foo=('a')[[ drop 1 ]] 'b'" ebnf>quot with-compilation-unit "ab" foo parse parse-result-ast 
+  "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call 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 
+  "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast 
+] unit-test
+
+{ CHAR: A } [
+  "A" [EBNF foo=[A-Z] EBNF] call parse-result-ast 
+] unit-test
+
+{ CHAR: Z } [
+  "Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast 
+] unit-test
+
+{ f } [
+  "0" [EBNF foo=[A-Z] EBNF] call  
+] unit-test
+
+{ CHAR: 0 } [
+  "0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast 
+] unit-test
+
+{ f } [
+  "A" [EBNF foo=[^A-Z] EBNF] call  
+] unit-test
+
+{ f } [
+  "Z" [EBNF foo=[^A-Z] EBNF] call  
 ] unit-test

extra/peg/ebnf/ebnf.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel parser words arrays strings math.parser sequences 
+USING: kernel compiler.units parser words arrays strings math.parser sequences 
        quotations vectors namespaces math assocs continuations peg
        peg.parsers unicode.categories multiline combinators.lib 
        splitting ;
@@ -9,6 +9,8 @@ IN: peg.ebnf
 TUPLE: ebnf-non-terminal symbol ;
 TUPLE: ebnf-terminal symbol ;
 TUPLE: ebnf-any-character ;
+TUPLE: ebnf-range pattern ;
+TUPLE: ebnf-ensure group ;
 TUPLE: ebnf-ensure-not group ;
 TUPLE: ebnf-choice options ;
 TUPLE: ebnf-sequence elements ;
@@ -22,6 +24,8 @@ TUPLE: ebnf rules ;
 C: <ebnf-non-terminal> ebnf-non-terminal
 C: <ebnf-terminal> ebnf-terminal
 C: <ebnf-any-character> ebnf-any-character
+C: <ebnf-range> ebnf-range
+C: <ebnf-ensure> ebnf-ensure
 C: <ebnf-ensure-not> ebnf-ensure-not
 C: <ebnf-choice> ebnf-choice
 C: <ebnf-sequence> ebnf-sequence
@@ -32,84 +36,6 @@ C: <ebnf-rule> ebnf-rule
 C: <ebnf-action> ebnf-action
 C: <ebnf> ebnf
 
-SYMBOL: parsers
-SYMBOL: non-terminals
-
-: reset-parser-generation ( -- ) 
-  V{ } clone parsers set 
-  H{ } clone non-terminals set ;
-
-: store-parser ( parser -- number )
-  parsers get [ push ] keep length 1- ;
-
-: get-parser ( index -- parser )
-  parsers get nth ;
-  
-: non-terminal-index ( name -- number )
-  dup non-terminals get at [
-    nip
-  ] [
-    f store-parser [ swap non-terminals get set-at ] keep
-  ] if* ;
-
-GENERIC: (generate-parser) ( ast -- id )
-
-: generate-parser ( ast -- id )
-  (generate-parser) ;
-
-M: ebnf-terminal (generate-parser) ( ast -- id )
-  ebnf-terminal-symbol token sp store-parser ;
-
-M: ebnf-non-terminal (generate-parser) ( ast -- id )
-  [
-    ebnf-non-terminal-symbol dup non-terminal-index , 
-    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 
-  ] map choice store-parser ;
-
-M: ebnf-sequence (generate-parser) ( ast -- id )
-  ebnf-sequence-elements [
-    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 ;
-
-M: ebnf-rule (generate-parser) ( ast -- id )
-  dup ebnf-rule-symbol non-terminal-index swap 
-  ebnf-rule-elements generate-parser get-parser ! nt-id body
-  swap [ parsers get set-nth ] keep ;
-
-M: ebnf-action (generate-parser) ( ast -- id )
-  [ 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: ebnf (generate-parser) ( ast -- id )
-  ebnf-rules [
-    generate-parser 
-  ] map peek ;
-
-DEFER: 'rhs'
-
 : syntax ( string -- parser )
   #! Parses the string, ignoring white space, and
   #! does not put the result in the AST.
@@ -149,6 +75,7 @@ DEFER: 'rhs'
       [ dup CHAR: [ = ]
       [ dup CHAR: . = ]
       [ dup CHAR: ! = ]
+      [ dup CHAR: & = ]
       [ dup CHAR: * = ]
       [ dup CHAR: + = ]
       [ dup CHAR: ? = ]
@@ -164,6 +91,14 @@ DEFER: 'rhs'
   #! A parser to match the symbol for any character match.
   [ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
 
+: 'range-parser' ( -- parser )
+  #! Match the syntax for declaring character ranges
+  [
+    [ "[" syntax , "[" token ensure-not , ] seq* hide ,
+    [ CHAR: ] = not ] satisfy repeat1 , 
+    "]" syntax ,
+  ] seq* [ first >string <ebnf-range> ] action ;
+ 
 : 'element' ( -- parser )
   #! An element of a rule. It can be a terminal or a 
   #! non-terminal but must not be followed by a "=". 
@@ -173,6 +108,7 @@ DEFER: 'rhs'
     [ 
       'non-terminal' ,
       'terminal' ,
+      'range-parser' ,
       'any-character' ,
     ] choice* ,
     "=" syntax ensure-not ,
@@ -194,7 +130,6 @@ DEFER: 'choice'
     "*" token sp ensure-not ,
     "+" token sp ensure-not ,
     "?" token sp ensure-not ,
-    "[[" token sp ensure-not ,
   ] seq* hide grouped ; 
 
 : 'repeat0' ( -- parser )
@@ -212,13 +147,6 @@ DEFER: 'choice'
     [ 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
@@ -228,17 +156,37 @@ DEFER: 'choice'
     'group' sp ,
   ] seq* [ first <ebnf-ensure-not> ] action ;
 
-: 'sequence' ( -- parser )
+: 'ensure' ( -- parser )
+  #! Parses the '&' syntax to ensure that 
+  #! something that matches the following elements does
+  #! exist in the parse stream.
+  [
+    "&" syntax ,
+    'group' sp ,
+  ] seq* [ first <ebnf-ensure> ] action ;
+
+: ('sequence') ( -- parser )
   #! A sequence of terminals and non-terminals, including
   #! groupings of those. 
   [ 
     'ensure-not' sp ,
+    'ensure' sp ,
     'element' sp ,
     'group' sp , 
     'repeat0' sp ,
     'repeat1' sp ,
     'optional' sp , 
-    'action' sp , 
+  ] choice* ;  
+
+: 'sequence' ( -- parser )
+  #! A sequence of terminals and non-terminals, including
+  #! groupings of those. 
+  [
+    [ 
+      ('sequence') ,
+      "[[" 'factor-code' "]]" syntax-pack ,
+    ] seq* [ first2 <ebnf-action> ] action ,
+    ('sequence') ,
   ] choice* repeat1 [ 
      dup length 1 = [ first ] [ <ebnf-sequence> ] if
   ] action ;
@@ -258,25 +206,84 @@ DEFER: 'choice'
 : 'ebnf' ( -- parser )
   'rule' sp repeat1 [ <ebnf> ] action ;
 
-: ebnf>quot ( string -- quot )
+GENERIC: (transform) ( ast -- parser )
-  'ebnf' parse [
+
-     parse-result-ast [
+SYMBOL: parser
-         reset-parser-generation
+SYMBOL: main
-         generate-parser drop
+
-         [
+: transform ( ast -- object )
-             non-terminals get
+  H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
-             [
+
-               get-parser [
+M: ebnf (transform) ( ast -- parser )
-                 swap , \ in , \ get , \ create ,
+  ebnf-rules [ (transform) ] map peek ;
-                 1quotation , \ define , 
+  
-               ] [
+M: ebnf-rule (transform) ( ast -- parser )
-                 drop
+  dup ebnf-rule-elements (transform) [
-               ] if*
+    swap ebnf-rule-symbol set
-             ] assoc-each
+  ] keep ;
-         ] [ ] make
+
-     ] with-scope
+M: ebnf-sequence (transform) ( ast -- parser )
-   ] [
+  ebnf-sequence-elements [ (transform) ] map seq ;
-    f
+
-   ] if* ;
+M: ebnf-choice (transform) ( ast -- parser )
+  ebnf-choice-options [ (transform) ] map choice ;
+
+M: ebnf-any-character (transform) ( ast -- parser )
+  drop any-char ;
+
+M: ebnf-range (transform) ( ast -- parser )
+  ebnf-range-pattern range-pattern ;
+
+M: ebnf-ensure (transform) ( ast -- parser )
+  ebnf-ensure-group (transform) ensure ;
+
+M: ebnf-ensure-not (transform) ( ast -- parser )
+  ebnf-ensure-not-group (transform) ensure-not ;
+
+M: ebnf-repeat0 (transform) ( ast -- parser )
+  ebnf-repeat0-group (transform) repeat0 ;
+
+M: ebnf-repeat1 (transform) ( ast -- parser )
+  ebnf-repeat1-group (transform) repeat1 ;
+
+M: ebnf-optional (transform) ( ast -- parser )
+  ebnf-optional-elements (transform) optional ;
+
+M: ebnf-action (transform) ( ast -- parser )
+  [ ebnf-action-parser (transform) ] keep
+  ebnf-action-code string-lines [ parse-lines ] with-compilation-unit action ;
+
+M: ebnf-terminal (transform) ( ast -- parser )
+  ebnf-terminal-symbol token sp ;
+
+M: ebnf-non-terminal (transform) ( ast -- parser )
+  ebnf-non-terminal-symbol  [
+    , parser get , \ at ,  
+  ] [ ] make delay sp ;
+
+: transform-ebnf ( string -- object )
+  'ebnf' parse parse-result-ast transform ;
+
+: check-parse-result ( result -- result )
+  dup [
+    dup parse-result-remaining empty? [
+      [ 
+        "Unable to fully parse EBNF. Left to parse was: " %
+        parse-result-remaining % 
+      ] "" make throw
+    ] unless
+  ] [
+    "Could not parse EBNF" throw
+  ] if ;
+
+: ebnf>quot ( string -- hashtable quot )
+  'ebnf' parse check-parse-result 
+  parse-result-ast transform dup main swap at compile ;
+
+: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
+
+: EBNF: 
+  CREATE-WORD dup 
+  ";EBNF" parse-multiline-string
+  ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing
 
-: <EBNF "EBNF>" parse-multiline-string ebnf>quot call ; parsing

extra/peg/expr/expr-tests.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.expr multiline sequences ;
+IN: peg.expr.tests
+
+{ 5 } [
+  "2+3" eval-expr 
+] unit-test
+
+{ 6 } [
+  "2*3" eval-expr 
+] unit-test
+
+{ 14 } [
+  "2+3*4" eval-expr 
+] unit-test
+
+{ 17 } [
+  "2+3*4+3" eval-expr 
+] unit-test
+
+{ 23 } [
+  "2+3*(4+3)" eval-expr 
+] unit-test

extra/peg/expr/expr.factor

@@ -9,22 +9,21 @@ IN: peg.expr
  #! { operator rhs } in to a tree structure of the correct precedence.
  swap [ first2 swap call ] reduce ;
 
-<EBNF
+EBNF: expr 
+times    = "*" [[ drop [ * ] ]]
+divide   = "/" [[ drop [ / ] ]]
+add      = "+" [[ drop [ + ] ]]
+subtract = "-" [[ drop [ - ] ]]
 
-times    = ("*") [[ drop [ * ] ]]
+digit    = [0-9] [[ digit> ]]
-divide   = ("/") [[ drop [ / ] ]]
+number   = (digit)+ [[ unclip [ swap 10 * + ] reduce ]]
-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>
+;EBNF
 
 : eval-expr ( string -- number )
-  expr parse parse-result-ast ;
+  expr parse-result-ast ;
+

extra/peg/parsers/parsers-docs.factor

@@ -159,3 +159,21 @@ HELP: 'string'
 } { $description
     "Returns a parser that matches an string composed of a \", anything that is not \", and another \"."
 } { $see-also 'integer' } ;
+
+HELP: range-pattern
+{ $values
+    { "pattern" "a string" }
+    { "parser" "a parser" }
+} { $description
+"Returns a parser that matches a single character based on the set "
+"of characters in the pattern string."
+"Any single character in the pattern matches that character. "
+"If the pattern begins with a ^ then the set is negated "
+"(the element matches any character not in the set). Any pair "
+"of characters separated with a dash (-) represents the "
+"range of characters from the first to the second, inclusive."
+{ $examples
+    { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" } 
+    { $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" } 
+}
+}  ;

extra/peg/parsers/parsers.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences strings namespaces math assocs shuffle 
-     vectors arrays combinators.lib memoize math.parser match
+     vectors arrays combinators.lib math.parser match
-     unicode.categories sequences.deep peg peg.private ;
+     unicode.categories sequences.deep peg peg.private 
+     peg.search math.ranges ;
 IN: peg.parsers
 
 TUPLE: just-parser p1 ;
@@ -18,26 +19,26 @@ TUPLE: just-parser p1 ;
 M: just-parser compile ( parser -- quot )
   just-parser-p1 compile just-pattern append ;
 
-MEMO: just ( parser -- parser )
+: just ( parser -- parser )
-  just-parser construct-boa init-parser ;
+  just-parser construct-boa ;
 
-MEMO: 1token ( ch -- parser ) 1string token ;
+: 1token ( ch -- parser ) 1string token ;
 
 <PRIVATE
-MEMO: (list-of) ( items separator repeat1? -- parser )
+: (list-of) ( items separator repeat1? -- parser )
   >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
   [ unclip 1vector swap first append ] action ;
 PRIVATE>
 
-MEMO: list-of ( items separator -- parser )
+: list-of ( items separator -- parser )
   hide f (list-of) ;
 
-MEMO: list-of-many ( items separator -- parser )
+: list-of-many ( items separator -- parser )
   hide t (list-of) ;
 
-MEMO: epsilon ( -- parser ) V{ } token ;
+: epsilon ( -- parser ) V{ } token ;
 
-MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
+: any-char ( -- parser ) [ drop t ] satisfy ;
 
 <PRIVATE
 
@@ -46,10 +47,10 @@ MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
 
 PRIVATE>
 
-MEMO: exactly-n ( parser n -- parser' )
+: exactly-n ( parser n -- parser' )
   swap <repetition> seq ;
 
-MEMO: at-most-n ( parser n -- parser' )
+: at-most-n ( parser n -- parser' )
   dup zero? [
     2drop epsilon
   ] [
@@ -57,29 +58,56 @@ MEMO: at-most-n ( parser n -- parser' )
     -rot 1- at-most-n 2choice
   ] if ;
 
-MEMO: at-least-n ( parser n -- parser' )
+: at-least-n ( parser n -- parser' )
   dupd exactly-n swap repeat0 2seq
   [ flatten-vectors ] action ;
 
-MEMO: from-m-to-n ( parser m n -- parser' )
+: from-m-to-n ( parser m n -- parser' )
   >r [ exactly-n ] 2keep r> swap - at-most-n 2seq
   [ flatten-vectors ] action ;
 
-MEMO: pack ( begin body end -- parser )
+: pack ( begin body end -- parser )
   >r >r hide r> r> hide 3seq [ first ] action ;
 
-MEMO: surrounded-by ( parser begin end -- parser' )
+: surrounded-by ( parser begin end -- parser' )
   [ token ] 2apply swapd pack ;
 
-MEMO: 'digit' ( -- parser )
+: 'digit' ( -- parser )
   [ digit? ] satisfy [ digit> ] action ;
 
-MEMO: 'integer' ( -- parser )
+: 'integer' ( -- parser )
   'digit' repeat1 [ 10 digits>integer ] action ;
 
-MEMO: 'string' ( -- parser )
+: 'string' ( -- parser )
   [
     [ CHAR: " = ] satisfy hide ,
     [ CHAR: " = not ] satisfy repeat0 ,
     [ CHAR: " = ] satisfy hide ,
   ] { } make seq [ first >string ] action ;
+
+: (range-pattern) ( pattern -- string )
+  #! Given a range pattern, produce a string containing
+  #! all characters within that range.
+  [ 
+    any-char , 
+    [ CHAR: - = ] satisfy hide , 
+    any-char , 
+  ] seq* [
+    first2 [a,b] >string    
+  ] action
+  replace ;
+
+: range-pattern ( pattern -- parser )
+  #! 'pattern' is a set of characters describing the
+  #! parser to be produced. Any single character in
+  #! the pattern matches that character. If the pattern
+  #! begins with a ^ then the set is negated (the element
+  #! matches any character not in the set). Any pair of
+  #! characters separated with a dash (-) represents the
+  #! range of characters from the first to the second,
+  #! inclusive.
+  dup first CHAR: ^ = [
+    1 tail (range-pattern) [ member? not ] curry satisfy 
+  ] [
+    (range-pattern) [ member? ] curry satisfy
+  ] if ;

extra/peg/peg-tests.factor

@@ -4,10 +4,6 @@
 USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
 IN: peg.tests
 
-{ 0 1 2 } [
-  0 next-id set-global get-next-id get-next-id get-next-id 
-] unit-test
-
 { f } [
   "endbegin" "begin" token parse
 ] unit-test

extra/peg/peg.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences strings namespaces math assocs shuffle 
-       vectors arrays combinators.lib memoize math.parser match
+       vectors arrays combinators.lib math.parser match
        unicode.categories sequences.lib compiler.units parser
        words ;
 IN: peg
@@ -10,70 +10,14 @@ TUPLE: parse-result remaining ast ;
 
 GENERIC: compile ( parser -- quot )
 
-: (parse) ( state parser -- result )
+: parse ( state parser -- result )
   compile call ;
 
-
-<PRIVATE
-
-SYMBOL: packrat-cache
 SYMBOL: ignore 
-SYMBOL: not-in-cache
-
-: not-in-cache? ( result -- ? )
-  not-in-cache = ;
 
 : <parse-result> ( remaining ast -- parse-result )
   parse-result construct-boa ;
 
-SYMBOL: next-id 
-
-: get-next-id ( -- number )
-  next-id get-global 0 or dup 1+ next-id set-global ;
-
-TUPLE: parser id ;
-
-: init-parser ( parser -- parser )
-  get-next-id parser construct-boa over set-delegate ;
-
-: from ( slice-or-string -- index )
-  dup slice? [ slice-from ] [ drop 0 ] if ;
-
-: get-cached ( input parser -- result )
-  [ from ] dip parser-id packrat-cache get at at* [ 
-    drop not-in-cache 
-  ] unless ;
-
-: put-cached ( result input parser -- )
-  parser-id dup packrat-cache get at [ 
-    nip
-  ] [ 
-    H{ } clone dup >r swap packrat-cache get set-at r>
-  ] if* 
-  [ from ] dip set-at ;
-
-PRIVATE>
-
-: parse ( input parser -- result )
-  packrat-cache get [
-    2dup get-cached dup not-in-cache? [ 
-!      "cache missed: " write over parser-id number>string write " - " write nl ! pick .
-      drop 
-      #! Protect against left recursion blowing the callstack
-      #! by storing a failed parse in the cache.
-      [ f ] dipd  [ put-cached ] 2keep
-      [ (parse) dup ] 2keep put-cached
-    ] [ 
-!      "cache hit: " write over parser-id number>string write " - " write nl ! pick . 
-      2nip
-    ] if
-  ] [
-    (parse)
-  ] if ;
-
-: packrat-parse ( input parser -- result )
-  H{ } clone packrat-cache [ parse ] with-variable ;
-
 <PRIVATE
 
 TUPLE: token-parser symbol ;
@@ -295,17 +239,17 @@ M: delay-parser compile ( parser -- quot )
 
 PRIVATE>
 
-MEMO: token ( string -- parser )
+: token ( string -- parser )
-  token-parser construct-boa init-parser ;      
+  token-parser construct-boa ;      
 
 : satisfy ( quot -- parser )
-  satisfy-parser construct-boa init-parser ;
+  satisfy-parser construct-boa ;
 
-MEMO: range ( min max -- parser )
+: range ( min max -- parser )
-  range-parser construct-boa init-parser ;
+  range-parser construct-boa ;
 
 : seq ( seq -- parser )
-  seq-parser construct-boa init-parser ;
+  seq-parser construct-boa ;
 
 : 2seq ( parser1 parser2 -- parser )
   2array seq ;
@@ -320,7 +264,7 @@ MEMO: range ( min max -- parser )
   { } make seq ; inline 
 
 : choice ( seq -- parser )
-  choice-parser construct-boa init-parser ;
+  choice-parser construct-boa ;
 
 : 2choice ( parser1 parser2 -- parser )
   2array choice ;
@@ -334,32 +278,32 @@ MEMO: range ( min max -- parser )
 : choice* ( quot -- paser )
   { } make choice ; inline 
 
-MEMO: repeat0 ( parser -- parser )
+: repeat0 ( parser -- parser )
-  repeat0-parser construct-boa init-parser ;
+  repeat0-parser construct-boa ;
 
-MEMO: repeat1 ( parser -- parser )
+: repeat1 ( parser -- parser )
-  repeat1-parser construct-boa init-parser ;
+  repeat1-parser construct-boa ;
 
-MEMO: optional ( parser -- parser )
+: optional ( parser -- parser )
-  optional-parser construct-boa init-parser ;
+  optional-parser construct-boa ;
 
-MEMO: ensure ( parser -- parser )
+: ensure ( parser -- parser )
-  ensure-parser construct-boa init-parser ;
+  ensure-parser construct-boa ;
 
-MEMO: ensure-not ( parser -- parser )
+: ensure-not ( parser -- parser )
-  ensure-not-parser construct-boa init-parser ;
+  ensure-not-parser construct-boa ;
 
 : action ( parser quot -- parser )
-  action-parser construct-boa init-parser ;
+  action-parser construct-boa ;
 
-MEMO: sp ( parser -- parser )
+: sp ( parser -- parser )
-  sp-parser construct-boa init-parser ;
+  sp-parser construct-boa ;
 
-MEMO: hide ( parser -- parser )
+: hide ( parser -- parser )
   [ drop ignore ] action ;
 
-MEMO: delay ( quot -- parser )
+: delay ( quot -- parser )
-  delay-parser construct-boa init-parser ;
+  delay-parser construct-boa ;
 
 : PEG:
   (:) [

extra/peg/pl0/pl0-tests.factor

@@ -4,14 +4,6 @@
 USING: kernel tools.test peg peg.pl0 multiline sequences ;
 IN: peg.pl0.tests
 
-{ "abc" } [
-  "abc" ident parse parse-result-ast 
-] unit-test
-
-{ 55 } [
-  "55abc" number parse parse-result-ast 
-] unit-test
-
 { t } [
   <"
 VAR x, squ;
@@ -29,7 +21,7 @@ BEGIN
       x := x + 1;
    END
 END.
-"> program parse parse-result-remaining empty?
+"> pl0 parse-result-remaining empty?
 ] unit-test
 
 { f } [
@@ -95,5 +87,5 @@ BEGIN
   y := 36;
   CALL gcd;
 END.
-  "> program parse parse-result-remaining empty?
+  "> pl0 parse-result-remaining empty?
 ] unit-test

extra/peg/pl0/pl0.factor

@@ -1,31 +1,26 @@
 ! 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 namespaces ;
+peg peg.ebnf peg.parsers memoize namespaces math ;
 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 ,
-  ] choice* repeat1 [ >string ] action ;
 
-MEMO: number ( -- parser )
+EBNF: pl0 
-  CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ;
+block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )?
-
+        ( "VAR" ident ( "," ident )* ";" )?
-<EBNF
+        ( "PROCEDURE" ident ";" ( block ";" )? )* statement 
-program = block "." 
+statement = ( ident ":=" expression | "CALL" ident |
-block = [ "CONST" ident "=" number { "," ident "=" number } ";" ]
+              "BEGIN" statement (";" statement )* "END" |
-        [ "VAR" ident { "," ident } ";" ]
-        { "PROCEDURE" ident ";" [ block ";" ] } statement 
-statement = [ ident ":=" expression | "CALL" ident |
-              "BEGIN" statement {";" statement } "END" |
               "IF" condition "THEN" statement |
-              "WHILE" condition "DO" statement ] 
+              "WHILE" condition "DO" statement )?
 condition = "ODD" expression |
             expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression 
-expression = ["+" | "-"] term {("+" | "-") term } 
+expression = ("+" | "-")? term (("+" | "-") term )* 
-term = factor {("*" | "/") factor } 
+term = factor (("*" | "/") factor )* 
 factor = ident | number | "(" expression ")"
-EBNF>
+ident = (([a-zA-Z])+) [[ >string ]]
+digit = ([0-9]) [[ digit> ]]
+number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
+program = block "."
+;EBNF

extra/random/blum-blum-shub/blum-blum-shub.factor

@@ -1,6 +1,6 @@
 USING: kernel math sequences namespaces
 math.miller-rabin combinators.cleave combinators.lib
-math.functions new-slots accessors random ;
+math.functions accessors random ;
 IN: random.blum-blum-shub
 
 ! TODO: take (log log M) bits instead of 1 bit

extra/random/dummy/dummy.factor

@@ -1,4 +1,4 @@
-USING: kernel random math new-slots accessors  ;
+USING: kernel random math accessors  ;
 IN: random.dummy
 
 TUPLE: random-dummy i ;

extra/random/mersenne-twister/mersenne-twister.factor

@@ -4,7 +4,7 @@
 ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
 
 USING: arrays kernel math namespaces sequences system init
-new-slots accessors math.ranges combinators.cleave random ;
+accessors math.ranges combinators.cleave random ;
 IN: random.mersenne-twister
 
 <PRIVATE

extra/semantic-db/hierarchy/hierarchy.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples hashtables kernel new-slots
+USING: accessors db.tuples hashtables kernel
 semantic-db semantic-db.relations sequences sequences.deep ;
 IN: semantic-db.hierarchy
 

extra/semantic-db/semantic-db.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ;
+USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ;
 IN: semantic-db
 
 TUPLE: node id content ;

extra/serialize/serialize.factor

@@ -11,7 +11,7 @@ io.binary strings classes words sbufs tuples arrays vectors
 byte-arrays bit-arrays quotations hashtables assocs help.syntax
 help.markup float-arrays splitting io.streams.byte-array
 io.encodings.string io.encodings.utf8 io.encodings.binary
-combinators combinators.cleave new-slots accessors locals
+combinators combinators.cleave accessors locals
 prettyprint compiler.units sequences.private tuples.private ;
 IN: serialize
 

extra/smtp/smtp.factor

@@ -4,11 +4,11 @@
 USING: namespaces io io.timeouts kernel logging io.sockets
 sequences combinators sequences.lib splitting assocs strings
 math.parser random system calendar io.encodings.ascii
-calendar.format new-slots accessors ;
+calendar.format accessors ;
 IN: smtp
 
 SYMBOL: smtp-domain
-SYMBOL: smtp-server     "localhost" 25 <inet> smtp-server set-global
+SYMBOL: smtp-server     "localhost" "smtp" <inet> smtp-server set-global
 SYMBOL: read-timeout    1 minutes read-timeout set-global
 SYMBOL: esmtp           t esmtp set-global
 
@@ -25,8 +25,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
 
 : crlf "\r\n" write ;
 
+: command ( string -- ) write crlf flush ;
+
 : helo ( -- )
-    esmtp get "EHLO " "HELO " ? write host-name write crlf ;
+    esmtp get "EHLO " "HELO " ? host-name append command ;
 
 : validate-address ( string -- string' )
     #! Make sure we send funky stuff to the server by accident.
@@ -34,13 +36,13 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
     [ "Bad e-mail address: " prepend throw ] unless ;
 
 : mail-from ( fromaddr -- )
-    "MAIL FROM:<" write validate-address write ">" write crlf ;
+    "MAIL FROM:<" swap validate-address ">" 3append command ;
 
 : rcpt-to ( to -- )
-    "RCPT TO:<" write validate-address write ">" write crlf ;
+    "RCPT TO:<" swap validate-address ">" 3append command ;
 
 : data ( -- )
-    "DATA" write crlf ;
+    "DATA" command ;
 
 : validate-message ( msg -- msg' )
     "." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
@@ -49,10 +51,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
     string-lines
     validate-message
     [ write crlf ] each
-    "." write crlf ;
+    "." command ;
 
 : quit ( -- )
-    "QUIT" write crlf ;
+    "QUIT" command ;
 
 LOG: smtp-response DEBUG
 
@@ -85,7 +87,7 @@ LOG: smtp-response DEBUG
     readln
     dup multiline? [ 3 head process-multiline ] when ;
 
-: get-ok ( -- ) flush receive-response check-response ;
+: get-ok ( -- ) receive-response check-response ;
 
 : validate-header ( string -- string' )
     dup "\r\n" seq-intersect empty?

extra/tools/deploy/shaker/shaker.factor

@@ -19,7 +19,7 @@ QUALIFIED: libc.private
 QUALIFIED: libc.private
 QUALIFIED: listener
 QUALIFIED: prettyprint.config
-QUALIFIED: random.private
+QUALIFIED: random
 QUALIFIED: source-files
 QUALIFIED: threads
 QUALIFIED: vocabs
@@ -108,7 +108,7 @@ IN: tools.deploy.shaker
 
 : stripped-globals ( -- seq )
     [
-        random.private:mt ,
+        random:random-generator ,
 
         {
             bootstrap.stage2:bootstrap-time

extra/tools/vocabs/vocabs.factor

@@ -108,6 +108,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
 : set-vocab-file-contents ( seq vocab name -- )
     dupd vocab-append-path [
         ?resource-path utf8 set-file-lines
+        \ (vocab-file-contents) reset-memoized
     ] [
         "The " swap vocab-name
         " vocabulary was not loaded from the file system"

extra/windows/com/syntax/syntax.factor

@@ -1,6 +1,6 @@
 USING: alien alien.c-types kernel windows.ole32
 combinators.lib parser splitting sequences.lib
-sequences namespaces new-slots combinators.cleave
+sequences namespaces combinators.cleave
 assocs quotations shuffle accessors words macros
 alien.syntax fry ;
 IN: windows.com.syntax