--- /dev/null
+/* :folding=explicit:collapseFolds=1: */
+
+/*
+ * $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.
+ */
+
+package factor;
+
+import factor.parser.*;
+import java.io.*;
+import java.util.*;
+
+public class DefaultVocabularyLookup implements VocabularyLookup
+{
+ public static final Cons DEFAULT_USE = new Cons("syntax",new Cons("scratchpad",null));
+ public static final String DEFAULT_IN = "scratchpad";
+
+ /**
+ * Maps vocabulary names to vocabularies.
+ */
+ private Map vocabularies;
+
+ //{{{ DefaultVocabularyLookup constructor
+ public DefaultVocabularyLookup()
+ {
+ vocabularies = new HashMap();
+
+ /* comments */
+ FactorWord lineComment = define("syntax","!");
+ lineComment.parsing = new LineComment(lineComment,false);
+ FactorWord stackComment = define("syntax","(");
+ stackComment.parsing = new StackComment(stackComment);
+ FactorWord docComment = define("syntax","#!");
+ docComment.parsing = new LineComment(docComment,true);
+
+ /* strings */
+ FactorWord str = define("syntax","\"");
+ str.parsing = new StringLiteral(str,true);
+ FactorWord ch = define("syntax","CHAR:");
+ ch.parsing = new CharLiteral(ch);
+
+ /* constants */
+ FactorWord t = define("syntax","t");
+ t.parsing = new T(t);
+ FactorWord f = define("syntax","f");
+ f.parsing = new F(f);
+ FactorWord complex = define("syntax","#{");
+ complex.parsing = new ComplexLiteral(complex,"}");
+
+ /* lists */
+ FactorWord bra = define("syntax","[");
+ bra.parsing = new Bra(bra);
+ FactorWord ket = define("syntax","]");
+ ket.parsing = new Ket(bra,ket);
+ FactorWord bar = define("syntax","|");
+ bar.parsing = new Bar(bar);
+
+ /* vectors */
+ FactorWord beginVector = define("syntax","{");
+ beginVector.parsing = new BeginVector(beginVector);
+ FactorWord endVector = define("syntax","}");
+ endVector.parsing = new EndVector(beginVector,endVector);
+
+ /* word defs */
+ FactorWord def = define("syntax",":");
+ def.parsing = new Def(def);
+ def.docComment = true;
+ FactorWord ine = define("syntax",";");
+ ine.parsing = new Ine(def,ine);
+ FactorWord symbol = define("syntax","SYMBOL:");
+ symbol.parsing = new Symbol(symbol);
+
+ /* reading numbers with another base */
+ FactorWord bin = define("syntax","BIN:");
+ bin.parsing = new Base(bin,2);
+ FactorWord oct = define("syntax","OCT:");
+ oct.parsing = new Base(oct,8);
+ FactorWord hex = define("syntax","HEX:");
+ hex.parsing = new Base(hex,16);
+
+ /* vocabulary parsing words */
+ FactorWord noParsing = define("syntax","POSTPONE:");
+ noParsing.parsing = new NoParsing(noParsing);
+ FactorWord defer = define("syntax","DEFER:");
+ defer.parsing = new Defer(defer);
+ FactorWord in = define("syntax","IN:");
+ in.parsing = new In(in);
+ FactorWord use = define("syntax","USE:");
+ use.parsing = new Use(use);
+
+ FactorWord pushWord = define("syntax","\\");
+ pushWord.parsing = new PushWord(pushWord);
+ } //}}}
+
+ //{{{ getVocabulary() method
+ public Map getVocabulary(String name)
+ {
+ return (Map)vocabularies.get(name);
+ } //}}}
+
+ //{{{ searchVocabulary() method
+ /**
+ * Search in the given vocabulary for the given word.
+ */
+ public FactorWord searchVocabulary(String vname, String name)
+ {
+ Map v = getVocabulary(vname);
+ if(v != null)
+ return (FactorWord)v.get(name);
+ else
+ return null;
+ } //}}}
+
+ //{{{ searchVocabulary() method
+ /**
+ * Search through the given vocabulary list for the given word.
+ */
+ public FactorWord searchVocabulary(Cons vocabulary, String name)
+ {
+ while(vocabulary != null)
+ {
+ FactorWord word = searchVocabulary(
+ (String)vocabulary.car,name);
+ if(word != null)
+ return word;
+
+ vocabulary = vocabulary.next();
+ }
+
+ return null;
+ } //}}}
+
+ //{{{ define() method
+ /**
+ * Define a word in the given vocabulary if it doesn't exist already.
+ */
+ public FactorWord define(String vocabulary, String name)
+ {
+ Map v = getVocabulary(vocabulary);
+ if(v == null)
+ {
+ v = new HashMap();
+ vocabularies.put(vocabulary,v);
+ }
+ Object value = v.get(name);
+ if(value instanceof FactorWord)
+ return (FactorWord)value;
+ else
+ {
+ // save to same workspace as vocabulary,
+ // or no workspace if vocabulary is builtins
+ FactorWord word = new FactorWord(vocabulary,name);
+ v.put(name,word);
+ return word;
+ }
+ } //}}}
+
+ //{{{ getVocabularies() method
+ public Cons getVocabularies()
+ {
+ Cons vocabs = null;
+ Iterator iter = vocabularies.keySet().iterator();
+ while(iter.hasNext())
+ vocabs = new Cons(iter.next(),vocabs);
+ return vocabs;
+ } //}}}
+
+ //{{{ getCompletions() method
+ public void getCompletions(String vocab, String word, Set completions,
+ boolean anywhere)
+ {
+ Map v = (Map)vocabularies.get(vocab);
+ if(v == null)
+ return;
+
+ Iterator words = v.values().iterator();
+
+ while(words.hasNext())
+ {
+ FactorWord w = (FactorWord)words.next();
+ if(w != null && w.name != null)
+ {
+ if(!completions.contains(w))
+ {
+ if(anywhere)
+ {
+ if(w.name.indexOf(word) != -1)
+ completions.add(w);
+ }
+ else
+ {
+ if(w.name.startsWith(word))
+ completions.add(w);
+ }
+ }
+ }
+ }
+ } //}}}
+
+ //{{{ parseObject() method
+ public Cons parseObject(String source) throws Exception
+ {
+ FactorReader parser = new FactorReader(
+ "parseObject()",
+ new BufferedReader(new StringReader(source)),
+ true,this);
+ return parser.parse();
+ } //}}}
+}
--- /dev/null
+/* :folding=explicit:collapseFolds=1: */
+
+/*
+ * $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.
+ */
+
+package factor;
+
+import java.util.Iterator;
+import java.util.Set;
+
+public interface VocabularyLookup
+{
+ public FactorWord define(String in, String word)
+ throws Exception;
+ public FactorWord searchVocabulary(Cons use, String word)
+ throws Exception;
+
+ /**
+ * @param vocab The vocabulary name
+ * @param word A substring of the word name to complete
+ * @param completions List to add completions to
+ * @param anywhere If true, word name will be matched anywhere, otherwise, just at
+ * the beginning of the name.
+ */
+ public void getCompletions(String vocab, String word, Set completions,
+ boolean anywhere) throws Exception;
+
+ public Cons getVocabularies() throws Exception;
+}
--- /dev/null
+! :folding=none:collapseFolds=1:
+
+! $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: io-internals
+USE: combinators
+USE: continuations
+USE: kernel
+USE: namespaces
+USE: stack
+USE: strings
+USE: threads
+
+: stdin 0 getenv ;
+: stdout 1 getenv ;
+
+: blocking-flush ( port -- )
+ [ add-write-io-task (yield) ] callcc0 drop ;
+
+: wait-to-write ( len port -- )
+ tuck can-write? [ drop ] [ blocking-flush ] ifte ;
+
+: blocking-write ( str port -- )
+ over
+ dup string? [ str-length ] [ drop 1 ] ifte
+ over wait-to-write write-fd-8 ;
+
+: blocking-fill ( port -- )
+ [ add-read-line-io-task (yield) ] callcc0 drop ;
+
+: wait-to-read-line ( port -- )
+ dup can-read-line? [ drop ] [ blocking-fill ] ifte ;
+
+: blocking-read-line ( port -- line )
+ dup wait-to-read-line read-line-fd-8 dup [ sbuf>str ] when ;
+
+: fill-fd# ( count port -- )
+ [ add-read-count-io-task (yield) ] callcc0 2drop ;
+
+: wait-to-read# ( count port -- )
+ 2dup can-read-count? [ 2drop ] [ fill-fd# ] ifte ;
+
+: blocking-read# ( count port -- str )
+ 2dup wait-to-read# read-count-fd-8 dup [ sbuf>str ] when ;
+
+: wait-to-accept ( socket -- )
+ [ add-accept-io-task (yield) ] callcc0 drop ;
+
+: blocking-accept ( socket -- host port in out )
+ dup wait-to-accept accept-fd ;
+
+: blocking-copy ( in out -- )
+ [ add-copy-io-task (yield) ] callcc0
+ pending-io-error pending-io-error ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $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: streams
+USE: combinators
+USE: continuations
+USE: io-internals
+USE: errors
+USE: hashtables
+USE: kernel
+USE: logic
+USE: stack
+USE: stdio
+USE: strings
+USE: namespaces
+USE: unparser
+
+: <server> ( port -- stream )
+ #! Starts listening on localhost:port. Returns a stream that
+ #! you can close with fclose, and accept connections from
+ #! with accept. No other stream operations are supported.
+ server-socket <stream> [
+ "socket" set
+
+ ( -- )
+ [ "socket" get close-port ] "fclose" set
+ ] extend ;
+
+: <client-stream> ( host port in out -- stream )
+ <fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;
+
+: <client> ( host port -- stream )
+ #! fflush yields until connection is established.
+ 2dup client-socket <client-stream> dup fflush ;
+
+: accept ( server -- client )
+ #! Accept a connection from a server socket.
+ "socket" swap hash blocking-accept <client-stream> ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $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: streams
+USE: combinators
+USE: continuations
+USE: io-internals
+USE: errors
+USE: hashtables
+USE: kernel
+USE: logic
+USE: stack
+USE: stdio
+USE: strings
+USE: namespaces
+
+: <fd-stream> ( in out -- stream )
+ #! Create a file descriptor stream object, wrapping a pair
+ #! of file descriptor handles for input and output.
+ <stream> [
+ "out" set
+ "in" set
+
+ ( str -- )
+ [ "out" get blocking-write ] "fwrite" set
+
+ ( -- str )
+ [ "in" get dup [ blocking-read-line ] when ] "freadln" set
+
+ ( count -- str )
+ [
+ "in" get dup [ blocking-read# ] [ nip ] ifte
+ ] "fread#" set
+
+ ( -- )
+ [ "out" get [ blocking-flush ] when* ] "fflush" set
+
+ ( -- )
+ [
+ "out" get [ dup blocking-flush close-port ] when*
+ "in" get [ close-port ] when*
+ ] "fclose" set
+ ] extend ;
+
+: <filecr> ( path -- stream )
+ t f open-file <fd-stream> ;
+
+: <filecw> ( path -- stream )
+ f t open-file <fd-stream> ;
+
+: <filebr> ( path -- stream )
+ <filecr> ;
+
+: <filebw> ( path -- stream )
+ <filecw> ;
+
+: init-stdio ( -- )
+ stdin stdout <fd-stream> <stdio-stream> "stdio" set ;
+
+: (fcopy) ( from to -- )
+ #! Copy the contents of the fd-stream 'from' to the
+ #! fd-stream 'to'. Use fcopy; this word does not close
+ #! streams.
+ "out" swap hash >r "in" swap hash r> blocking-copy ;
+
+: fcopy ( from to -- )
+ #! Copy the contents of the fd-stream 'from' to the
+ #! fd-stream 'to'.
+ [ 2dup (fcopy) ] [ -rot fclose fclose rethrow ] catch ;
+
+: resource-path ( -- path )
+ "resource-path" get [ "." ] unless* ;
+
+: <resource-stream> ( path -- stream )
+ resource-path swap cat2 <filecr> ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $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: kernel
+USE: combinators
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: prettyprint
+USE: stack
+USE: stdio
+USE: words
+USE: vectors
+USE: unparser
+
+: heap-stat. ( type instances bytes -- )
+ dup 0 = [
+ 3drop
+ ] [
+ rot type-name write ": " write
+ unparse write " bytes, " write
+ unparse write " instances" print
+ ] ifte ;
+
+: heap-stats. ( -- )
+ #! Print heap allocation breakdown.
+ 0 heap-stats [ dupd uncons heap-stat. succ ] each drop ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $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: profiler
+USE: combinators
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: prettyprint
+USE: stack
+USE: words
+USE: vectors
+
+! The variable "only-top" toggles between
+! culminative counts, and top of call stack counts.
+SYMBOL: only-top
+
+: reset-counts ( -- )
+ [ 0 over set-call-count 0 swap set-allot-count ] each-word ;
+
+: sort-counts ( alist -- alist )
+ [ swap cdr swap cdr > ] sort ;
+
+: call-count, ( word -- )
+ #! Add to constructing list if call count is non-zero.
+ dup call-count dup 0 = [ 2drop ] [ cons , ] ifte ;
+
+: counts. ( alist -- )
+ sort-counts [ . ] each ;
+
+: call-counts. ( -- )
+ #! Print word/call count pairs.
+ [ [ call-count, ] each-word ] make-list counts. ;
+
+: profile-depth ( -- n )
+ only-top get [ -1 ] [ callstack vector-length ] ifte ;
+
+: (call-profile) ( quot -- )
+ reset-counts
+ profile-depth call-profiling
+ call
+ f call-profiling ;
+
+: call-profile ( quot -- )
+ #! Execute a quotation with the CPU profiler enabled.
+ (call-profile) call-counts. ;
+
+: allot-count, ( word -- )
+ #! Add to constructing list if allot count is non-zero.
+ dup allot-count dup 0 = [ 2drop ] [ cons , ] ifte ;
+
+: allot-counts. ( -- alist )
+ #! Print word/allot count pairs.
+ [ [ allot-count, ] each-word ] make-list counts. ;
+
+: allot-profile ( quot -- )
+ #! Execute a quotation with the memory profiler enabled.
+ reset-counts
+ profile-depth allot-profiling
+ call
+ f allot-profiling
+ allot-counts. ;
projects / factor.git / commitdiff