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

generic.factor cleanups; started generalized dispatching

cvs
Slava Pestov 2004-12-11 23:18:43 +00:00
parent 4445a05e81
commit ee5fc9575d
23 changed files with 167 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
factor/jedit/FactorPlugin.java
View File

@ -447,6 +447,8 @@ public class FactorPlugin extends EditPlugin
String decl = "USE: " + vocab;
if(leadingNewline)
decl = "\n" + decl;
if(lastUseOffset == 0)
decl = decl + "\n";
buffer.insert(lastUseOffset,decl);
showStatus(view,"inserted-use",decl);
} //}}}

2
library/bootstrap/boot-stage2.factor
View File

@ -36,6 +36,7 @@ USE: stdio
"/version.factor"
"/library/kernel.factor"
"/library/stack.factor"
"/library/generic.factor"
"/library/types.factor"
"/library/math/math.factor"
"/library/cons.factor"
@ -50,7 +51,6 @@ USE: stdio
"/library/strings.factor"
"/library/hashtables.factor"
"/library/namespaces.factor"
"/library/generic.factor"
"/library/list-namespaces.factor"
"/library/sbuf.factor"
"/library/continuations.factor"

2
library/bootstrap/boot.factor
View File

@ -38,6 +38,7 @@ primitives,
"/version.factor"
"/library/stack.factor"
"/library/kernel.factor"
"/library/generic.factor"
"/library/types.factor"
"/library/combinators.factor"
"/library/math/math.factor"
@ -52,7 +53,6 @@ primitives,
"/library/strings.factor"
"/library/hashtables.factor"
"/library/namespaces.factor"
"/library/generic.factor"
"/library/list-namespaces.factor"
"/library/sbuf.factor"
"/library/continuations.factor"

31
library/bootstrap/image.factor
View File

@ -42,7 +42,6 @@ IN: image
USE: errors
USE: hashtables
USE: kernel
USE: kernel-internals
USE: lists
USE: math
USE: namespaces
@ -84,6 +83,26 @@ SYMBOL: boot-quot
: 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 ;
@ -135,14 +154,14 @@ SYMBOL: boot-quot
( 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 )

14
library/compiler/linearizer.factor
View File

@ -86,10 +86,16 @@ SYMBOL: #return-to ( push addr on C stack )
: 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
@ -98,11 +104,13 @@ SYMBOL: #return-to ( push addr on C stack )
#! 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

26
library/compiler/optimizer.factor
View File

@ -129,20 +129,23 @@ USE: prettyprint
[ 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 ;
@ -158,17 +161,16 @@ USE: prettyprint
[ 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

73
library/generic.factor
View File

@ -37,7 +37,23 @@ USE: strings
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
@ -63,7 +79,7 @@ SYMBOL: delegate
: 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.
@ -71,20 +87,17 @@ SYMBOL: delegate
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:
@ -93,15 +106,26 @@ SYMBOL: delegate
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 ;
@ -111,23 +135,18 @@ SYMBOL: delegate
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

4
library/httpd/html.factor
View File

@ -143,7 +143,7 @@ M: html-stream fwrite-attr ( str style stream -- )
] 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
@ -159,7 +159,7 @@ C: html-stream ( stream -- 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 ;

5
library/inference/dataflow.factor
View File

@ -40,6 +40,11 @@ SYMBOL: dataflow-graph
! 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 )

2
library/io/ansi.factor
View File

@ -82,7 +82,7 @@ M: ansi-stream fwrite-attr ( string style stream -- )
[
[ 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

4
library/io/network.factor
View File

@ -39,13 +39,13 @@ USE: generic
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 ;

6
library/io/stdio.factor
View File

@ -63,10 +63,10 @@ SYMBOL: stdio
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 ;

14
library/io/stream-impl.factor
View File

@ -41,28 +41,28 @@ USE: generic
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> ;

10
library/io/stream.factor
View File

@ -51,16 +51,16 @@ GENERIC: fclose ( 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
@ -69,4 +69,4 @@ M: string-output-stream fauto-flush ( stream -- )
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 ;

11
library/strings.factor
View File

@ -151,10 +151,7 @@ USE: math
: 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 ;

4
library/syntax/parse-syntax.factor
View File

@ -144,11 +144,11 @@ IN: syntax
: :
#! 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:

20
library/test/generic.factor
View File

@ -6,7 +6,7 @@ USE: test
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
@ -14,20 +14,20 @@ C: test-traits ;C
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"
@ -38,7 +38,7 @@ M: quux foo "foo" swap hash ;M
] unit-test
TRAITS: ctr-test
C: ctr-test [ 5 "x" set ] extend ;C
C: ctr-test [ 5 "x" set ] extend ;
[
5
@ -47,12 +47,12 @@ C: ctr-test [ 5 "x" set ] extend ;C
] 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

3
library/test/lists/assoc.factor
View File

@ -45,6 +45,3 @@ USE: test
[ [ [ "one" + ] [ "four" * ] ] ] [
"three" "quot-alist" get remove-assoc
] unit-test
[ [ "one" "three" "four" ] [ [ + ] [ - ] [ * ] ] ]
[ "quot-alist" get unzip ] unit-test

8
library/test/lists/cons.factor
View File

@ -25,11 +25,3 @@ USE: 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

10
library/test/stream.factor
View File

@ -15,19 +15,19 @@ M: xyzzy-stream fwrite-attr ( str style stream -- )
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>"

8
library/tools/jedit-wire.factor
View File

@ -80,16 +80,16 @@ USE: listener
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.

50
library/types.factor
View File

@ -27,42 +27,22 @@
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

3
library/words.factor
View File

@ -42,11 +42,12 @@ USE: strings
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 ;