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

major bootstrap cleanup

cvs
Slava Pestov 2005-08-20 01:46:12 +00:00
parent 28682c091a
commit c8eacd7b0b
35 changed files with 247 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
TODO.FACTOR.txt
View File

@ -1,3 +1,19 @@
- fix bootstrap failure
- flushing optimization
- add foldable, flushable, inline to all relevant library words
- new prettyprinter
- limit output to n lines
- limit sequences to n elements
- put newlines where necessary
- limit lines to 64 chars
- conditional newlines after certain words
- rename prettyprint* to pprint, prettyprint to pp
- reader syntax for arrays, byte arrays, displaced aliens
- print parsing words in bold
- unify unparse and prettyprint
- split, group: return vectors
- sleep word
+ ui:
- fix listener prompt display after presentation commands invoked
@ -42,7 +58,6 @@
- http keep alive, and range get
- code walker & exceptions
- sleep word
+ ffi:
@ -59,7 +74,6 @@
- changing a word to be 'inline' after it was already defined doesn't
work properly
- inference needs to be more robust with heavily recursive code
- powerpc: float ffi parameters
- fix fixnum<< and /i overflow on PowerPC
- simplifier:
- kill replace after a peek
@ -82,11 +96,9 @@
- powerpc has weird callstack residue
- instances: do not use make-list
- method doc strings
- clean up metaclasses
- vectors: ensure its ok with bignum indices
- code gc
- doc comments of generics
- M: object should not inhibit delegation
+ i/o:
@ -95,13 +107,9 @@
- unix io: handle \n\r and \n\0
- stream server can hang because of exception handler limitations
- better i/o scheduler
- unify unparse and prettyprint
- utf16, utf8 encoding
- fix i/o on generic x86/ppc unix
- if two tasks write to a unix stream, the buffer can overflow
- rename prettyprint* to pprint, prettyprint to pp
- reader syntax for arrays, byte arrays, displaced aliens
- print parsing words in bold
+ nice to have libraries:

9
library/alien/aliens.factor
View File

@ -4,15 +4,6 @@ IN: alien
USING: hashtables io kernel kernel-internals lists math
namespaces parser ;
DEFER: dll?
BUILTIN: dll 15 dll? { 1 "dll-path" f } ;
DEFER: alien?
BUILTIN: alien 16 alien? ;
DEFER: displaced-alien?
BUILTIN: displaced-alien 20 displaced-alien? ;
UNION: c-ptr byte-array alien displaced-alien ;
: NULL ( -- null )

3
library/bootstrap/boot-stage1.factor
View File

@ -118,7 +118,6 @@ parser prettyprint sequences io vectors words ;
] make-list
"object" [ "generic" ] search
"tuple" [ "generic" ] search
"null" [ "generic" ] search
"typemap" [ "generic" ] search
"builtins" [ "generic" ] search
@ -129,7 +128,6 @@ reveal
reveal
reveal
reveal
reveal
[
[
@ -147,7 +145,6 @@ reveal
"/library/generic/slots.factor"
"/library/generic/object.factor"
"/library/generic/null.factor"
"/library/generic/builtin.factor"
"/library/generic/math-combination.factor"
"/library/generic/predicate.factor"
"/library/generic/union.factor"

115
library/bootstrap/primitives.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: image
USING: alien assembler compiler errors files generic generic
hashtables hashtables io io-internals kernel kernel
kernel-internals lists lists math math math-internals memory
namespaces parser parser profiler sequences strings unparser
vectors vectors words words ;
USING: alien generic hashtables io kernel kernel-internals lists
math namespaces sequences strings vectors words ;
! Some very tricky code creating a bootstrap embryo in the
! host image.
"Creating primitives and basic runtime structures..." print
@ -18,12 +18,7 @@ vocabularies
"generic" vocab clone
<namespace> vocabularies set
! Hack
{{ [[ { } null ]] }} typemap set
num-types empty-vector builtins set
<namespace> crossref set
f crossref set
vocabularies get [
"generic" set
@ -231,3 +226,101 @@ vocabularies get [
FORGET: make-primitive
FORGET: set-stack-effect
! Okay, now we have primitives fleshed out. Bring up the generic
! word system.
: builtin-predicate ( class predicate -- )
[ \ type , over types first , \ eq? , ] make-list
define-predicate ;
: register-builtin ( class -- )
dup types first builtins get set-nth ;
: define-builtin ( symbol type# predicate slotspec -- )
>r >r >r
dup intern-symbol
dup r> 1vector "types" set-word-prop
dup builtin define-class
dup r> builtin-predicate
dup r> intern-slots 2dup "slots" set-word-prop
define-slots
register-builtin ;
! Hack
{{ [[ { } null ]] }} typemap set
num-types empty-vector builtins set
"fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
"fixnum" "math" create 0 "math-priority" set-word-prop
"fixnum" "math" create ">fixnum" [ "math" ] search unit "coercer" set-word-prop
"bignum" "math" create 1 "bignum?" "math" create { } define-builtin
"bignum" "math" create 1 "math-priority" set-word-prop
"bignum" "math" create ">bignum" [ "math" ] search unit "coercer" set-word-prop
"cons" "lists" create 2 "cons?" "lists" create
{ { 0 { "car" "lists" } f } { 1 { "cdr" "lists" } f } } define-builtin
"ratio" "math" create 4 "ratio?" "math" create
{ { 0 { "numerator" "math" } f } { 1 { "denominator" "math" } f } } define-builtin
"ratio" "math" create 2 "math-priority" set-word-prop
"float" "math" create 5 "float?" "math" create { } define-builtin
"float" "math" create 3 "math-priority" set-word-prop
"float" "math" create ">float" [ "math" ] search unit "coercer" set-word-prop
"complex" "math" create 6 "complex?" "math" create
{ { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin
"complex" "math" create 4 "math-priority" set-word-prop
"t" "!syntax" create 7 "t?" "kernel" create
{ } define-builtin
"array" "kernel-internals" create 8 "array?" "kernel-internals" create
{ } define-builtin
"f" "!syntax" create 9 "not" "kernel" create
{ } define-builtin
"hashtable" "hashtables" create 10 "hashtable?" "hashtables" create {
{ 1 { "hash-size" "hashtables" } { "set-hash-size" "kernel-internals" } }
{ 2 { "hash-array" "kernel-internals" } { "set-hash-array" "kernel-internals" } }
} define-builtin
"vector" "vectors" create 11 "vector?" "vectors" create {
{ 1 { "length" "sequences" } { "set-capacity" "kernel-internals" } }
{ 2 { "underlying" "kernel-internals" } { "set-underlying" "kernel-internals" } }
} define-builtin
"string" "strings" create 12 "string?" "strings" create {
{ 1 { "length" "sequences" } f }
{ 2 { "hashcode" "kernel" } f }
} define-builtin
"sbuf" "strings" create 13 "sbuf?" "strings" create {
{ 1 { "length" "sequences" } { "set-capacity" "kernel-internals" } }
{ 2 { "underlying" "kernel-internals" } { "set-underlying" "kernel-internals" } }
} define-builtin
"wrapper" "kernel" create 14 "wrapper?" "kernel" create
{ { 1 { "wrapped" "kernel" } f } } define-builtin
"dll" "alien" create 15 "dll?" "alien" create
{ { 1 { "dll-path" "alien" } f } } define-builtin
"alien" "alien" create 16 "alien?" "alien" create { } define-builtin
"word" "words" create 17 "word?" "words" create {
{ 1 { "hashcode" "kernel" } f }
{ 4 { "word-def" "words" } { "set-word-def" "words" } }
{ 5 { "word-props" "words" } { "set-word-props" "words" } }
} define-builtin
"tuple" "kernel" create 18 "tuple?" "kernel" create { } define-builtin
"displaced-alien" "alien" create 20 "displaced-alien?" "alien" create { } define-builtin
FORGET: builtin-predicate
FORGET: register-builtin
FORGET: define-builtin

3
library/collections/arrays.factor
View File

@ -17,9 +17,6 @@ DEFER: repeat
IN: kernel-internals
USING: kernel math-internals sequences ;
DEFER: array?
BUILTIN: array 8 array? ;
: array-capacity ( a -- n ) 1 slot ; inline
: array-nth ( n a -- obj ) swap 2 fixnum+ slot ; inline
: set-array-nth ( obj n a -- ) swap 2 fixnum+ set-slot ; inline

3
library/collections/cons.factor
View File

@ -6,9 +6,6 @@ IN: lists USING: generic kernel sequences ;
! else depends on, and is loaded early in bootstrap.
! lists.factor has everything else.
DEFER: cons?
BUILTIN: cons 2 cons? { 0 "car" f } { 1 "cdr" f } ;
! We borrow an idiom from Common Lisp. The car/cdr of an empty
! list is the empty list.
M: f car ;

16
library/collections/hashtables.factor
View File

@ -1,20 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel-internals
DEFER: hash-array
DEFER: set-hash-array
DEFER: set-hash-size
IN: hashtables
USING: generic kernel lists math sequences vectors ;
! We put hash-size in the hashtables vocabulary, and
! the other words in kernel-internals.
DEFER: hashtable?
BUILTIN: hashtable 10 hashtable?
{ 1 "hash-size" set-hash-size }
{ 2 hash-array set-hash-array } ;
USING: generic kernel lists math sequences vectors
kernel-internals ;
! A hashtable is implemented as an array of buckets. The
! array index is determined using a hash function, and the

5
library/collections/sbuf.factor
View File

@ -10,11 +10,6 @@ USING: generic sequences ;
M: string resize resize-string ;
DEFER: sbuf?
BUILTIN: sbuf 13 sbuf?
{ 1 length set-capacity }
{ 2 underlying set-underlying } ;
M: sbuf set-length ( n sbuf -- ) grow-length ;
M: sbuf nth ( n sbuf -- ch ) bounds-check underlying char-slot ;

3
library/collections/sequences-epilogue.factor
View File

@ -34,6 +34,9 @@ M: object each ( seq quot -- )
[ [ swap >r >r uncons r> 2nth r> call ] 3keep ] repeat
2drop ; inline
: 2reduce ( seq seq identity quot -- value | quot: e x y -- z )
>r -rot r> 2each ; inline
: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
over [
length <vector> 2swap

4
library/collections/strings.factor
View File

@ -3,10 +3,6 @@
IN: strings
USING: generic kernel kernel-internals lists math sequences ;
! Strings
DEFER: string?
BUILTIN: string 12 string? { 1 length f } { 2 hashcode f } ;
M: string nth ( n str -- ch ) bounds-check char-slot ;
GENERIC: >string ( seq -- string )

5
library/collections/vectors.factor
View File

@ -4,11 +4,6 @@ IN: vectors
USING: errors generic kernel kernel-internals lists math
math-internals sequences ;
DEFER: vector?
BUILTIN: vector 11 vector?
{ 1 length set-capacity }
{ 2 underlying set-underlying } ;
M: vector set-length ( len vec -- ) grow-length ;
M: vector nth ( n vec -- obj ) bounds-check underlying array-nth ;

4
library/compiler/intrinsics.factor
View File

@ -56,6 +56,10 @@ sequences vectors words ;
: node-peek ( node -- value ) node-in-d peek ;
: type-tag ( type -- tag )
#! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ;
: value-tag ( value node -- n/f )
#! If the tag is known, output it, otherwise f.
node-classes hash dup [

36
library/generic/builtin.factor
View File

@ -1,36 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
USING: errors hashtables kernel lists math namespaces parser
sequences strings vectors words ;
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
! Global vector mapping type numbers to builtin class objects.
SYMBOL: builtins
: builtin-predicate ( class predicate -- )
[ \ type , over types first , \ eq? , ] make-list
define-predicate ;
: register-builtin ( class -- )
dup types first builtins get set-nth ;
: define-builtin ( symbol type# predicate slotspec -- )
>r >r >r
dup intern-symbol
dup r> 1vector "types" set-word-prop
dup builtin define-class
dup r> builtin-predicate
dup r> intern-slots 2dup "slots" set-word-prop
define-slots
register-builtin ;
: type>class ( n -- symbol ) builtins get nth ;
PREDICATE: word builtin metaclass builtin = ;
: type-tag ( type -- tag )
#! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ;

8
library/generic/generic.factor
View File

@ -14,6 +14,14 @@ SYMBOL: typemap
SYMBOL: object
SYMBOL: null
! Global vector mapping type numbers to builtin class objects.
SYMBOL: builtins
! Builtin metaclass
SYMBOL: builtin
: type>class ( n -- symbol ) builtins get nth ;
: predicate-word ( word -- word )
word-name "?" append create-in ;

2
library/generic/math-combination.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
USING: errors generic hashtables kernel kernel-internals lists
math namespaces sequences words ;

14
library/generic/slots.factor
View File

@ -29,12 +29,8 @@ sequences strings vectors words ;
: define-slot ( class slot reader writer -- )
>r >r 2dup r> define-reader r> define-writer ;
: ?create-in dup string? [ create-in ] when ;
: intern-slots ( spec -- spec )
#! For convenience, we permit reader/writers to be specified
#! as strings.
[ 3unseq swap ?create-in swap ?create-in 3vector ] map ;
[ 3unseq swap 2unseq create swap 2unseq create 3vector ] map ;
: define-slots ( class spec -- )
#! Define a collection of slot readers and writers for the
@ -44,10 +40,11 @@ sequences strings vectors words ;
[ 3unseq define-slot ] each-with ;
: reader-word ( class name -- word )
>r word-name "-" r> append3 create-in ;
>r word-name "-" r> append3 "in" get 2vector ;
: writer-word ( class name -- word )
[ swap "set-" % word-name % "-" % % ] make-string create-in ;
[ swap "set-" % word-name % "-" % % ] make-string
"in" get 2vector ;
: simple-slot ( class name -- reader writer )
[ reader-word ] 2keep writer-word ;
@ -58,4 +55,5 @@ sequences strings vectors words ;
#! set-<class>-<slot>. Slot numbering is consecutive and
#! begins at base.
over length [ + ] map-with
[ >r dupd simple-slot r> -rot 3vector ] 2map nip ;
[ >r dupd simple-slot r> -rot 3vector ] 2map nip
intern-slots ;

15
library/generic/tuple.factor
View File

@ -12,9 +12,6 @@ namespaces parser sequences strings vectors words ;
! slot 2 - the class, a word
! slot 3 - the delegate tuple, or f
DEFER: tuple?
BUILTIN: tuple 18 tuple? ;
: delegate ( object -- delegate )
dup tuple? [ 3 slot ] [ drop f ] ifte ; inline
@ -47,12 +44,13 @@ BUILTIN: tuple 18 tuple? ;
r> 2drop
] ifte ;
: delegate-slots { { 3 delegate set-delegate } } ;
: tuple-slots ( tuple slots -- )
2dup "slot-names" set-word-prop
2dup length 2 + "tuple-size" set-word-prop
dupd 4 simple-slots
2dup { [ 3 delegate set-delegate ] } swap append
"slots" set-word-prop
2dup delegate-slots swap append "slots" set-word-prop
define-slots ;
: tuple-constructor ( class -- word )
@ -83,11 +81,8 @@ BUILTIN: tuple 18 tuple? ;
TUPLE: mirror tuple ;
C: mirror ( tuple -- mirror )
over tuple? [
[ set-mirror-tuple ] keep
] [
"Not a tuple" throw
] ifte ;
over tuple? [ "Not a tuple" throw ] unless
[ set-mirror-tuple ] keep ;
M: mirror nth ( n mirror -- elt )
bounds-check mirror-tuple array-nth ;

23
library/io/lines.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io
USING: errors generic io kernel math namespaces sequences ;
USING: errors generic io kernel math namespaces sequences
vectors ;
TUPLE: line-reader cr ;
@ -40,19 +41,9 @@ M: line-reader stream-read ( count line -- string )
drop
] ifte ;
! Reading lines and counting line numbers.
SYMBOL: line-number
SYMBOL: parser-stream
: (lines) ( seq -- seq )
readln [ over push (lines) ] when* ;
: next-line ( -- str )
parser-stream get stream-readln
line-number [ 1 + ] change ;
: read-lines ( stream quot -- )
#! Apply a quotation to each line as its read. Close the
#! stream.
swap [
parser-stream set 0 line-number set [ next-line ] while
] [
parser-stream get stream-close rethrow
] catch ;
: lines ( stream -- seq )
#! Read all lines from the stream into a sequence.
[ 100 <vector> (lines) ] with-stream ;

70
library/io/stdio.factor
View File

@ -1,33 +1,37 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io
USING: errors generic kernel lists namespaces strings styles ;
: flush ( -- ) stdio get stream-flush ;
: readln ( -- string/f ) stdio get stream-readln ;
: read1 ( -- char/f ) stdio get stream-read1 ;
: read ( count -- string ) stdio get stream-read ;
: write ( string -- ) stdio get stream-write ;
: write1 ( char -- ) stdio get stream-write1 ;
: format ( string style -- ) stdio get stream-format ;
: print ( string -- ) stdio get stream-print ;
: terpri ( -- ) stdio get stream-terpri ;
: close ( -- ) stdio get stream-close ;
: crlf ( -- ) "\r\n" write ;
: bl ( -- ) " " write ;
: write-icon ( resource -- )
#! Write an icon. Eg, /library/icons/File.png
icon swons unit "" swap format ;
: with-stream ( stream quot -- )
#! Close the stream no matter what happens.
[ swap stdio set [ close rethrow ] catch ] with-scope ;
: with-stream* ( stream quot -- )
#! Close the stream if there is an error.
[
swap stdio set
[ [ close rethrow ] when* ] catch
] with-scope ;
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io
USING: errors generic kernel lists namespaces strings styles ;
: flush ( -- ) stdio get stream-flush ;
: readln ( -- string/f ) stdio get stream-readln ;
: read1 ( -- char/f ) stdio get stream-read1 ;
: read ( count -- string ) stdio get stream-read ;
: write ( string -- ) stdio get stream-write ;
: write1 ( char -- ) stdio get stream-write1 ;
: format ( string style -- ) stdio get stream-format ;
: print ( string -- ) stdio get stream-print ;
: terpri ( -- ) stdio get stream-terpri ;
: close ( -- ) stdio get stream-close ;
: crlf ( -- ) "\r\n" write ;
: bl ( -- ) " " write ;
: write-icon ( resource -- )
#! Write an icon. Eg, /library/icons/File.png
icon swons unit "" swap format ;
: with-stream ( stream quot -- )
#! Close the stream no matter what happens.
[ swap stdio set [ close rethrow ] catch ] with-scope ;
: with-stream* ( stream quot -- )
#! Close the stream if there is an error.
[
swap stdio set
[ [ close rethrow ] when* ] catch
] with-scope ;
: contents ( stream -- string )
#! Read the entire stream into a string.
4096 <sbuf> [ stream-copy ] keep >string ;

16
library/kernel.factor
View File

@ -46,17 +46,10 @@ M: object clone ;
#! Push t if cond is true, otherwise push f.
rot [ drop ] [ nip ] ifte ; inline
DEFER: wrapper?
BUILTIN: wrapper 14 wrapper? { 1 "wrapped" f } ;
M: wrapper = ( obj wrapper -- ? )
over wrapper?
[ swap wrapped swap wrapped = ] [ 2drop f ] ifte ;
! defined in parse-syntax.factor
DEFER: not
DEFER: t?
: >boolean t f ? ; inline
: and ( a b -- a&b ) f ? ; inline
: or ( a b -- a|b ) t swap ? ; inline
@ -93,15 +86,6 @@ DEFER: t?
: 3keep ( x y z quot -- x y z | quot: x y z -- )
>r 3dup r> swap >r swap >r swap >r call r> r> r> ; inline
: while ( quot generator -- )
#! Keep applying the quotation to the value produced by
#! calling the generator until the generator returns f.
2dup >r >r swap >r call dup [
r> call r> r> while
] [
r> 2drop r> r> 2drop
] ifte ; inline
: ifte* ( cond true false -- | true: cond -- | false: -- )
#! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte
pick [ drop call ] [ 2nip call ] ifte ; inline

4
library/math/complex.factor
View File

@ -10,10 +10,6 @@ USING: errors generic kernel kernel-internals math ;
IN: math
DEFER: complex?
BUILTIN: complex 6 complex? { 0 "real" f } { 1 "imaginary" f } ;
MATH-CLASS: complex 4 f
UNION: number real complex ;
M: real real ;

4
library/math/float.factor
View File

@ -3,10 +3,6 @@
IN: math
USING: generic kernel math-internals ;
DEFER: float?
BUILTIN: float 5 float? ;
MATH-CLASS: float 3 >float
UNION: real rational float ;
M: real abs dup 0 < [ neg ] when ;

8
library/math/integer.factor
View File

@ -3,14 +3,6 @@
IN: math
USING: errors generic kernel math sequences ;
DEFER: fixnum?
BUILTIN: fixnum 0 fixnum? ;
MATH-CLASS: fixnum 0 >fixnum
DEFER: bignum?
BUILTIN: bignum 1 bignum? ;
MATH-CLASS: bignum 1 >bignum
UNION: integer fixnum bignum ;
: (gcd) ( b a y x -- a d )

4
library/math/matrices.factor
View File

@ -34,8 +34,8 @@ USING: generic kernel sequences vectors ;
: set-axis ( x y axis -- v )
2dup v* >r >r drop dup r> v* v- r> v+ ;
: v. ( v v -- x ) 0 -rot [ * + ] 2each ;
: c. ( v v -- x ) 0 -rot [ conjugate * + ] 2each ;
: v. ( v v -- x ) 0 [ * + ] 2reduce ;
: c. ( v v -- x ) 0 [ conjugate * + ] 2reduce ;
: norm-sq ( v -- n ) 0 [ absq + ] reduce ;

4
library/math/ratio.factor
View File

@ -3,10 +3,6 @@
IN: math
USING: generic kernel kernel-internals math math-internals ;
DEFER: ratio?
BUILTIN: ratio 4 ratio? { 0 "numerator" f } { 1 "denominator" f } ;
MATH-CLASS: ratio 2 f
UNION: rational integer ratio ;
M: integer numerator ;

11
library/syntax/generic.factor
View File

@ -13,10 +13,6 @@ USING: syntax generic kernel lists namespaces parser words ;
#! G: word picker dispatcher ;
CREATE [ 2unlist rot define-generic* ] [ ] ; parsing
: BUILTIN:
#! Syntax: BUILTIN: <class> <type#> <predicate> <slots> ;
CREATE scan-word scan-word [ define-builtin ] [ ] ; parsing
: COMPLEMENT: ( -- )
#! Followed by a class name, then a complemented class.
CREATE
@ -57,10 +53,3 @@ USING: syntax generic kernel lists namespaces parser words ;
#! stack.
scan-word [ tuple-constructor ] keep
[ define-constructor ] [ ] ; parsing
: MATH-CLASS:
#! Followed by class name, priority, and coercer.
scan-word
dup scan-word "math-priority" set-word-prop
scan-word dup \ f = [ drop f ] [ unit ] ifte
"coercer" set-word-prop ; parsing

76
library/syntax/parse-stream.factor
View File

@ -1,36 +1,40 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: parser
USING: kernel lists namespaces sequences io ;
: file-vocabs ( -- )
"scratchpad" "in" set
[ "syntax" "scratchpad" ] "use" set ;
: (parse-stream) ( stream -- quot )
[ f swap [ (parse) ] read-lines reverse ] with-parser ;
: parse-stream ( name stream -- quot )
[
swap file set file-vocabs
(parse-stream)
file off line-number off
] with-scope ;
: parse-file ( file -- quot )
dup <file-reader> parse-stream ;
: run-file ( file -- )
parse-file call ;
: parse-resource ( path -- quot )
#! Resources are loaded from the resource-path variable, or
#! the current directory if it is not set. Words defined in
#! resources have a definition source path starting with
#! resource:. This allows words that operate on source
#! files, like "jedit", to use a different resource path
#! at run time than was used at parse time.
"resource:" over append swap <resource-stream> parse-stream ;
: run-resource ( file -- )
parse-resource call ;
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: parser
USING: kernel lists namespaces sequences io ;
: file-vocabs ( -- )
"scratchpad" "in" set
[ "syntax" "scratchpad" ] "use" set ;
: (parse-stream) ( stream -- quot )
[
lines dup length [ ]
[ line-number set (parse) ] 2reduce
reverse
] with-parser ;
: parse-stream ( name stream -- quot )
[
swap file set file-vocabs
(parse-stream)
file off line-number off
] with-scope ;
: parse-file ( file -- quot )
dup <file-reader> parse-stream ;
: run-file ( file -- )
parse-file call ;
: parse-resource ( path -- quot )
#! Resources are loaded from the resource-path variable, or
#! the current directory if it is not set. Words defined in
#! resources have a definition source path starting with
#! resource:. This allows words that operate on source
#! files, like "jedit", to use a different resource path
#! at run time than was used at parse time.
"resource:" over append swap <resource-stream> parse-stream ;
: run-resource ( file -- )
parse-resource call ;

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

@ -36,14 +36,8 @@ words ;
! Booleans
! The canonical t is a heap-allocated dummy object.
BUILTIN: t 7 t? ;
: t t swons ; parsing
! In the runtime, the canonical f is represented as a null
! pointer with tag 3. So
! f address . ==> 3
BUILTIN: f 9 not ;
: f f swons ; parsing
! Lists

2
library/syntax/parse-words.factor
View File

@ -14,6 +14,8 @@ strings unparser words ;
! of vocabularies. If it is a parsing word, it is executed
! immediately. Otherwise it is appended to the parse tree.
SYMBOL: line-number
: use+ ( string -- ) "use" [ cons ] change ;
: parsing? ( word -- ? )

7
library/syntax/see.factor
View File

@ -101,13 +101,6 @@ M: complement class.
dup unparse. bl
"complement" word-prop unparse. terpri ;
M: builtin class.
\ BUILTIN: unparse. bl
dup unparse. bl
dup types first unparse write bl
0 swap "slots" word-prop prettyprint-elements drop
prettyprint-; ;
M: predicate class.
\ PREDICATE: unparse. bl
dup "superclass" word-prop unparse. bl

4
library/test/combinators.factor
View File

@ -31,10 +31,6 @@ USE: namespaces
[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?ifte ] string-out ] unit-test
[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?ifte ] string-out ] unit-test
[ [ 9 8 7 6 5 4 3 2 1 ] ]
[ [ 10 [ , ] [ 1 - dup dup 0 = [ drop f ] when ] while ] make-list nip ]
unit-test
[ "even" ] [
2 {
{ [ dup 2 mod 0 = ] [ drop "even" ] }

8
library/tools/memory.factor
View File

@ -35,13 +35,17 @@ vectors words ;
! Some words for iterating through the heap.
: (each-object) ( quot -- )
next-object [ swap [ call ] keep (each-object) ] when* ;
inline
: each-object ( quot -- )
#! Applies the quotation to each object in the image. We
#! use the lower-level >c and c> words here to avoid
#! copying the stacks.
[ end-scan rethrow ] >c
begin-scan [ next-object ] while
f c> call ;
begin-scan (each-object) drop
f c> call ; inline
: instances ( quot -- list )
#! Return a list of all object that return true when the

5
library/words.factor
View File

@ -6,11 +6,6 @@ namespaces sequences strings vectors ;
! The basic word type. Words can be named and compared using
! identity. They hold a property map.
DEFER: word?
BUILTIN: word 17 word?
{ 1 hashcode f }
{ 4 "word-def" "set-word-def" }
{ 5 "word-props" "set-word-props" } ;
: word-prop ( word name -- value ) swap word-props hash ;
: set-word-prop ( word value name -- ) rot word-props set-hash ;

4
native/factor.c
View File

@ -10,8 +10,10 @@ void init_factor(char* image, CELL ds_size, CELL cs_size,
init_ffi();
init_arena(gen_count,young_size,aging_size);
init_compiler(code_size);
load_image(image,literal_size);
init_stacks(ds_size,cs_size);
callframe = F;
load_image(image,literal_size);
callframe = userenv[BOOT_ENV];
init_c_io();
init_signals();
init_errors();

1
native/stack.c
View File

@ -30,7 +30,6 @@ void init_stacks(CELL ds_size_, CELL cs_size_)
reset_datastack();
cs_bot = (CELL)alloc_guarded(cs_size);
reset_callstack();
callframe = userenv[BOOT_ENV];
}
void primitive_drop(void)