\r
+ compiler:\r
\r
+- slot compilation\r
+- optimize away dispatch\r
- getenv/setenv: if literal arg, compile as a load/store\r
- assembler opcodes dispatch on operand types\r
- save code in image\r
\r
- make see work with generics\r
- doc comments of generics\r
+- redo traits with generic method map\r
\r
+ ffi:\r
\r
- remove sbufs\r
- cat, reverse-cat primitives\r
- first-class hashtables\r
-- rewrite accessors and mutators in Factor, with slot/set-slot primitive\r
- add a socket timeout\r
- do transfer-word in fixup\r
-- move dispatch getenv setenv to kernel-internals\r
\r
+ misc:\r
\r
- jedit ==> jedit-word, jedit takes a file name\r
- nicer way to combine two paths\r
- ditch object paths\r
-- browser responder for word links in HTTPd; inspect responder for\r
- objects\r
+- browser responder for word links in HTTPd\r
- worddef props\r
- prettyprint: when unparse called due to recursion, write a link\r
\r
"/library/io/files.factor"\r
"/library/eval-catch.factor"\r
"/library/tools/listener.factor"\r
- "/library/tools/inspector.factor"\r
"/library/tools/word-tools.factor"\r
"/library/test/test.factor"\r
"/library/io/ansi.factor"\r
"/library/httpd/responder.factor"\r
"/library/httpd/httpd.factor"\r
"/library/httpd/file-responder.factor"\r
- "/library/httpd/inspect-responder.factor"\r
"/library/httpd/test-responder.factor"\r
"/library/httpd/quit-responder.factor"\r
"/library/httpd/resource-responder.factor"\r
USE: presentation
USE: words
USE: unparser
+USE: kernel-internals
: cli-args ( -- args ) 10 getenv ;
[ "kernel" | "call" ]
[ "kernel" | "ifte" ]
[ "lists" | "cons" ]
- [ "lists" | "car" ]
- [ "lists" | "cdr" ]
[ "vectors" | "<vector>" ]
- [ "vectors" | "vector-length" ]
- [ "vectors" | "set-vector-length" ]
[ "vectors" | "vector-nth" ]
[ "vectors" | "set-vector-nth" ]
- [ "strings" | "str-length" ]
[ "strings" | "str-nth" ]
[ "strings" | "str-compare" ]
[ "strings" | "str=" ]
[ "math" | ">fixnum" ]
[ "math" | ">bignum" ]
[ "math" | ">float" ]
- [ "math" | "numerator" ]
- [ "math" | "denominator" ]
- [ "math" | "fraction>" ]
+ [ "math-internals" | "(fraction>)" ]
[ "parser" | "str>float" ]
[ "unparser" | "(unparse-float)" ]
- [ "math" | "float>bits" ]
- [ "math" | "real" ]
- [ "math" | "imaginary" ]
- [ "math" | "rect>" ]
+ [ "math-internals" | "(rect>)" ]
[ "math-internals" | "fixnum=" ]
[ "math-internals" | "fixnum+" ]
[ "math-internals" | "fixnum-" ]
[ "math-internals" | "fsinh" ]
[ "math-internals" | "fsqrt" ]
[ "words" | "<word>" ]
- [ "words" | "word-hashcode" ]
- [ "words" | "word-xt" ]
- [ "words" | "set-word-xt" ]
- [ "words" | "word-primitive" ]
- [ "words" | "set-word-primitive" ]
- [ "words" | "word-parameter" ]
- [ "words" | "set-word-parameter" ]
- [ "words" | "word-plist" ]
- [ "words" | "set-word-plist" ]
+ [ "words" | "update-xt" ]
[ "profiler" | "call-profiling" ]
- [ "profiler" | "call-count" ]
- [ "profiler" | "set-call-count" ]
[ "profiler" | "allot-profiling" ]
- [ "profiler" | "allot-count" ]
- [ "profiler" | "set-allot-count" ]
[ "words" | "compiled?" ]
[ "kernel" | "drop" ]
[ "kernel" | "dup" ]
[ "kernel" | ">r" ]
[ "kernel" | "r>" ]
[ "kernel" | "eq?" ]
- [ "kernel" | "getenv" ]
- [ "kernel" | "setenv" ]
+ [ "kernel-internals" | "getenv" ]
+ [ "kernel-internals" | "setenv" ]
[ "io-internals" | "open-file" ]
[ "files" | "stat" ]
[ "files" | "(directory)" ]
[ "files" | "cd" ]
[ "compiler" | "compiled-offset" ]
[ "compiler" | "set-compiled-offset" ]
- [ "compiler" | "set-compiled-cell" ]
- [ "compiler" | "set-compiled-byte" ]
[ "compiler" | "literal-top" ]
[ "compiler" | "set-literal-top" ]
[ "kernel" | "address" ]
[ "kernel-internals" | "memory>string" ]
[ "alien" | "local-alien?" ]
[ "alien" | "alien-address" ]
+ [ "lists" | ">cons" ]
+ [ "vectors" | ">vector" ]
+ [ "strings" | ">string" ]
+ [ "words" | ">word" ]
+ [ "kernel-internals" | "slot" ]
+ [ "kernel-internals" | "set-slot" ]
+ [ "kernel-internals" | "integer-slot" ]
+ [ "kernel-internals" | "set-integer-slot" ]
+ [ "kernel-internals" | "grow-array" ]
] [
unswons create swap succ [ f define ] keep
] each drop
?run-file
] when ;
-: cli-var-param ( name value -- )
- swap ":" split set-object-path ;
+: set-path ( value list -- )
+ unswons over [ nest [ set-path ] bind ] [ nip set ] ifte ;
+
+: cli-var-param ( name value -- ) swap ":" split set-path ;
+
+: cli-bool-param ( name -- ) "no-" ?str-head not put ;
: cli-param ( param -- )
#! Handle a command-line argument starting with '-' by
#!
#! Arguments containing = are handled differently; they
#! set the object path.
- "=" split1 [
- cli-var-param
- ] [
- "no-" ?str-head not put
- ] ifte* ;
+ "=" split1 [ cli-var-param ] [ cli-bool-param ] ifte* ;
: cli-arg ( argument -- argument )
#! Handle a command-line argument. If the argument was
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: kernel
-USE: lists
: slip ( quot x -- x )
>r call r> ; inline
#! Apply code to input.
swap dup >r call r> swap ; inline
-IN: lists DEFER: uncons IN: kernel
-: cond ( x list -- )
- #! The list is of this form:
- #!
- #! [ [ condition 1 ] [ code 1 ]
- #! [ condition 2 ] [ code 2 ]
- #! ... ]
- #!
- #! Each condition is evaluated in turn. If it returns true,
- #! the code is evaluated. If it returns false, the next
- #! condition is checked.
- #!
- #! Before evaluating each condition, the top of the stack is
- #! duplicated. After the last condition is evaluated, the
- #! top of the stack is popped.
- #!
- #! So each condition and code block must have stack effect:
- #! ( X -- )
- #!
- #! This combinator will not compile.
- dup [
- uncons >r over >r call r> r> rot [
- car call
- ] [
- cdr cond
- ] ifte
- ] [
- 2drop
- ] ifte ;
-
: ifte* ( cond true false -- )
#! If the condition is not f, execute the 'true' quotation,
#! with the condition on the stack. Otherwise, pop the
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
+USE: alien
USE: math
USE: kernel
-: cell 4 ;
-: literal-table 1024 cell * ;
+: cell 4 ; inline
+: literal-table 1024 cell * ; inline
: init-assembler ( -- )
compiled-offset literal-table + set-compiled-offset ;
+: set-compiled-byte ( n addr -- )
+ <alien> 0 set-alien-1 ; inline
+
+: set-compiled-cell ( n addr -- )
+ <alien> 0 set-alien-cell ; inline
+
: compile-aligned ( n -- )
- compiled-offset swap align set-compiled-offset ;
+ compiled-offset swap align set-compiled-offset ; inline
: intern-literal ( obj -- lit# )
address
: compile-byte ( n -- )
compiled-offset set-compiled-byte
- compiled-offset 1 + set-compiled-offset ;
+ compiled-offset 1 + set-compiled-offset ; inline
: compile-cell ( n -- )
compiled-offset set-compiled-cell
- compiled-offset cell + set-compiled-offset ;
+ compiled-offset cell + set-compiled-offset ; inline
IN: lists
USE: generic
USE: kernel
+USE: kernel-internals
! This file contains vital list-related words that everything
! else depends on, and is loaded early in bootstrap.
BUILTIN: cons 2
+: car ( [ car | cdr ] -- car ) >cons 0 slot ; inline
+: cdr ( [ car | cdr ] -- cdr ) >cons 1 slot ; inline
+
: swons ( cdr car -- [ car | cdr ] )
#! Push a new cons cell. If the cdr is f or a proper list,
#! has the effect of prepending the car to the cdr.
IN: errors
USE: kernel
+USE: kernel-internals
USE: lists
USE: math
USE: namespaces
USE: errors
USE: hashtables
USE: kernel
+USE: kernel-internals
USE: lists
USE: namespaces
USE: parser
[ test-responder ] "get" set
] extend add-responder
-<responder> [
- "inspect" "responder" set
- [ inspect-responder ] "get" set
- "global" "default-argument" set
-] extend add-responder
-
<responder> [
"quit" "responder" set
[ quit-responder ] "get" set
call
] ifte* ;
-: object-link-href ( path -- href )
- #! Perhaps this should not be hard-coded.
- "/responder/inspect/" swap cat2 ;
-
-: object-link-tag ( style quot -- )
- over "object-link" swap assoc [
- <a href= object-link-href url-encode a> call </a>
- ] [
- call
- ] ifte* ;
-
: icon-tag ( string style quot -- )
over "icon" swap assoc dup [
<img src= "/responder/resource/" swap cat2 img/>
[
[
[
- [
- [ drop chars>entities write ] span-tag
- ] file-link-tag
- ] object-link-tag
+ [ drop chars>entities write ] span-tag
+ ] file-link-tag
] icon-tag
] bind ;
+++ /dev/null
-! :folding=indent:collapseFolds=0:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: inspect-responder
-USE: html
-USE: inspector
-USE: namespaces
-USE: kernel
-
-USE: httpd
-USE: httpd-responder
-
-: inspect-responder ( argument -- )
- serving-html dup [
- describe-path
- ] simple-html-document ;
pop-d drop ( n )
infer-branches ;
+USE: kernel-internals
\ dispatch [ infer-dispatch ] "infer" set-word-property
\ dispatch [ 2 | 0 ] "infer-effect" set-word-property
] when*
] catch ;
-: apply-compound ( word -- )
+GENERIC: (apply-word)
+
+M: compound (apply-word) ( word -- )
#! Infer a compound word's stack effect.
dup "inline" word-property [
inline-compound drop
infer-compound
] ifte ;
+M: symbol (apply-word) ( word -- )
+ apply-literal ;
+
: current-word ( -- word )
#! Push word we're currently inferring effect of.
recursive-state get car car ;
2drop no-base-case
] ifte ;
-: no-effect? ( word -- ? )
- "no-effect" word-property ;
-
: apply-word ( word -- )
#! Apply the word's stack effect to the inferencer state.
dup recursive-state get assoc dup [
drop dup "infer-effect" word-property dup [
apply-effect
] [
- drop
- [
- [ no-effect? ] [ no-effect ]
- [ compound? ] [ apply-compound ]
- [ symbol? ] [ apply-literal ]
- [ drop t ] [ no-effect ]
- ] cond
+ drop dup "no-effect" word-property [
+ no-effect
+ ] [
+ (apply-word)
+ ] ifte
] ifte
] ifte ;
IN: io-internals
USE: generic
USE: kernel
+USE: kernel-internals
USE: namespaces
USE: strings
USE: threads
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: kernel
+IN: kernel-internals
USE: generic
+USE: kernel
USE: vectors
+: dispatch ( n vtable -- )
+ vector-nth call ;
+
+IN: kernel
+
GENERIC: hashcode ( obj -- n )
M: object hashcode drop 0 ;
#! Returns one of "unix" or "win32".
11 getenv ;
-: dispatch ( n vtable -- )
- vector-nth call ;
-
: set-boot ( quot -- )
#! Set the boot quotation.
8 setenv ;
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+IN: errors
+DEFER: throw
+
IN: math
USE: generic
USE: kernel
+USE: kernel-internals
USE: math
USE: math-internals
+GENERIC: real ( #{ re im } -- re )
+M: real real ;
+M: complex real 0 slot ;
+
+GENERIC: imaginary ( #{ re im } -- im )
+M: real imaginary drop 0 ;
+M: complex imaginary 1 slot ;
+
+: rect> ( xr xi -- x )
+ over real? over real? and [
+ dup 0 = [ drop ] [ (rect>) ] ifte
+ ] [
+ "Complex number must have real components" throw drop
+ ] ifte ; inline
+
: >rect ( x -- xr xi ) dup real swap imaginary ; inline
: conjugate ( z -- z* )
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+IN: errors
+DEFER: throw
+
IN: math-internals
USE: generic
USE: kernel
dup 0 < [ swap neg swap neg ] when
2dup gcd tuck /i >r /i r> ; inline
+: fraction> ( a b -- a/b )
+ dup 0 = [
+ "Division by zero" throw drop
+ ] [
+ dup 1 = [
+ drop
+ ] [
+ (fraction>)
+ ] ifte
+ ] ifte ; inline
+
: integer/ ( x y -- x/y )
reduce fraction> ; inline
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: math-internals
+IN: math
USE: generic
USE: kernel
+USE: kernel-internals
USE: math
+USE: math-internals
+
+GENERIC: numerator ( a/b -- a )
+M: integer numerator ;
+M: ratio numerator 0 slot ;
+
+GENERIC: denominator ( a/b -- b )
+M: integer denominator drop 1 ;
+M: ratio denominator 1 slot ;
+
+IN: math-internals
: 2>fraction ( a/b c/d -- a c b d )
[ swap numerator swap numerator ] 2keep
IN: namespaces
USE: hashtables
USE: kernel
+USE: kernel-internals
USE: lists
-USE: strings
-USE: vectors
! Other languages have classes, objects, variables, etc.
! Factor has similar concepts.
: init-namespaces ( -- )
global >n ;
-: namespace-buckets 23 ;
-
: <namespace> ( -- n )
#! Create a new namespace.
- namespace-buckets <hashtable> ;
+ 23 <hashtable> ;
: (get) ( var ns -- value )
#! Internal word for searching the namestack.
: set ( value variable -- ) namespace set-hash ;
: put ( variable value -- ) swap set ;
+: nest ( variable -- hash )
+ #! If the variable is set in the current namespace, return
+ #! its value, otherwise set its value to a new namespace.
+ dup namespace hash dup [
+ nip
+ ] [
+ drop >r <namespace> dup r> set
+ ] ifte ;
+
: change ( var quot -- )
#! Execute the quotation with the variable value on the
#! stack. The set the variable to the return value of the
#! ] extend ;
over >r bind r> ; inline
-: traverse-path ( name object -- object )
- dup hashtable? [ hash ] [ 2drop f ] ifte ;
-
-: (object-path) ( object list -- object )
- [ uncons >r swap traverse-path r> (object-path) ] when* ;
-
-: object-path ( list -- object )
- #! An object path is a list of strings. Each string is a
- #! variable name in the object namespace at that level.
- #! Returns f if any of the objects are not set.
- namespace swap (object-path) ;
-
-: (set-object-path) ( name -- namespace )
- dup namespace hash dup [
- nip
- ] [
- drop <namespace> tuck put
- ] ifte ;
-
-: set-object-path ( value list -- )
- unswons over [
- (set-object-path) [ set-object-path ] bind
- ] [
- nip set
- ] ifte ;
-
: on ( var -- ) t put ;
: off ( var -- ) f put ;
IN: alien
DEFER: alien
+DEFER: dll
USE: alien
USE: compiler
[ call " quot -- " [ [ general-list ] [ ] ] ]
[ ifte " cond true false -- " [ [ object general-list general-list ] [ ] ] ]
[ cons " car cdr -- [ car | cdr ] " [ [ object object ] [ cons ] ] ]
- [ car " [ car | cdr ] -- car " [ [ cons ] [ object ] ] ]
- [ cdr " [ car | cdr ] -- cdr " [ [ cons ] [ object ] ] ]
[ <vector> " capacity -- vector" [ [ integer ] [ vector ] ] ]
- [ vector-length " vector -- n " [ [ vector ] [ integer ] ] ]
- [ set-vector-length " n vector -- " [ [ integer vector ] [ ] ] ]
[ vector-nth " n vector -- obj " [ [ integer vector ] [ object ] ] ]
[ set-vector-nth " obj n vector -- " [ [ object integer vector ] [ ] ] ]
- [ str-length " str -- n " [ [ string ] [ integer ] ] ]
[ str-nth " n str -- ch " [ [ integer string ] [ integer ] ] ]
[ str-compare " str str -- -1/0/1 " [ [ string string ] [ integer ] ] ]
[ str= " str str -- ? " [ [ string string ] [ boolean ] ] ]
[ >fixnum " n -- fixnum " [ [ number ] [ fixnum ] ] ]
[ >bignum " n -- bignum " [ [ number ] [ bignum ] ] ]
[ >float " n -- float " [ [ number ] [ float ] ] ]
- [ numerator " a/b -- a " [ [ rational ] [ integer ] ] ]
- [ denominator " a/b -- b " [ [ rational ] [ integer ] ] ]
- [ fraction> " a b -- a/b " [ [ integer integer ] [ rational ] ] ]
+ [ (fraction>) " a b -- a/b " [ [ integer integer ] [ rational ] ] ]
[ str>float " str -- float " [ [ string ] [ float ] ] ]
[ (unparse-float) " float -- str " [ [ float ] [ string ] ] ]
- [ float>bits " float -- n " [ [ float ] [ integer ] ] ]
- [ real " #{ re im } -- re " [ [ number ] [ real ] ] ]
- [ imaginary " #{ re im } -- im " [ [ number ] [ real ] ] ]
- [ rect> " re im -- #{ re im } " [ [ real real ] [ number ] ] ]
+ [ (rect>) " re im -- #{ re im } " [ [ real real ] [ number ] ] ]
[ fixnum= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ]
[ fixnum+ " x y -- x+y " [ [ fixnum fixnum ] [ integer ] ] ]
[ fixnum- " x y -- x-y " [ [ fixnum fixnum ] [ integer ] ] ]
[ fsin " x -- y " [ [ real ] [ float ] ] ]
[ fsinh " x -- y " [ [ real ] [ float ] ] ]
[ fsqrt " x -- y " [ [ real ] [ float ] ] ]
- [ <word> " prim param plist -- word " [ [ integer object general-list ] [ word ] ] ]
- [ word-hashcode " word -- n " [ [ word ] [ integer ] ] ]
- [ word-xt " word -- xt " [ [ word ] [ integer ] ] ]
- [ set-word-xt " xt word -- " [ [ integer word ] [ ] ] ]
- [ word-primitive " word -- n " [ [ word ] [ integer ] ] ]
- [ set-word-primitive " n word -- " [ [ integer word ] [ ] ] ]
- [ word-parameter " word -- obj " [ [ word ] [ object ] ] ]
- [ set-word-parameter " obj word -- " [ [ object word ] [ ] ] ]
- [ word-plist " word -- alist" [ [ word ] [ general-list ] ] ]
- [ set-word-plist " alist word -- " [ [ general-list word ] [ ] ] ]
+ [ <word> " -- word " [ [ ] [ word ] ] ]
+ [ update-xt " word -- " [ [ word ] [ ] ] ]
[ drop " x -- " [ [ object ] [ ] ] ]
[ dup " x -- x x " [ [ object ] [ object object ] ] ]
[ swap " x y -- y x " [ [ object object ] [ object object ] ] ]
[ eq? " x y -- ? " [ [ object object ] [ boolean ] ] ]
[ getenv " n -- obj " [ [ fixnum ] [ object ] ] ]
[ setenv " obj n -- " [ [ object fixnum ] [ ] ] ]
- [ open-file " path r w -- port " [ 3 | 1 ] ]
- [ stat " path -- [ dir? perm size mtime ] " [ 1 | 1 ] ]
- [ (directory) " path -- list " [ 1 | 1 ] ]
- [ garbage-collection " -- " [ 0 | 0 ] ]
- [ save-image " path -- " [ 1 | 0 ] ]
+ [ open-file " path r w -- port " [ [ string object object ] [ port ] ] ]
+ [ stat " path -- [ dir? perm size mtime ] " [ [ string ] [ cons ] ] ]
+ [ (directory) " path -- list " [ [ string ] [ general-list ] ] ]
+ [ garbage-collection " -- " [ [ ] [ ] ] ]
+ [ save-image " path -- " [ [ string ] [ ] ] ]
[ datastack " -- ds " f ]
[ callstack " -- cs " f ]
[ set-datastack " ds -- " f ]
[ set-callstack " cs -- " f ]
- [ exit* " n -- " [ 1 | 0 ] ]
- [ client-socket " host port -- in out " [ 2 | 2 ] ]
- [ server-socket " port -- server " [ 1 | 1 ] ]
- [ close-port " port -- " [ 1 | 0 ] ]
+ [ exit* " n -- " [ [ integer ] [ ] ] ]
+ [ client-socket " host port -- in out " [ [ string integer ] [ port port ] ] ]
+ [ server-socket " port -- server " [ [ integer ] [ port ] ] ]
+ [ close-port " port -- " [ [ port ] ] ]
[ add-accept-io-task " server callback -- " [ 2 | 0 ] ]
[ accept-fd " server -- host port in out " [ 1 | 4 ] ]
[ can-read-line? " port -- ? " [ 1 | 1 ] ]
[ next-io-task " -- callback " [ 0 | 1 ] ]
[ room " -- free total free total " [ 0 | 4 ] ]
[ os-env " str -- str " [ 1 | 1 ] ]
- [ millis " -- n " [ 0 | 1 ] ]
- [ init-random " -- " [ 0 | 0 ] ]
- [ (random-int) " -- n " [ 0 | 1 ] ]
- [ type " obj -- n " [ 1 | 1 ] ]
- [ call-profiling " depth -- " [ 1 | 0 ] ]
- [ call-count " word -- n " [ 1 | 1 ] ]
- [ set-call-count " n word -- " [ 2 | 0 ] ]
- [ allot-profiling " depth -- " [ 1 | 0 ] ]
- [ allot-count " word -- n " [ 1 | 1 ] ]
- [ set-allot-count " n word -- n " [ 2 | 1 ] ]
- [ cwd " -- dir " [ 0 | 1 ] ]
- [ cd " dir -- " [ 1 | 0 ] ]
- [ compiled-offset " -- ptr " [ 0 | 1 ] ]
- [ set-compiled-offset " ptr -- " [ 1 | 0 ] ]
- [ set-compiled-cell " n ptr -- " [ 2 | 0 ] ]
- [ set-compiled-byte " n ptr -- " [ 2 | 0 ] ]
- [ literal-top " -- ptr " [ 0 | 1 ] ]
- [ set-literal-top " ptr -- " [ 1 | 0 ] ]
- [ address " obj -- ptr " [ 1 | 1 ] ]
- [ dlopen " path -- dll " [ 1 | 1 ] ]
- [ dlsym " name dll -- ptr " [ 2 | 1 ] ]
- [ dlsym-self " name -- ptr " [ 1 | 1 ] ]
- [ dlclose " dll -- " [ 1 | 0 ] ]
- [ <alien> " ptr -- alien " [ 1 | 1 ] ]
- [ <local-alien> " len -- alien " [ 1 | 1 ] ]
- [ alien-cell " alien off -- n " [ 2 | 1 ] ]
- [ set-alien-cell " n alien off -- " [ 3 | 0 ] ]
- [ alien-4 " alien off -- n " [ 2 | 1 ] ]
- [ set-alien-4 " n alien off -- " [ 3 | 0 ] ]
- [ alien-2 " alien off -- n " [ 2 | 1 ] ]
- [ set-alien-2 " n alien off -- " [ 3 | 0 ] ]
- [ alien-1 " alien off -- n " [ 2 | 1 ] ]
- [ set-alien-1 " n alien off -- " [ 3 | 0 ] ]
+ [ millis " -- n " [ [ ] [ integer ] ] ]
+ [ init-random " -- " [ [ ] [ ] ] ]
+ [ (random-int) " -- n " [ [ ] [ integer ] ] ]
+ [ type " obj -- n " [ [ object ] [ fixnum ] ] ]
+ [ call-profiling " depth -- " [ [ integer ] [ ] ] ]
+ [ allot-profiling " depth -- " [ [ integer ] [ ] ] ]
+ [ cwd " -- dir " [ [ ] [ string ] ] ]
+ [ cd " dir -- " [ [ string ] [ ] ] ]
+ [ compiled-offset " -- ptr " [ [ ] [ integer ] ] ]
+ [ set-compiled-offset " ptr -- " [ [ integer ] [ ] ] ]
+ [ literal-top " -- ptr " [ [ ] [ integer ] ] ]
+ [ set-literal-top " ptr -- " [ [ integer ] [ ] ] ]
+ [ address " obj -- ptr " [ [ object ] [ integer ] ] ]
+ [ dlopen " path -- dll " [ [ string ] [ dll ] ] ]
+ [ dlsym " name dll -- ptr " [ [ string dll ] [ integer ] ] ]
+ [ dlsym-self " name -- ptr " [ [ string ] [ integer ] ] ]
+ [ dlclose " dll -- " [ [ dll ] [ ] ] ]
+ [ <alien> " ptr -- alien " [ [ integer ] [ alien ] ] ]
+ [ <local-alien> " len -- alien " [ [ integer ] [ alien ] ] ]
+ [ alien-cell " alien off -- n " [ [ alien integer ] [ integer ] ] ]
+ [ set-alien-cell " n alien off -- " [ [ integer alien integer ] [ ] ] ]
+ [ alien-4 " alien off -- n " [ [ alien integer ] [ integer ] ] ]
+ [ set-alien-4 " n alien off -- " [ [ integer alien integer ] [ ] ] ]
+ [ alien-2 " alien off -- n " [ [ alien integer ] [ fixnum ] ] ]
+ [ set-alien-2 " n alien off -- " [ [ integer alien integer ] [ ] ] ]
+ [ alien-1 " alien off -- n " [ [ alien integer ] [ fixnum ] ] ]
+ [ set-alien-1 " n alien off -- " [ [ integer alien integer ] [ ] ] ]
[ heap-stats " -- instances bytes " [ [ ] [ general-list ] ] ]
[ throw " error -- " [ [ object ] [ ] ] ]
[ string>memory " str address -- " [ [ string integer ] [ ] ] ]
[ memory>string " address length -- str " [ [ integer integer ] [ string ] ] ]
[ local-alien? " alien -- ? " [ [ alien ] [ object ] ] ]
[ alien-address " alien -- address " [ [ alien ] [ integer ] ] ]
+ [ >cons " cons -- cons " [ [ cons ] [ cons ] ] ]
+ [ >vector " vector -- vector " [ [ vector ] [ vector ] ] ]
+ [ >string " string -- string " [ [ string ] [ string ] ] ]
+ [ >word " word -- word " [ [ word ] [ word ] ] ]
+ [ slot " obj n -- obj " [ [ object fixnum ] [ object ] ] ]
+ [ set-slot " obj obj n -- " [ [ object object fixnum ] [ ] ] ]
+ [ integer-slot " obj n -- n " [ [ object fixnum ] [ integer ] ] ]
+ [ set-integer-slot " n obj n -- " [ [ integer object fixnum ] [ ] ] ]
+ [ grow-array " n array -- array " [ [ integer array ] [ integer ] ] ]
] [
uncons dupd uncons car ( word word stack-effect infer-effect )
>r "stack-effect" set-word-property r>
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: kernel
-USE: vectors
: 2drop ( x x -- ) drop drop ; inline
: 3drop ( x x x -- ) drop drop drop ; inline
#! this from a word definition will clobber any values left
#! on the data stack by the caller.
{ } set-datastack ;
-
-: depth ( -- n )
- #! Push the number of elements on the datastack.
- datastack vector-length ;
IN: strings
USE: generic
USE: kernel
+USE: kernel-internals
USE: lists
USE: math
M: string hashcode str-hashcode ;
M: string = str= ;
+: str-length ( str -- len ) >string 1 integer-slot ; inline
+
BUILTIN: sbuf 13
M: sbuf hashcode sbuf-hashcode ;
M: sbuf = sbuf= ;
USE: prettyprint
USE: words
USE: kernel
+USE: kernel-internals
USE: generic
: dataflow-contains-op? ( object list -- ? )
car car ; inline
[ t ] [
- \ car [ inline-test ] dataflow dataflow-contains-param? >boolean
+ \ slot [ inline-test ] dataflow dataflow-contains-param? >boolean
] unit-test
[ t ] [
USE: command-line
USE: namespaces
USE: test
+USE: kernel
+USE: hashtables
+USE: lists
[
[ f ] [ "-no-user-init" cli-arg ] unit-test
[ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test
] with-scope
+
+: traverse-path ( name object -- object )
+ dup hashtable? [ hash ] [ 2drop f ] ifte ;
+
+: (object-path) ( object list -- object )
+ [ uncons >r swap traverse-path r> (object-path) ] when* ;
+
+: object-path ( list -- object )
+ #! An object path is a list of strings. Each string is a
+ #! variable name in the object namespace at that level.
+ #! Returns f if any of the objects are not set.
+ namespace swap (object-path) ;
+
+[
+ 5 [ "test" "object" "path" ] set-path
+ [ 5 ] [ [ "test" "object" "path" ] object-path ] unit-test
+
+ 7 [ "test" "object" "pathe" ] set-path
+ [ 7 ] [ [ "test" "object" "pathe" ] object-path ] unit-test
+
+ 9 [ "teste" "object" "pathe" ] set-path
+ [ 9 ] [ [ "teste" "object" "pathe" ] object-path ] unit-test
+] with-scope
USE: lists
USE: test
+[ 5 car ] unit-test-fails
+[ "Hello world" cdr ] unit-test-fails
+
[ f ] [ f cons? ] unit-test
[ f ] [ t cons? ] unit-test
[ t ] [ [ t | f ] cons? ] unit-test
[ t ] [ pi 3 > ] unit-test
[ f ] [ e 2 <= ] unit-test
-
-[ 4607182418800017408 ] [ 1.0 float>bits ] unit-test
-[ 4614256656552045848 ] [ pi float>bits ] unit-test
-[ 4613303445314885481 ] [ e float>bits ] unit-test
[ t ] [ test-namespace ] unit-test
-! Object paths should not resolve further up in the namestack.
-
-<namespace> "test-namespace" set
-[ f ]
-[ [ "test-namespace" "test-namespace" ] object-path ]
-unit-test
-
-[ f ]
-[ [ "alalal" "boobobo" "bah" ] object-path ]
-unit-test
+[
+ "nested" off
-[ t ]
-[ namespace [ ] object-path = ]
-unit-test
+ "nested" nest [ 5 "x" set ] bind
+ [ 5 ] [ "nested" nest [ "x" get ] bind ] unit-test
-[ t ]
-[
- \ test-word
- global [ [ vocabularies "test" "test-word" ] object-path ] bind
- =
-] unit-test
+] with-scope
10 "some-global" set
[ f ]
[ <namespace> [ f "some-global" set "some-global" get ] bind ]
unit-test
-
-[
- 5 [ "test" "object" "path" ] set-object-path
- [ 5 ] [ [ "test" "object" "path" ] object-path ] unit-test
-
- 7 [ "test" "object" "pathe" ] set-object-path
- [ 7 ] [ [ "test" "object" "pathe" ] object-path ] unit-test
-
- 9 [ "teste" "object" "pathe" ] set-object-path
- [ 9 ] [ [ "teste" "object" "pathe" ] object-path ] unit-test
-] with-scope
USE: vectors
USE: strings
+[ [ t f t ] vector-length ] unit-test-fails
+[ 3 ] [ { t f t } vector-length ] unit-test
+
[ 3 { } vector-nth ] unit-test-fails
[ 3 #{ 1 2 } vector-nth ] unit-test-fails
+[ "hey" [ 1 2 ] set-vector-length ] unit-test-fails
+[ "hey" { 1 2 } set-vector-length ] unit-test-fails
+
+[ 3 ] [ 3 0 <vector> [ set-vector-length ] keep vector-length ] unit-test
+[ "yo" ] [
+ "yo" 4 1 <vector> [ set-vector-nth ] keep 4 swap vector-nth
+] unit-test
+
[ 5 list>vector ] unit-test-fails
[ { } ] [ [ ] list>vector ] unit-test
[ { 1 2 } ] [ [ 1 2 ] list>vector ] unit-test
IN: threads
USE: io-internals
USE: kernel
+USE: kernel-internals
USE: lists
! Core of the multitasker. Used by io-internals.factor and
IN: errors
USE: kernel
+USE: kernel-internals
USE: lists
USE: namespaces
USE: prettyprint
#! reporting.
dup [
[ 100 | "fixnum/bignum" ]
- [ 101 | "fixnum/bignum/ratio" ]
- [ 102 | "fixnum/bignum/ratio/float" ]
- [ 103 | "fixnum/bignum/ratio/float/complex" ]
- [ 104 | "fixnum/string" ]
+ [ 104 | "fixnum/bignum/string" ]
] assoc dup [
nip
] [
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: inspector
-USE: kernel
-USE: hashtables
-USE: lists
-USE: namespaces
-USE: stdio
-USE: strings
-USE: presentation
-USE: words
-USE: prettyprint
-USE: unparser
-USE: vectors
-USE: math
-
-: relative>absolute-object-path ( string -- string )
- "object-path" get [ "'" rot cat3 ] when* ;
-
-: vars. ( -- )
- #! Print a list of defined variables.
- namespace hash-keys [.] ;
-
-: object-actions ( -- alist )
- [
- [ "Describe" | "describe-path" ]
- [ "Push" | "lookup" ]
- ] ;
-
-: link-style ( path -- style )
- relative>absolute-object-path
- dup "object-link" swons swap
- object-actions <actions> "actions" swons
- t "underline" swons
- 3list
- default-style append ;
-
-: pad-string ( len str -- str )
- str-length - " " fill ;
-
-: var-name. ( max name -- )
- tuck unparse pad-string write dup link-style
- swap unparse swap write-attr ;
-
-: value. ( max name value -- )
- >r var-name. ": " write r> . ;
-
-: max-str-length ( list -- len )
- #! Returns the length of the longest string in the given
- #! list.
- 0 swap [ str-length max ] each ;
-
-: name-padding ( alist -- col )
- [ car unparse ] map max-str-length ;
-
-: describe-assoc ( alist -- )
- dup name-padding swap
- [ dupd uncons value. ] each drop ;
-
-: alist-sort ( list -- list )
- [ swap car unparse swap car unparse str-lexi> ] sort ;
-
-: describe-hashtable ( hashtables -- )
- hash>alist alist-sort describe-assoc ;
-
-: describe ( obj -- )
- [
- [ word? ]
- [ see ]
-
- [ string? ]
- [ print ]
-
- [ assoc? ]
- [ describe-assoc ]
-
- [ hashtable? ]
- [ describe-hashtable ]
-
- [ drop t ]
- [ prettyprint ]
- ] cond ;
-
-: lookup ( str -- object )
- global [ "'" split object-path ] bind ;
-
-: describe-path ( string -- )
- [ dup "object-path" set lookup describe ] with-scope ;
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: kernel-internals
USE: generic
+USE: kernel
+USE: lists
+USE: math
+
+IN: errors
+DEFER: throw
+
+IN: kernel-internals
BUILTIN: array 8
+! UNSAFE!
+: array-capacity ( array -- n ) 1 integer-slot ; inline
+: vector-array ( vec -- array ) 2 slot ; inline
+: set-vector-array ( array vec -- ) 2 set-slot ; inline
+
+: grow-vector-array ( len vec -- )
+ [ vector-array grow-array ] keep set-vector-array ; inline
+
+: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline
+
IN: vectors
-USE: kernel
-USE: lists
-USE: math
BUILTIN: vector 11
+: vector-length ( vec -- len ) >vector 1 integer-slot ; inline
+
+: set-vector-length ( len vec -- )
+ >vector over 0 < [
+ "Vector length must be positive" throw 2drop
+ ] [
+ 2dup (set-vector-length) grow-vector-array
+ ] ifte ;
+
: empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike
#! <vector>, which gives an empty vector with a certain
#! vector. For example, if n=1, this returns a vector of
#! one element.
[ vector-length swap - ] keep vector-tail ;
+
+! Find a better place for this
+IN: kernel
+
+: depth ( -- n )
+ #! Push the number of elements on the datastack.
+ datastack vector-length ;
: (create) ( name vocab -- word )
#! Create an undefined word without adding to a vocabulary.
- <plist> 0 f rot <word> ;
+ <plist> <word> [ set-word-plist ] keep ;
: reveal ( word -- )
#! Add a new word to its vocabulary.
vocabularies get [
- dup word-vocabulary
- over word-name
- 2list set-object-path
+ dup word-vocabulary nest [
+ dup word-name set
+ ] bind
] bind ;
: create ( name vocab -- word )
"inference"
"inferior"
"interpreter"
- "inspector"
"jedit"
"kernel"
"listener"
USE: generic
USE: hashtables
USE: kernel
+USE: kernel-internals
USE: lists
USE: math
USE: namespaces
BUILTIN: word 1
-M: word hashcode word-hashcode ;
+M: word hashcode 1 integer-slot ;
+
+: word-xt ( w -- xt ) >word 2 integer-slot ; inline
+: set-word-xt ( xt w -- ) >word 2 set-integer-slot ; inline
+
+: word-primitive ( w -- n ) >word 3 integer-slot ; inline
+: set-word-primitive ( n w -- )
+ >word [ 3 set-integer-slot ] keep update-xt ; inline
+
+: word-parameter ( w -- obj ) >word 4 slot ; inline
+: set-word-parameter ( obj w -- ) >word 4 set-slot ; inline
+
+: word-plist ( w -- obj ) >word 5 slot ; inline
+: set-word-plist ( obj w -- ) >word 5 set-slot ; inline
+
+: call-count ( w -- n ) >word 6 integer-slot ; inline
+: set-call-count ( n w -- ) >word 6 set-integer-slot ; inline
+
+: allot-count ( w -- n ) >word 7 integer-slot ; inline
+: set-allot-count ( n w -- ) >word 7 set-integer-slot ; inline
SYMBOL: vocabularies
: word-property ( word pname -- pvalue )
- swap word-plist assoc ;
+ swap word-plist assoc ; inline
: set-word-property ( word pvalue pname -- )
pick word-plist
pick [ set-assoc ] [ remove-assoc nip ] ifte
- swap set-word-plist ;
+ swap set-word-plist ; inline
PREDICATE: word compound ( obj -- ? ) word-primitive 1 = ;
PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;
dpush(tag_fixnum(type));
}
-
-bool realp(CELL tagged)
-{
- switch(type_of(tagged))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- case RATIO_TYPE:
- case FLOAT_TYPE:
- return true;
- break;
- default:
- return false;
- break;
- }
-}
-
-bool zerop(CELL tagged)
-{
- switch(type_of(tagged))
- {
- case FIXNUM_TYPE:
- return tagged == 0;
- case BIGNUM_TYPE:
- return BIGNUM_ZERO_P((F_ARRAY*)UNTAG(tagged));
- case FLOAT_TYPE:
- return ((F_FLOAT*)UNTAG(tagged))->n == 0.0;
- case RATIO_TYPE:
- case COMPLEX_TYPE:
- return false;
- default:
- type_error(NUMBER_TYPE,tagged);
- return false; /* Can't happen */
- }
-}
-
-bool onep(CELL tagged)
-{
- switch(type_of(tagged))
- {
- case FIXNUM_TYPE:
- return tagged == tag_fixnum(1);
- case BIGNUM_TYPE:
- return BIGNUM_ONE_P((F_ARRAY*)UNTAG(tagged),0);
- case FLOAT_TYPE:
- return ((F_FLOAT*)UNTAG(tagged))->n == 1.0;
- case RATIO_TYPE:
- case COMPLEX_TYPE:
- return false;
- default:
- type_error(NUMBER_TYPE,tagged);
- return false; /* Can't happen */
- }
-}
#include "factor.h"
void primitive_arithmetic_type(void);
-
-bool realp(CELL tagged);
-
-bool zerop(CELL tagged);
-bool onep(CELL tagged);
#include "factor.h"
/* untagged */
-F_ARRAY* allot_array(CELL type, F_FIXNUM capacity)
+F_ARRAY* allot_array(CELL type, CELL capacity)
{
F_ARRAY* array;
if(capacity < 0)
}
/* untagged */
-F_ARRAY* array(F_FIXNUM capacity, CELL fill)
+F_ARRAY* array(CELL capacity, CELL fill)
{
int i;
return array;
}
-F_ARRAY* grow_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
+F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
{
/* later on, do an optimization: if end of array is here, just grow */
int i;
+ F_ARRAY* new_array;
- F_ARRAY* new_array = allot_array(untag_header(array->header),capacity);
+ if(array->capacity >= capacity)
+ return array;
+
+ new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,array->capacity * CELLS);
return new_array;
}
-F_ARRAY* shrink_array(F_ARRAY* array, F_FIXNUM capacity)
+void primitive_grow_array(void)
+{
+ F_ARRAY* array = untag_array(dpop());
+ CELL capacity = to_fixnum(dpop());
+ dpush(tag_object(grow_array(array,capacity,F)));
+}
+
+F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity)
{
F_ARRAY* new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,capacity * CELLS);
return (F_ARRAY*)UNTAG(tagged); /* FIXME */
}
-F_ARRAY* allot_array(CELL type, F_FIXNUM capacity);
-F_ARRAY* array(F_FIXNUM capacity, CELL fill);
-F_ARRAY* grow_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
-F_ARRAY* shrink_array(F_ARRAY* array, F_FIXNUM capacity);
+F_ARRAY* allot_array(CELL type, CELL capacity);
+F_ARRAY* array(CELL capacity, CELL fill);
+F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
+void primitive_grow_array(void);
+F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
literal_top = compiling.base;
}
-void check_compiled_offset(CELL offset)
-{
- if(offset < compiling.base || offset >= compiling.limit)
- range_error(F,0,to_integer(offset),compiling.limit);
-}
-
-void primitive_set_compiled_byte(void)
-{
- CELL offset = unbox_integer();
- BYTE b = to_fixnum(dpop());
- check_compiled_offset(offset);
- bput(offset,b);
-}
-
-void primitive_set_compiled_cell(void)
-{
- CELL offset = unbox_integer();
- CELL c = to_fixnum(dpop());
- check_compiled_offset(offset);
- put(offset,c);
-}
-
void primitive_compiled_offset(void)
{
box_integer(compiling.here);
void primitive_set_compiled_offset(void)
{
CELL offset = unbox_integer();
- check_compiled_offset(offset);
compiling.here = offset;
}
void primitive_set_literal_top(void)
{
CELL offset = unbox_integer();
- check_compiled_offset(offset);
literal_top = offset;
}
void collect_literals(void)
{
- CELL i = compiling.base;
- while(i < literal_top)
- {
+ CELL i;
+ for(i = compiling.base; i < literal_top; i += CELLS)
copy_object((CELL*)i);
- i += CELLS;
- }
}
CELL literal_top;
void init_compiler(void);
-void primitive_set_compiled_byte(void);
-void primitive_set_compiled_cell(void);
void primitive_compiled_offset(void);
void primitive_set_compiled_offset(void);
void primitive_literal_top(void);
#include "factor.h"
-void primitive_real(void)
-{
- switch(type_of(dpeek()))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- case FLOAT_TYPE:
- case RATIO_TYPE:
- /* No op */
- break;
- case COMPLEX_TYPE:
- drepl(untag_complex(dpeek())->real);
- break;
- default:
- type_error(NUMBER_TYPE,dpeek());
- break;
- }
-}
-
-void primitive_imaginary(void)
-{
- switch(type_of(dpeek()))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- case FLOAT_TYPE:
- case RATIO_TYPE:
- drepl(tag_fixnum(0));
- break;
- case COMPLEX_TYPE:
- drepl(untag_complex(dpeek())->imaginary);
- break;
- default:
- type_error(NUMBER_TYPE,dpeek());
- break;
- }
-}
-
void primitive_from_rect(void)
{
- CELL imaginary, real;
+ CELL imaginary = dpop();
+ CELL real = dpop();
+ F_COMPLEX* complex;
maybe_garbage_collection();
- imaginary = dpop();
- real = dpop();
-
- if(!realp(imaginary))
- type_error(REAL_TYPE,imaginary);
-
- if(!realp(real))
- type_error(REAL_TYPE,real);
-
- if(zerop(imaginary))
- dpush(real);
- else
- {
- F_COMPLEX* complex = allot(sizeof(F_COMPLEX));
- complex->real = real;
- complex->imaginary = imaginary;
- dpush(tag_complex(complex));
- }
+ complex = allot(sizeof(F_COMPLEX));
+ complex->real = real;
+ complex->imaginary = imaginary;
+ dpush(tag_complex(complex));
}
CELL imaginary;
} F_COMPLEX;
-INLINE F_COMPLEX* untag_complex(CELL tagged)
-{
- type_check(COMPLEX_TYPE,tagged);
- return (F_COMPLEX*)UNTAG(tagged);
-}
-
INLINE CELL tag_complex(F_COMPLEX* complex)
{
return RETAG(complex,COMPLEX_TYPE);
}
-void primitive_real(void);
-void primitive_imaginary(void);
void primitive_from_rect(void);
dpush(cons(car,cdr));
}
-void primitive_car(void)
+void primitive_to_cons(void)
{
- drepl(car(dpeek()));
-}
-
-void primitive_cdr(void)
-{
- drepl(cdr(dpeek()));
+ type_check(CONS_TYPE,dpeek());
}
}
void primitive_cons(void);
-void primitive_car(void);
-void primitive_cdr(void);
+void primitive_to_cons(void);
#include "word.h"
#include "run.h"
#include "signal.h"
+#include "cons.h"
#include "fixnum.h"
#include "array.h"
#include "s48_bignumint.h"
#include "write.h"
#include "file.h"
#include "socket.h"
-#include "cons.h"
#include "image.h"
#include "primitives.h"
#include "vector.h"
box_c_string(tmp);
}
-void primitive_float_to_bits(void)
-{
- double f;
- int64_t f_raw;
-
- maybe_garbage_collection();
-
- f = untag_float(dpeek());
- f_raw = *(int64_t*)&f;
- drepl(tag_object(s48_long_long_to_bignum(f_raw)));
-}
-
#define GC_AND_POP_FLOATS(x,y) \
double x, y; \
maybe_garbage_collection(); \
primitive_call,
primitive_ifte,
primitive_cons,
- primitive_car,
- primitive_cdr,
primitive_vector,
- primitive_vector_length,
- primitive_set_vector_length,
primitive_vector_nth,
primitive_set_vector_nth,
- primitive_string_length,
primitive_string_nth,
primitive_string_compare,
primitive_string_eq,
primitive_to_fixnum,
primitive_to_bignum,
primitive_to_float,
- primitive_numerator,
- primitive_denominator,
primitive_from_fraction,
primitive_str_to_float,
primitive_float_to_str,
- primitive_float_to_bits,
- primitive_real,
- primitive_imaginary,
primitive_from_rect,
primitive_fixnum_eq,
primitive_fixnum_add,
primitive_fsinh,
primitive_fsqrt,
primitive_word,
- primitive_word_hashcode,
- primitive_word_xt,
- primitive_set_word_xt,
- primitive_word_primitive,
- primitive_set_word_primitive,
- primitive_word_parameter,
- primitive_set_word_parameter,
- primitive_word_plist,
- primitive_set_word_plist,
+ primitive_update_xt,
primitive_call_profiling,
- primitive_word_call_count,
- primitive_set_word_call_count,
primitive_allot_profiling,
- primitive_word_allot_count,
- primitive_set_word_allot_count,
primitive_word_compiledp,
primitive_drop,
primitive_dup,
primitive_cd,
primitive_compiled_offset,
primitive_set_compiled_offset,
- primitive_set_compiled_cell,
- primitive_set_compiled_byte,
primitive_literal_top,
primitive_set_literal_top,
primitive_address,
primitive_memory_to_string,
primitive_local_alienp,
primitive_alien_address,
+ primitive_to_cons,
+ primitive_to_vector,
+ primitive_to_string,
+ primitive_to_word,
+ primitive_slot,
+ primitive_set_slot,
+ primitive_integer_slot,
+ primitive_set_integer_slot,
+ primitive_grow_array
};
CELL primitive_to_xt(CELL primitive)
extern XT primitives[];
-#define PRIMITIVE_COUNT 192
+#define PRIMITIVE_COUNT 195
CELL primitive_to_xt(CELL primitive);
library implementation, to avoid breaking invariants. */
void primitive_from_fraction(void)
{
- CELL numerator, denominator;
+ CELL denominator = dpop();
+ CELL numerator = dpop();
+ F_RATIO* ratio;
maybe_garbage_collection();
- denominator = dpop();
- numerator = dpop();
- if(zerop(denominator))
- raise(SIGFPE);
- if(onep(denominator))
- dpush(numerator);
- else
- {
- F_RATIO* ratio = allot(sizeof(F_RATIO));
- ratio->numerator = numerator;
- ratio->denominator = denominator;
- dpush(tag_ratio(ratio));
- }
-}
-
-void primitive_numerator(void)
-{
- switch(type_of(dpeek()))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- /* No op */
- break;
- case RATIO_TYPE:
- drepl(untag_ratio(dpeek())->numerator);
- break;
- default:
- type_error(RATIONAL_TYPE,dpeek());
- break;
- }
-}
-
-void primitive_denominator(void)
-{
- switch(type_of(dpeek()))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- drepl(tag_fixnum(1));
- break;
- case RATIO_TYPE:
- drepl(untag_ratio(dpeek())->denominator);
- break;
- default:
- type_error(RATIONAL_TYPE,dpeek());
- break;
- }
+ ratio = allot(sizeof(F_RATIO));
+ ratio->numerator = numerator;
+ ratio->denominator = denominator;
+ dpush(tag_ratio(ratio));
}
CELL denominator;
} F_RATIO;
-INLINE F_RATIO* untag_ratio(CELL tagged)
-{
- type_check(RATIO_TYPE,tagged);
- return (F_RATIO*)UNTAG(tagged);
-}
-
INLINE CELL tag_ratio(F_RATIO* ratio)
{
return RETAG(ratio,RATIO_TYPE);
}
-void primitive_numerator(void);
-void primitive_denominator(void);
void primitive_from_fraction(void);
{
F_SBUF* s1 = untag_sbuf(dpop());
CELL with = dpop();
- if(typep(SBUF_TYPE,with))
+ if(type_of(with) == SBUF_TYPE)
dpush(tag_boolean(sbuf_eq(s1,(F_SBUF*)UNTAG(with))));
else
dpush(F);
return to_c_string(untag_string(dpop()));
}
-void primitive_string_length(void)
-{
- drepl(tag_fixnum(untag_string(dpeek())->capacity));
-}
-
void primitive_string_nth(void)
{
F_STRING* string = untag_string(dpop());
{
F_STRING* s1 = untag_string(dpop());
CELL with = dpop();
- if(typep(STRING_TYPE,with))
+ if(type_of(with) == STRING_TYPE)
dpush(tag_boolean(string_eq(s1,(F_STRING*)UNTAG(with))));
else
dpush(F);
rehash_string(s);
drepl(tag_object(s));
}
+
+void primitive_to_string(void)
+{
+ type_check(STRING_TYPE,dpeek());
+}
cput(SREF(string,index),value);
}
-void primitive_string_length(void);
void primitive_string_nth(void);
F_FIXNUM string_compare_head(F_STRING* s1, F_STRING* s2, CELL len);
F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2);
void string_reverse(F_STRING* s, int len);
F_STRING* string_clone(F_STRING* s, int len);
void primitive_string_reverse(void);
+void primitive_to_string(void);
#include "factor.h"
-bool typep(CELL type, CELL tagged)
-{
- return type_of(tagged) == type;
-}
-
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
{
drepl(tag_fixnum(type_of(dpeek())));
}
+
+#define SLOT(obj,slot) UNTAG(obj) + slot * CELLS
+
+void primitive_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = dpop();
+ dpush(get(SLOT(obj,slot)));
+}
+
+void primitive_set_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = dpop();
+ CELL value = dpop();
+ put(SLOT(obj,slot),value);
+}
+
+void primitive_integer_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = dpop();
+ dpush(tag_integer(get(SLOT(obj,slot))));
+}
+
+void primitive_set_integer_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = dpop();
+ F_FIXNUM value = to_integer(dpop());
+ put(SLOT(obj,slot),value);
+}
/* Pseudo-types. For error reporting only. */
#define INTEGER_TYPE 100 /* F_FIXNUM or BIGNUM */
-#define RATIONAL_TYPE 101 /* INTEGER or F_RATIO */
-#define REAL_TYPE 102 /* RATIONAL or F_FLOAT */
-#define NUMBER_TYPE 103 /* F_COMPLEX or REAL */
#define TEXT_TYPE 104 /* F_FIXNUM or F_STRING */
-bool typep(CELL type, CELL tagged);
-
INLINE CELL tag_header(CELL cell)
{
return RETAG(cell << TAG_BITS,HEADER_TYPE);
else
return tag;
}
+
+void primitive_slot(void);
+void primitive_set_slot(void);
+void primitive_integer_slot(void);
+void primitive_set_integer_slot(void);
for(i = 0; i < fd_count; i++)
{
- if(typep(PORT_TYPE,io_tasks[i].port))
+ if(type_of(io_tasks[i].port) == PORT_TYPE)
{
if(untag_port(io_tasks[i].port)->closed)
*closed = true;
{
IO_TASK io_task = io_tasks[i];
- if(typep(PORT_TYPE,io_task.port))
+ if(type_of(io_task.port) == PORT_TYPE)
{
F_PORT* port = untag_port(io_task.port);
if(port->closed)
drepl(tag_object(vector(to_fixnum(dpeek()))));
}
-void primitive_vector_length(void)
+void primitive_to_vector(void)
{
- drepl(tag_fixnum(untag_vector(dpeek())->top));
-}
-
-void primitive_set_vector_length(void)
-{
- F_VECTOR* vector;
- F_FIXNUM length;
- F_ARRAY* array;
-
- maybe_garbage_collection();
-
- vector = untag_vector(dpop());
- length = to_fixnum(dpop());
- array = untag_array(vector->array);
-
- if(length < 0)
- range_error(tag_object(vector),0,tag_fixnum(length),vector->top);
- vector->top = length;
- if(length > array->capacity)
- vector->array = tag_object(grow_array(array,length,F));
+ type_check(VECTOR_TYPE,dpeek());
}
void primitive_vector_nth(void)
F_VECTOR* vector(F_FIXNUM capacity);
void primitive_vector(void);
-void primitive_vector_length(void);
-void primitive_set_vector_length(void);
+void primitive_to_vector(void);
void primitive_vector_nth(void);
void vector_ensure_capacity(F_VECTOR* vector, CELL index);
void primitive_set_vector_nth(void);
#include "factor.h"
-F_WORD* word(CELL primitive, CELL parameter, CELL plist)
-{
- F_WORD* word = allot_object(WORD_TYPE,sizeof(F_WORD));
- word->hashcode = (CELL)word; /* initial address */
- word->xt = primitive_to_xt(primitive);
- word->primitive = primitive;
- word->parameter = parameter;
- word->plist = plist;
- word->call_count = 0;
- word->allot_count = 0;
-
- return word;
-}
-
/* When a word is executed we jump to the value of the xt field. However this
value is an unportable function pointer, so in the image we store a primitive
number that indexes a list of xts. */
/* <word> ( primitive parameter plist -- word ) */
void primitive_word(void)
{
- CELL plist, parameter;
- F_FIXNUM primitive;
+ F_WORD* word;
maybe_garbage_collection();
- plist = dpop();
- parameter = dpop();
- primitive = to_fixnum(dpop());
- dpush(tag_word(word(primitive,parameter,plist)));
-}
-
-void primitive_word_hashcode(void)
-{
- drepl(tag_fixnum(untag_word(dpeek())->hashcode));
-}
-
-void primitive_word_xt(void)
-{
- drepl(tag_cell(untag_word(dpeek())->xt));
-}
-
-void primitive_set_word_xt(void)
-{
- F_WORD* word = untag_word(dpop());
- word->xt = unbox_integer();
-}
-
-void primitive_word_primitive(void)
-{
- drepl(tag_fixnum(untag_word(dpeek())->primitive));
-}
-
-void primitive_set_word_primitive(void)
-{
- F_WORD* word = untag_word(dpop());
- word->primitive = to_fixnum(dpop());
- update_xt(word);
-}
-
-void primitive_word_parameter(void)
-{
- drepl(untag_word(dpeek())->parameter);
-}
-
-void primitive_set_word_parameter(void)
-{
- F_WORD* word = untag_word(dpop());
- word->parameter = dpop();
-}
-
-void primitive_word_plist(void)
-{
- drepl(untag_word(dpeek())->plist);
-}
-
-void primitive_set_word_plist(void)
-{
- F_WORD* word = untag_word(dpop());
- word->plist = dpop();
-}
-
-void primitive_word_call_count(void)
-{
- drepl(tag_cell(untag_word(dpeek())->call_count));
-}
-
-void primitive_set_word_call_count(void)
-{
- F_WORD* word = untag_word(dpop());
- word->call_count = to_fixnum(dpop());
+ word = allot_object(WORD_TYPE,sizeof(F_WORD));
+ word->hashcode = (CELL)word; /* initial address */
+ word->xt = (CELL)undefined;
+ word->primitive = 0;
+ word->parameter = F;
+ word->plist = F;
+ word->call_count = 0;
+ word->allot_count = 0;
+ dpush(tag_word(word));
}
-void primitive_word_allot_count(void)
+void primitive_update_xt(void)
{
- drepl(tag_cell(untag_word(dpeek())->allot_count));
+ update_xt(untag_word(dpop()));
}
-void primitive_set_word_allot_count(void)
+void primitive_word_compiledp(void)
{
F_WORD* word = untag_word(dpop());
- word->allot_count = to_fixnum(dpop());
+ box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym);
}
-void primitive_word_compiledp(void)
+void primitive_to_word(void)
{
- F_WORD* word = untag_word(dpop());
- box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym);
+ type_check(WORD_TYPE,dpeek());
}
void fixup_word(F_WORD* word)
return RETAG(word,WORD_TYPE);
}
-F_WORD* word(CELL primitive, CELL parameter, CELL plist);
void update_xt(F_WORD* word);
void primitive_word(void);
-void primitive_word_hashcode(void);
-void primitive_word_primitive(void);
-void primitive_set_word_primitive(void);
-void primitive_word_xt(void);
-void primitive_set_word_xt(void);
-void primitive_word_parameter(void);
-void primitive_set_word_parameter(void);
-void primitive_word_plist(void);
-void primitive_set_word_plist(void);
-void primitive_word_call_count(void);
-void primitive_set_word_call_count(void);
-void primitive_word_allot_count(void);
-void primitive_set_word_allot_count(void);
+void primitive_update_xt(void);
void primitive_word_compiledp(void);
+void primitive_to_word(void);
void fixup_word(F_WORD* word);
void collect_word(F_WORD* word);
projects / factor.git / commitdiff