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

Implement stricter vocab search path semantics, with a new API for vocabs.parser. Add map-find-last to sequences vocab

db4
Slava Pestov 2009-05-14 22:31:29 -05:00
parent fb6df472a2
commit b31fe9b8f2
27 changed files with 240 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/complex/functor/functor.factor
View File

@ -23,7 +23,7 @@ WHERE
: *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
T in get
T current-vocab
{ { N "real" } { N "imaginary" } }
define-struct

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

@ -22,7 +22,7 @@ SYNTAX: TYPEDEF:
scan scan typedef ;
SYNTAX: C-STRUCT:
scan in get parse-definition define-struct ;
scan current-vocab parse-definition define-struct ;
SYNTAX: C-UNION:
scan parse-definition define-union ;

2
basis/command-line/command-line.factor
View File

@ -69,6 +69,4 @@ SYMBOL: main-vocab-hook
: ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ;
: script-mode ( -- ) ;
[ default-cli-args ] "command-line" add-init-hook

4
basis/functors/functors.factor
View File

@ -146,10 +146,10 @@ DEFER: ;FUNCTOR delimiter
} ;
: push-functor-words ( -- )
functor-words use get push ;
functor-words use-words ;
: pop-functor-words ( -- )
functor-words use get delq ;
functor-words unuse-words ;
: parse-functor-body ( -- form )
push-functor-words

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

@ -16,4 +16,4 @@ SYNTAX: ARTICLE:
] dip remember-definition ;
SYNTAX: ABOUT:
in get vocab scan-object >>help changed-definition ;
current-vocab scan-object >>help changed-definition ;

2
basis/io/sockets/sockets.factor
View File

@ -11,7 +11,7 @@ IN: io.sockets
<< {
{ [ os windows? ] [ "windows.winsock" ] }
{ [ os unix? ] [ "unix" ] }
} cond add-ambiguous-use >>
} cond use-vocab >>
! Addressing
GENERIC: protocol-family ( addrspec -- af )

2
basis/listener/listener-tests.factor
View File

@ -15,7 +15,7 @@ SYNTAX: hello "Hi" print ;
] with-file-vocabs
[
"debugger" add-use
"debugger" add-ambiguous-use
[ [ \ + 1 2 3 4 ] ]
[

4
basis/listener/listener.factor
View File

@ -10,7 +10,7 @@ IN: listener
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-lines-interactive ( lines -- quot/f )
[ parse-lines in get ] with-compilation-unit in set ;
[ parse-lines ] with-compilation-unit ;
: read-quot-step ( lines -- quot/f )
[ parse-lines-interactive ] [
@ -98,7 +98,7 @@ t error-summary? set-global
] [ drop ] if ;
: prompt. ( -- )
in get auto-use? get [ " - auto" append ] when "( " " )" surround
current-vocab name>> auto-use? get [ " - auto" append ] when "( " " )" surround
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
:: (listener) ( datastack -- )

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

@ -25,12 +25,6 @@ SYMBOL: in-lambda?
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
: push-locals ( assoc -- )
use get push ;
: pop-locals ( assoc -- )
use get delq ;
SINGLETON: lambda-parser
SYMBOL: locals
@ -39,7 +33,9 @@ SYMBOL: locals
'[
in-lambda? on
lambda-parser quotation-parser set
[ locals set ] [ push-locals @ ] [ pop-locals ] tri
[ locals set ]
[ use-words @ ]
[ unuse-words ] tri
] with-scope ; inline
: (parse-lambda) ( assoc -- quot )
@ -81,9 +77,9 @@ M: lambda-parser parse-quotation ( -- quotation )
: parse-bindings* ( end -- words assoc )
[
namespace push-locals
namespace use-words
(parse-bindings)
namespace pop-locals
namespace unuse-words
] with-bindings ;
: parse-let* ( -- form )

2
basis/opengl/gl/extensions/extensions.factor
View File

@ -9,7 +9,7 @@ ERROR: unknown-gl-platform ;
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
{ [ os unix? ] [ "opengl.gl.unix" ] }
[ unknown-gl-platform ]
} cond add-use >>
} cond use-vocab >>
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+

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

@ -1,12 +1,12 @@
USING: destructors help.markup help.syntax kernel math multiline sequences
vocabs vocabs.parser words ;
vocabs vocabs.parser words namespaces ;
IN: ui.pixel-formats
! break circular dependency
<<
"ui.gadgets.worlds" create-vocab drop
"world" "ui.gadgets.worlds" create drop
"ui.gadgets.worlds" (add-use)
"ui.gadgets.worlds" vocab-words use-words
>>
ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"

19
basis/ui/tools/listener/listener.factor
View File

@ -38,13 +38,12 @@ output history flag mailbox thread waiting token-model word-model popup ;
[ thread>> dup [ thread-registered? ] when ]
} 1&& not ;
SLOT: vocabs
SLOT: manifest
M: interactor vocabs>>
M: interactor manifest>>
dup interactor-busy? [ drop f ] [
use swap
interactor-continuation name>>
assoc-stack
manifest swap assoc-stack
] if ;
: vocab-exists? ( name -- ? )
@ -56,7 +55,7 @@ M: vocab-completion (word-at-caret)
drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
M: word-completion (word-at-caret)
vocabs>> assoc-stack ;
manifest>> search-manifest ;
M: char-completion (word-at-caret)
2drop f ;
@ -300,15 +299,15 @@ M: listener-operation invoke-command ( target command -- )
: clear-stack ( listener -- )
[ [ clear ] \ clear ] dip (call-listener) ;
: use-if-necessary ( word seq -- )
: use-if-necessary ( word manifest -- )
2dup [ vocabulary>> ] dip and [
2dup [ assoc-stack ] keep = [ 2drop ] [
[ vocabulary>> vocab-words ] dip push
] if
manifest [
vocabulary>> use-vocab
] with-variable
] [ 2drop ] if ;
M: word accept-completion-hook
interactor>> vocabs>> use-if-necessary ;
interactor>> manifest>> use-if-necessary ;
M: object accept-completion-hook 2drop ;

4
basis/ui/tools/operations/operations.factor
View File

@ -131,13 +131,13 @@ M: quotation com-stack-effect infer. ;
M: word com-stack-effect 1quotation com-stack-effect ;
: com-enter-in ( vocab -- ) vocab-name set-in ;
: com-enter-in ( vocab -- ) vocab-name set-current-vocab ;
[ vocab? ] \ com-enter-in H{
{ +listener+ t }
} define-operation
: com-use-vocab ( vocab -- ) vocab-name add-use ;
: com-use-vocab ( vocab -- ) vocab-name use-vocab ;
[ vocab-spec? ] \ com-use-vocab H{
{ +secondary+ t }

14
core/bootstrap/stage1.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays debugger generic hashtables io assocs
kernel.private kernel math memory namespaces make parser
prettyprint sequences vectors words system splitting
init io.files bootstrap.image bootstrap.image.private vocabs
vocabs.loader system debugger continuations ;
USING: arrays debugger generic hashtables io assocs kernel.private
kernel math memory namespaces make parser prettyprint sequences
vectors words system splitting init io.files vocabs vocabs.loader
debugger continuations ;
QUALIFIED: bootstrap.image.private
IN: bootstrap.stage1
"Bootstrap stage 1..." print flush
@ -51,4 +51,4 @@ load-help? off
] if
] %
] [ ] make
bootstrap-boot-quot set
bootstrap.image.private:bootstrap-boot-quot set

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

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser words kernel classes compiler.units lexer ;
USING: parser vocabs.parser words kernel classes compiler.units lexer ;
IN: classes.parser
: save-class-location ( class -- )

3
core/init/init.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations continuations.private kernel
kernel.private sequences assocs namespaces namespaces.private
continuations continuations.private ;
kernel.private sequences assocs namespaces namespaces.private ;
IN: init
SYMBOL: init-hooks

2
core/io/backend/backend.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
io.encodings.utf8 init assocs splitting alien ;
io.encodings.utf8 assocs splitting alien ;
IN: io.backend
SYMBOL: io-backend

22
core/parser/parser.factor
View File

@ -31,16 +31,6 @@ t parser-notes set-global
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
TUPLE: no-current-vocab ;
: no-current-vocab ( -- vocab )
\ no-current-vocab boa
{ { "Define words in scratchpad vocabulary" "scratchpad" } }
throw-restarts dup set-in ;
: current-vocab ( -- str )
in get [ no-current-vocab ] unless* ;
: create-in ( str -- word )
current-vocab create dup set-word dup save-location ;
@ -55,7 +45,7 @@ SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word )
dup word? [
dup vocabulary>>
[ (add-use) ]
[ use-vocab ]
[ amended-use get dup [ push ] [ 2drop ] if ]
[ "Added \"" "\" vocabulary to search path" surround note. ]
tri
@ -134,8 +124,9 @@ SYMBOL: bootstrap-syntax
: with-file-vocabs ( quot -- )
[
f in set { "syntax" } set-use
bootstrap-syntax get [ use get push ] when*
<manifest> manifest set
"syntax" use-vocab
bootstrap-syntax get [ use-words ] when*
call
] with-scope ; inline
@ -195,8 +186,9 @@ SYMBOL: interactive-vocabs
: with-interactive-vocabs ( quot -- )
[
"scratchpad" in set
interactive-vocabs get set-use
<manifest> manifest set
"scratchpad" set-current-vocab
interactive-vocabs get only-use-vocabs
call
] with-scope ; inline

2
core/sbufs/sbufs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math strings sequences.private sequences
USING: accessors kernel math sequences.private sequences
strings growable strings.private ;
IN: sbufs

15
core/sequences/sequences.factor
View File

@ -834,11 +834,20 @@ PRIVATE>
[ [ 2unclip-slice ] dip [ call ] keep ] dip
compose 2reduce ; inline
: map-find ( seq quot -- result elt )
[ f ] 2dip
[ [ nip ] dip call dup ] curry find
<PRIVATE
: (map-find) ( seq quot find-quot -- result elt )
[ [ f ] 2dip [ [ nip ] dip call dup ] curry ] dip call
[ [ drop f ] unless ] dip ; inline
PRIVATE>
: map-find ( seq quot -- result elt )
[ find ] (map-find) ; inline
: map-find-last ( seq quot -- result elt )
[ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last )
[ but-last-slice ] [ peek ] bi ; inline

2
core/slots/slots.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings words effects generic generic.standard
make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
words sequences.private assocs alien quotations hashtables ;
IN: slots

6
core/sorting/sorting.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math sequences vectors math.order
sequences sequences.private math.order ;
USING: accessors arrays kernel math vectors math.order
sequences sequences.private ;
IN: sorting
! Optimized merge-sort:

18
core/syntax/syntax.factor
View File

@ -41,28 +41,26 @@ IN: bootstrap.syntax
"#!" [ POSTPONE: ! ] define-core-syntax
"IN:" [ scan set-in ] define-core-syntax
"IN:" [ scan set-current-vocab ] define-core-syntax
"PRIVATE>" [ in get ".private" ?tail drop set-in ] define-core-syntax
"<PRIVATE" [ begin-private ] define-core-syntax
"<PRIVATE" [
POSTPONE: PRIVATE> in get ".private" append set-in
] define-core-syntax
"PRIVATE>" [ end-private ] define-core-syntax
"USE:" [ scan add-use ] define-core-syntax
"USE:" [ scan use-vocab ] define-core-syntax
"USING:" [ ";" parse-tokens [ add-use ] each ] define-core-syntax
"USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax
"QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
"QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax
"FROM:" [
scan "=>" expect ";" parse-tokens swap add-words-from
scan "=>" expect ";" parse-tokens add-words-from
] define-core-syntax
"EXCLUDE:" [
scan "=>" expect ";" parse-tokens swap add-words-excluding
scan "=>" expect ";" parse-tokens add-words-excluding
] define-core-syntax
"RENAME:" [
@ -227,7 +225,7 @@ IN: bootstrap.syntax
"))" parse-effect parsed
] define-core-syntax
"MAIN:" [ scan-word in get vocab (>>main) ] define-core-syntax
"MAIN:" [ scan-word current-vocab (>>main) ] define-core-syntax
"<<" [
[

213
core/vocabs/parser/parser.factor
View File

@ -2,11 +2,167 @@
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel namespaces sequences
sets strings vocabs sorting accessors arrays compiler.units ;
sets strings vocabs sorting accessors arrays compiler.units
combinators vectors splitting continuations ;
IN: vocabs.parser
ERROR: no-word-error name ;
TUPLE: manifest
current-vocab
{ search-vocabs vector }
{ qualified-vocabs vector }
{ extra-words vector } ;
: <manifest> ( -- manifest )
manifest new
V{ } clone >>search-vocabs
V{ } clone >>qualified-vocabs
V{ } clone >>extra-words ;
M: manifest clone
call-next-method
[ clone ] change-search-vocabs
[ clone ] change-qualified-vocabs
[ clone ] change-extra-words ;
<PRIVATE
: clear-manifest ( -- )
manifest get
[ search-vocabs>> delete-all ]
[ qualified-vocabs>> delete-all ]
[ extra-words>> delete-all ]
tri ;
: (use-vocab) ( vocab -- vocab seq )
load-vocab manifest get search-vocabs>> ;
: (add-qualified) ( qualified -- )
manifest get qualified-vocabs>> push ;
: (from) ( vocab words -- vocab words words' assoc )
2dup swap load-vocab words>> ;
: (use-words) ( assoc -- assoc seq )
manifest get extra-words>> ;
: extract-words ( seq assoc -- assoc' )
extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ;
: (lookup) ( name assoc -- word/f )
at dup forward-reference? [ drop f ] when ;
PRIVATE>
: set-current-vocab ( name -- )
create-vocab manifest get
[ (>>current-vocab) ]
[ [ words>> ] dip extra-words>> push ]
2bi ;
TUPLE: no-current-vocab ;
: no-current-vocab ( -- vocab )
\ no-current-vocab boa
{ { "Define words in scratchpad vocabulary" "scratchpad" } }
throw-restarts dup set-current-vocab ;
: current-vocab ( -- vocab )
manifest get current-vocab>> [ no-current-vocab ] unless* ;
: begin-private ( -- )
manifest get current-vocab>> vocab-name ".private" ?tail
[ drop ] [ ".private" append set-current-vocab ] if ;
: end-private ( -- )
manifest get current-vocab>> vocab-name ".private" ?tail
[ set-current-vocab ] [ drop ] if ;
: use-vocab ( vocab -- ) (use-vocab) push ;
: unuse-vocab ( vocab -- ) (use-vocab) delq ;
: only-use-vocabs ( vocabs -- )
clear-manifest
[ vocab ] V{ } map-as sift
manifest get search-vocabs>> push-all ;
TUPLE: qualified vocab prefix words ;
: <qualified> ( vocab prefix -- qualified )
2dup
[ load-vocab words>> ] [ CHAR: : suffix ] bi*
[ swap [ prepend ] dip ] curry assoc-map
qualified boa ;
: add-qualified ( vocab prefix -- )
<qualified> (add-qualified) ;
TUPLE: from vocab names words ;
: <from> ( vocab words -- from )
(from) extract-words from boa ;
: add-words-from ( vocab words -- )
<from> (add-qualified) ;
TUPLE: exclude vocab names words ;
: <exclude> ( vocab words -- from )
(from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ;
: add-words-excluding ( vocab words -- )
<exclude> (add-qualified) ;
TUPLE: rename word vocab words ;
: <rename> ( word vocab new-name -- rename )
[ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip
associate rename boa ;
: add-renamed-word ( word vocab new-name -- )
<rename> (add-qualified) ;
: use-words ( words -- ) (use-words) push ;
: unuse-words ( words -- ) (use-words) delq ;
ERROR: ambiguous-use-error words ;
<PRIVATE
: (vocab-search) ( name assocs -- words n )
[ words>> (lookup) ] with map
sift dup length ;
: vocab-search ( name manifest -- word/f )
search-vocabs>>
(vocab-search) {
{ 0 [ drop f ] }
{ 1 [ first ] }
[ drop ambiguous-use-error ]
} case ;
: qualified-search ( name manifest -- word/f )
qualified-vocabs>>
(vocab-search) 0 = [ drop f ] [ peek ] if ;
: word-search ( name manifest -- word/f )
extra-words>> [ (lookup) ] with map-find-last drop ;
PRIVATE>
: search-manifest ( name manifest -- word/f )
2dup word-search dup [ 2nip ] [
drop 2dup qualified-search dup [ 2nip ] [
drop vocab-search
] if
] if ;
: search ( name -- word/f )
manifest get search-manifest ;
: word-restarts ( name possibilities -- restarts )
natural-sort
[ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
@ -15,58 +171,3 @@ ERROR: no-word-error name ;
: <no-word-error> ( name possibilities -- error restarts )
[ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
SYMBOL: use
SYMBOL: in
: (add-use) ( vocab -- )
vocab-words use get push ;
: add-use ( vocab -- )
load-vocab (add-use) ;
: set-use ( seq -- )
[ vocab-words ] V{ } map-as sift use set ;
: add-qualified ( vocab prefix -- )
[ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
[ swap [ prepend ] dip ] curry assoc-map
use get push ;
: words-named-in ( words assoc -- assoc' )
[ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
: partial-vocab-including ( words vocab -- assoc )
load-vocab vocab-words words-named-in ;
: add-words-from ( words vocab -- )
partial-vocab-including use get push ;
: partial-vocab-excluding ( words vocab -- assoc )
load-vocab vocab-words [ nip ] [ words-named-in ] 2bi assoc-diff ;
: add-words-excluding ( words vocab -- )
partial-vocab-excluding use get push ;
: add-renamed-word ( word vocab new-name -- )
[ load-vocab vocab-words dupd at [ ] [ no-word-error ] ?if ] dip
associate use get push ;
: check-vocab-string ( name -- name )
dup string? [ "Vocabulary name must be a string" throw ] unless ;
: set-in ( name -- )
check-vocab-string dup in set create-vocab (add-use) ;
: check-forward ( str word -- word/f )
dup forward-reference? [
drop
use get
[ at ] with map sift
[ forward-reference? not ] find-last nip
] [
nip
] if ;
: search ( str -- word/f )
dup use get assoc-stack check-forward ;

6
core/vocabs/vocabs.factor
View File

@ -78,7 +78,13 @@ GENERIC: vocabs-changed ( obj -- )
: notify-vocab-observers ( -- )
vocab-observers get [ vocabs-changed ] each ;
ERROR: bad-vocab-name name ;
: check-vocab-name ( name -- name )
dup string? [ bad-vocab-name ] unless ;
: create-vocab ( name -- vocab )
check-vocab-name
dictionary get [ <vocab> ] cache
notify-vocab-observers ;

8
core/words/words.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions graphs assocs kernel
kernel.private kernel.private slots.private math namespaces sequences
USING: accessors arrays definitions graphs kernel
kernel.private slots.private math namespaces sequences
strings vectors sbufs quotations assocs hashtables sorting vocabs
math.order sets ;
IN: words
@ -180,12 +180,12 @@ M: word reset-word
ERROR: bad-create name vocab ;
: check-create ( name vocab -- name vocab )
2dup [ string? ] both?
2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and
[ bad-create ] unless ;
: create ( name vocab -- word )
check-create 2dup lookup
dup [ 2nip ] [ drop <word> dup reveal ] if ;
dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
: constructor-word ( name vocab -- word )
[ "<" ">" surround ] dip create ;

8
extra/infix/infix.factor
View File

@ -85,12 +85,10 @@ SYNTAX: [infix
"infix]" [infix-parse parsed \ call parsed ;
<PRIVATE
: parse-infix-locals ( assoc end -- quot )
[
in-lambda? on
[ dup [ locals set ] [ push-locals ] bi ] dip
[infix-parse prepare-operand swap pop-locals
] with-scope ;
'[ _ [infix-parse prepare-operand ] ((parse-lambda)) ;
PRIVATE>
SYNTAX: [infix|