+- fix bootstrap failure\r
+- flushing optimization\r
+- add foldable, flushable, inline to all relevant library words\r
+- new prettyprinter\r
+ - limit output to n lines\r
+ - limit sequences to n elements\r
+ - put newlines where necessary\r
+ - limit lines to 64 chars\r
+ - conditional newlines after certain words\r
+ - rename prettyprint* to pprint, prettyprint to pp\r
+ - reader syntax for arrays, byte arrays, displaced aliens\r
+ - print parsing words in bold\r
+ - unify unparse and prettyprint\r
+- split, group: return vectors\r
+- sleep word\r
+\r
+ ui:\r
\r
- fix listener prompt display after presentation commands invoked\r
\r
- http keep alive, and range get\r
- code walker & exceptions\r
-- sleep word\r
\r
+ ffi:\r
\r
- changing a word to be 'inline' after it was already defined doesn't\r
work properly\r
- inference needs to be more robust with heavily recursive code\r
-- powerpc: float ffi parameters\r
- fix fixnum<< and /i overflow on PowerPC\r
- simplifier:\r
- kill replace after a peek\r
- powerpc has weird callstack residue\r
- instances: do not use make-list\r
- method doc strings\r
-- clean up metaclasses\r
- vectors: ensure its ok with bignum indices\r
- code gc\r
- doc comments of generics\r
-- M: object should not inhibit delegation\r
\r
+ i/o:\r
\r
- unix io: handle \n\r and \n\0\r
- stream server can hang because of exception handler limitations\r
- better i/o scheduler\r
-- unify unparse and prettyprint\r
- utf16, utf8 encoding\r
- fix i/o on generic x86/ppc unix\r
- if two tasks write to a unix stream, the buffer can overflow\r
-- rename prettyprint* to pprint, prettyprint to pp\r
-- reader syntax for arrays, byte arrays, displaced aliens\r
-- print parsing words in bold\r
\r
+ nice to have libraries:\r
\r
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 )
] make-list
"object" [ "generic" ] search
-"tuple" [ "generic" ] search
"null" [ "generic" ] search
"typemap" [ "generic" ] search
"builtins" [ "generic" ] search
reveal
reveal
reveal
-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"
! 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
"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
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
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
! 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 ;
! 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
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 ;
[ [ 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
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 )
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 ;
: 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 [
+++ /dev/null
-! 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 ;
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 ;
+! 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 ;
: 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
[ 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 ;
#! 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 ;
! 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
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 )
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 ;
! 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 ;
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 ;
-! 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.\r
+! See http://factor.sf.net/license.txt for BSD license.\r
+IN: io\r
+USING: errors generic kernel lists namespaces strings styles ;\r
+\r
+: flush ( -- ) stdio get stream-flush ;\r
+: readln ( -- string/f ) stdio get stream-readln ;\r
+: read1 ( -- char/f ) stdio get stream-read1 ;\r
+: read ( count -- string ) stdio get stream-read ;\r
+: write ( string -- ) stdio get stream-write ;\r
+: write1 ( char -- ) stdio get stream-write1 ;\r
+: format ( string style -- ) stdio get stream-format ;\r
+: print ( string -- ) stdio get stream-print ;\r
+: terpri ( -- ) stdio get stream-terpri ;\r
+: close ( -- ) stdio get stream-close ;\r
+\r
+: crlf ( -- ) "\r\n" write ;\r
+: bl ( -- ) " " write ;\r
+\r
+: write-icon ( resource -- )\r
+ #! Write an icon. Eg, /library/icons/File.png\r
+ icon swons unit "" swap format ;\r
+\r
+: with-stream ( stream quot -- )\r
+ #! Close the stream no matter what happens.\r
+ [ swap stdio set [ close rethrow ] catch ] with-scope ;\r
+\r
+: with-stream* ( stream quot -- )\r
+ #! Close the stream if there is an error.\r
+ [\r
+ swap stdio set\r
+ [ [ close rethrow ] when* ] catch\r
+ ] with-scope ;\r
+\r
+: contents ( stream -- string )\r
+ #! Read the entire stream into a string.\r
+ 4096 <sbuf> [ stream-copy ] keep >string ;\r
#! 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
: 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
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 ;
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 ;
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 )
: 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 ;
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 ;
#! 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
#! 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
-! 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.\r
+! See http://factor.sf.net/license.txt for BSD license.\r
+IN: parser\r
+USING: kernel lists namespaces sequences io ;\r
+\r
+: file-vocabs ( -- )\r
+ "scratchpad" "in" set\r
+ [ "syntax" "scratchpad" ] "use" set ;\r
+\r
+: (parse-stream) ( stream -- quot )\r
+ [\r
+ lines dup length [ ]\r
+ [ line-number set (parse) ] 2reduce\r
+ reverse\r
+ ] with-parser ;\r
+\r
+: parse-stream ( name stream -- quot )\r
+ [\r
+ swap file set file-vocabs\r
+ (parse-stream)\r
+ file off line-number off\r
+ ] with-scope ;\r
+\r
+: parse-file ( file -- quot )\r
+ dup <file-reader> parse-stream ;\r
+\r
+: run-file ( file -- )\r
+ parse-file call ;\r
+\r
+: parse-resource ( path -- quot )\r
+ #! Resources are loaded from the resource-path variable, or\r
+ #! the current directory if it is not set. Words defined in\r
+ #! resources have a definition source path starting with\r
+ #! resource:. This allows words that operate on source\r
+ #! files, like "jedit", to use a different resource path\r
+ #! at run time than was used at parse time.\r
+ "resource:" over append swap <resource-stream> parse-stream ;\r
+\r
+: run-resource ( file -- )\r
+ parse-resource call ;\r
! 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
! 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 -- ? )
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
[ "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" ] }
! 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
! 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 ;
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();
reset_datastack();
cs_bot = (CELL)alloc_guarded(cs_size);
reset_callstack();
- callframe = userenv[BOOT_ENV];
}
void primitive_drop(void)
projects / factor.git / commitdiff