String decl = "USE: " + vocab;
if(leadingNewline)
decl = "\n" + decl;
+ if(lastUseOffset == 0)
+ decl = decl + "\n";
buffer.insert(lastUseOffset,decl);
showStatus(view,"inserted-use",decl);
} //}}}
"/version.factor"\r
"/library/kernel.factor"\r
"/library/stack.factor"\r
+ "/library/generic.factor"\r
"/library/types.factor"\r
"/library/math/math.factor"\r
"/library/cons.factor"\r
"/library/strings.factor"\r
"/library/hashtables.factor"\r
"/library/namespaces.factor"\r
- "/library/generic.factor"\r
"/library/list-namespaces.factor"\r
"/library/sbuf.factor"\r
"/library/continuations.factor"\r
"/version.factor"
"/library/stack.factor"
"/library/kernel.factor"
+ "/library/generic.factor"
"/library/types.factor"
"/library/combinators.factor"
"/library/math/math.factor"
"/library/strings.factor"
"/library/hashtables.factor"
"/library/namespaces.factor"
- "/library/generic.factor"
"/library/list-namespaces.factor"
"/library/sbuf.factor"
"/library/continuations.factor"
USE: errors
USE: hashtables
USE: kernel
-USE: kernel-internals
USE: lists
USE: math
USE: namespaces
: untag ( cell tag -- ) tag-mask bitnot bitand ;
: tag ( cell -- tag ) tag-mask bitand ;
+: fixnum-tag BIN: 000 ; inline
+: word-tag BIN: 001 ; inline
+: cons-tag BIN: 010 ; inline
+: object-tag BIN: 011 ; inline
+: ratio-tag BIN: 100 ; inline
+: complex-tag BIN: 101 ; inline
+: header-tag BIN: 110 ; inline
+
+: f-type 6 ; inline
+: t-type 7 ; inline
+: array-type 8 ; inline
+: bignum-type 9 ; inline
+: float-type 10 ; inline
+: vector-type 11 ; inline
+: string-type 12 ; inline
+: sbuf-type 13 ; inline
+: port-type 14 ; inline
+: dll-type 15 ; inline
+: alien-type 16 ; inline
+
: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
: >header ( id -- tagged ) header-tag immediate ;
( Bignums )
: emit-bignum ( bignum -- tagged )
+ #! This can only emit 0, -1 and 1.
object-tag here-as >r
bignum-type >header emit
- dup 0 = 1 2 ? emit ( capacity )
[
- [ 0 = ] [ emit pad ]
- [ 0 < ] [ 1 emit neg emit ]
- [ 0 > ] [ 0 emit emit ]
- ] cond r> ;
+ [ 0 | [ 1 0 ] ]
+ [ -1 | [ 2 1 1 ] ]
+ [ 1 | [ 2 0 1 ] ]
+ ] assoc [ emit ] each pad r> ;
( Special objects )
: label, ( label -- )
#label swons , ;
-: (linearize-label) ( node -- )
+: linearize-simple-label ( node -- )
+ #! Some labels become simple labels after the optimization
+ #! stage.
dup [ node-label get ] bind label,
[ node-param get ] bind (linearize) ;
+#simple-label [
+ linearize-simple-label
+] "linearizer" set-word-property
+
: linearize-label ( node -- )
#! Labels are tricky, because they might contain non-tail
#! calls. So we push the address of the location right after
#! this in the common case where the labelled block does
#! not contain non-tail recursive calls to itself.
<label> dup #return-to swons , >r
- (linearize-label)
+ linearize-simple-label
[ #return ] ,
r> label, ;
-#label [ linearize-label ] "linearizer" set-word-property
+#label [
+ linearize-label
+] "linearizer" set-word-property
: linearize-ifte ( param -- )
#! The parameter is a list of two lists, each one a dataflow
[ node-param get ] bind can-kill?
] "can-kill" set-word-property
-: (calls-label?) ( label node -- ? )
- "calls-label" [ 2drop f ] apply-dataflow ;
-
#call-label [
[ node-param get ] bind =
] "calls-label" set-word-property
: calls-label? ( label list -- ? )
- [ dupd (calls-label?) ] some? nip ;
+ [
+ dupd "calls-label" [ 2drop f ] apply-dataflow
+ ] some? nip ;
#label [
[ node-param get ] bind calls-label?
] "calls-label" set-word-property
+#simple-label [
+ [ node-param get ] bind calls-label?
+] "calls-label" set-word-property
+
: branches-call-label? ( label list -- ? )
[ dupd calls-label? ] some? nip ;
[ node-param get ] bind branches-call-label?
] "calls-label" set-word-property
-: recursive-label? ( node -- ? )
+: optimize-label ( -- op )
#! Does the label node contain calls to itself?
- [ node-label get node-param get ] bind
- calls-label? ;
+ node-label get node-param get calls-label?
+ #label #simple-label ? ;
#label [ ( literals node -- )
- dup recursive-label? [
- [ node-param [ kill-nodes ] change ] extend ,
- ] [
- [ node-param get ] bind (kill-nodes)
- ] ifte
+ [
+ optimize-label node-op set
+ node-param [ kill-nodes ] change
+ ] extend ,
] "kill-node" set-word-property
#ifte [ scan-branches ] "scan-literal" set-word-property
USE: words
USE: vectors
-! A simple prototype-based generic word system.
+! A simple single-dispatch generic word system.
+
+: predicate-word ( word -- word )
+ word-name "?" cat2 "in" get create ;
+
+: builtin-predicate ( symbol type# -- )
+ [ swap type eq? ] cons >r predicate-word r> define-compound ;
+
+: BUILTIN:
+ #! Followed by type name and type number. Define a built-in
+ #! type predicate with this number.
+ CREATE dup undefined? [ dup define-symbol ] when scan-word
+ 2dup builtin-predicate
+ "builtin-type" set-word-property ; parsing
+
+: builtin-type ( symbol -- n )
+ "builtin-type" word-property ;
! Hashtable slot holding a selector->method map.
SYMBOL: traits
: undefined-method
"No applicable method." throw ;
-: method ( selector traits -- traits quot )
+: traits-method ( selector traits -- traits quot )
#! Look up the method with the traits object on the stack.
#! Returns the traits to call the method on; either the
#! original object, or one of the delegates.
rot drop cdr ( method is defined )
] [
drop delegate swap hash* dup [
- cdr method ( check delegate )
+ cdr traits-method ( check delegate )
] [
drop [ undefined-method ] ( no delegate )
] ifte
] ifte ;
-: predicate-word ( word -- word )
- word-name "?" cat2 "in" get create ;
-
-: define-predicate ( word -- )
+: traits-predicate ( word -- )
#! foo? where foo is a traits type tests if the top of stack
#! is of this type.
dup predicate-word swap
- [ object-map ] swap traits-map [ eq? ] cons append
+ traits-map [ swap object-map eq? ] cons
define-compound ;
: TRAITS:
CREATE
dup define-symbol
dup init-traits-map
- define-predicate ; parsing
+ traits-predicate ; parsing
+
+: add-method ( quot class vtable -- )
+ >r "builtin-type" word-property r>
+ set-vector-nth ;
+
+: <vtable> ( word -- vtable )
+ num-types [ drop [ undefined-method ] ] vector-project
+ [ "vtable" set-word-property ] keep ;
+
+: add-traits-dispatch ( word vtable -- )
+ >r unit [ car swap traits-method call ] cons \ vector r>
+ add-method ;
: GENERIC:
#! GENERIC: bar creates a generic word bar that calls the
#! bar method on the traits object, with the traits object
#! on the stack.
- CREATE
- dup unit [ car swap method call ] cons
- define-compound ; parsing
+ CREATE dup <vtable> 2dup add-traits-dispatch
+ [ generic ] cons define-compound ; parsing
: constructor-word ( word -- word )
word-name "<" swap ">" cat3 "in" get create ;
traits-map [ traits pick set-hash ] cons append
define-compound ;
-: C: ( -- word [ ] )
- #! C: foo ... begins definition for <foo> where foo is a
- #! traits type. We have to reverse the list at the end,
- #! since the parser conses onto the list, and it will be
- #! reversed again by ;C.
- scan-word [ constructor-word [ <namespace> ] ] keep
- traits-map [ traits pick set-hash ] cons append reverse ;
- parsing
+: (;C) ( constructor traits definition -- )
+ >r
+ traits-map [ traits pick set-hash ] cons \ <namespace> swons
+ r> append define-compound ;
-: ;C ( word [ ] -- )
- POSTPONE: ; ; parsing
+: C: ( -- constructor traits [ ] )
+ #! C: foo ... begins definition for <foo> where foo is a
+ #! traits type.
+ scan-word [ constructor-word ] keep [ (;C) ] [ ] ; parsing
: M: ( -- type generic [ ] )
#! M: foo bar begins a definition of the bar generic word
#! specialized to the foo type.
- scan-word scan-word f ; parsing
-
-: ;M ( type generic def -- )
- #! ;M ends a method definition.
- rot traits-map [ reverse put ] bind ; parsing
+ scan-word scan-word [ rot traits-map [ put ] bind ] [ ] ;
+ parsing
] file-link-tag
] object-link-tag
] icon-tag
- ] bind ;M
+ ] bind ;
C: html-stream ( stream -- stream )
#! Wraps the given stream in an HTML stream. An HTML stream
#! underline
#! size
#! link - an object path
- [ dup delegate set stdio set ] extend ;C
+ [ dup delegate set stdio set ] extend ;
: with-html-stream ( quot -- )
[ stdio [ <html-stream> ] change call ] with-scope ;
! Label nodes have the node-label variable set.
SYMBOL: #label
+! A label that is not called recursively at all, or only tail
+! recursively. The optimizer changes some #labels to
+! #simple-labels.
+SYMBOL: #simple-label
+
SYMBOL: #call ( non-tail call )
SYMBOL: #call-label
SYMBOL: #push ( literal )
[
[ default-style ] unless* ansi-attr-string
delegate get fwrite
- ] bind ;M
+ ] bind ;
C: ansi-stream ( stream -- stream )
#! Wraps the given stream in an ANSI stream. ANSI streams
TRAITS: server
M: server fclose ( stream -- )
- [ "socket" get close-port ] bind ;M
+ [ "socket" get close-port ] bind ;
C: server ( port -- stream )
#! Starts listening on localhost:port. Returns a stream that
#! you can close with fclose, and accept connections from
#! with accept. No other stream operations are supported.
- [ server-socket "socket" set ] extend ;C
+ [ server-socket "socket" set ] extend ;
: <client-stream> ( host port in out -- stream )
<fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;
TRAITS: stdio-stream
M: stdio-stream fauto-flush ( -- )
- [ delegate get fflush ] bind ;M
+ [ delegate get fflush ] bind ;
M: stdio-stream fclose ( -- )
- drop ;M
+ drop ;
C: stdio-stream ( delegate -- stream )
- [ delegate set ] extend ;C
+ [ delegate set ] extend ;
TRAITS: fd-stream
M: fd-stream fwrite-attr ( str style stream -- )
- [ drop "out" get blocking-write ] bind ;M
+ [ drop "out" get blocking-write ] bind ;
M: fd-stream freadln ( stream -- str )
- [ "in" get dup [ blocking-read-line ] when ] bind ;M
+ [ "in" get dup [ blocking-read-line ] when ] bind ;
M: fd-stream fread# ( count stream -- str )
- [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ;M
+ [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ;
M: fd-stream fflush ( stream -- )
- [ "out" get [ blocking-flush ] when* ] bind ;M
+ [ "out" get [ blocking-flush ] when* ] bind ;
M: fd-stream fauto-flush ( stream -- )
- drop ;M
+ drop ;
M: fd-stream fclose ( -- )
[
"out" get [ dup blocking-flush close-port ] when*
"in" get [ close-port ] when*
- ] bind ;M
+ ] bind ;
C: fd-stream ( in out -- stream )
- [ "out" set "in" set ] extend ;C
+ [ "out" set "in" set ] extend ;
: <filecr> ( path -- stream )
t f open-file <fd-stream> ;
TRAITS: string-output-stream
M: string-output-stream fwrite-attr ( string style stream -- )
- [ drop "buf" get sbuf-append ] bind ;M
+ [ drop "buf" get sbuf-append ] bind ;
M: string-output-stream fclose ( stream -- )
- drop ;M
+ drop ;
M: string-output-stream fflush ( stream -- )
- drop ;M
+ drop ;
M: string-output-stream fauto-flush ( stream -- )
- drop ;M
+ drop ;
: stream>str ( stream -- string )
#! Returns the string written to the given string output
C: string-output-stream ( size -- stream )
#! Creates a new stream for writing to a string buffer.
- [ <sbuf> "buf" set ] extend ;C
+ [ <sbuf> "buf" set ] extend ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
- [
- [ letter? ] [ drop t ]
- [ LETTER? ] [ drop t ]
- [ digit? ] [ drop t ]
- [ "/_?." str-contains? ] [ drop t ]
- [ ] [ drop f ]
- ] cond ;
+ dup letter?
+ over LETTER? or
+ over digit? or
+ swap "/_?." str-contains? or ;
: :
#! Begin a word definition. Word name follows.
- CREATE [ ] "in-definition" on ; parsing
+ CREATE [ define-compound ] [ ] "in-definition" on ; parsing
: ;
#! End a word definition.
- "in-definition" off reverse define-compound ; parsing
+ "in-definition" off reverse swap call ; parsing
! Symbols
: SYMBOL:
USE: kernel
TRAITS: test-traits
-C: test-traits ;C
+C: test-traits ;
[ t ] [ <test-traits> test-traits? ] unit-test
[ f ] [ "hello" test-traits? ] unit-test
GENERIC: foo
-M: test-traits foo drop 12 ;M
+M: test-traits foo drop 12 ;
TRAITS: another-test
-C: another-test ;C
+C: another-test ;
-M: another-test foo drop 13 ;M
+M: another-test foo drop 13 ;
[ 12 ] [ <test-traits> foo ] unit-test
[ 13 ] [ <another-test> foo ] unit-test
TRAITS: quux
-C: quux ;C
+C: quux ;
-M: quux foo "foo" swap hash ;M
+M: quux foo "foo" swap hash ;
[
"Hi"
] unit-test
TRAITS: ctr-test
-C: ctr-test [ 5 "x" set ] extend ;C
+C: ctr-test [ 5 "x" set ] extend ;
[
5
] unit-test
TRAITS: del1
-C: del1 ;C
+C: del1 ;
GENERIC: super
-M: del1 super drop 5 ;M
+M: del1 super drop 5 ;
TRAITS: del2
-C: del2 ( delegate -- del2 ) [ delegate set ] extend ;C
+C: del2 ( delegate -- del2 ) [ delegate set ] extend ;
[ 5 ] [ <del1> <del2> super ] unit-test
[ [ [ "one" + ] [ "four" * ] ] ] [
"three" "quot-alist" get remove-assoc
] unit-test
-
-[ [ "one" "three" "four" ] [ [ + ] [ - ] [ * ] ] ]
-[ "quot-alist" get unzip ] unit-test
[ [ 1 2 ] ] [ 1 2 2list ] unit-test
[ [ 1 2 3 ] ] [ 1 2 3 3list ] unit-test
-
-[ [ "car1" | "cdr1" ] [ "car2" | "cdr2" ] ]
-[ "car1" "car2" "cdr1" "cdr2" 2cons ]
-unit-test
-
-[ [ "car1" | "cdr1" ] [ "car2" | "cdr2" ] ]
-[ "cdr1" "cdr2" "car1" "car2" 2swons ]
-unit-test
drop "<" delegate get fwrite
delegate get fwrite
">" delegate get fwrite
- ] bind ;M
+ ] bind ;
M: xyzzy-stream fclose ( stream -- )
- drop ;M
+ drop ;
M: xyzzy-stream fflush ( stream -- )
- drop ;M
+ drop ;
M: xyzzy-stream fauto-flush ( stream -- )
- drop ;M
+ drop ;
C: xyzzy-stream ( stream -- stream )
- [ delegate set ] extend ;C
+ [ delegate set ] extend ;
[
"<xyzzy>"
TRAITS: jedit-stream
M: jedit-stream freadln ( stream -- str )
- [ CHAR: r write flush read-big-endian-32 read# ] bind ;M
+ [ CHAR: r write flush read-big-endian-32 read# ] bind ;
M: jedit-stream fwrite-attr ( str style stream -- )
- [ [ default-style ] unless* jedit-write-attr ] bind ;M
+ [ [ default-style ] unless* jedit-write-attr ] bind ;
M: jedit-stream fflush ( stream -- )
- [ CHAR: f write flush ] bind ;M
+ [ CHAR: f write flush ] bind ;
C: jedit-stream ( stream -- stream )
- [ dup delegate set stdio set ] extend ;C
+ [ dup delegate set stdio set ] extend ;
: stream-server ( -- )
#! Execute this in the inferior Factor.
USE: kernel
USE: math
+USE: generic
-IN: kernel-internals
-
-: fixnum-tag BIN: 000 ; inline
-: word-tag BIN: 001 ; inline
-: cons-tag BIN: 010 ; inline
-: object-tag BIN: 011 ; inline
-: ratio-tag BIN: 100 ; inline
-: complex-tag BIN: 101 ; inline
-: header-tag BIN: 110 ; inline
-
-: f-type 6 ; inline
-: t-type 7 ; inline
-: array-type 8 ; inline
-: bignum-type 9 ; inline
-: float-type 10 ; inline
-: vector-type 11 ; inline
-: string-type 12 ; inline
-: sbuf-type 13 ; inline
-: port-type 14 ; inline
-: dll-type 15 ; inline
-: alien-type 16 ; inline
-
-IN: math : fixnum? ( obj -- ? ) type fixnum-tag eq? ;
-IN: words : word? ( obj -- ? ) type word-tag eq? ;
-IN: lists : cons? ( obj -- ? ) type cons-tag eq? ;
-IN: math : ratio? ( obj -- ? ) type ratio-tag eq? ;
-IN: math : complex? ( obj -- ? ) type complex-tag eq? ;
-IN: math : bignum? ( obj -- ? ) type bignum-type eq? ;
-IN: math : float? ( obj -- ? ) type float-type eq? ;
-IN: vectors : vector? ( obj -- ? ) type vector-type eq? ;
-IN: strings : string? ( obj -- ? ) type string-type eq? ;
-IN: strings : sbuf? ( obj -- ? ) type sbuf-type eq? ;
-IN: io-internals : port? ( obj -- ? ) type port-type eq? ;
-IN: alien : dll? ( obj -- ? ) type dll-type eq? ;
-IN: alien : alien? ( obj -- ? ) type alien-type eq? ;
+IN: vectors SYMBOL: vector
+IN: math BUILTIN: fixnum 0
+IN: words BUILTIN: word 1
+IN: lists BUILTIN: cons 2
+IN: math BUILTIN: ratio 4
+IN: math BUILTIN: complex 5
+IN: math BUILTIN: bignum 9
+IN: math BUILTIN: float 10
+IN: vectors BUILTIN: vector 11
+IN: strings BUILTIN: string 12
+IN: strings BUILTIN: sbuf 13
+IN: io-internals BUILTIN: port 14
+IN: alien BUILTIN: dll 15
+IN: alien BUILTIN: alien 16
IN: kernel
swap set-word-plist ;
: ?word-primitive ( obj -- prim/0 )
- dup word? [ word-primitive ] [ drop 0 ] ifte ;
+ dup word? [ word-primitive ] [ drop -1 ] ifte ;
: compound? ( obj -- ? ) ?word-primitive 1 = ;
: primitive? ( obj -- ? ) ?word-primitive 2 > ;
: symbol? ( obj -- ? ) ?word-primitive 2 = ;
+: undefined? ( obj -- ? ) ?word-primitive 0 = ;
: word ( -- word ) global [ "last-word" get ] bind ;
: set-word ( word -- ) global [ "last-word" set ] bind ;
projects / factor.git / commitdiff