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

core: Rename create to create-word, create-in to create-word-in.

db4
Doug Coleman 2015-06-08 12:38:38 -07:00
parent a4c5a748ad
commit 6e60c811ac
51 changed files with 134 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -39,7 +39,7 @@ M: enum-c-type c-type-setter
[ first define-singleton-class ] each ; [ first define-singleton-class ] each ;
: define-enum-constructor ( word -- ) : define-enum-constructor ( word -- )
[ name>> "<" ">" surround create-in ] keep [ name>> "<" ">" surround create-word-in ] keep
[ number>enum ] curry ( number -- enum ) define-inline ; [ number>enum ] curry ( number -- enum ) define-inline ;
PRIVATE> PRIVATE>

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

@ -41,7 +41,7 @@ ERROR: bad-array-type ;
{ [ dup "{" = ] [ drop \ } parse-until >array ] } { [ dup "{" = ] [ drop \ } parse-until >array ] }
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] } { [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
[ parse-c-type ] [ parse-c-type ]
} cond ; } cond ;
: reset-c-type ( word -- ) : reset-c-type ( word -- )
dup "struct-size" word-prop dup "struct-size" word-prop
@ -59,7 +59,7 @@ ERROR: *-in-c-type-name name ;
[ *-in-c-type-name ] when ; [ *-in-c-type-name ] when ;
: (CREATE-C-TYPE) ( word -- word ) : (CREATE-C-TYPE) ( word -- word )
validate-c-type-name current-vocab create { validate-c-type-name current-vocab create-word {
[ fake-definition ] [ fake-definition ]
[ set-last-word ] [ set-last-word ]
[ reset-c-type ] [ reset-c-type ]
@ -133,7 +133,7 @@ PRIVATE>
[ { } ] [ return-type-name 1array ] if-void <effect> ; [ { } ] [ return-type-name 1array ] if-void <effect> ;
: create-function ( name -- word ) : create-function ( name -- word )
create-in dup reset-generic ; create-word-in dup reset-generic ;
:: (make-function) ( return function library types names -- quot effect ) :: (make-function) ( return function library types names -- quot effect )
return library function types function-quot return library function types function-quot
@ -150,7 +150,7 @@ PRIVATE>
'[ [ _ _ _ ] dip alien-callback ] ; '[ [ _ _ _ ] dip alien-callback ] ;
:: make-callback-type ( lib return type-name types names -- word quot effect ) :: make-callback-type ( lib return type-name types names -- word quot effect )
type-name current-vocab create :> type-word type-name current-vocab create-word :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef void* type-word typedef
type-word names return function-effect "callback-effect" set-word-prop type-word names return function-effect "callback-effect" set-word-prop
@ -185,7 +185,7 @@ PREDICATE: alien-callback-type-word < typedef-word
[ nip ] [ global-quot ] 2bi ( -- value ) define-declared ; [ nip ] [ global-quot ] 2bi ( -- value ) define-declared ;
: define-global-setter ( type word -- ) : define-global-setter ( type word -- )
[ nip name>> "set-" prepend create-in ] [ nip name>> "set-" prepend create-word-in ]
[ set-global-quot ] 2bi ( obj -- ) define-declared ; [ set-global-quot ] 2bi ( obj -- ) define-declared ;
: define-global ( type word -- ) : define-global ( type word -- )

2
basis/cocoa/messages/messages.factor
View File

@ -246,7 +246,7 @@ ERROR: no-objc-type name ;
: define-objc-class-word ( quot name -- ) : define-objc-class-word ( quot name -- )
[ class-init-hooks get set-at ] [ class-init-hooks get set-at ]
[ [
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi [ "cocoa.classes" create-word ] [ '[ _ objc-class ] ] bi
( -- class ) define-declared ( -- class ) define-declared
] bi ; ] bi ;

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

@ -64,7 +64,7 @@ IN: cocoa.subclassing
:: define-objc-class ( name superclass protocols methods -- ) :: define-objc-class ( name superclass protocols methods -- )
methods prepare-methods :> methods methods prepare-methods :> methods
name "cocoa.classes" create drop name "cocoa.classes" create-word drop
methods name redefine-objc-methods methods name redefine-objc-methods
name [ methods protocols superclass name (define-objc-class) ] import-objc-class ; name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;

2
basis/compiler/cfg/hats/hats.factor
View File

@ -11,7 +11,7 @@ IN: compiler.cfg.hats
<PRIVATE <PRIVATE
: hat-name ( insn -- word ) : hat-name ( insn -- word )
name>> "##" ?head drop "^^" prepend create-in ; name>> "##" ?head drop "^^" prepend create-word-in ;
: hat-quot ( insn -- quot ) : hat-quot ( insn -- quot )
[ [

2
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -75,7 +75,7 @@ TUPLE: insn-slot-spec type name rep ;
name>> "," append ; name>> "," append ;
: define-insn-ctor ( class specs -- ) : define-insn-ctor ( class specs -- )
[ [ insn-ctor-name create-in ] [ '[ _ ] [ f ] [ boa , ] surround ] bi ] dip [ [ insn-ctor-name create-word-in ] [ '[ _ ] [ f ] [ boa , ] surround ] bi ] dip
[ name>> ] map { } <effect> define-declared ; [ name>> ] map { } <effect> define-declared ;
: define-insn ( class superclass specs -- ) : define-insn ( class superclass specs -- )

2
basis/cpu/x86/assembler/syntax/syntax.factor
View File

@ -9,7 +9,7 @@ SYMBOL: registers
registers [ H{ } clone ] initialize registers [ H{ } clone ] initialize
: define-register ( name num size -- word ) : define-register ( name num size -- word )
[ create-in ] 2dip { [ create-word-in ] 2dip {
[ 2drop ] [ 2drop ]
[ 2drop define-symbol ] [ 2drop define-symbol ]
[ drop "register" set-word-prop ] [ drop "register" set-word-prop ]

6
basis/functors/functors.factor
View File

@ -129,11 +129,11 @@ PRIVATE>
SYNTAX: IS [ parse-word ] (INTERPOLATE) ; SYNTAX: IS [ parse-word ] (INTERPOLATE) ;
SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ; SYNTAX: DEFERS [ current-vocab create-word ] (INTERPOLATE) ;
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ; SYNTAX: DEFINES [ create-word-in ] (INTERPOLATE) ;
SYNTAX: DEFINES-PRIVATE [ begin-private create-in end-private ] (INTERPOLATE) ; SYNTAX: DEFINES-PRIVATE [ begin-private create-word-in end-private ] (INTERPOLATE) ;
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;

2
basis/gobject-introspection/ffi/ffi.factor
View File

@ -12,7 +12,7 @@ IN: gobject-introspection.ffi
: defer-c-type ( c-type-name -- c-type ) : defer-c-type ( c-type-name -- c-type )
deferred-type swap (CREATE-C-TYPE) [ typedef ] keep ; deferred-type swap (CREATE-C-TYPE) [ typedef ] keep ;
! create-in dup ! create-word-in dup
! [ fake-definition ] [ undefined-def define ] bi ; ! [ fake-definition ] [ undefined-def define ] bi ;
:: defer-types ( types type-info-class -- ) :: defer-types ( types type-info-class -- )

2
basis/gobject-introspection/standard-types/standard-types.factor
View File

@ -38,7 +38,7 @@ int lookup-c-type clone
[ >c-bool ] >>unboxer-quot [ >c-bool ] >>unboxer-quot
[ c-bool> ] >>boxer-quot [ c-bool> ] >>boxer-quot
object >>boxed-class object >>boxed-class
"gboolean" create-in typedef "gboolean" create-word-in typedef
STRUCT: longdouble { data char[10] } ; STRUCT: longdouble { data char[10] } ;
>> >>

2
basis/gobject-introspection/types/types.factor
View File

@ -108,5 +108,5 @@ void* lookup-c-type clone
[ drop deferred-type-error ] >>unboxer-quot [ drop deferred-type-error ] >>unboxer-quot
[ drop deferred-type-error ] >>boxer-quot [ drop deferred-type-error ] >>boxer-quot
object >>boxed-class object >>boxed-class
"deferred-type" create-in typedef "deferred-type" create-word-in typedef
>> >>

2
basis/io/encodings/8-bit/8-bit.factor
View File

@ -41,7 +41,7 @@ M: 8-bit-encoding <decoder>
8-bit-encodings get-global at <decoder> ; 8-bit-encodings get-global at <decoder> ;
: create-encoding ( name -- word ) : create-encoding ( name -- word )
create-in create-word-in
[ define-singleton-class ] [ define-singleton-class ]
[ 8-bit-encoding add-mixin-instance ] [ 8-bit-encoding add-mixin-instance ]
[ ] tri ; [ ] tri ;

2
basis/match/match.factor
View File

@ -9,7 +9,7 @@ IN: match
SYMBOL: _ SYMBOL: _
: define-match-var ( name -- ) : define-match-var ( name -- )
create-in create-word-in
dup t "match-var" set-word-prop dup t "match-var" set-word-prop
dup [ get ] curry ( -- value ) define-declared ; dup [ get ] curry ( -- value ) define-declared ;

2
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -84,7 +84,7 @@ M: word integer-op-input-classes
] [ ] make ; ] [ ] make ;
: integer-op-word ( triple -- word ) : integer-op-word ( triple -- word )
[ name>> ] map "-" join "math.partial-dispatch" create ; [ name>> ] map "-" join "math.partial-dispatch" create-word ;
: integer-op-quot ( fix-word big-word triple -- quot ) : integer-op-quot ( fix-word big-word triple -- quot )
[ second ] [ third ] bi 2array { [ second ] [ third ] bi 2array {

2
basis/math/vectors/simd/cords/cords.factor
View File

@ -76,7 +76,7 @@ SYNTAX: A{ \ } [ >A ] parse-literal ;
: define-simd-128-cord ( A/2 T -- ) : define-simd-128-cord ( A/2 T -- )
[ define-specialized-cord ] [ define-specialized-cord ]
[ create-in (define-simd-128-cord) ] 2bi ; [ create-word-in (define-simd-128-cord) ] 2bi ;
SYNTAX: SIMD-128-CORD: SYNTAX: SIMD-128-CORD:
scan-word scan-token define-simd-128-cord ; scan-word scan-token define-simd-128-cord ;

2
basis/openssl/libssl/libssl.factor
View File

@ -445,7 +445,7 @@ H{ } clone verify-messages set-global
: verify-message ( n -- word ) verify-messages get-global at ; : verify-message ( n -- word ) verify-messages get-global at ;
SYNTAX: X509_V_: SYNTAX: X509_V_:
scan-token "X509_V_" prepend create-in scan-token "X509_V_" prepend create-word-in
scan-number scan-number
[ 1quotation ( -- value ) define-inline ] [ 1quotation ( -- value ) define-inline ]
[ verify-messages get set-at ] [ verify-messages get set-at ]

2
basis/roman/roman.factor
View File

@ -57,7 +57,7 @@ PRIVATE>
<< <<
SYNTAX: ROMAN-OP: SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep scan-word [ name>> "roman" prepend create-word-in ] keep
1quotation '[ _ binary-roman-op ] 1quotation '[ _ binary-roman-op ]
scan-effect define-declared ; scan-effect define-declared ;

2
basis/tools/test/test.factor
View File

@ -106,7 +106,7 @@ MACRO: <experiment> ( word -- )
SYNTAX: TEST: SYNTAX: TEST:
scan-token scan-token
[ create-in ] [ create-word-in ]
[ "(" ")" surround search '[ _ parse-test ] ] bi [ "(" ")" surround search '[ _ parse-test ] ] bi
define-syntax ; define-syntax ;

2
basis/tr/tr.factor
View File

@ -25,7 +25,7 @@ M: bad-tr summary
{ { byte-array } { string } } set-specializer ; { { byte-array } { string } } set-specializer ;
: create-tr ( token -- word ) : create-tr ( token -- word )
create-in dup tr-hints ; create-word-in dup tr-hints ;
: tr-quot ( mapping -- quot ) : tr-quot ( mapping -- quot )
'[ [ dup ascii? [ _ tr-nth ] when ] map ] ; '[ [ dup ascii? [ _ tr-nth ] when ] map ] ;

2
basis/ui/pixel-formats/pixel-formats-docs.factor
View File

@ -5,7 +5,7 @@ IN: ui.pixel-formats
! break circular dependency ! break circular dependency
<< <<
"ui.gadgets.worlds" create-vocab drop "ui.gadgets.worlds" create-vocab drop
"world" "ui.gadgets.worlds" create drop "world" "ui.gadgets.worlds" create-word drop
"ui.gadgets.worlds" vocab-words-assoc use-words "ui.gadgets.worlds" vocab-words-assoc use-words
>> >>

6
basis/unicode/breaks/breaks.factor
View File

@ -97,7 +97,7 @@ SYMBOL: table
graphemes iota { SpacingMark } connect graphemes iota { SpacingMark } connect
{ Prepend } graphemes iota connect ; { Prepend } graphemes iota connect ;
"grapheme-table" create-in "grapheme-table" create-word-in
graphemes init-table table graphemes init-table table
[ make-grapheme-table finish-table ] with-variable [ make-grapheme-table finish-table ] with-variable
define-constant define-constant
@ -164,7 +164,7 @@ CONSTANT: word-break-classes H{
{ "ExtendNumLet" 12 } { "ExtendNumLet" 12 }
} }
"word-break-table" create-in "word-break-table" create-word-in
"vocab:unicode/data/WordBreakProperty.txt" "vocab:unicode/data/WordBreakProperty.txt"
load-interval-file dup array>> load-interval-file dup array>>
[ 2 swap [ word-break-classes at ] change-nth ] each [ 2 swap [ word-break-classes at ] change-nth ] each
@ -198,7 +198,7 @@ SYMBOL: check-number-after
[ { { 0 [ f ] } { 1 [ t ] } [ ] } case ] map [ { { 0 [ f ] } { 1 [ t ] } [ ] } case ] map
] map ; ] map ;
"word-table" create-in "word-table" create-word-in
unicode-words init-table table unicode-words init-table table
[ make-word-table finish-word-table ] with-variable [ make-word-table finish-word-table ] with-variable
define-constant define-constant

2
basis/unicode/script/script.factor
View File

@ -7,7 +7,7 @@ IN: unicode.script
<PRIVATE <PRIVATE
<< <<
"script-table" create-in "script-table" create-word-in
"vocab:unicode/script/Scripts.txt" load-interval-file "vocab:unicode/script/Scripts.txt" load-interval-file
define-constant define-constant
>> >>

4
basis/windows/com/syntax/syntax.factor
View File

@ -53,11 +53,11 @@ ERROR: no-com-interface interface ;
V{ } clone [ (parse-com-functions) ] keep >array ; V{ } clone [ (parse-com-functions) ] keep >array ;
: (iid-word) ( definition -- word ) : (iid-word) ( definition -- word )
word>> name>> "-iid" append create-in ; word>> name>> "-iid" append create-word-in ;
: (function-word) ( function interface -- word ) : (function-word) ( function interface -- word )
swap [ word>> name>> "::" ] [ name>> ] bi* swap [ word>> name>> "::" ] [ name>> ] bi*
3append create-in ; 3append create-word-in ;
: family-tree ( definition -- definitions ) : family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if* dup parent>> [ family-tree ] [ { } ] if*

2
basis/xmode/tokens/tokens.factor
View File

@ -13,7 +13,7 @@ SYMBOL: tokens
"KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3"
"LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL"
} [ } [
dup create-in dup define-symbol dup create-word-in dup define-symbol
] H{ } map>assoc tokens set-global ] H{ } map>assoc tokens set-global
>> >>

90
core/bootstrap/primitives.factor
View File

@ -52,7 +52,7 @@ num-types get f <array> builtins set
call( -- ) ! syntax-quot call( -- ) ! syntax-quot
! Create some empty vocabs where the below primitives and ! create-word some empty vocabs where the below primitives and
! classes will go ! classes will go
{ {
"alien" "alien"
@ -118,7 +118,7 @@ call( -- ) ! syntax-quot
tri ; tri ;
: prepare-slots ( slots -- slots' ) : prepare-slots ( slots -- slots' )
[ [ dup pair? [ first2 create ] when ] map ] map ; [ [ dup pair? [ first2 create-word ] when ] map ] map ;
: define-builtin-slots ( class slots -- ) : define-builtin-slots ( class slots -- )
prepare-slots make-slots 1 finalize-slots prepare-slots make-slots 1 finalize-slots
@ -130,38 +130,38 @@ call( -- ) ! syntax-quot
: define-builtin ( symbol slotspec -- ) : define-builtin ( symbol slotspec -- )
[ [ define-builtin-predicate ] keep ] dip define-builtin-slots ; [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
"fixnum" "math" create register-builtin "fixnum" "math" create-word register-builtin
"bignum" "math" create register-builtin "bignum" "math" create-word register-builtin
"tuple" "kernel" create register-builtin "tuple" "kernel" create-word register-builtin
"float" "math" create register-builtin "float" "math" create-word register-builtin
"f" "syntax" lookup-word register-builtin "f" "syntax" lookup-word register-builtin
"array" "arrays" create register-builtin "array" "arrays" create-word register-builtin
"wrapper" "kernel" create register-builtin "wrapper" "kernel" create-word register-builtin
"callstack" "kernel" create register-builtin "callstack" "kernel" create-word register-builtin
"string" "strings" create register-builtin "string" "strings" create-word register-builtin
"quotation" "quotations" create register-builtin "quotation" "quotations" create-word register-builtin
"dll" "alien" create register-builtin "dll" "alien" create-word register-builtin
"alien" "alien" create register-builtin "alien" "alien" create-word register-builtin
"word" "words" create register-builtin "word" "words" create-word register-builtin
"byte-array" "byte-arrays" create register-builtin "byte-array" "byte-arrays" create-word register-builtin
! We need this before defining c-ptr below ! We need this before defining c-ptr below
"f" "syntax" lookup-word { } define-builtin "f" "syntax" lookup-word { } define-builtin
"f" "syntax" create [ not ] "predicate" set-word-prop "f" "syntax" create-word [ not ] "predicate" set-word-prop
"f?" "syntax" vocab-words-assoc delete-at "f?" "syntax" vocab-words-assoc delete-at
"t" "syntax" lookup-word define-singleton-class "t" "syntax" lookup-word define-singleton-class
! Some unions ! Some unions
"c-ptr" "alien" create [ "c-ptr" "alien" create-word [
"alien" "alien" lookup-word , "alien" "alien" lookup-word ,
"f" "syntax" lookup-word , "f" "syntax" lookup-word ,
"byte-array" "byte-arrays" lookup-word , "byte-array" "byte-arrays" lookup-word ,
] { } make define-union-class ] { } make define-union-class
! A predicate class used for declarations ! A predicate class used for declarations
"array-capacity" "sequences.private" create "array-capacity" "sequences.private" create-word
"fixnum" "math" lookup-word "fixnum" "math" lookup-word
[ [
[ dup 0 fixnum>= ] % [ dup 0 fixnum>= ] %
@ -175,7 +175,7 @@ define-predicate-class
"coercer" set-word-prop "coercer" set-word-prop
! Catch-all class for providing a default method. ! Catch-all class for providing a default method.
"object" "kernel" create "object" "kernel" create-word
[ f f { } intersection-class define-class ] [ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ] [ [ drop t ] "predicate" set-word-prop ]
bi bi
@ -183,51 +183,51 @@ bi
"object?" "kernel" vocab-words-assoc delete-at "object?" "kernel" vocab-words-assoc delete-at
! Empty class with no instances ! Empty class with no instances
"null" "kernel" create "null" "kernel" create-word
[ f { } f union-class define-class ] [ f { } f union-class define-class ]
[ [ drop f ] "predicate" set-word-prop ] [ [ drop f ] "predicate" set-word-prop ]
bi bi
"null?" "kernel" vocab-words-assoc delete-at "null?" "kernel" vocab-words-assoc delete-at
"fixnum" "math" create { } define-builtin "fixnum" "math" create-word { } define-builtin
"fixnum" "math" create "integer>fixnum-strict" "math" create 1quotation "coercer" set-word-prop "fixnum" "math" create-word "integer>fixnum-strict" "math" create-word 1quotation "coercer" set-word-prop
"bignum" "math" create { } define-builtin "bignum" "math" create-word { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop "bignum" "math" create-word ">bignum" "math" create-word 1quotation "coercer" set-word-prop
"float" "math" create { } define-builtin "float" "math" create-word { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop "float" "math" create-word ">float" "math" create-word 1quotation "coercer" set-word-prop
"array" "arrays" create { "array" "arrays" create-word {
{ "length" { "array-capacity" "sequences.private" } read-only } { "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin } define-builtin
"wrapper" "kernel" create { "wrapper" "kernel" create-word {
{ "wrapped" read-only } { "wrapped" read-only }
} define-builtin } define-builtin
"string" "strings" create { "string" "strings" create-word {
{ "length" { "array-capacity" "sequences.private" } read-only } { "length" { "array-capacity" "sequences.private" } read-only }
"aux" "aux"
} define-builtin } define-builtin
"quotation" "quotations" create { "quotation" "quotations" create-word {
{ "array" { "array" "arrays" } read-only } { "array" { "array" "arrays" } read-only }
"cached-effect" "cached-effect"
"cache-counter" "cache-counter"
} define-builtin } define-builtin
"dll" "alien" create { "dll" "alien" create-word {
{ "path" { "byte-array" "byte-arrays" } read-only } { "path" { "byte-array" "byte-arrays" } read-only }
} define-builtin } define-builtin
"alien" "alien" create { "alien" "alien" create-word {
{ "underlying" { "c-ptr" "alien" } read-only } { "underlying" { "c-ptr" "alien" } read-only }
"expired" "expired"
} define-builtin } define-builtin
"word" "words" create { "word" "words" create-word {
{ "hashcode" { "fixnum" "math" } } { "hashcode" { "fixnum" "math" } }
"name" "name"
"vocabulary" "vocabulary"
@ -238,32 +238,32 @@ bi
{ "sub-primitive" read-only } { "sub-primitive" read-only }
} define-builtin } define-builtin
"byte-array" "byte-arrays" create { "byte-array" "byte-arrays" create-word {
{ "length" { "array-capacity" "sequences.private" } read-only } { "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin } define-builtin
"callstack" "kernel" create { } define-builtin "callstack" "kernel" create-word { } define-builtin
"tuple" "kernel" create "tuple" "kernel" create-word
[ { } define-builtin ] [ { } define-builtin ]
[ define-tuple-layout ] [ define-tuple-layout ]
bi bi
! Create special tombstone values ! create-word special tombstone values
"tombstone" "hashtables.private" create "tombstone" "hashtables.private" create-word
tuple tuple
{ "state" } define-tuple-class { "state" } define-tuple-class
"((empty))" "hashtables.private" create "((empty))" "hashtables.private" create-word
{ f } "tombstone" "hashtables.private" lookup-word { f } "tombstone" "hashtables.private" lookup-word
slots>tuple 1quotation ( -- value ) define-inline slots>tuple 1quotation ( -- value ) define-inline
"((tombstone))" "hashtables.private" create "((tombstone))" "hashtables.private" create-word
{ t } "tombstone" "hashtables.private" lookup-word { t } "tombstone" "hashtables.private" lookup-word
slots>tuple 1quotation ( -- value ) define-inline slots>tuple 1quotation ( -- value ) define-inline
! Some tuple classes ! Some tuple classes
"curry" "kernel" create "curry" "kernel" create-word
tuple tuple
{ {
{ "obj" read-only } { "obj" read-only }
@ -285,7 +285,7 @@ tuple
} cleave } cleave
( obj quot -- curry ) define-declared ( obj quot -- curry ) define-declared
"compose" "kernel" create "compose" "kernel" create-word
tuple tuple
{ {
{ "first" read-only } { "first" read-only }
@ -311,7 +311,7 @@ tuple
! Sub-primitive words ! Sub-primitive words
: make-sub-primitive ( word vocab effect -- ) : make-sub-primitive ( word vocab effect -- )
[ [
create create-word
dup t "primitive" set-word-prop dup t "primitive" set-word-prop
dup 1quotation dup 1quotation
] dip define-declared ; ] dip define-declared ;
@ -385,7 +385,7 @@ tuple
: make-primitive ( word vocab function effect -- ) : make-primitive ( word vocab function effect -- )
[ [
[ [
create create-word
dup reset-word dup reset-word
dup t "primitive" set-word-prop dup t "primitive" set-word-prop
] dip ] dip
@ -558,6 +558,6 @@ tuple
} [ first4 make-primitive ] each } [ first4 make-primitive ] each
! Bump build number ! Bump build number
"build" "kernel" create build 1 + [ ] curry ( -- n ) define-declared "build" "kernel" create-word build 1 + [ ] curry ( -- n ) define-declared
] with-compilation-unit ] with-compilation-unit

2
core/bootstrap/syntax.factor
View File

@ -96,7 +96,7 @@ IN: bootstrap.syntax
"<<<<<<<" "<<<<<<<"
"=======" "======="
">>>>>>>" ">>>>>>>"
} [ "syntax" create drop ] each } [ "syntax" create-word drop ] each
"t" "syntax" lookup-word define-symbol "t" "syntax" lookup-word define-symbol
] with-compilation-unit ] with-compilation-unit

2
core/classes/classes.factor
View File

@ -73,7 +73,7 @@ PRIVATE>
PREDICATE: predicate < word "predicating" word-prop >boolean ; PREDICATE: predicate < word "predicating" word-prop >boolean ;
: create-predicate-word ( word -- predicate ) : create-predicate-word ( word -- predicate )
[ name>> "?" append ] [ vocabulary>> ] bi create [ name>> "?" append ] [ vocabulary>> ] bi create-word
dup predicate? [ dup reset-generic ] unless ; dup predicate? [ dup reset-generic ] unless ;
GENERIC: class-of ( object -- class ) GENERIC: class-of ( object -- class )

2
core/classes/parser/parser.factor
View File

@ -7,7 +7,7 @@ IN: classes.parser
location remember-class ; location remember-class ;
: create-class-in ( string -- word ) : create-class-in ( string -- word )
current-vocab create current-vocab create-word
dup t "defining-class" set-word-prop dup t "defining-class" set-word-prop
dup set-last-word dup set-last-word
dup save-class-location dup save-class-location

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

@ -123,7 +123,7 @@ HELP: save-location
HELP: bad-number HELP: bad-number
{ $error-description "Indicates the parser encountered an invalid numeric literal." } ; { $error-description "Indicates the parser encountered an invalid numeric literal." } ;
HELP: create-in HELP: create-word-in
{ $values { "str" "a word name" } { "word" "a new word" } } { $values { "str" "a word name" } { "word" "a new word" } }
{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." } { $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." }
$parsing-note ; $parsing-note ;

5
core/parser/parser-tests.factor
View File

@ -203,7 +203,6 @@ DEFER: foo
[ f ] [ [ f ] [
"IN: parser.tests : x ( -- ) ;" "IN: parser.tests : x ( -- ) ;"
<string-reader> "a" parse-stream drop <string-reader> "a" parse-stream drop
"y" "parser.tests" lookup-word "y" "parser.tests" lookup-word
] unit-test ] unit-test
@ -551,7 +550,7 @@ EXCLUDE: qualified.tests.bar => x ;
[ t ] [ "was-once-a-word-bug" "parser.tests" lookup-word >boolean ] unit-test [ t ] [ "was-once-a-word-bug" "parser.tests" lookup-word >boolean ] unit-test
[ [ ] ] [ [ [ ] ] [
"IN: parser.tests USE: words << \"was-once-a-word-bug\" \"parser.tests\" create [ ] ( -- ) define-declared >>" "IN: parser.tests USE: words << \"was-once-a-word-bug\" \"parser.tests\" create-word [ ] ( -- ) define-declared >>"
<string-reader> "was-once-a-word-test" parse-stream <string-reader> "was-once-a-word-test" parse-stream
] unit-test ] unit-test
@ -630,7 +629,7 @@ EXCLUDE: qualified.tests.bar => x ;
[ "vocabs.loader.test.l" use-vocab ] must-fail [ "vocabs.loader.test.l" use-vocab ] must-fail
[ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> in? ] unit-test [ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> in? ] unit-test
[ ] [ "vocabs.loader.test.l" unuse-vocab ] unit-test [ ] [ "vocabs.loader.test.l" unuse-vocab ] unit-test
[ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> in? ] unit-test [ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> in? ] unit-test
] with-file-vocabs ] with-file-vocabs
! Test cases for #183 ! Test cases for #183

8
core/parser/parser.factor
View File

@ -17,8 +17,8 @@ IN: parser
M: parsing-word stack-effect drop ( parsed -- parsed ) ; M: parsing-word stack-effect drop ( parsed -- parsed ) ;
: create-in ( str -- word ) : create-word-in ( str -- word )
current-vocab create dup set-last-word dup save-location ; current-vocab create-word dup set-last-word dup save-location ;
SYMBOL: auto-use? SYMBOL: auto-use?
@ -29,7 +29,7 @@ SYMBOL: auto-use?
dup vocabulary>> dup vocabulary>>
[ auto-use-vocab ] [ auto-use-vocab ]
[ "Added \"" "\" vocabulary to search path" surround note. ] bi [ "Added \"" "\" vocabulary to search path" surround note. ] bi
] [ create-in ] if ; ] [ create-word-in ] if ;
: ignore-forwards ( seq -- seq' ) : ignore-forwards ( seq -- seq' )
[ forward-reference? ] reject ; [ forward-reference? ] reject ;
@ -81,7 +81,7 @@ ERROR: invalid-word-name string ;
[ invalid-word-name ] when ; [ invalid-word-name ] when ;
: scan-new ( -- word ) : scan-new ( -- word )
scan-word-name create-in ; scan-word-name create-word-in ;
: scan-new-word ( -- word ) : scan-new-word ( -- word )
scan-new dup reset-generic ; scan-new dup reset-generic ;

8
core/slots/slots.factor
View File

@ -39,7 +39,7 @@ M: object reader-quot
] [ ] make ; ] [ ] make ;
: reader-word ( name -- word ) : reader-word ( name -- word )
">>" append "accessors" create ">>" append "accessors" create-word
dup t "reader" set-word-prop ; dup t "reader" set-word-prop ;
: reader-props ( slot-spec -- assoc ) : reader-props ( slot-spec -- assoc )
@ -60,7 +60,7 @@ M: object reader-quot
] 2bi ; ] 2bi ;
: writer-word ( name -- word ) : writer-word ( name -- word )
"<<" append "accessors" create "<<" append "accessors" create-word
dup t "writer" set-word-prop ; dup t "writer" set-word-prop ;
ERROR: bad-slot-value value class ; ERROR: bad-slot-value value class ;
@ -107,7 +107,7 @@ M: object writer-quot
] 2bi ; ] 2bi ;
: setter-word ( name -- word ) : setter-word ( name -- word )
">>" prepend "accessors" create ; ">>" prepend "accessors" create-word ;
: define-setter ( name -- ) : define-setter ( name -- )
dup setter-word dup deferred? [ dup setter-word dup deferred? [
@ -116,7 +116,7 @@ M: object writer-quot
] [ 2drop ] if ; ] [ 2drop ] if ;
: changer-word ( name -- word ) : changer-word ( name -- word )
"change-" prepend "accessors" create ; "change-" prepend "accessors" create-word ;
: define-changer ( name -- ) : define-changer ( name -- )
dup changer-word dup deferred? [ dup changer-word dup deferred? [

4
core/syntax/syntax.factor
View File

@ -127,7 +127,7 @@ IN: bootstrap.syntax
] define-core-syntax ] define-core-syntax
"SYMBOLS:" [ "SYMBOLS:" [
";" [ create-in [ reset-generic ] [ define-symbol ] bi ] each-token ";" [ create-word-in [ reset-generic ] [ define-symbol ] bi ] each-token
] define-core-syntax ] define-core-syntax
"SINGLETONS:" [ "SINGLETONS:" [
@ -135,7 +135,7 @@ IN: bootstrap.syntax
] define-core-syntax ] define-core-syntax
"DEFER:" [ "DEFER:" [
scan-token current-vocab create scan-token current-vocab create-word
[ fake-definition ] [ set-last-word ] [ undefined-def define ] tri [ fake-definition ] [ set-last-word ] [ undefined-def define ] tri
] define-core-syntax ] define-core-syntax

2
core/vocabs/loader/loader-tests.factor
View File

@ -84,7 +84,7 @@ IN: vocabs.loader.tests
[ ] [ [ ] [
[ [
"bob" "vocabs.loader.test.b" create [ ] define "bob" "vocabs.loader.test.b" create-word [ ] define
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test

12
core/vocabs/parser/parser-tests.factor
View File

@ -20,7 +20,7 @@ must-fail-with
[ aaa ] [ "uutt" search ] unit-test [ aaa ] [ "uutt" search ] unit-test
[ aaa ] [ "vocabs.parser.tests:aaa" search ] unit-test [ aaa ] [ "vocabs.parser.tests:aaa" search ] unit-test
[ ] [ [ "bbb" "vocabs.parser.tests" create drop ] with-compilation-unit ] unit-test [ ] [ [ "bbb" "vocabs.parser.tests" create-word drop ] with-compilation-unit ] unit-test
[ "bbb" ] [ "vocabs.parser.tests:bbb" search name>> ] unit-test [ "bbb" ] [ "vocabs.parser.tests:bbb" search name>> ] unit-test
@ -34,18 +34,18 @@ must-fail-with
[ ] [ "vocabs.parser.tests.foo" set-current-vocab ] unit-test [ ] [ "vocabs.parser.tests.foo" set-current-vocab ] unit-test
[ ] [ [ "bbb" current-vocab create drop ] with-compilation-unit ] unit-test [ ] [ [ "bbb" current-vocab create-word drop ] with-compilation-unit ] unit-test
[ t ] [ "bbb" search >boolean ] unit-test [ t ] [ "bbb" search >boolean ] unit-test
[ ] [ [ "vocabs.parser.tests.foo" forget-vocab ] with-compilation-unit ] unit-test [ ] [ [ "vocabs.parser.tests.foo" forget-vocab ] with-compilation-unit ] unit-test
[ [ "bbb" current-vocab create drop ] with-compilation-unit ] [ error>> no-current-vocab-error? ] must-fail-with [ [ "bbb" current-vocab create-word drop ] with-compilation-unit ] [ error>> no-current-vocab-error? ] must-fail-with
[ begin-private ] [ error>> no-current-vocab-error? ] must-fail-with [ begin-private ] [ error>> no-current-vocab-error? ] must-fail-with
[ end-private ] [ error>> no-current-vocab-error? ] must-fail-with [ end-private ] [ error>> no-current-vocab-error? ] must-fail-with
[ f ] [ "bbb" search >boolean ] unit-test [ f ] [ "bbb" search >boolean ] unit-test
] with-manifest ] with-manifest

18
core/words/words-docs.factor
View File

@ -9,8 +9,8 @@ $nl
$nl $nl
"Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "word-search" } ")." "Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "word-search" } ")."
{ $subsections { $subsections
create create-word
create-in create-word-in
lookup-word lookup-word
} ; } ;
@ -246,13 +246,13 @@ $low-level-note
HELP: <word> HELP: <word>
{ $values { "name" string } { "vocab" string } { "word" word } } { $values { "name" string } { "vocab" string } { "word" word } }
{ $description "Allocates a word with the specified name and vocabulary. User code should call " { $link <uninterned-word> } " to create uninterned words and " { $link create } " to create interned words, instead of calling this constructor directly." } { $description "Allocates a word with the specified name and vocabulary. User code should call " { $link <uninterned-word> } " to create uninterned words and " { $link create-word } " to create interned words, instead of calling this constructor directly." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: <uninterned-word> HELP: <uninterned-word>
{ $values { "name" string } { "word" word } } { $values { "name" string } { "word" word } }
{ $description "Creates an uninterned word with the specified name, that is not equal to any other word in the system." } { $description "Creates an uninterned word with the specified name, that is not equal to any other word in the system." }
{ $notes "Unlike " { $link create } ", this word does not have to be called from inside " { $link with-compilation-unit } "." } ; { $notes "Unlike " { $link create-word } ", this word does not have to be called from inside " { $link with-compilation-unit } "." } ;
HELP: gensym HELP: gensym
{ $values { "word" word } } { $values { "word" word } }
@ -262,7 +262,7 @@ HELP: gensym
"( gensym )" "( gensym )"
} }
} }
{ $notes "Unlike " { $link create } ", this word does not have to be called from inside " { $link with-compilation-unit } "." } ; { $notes "Unlike " { $link create-word } ", this word does not have to be called from inside " { $link with-compilation-unit } "." } ;
HELP: bootstrapping? HELP: bootstrapping?
{ $var-description "Set by the library while bootstrap is in progress. Some parsing words need to behave differently during bootstrap." } ; { $var-description "Set by the library while bootstrap is in progress. Some parsing words need to behave differently during bootstrap." } ;
@ -286,17 +286,17 @@ HELP: lookup-word
HELP: reveal HELP: reveal
{ $values { "word" word } } { $values { "word" word } }
{ $description "Adds a newly-created word to the dictionary. Usually this word does not need to be called directly, and is only called as part of " { $link create } "." } ; { $description "Adds a newly-created word to the dictionary. Usually this word does not need to be called directly, and is only called as part of " { $link create-word } "." } ;
HELP: check-create HELP: check-create
{ $values { "name" string } { "vocab" string } } { $values { "name" string } { "vocab" string } }
{ $description "Throws a " { $link check-create } " error if " { $snippet "name" } " or " { $snippet "vocab" } " is not a string." } { $description "Throws a " { $link check-create } " error if " { $snippet "name" } " or " { $snippet "vocab" } " is not a string." }
{ $error-description "Thrown if " { $link create } " is called with invalid parameters." } ; { $error-description "Thrown if " { $link create-word } " is called with invalid parameters." } ;
HELP: create HELP: create-word
{ $values { "name" string } { "vocab" string } { "word" word } } { $values { "name" string } { "vocab" string } { "word" word } }
{ $description "Creates a new word. If the vocabulary already contains a word with the requested name, outputs the existing word. The vocabulary must exist already; if it does not, you must call " { $link create-vocab } " first." } { $description "Creates a new word. If the vocabulary already contains a word with the requested name, outputs the existing word. The vocabulary must exist already; if it does not, you must call " { $link create-vocab } " first." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } ". Parsing words should call " { $link create-in } " instead of this word." } ; { $notes "This word must be called from inside " { $link with-compilation-unit } ". Parsing words should call " { $link create-word-in } " instead of this word." } ;
HELP: constructor-word HELP: constructor-word
{ $values { "name" string } { "vocab" string } { "word" word } } { $values { "name" string } { "vocab" string } { "word" word } }

8
core/words/words-tests.factor
View File

@ -6,7 +6,7 @@ IN: words.tests
[ 4 ] [ [ 4 ] [
[ [
"poo" "words.tests" create [ 2 2 + ] ( -- n ) define-declared "poo" "words.tests" create-word [ 2 2 + ] ( -- n ) define-declared
] with-compilation-unit ] with-compilation-unit
"poo" "words.tests" lookup-word execute "poo" "words.tests" lookup-word execute
] unit-test ] unit-test
@ -25,7 +25,7 @@ DEFER: plist-test
\ plist-test "sample-property" word-prop \ plist-test "sample-property" word-prop
] unit-test ] unit-test
[ ] [ [ "create-test" "scratchpad" create { 1 2 } "testing" set-word-prop ] with-compilation-unit ] unit-test [ ] [ [ "create-test" "scratchpad" create-word { 1 2 } "testing" set-word-prop ] with-compilation-unit ] unit-test
[ { 1 2 } ] [ [ { 1 2 } ] [
"create-test" "scratchpad" lookup-word "testing" word-prop "create-test" "scratchpad" lookup-word "testing" word-prop
@ -34,7 +34,7 @@ DEFER: plist-test
[ [
[ t ] [ \ array? "array?" "arrays" lookup-word = ] unit-test [ t ] [ \ array? "array?" "arrays" lookup-word = ] unit-test
[ ] [ [ "test-scope" "scratchpad" create drop ] with-compilation-unit ] unit-test [ ] [ [ "test-scope" "scratchpad" create-word drop ] with-compilation-unit ] unit-test
] with-scope ] with-scope
[ "test-scope" ] [ [ "test-scope" ] [
@ -73,7 +73,7 @@ DEFER: deferred
[ ] [ "IN: words.tests FORGET: not-compiled" eval( -- ) ] unit-test [ ] [ "IN: words.tests FORGET: not-compiled" eval( -- ) ] unit-test
[ ] [ [ "no-loc" "words.tests" create drop ] with-compilation-unit ] unit-test [ ] [ [ "no-loc" "words.tests" create-word drop ] with-compilation-unit ] unit-test
[ f ] [ "no-loc" "words.tests" lookup-word where ] unit-test [ f ] [ "no-loc" "words.tests" lookup-word where ] unit-test
[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test [ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test

4
core/words/words.factor
View File

@ -210,7 +210,7 @@ ERROR: bad-create name vocab ;
2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and 2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and
[ bad-create ] unless ; [ bad-create ] unless ;
: create ( name vocab -- word ) : create-word ( name vocab -- word )
check-create 2dup lookup-word check-create 2dup lookup-word
[ 2nip ] [ [ 2nip ] [
vocab-name <word> vocab-name <word>
@ -219,7 +219,7 @@ ERROR: bad-create name vocab ;
] if* ; ] if* ;
: constructor-word ( name vocab -- word ) : constructor-word ( name vocab -- word )
[ "<" ">" surround ] dip create ; [ "<" ">" surround ] dip create-word ;
PREDICATE: parsing-word < word "parsing" word-prop ; PREDICATE: parsing-word < word "parsing" word-prop ;

2
extra/constructors/constructors.factor
View File

@ -38,7 +38,7 @@ ERROR: unknown-constructor-parameters class effect unknown ;
[ constructor-boa-quot ] keep define-declared ; [ constructor-boa-quot ] keep define-declared ;
: create-reset ( string -- word ) : create-reset ( string -- word )
create-in dup reset-generic ; create-word-in dup reset-generic ;
: scan-constructor ( -- word class ) : scan-constructor ( -- word class )
scan-new-word scan-class ; scan-new-word scan-class ;

2
extra/cpu/8080/emulator/emulator.factor
View File

@ -1377,7 +1377,7 @@ SYMBOL: last-opcode
#! that would implement that instruction. #! that would implement that instruction.
dup " " join instruction-quotations dup " " join instruction-quotations
[ [
"_" join [ "emulate-" % % ] "" make create-in "_" join [ "emulate-" % % ] "" make create-word-in
dup last-instruction set-global dup last-instruction set-global
] dip ( cpu -- ) define-declared ; ] dip ( cpu -- ) define-declared ;

4
extra/cuda/syntax/syntax.factor
View File

@ -10,9 +10,9 @@ SYNTAX: CUDA-LIBRARY:
[ current-cuda-library set-global ] bi ; [ current-cuda-library set-global ] bi ;
SYNTAX: CUDA-FUNCTION: SYNTAX: CUDA-FUNCTION:
scan-token [ create-in current-cuda-library get ] keep scan-token [ create-word-in current-cuda-library get ] keep
";" scan-c-args drop define-cuda-function ; ";" scan-c-args drop define-cuda-function ;
SYNTAX: CUDA-GLOBAL: SYNTAX: CUDA-GLOBAL:
scan-token [ create-in current-cuda-library get ] keep scan-token [ create-word-in current-cuda-library get ] keep
define-cuda-global ; define-cuda-global ;

2
extra/game/worlds/worlds.factor
View File

@ -79,7 +79,7 @@ M: game-world apply-world-attributes
f swap open-window* dup promise>> ?promise drop ; f swap open-window* dup promise>> ?promise drop ;
: define-attributes-word ( word tuple -- ) : define-attributes-word ( word tuple -- )
[ name>> "-attributes" append create-in ] dip define-constant ; [ name>> "-attributes" append create-word-in ] dip define-constant ;
SYNTAX: GAME: SYNTAX: GAME:
scan-new-word scan-new-word

2
extra/gml/macros/macros.factor
View File

@ -31,7 +31,7 @@ SYNTAX: LOG-GML:
[let [let
(GML:) :> ( word name effect def ) (GML:) :> ( word name effect def )
name "-record" append create-in :> record-class name "-record" append create-word-in :> record-class
record-class tuple effect in>> define-tuple-class record-class tuple effect in>> define-tuple-class
record-class def effect in>> length record-class def effect in>> length

2
extra/gml/runtime/runtime.factor
View File

@ -186,7 +186,7 @@ global-dictionary [ H{ } clone ] initialize
primitive-effect define-declared ; primitive-effect define-declared ;
: scan-gml-name ( -- word name ) : scan-gml-name ( -- word name )
scan-token [ "gml-" prepend create-in ] keep ; scan-token [ "gml-" prepend create-word-in ] keep ;
: (GML:) ( -- word name effect def ) : (GML:) ( -- word name effect def )
scan-gml-name scan-effect parse-definition ; scan-gml-name scan-effect parse-definition ;

2
extra/project-euler/common/common.factor
View File

@ -158,7 +158,7 @@ PRIVATE>
SYNTAX: SOLUTION: SYNTAX: SOLUTION:
scan-word scan-word
[ name>> "-main" append create-in ] keep [ name>> "-main" append create-word-in ] keep
[ drop current-vocab main<< ] [ drop current-vocab main<< ]
[ [ . ] swap prefix ( -- ) define-declared ] [ [ . ] swap prefix ( -- ) define-declared ]
2bi ; 2bi ;

6
extra/python/syntax/syntax.factor
View File

@ -35,7 +35,7 @@ SYMBOL: current-context
: make-factor-words ( module name prefix? -- call-word obj-word ) : make-factor-words ( module name prefix? -- call-word obj-word )
[ [ ":" glue ] [ ":$" glue ] 2bi ] [ nip dup "$" prepend ] if [ [ ":" glue ] [ ":$" glue ] 2bi ] [ nip dup "$" prepend ] if
[ create-in ] bi@ ; [ create-word-in ] bi@ ;
: import-getattr ( module name -- alien ) : import-getattr ( module name -- alien )
[ py-import ] dip getattr ; [ py-import ] dip getattr ;
@ -50,10 +50,10 @@ SYMBOL: current-context
'[ @ rot _ getattr -rot call-object-full @ ] ; '[ @ rot _ getattr -rot call-object-full @ ] ;
: method-callable ( name effect -- ) : method-callable ( name effect -- )
[ dup create-in swap ] dip [ make-method-quot ] keep define-inline ; [ dup create-word-in swap ] dip [ make-method-quot ] keep define-inline ;
: method-object ( name -- ) : method-object ( name -- )
[ "$" prepend create-in ] [ '[ _ getattr ] ] bi [ "$" prepend create-word-in ] [ '[ _ getattr ] ] bi
{ "obj" } { "obj'" } <effect> define-inline ; { "obj" } { "obj'" } <effect> define-inline ;
: add-method ( name effect -- ) : add-method ( name effect -- )

2
extra/variants/variants.factor
View File

@ -14,7 +14,7 @@ M: variant-class initial-value*
: define-tuple-class-and-boa-word ( class superclass slots -- ) : define-tuple-class-and-boa-word ( class superclass slots -- )
pick [ define-tuple-class ] dip pick [ define-tuple-class ] dip
dup name>> "<" ">" surround create-in swap define-boa-word ; dup name>> "<" ">" surround create-word-in swap define-boa-word ;
: define-variant-member ( member -- class ) : define-variant-member ( member -- class )
dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ; dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;

2
unmaintained/alien/cxx/cxx.factor
View File

@ -12,7 +12,7 @@ IN: alien.cxx
create-class-in [ define-mixin-class ] keep ; create-class-in [ define-mixin-class ] keep ;
: class-tuple-word ( word -- word' ) : class-tuple-word ( word -- word' )
"#" append create-in ; "#" append create-word-in ;
: define-class-tuple ( word mixin -- ) : define-class-tuple ( word mixin -- )
[ drop class-wrapper { } define-tuple-class ] [ drop class-wrapper { } define-tuple-class ]

4
unmaintained/alien/marshall/structs/structs.factor
View File

@ -27,7 +27,7 @@ IN: alien.marshall.structs
: define-struct-constructor ( class -- ) : define-struct-constructor ( class -- )
{ {
[ name>> "<" prepend ">" append create-in ] [ name>> "<" prepend ">" append create-word-in ]
[ '[ _ new ] ] [ '[ _ new ] ]
[ name>> '[ _ malloc-struct >>underlying ] append ] [ name>> '[ _ malloc-struct >>underlying ] append ]
[ name>> 1array ] [ name>> 1array ]
@ -35,7 +35,7 @@ IN: alien.marshall.structs
PRIVATE> PRIVATE>
:: define-struct-tuple ( name -- ) :: define-struct-tuple ( name -- )
name create-in :> class name create-word-in :> class
class struct-wrapper { } define-tuple-class class struct-wrapper { } define-tuple-class
class define-struct-constructor class define-struct-constructor
name c-type fields>> [ name c-type fields>> [

2
unmaintained/modules/rpc/rpc.factor
View File

@ -11,7 +11,7 @@ TUPLE: rpc-request args vocabspec wordname ;
serialize flush deserialize dup no-vocab? [ throw ] when ; serialize flush deserialize dup no-vocab? [ throw ] when ;
:: define-remote ( str effect addrspec vocabspec -- ) :: define-remote ( str effect addrspec vocabspec -- )
str create-in effect [ in>> length ] [ out>> length ] bi str create-word-in effect [ in>> length ] [ out>> length ] bi
'[ _ narray vocabspec str rpc-request boa addrspec 9012 <inet> binary '[ _ narray vocabspec str rpc-request boa addrspec 9012 <inet> binary
[ "doer" serialize send-with-check ] with-client _ firstn ] [ "doer" serialize send-with-check ] with-client _ firstn ]
effect define-declared ; effect define-declared ;

4
unmaintained/semantic-db/semantic-db.factor
View File

@ -207,7 +207,7 @@ C: <relation-definition> relation-definition
] if ; ] if ;
: (define-relation-word) ( id-word name>> definition -- id-word ) : (define-relation-word) ( id-word name>> definition -- id-word )
>r create-in over [ execute ] curry r> compose define ; >r create-word-in over [ execute ] curry r> compose define ;
: define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word ) : define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word )
>r >r [ >r >r [
@ -229,7 +229,7 @@ C: <relation-definition> relation-definition
[ ensure-context ensure-relation ] 2curry define ; [ ensure-context ensure-relation ] 2curry define ;
: create-id-word ( relation-definition -- id-word ) : create-id-word ( relation-definition -- id-word )
dup id-word>> "id-word" choose-word-name create-in ; dup id-word>> "id-word" choose-word-name create-word-in ;
PRIVATE> PRIVATE>