diff --git a/.cvskeywords b/.cvskeywords index ff513cc7c9..6584da683e 100644 --- a/.cvskeywords +++ b/.cvskeywords @@ -1,185 +1,119 @@ -./library/compiler/simplifier.factor:! $Id: simplifier.factor,v 1.4 2004/12/19 01:24:45 spestov Exp $ -./library/compiler/xt.factor:! $Id: xt.factor,v 1.6 2004/12/17 00:57:03 spestov Exp $ -./library/compiler/assembler.factor:! $Id: assembler.factor,v 1.8 2004/12/25 07:55:03 spestov Exp $ -./library/compiler/assembly-x86.factor:! $Id: assembly-x86.factor,v 1.15 2004/12/31 07:17:43 spestov Exp $ -./library/compiler/generator-x86.factor:! $Id: generator-x86.factor,v 1.19 2004/12/31 07:17:43 spestov Exp $ -./library/compiler/alien-types.factor:! $Id: alien-types.factor,v 1.17 2004/12/29 08:35:44 spestov Exp $ -./library/compiler/generator.factor:! $Id: generator.factor,v 1.9 2004/12/31 07:17:43 spestov Exp $ -./library/compiler/alien.factor:! $Id: alien.factor,v 1.22 2004/12/31 07:17:43 spestov Exp $ -./library/compiler/optimizer.factor:! $Id: optimizer.factor,v 1.14 2005/01/01 22:20:47 spestov Exp $ -./library/compiler/compiler.factor:! $Id: compiler.factor,v 1.32 2004/12/27 20:27:17 spestov Exp $ -./library/compiler/linearizer.factor:! $Id: linearizer.factor,v 1.19 2005/01/01 22:20:47 spestov Exp $ -./library/vectors.factor:! $Id: vectors.factor,v 1.25 2004/12/30 07:40:13 spestov Exp $ -./library/kernel.factor:! $Id: kernel.factor,v 1.16 2004/12/31 07:17:43 spestov Exp $ +./library/compiler/simplifier.factor:! $Id: simplifier.factor,v 1.9 2005/01/19 02:42:21 spestov Exp $ +./library/compiler/xt.factor:! $Id: xt.factor,v 1.8 2005/01/07 02:42:07 spestov Exp $ +./library/compiler/assembler.factor:! $Id: assembler.factor,v 1.12 2005/02/15 02:58:05 spestov Exp $ +./library/compiler/generator.factor:! $Id: generator.factor,v 1.13 2005/01/17 20:32:56 spestov Exp $ +./library/compiler/x86/assembler.factor:! $Id: assembler.factor,v 1.3 2005/01/16 22:57:59 spestov Exp $ +./library/compiler/x86/fixnum.factor:! $Id: fixnum.factor,v 1.6 2005/02/17 04:24:35 spestov Exp $ +./library/compiler/optimizer.factor:! $Id: optimizer.factor,v 1.19 2005/01/20 02:01:46 spestov Exp $ +./library/compiler/compiler.factor:! $Id: compiler.factor,v 1.33 2005/01/07 00:10:00 spestov Exp $ +./library/compiler/linearizer.factor:! $Id: linearizer.factor,v 1.22 2005/02/18 00:01:10 spestov Exp $ +./library/ui/line-editor.factor:! $Id: line-editor.factor,v 1.3 2005/01/04 05:41:14 spestov Exp $ +./library/ui/console.factor:! $Id: console.factor,v 1.17 2005/02/15 03:15:02 spestov Exp $ ./library/win32/win32-io.factor:! $Id: win32-io.factor,v 1.3 2004/12/29 07:16:03 eiz Exp $ -./library/win32/win32-errors.factor:! $Id: win32-errors.factor,v 1.3 2004/12/29 07:16:03 eiz Exp $ -./library/win32/winsock.factor:! $Id: winsock.factor,v 1.2 2004/12/29 07:16:03 eiz Exp $ -./library/httpd/file-responder.factor:! $Id: file-responder.factor,v 1.16 2004/12/19 08:04:02 spestov Exp $ -./library/httpd/http-common.factor:! $Id: http-common.factor,v 1.17 2004/12/19 08:04:02 spestov Exp $ -./library/httpd/quit-responder.factor:! $Id: quit-responder.factor,v 1.6 2004/12/11 00:29:03 spestov Exp $ -./library/httpd/responder.factor:! $Id: responder.factor,v 1.18 2004/12/11 00:29:03 spestov Exp $ +./library/win32/win32-errors.factor:! $Id: win32-errors.factor,v 1.5 2005/02/07 23:04:49 eiz Exp $ +./library/win32/winsock.factor:! $Id: winsock.factor,v 1.3 2005/02/18 04:01:29 eiz Exp $ +./library/httpd/file-responder.factor:! $Id: file-responder.factor,v 1.17 2005/01/29 05:07:55 spestov Exp $ +./library/httpd/http-common.factor:! $Id: http-common.factor,v 1.19 2005/02/15 03:15:00 spestov Exp $ +./library/httpd/quit-responder.factor:! $Id: quit-responder.factor,v 1.7 2005/02/15 03:15:00 spestov Exp $ +./library/httpd/responder.factor:! $Id: responder.factor,v 1.19 2005/01/14 00:49:44 spestov Exp $ ./library/httpd/resource-responder.factor:! $Id: resource-responder.factor,v 1.4 2004/12/11 00:29:03 spestov Exp $ -./library/httpd/default-responders.factor:! $Id: default-responders.factor,v 1.12 2004/12/24 07:52:00 spestov Exp $ -./library/httpd/html.factor:! $Id: html.factor,v 1.22 2004/12/24 07:52:00 spestov Exp $ +./library/httpd/default-responders.factor:! $Id: default-responders.factor,v 1.13 2005/02/14 21:44:15 doublec Exp $ ./library/httpd/test-responder.factor:! $Id: test-responder.factor,v 1.5 2004/12/11 00:29:03 spestov Exp $ -./library/httpd/httpd.factor:! $Id: httpd.factor,v 1.23 2004/12/26 02:28:46 spestov Exp $ -./library/httpd/url-encoding.factor:! $Id: url-encoding.factor,v 1.13 2004/12/29 08:35:44 spestov Exp $ -./library/math/arc-trig-hyp.factor:! $Id: arc-trig-hyp.factor,v 1.7 2004/12/29 08:35:45 spestov Exp $ -./library/math/float.factor:! $Id: float.factor,v 1.1 2004/12/19 04:18:31 spestov Exp $ -./library/math/complex.factor:! $Id: complex.factor,v 1.6 2004/12/31 07:17:45 spestov Exp $ -./library/math/constants.factor:! $Id: constants.factor,v 1.2 2004/09/19 02:29:28 spestov Exp $ -./library/math/integer.factor:! $Id: integer.factor,v 1.4 2004/12/31 01:46:20 spestov Exp $ -./library/math/math-combinators.factor:! $Id: math-combinators.factor,v 1.11 2004/12/29 08:35:45 spestov Exp $ -./library/math/pow.factor:! $Id: pow.factor,v 1.9 2004/12/11 00:29:04 spestov Exp $ -./library/math/math.factor:! $Id: math.factor,v 1.14 2004/12/30 07:40:14 spestov Exp $ -./library/math/ratio.factor:! $Id: ratio.factor,v 1.3 2004/12/31 07:17:45 spestov Exp $ -./library/math/trig-hyp.factor:! $Id: trig-hyp.factor,v 1.9 2004/12/11 00:29:04 spestov Exp $ -./library/errors.factor:! $Id: errors.factor,v 1.18 2004/12/24 07:51:58 spestov Exp $ -./library/random.factor:! $Id: random.factor,v 1.9 2004/12/29 08:35:43 spestov Exp $ -./library/combinators.factor:! $Id: combinators.factor,v 1.18 2004/12/24 07:51:58 spestov Exp $ -./library/words.factor:! $Id: words.factor,v 1.21 2004/12/31 07:17:43 spestov Exp $ -./library/continuations.factor:! $Id: continuations.factor,v 1.6 2004/12/11 00:29:00 spestov Exp $ -./library/assoc.factor:! $Id: assoc.factor,v 1.13 2005/01/01 22:20:46 spestov Exp $ -./library/list-namespaces.factor:! $Id: list-namespaces.factor,v 1.13 2004/12/23 06:14:04 spestov Exp $ -./library/inference/words.factor:! $Id: words.factor,v 1.34 2004/12/31 07:17:44 spestov Exp $ -./library/inference/dataflow.factor:! $Id: dataflow.factor,v 1.21 2004/12/26 06:42:08 spestov Exp $ -./library/inference/stack.factor:! $Id: stack.factor,v 1.10 2004/12/11 00:29:03 spestov Exp $ -./library/inference/branches.factor:! $Id: branches.factor,v 1.39 2005/01/01 22:20:47 spestov Exp $ -./library/inference/inference.factor:! $Id: inference.factor,v 1.27 2004/12/31 07:17:44 spestov Exp $ -./library/inference/types.factor:! $Id: types.factor,v 1.2 2004/12/31 07:17:44 spestov Exp $ -./library/vocabularies.factor:! $Id: vocabularies.factor,v 1.22 2004/12/25 23:08:18 spestov Exp $ -./library/generic/object.factor:! $Id: object.factor,v 1.6 2004/12/29 23:01:22 spestov Exp $ -./library/generic/builtin.factor:! $Id: builtin.factor,v 1.10 2004/12/29 23:01:22 spestov Exp $ -./library/generic/generic.factor:! $Id: generic.factor,v 1.16 2005/01/01 22:20:47 spestov Exp $ -./library/generic/predicate.factor:! $Id: predicate.factor,v 1.9 2004/12/31 07:17:43 spestov Exp $ -./library/generic/traits.factor:! $Id: traits.factor,v 1.6 2005/01/01 23:02:22 spestov Exp $ -./library/generic/union.factor:! $Id: union.factor,v 1.6 2004/12/29 23:01:22 spestov Exp $ -./library/lists.factor:! $Id: lists.factor,v 1.44 2005/01/01 22:20:46 spestov Exp $ -./library/stack.factor:! $Id: stack.factor,v 1.8 2004/12/24 07:51:59 spestov Exp $ -./library/primitives.factor:! $Id: primitives.factor,v 1.20 2004/12/31 07:17:43 spestov Exp $ -./library/cons.factor:! $Id: cons.factor,v 1.12 2005/01/01 22:20:46 spestov Exp $ -./library/bootstrap/boot-stage2.factor:! $Id: boot-stage2.factor,v 1.31 2004/12/31 07:17:43 spestov Exp $ -./library/bootstrap/win32-io.factor:! $Id: win32-io.factor,v 1.3 2004/12/29 07:15:59 eiz Exp $ -./library/bootstrap/image.factor:! $Id: image.factor,v 1.15 2005/01/01 22:20:47 spestov Exp $ -./library/bootstrap/init-stage2.factor:! $Id: init-stage2.factor,v 1.23 2004/12/29 08:35:43 spestov Exp $ -./library/bootstrap/primitives.factor:! $Id: primitives.factor,v 1.11 2005/01/01 22:20:47 spestov Exp $ -./library/bootstrap/init.factor:! $Id: init.factor,v 1.6 2004/12/24 04:55:21 spestov Exp $ -./library/bootstrap/boot.factor:! $Id: boot.factor,v 1.16 2004/12/31 23:51:30 spestov Exp $ -./library/sdl/sdl-video.factor:! $Id: sdl-video.factor,v 1.13 2004/12/25 23:08:19 spestov Exp $ +./library/httpd/url-encoding.factor:! $Id: url-encoding.factor,v 1.14 2005/01/13 22:28:27 spestov Exp $ +./library/inference/dataflow.factor:! $Id: dataflow.factor,v 1.23 2005/01/14 19:56:13 spestov Exp $ +./library/inference/test.factor:! $Id: test.factor,v 1.2 2005/01/13 22:28:28 spestov Exp $ +./library/inference/stack.factor:! $Id: stack.factor,v 1.12 2005/01/16 22:58:25 spestov Exp $ +./library/inference/inference.factor:! $Id: inference.factor,v 1.35 2005/02/09 03:02:41 spestov Exp $ +./library/bootstrap/win32-io.factor:! $Id: win32-io.factor,v 1.4 2005/02/07 14:46:56 eiz Exp $ +./library/bootstrap/image.factor:! $Id: image.factor,v 1.25 2005/02/10 00:58:52 spestov Exp $ +./library/bootstrap/init.factor:! $Id: init.factor,v 1.8 2005/02/07 23:04:34 eiz Exp $ +./library/sdl/sdl-video.factor:! $Id: sdl-video.factor,v 1.14 2005/01/23 21:47:28 spestov Exp $ ./library/sdl/sdl.factor:! $Id: sdl.factor,v 1.5 2004/12/18 05:38:51 spestov Exp $ ./library/sdl/sdl-gfx.factor:! $Id: sdl-gfx.factor,v 1.5 2004/12/18 04:02:19 spestov Exp $ -./library/sdl/sdl-utils.factor:! $Id: sdl-utils.factor,v 1.8 2004/12/26 23:52:58 spestov Exp $ -./library/sdl/sdl-keysym.factor:! $Id: sdl-keysym.factor,v 1.1 2004/11/10 02:51:43 spestov Exp $ -./library/sdl/sdl-keyboard.factor:! $Id: sdl-keyboard.factor,v 1.1 2004/12/26 23:52:58 spestov Exp $ -./library/sdl/sdl-event.factor:! $Id: sdl-event.factor,v 1.9 2004/12/18 04:02:19 spestov Exp $ -./library/tools/jedit-wire.factor:! $Id: jedit-wire.factor,v 1.10 2005/01/01 22:20:48 spestov Exp $ -./library/tools/heap-stats.factor:! $Id: heap-stats.factor,v 1.6 2004/12/29 08:35:46 spestov Exp $ -./library/tools/debugger.factor:! $Id: debugger.factor,v 1.20 2004/12/29 08:35:45 spestov Exp $ +./library/sdl/sdl-keysym.factor:! $Id: sdl-keysym.factor,v 1.3 2005/01/14 00:49:45 spestov Exp $ +./library/sdl/sdl-event.factor:! $Id: sdl-event.factor,v 1.11 2005/02/04 03:21:51 spestov Exp $ +./library/tools/jedit-wire.factor:! $Id: jedit-wire.factor,v 1.12 2005/02/15 03:15:02 spestov Exp $ ./library/tools/profiler.factor:! $Id: profiler.factor,v 1.2 2004/12/11 00:29:07 spestov Exp $ -./library/tools/jedit.factor:! $Id: jedit.factor,v 1.3 2004/12/19 08:04:03 spestov Exp $ -./library/tools/listener.factor:! $Id: listener.factor,v 1.13 2005/01/02 21:31:43 spestov Exp $ -./library/tools/interpreter.factor:! $Id: interpreter.factor,v 1.13 2005/01/01 23:02:23 spestov Exp $ -./library/tools/word-tools.factor:! $Id: word-tools.factor,v 1.7 2005/01/01 22:20:48 spestov Exp $ -./library/tools/telnetd.factor:! $Id: telnetd.factor,v 1.5 2004/12/29 08:35:46 spestov Exp $ -./library/hashtables.factor:! $Id: hashtables.factor,v 1.15 2004/12/28 05:04:19 spestov Exp $ -./library/syntax/prettyprint.factor:! $Id: prettyprint.factor,v 1.12 2004/12/29 23:01:22 spestov Exp $ -./library/syntax/see.factor:! $Id: see.factor,v 1.7 2004/12/30 07:40:14 spestov Exp $ -./library/syntax/parse-syntax.factor:! $Id: parse-syntax.factor,v 1.7 2004/12/15 21:57:29 spestov Exp $ ./library/syntax/parse-numbers.factor:! $Id: parse-numbers.factor,v 1.4 2004/12/19 04:18:32 spestov Exp $ -./library/syntax/parse-stream.factor:! $Id: parse-stream.factor,v 1.4 2004/12/29 08:35:45 spestov Exp $ -./library/syntax/parser.factor:! $Id: parser.factor,v 1.5 2004/12/29 08:35:45 spestov Exp $ -./library/syntax/unparser.factor:! $Id: unparser.factor,v 1.8 2004/12/29 08:35:45 spestov Exp $ -./library/gensym.factor:! $Id: gensym.factor,v 1.4 2004/12/29 08:35:43 spestov Exp $ -./library/strings.factor:! $Id: strings.factor,v 1.29 2004/12/31 07:17:43 spestov Exp $ -./library/in-thread.factor:! $Id: in-thread.factor,v 1.4 2004/12/26 02:28:46 spestov Exp $ -./library/cli.factor:! $Id: cli.factor,v 1.10 2004/12/29 08:35:43 spestov Exp $ -./library/eval-catch.factor:! $Id: eval-catch.factor,v 1.5 2004/12/26 02:28:46 spestov Exp $ -./library/threads.factor:! $Id: threads.factor,v 1.4 2004/12/27 11:56:05 eiz Exp $ -./library/sbuf.factor:! $Id: sbuf.factor,v 1.15 2004/12/19 08:04:01 spestov Exp $ -./library/namespaces.factor:! $Id: namespaces.factor,v 1.21 2004/12/29 08:35:43 spestov Exp $ -./library/io/vocabulary-style.factor:! $Id: vocabulary-style.factor,v 1.2 2004/12/11 00:29:04 spestov Exp $ -./library/io/ansi.factor:! $Id: ansi.factor,v 1.8 2004/12/29 08:35:45 spestov Exp $ -./library/io/win32-io-internals.factor:! $Id: win32-io-internals.factor,v 1.4 2004/12/29 07:16:03 eiz Exp $ -./library/io/network.factor:! $Id: network.factor,v 1.5 2004/12/27 11:56:05 eiz Exp $ -./library/io/win32-stream.factor:! $Id: win32-stream.factor,v 1.6 2005/01/02 21:14:21 eiz Exp $ +./library/syntax/parse-stream.factor:! $Id: parse-stream.factor,v 1.6 2005/02/15 03:15:01 spestov Exp $ +./library/io/vocabulary-style.factor:! $Id: vocabulary-style.factor,v 1.4 2005/02/14 21:44:15 doublec Exp $ +./library/io/win32-io-internals.factor:! $Id: win32-io-internals.factor,v 1.8 2005/02/15 03:15:01 spestov Exp $ +./library/io/win32-stream.factor:! $Id: win32-stream.factor,v 1.10 2005/02/18 08:48:56 eiz Exp $ ./library/io/stdio-binary.factor:! $Id: stdio-binary.factor,v 1.2 2004/12/11 00:29:04 spestov Exp $ -./library/io/io-internals.factor:! $Id: io-internals.factor,v 1.5 2004/12/27 11:56:05 eiz Exp $ -./library/io/presentation.factor:! $Id: presentation.factor,v 1.3 2004/12/20 20:29:54 spestov Exp $ -./library/io/stream-impl.factor:! $Id: stream-impl.factor,v 1.5 2004/12/11 23:18:42 spestov Exp $ -./library/io/buffer.factor:! $Id: buffer.factor,v 1.4 2005/01/02 21:14:21 eiz Exp $ -./library/io/stream.factor:! $Id: stream.factor,v 1.8 2004/12/29 08:35:45 spestov Exp $ -./library/io/files.factor:! $Id: files.factor,v 1.5 2005/01/01 22:20:47 spestov Exp $ -./library/io/logging.factor:! $Id: logging.factor,v 1.3 2004/12/11 00:29:04 spestov Exp $ -./library/io/stdio.factor:! $Id: stdio.factor,v 1.8 2004/12/29 08:35:45 spestov Exp $ -./library/io/win32-console.factor:! $Id: win32-console.factor,v 1.5 2004/12/29 08:35:45 spestov Exp $ -./library/io/win32-server.factor:! $Id: win32-server.factor,v 1.3 2005/01/02 21:14:21 eiz Exp $ -./factor/ExternalFactor.java: * $Id: ExternalFactor.java,v 1.12 2005/01/02 21:22:11 spestov Exp $ +./library/io/io-internals.factor:! $Id: io-internals.factor,v 1.7 2005/02/15 03:15:01 spestov Exp $ +./library/io/presentation.factor:! $Id: presentation.factor,v 1.5 2005/02/15 03:15:01 spestov Exp $ +./library/io/buffer.factor:! $Id: buffer.factor,v 1.5 2005/02/12 07:23:38 eiz Exp $ +./library/io/logging.factor:! $Id: logging.factor,v 1.6 2005/02/15 03:15:01 spestov Exp $ +./library/io/win32-server.factor:! $Id: win32-server.factor,v 1.8 2005/02/18 08:48:56 eiz Exp $ +./factor/ExternalFactor.java: * $Id: ExternalFactor.java,v 1.16 2005/02/17 02:54:35 spestov Exp $ ./factor/math/Complex.java: * $Id: Complex.java,v 1.1.1.1 2004/07/16 06:26:13 spestov Exp $ ./factor/math/FactorNumber.java: * $Id: FactorNumber.java,v 1.1.1.1 2004/07/16 06:26:12 spestov Exp $ ./factor/math/NumberParser.java: * $Id: NumberParser.java,v 1.2 2004/08/07 22:45:47 spestov Exp $ ./factor/math/Ratio.java: * $Id: Ratio.java,v 1.1.1.1 2004/07/16 06:26:13 spestov Exp $ ./factor/math/FactorMath.java: * $Id: FactorMath.java,v 1.2 2004/08/26 23:37:16 spestov Exp $ ./factor/FactorExternalizable.java: * $Id: FactorExternalizable.java,v 1.1.1.1 2004/07/16 06:26:06 spestov Exp $ -./factor/FactorArray.java: * $Id: FactorArray.java,v 1.7 2004/11/20 21:56:59 spestov Exp $ -./factor/FactorSymbolDefinition.java:* $Id: FactorSymbolDefinition.java,v 1.4 2004/12/06 00:42:55 spestov Exp $ +./factor/FactorArray.java: * $Id: FactorArray.java,v 1.8 2005/01/07 19:37:20 spestov Exp $ ./factor/FactorLib.java: * $Id: FactorLib.java,v 1.8 2004/11/17 04:04:50 spestov Exp $ ./factor/ReadTable.java: * $Id: ReadTable.java,v 1.4 2004/09/06 00:14:36 spestov Exp $ -./factor/FactorReader.java: * $Id: FactorReader.java,v 1.15 2004/12/20 21:06:42 spestov Exp $ +./factor/FactorReader.java: * $Id: FactorReader.java,v 1.17 2005/01/21 04:10:37 spestov Exp $ ./factor/FactorParsingDefinition.java: * $Id: FactorParsingDefinition.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ -./factor/FactorTraitsDefinition.java:* $Id: FactorTraitsDefinition.java,v 1.1 2004/12/06 00:42:55 spestov Exp $ -./factor/Cons.java: * $Id: Cons.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ -./factor/FactorGenericDefinition.java:* $Id: FactorGenericDefinition.java,v 1.1 2004/12/06 00:42:55 spestov Exp $ -./factor/FactorCompoundDefinition.java:* $Id: FactorCompoundDefinition.java,v 1.7 2004/12/06 00:42:55 spestov Exp $ -./factor/DefaultVocabularyLookup.java: * $Id: DefaultVocabularyLookup.java,v 1.5 2004/12/20 00:36:10 spestov Exp $ +./factor/Cons.java: * $Id: Cons.java,v 1.5 2005/01/14 00:49:42 spestov Exp $ +./factor/DefaultVocabularyLookup.java: * $Id: DefaultVocabularyLookup.java,v 1.11 2005/02/17 02:54:35 spestov Exp $ ./factor/parser/ComplexLiteral.java: * $Id: ComplexLiteral.java,v 1.4 2004/11/17 04:04:50 spestov Exp $ ./factor/parser/Base.java: * $Id: Base.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ -./factor/parser/Symbol.java: * $Id: Symbol.java,v 1.5 2004/12/06 00:42:55 spestov Exp $ ./factor/parser/NoParsing.java: * $Id: NoParsing.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ -./factor/parser/Traits.java: * $Id: Traits.java,v 1.3 2004/12/20 02:07:16 spestov Exp $ ./factor/parser/StringLiteral.java: * $Id: StringLiteral.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ -./factor/parser/Bar.java: * $Id: Bar.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ -./factor/parser/BeginMethod.java: * $Id: BeginMethod.java,v 1.3 2004/12/23 03:16:44 spestov Exp $ -./factor/parser/Def.java: * $Id: Def.java,v 1.8 2004/12/06 00:42:55 spestov Exp $ +./factor/parser/BeginMethod.java: * $Id: BeginMethod.java,v 1.4 2005/01/07 19:37:21 spestov Exp $ +./factor/parser/Tuple.java: * $Id: Tuple.java,v 1.2 2005/02/06 03:51:40 spestov Exp $ +./factor/parser/Def.java: * $Id: Def.java,v 1.9 2005/01/07 19:37:21 spestov Exp $ ./factor/parser/F.java: * $Id: F.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ ./factor/parser/CharLiteral.java: * $Id: CharLiteral.java,v 1.6 2004/11/17 04:04:50 spestov Exp $ ./factor/parser/LineComment.java: * $Id: LineComment.java,v 1.4 2004/11/19 22:28:23 spestov Exp $ +./factor/parser/BeginUnion.java: * $Id: BeginUnion.java,v 1.1 2005/01/07 19:37:21 spestov Exp $ +./factor/parser/Using.java: * $Id: Using.java,v 1.2 2005/01/29 21:39:29 spestov Exp $ ./factor/parser/T.java: * $Id: T.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ ./factor/parser/StackComment.java: * $Id: StackComment.java,v 1.4 2004/11/19 22:28:23 spestov Exp $ -./factor/parser/BeginConstructor.java: * $Id: BeginConstructor.java,v 1.1 2004/12/12 21:32:46 spestov Exp $ -./factor/parser/Generic.java: * $Id: Generic.java,v 1.1 2004/12/06 00:42:55 spestov Exp $ +./factor/parser/BeginConstructor.java: * $Id: BeginConstructor.java,v 1.2 2005/01/07 19:37:21 spestov Exp $ +./factor/parser/Definer.java: * $Id: Definer.java,v 1.1 2005/01/07 00:10:00 spestov Exp $ ./factor/parser/PushWord.java: * $Id: PushWord.java,v 1.2 2004/11/17 04:04:50 spestov Exp $ +./factor/parser/BeginPredicate.java: * $Id: BeginPredicate.java,v 1.1 2005/01/07 19:37:21 spestov Exp $ +./factor/parser/BeginCons.java: * $Id: BeginCons.java,v 1.1 2005/01/14 00:49:43 spestov Exp $ ./factor/parser/Use.java: * $Id: Use.java,v 1.4 2004/11/17 04:04:50 spestov Exp $ ./factor/parser/EndVector.java: * $Id: EndVector.java,v 1.2 2004/11/17 04:04:50 spestov Exp $ ./factor/parser/Ket.java: * $Id: Ket.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ -./factor/parser/Defer.java: * $Id: Defer.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ -./factor/parser/Ine.java: * $Id: Ine.java,v 1.8 2004/12/06 00:42:55 spestov Exp $ +./factor/parser/Ine.java: * $Id: Ine.java,v 1.10 2005/01/07 19:37:21 spestov Exp $ +./factor/parser/EndCons.java: * $Id: EndCons.java,v 1.1 2005/01/14 00:49:43 spestov Exp $ ./factor/parser/Bra.java: * $Id: Bra.java,v 1.3 2004/11/17 04:04:50 spestov Exp $ ./factor/parser/In.java: * $Id: In.java,v 1.5 2004/12/12 21:32:46 spestov Exp $ ./factor/parser/BeginVector.java: * $Id: BeginVector.java,v 1.2 2004/11/17 04:04:50 spestov Exp $ -./factor/FactorWord.java: * $Id: FactorWord.java,v 1.10 2004/12/05 23:33:19 spestov Exp $ -./factor/VocabularyLookup.java: * $Id: VocabularyLookup.java,v 1.3 2004/12/20 00:36:10 spestov Exp $ -./factor/jedit/FactorAsset.java: * $Id: FactorAsset.java,v 1.5 2004/11/19 22:28:23 spestov Exp $ +./factor/FactorWord.java: * $Id: FactorWord.java,v 1.11 2005/01/07 00:09:59 spestov Exp $ +./factor/VocabularyLookup.java: * $Id: VocabularyLookup.java,v 1.4 2005/02/17 02:54:35 spestov Exp $ +./factor/jedit/AbstractCompletion.java: * $Id: AbstractCompletion.java,v 1.1 2005/02/17 02:54:36 spestov Exp $ +./factor/jedit/FactorVocabCompletion.java: * $Id: FactorVocabCompletion.java,v 1.1 2005/02/17 02:54:36 spestov Exp $ +./factor/jedit/FactorAsset.java: * $Id: FactorAsset.java,v 1.6 2005/01/07 00:09:59 spestov Exp $ +./factor/jedit/InferBufferProcessor.java: * $Id: InferBufferProcessor.java,v 1.3 2005/01/24 02:53:55 spestov Exp $ ./factor/jedit/FactorParsedData.java: * $Id: FactorParsedData.java,v 1.4 2004/12/19 06:48:31 spestov Exp $ ./factor/jedit/RestartableFactorScanner.java: * $Id: RestartableFactorScanner.java,v 1.3 2004/12/12 21:32:46 spestov Exp $ -./factor/jedit/FactorSideKickParser.java: * $Id: FactorSideKickParser.java,v 1.22 2004/12/24 04:55:21 spestov Exp $ -./factor/jedit/EditWordDialog.java: * $Id: EditWordDialog.java,v 1.6 2004/12/20 00:36:10 spestov Exp $ -./factor/jedit/FactorPlugin.java: * $Id: FactorPlugin.java,v 1.39 2005/01/02 21:31:43 spestov Exp $ +./factor/jedit/FactorSideKickParser.java: * $Id: FactorSideKickParser.java,v 1.26 2005/02/17 02:54:36 spestov Exp $ +./factor/jedit/EditWordDialog.java: * $Id: EditWordDialog.java,v 1.7 2005/02/17 02:54:36 spestov Exp $ +./factor/jedit/FactorPlugin.java: * $Id: FactorPlugin.java,v 1.45 2005/02/18 02:19:26 spestov Exp $ ./factor/jedit/FactorOptionPane.java: * $Id: FactorOptionPane.java,v 1.2 2004/11/27 03:23:55 spestov Exp $ -./factor/jedit/FactorShell.java: * $Id: FactorShell.java,v 1.10 2004/12/29 23:01:22 spestov Exp $ -./factor/jedit/FactorCompletion.java: * $Id: FactorCompletion.java,v 1.9 2004/12/31 01:46:19 spestov Exp $ -./factor/jedit/WordPreview.java: * $Id: WordPreview.java,v 1.9 2004/12/05 23:33:19 spestov Exp $ +./factor/jedit/FactorShell.java: * $Id: FactorShell.java,v 1.11 2005/02/10 22:36:19 spestov Exp $ +./factor/jedit/WordPreview.java: * $Id: WordPreview.java,v 1.12 2005/02/17 02:54:36 spestov Exp $ ./factor/jedit/WordListDialog.java: * $Id: WordListDialog.java,v 1.4 2004/12/20 02:06:55 spestov Exp $ -./factor/jedit/WordPopup.java: * $Id: WordPopup.java,v 1.1 2004/12/20 23:02:42 spestov Exp $ -./factor/jedit/ListenerAttributeSet.java: * $Id: ListenerAttributeSet.java,v 1.4 2004/11/26 04:14:16 spestov Exp $ -./factor/jedit/FactorWordRenderer.java: * $Id: FactorWordRenderer.java,v 1.13 2004/12/06 00:42:55 spestov Exp $ +./factor/jedit/ListenerAttributeSet.java: * $Id: ListenerAttributeSet.java,v 1.5 2005/01/07 19:37:21 spestov Exp $ +./factor/jedit/FactorBufferProcessor.java: * $Id: FactorBufferProcessor.java,v 1.4 2005/01/24 02:53:55 spestov Exp $ +./factor/jedit/CompileBufferProcessor.java: * $Id: CompileBufferProcessor.java,v 1.2 2005/01/24 02:53:55 spestov Exp $ +./factor/jedit/FactorWordRenderer.java: * $Id: FactorWordRenderer.java,v 1.14 2005/01/07 00:10:00 spestov Exp $ +./factor/jedit/TextAreaPopup.java: * $Id: TextAreaPopup.java,v 1.1 2005/01/08 05:15:35 spestov Exp $ ./factor/jedit/InsertUseDialog.java: * $Id: InsertUseDialog.java,v 1.3 2004/09/04 05:05:49 spestov Exp $ -./factor/FactorWordDefinition.java: * $Id: FactorWordDefinition.java,v 1.6 2004/12/06 00:42:55 spestov Exp $ +./factor/jedit/FactorWordCompletion.java: * $Id: FactorWordCompletion.java,v 1.1 2005/02/17 02:54:36 spestov Exp $ ./factor/FactorStream.java: * $Id: FactorStream.java,v 1.1 2004/11/19 04:23:12 spestov Exp $ -./factor/FactorMethodDefinition.java: * $Id: FactorMethodDefinition.java,v 1.1 2004/12/06 00:42:55 spestov Exp $ +./factor/FactorMethodDefinition.java: * $Id: FactorMethodDefinition.java,v 1.2 2005/01/07 00:09:59 spestov Exp $ ./factor/FactorScanner.java: * $Id: FactorScanner.java,v 1.7 2004/12/05 23:33:19 spestov Exp $ ./factor/FactorParseException.java: * $Id: FactorParseException.java,v 1.3 2004/08/13 22:43:03 spestov Exp $ ./factor/FactorException.java: * $Id: FactorException.java,v 1.1.1.1 2004/07/16 06:26:06 spestov Exp $ ./examples/quadratic.factor:! $Id: quadratic.factor,v 1.3 2004/12/11 02:39:27 spestov Exp $ ./native/s48_bignum.c:$Id: s48_bignum.c,v 1.7 2004/12/11 02:39:45 spestov Exp $ -./native/s48_bignumint.h:$Id: s48_bignumint.h,v 1.9 2004/12/11 02:46:41 spestov Exp $ +./native/s48_bignumint.h:$Id: s48_bignumint.h,v 1.10 2005/01/28 01:06:10 spestov Exp $ ./native/s48_bignum.h:$Id: s48_bignum.h,v 1.7 2004/12/11 02:46:41 spestov Exp $ diff --git a/Makefile b/Makefile index 417c47a299..45e4277e61 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,14 @@ CC = gcc -DEFAULT_CFLAGS = -Wall -g $(SITE_CFLAGS) +DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS) DEFAULT_LIBS = -lm STRIP = strip -OBJS = native/arithmetic.o native/array.o native/bignum.o \ +UNIX_OBJS = native/unix/file.o native/unix/io.o native/unix/socket.o \ + native/unix/signal.o native/unix/read.o native/unix/write.o \ + native/unix/ffi.o native/unix/run.o + +OBJS = $(UNIX_OBJS) native/arithmetic.o native/array.o native/bignum.o \ native/s48_bignum.o \ native/complex.o native/cons.o native/error.o \ native/factor.o native/fixnum.o \ @@ -17,14 +21,8 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \ native/string.o native/types.o native/vector.o \ native/word.o native/compiler.o \ native/ffi.o native/boolean.o \ - native/unix/file.o \ - native/unix/io.o \ - native/unix/socket.o \ - native/unix/signal.o \ - native/unix/read.o \ - native/unix/write.o \ - native/unix/ffi.o \ - native/debug.o + native/debug.o \ + native/hashtable.o default: @echo "Run 'make' with one of the following parameters:" @@ -34,6 +32,7 @@ default: @echo "linux" @echo "macosx" @echo "solaris" + @echo "windows" @echo "" @echo "Also, you might want to set the SITE_CFLAGS environment" @echo "variable to enable some CPU-specific optimizations; this" @@ -54,12 +53,12 @@ bsd-nopthread: macosx: $(MAKE) f \ CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \ - LIBS="$(DEFAULT_LIBS)" + LIBS="$(DEFAULT_LIBS)" linux: $(MAKE) f \ CFLAGS="$(DEFAULT_CFLAGS) -DFFI -export-dynamic" \ - LIBS="$(DEFAULT_LIBS) -ldl" + LIBS="$(DEFAULT_LIBS) -ldl" solaris: $(MAKE) f \ @@ -68,7 +67,7 @@ solaris: f: $(OBJS) $(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS) - #$(STRIP) $@ + $(STRIP) $@ clean: rm -f $(OBJS) diff --git a/Makefile.win32 b/Makefile.win32 new file mode 100644 index 0000000000..804a9999f0 --- /dev/null +++ b/Makefile.win32 @@ -0,0 +1,52 @@ +CC = gcc +DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS) +DEFAULT_LIBS = -lm + +STRIP = strip + +WIN32_OBJS = native\win32\ffi.o native\win32\file.o native\win32\io.o \ + native\win32\misc.o native\win32\read.o native\win32\write.o \ + native\win32\run.o + +OBJS = $(WIN32_OBJS) native\arithmetic.o native\array.o native\bignum.o \ + native\s48_bignum.o \ + native\complex.o native\cons.o native\error.o \ + native\factor.o native\fixnum.o \ + native\float.o native\gc.o \ + native\image.o native\memory.o \ + native\misc.o native\port.o native\primitives.o \ + native\ratio.o native\relocate.o \ + native\run.o \ + native\sbuf.o native\stack.o \ + native\string.o native\types.o native\vector.o \ + native\word.o native\compiler.o \ + native\ffi.o native\boolean.o \ + native\debug.o \ + native\hashtable.o + +default: + @echo "Run 'make' with one of the following parameters:" + @echo "" + @echo "windows" + @echo "" + @echo "Also, you might want to set the SITE_CFLAGS environment" + @echo "variable to enable some CPU-specific optimizations; this" + @echo "can make a huge difference. Eg:" + @echo "" + @echo "export SITE_CFLAGS=\"-march=pentium4 -ffast-math\"" + +windows: + $(MAKE) -f Makefile.win32 f \ + CFLAGS="$(DEFAULT_CFLAGS) -DFFI -DWIN32" \ + LIBS="$(DEFAULT_LIBS)" + +f: $(OBJS) + $(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS) + $(STRIP) $@ + +clean: + del $(OBJS) + +.c.o: + $(CC) -c $(CFLAGS) -o $@ $< + diff --git a/README.WIN32.txt b/README.WIN32.txt deleted file mode 100644 index 0456ad39ff..0000000000 --- a/README.WIN32.txt +++ /dev/null @@ -1,20 +0,0 @@ -FACTOR ON WINDOWS - -The Windows port of Factor requires Windows 2000 or later. If you are -using Windows 95, 98 or NT, you might be able to get the Unix port of -Factor running inside Cygwin. Or you might not. - -A precompiled factor.exe is included with the download, along with -SDL.dll and SDL_gfx.dll. The SDL libraries are required for the -interactive interpreter. Factor does not use the Windows console, -because it does not support asynchronous I/O. - -To run the Windows port, open a DOS prompt and type: - - cd - - factor.exe boot.image.le32 -... Files are loaded and factor.image is written. - - factor.exe factor.image -... Factor starts the SDL console now. diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 5c06251c60..9a04a1a332 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,56 +1,63 @@ -+ compiler: +72/73: +- update plugin docs +- word preview for remote words +- faster completion + +- [ [ dup call ] dup call ] infer hangs +- type inference fails with some assembler words; + displaced, register and other predicates need to inherit from list + not cons, and need stronger branch partial eval +- print warning on null class - optimize away dispatch -- getenv/setenv: if literal arg, compile as a load/store -- assembler opcodes dispatch on operand types -+ oop: +- move tuple to generic vocab -- make see work with union, builtin, predicate -- doc comments of generics +- vectors: ensure its ok with bignum indices +- code gc +- ppc register decls -+ ffi: +- #jump-f #jump-f-label +- extract word inside M:, C:, and structure browsing for these +- fix checkbox alignment +- each-slot combinator +- references primitive +- resize window: world not updated until mouse moved +- x>offset +- fix completion invoke in middle of word +- don't hardcode so many colors +- ffi unicode strings: null char security hole +- utf16 string boxing +- sdl console crash +- UI: don't roll over if mouse button is down +- more accurate types for various words +- optimize out >array, >tuple, >hashtable etc +- write read: write should flush -- figure out how to load an image referring to missing libraries ++ compiler/ffi: + +- value type structs +- out parameters - is signed -vs- unsigned pointers an issue? - bitfields in C structs - SDL_Rect** type - struct membres that are not * - FFI float types -+ listener/plugin: ++ i/o: -- WordPreview calls markTokens() -> NPE - stream server can hang because of exception handler limitations -- listener should be multithreaded -- compile all, infer all commands -- faster completion -- errors don't always disappear -- NPE in ErrorHighlight -- maple-like: press enter at old commands to evaluate there -- completion in the listener -- special completion for USE:/IN: +- better i/o scheduler +- nicer way to combine two paths +- add a socket timeout +- unix ffi i/o + kernel: -- do partial objects cause problems? -- better i/o scheduler -- remove sbufs - cat, reverse-cat primitives -- first-class hashtables -- add a socket timeout - -+ misc: - -- perhaps /i should work with all numbers -- unit test weirdness: 2 lines appears at end -- jedit ==> jedit-word, jedit takes a file name -- nicer way to combine two paths -- browser responder for word links in HTTPd +- generational gc +- make see work with union, builtin, predicate +- doc comments of generics +- proper ordering for classes +- make-vector and make-string should not need a reverse step - worddef props -- prettyprint: when unparse called due to recursion, write a link - -+ httpd: - -- log with date -- file responder; last-modified field diff --git a/actions.xml b/actions.xml index ee174c35d5..654f989e9f 100644 --- a/actions.xml +++ b/actions.xml @@ -49,7 +49,7 @@ - WordPopup.showWordPopup(textArea); + FactorPlugin.factorWordPopupOp(view,"see"); @@ -82,4 +82,24 @@ FactorPlugin.extractWord(view); + + + FactorPlugin.factorWordPopupOp(view,"unit infer ."); + + + + + FactorPlugin.factorWordOutputOp(view,"recompile"); + + + + + InferBufferProcessor.createInferUnitTests(view,buffer); + + + + + new CompileBufferProcessor(view,buffer); + + diff --git a/boot.image.be32 b/boot.image.be32 index 82735ec66c..32516a3d5c 100644 Binary files a/boot.image.be32 and b/boot.image.be32 differ diff --git a/boot.image.be64 b/boot.image.be64 index 4b09d8318e..6ff34c96df 100644 Binary files a/boot.image.be64 and b/boot.image.be64 differ diff --git a/boot.image.le32 b/boot.image.le32 index 13d1d62971..9ccf2a1e68 100644 Binary files a/boot.image.le32 and b/boot.image.le32 differ diff --git a/boot.image.le64 b/boot.image.le64 index 5522c6fa7e..01530dff2d 100644 Binary files a/boot.image.le64 and b/boot.image.le64 differ diff --git a/contrib/cont-responder/cont-numbers-game.factor b/contrib/cont-responder/cont-numbers-game.factor index 598de12b8a..de8293aaba 100644 --- a/contrib/cont-responder/cont-numbers-game.factor +++ b/contrib/cont-responder/cont-numbers-game.factor @@ -39,7 +39,6 @@ USE: random USE: parser USE: html USE: cont-responder -USE: cont-utils USE: stdio USE: namespaces diff --git a/contrib/cont-responder/cont-testing.factor b/contrib/cont-responder/cont-testing.factor index 38030774c4..899b8b3712 100644 --- a/contrib/cont-responder/cont-testing.factor +++ b/contrib/cont-responder/cont-testing.factor @@ -39,7 +39,7 @@ ! eg. ! [ test-cont-responder ] test-cont-function ! => HTTP/1.1 302 Document Moved -! Location: 8506502852110820 +! Location: ?id=8506502852110820 ! Content-Length: 0 ! Content-Type: text/plain ! @@ -48,12 +48,12 @@ ! Content-Type: text/html ! ! Page one -!

Page one

Next +!

Page one

Next ! ! ! "5431597582800278" f test-cont-click ! => HTTP/1.1 302 Document Moved -! Location: 7944183606904129 +! Location: ?id=7944183606904129 ! Content-Length: 0 ! Content-Type: text/plain ! @@ -63,14 +63,14 @@ ! ! Enter your name !

Enter your name

-!
-! Name: -! +! +! Name: +! !
! -! "8503790719833723" [ [ "name" | "Chris" ] ] alist>hash test-cont-click +! "8503790719833723" [ [[ "name" "Chris" ]] ] alist>hash test-cont-click ! => HTTP/1.1 302 Document Moved -! Location: 8879727708050260 +! Location: ?id=8879727708050260 ! Content-Length: 0 ! Content-Type: text/plain ! @@ -80,7 +80,7 @@ ! ! Hello Chris !

Hello Chris

-! Next +! Next ! ! ! etc. diff --git a/contrib/cont-responder/cont-utils.factor b/contrib/cont-responder/cont-utils.factor deleted file mode 100644 index 0ed17a4117..0000000000 --- a/contrib/cont-responder/cont-utils.factor +++ /dev/null @@ -1,91 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! -! 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. -! -! General purpose words for display pages using the continuation -! based responder. -IN: cont-utils -USE: html -USE: cont-responder -USE: lists -USE: stdio -USE: kernel -USE: namespaces -USE: html - -: simple-page ( title quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. - - swap write - call - ; - -: styled-page ( title stylesheet-quot quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. stylesheet-quot - #! is called to generate the required stylesheet. - - - rot write - swap call - - call - ; - -: paragraph ( str -- ) - #! Output the string as an html paragraph -

write

; - -: show-message-page ( message -- ) - #! Display the message in an HTML page with an OK button. - [ - "Press OK to Continue" [ - swap paragraph - "OK" write - ] simple-page - ] show 2drop ; - -: vertical-layout ( list -- ) - #! Given a list of HTML components, arrange them vertically. - - [ ] each -
call
; - -: horizontal-layout ( list -- ) - #! Given a list of HTML components, arrange them horizontally. - - [ ] each -
call
; - -: button ( label -- ) - #! Output an HTML submit button with the given label. - ; - -: with-simple-html-output ( quot -- ) - #! Run the quotation inside an HTML stream wrapped - #! around stdio. - 
 
-    stdio get  [
-      call
-    ] with-stream
-
; diff --git a/contrib/cont-responder/eval-responder.factor b/contrib/cont-responder/eval-responder.factor index 41e9651aad..d2c02418da 100644 --- a/contrib/cont-responder/eval-responder.factor +++ b/contrib/cont-responder/eval-responder.factor @@ -26,7 +26,6 @@ IN: eval-responder USE: html USE: cont-responder -USE: cont-utils USE: kernel USE: stdio USE: namespaces @@ -73,7 +72,7 @@ USE: logging : escape-quotes ( string -- string ) #! Replace occurrences of single quotes with #! backslash quote. - [ dup [ [ CHAR: ' | "\\'" ] [ CHAR: " | "\\\"" ] ] assoc dup rot ? ] str-map ; + [ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc dup rot ? ] str-map ; : make-eval-javascript ( string -- string ) #! Give a string return some javascript that when @@ -110,7 +109,7 @@ USE: logging #! of the given word. dup dup [ - "responder" "inspect" put + "responder" "browser" put @@ -186,8 +185,8 @@ USE: logging #! All output should go to a string which is returned on the #! callstack along with the resulting datastack as a list. [ - "inspect" "responder" set - 1024 dup >r [ + "browser" "responder" set + 1024 dup >r [ do-eval ] with-stream r> stream>str ] bind ; diff --git a/contrib/cont-responder/live-updater-responder.factor b/contrib/cont-responder/live-updater-responder.factor index 1db05950cb..aad1ef7e19 100644 --- a/contrib/cont-responder/live-updater-responder.factor +++ b/contrib/cont-responder/live-updater-responder.factor @@ -31,7 +31,6 @@ USE: html USE: words USE: stdio USE: kernel -USE: cont-utils USE: cont-responder USE: prettyprint @@ -39,7 +38,7 @@ USE: prettyprint #! Given a string that is a factor word, show the #! aporpos of that word. [ - "responder" "inspect" put + "responder" "browser" put 
 
         stdio get  [   
           apropos.
diff --git a/contrib/cont-responder/live-updater.factor b/contrib/cont-responder/live-updater.factor
index ec38599582..16c28921a1 100644
--- a/contrib/cont-responder/live-updater.factor
+++ b/contrib/cont-responder/live-updater.factor
@@ -35,11 +35,11 @@ USE: lists
 
 : get-live-updater-js* ( stream -- string )
   #! Read all lines from the stream, creating a string of the result.
-  dup freadln dup [ , "\n" , get-live-updater-js* ] [ drop fclose ] ifte ;
+  dup stream-readln dup [ , "\n" , get-live-updater-js* ] [ drop stream-close ] ifte ;
 
 : get-live-updater-js ( filename -- string )
   #! Return the liveUpdater javascript code as a string.
-   [ get-live-updater-js* ] make-string ;
+   [ get-live-updater-js* ] make-string ;
 
 : live-updater-url ( -- url )
   #! Generate an URL to the liveUpdater.js code.
@@ -47,7 +47,7 @@ USE: lists
     [
       "js/liveUpdater.js" get-live-updater-js write
     ] show        
-  ] register-continuation ;
+  ] register-continuation id>url ;
 
 : include-live-updater-js ( -- )
   #! Write out the HTML script to include the live updater
@@ -96,7 +96,7 @@ USE: lists
     "document.getElementById('" write
     write
     "').onclick=liveUpdaterUri('" write
-    register-live-anchor-quot write
+    register-live-anchor-quot id>url write
     "');" write
    ;
   
@@ -153,7 +153,7 @@ USE: lists
     "liveSearch('" write
     write
     "', '" write
-    register-live-search-quot write
+    register-live-search-quot id>url write
     "');" write
    ;
 
diff --git a/contrib/cont-responder/load.factor b/contrib/cont-responder/load.factor
index 967a089a0f..d25f24ed15 100644
--- a/contrib/cont-responder/load.factor
+++ b/contrib/cont-responder/load.factor
@@ -33,19 +33,23 @@ USE: stdio
 
 USE: parser
 
-: l1  
-  "cont-responder.factor" run-file 
-  "cont-utils.factor" run-file ;
-: l2 
+: l1 
   "cont-examples.factor" run-file 
   "cont-numbers-game.factor" run-file ;
-: l3 "todo.factor" run-file ;
-: l4 "todo-example.factor" run-file ;
-: l5 "live-updater.factor" run-file ;
-: l6 "eval-responder.factor" run-file ;
-: l7 "live-updater-responder.factor" run-file ;
-: l8 "browser.factor" run-file ;
-: l9 "cont-testing.factor" run-file ;
-: la ;
+: l2 "todo.factor" run-file ;
+: l3 "todo-example.factor" run-file ;
+: l4 "live-updater.factor" run-file ;
+: l5 "eval-responder.factor" run-file ;
+: l6 "live-updater-responder.factor" run-file ;
+: l7 "cont-testing.factor" run-file ;
+: l8 
+  #! Use for reloading and testing changes to browser responder
+  #! in factor core.
+  "../../library/httpd/browser-responder.factor" run-file ;
+: l9
+  #! Use for reloading and testing changes to cont responder
+  #! in factor core.
+  "../../library/httpd/cont-responder.factor" run-file ;
+DEFER: la
 : la [ 8888 httpd ] [ dup . flush [ la ] when* ] catch ;
 : lb [ la "httpd thread exited.\n" write flush ] in-thread  ;
diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor
index 1bdf64f44a..a79b0b46c1 100644
--- a/contrib/cont-responder/todo-example.factor
+++ b/contrib/cont-responder/todo-example.factor
@@ -29,7 +29,6 @@
 IN: todo-example
 USE: cont-responder
 USE: html
-USE: cont-utils
 USE: html
 USE: stdio
 USE: strings
@@ -107,7 +106,7 @@ USE: kernel
 
 : todo-stylesheet-url ( -- url )
   #! Generate an URL for the stylesheet.
-  t [ [ drop todo-stylesheet write ] show ] register-continuation ;
+  t [ [ drop todo-stylesheet write ] show ] register-continuation id>url ;
 
 : include-todo-stylesheet ( -- )  
   #! Generate HTML to include the todo stylesheet
diff --git a/contrib/cont-responder/todo.factor b/contrib/cont-responder/todo.factor
index a773320a35..e748f8536b 100644
--- a/contrib/cont-responder/todo.factor
+++ b/contrib/cont-responder/todo.factor
@@ -91,22 +91,22 @@ USE: hashtables
 
 : store-todo (  filename -- )
   #! store the todo list in the given file.
-   [ write-todo ] with-stream ;
+   [ write-todo ] with-stream ;
 
 : read-todo ( --  )
   #! Read a todo list from the current input stream.
-  read url-decode read url-decode  
-  read str>number [
+  read-line url-decode read-line url-decode  
+  read-line str>number [
     dup
      [
-      read url-decode "yes" = "complete?" set
-      read url-decode "priority" set
-      read url-decode "description" set
+      read-line url-decode "yes" = "complete?" set
+      read-line url-decode "priority" set
+      read-line url-decode "description" set
     ] extend add-todo-item
   ] times ;
 
 : load-todo ( filename --  )
-   [ read-todo ] with-stream ;  
+   [ read-todo ] with-stream ;  
 
 : password-matches? ( password  --  )
   #! Returns the  if the password matches otherwise
diff --git a/contrib/sqlite/sqlite.factor b/contrib/sqlite/sqlite.factor
new file mode 100644
index 0000000000..bde8be34e3
--- /dev/null
+++ b/contrib/sqlite/sqlite.factor
@@ -0,0 +1,228 @@
+! Copyright (C) 2005 Chris Double.
+! 
+! 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.
+!
+! An interface to the sqlite database. Tested against sqlite v3.0.8.
+! Remeber to pass the following to factor:
+!  -libraries:sqlite=libsqlite3.so
+!
+! Not all functions have been wrapped yet. Only those directly involving
+! executing SQL calls and obtaining results.
+!
+IN: sqlite
+USE: kernel
+USE: alien
+USE: compiler
+USE: errors
+USE: strings
+USE: namespaces
+
+BEGIN-STRUCT: sqlite3
+END-STRUCT
+
+BEGIN-STRUCT: sqlite3-indirect
+  FIELD: sqlite3* pointer
+END-STRUCT
+
+BEGIN-STRUCT: sqlite3-stmt
+END-STRUCT
+
+BEGIN-STRUCT: sqlite3-stmt-indirect
+  FIELD: sqlite3-stmt* pointer
+END-STRUCT
+
+BEGIN-STRUCT: char*-indirect
+  FIELD: char* pointer
+END-STRUCT
+
+! Return values from sqlite functions
+: SQLITE_OK           0   ; ! Successful result
+: SQLITE_ERROR        1   ; ! SQL error or missing database
+: SQLITE_INTERNAL     2   ; ! An internal logic error in SQLite 
+: SQLITE_PERM         3   ; ! Access permission denied 
+: SQLITE_ABORT        4   ; ! Callback routine requested an abort 
+: SQLITE_BUSY         5   ; ! The database file is locked 
+: SQLITE_LOCKED       6   ; ! A table in the database is locked 
+: SQLITE_NOMEM        7   ; ! A malloc() failed 
+: SQLITE_READONLY     8   ; ! Attempt to write a readonly database 
+: SQLITE_INTERRUPT    9   ; ! Operation terminated by sqlite_interrupt() 
+: SQLITE_IOERR       10   ; ! Some kind of disk I/O error occurred 
+: SQLITE_CORRUPT     11   ; ! The database disk image is malformed 
+: SQLITE_NOTFOUND    12   ; ! (Internal Only) Table or record not found 
+: SQLITE_FULL        13   ; ! Insertion failed because database is full 
+: SQLITE_CANTOPEN    14   ; ! Unable to open the database file 
+: SQLITE_PROTOCOL    15   ; ! Database lock protocol error 
+: SQLITE_EMPTY       16   ; ! (Internal Only) Database table is empty 
+: SQLITE_SCHEMA      17   ; ! The database schema changed 
+: SQLITE_TOOBIG      18   ; ! Too much data for one row of a table 
+: SQLITE_CONSTRAINT  19   ; ! Abort due to contraint violation 
+: SQLITE_MISMATCH    20   ; ! Data type mismatch 
+: SQLITE_MISUSE      21   ; ! Library used incorrectly 
+: SQLITE_NOLFS       22   ; ! Uses OS features not supported on host 
+: SQLITE_AUTH        23   ; ! Authorization denied 
+: SQLITE_ROW         100  ; ! sqlite_step() has another row ready 
+: SQLITE_DONE        101  ; ! sqlite_step() has finished executing 
+
+! Return values from the sqlite3_column_type function
+: SQLITE_INTEGER     1 ;
+: SQLITE_FLOAT       2 ;
+: SQLITE_TEXT        3 ;
+: SQLITE_BLOB        4 ;
+: SQLITE_NULL        5 ;
+
+! Values for the 'destructor' parameter of the 'bind' routines. 
+: SQLITE_STATIC      0  ;
+: SQLITE_TRANSIENT   -1 ;
+
+: sqlite3_open ( filename sqlite3-indirect -- result )
+  "int" "sqlite" "sqlite3_open" [ "char*" "sqlite3-indirect*" ] alien-invoke ; compiled
+
+: sqlite3_close ( db -- )
+  "int" "sqlite" "sqlite3_close" [ "sqlite3*" ] alien-invoke ; compiled
+
+: sqlite3_prepare ( db sql sql-len sqlite3-stmt-indirect tail -- result )
+  "int" "sqlite" "sqlite3_prepare" [ "sqlite3*" "char*" "int" "sqlite3-stmt-indirect*" "char*-indirect*" ] alien-invoke ; compiled
+
+: sqlite3_finalize ( stmt -- result ) 
+  "int" "sqlite" "sqlite3_finalize" [ "sqlite3-stmt*" ] alien-invoke ; compiled
+
+: sqlite3_reset ( stmt -- result )
+  "int" "sqlite" "sqlite3_reset" [ "sqlite3-stmt*" ] alien-invoke ; compiled
+
+: sqlite3_step ( stmt -- result )
+  "int" "sqlite" "sqlite3_step" [ "sqlite3-stmt*" ] alien-invoke ; compiled
+
+: sqlite3_bind_blob ( stmt index pointer len destructor -- result )
+  "int" "sqlite" "sqlite3_bind_blob" [ "sqlite3-stmt*" "int" "void*" "int" "int" ] alien-invoke ; compiled
+
+: sqlite3_bind_int ( stmt index int -- result )
+  "int" "sqlite" "sqlite3_bind_int" [ "sqlite3-stmt*" "int" "int" ] alien-invoke ; compiled
+
+: sqlite3_bind_null ( stmt index  -- result )
+  "int" "sqlite" "sqlite3_bind_null" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
+
+: sqlite3_bind_text ( stmt index text len destructor -- result )
+  "int" "sqlite" "sqlite3_bind_text" [ "sqlite3-stmt*" "int" "char*" "int" "int" ] alien-invoke ; compiled
+
+: sqlite3_column_count ( stmt -- count )
+  "int" "sqlite" "sqlite3_column_count" [ "sqlite3-stmt*" ] alien-invoke ; compiled
+
+: sqlite3_column_blob ( stmt col -- void* )
+  "void*" "sqlite" "sqlite3_column_blob" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
+
+: sqlite3_column_bytes ( stmt col -- int )
+  "int" "sqlite" "sqlite3_column_bytes" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
+
+: sqlite3_column_decltype ( stmt col -- string )
+  "char*" "sqlite" "sqlite3_column_decltype" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
+
+: sqlite3_column_int ( stmt col -- int )
+  "int" "sqlite" "sqlite3_column_int" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
+
+: sqlite3_column_name ( stmt col -- string )
+  "char*" "sqlite" "sqlite3_column_name" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
+
+: sqlite3_column_text ( stmt col -- string )
+  "char*" "sqlite" "sqlite3_column_text" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
+
+: sqlite3_column_type ( stmt col -- int )
+  "int" "sqlite" "sqlite3_column_type" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
+
+! High level sqlite routines
+: sqlite-check-result ( result -- )
+  #! Check the result from a sqlite call is ok. If it is
+  #! return, otherwise throw an error. TODO: Throw the actual
+  #! error text message.
+  dup SQLITE_OK = [
+    drop 
+  ] [
+    "sqlite returned an error. See datastack for the error value." throw
+  ] ifte ;
+
+: sqlite-open ( filename -- db )
+  #! Open the database referenced by the filename and return
+  #! a handle to that database. An error is thrown if the database
+  #! failed to open.
+   tuck sqlite3_open sqlite-check-result sqlite3-indirect-pointer ;
+
+: sqlite-close ( db -- )
+  #! Close the given database
+  sqlite3_close sqlite-check-result ;
+
+: sqlite-prepare ( db sql -- statement )
+  #! Prepare a SQL statement. Returns the statement which
+  #! can have values bound to parameters or simply executed.
+  #! TODO: Support multiple statements in the SQL string.
+  dup str-length  dup >r 
+   sqlite3_prepare sqlite-check-result
+  r> sqlite3-stmt-indirect-pointer ;
+    
+: sqlite-finalize ( statement -- )
+  #! Clean up all resources related to a statement. Once called
+  #! the statement cannot be used. All statements must be finalized
+  #! before closing the database.
+  sqlite3_finalize sqlite-check-result ;
+
+: sqlite-reset ( statement -- )
+  #! Reset a statement so it can be called again, possibly with
+  #! different parameters.
+  sqlite3_reset sqlite-check-result ;
+
+: column-count ( statement -- int )
+  #! Given a prepared statement, return the number of
+  #! columns in each row of the result set of that statement.
+  sqlite3_column_count ;
+
+: column-text ( statement column -- string )
+  #! Return the value of the given column, indexed
+  #! from zero, as a string.
+  sqlite3_column_text ;
+
+: step-complete? ( step-result -- bool )
+  #! Return true if the result of a sqlite3_step is
+  #! such that the iteration has completed (ie. it is
+  #! SQLITE_DONE). Throw an error if an error occurs. 
+  dup SQLITE_ROW =  [
+    drop f
+  ] [
+    dup SQLITE_DONE = [
+      drop t 
+    ] [
+      sqlite-check-result
+    ] ifte
+  ] ifte ;
+
+: sqlite-each ( statement quot -- )    
+  #! Execute the SQL statement, and call the quotation for
+  #! each row returned from executing the statement with the
+  #! statement on the top of the stack.
+  over sqlite3_step step-complete? [ 
+    2drop
+  ] [
+    2dup 2slip sqlite-each
+  ] ifte ;
+
+! For comparison, here is the linrec implementation of sqlite-each
+! [ drop sqlite3_step step-complete? ]
+! [ 2drop ]
+! [ 2dup 2slip ]
+! [ ] linrec ; 
\ No newline at end of file
diff --git a/library/list-namespaces.factor b/contrib/sqlite/test.factor
similarity index 53%
rename from library/list-namespaces.factor
rename to contrib/sqlite/test.factor
index 0bab6cbfaa..59be1583cf 100644
--- a/library/list-namespaces.factor
+++ b/contrib/sqlite/test.factor
@@ -1,8 +1,4 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 2004 Slava Pestov.
+! Copyright (C) 2005 Chris Double.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -24,42 +20,36 @@
 ! 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: lists
+!
+! Test the sqlite interface
+!
+! Create a test database like follows:
+!
+!   sqlite3 test.db
+!   > create table test (name varchar(30), address varchar(30));
+!   > insert into test values('John', 'America');
+!   > insert into test values('Jane', 'New Zealand');
+!   > [eof]
+!
+!  Then run this file.
+USE: sqlite
 USE: kernel
-USE: namespaces
+USE: stdio
+USE: prettyprint
 
-: cons@ ( x var -- )
-    #! Prepend x to the list stored in var.
-    [ cons ] change ;
+: show-people ( statement -- )
+  dup 0 column-text write " from " write 1 column-text . ;
 
-: unique@ ( elem var -- )
-    #! Prepend an element to the proper list stored in a
-    #! variable if it is not already contained in the list.
-    [ unique ] change ;
+: run-test ( -- )
+  "test.db" sqlite-open
+  dup "select * from test" sqlite-prepare
+  dup [ show-people ] sqlite-each 
+  sqlite-finalize
+  sqlite-close ;
 
-SYMBOL: list-buffer
+: run-test2 ( -- )
+  "test.db" sqlite-open
+  dup "select * from test" sqlite-prepare
+  dup [ show-people ] ;
 
-: make-rlist ( quot -- list )
-    #! Call a quotation. The quotation can call , to prepend
-    #! objects to the list that is returned when the quotation
-    #! is done.
-    [ list-buffer off call list-buffer get ] with-scope ;
-    inline
-
-: make-list ( quot -- list )
-    #! Return a list whose entries are in the same order that ,
-    #! was called.
-    make-rlist reverse ; inline
-
-: , ( obj -- )
-    #! Append an object to the currently constructing list.
-    list-buffer cons@ ;
-
-: unique, ( obj -- )
-    #! Append an object to the currently constructing list, only
-    #! if the object does not already occur in the list.
-    list-buffer unique@ ;
-
-: append, ( list -- )
-    [ , ] each ;
+run-test
\ No newline at end of file
diff --git a/doc/alien.txt b/doc/alien.txt
index 01a6c5a030..369b941b3c 100644
--- a/doc/alien.txt
+++ b/doc/alien.txt
@@ -8,14 +8,14 @@ its drawbacks -- namely, its not portable.
 All FFI words are in the "alien" vocabulary.
 
 The basic principle is generating machine stubs from C function
-prototypes. The main entry point is the 'alien-call' word, which is
+prototypes. The main entry point is the 'alien-invoke' word, which is
 defined as simply throwing an error. However, it is given special
 compilation behavior. This means it can only be used in compiled words.
 
 Here is an example from sdl-video.factor:
 
 : SDL_LockSurface ( surface -- )
-    "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ;
+    "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-invoke ;
 
 The parameters are:
 
diff --git a/contrib/cont-responder/tutorial.txt b/doc/cont-responder-tutorial.txt
similarity index 95%
rename from contrib/cont-responder/tutorial.txt
rename to doc/cont-responder-tutorial.txt
index dae16542f7..959daa9b83 100644
--- a/contrib/cont-responder/tutorial.txt
+++ b/doc/cont-responder-tutorial.txt
@@ -14,13 +14,10 @@ things work.
 
 Getting Started
 ===============
-To get started you will first need to load the 'cont-responder'
-code. You will need the following as a minimum:
+To get started you will first need to use the 'cont-responder'
+vocabulary:
 
-  "cont-responder.factor" run-file
-  "cont-utils.factor" run-file
   USE: cont-responder
-  USE: cont-utils
 
 The responders that you will be writing will require an instance of
 the httpd server to be running. It will be run in a background thread
@@ -152,7 +149,7 @@ Dynamic Data
 ============
 
 Adding dynamic data to the page is relatively easy. This example pulls
-a information from the 'room' word which displays memory details about
+information from the 'room' word which displays memory details about
 the running Factor system. It also uses 'room.' which outputs these
 details to standard output and this is wrapped in a 
 tag so it is
 formatted correctly.
@@ -331,10 +328,10 @@ sequence the page shows. Any Factor code can be called and the
 continuation based system will sequentially display each page. The
 back button, browser window cloning, etc will all continue to work.
 
-You'll notice the URL's in the browser have a number at the end of
-them. This is the 'continuation identifier' which is like a session id
-except that it identifies not just the data you have stored but your
-location within the responder as well.
+You'll notice the URL's in the browser have an 'id' query parameter with
+a number as its value. This is the 'continuation identifier' which is
+like a session id except that it identifies not just the data you have
+stored but your location within the responder as well.
 
 Forms and POST data
 ===================
@@ -588,9 +585,9 @@ them and expect them to work. The 'show' call for example will fail as
 it expects some continuations to in the continuation table for that
 responder.
 
-The 'cont-testing.factor' file contains some simple words that
-maintains this state for you in such a way that you can test the words
-from the console:
+The 'cont-testing.factor' file (in the contrib/cont-responder
+directory) contains some simple words that maintains this state for
+you in such a way that you can test the words from the console:
 
   "cont-testing.factor" run-file
 
@@ -603,7 +600,7 @@ calls the code we want to test and call the 'test-cont-function' word:
    [ subroutine-example1 ] test-cont-function
    => 
   HTTP/1.1 302 Document Moved
-  Location: 8209741119458310
+  Location: ?id=8209741119458310
   Content-Length: 0
   Content-Type: text/plain
 
@@ -628,9 +625,9 @@ state on the stack:
   Content-Type: text/html
   Subroutine Example 1
         
Please select:
-                 
  1. Flow1
    2. 
-                     
  2. Flow2
    3. 
-                     
  3. Flow3
    4. 
+                 
    1. Flow1
      2. 
+                     
    2. Flow2
      3. 
+                     
    3. Flow3
      4. 
                  
    
               
    
         
@@ -645,7 +642,7 @@ written previously:
    [ post-example1 ] test-cont-function
     =>
   HTTP/1.1 302 Document Moved
-  Location: 5829759941409535
+  Location: ?id=5829759941409535
   Content-Length: 0
   Content-Type: text/plain
 
@@ -658,7 +655,7 @@ Again we skip past the forward:
 
   Please enter your name
         
-          
    
+          
             
    Please enter your name:
                
                
diff --git a/doc/devel-guide.tex b/doc/devel-guide.tex
index c5ae07901d..5cb2ead5b1 100644
--- a/doc/devel-guide.tex
+++ b/doc/devel-guide.tex
@@ -2526,6 +2526,365 @@ USE: vectors
     10  main-menu ;
 \end{verbatim}
 
+\chapter{Working with classes}
+
+\section{What is object oriented programming?}
+
+Object oriented programming is a commonly-used term, however many people
+define it differently. Most will agree it consists of three key ideas:
+
+\begin{itemize}
+\item Objects are small pieces of state with the required identity and
+equality semantics, along with runtime information
+allowing the object to reflect on itself.
+
+\item Objects are organized in some manner, allowing one to express
+that a given set of objects features common behavior or shape. Factor organizes
+objects into classes and types, however its definition of these terms is
+slightly different from convention.
+
+\item Behavior can be defined on objects, and dispatched in a polymorphic way,
+where invoking a generic operation on an object takes action most
+appropriate to that object.
+\end{itemize}
+
+The separation into three parts is reflected in the design of the Factor
+object system.
+
+The following terminology is used in this guide:
+
+\begin{itemize}
+\item \emph{Class} -- a class is a set of objects given by a predicate
+that distinglishes elements of the class from other objects, along with
+some associated meta-information.
+
+\item \emph{Type} -- a type is a concrete representation of an object
+in runtime memory. There is only a fixed number of built-in types, such as
+integers, strings, and arrays. Each object has a unique type it belongs to,
+whereas it may be a member of an arbitrary number of classes.
+
+\end{itemize}
+
+In many languages, a class refers to a specific object organization,
+typically a specification form for named slots that objects in the class
+shall have. In Factor, the \texttt{tuple} metaclass allows one to create
+such conventional objects. However, we will look at generic words
+and built-in classes first.
+
+\section{Generic words and methods}
+
+To use the generic word system, you must put the following near the
+beginning of your source file:
+
+\begin{verbatim}
+USE: generic
+\end{verbatim}
+
+The motivation for generic words is that sometimes, you want to write a word that has
+differing behavior depending on the class of its argument. For example,
+in a game, a \texttt{draw} word could take different action if given a ship, a
+weapon, a planet, etc. Writing one large \texttt{draw} word that contains type case logic results in
+unnecessary coupling -- adding support for a new type of graphical
+object would require modifying the original definition of \texttt{draw}, for
+example.
+
+A generic word is a word whose behavior depends on the class of the
+object at the top of the stack, however this behavior is defined in a
+decentralized manner.
+
+A new generic word is defined using the following syntax:
+
+\begin{verbatim}
+GENERIC: draw ( actor -- )
+#! Draw the actor.
+\end{verbatim}
+
+A stack effect comment, as shown above, is not required but recommended.
+
+A generic word just defined like that will simply raise an error if
+invoked. Specific behavior is defined using methods.
+
+A method associates behavior with a generic word. Methods are defined by
+writing \texttt{M:}, followed by a class name, followed by the name of a
+previously-defined generic word.
+
+One of the main benefits of generic words is that each method definition
+can potentially occur in a different source file. Generic word
+definitions also hide conditionals.
+
+Here are two methods for the generic \texttt{draw} word:
+
+\begin{verbatim}
+M: ship draw ( actor -- )
+    [
+        surface get screen-xy radius get color get
+        filledCircleColor
+    ] bind ;
+
+M: plasma draw ( actor -- )
+    [
+        surface get screen-xy dup len get + color get
+        vlineColor
+    ] bind ;
+\end{verbatim}
+
+Here, \texttt{ship} and \texttt{class} are user-defined classes.
+
+Every object is a member of the \texttt{object} class. If you provide a method specializing
+on the \texttt{object} class for some generic word, the method will be
+invoked when no other more specific method exists. For example:
+
+\begin{verbatim}
+GENERIC: describe
+M: number describe "The number " write . ;
+M: object describe "I don't know anything about " write . ;
+\end{verbatim}
+
+\section{Classes}
+
+Recall that in Factor, a class is just a predicate that categorizes objects as
+being a member of the class or not. To be useful, it must be consistent
+-- for a given object, it must always return the same truth value.
+
+Classes are not always subsets or supersets of types and new classes can be defined by the user. Classes can be quite arbitrary:
+
+\begin{itemize}
+\item Cons cells where both elements are integers
+
+\item Floating point numbers between -1 and 1
+
+\item Hash tables holding a certain key
+
+\item Any object that occurs as a member of a certain global variable
+holding a list.
+
+\item \... and so on.
+\end{itemize}
+
+The building blocks of classes are the various built-in types, and
+user-defined tupes. Tuples are covered later in this chapter.
+The built-in types each get their own class whose members are precisely
+the objects having that type. The following built-in classes are
+defined:
+
+\begin{itemize}
+\item \texttt{alien}
+\item \texttt{array}
+\item \texttt{bignum}
+\item \texttt{complex}
+\item \texttt{cons}
+\item \texttt{dll}
+\item \texttt{f}
+\item \texttt{fixnum}
+\item \texttt{float}
+\item \texttt{port}
+\item \texttt{ratio}
+\item \texttt{sbuf}
+\item \texttt{string}
+\item \texttt{t}
+\item \texttt{tuple}
+\item \texttt{vector}
+\item \texttt{word}
+\end{itemize}
+
+Each builtin class has a corresponding membership test predicate, named
+after the builtin class suffixed by \texttt{?}. For example, \texttt{cons?}, \texttt{word?}, etc. Automatically-defined predicates is a common theme, and
+in fact \emph{every} class has a corresponding predicate word,
+with the following
+exceptions:
+
+\begin{itemize}
+\item \texttt{object} -- there is no need for a predicate word, since
+every object is an instance of this class.
+\item \texttt{f} -- the only instance of this class is the sigleton
+\texttt{f} signifying falsity, missing value, and empty list, and the predicate testing for this is the built-in library word \texttt{not}.
+\item \texttt{t} -- the only instance of this class is the canonical truth value
+\texttt{t}. You can write \texttt{t =} to test for this object, however usually
+any object distinct from \texttt{f} is taken as a truth value, and \texttt{t} is not tested for directly.
+\end{itemize}
+
+\section{Metaclasses}
+
+So far, we have only seen predefined classes corresponding to built-in
+types. More complicated classes are defined in terms of metaclasses.
+This section will describe how to define new classes belonging to
+predefined metaclasses.
+
+Just like shared object object traits motivates the existence of classes,
+common behavior shared between classes themselves motivates metaclasses.
+For example, classes corresponding to built-in types, such as \texttt{fixnum}
+and \texttt{string}, are instances of
+the \texttt{builtin} metaclass, whereas a user-defined class is not an
+instance of \texttt{builtin}.
+
+\subsection{The \texttt{union} metaclass}
+
+The \texttt{union} metaclass allows new classes to be
+defined as aggregates of existing classes.
+
+For example, the Factor library defines some unions over numeric types:
+
+\begin{verbatim}
+UNION: integer fixnum bignum ;
+UNION: rational integer ratio ;
+UNION: real rational float ;
+UNION: number real complex ;
+\end{verbatim}
+
+Now, the absolute value function can be defined in an efficient manner
+for real numbers, and in a more general fashion for complex numbers:
+
+\begin{verbatim}
+GENERIC: abs ( z -- |z| )
+M: real abs dup 0 < [ neg ] when ;
+M: complex abs >rect mag2 ;
+\end{verbatim}
+
+New unions can be defined as in the numerical classes example:
+you write \texttt{UNION:} followed by the name of the union,
+followed by its members. The list of members is terminated with a
+semi-colon.
+
+A predicate named after the union followed by '?' is
+automatically-defined. For example, the following definition of 'real?'
+was automatically created:
+
+\begin{verbatim}
+: real?
+    dup rational? [
+        drop t 
+    ] [
+        dup float? [
+            drop t 
+        ] [
+            drop f 
+        ] ifte 
+    ] ifte ;
+\end{verbatim}
+
+\subsection{The \texttt{complement} metaclass}
+
+The \texttt{complement} metaclass allows you to define a class whose members
+are exactly those not in another class. For example, the class of all
+truth values is defined in \texttt{library/kernel.factor} by:
+
+\begin{verbatim}
+COMPLEMENT: general-t f
+\end{verbatim}
+
+\subsection{The \texttt{predicate} metaclass}
+
+The predicate metaclass contains classes whose membership test is an
+arbitrary expression. To speed up dispatch, each predicate must be
+defined as a subclass of some other class. That way predicates
+subclassing from disjoint builtin classes do not need to be
+exhaustively tested.
+
+The source file \texttt{library/strings.factor} defines some subclasses of \texttt{integer}
+classifying ASCII characters:
+
+\begin{verbatim}
+PREDICATE: integer blank     " \t\n\r" str-contains? ;
+PREDICATE: integer letter    CHAR: a CHAR: z between? ;
+PREDICATE: integer LETTER    CHAR: A CHAR: Z between? ;
+PREDICATE: integer digit     CHAR: 0 CHAR: 9 between? ;
+PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
+\end{verbatim}
+
+Each predicate defines a corresponding predicate word whose name is
+suffixed with '?'; for example, a 'digit?' word is automatically
+defined:
+
+\begin{verbatim}
+: digit?
+    dup integer? [
+        CHAR: 0 CHAR: 9 between?
+    ] [
+        drop f
+    ] ifte ;
+\end{verbatim}
+
+For obvious reasons, the predicate definition must consume and produce
+exactly one value on the stack.
+
+\section{Tuples}
+
+Tuples are user-defined classes whose objects consist of named slots.
+
+New tuple classes are defined with the following syntax:
+
+\begin{verbatim}
+TUPLE: point x y z ;
+\end{verbatim}
+
+This defines a new class named \texttt{point}, along with the
+following set of words:
+
+\begin{verbatim}
+ point?
+point-x set-point-x
+point-y set-point-y
+point-z set-point-z
+\end{verbatim}
+
+The word \texttt{} takes the slot values from the stack and
+produces a new \texttt{point}:
+
+\begin{alltt}
+\textbf{ok} 1 2 3  .
+\textbf{<< point 1 2 3 >>}
+\end{alltt}
+
+As you can guess from the above, there is a literal syntax for tuples,
+and the \texttt{point?}~word tests if the top of the stack is an object
+belonging to that class:
+
+\begin{alltt}
+\textbf{ok} << point 1 2 3 >> point? .
+\textbf{t}
+\end{alltt}
+
+The general form of the literal syntax is as follows:
+
+\begin{alltt}
+<< \emph{class} \emph{slots} \... >>
+\end{alltt}
+
+The syntax consists of the tuple class name followed by the
+values of all slots. An error is raised if insufficient or extraneous slot values are specified.
+
+As usual, the distinction between literal syntax and explicit calls is the
+time the tuple is created; literals are created at parse time, whereas
+explicit constructor calls creates a new object each time the code
+runs.
+
+Slots are read and written using the various automatically-defined words with names of the
+form \texttt{\emph{class}-\emph{slot}} and \texttt{set-\emph{class}-\emph{slot}}.
+
+\subsection{Constructors}
+
+A tuple constructor is named after the tuple class surrounded in angle
+brackets (\texttt{<} and \texttt{>}). A default constructor is provided
+that reads slot values from the stack, however a custom constructor can
+be defined using the \texttt{C:} parsing word.
+
+\subsection{Delegation}
+
+If a tuple defines a slot named \texttt{delegate}, any generic words called on
+the tuple that are not defined for the tuple's class will be passed on
+to the delegate.
+
+This idiom is used in the I/O code for wrapper streams. For example, the
+\texttt{ansi-stream} class delegates all generic words to its underlying stream,
+except for \texttt{fwrite-attr}, which outputs the necessary terminal escape
+codes. Another example is \texttt{stdio-stream}, which performs all I/O on its
+underlying stream, except it flushes after every new line (which would
+be undesirable for say, a file).
+
+Delegation is used instead of inheritance in Factor, but it is not a
+substitute; in particular, the semantics differ in that a delegated
+method call receives the delegate on the stack, not the original object.
+
 \input{new-guide.ind}
 
 \end{document}
diff --git a/doc/generic.txt b/doc/generic.txt
deleted file mode 100644
index 224deb1cad..0000000000
--- a/doc/generic.txt
+++ /dev/null
@@ -1,272 +0,0 @@
-THE FACTOR GENERIC WORD SYSTEM
-
-Factor's generic word system is a very abstract generalization of
-"object oriented" features found in other programming languges.
-
-To use the generic word system, you must put the following near the
-beginning of your source file:
-
-USE: generic
-
-The key motivation is that sometimes, you want to write a word that has
-differing behavior depending on the class of its argument. For example,
-in a game, a 'draw' word could take different action if given a ship, a
-weapon, a planet, etc.
-
-Duplicating 'type case' logic is undesirable and also results in
-unnecessary coupling -- adding support for a new type of graphical
-object would require modifying the original definition of 'draw', for
-example.
-
-* Types
-
-In Factor, the idea of a 'type' refers to a very concrete concept. The
-type of an object is its representation in runtime object memory. Types
-include fixnums, bignums, cons cells, vectors, strings, and so on. The
-set of available types is fixed; adding a new type requires modifying
-the runtime source written in C.
-
-* Classes
-
-In Factor, a 'class' is just a predicate that categorizes objects as
-being a member of the class or not. To be useful, it must be consistent
--- for a given object, it must always return the same truth value.
-
-Examples of classes might include:
-
-- Cons cells where both elements are integers
-
-- Floating point numbers between -1 and 1
-
-- Hash tables holding a certain key
-
-- Any object that occurs as a member of a certain global variable
-holding a list.
-
-- ... and so on.
-
-As you can see, a class of objects does not need to be a subset or a
-superset of a type of objects.
-
-Classes, unlike types, can be defined by the user.
-
-* Generic words
-
-A generic word is a word whose behavior depends on the class of the
-object at the top of the stack.
-
-Generic words are defined using the following syntax:
-
-GENERIC: draw ( actor -- )
-#! Draw the actor.
-
-A stack effect comment, as above, is not required but recommended.
-
-* Methods
-
-A method associates behavior to a generic word. Methods are defined by
-writing M:, followed by a class name, followed by the name of a
-previously-defined generic word.
-
-One of the main benefits of generic words is that each method definition
-can potentially occur in a different source file. Generic word
-definitions also hide conditionals.
-
-Here are two methods for the generic 'draw' word:
-
-M: ship draw ( actor -- )
-    [
-        surface get screen-xy radius get color get
-        filledCircleColor
-    ] bind ;
-
-M: plasma draw ( actor -- )
-    [
-        surface get screen-xy dup len get + color get
-        vlineColor
-    ] bind ;
-
-Here, 'ship' and 'class' are user-defined classes.
-
-* Metaclasses
-
-To understand what classes already exist, and how to define your own
-classes, the concept of a 'metaclass' must be grasped first. Roughly
-speaking, a metaclass is a class of classes.
-
-New metaclasses can be defined by the user, but its an involved process
-that requires a deeper understanding of the generic word systsem than
-can be given here.
-
-** The object class
-
-Every object is a member of the object class. The object class is also a
-metaclass, and it is the one and only instance of itself.
-
-Confusing? The idea is pretty simple. If you define a method on
-'object', it will be called when no more specific method is available:
-
-GENERIC: describe
-M: number describe "The number " write . ;
-M: object describe "I don't know anything about " write . ;
-
-Since the only instance of the object metaclass is itself, you cannot
-define new classes in the object metaclass.
-
-** The builtin metaclass
-
-The builtin metaclass contains precisely the following classes; each
-class corresponds to a runtime type:
-
-alien
-array
-bignum
-complex
-cons
-dll
-f
-fixnum
-float
-port
-ratio
-sbuf
-string
-t
-vector
-word
-
-Each builtin class has a corresponding membership test predicate, named
-after the builtin class suffixed with '?'. For example, cons?, word?,
-etc.
-
-Adding new classes to the builtin metaclass requires modifications to
-the C code comprising Factor's runtime.
-
-** The union metaclass
-
-The union metaclass contains classes whose members are defined to be the
-aggregate of the members of a list of existing classes.
-
-For example, the Factor library defines some unions over numeric types:
-
-UNION: integer fixnum bignum ;
-UNION: rational integer ratio ;
-UNION: real rational float ;
-UNION: number real complex ;
-
-Now, the absolute value function can be defined in an efficient manner
-for real numbers, and in a more general fashion for complex numbers:
-
-GENERIC: abs ( z -- |z| )
-M: real abs dup 0 < [ neg ] when ;
-M: complex abs >rect mag2 ;
-
-New unions can be defined by you, and the numerical types example above
-gives the syntax: you write UNION: followed by the name of the union,
-followed by its members. The list of members is terminated with a
-semi-colon.
-
-A predicate named after the union followed by '?' is
-automatically-defined. For example, the following definition of 'real?'
-was automatically created:
-
-: real?
-    dup rational? [
-        drop t 
-    ] [
-        dup float? [
-            drop t 
-        ] [
-            drop f 
-        ] ifte 
-    ] ifte ;
-
-** The predicate metaclass
-
-The predicate metaclass contains classes whose membership test is an
-arbitrary expression. To speed up dispatch, each predicate must be
-defined as a subclass of some other class. That way predicates
-subclassing from disjoint builtin classes do not need to be
-simultaenously tested.
-
-The library/strings.factor module defines some subclasses of integer,
-classifying the different types of ASCII characters:
-
-PREDICATE: integer blank     " \t\n\r" str-contains? ;
-PREDICATE: integer letter    CHAR: a CHAR: z between? ;
-PREDICATE: integer LETTER    CHAR: A CHAR: Z between? ;
-PREDICATE: integer digit     CHAR: 0 CHAR: 9 between? ;
-PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
-
-Each predicate defines a corresponding predicate word whose name is
-suffixed with '?'; for example, a 'digit?' word is automatically
-defined:
-
-: digit?
-    dup integer? [
-        CHAR: 0 CHAR: 9 between?
-    ] [
-        drop f
-    ] ifte ;
-
-For obvious reasons, the predicate definition must consume and produce
-exactly one value on the stack.
-
-** The traits metaclass
-
-(The name for this metaclass is wrong and will change eventually. The
-original idea was to allow an object to inherit any number of 'traits',
-thus they would behave like mixins. This never materialized.)
-
-The traits metaclass allows one to associate more fine-grained behavior,
-specifically with hashtables.
-
-New classes can be defined like so:
-
-TRAITS: plasma
-
-In terms of behavior, this is actually identical to the following:
-
-PREDICATE: hashtable plasma \ traits swap hash plasma = ;
-
-However, it is far more efficient (and less verbose).
-
-You can define methods as usual:
-
-GENERIC: collide ( actor1 actor2 -- )
-
-M: plasma collide ( actor1 actor2 -- )
-    #! Remove the other actor.
-    deactivate deactivate ;
-
-How does one actually get an object that plasma? responds with t to? You
-define a constructor word by writing C: followed by the class name:
-
-C: plasma ( actor dy -- plasma )
-    [
-        velocity set
-        actor-xy
-        blue color set
-        10 len set
-        5 radius set
-        active on
-    ] extend ;
-
-The constructor word is named after the class, surrounded in angle
-brackets (< and >). For example, the above actually creates a word named
-.
-
-The constructor's definition begins with the parameters given by the
-user, underneath a blank plasma object.
-
-That is, a dummy constructor just returns a blank hashtable that
-responds t to the corresponding membership predicate:
-
-TRAITS: foo
-C: foo ;
-
- foo? .
-==> t
-
-"hello" foo? .
-==> f
diff --git a/examples/dejong.factor b/examples/dejong.factor
index 2b890b92dd..03c0f58f17 100644
--- a/examples/dejong.factor
+++ b/examples/dejong.factor
@@ -4,7 +4,7 @@
 !
 ! ./f boot.image.le32
 !     -libraries:sdl:name=libSDL.so
-!     -libraries:sdl-gfx:name=libSDL_gfx.
+!     -libraries:sdl-gfx:name=libSDL_gfx.so
 !
 ! (But all on one line)
 !
@@ -36,10 +36,7 @@ SYMBOL: d
 : next-x ( x y -- x ) a get * sin swap b get * cos - ;
 : next-y ( x y -- y ) swap c get * sin swap d get * cos - ;
 
-: white ( -- rgb )
-    HEX: ffffffff ;
-
-: pixel ( #{ x y } color -- )
+: pixel ( #{ x y }# color -- )
     >r >r surface get r> >rect r> pixelColor ;
 
 : iterate-dejong ( x y -- x y )
@@ -51,21 +48,21 @@ SYMBOL: d
 
 : draw-dejong ( x0 y0 iterations -- )
     [
-        iterate-dejong 2dup scale-dejong rect> white pixel
-    ] times 2drop ;
+        iterate-dejong 2dup scale-dejong rect> white rgb pixel
+    ] times 2drop ; compiled
 
 : dejong ( -- )
     ! Fiddle with these four values!
-    1.4 a set
-    -2.3 b set
-    2.4 c set
+    1.0 a set
+    -1.3 b set
+    0.8 c set
     -2.1 d set
 
-    640 480 32 SDL_HWSURFACE [
-        [ 0 0 100000 draw-dejong ] with-surface
+    1024 768 0 SDL_HWSURFACE [
+        [ 0 0 200000 [ draw-dejong ] time ] with-surface
 
          event-loop
         SDL_Quit
-    ] with-screen ; compiled
+    ] with-screen ;
 
-[ dejong ] time
+dejong
diff --git a/examples/factoroids.factor b/examples/factoroids.factor
deleted file mode 100644
index 0e09903a13..0000000000
--- a/examples/factoroids.factor
+++ /dev/null
@@ -1,336 +0,0 @@
-! A simple space shooter.
-!
-! To run this code, bootstrap Factor like so:
-!
-! ./f boot.image.le32
-!     -libraries:sdl:name=libSDL.so
-!     -libraries:sdl-gfx:name=libSDL_gfx.
-!
-! (But all on one line)
-!
-! Then, start Factor as usual (./f factor.image) and enter this
-! at the listener:
-!
-! "examples/factoroids.factor" run-file
-
-IN: factoroids
-
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: generic
-USE: random
-USE: sdl
-USE: sdl-event
-USE: sdl-gfx
-USE: sdl-keysym
-USE: sdl-video
-
-! Game objects
-GENERIC: draw ( actor -- )
-#! Draw the actor.
-
-GENERIC: tick ( actor -- ? )
-#! Return f if the actor should be removed.
-
-GENERIC: collide ( actor1 actor2 -- )
-#! Handle collision of two actors.
-
-! Actor attributes
-SYMBOL: position
-SYMBOL: radius
-SYMBOL: len
-SYMBOL: velocity
-SYMBOL: color
-SYMBOL: active
-
-! The list of actors is divided into layers. Note that an
-! actor's tick method can only add actors to layers other than
-! the actor's layer. The player layer only has one actor.
-SYMBOL: player
-SYMBOL: enemies
-SYMBOL: player-shots
-SYMBOL: enemy-shots
-
-: player-actor ( -- player )
-    player get dup [ car ] when ;
-
-: x-in-screen? ( x -- ? ) 0 width get between? ;
-: y-in-screen? ( y -- ? ) 0 height get between? ;
-
-: in-screen? ( actor -- ? )
-    #! Is the actor in the screen?
-    [
-        position get >rect y-in-screen? swap x-in-screen? and
-    ] bind ;
-
-: move ( -- )
-    #! Add velocity vector to current actor's position vector.
-    velocity get position [ + ] change ;
-
-: active? ( actor -- ? )
-    #! Push f if the actor should be removed.
-    [ active get ] bind ;
-
-: deactivate ( actor -- )
-    #! Cause the actor to be removed in the next tick cycle.
-    [ active off ] bind ;
-
-: screen-xy ( -- x y )
-    position get >rect swap >fixnum swap >fixnum ;
-
-: actor-xy ( actor -- )
-    #! Copy actor's x/y co-ordinates to this namespace.
-    [ position get ] bind position set ;
-
-! Collision detection
-: distance ( actor1 actor2 -- x )
-    #! Distance between two actor's positions.
-    >r [ position get ] bind r> [ position get ] bind - abs ;
-
-: min-distance ( actor1 actor2 -- )
-    #! Minimum distance before there is a collision.
-    >r [ radius get ] bind r> [ radius get ] bind + ;
-
-: collision? ( actor1 actor2 -- ? )
-    2dup distance >r min-distance r> > ;
-
-: check-collision ( actor1 actor2 -- )
-    2dup collision? [ collide ] [ 2drop ] ifte ;
-
-: layer-actor-collision ( actor layer -- )
-    #! The layer is a list of actors.
-    [ dupd check-collision ] each drop ;
-
-: layer-collision ( layer layer -- )
-    swap [ over layer-actor-collision ] each drop ;
-
-: collisions ( -- )
-    #! Only collisions we allow are player colliding with an
-    #! enemy shot, and player shot colliding with enemy.
-    player get enemy-shots get layer-collision
-    enemies get player-shots get layer-collision ;
-
-! The player's ship
-
-TRAITS: ship
-M: ship draw ( actor -- )
-    [
-        surface get screen-xy radius get color get
-        filledCircleColor
-    ] bind ;
-
-M: ship tick ( actor -- ? ) dup [ move ] bind active? ;
-
-C: ship ( -- ship )
-    [
-        width get 2 /i  height get 50 - rect> position set
-        white color set
-        10 radius set
-        0 velocity set
-        active on
-    ] extend ;
-
-! Projectiles
-TRAITS: plasma
-M: plasma draw ( actor -- )
-    [
-        surface get screen-xy dup len get + color get
-        vlineColor
-    ] bind ;
-
-M: plasma tick ( actor -- ? )
-    dup [ move ] bind dup in-screen? swap active? and ;
-
-M: plasma collide ( actor1 actor2 -- )
-    #! Remove the other actor.
-    deactivate deactivate ;
-
-C: plasma ( actor dy -- plasma )
-    [
-        velocity set
-        actor-xy
-        blue color set
-        10 len set
-        5 radius set
-        active on
-    ] extend ;
-
-: player-fire ( -- )
-    #! Do nothing if player is dead.
-    player-actor [
-        #{ 0 -6 }  player-shots cons@
-    ] when* ;
-
-: enemy-fire ( actor -- )
-    #{ 0 5 }  enemy-shots cons@ ;
-
-! Background of stars
-TRAITS: particle
-
-M: particle draw ( actor -- )
-    [ surface get screen-xy color get pixelColor ] bind ;
-
-: wrap ( -- )
-    #! If current actor has gone beyond screen bounds, move it
-    #! back.
-    position get >rect
-    swap >fixnum width get rem
-    swap >fixnum height get rem
-    rect> position set ;
-
-M: particle tick ( actor -- )
-    [ move wrap t ] bind ;
-
-C: particle ;
-
-SYMBOL: stars
-: star-count 100 ;
-
-: random-x 0 width get random-int ;
-: random-y 0 height get random-int ;
-: random-position random-x random-y rect> ;
-: random-byte 0 255 random-int ;
-: random-color random-byte random-byte random-byte 255 rgba ;
-: random-velocity 0 10 20 random-int 10 /f rect> ;
-
-: random-star ( -- star )
-     [
-        random-position position set
-        random-color color set
-        random-velocity velocity set
-        active on
-    ] extend ;
-
-: init-stars ( -- )
-    #! Generate random background of scrolling stars.
-    [ ] star-count [ random-star swons ] times stars set ;
-
-: draw-stars ( -- )
-    stars get [ draw ] each ;
-
-: tick-stars ( -- )
-    stars get [ tick drop ] each ;
-
-! Enemies
-: enemy-chance 50 ;
-
-TRAITS: enemy
-M: enemy draw ( actor -- )
-    [
-        surface get screen-xy radius get color get
-        filledCircleColor
-    ] bind ;
-
-: attack-chance 30 ;
-
-: chance ( n -- boolean )
-    #! Returns true with a 1/n probability, false with a (n-1)/n
-    #! probability.
-    1 swap random-int 1 = ;
-
-: attack ( actor -- )
-    #! Fire a shot some of the time.
-    attack-chance chance [ enemy-fire ] [ drop ] ifte ;
-
-SYMBOL: wiggle-x
-
-: wiggle ( -- )
-    #! Wiggle from left to right.
-    -3 3 random-int wiggle-x [ + ] change
-    wiggle-x get sgn 1 rect> velocity set ;
-
-M: enemy tick ( actor -- )
-    dup attack
-    dup [ wiggle move position get imaginary ] bind
-    y-in-screen? swap active? and ;
-
-C: enemy ;
-
-: spawn-enemy ( -- )
-     [
-        random-x 10 rect> position set
-        red color set
-        0 wiggle-x set
-        0 velocity set
-        10 radius set
-        active on
-    ] extend ;
-
-: spawn-enemies ( -- )
-    enemy-chance chance [ spawn-enemy enemies cons@ ] when ;
-
-! Event handling
-SYMBOL: event
-
-: mouse-motion-event ( event -- )
-    motion-event-x player-actor dup [
-        [ position get imaginary rect> position set ] bind
-    ] [
-        2drop
-    ] ifte ;
-
-: mouse-down-event ( event -- )
-    drop player-fire ;
-
-: handle-event ( event -- ? )
-    #! Return if we should continue or stop.
-    [
-        [ event-type SDL_MOUSEBUTTONDOWN = ] [ mouse-down-event t ]
-        [ event-type SDL_MOUSEMOTION = ] [ mouse-motion-event t ]
-        [ event-type SDL_QUIT = ] [ drop f ]
-        [ drop t ] [ drop t ]
-    ] cond ;
-
-: check-event ( -- ? )
-    #! Check if there is a pending event.
-    #! Return if we should continue or stop.
-    event get dup SDL_PollEvent [
-        handle-event [ check-event ] [ f ] ifte
-    ] [
-        drop t
-    ] ifte ;
-
-! Game loop
-: init-game ( -- )
-    #! Init game objects.
-    init-stars
-     unit player set
-     event set ;
-
-: each-layer ( quot -- )
-    #! Apply quotation to each layer.
-    [ enemies enemy-shots player player-shots ] swap each ;
-
-: draw-actors ( -- )
-    [ get [ draw ] each ] each-layer ;
-
-: tick-actors ( -- )
-    #! Advance game state by one frame. Actors whose tick word
-    #! returns f are removed from the layer.
-    [ dup get [ tick ] subset put ] each-layer ;
-
-: render ( -- )
-    #! Draw the scene.
-    [ black clear-surface draw-stars draw-actors ] with-surface ;
-
-: advance ( -- )
-    #! Advance game state by one frame.
-    tick-actors tick-stars spawn-enemies ;
-
-: game-loop ( -- )
-    #! Render, advance game state, repeat.
-    render advance collisions check-event [ game-loop ] when ;
-
-: factoroids ( -- )
-    #! Main word.
-    640 480 32 SDL_HWSURFACE [
-        "Factoroids" "Factoroids" SDL_WM_SetCaption
-        init-game game-loop
-    ] with-screen ;
-
-factoroids
diff --git a/examples/format.factor b/examples/format.factor
new file mode 100644
index 0000000000..fa17db9979
--- /dev/null
+++ b/examples/format.factor
@@ -0,0 +1,39 @@
+IN: format
+USE: kernel
+USE: math
+USE: namespaces
+USE: strings
+USE: test
+
+: decimal-split ( string -- string string )
+    #! Split a string before and after the decimal point.
+    dup "." index-of dup -1 = [ drop f ] [ str// ] ifte ;
+
+: decimal-tail ( count str -- string )
+    #! Given a decimal, trims all but a count of decimal places.
+    [ str-length min ] keep str-head ;
+
+: decimal-cat ( before after -- string )
+    #! If after is of zero length, return before, otherwise
+    #! return "before.after".
+    dup str-length 0 = [
+        drop
+    ] [
+        "." swap cat3
+    ] ifte ;
+
+: decimal-places ( num count -- string )
+    #! Trims the number to a count of decimal places.
+    >r decimal-split dup [
+        r> swap decimal-tail decimal-cat
+    ] [
+        r> 2drop
+    ] ifte ;
+
+[ "123" ] [ 4 "123" decimal-tail ] unit-test
+[ "12" ] [ 2 "123" decimal-tail ] unit-test
+[ "123" ] [ "123" 2 decimal-places ] unit-test
+[ "123.12" ] [ "123.12" 2 decimal-places ] unit-test
+[ "123.123" ] [ "123.123" 5 decimal-places ] unit-test
+[ "123" ] [ "123.123" 0 decimal-places ] unit-test
+
diff --git a/examples/gadget-test.factor b/examples/gadget-test.factor
new file mode 100644
index 0000000000..7a46689dc9
--- /dev/null
+++ b/examples/gadget-test.factor
@@ -0,0 +1,89 @@
+! TrueType font rendering demo.
+!
+! To run this code, bootstrap Factor like so:
+!
+! ./f boot.image.le32
+!     -libraries:sdl:name=libSDL.so
+!     -libraries:sdl-gfx:name=libSDL_gfx.so
+!     -libraries:sdl-ttf:name=libSDL_ttf.so
+!
+! (But all on one line)
+!
+! Then, start Factor as usual (./f factor.image) and enter this
+! at the listener:
+!
+! "examples/text-demo.factor" run-file
+
+IN: text-demo
+USE: streams
+USE: sdl
+USE: sdl-event
+USE: sdl-gfx
+USE: sdl-video
+USE: sdl-ttf
+USE: namespaces
+USE: math
+USE: kernel
+USE: test
+USE: compiler
+USE: strings
+USE: alien
+USE: prettyprint
+USE: lists
+USE: gadgets
+USE: generic
+USE: stdio
+USE: prettyprint
+USE: words
+
+: grab ( gadget hand -- )
+    [ swap screen-pos swap screen-pos - >rect ] 2keep
+    >r [ move-gadget ] keep r> add-gadget ;
+
+: release ( gadget world -- )
+    >r dup screen-pos >r
+    dup unparent
+    r> >rect pick move-gadget
+    r> add-gadget ;
+
+: moving-actions
+    {{
+            [[ [ button-down 1 ] [ my-hand grab ] ]]
+        [[ [ button-up 1 ] [ world get release ] ]]
+    }} swap set-gadget-gestures ;
+
+: filled? "filled" get checkbox-selected? ;
+
+: 
+    filled? [  ] [  ] ifte  dup moving-actions ;
+
+: 
+    filled? [  ] [  ] ifte  dup moving-actions ;
+
+: 
+      dup moving-actions ;
+
+: make-shapes ( -- )
+    f world get set-gadget-children
+    
+    default-gap  "pile" set
+    default-gap  "shelf" set
+    "Close" [ "dialog" get world get remove-gadget ]
"Source" write
[ [ parse ] [ [ "No such word" write ] [ car see ] ifte ] catch ] with-simple-html-output
+ [ ] each +
call
; + +: horizontal-layout ( list -- ) + #! Given a list of HTML components, arrange them horizontally. + + [ ] each +
call
; + +: button ( label -- ) + #! Output an HTML submit button with the given label. + ; + +: with-simple-html-output ( quot -- ) + #! Run the quotation inside an HTML stream wrapped + #! around stdio. + 
 
+    stdio get  [
+      call
+    ] with-stream
+
; diff --git a/library/httpd/default-responders.factor b/library/httpd/default-responders.factor index 39cc7c89d4..35b8ee86b1 100644 --- a/library/httpd/default-responders.factor +++ b/library/httpd/default-responders.factor @@ -36,6 +36,8 @@ USE: inspect-responder USE: quit-responder USE: file-responder USE: resource-responder +USE: cont-responder +USE: browser-responder #! Remove all existing responders, and create a blank #! responder table. @@ -68,4 +70,6 @@ global [ "httpd-responders" set ] bind [ resource-responder ] "get" set ] extend add-responder +"browser" [ f browser-responder ] install-cont-responder + "file" set-default-responder diff --git a/library/httpd/file-responder.factor b/library/httpd/file-responder.factor index ea4d8c45b3..61231fd17f 100644 --- a/library/httpd/file-responder.factor +++ b/library/httpd/file-responder.factor @@ -54,7 +54,7 @@ USE: unparser over file-length file-response "method" get "head" = [ drop ] [ - stdio get fcopy + stdio get fcopy ] ifte ; : serve-file ( filename -- ) diff --git a/library/httpd/html.factor b/library/httpd/html.factor index 00f3f3fdad..9072c4d359 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -1,49 +1,16 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: html -USE: lists -USE: kernel -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: unparser -USE: url-encoding -USE: presentation -USE: generic +USING: lists kernel namespaces stdio streams strings unparser +url-encoding presentation generic ; : html-entities ( -- alist ) [ - [ CHAR: < | "<" ] - [ CHAR: > | ">" ] - [ CHAR: & | "&" ] - [ CHAR: ' | "'" ] - [ CHAR: " | """ ] + [[ CHAR: < "<" ]] + [[ CHAR: > ">" ]] + [[ CHAR: & "&" ]] + [[ CHAR: ' "'" ]] + [[ CHAR: " """ ]] ] ; : char>entity ( ch -- str ) @@ -110,6 +77,19 @@ USE: generic call ] ifte* ; +: browser-link-href ( style -- href ) + dup "browser-link-word" swap assoc url-encode + swap "browser-link-vocab" swap assoc url-encode + "responder" get url-encode + [ "/responder/" , , "/?vocab=" , , "&word=" , , ] make-string ; + +: browser-link-tag ( style quot -- style ) + over "browser-link-word" swap assoc [ + call + ] [ + call + ] ifte ; + : icon-tag ( string style quot -- ) over "icon" swap assoc dup [ @@ -120,15 +100,17 @@ USE: generic drop call ] ifte ; -TRAITS: html-stream +TUPLE: html-stream delegate ; -M: html-stream fwrite-attr ( str style stream -- ) - [ +M: html-stream stream-write-attr ( str style stream -- ) + wrapper-stream-scope [ [ [ - [ drop chars>entities write ] span-tag - ] file-link-tag - ] icon-tag + [ + [ drop chars>entities write ] span-tag + ] file-link-tag + ] icon-tag + ] browser-link-tag ] bind ; C: html-stream ( stream -- stream ) @@ -145,7 +127,7 @@ C: html-stream ( stream -- stream ) #! underline #! size #! link - an object path - [ dup delegate set stdio set ] extend ; + [ >r r> set-html-stream-delegate ] keep ; : with-html-stream ( quot -- ) [ stdio [ ] change call ] with-scope ; diff --git a/library/httpd/http-common.factor b/library/httpd/http-common.factor index afb4b2faf1..3e1cd1d588 100644 --- a/library/httpd/http-common.factor +++ b/library/httpd/http-common.factor @@ -50,7 +50,7 @@ USE: url-encoding : error-head ( error -- ) dup log-error - [ [ "Content-Type" | "text/html" ] ] over response ; + [ [[ "Content-Type" "text/html" ]] ] over response ; : httpd-error ( error -- ) #! This must be run from handle-request @@ -65,11 +65,11 @@ USE: url-encoding ] with-scope ; : serving-html ( -- ) - [ [ "Content-Type" | "text/html" ] ] + [ [[ "Content-Type" "text/html" ]] ] "200 Document follows" response terpri ; : serving-text ( -- ) - [ [ "Content-Type" | "text/plain" ] ] + [ [[ "Content-Type" "text/plain" ]] ] "200 Document follows" response terpri ; : redirect ( to -- ) @@ -86,7 +86,7 @@ USE: url-encoding ": " split1 dup [ cons swons ] [ 2drop ] ifte ; : (read-header) ( alist -- alist ) - read dup + read-line dup f-or-"" [ drop ] [ header-line (read-header) ] ifte ; : read-header ( -- alist ) @@ -105,7 +105,7 @@ USE: url-encoding ] when ; : read-post-request ( header -- alist ) - content-length dup [ read# query>alist ] when ; + content-length dup [ read query>alist ] when ; : log-user-agent ( alist -- ) "User-Agent" swap assoc* [ diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index b0822ac90d..e1d2f70918 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -1,64 +1,37 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: httpd -USE: errors -USE: httpd-responder -USE: kernel -USE: lists -USE: logging -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: threads -USE: url-encoding +USING: errors httpd-responder kernel lists logging namespaces +stdio streams strings threads url-encoding ; : httpd-log-stream ( -- stream ) #! Set httpd-log-file to save httpd log to a file. "httpd-log-file" get dup [ - + ] [ drop stdio get ] ifte ; -: url>path ( uri -- path ) +: (url>path) ( uri -- path ) url-decode "http://" ?str-head [ "/" split1 dup "" ? nip ] when ; +: url>path ( uri -- path ) + "?" split1 dup [ + >r (url>path) "?" r> cat3 + ] [ + drop (url>path) + ] ifte ; + : secure-path ( path -- path ) ".." over str-contains? [ drop f ] when ; : request-method ( cmd -- method ) [ - [ "GET" | "get" ] - [ "POST" | "post" ] - [ "HEAD" | "head" ] + [[ "GET" "get" ]] + [[ "POST" "post" ]] + [[ "HEAD" "head" ]] ] assoc [ "bad" ] unless* ; : (handle-request) ( arg cmd -- url method ) @@ -83,8 +56,7 @@ USE: url-encoding : httpd-client ( socket -- ) [ [ - stdio get "client" set log-client - read [ parse-request ] when* + stdio get log-client read-line [ parse-request ] when* ] with-stream ] try ; @@ -98,7 +70,7 @@ USE: url-encoding "http-server" set [ httpd-loop ] [ - "http-server" get fclose rethrow + "http-server" get stream-close rethrow ] catch ; : httpd ( port -- ) diff --git a/library/httpd/quit-responder.factor b/library/httpd/quit-responder.factor index 5d99f77b39..9644ebae78 100644 --- a/library/httpd/quit-responder.factor +++ b/library/httpd/quit-responder.factor @@ -42,5 +42,5 @@ USE: streams "quit-prohibited" get [ quit-prohibited ] [ - "http-server" get fclose + "http-server" get stream-close ] ifte ; diff --git a/library/httpd/responder.factor b/library/httpd/responder.factor index b374dbabba..c5ca5710c3 100644 --- a/library/httpd/responder.factor +++ b/library/httpd/responder.factor @@ -46,7 +46,7 @@ USE: strings ! - raw-query -- raw query string ! - query -- an alist of query parameters, eg ! foo.bar?a=b&c=d becomes -! [ [ "a" | "b" ] [ "c" | "d" ] ] +! [ [[ "a" "b" ]] [[ "c" "d" ]] ] ! - header -- an alist of headers from the user's client ! - response -- an alist of the POST request response diff --git a/library/httpd/url-encoding.factor b/library/httpd/url-encoding.factor index 0993a14cfa..bada6ff4fa 100644 --- a/library/httpd/url-encoding.factor +++ b/library/httpd/url-encoding.factor @@ -30,6 +30,7 @@ USE: errors USE: kernel USE: lists USE: math +USE: namespaces USE: parser USE: strings USE: unparser diff --git a/library/in-thread.factor b/library/in-thread.factor index 37ff962057..eef6acdbb0 100644 --- a/library/in-thread.factor +++ b/library/in-thread.factor @@ -1,35 +1,6 @@ -! :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: threads -USE: errors -USE: io-internals -USE: kernel -USE: lists +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: threads USING: errors io-internals kernel lists ; : in-thread ( quot -- ) #! Execute a quotation in a co-operative thread. The diff --git a/library/inference/branches.factor b/library/inference/branches.factor index e30e0310cf..e2bbf87991 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -1,43 +1,8 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: hashtables -USE: prettyprint +USING: errors generic interpreter kernel lists math namespaces +strings vectors words hashtables prettyprint ; : longest-vector ( list -- length ) [ vector-length ] map [ > ] top ; @@ -47,7 +12,7 @@ USE: prettyprint : add-inputs ( count stack -- stack ) #! Add this many inputs to the given stack. - dup >r vector-length - computed-value-vector dup r> + [ vector-length - computed-value-vector ] keep vector-append ; : unify-lengths ( list -- list ) @@ -73,15 +38,15 @@ USE: prettyprint : unify-stacks ( list -- stack ) #! Replace differing literals in stacks with unknown #! results. - unify-lengths vector-transpose [ unify-results ] vector-map ; + unify-lengths vector-transpose [ unify-results ] vector-map ; : balanced? ( list -- ? ) - #! Check if a list of [ instack | outstack ] pairs is + #! Check if a list of [[ instack outstack ]] pairs is #! balanced. [ uncons vector-length swap vector-length - ] map all=? ; : unify-effect ( list -- in out ) - #! Unify a list of [ instack | outstack ] pairs. + #! Unify a list of [[ instack outstack ]] pairs. dup balanced? [ unzip unify-stacks >r unify-stacks r> ] [ @@ -89,7 +54,7 @@ USE: prettyprint ] ifte ; : datastack-effect ( list -- ) - [ [ d-in get meta-d get ] bind cons ] map + [ [ effect ] bind ] map unify-effect meta-d set d-in set ; @@ -99,23 +64,24 @@ USE: prettyprint meta-r set drop ; : filter-terminators ( list -- list ) - [ [ d-in get meta-d get and ] bind ] subset [ - "No branch has a stack effect" throw - ] unless* ; + #! Remove branches that unconditionally throw errors. + [ [ active? ] bind ] subset ; : unify-effects ( list -- ) - filter-terminators dup datastack-effect callstack-effect ; + filter-terminators [ + dup datastack-effect callstack-effect + ] [ + terminate + ] ifte* ; SYMBOL: cloned -: deep-clone ( vector -- vector ) - #! Clone a vector if it hasn't already been cloned in this +: deep-clone ( obj -- obj ) + #! Clone an object if it hasn't already been cloned in this #! with-deep-clone scope. - dup cloned get assoc dup [ - nip - ] [ - drop vector-clone [ dup cloned [ acons ] change ] keep - ] ifte ; + dup cloned get assoc [ + clone [ dup cloned [ acons ] change ] keep + ] ?unless ; : deep-clone-vector ( vector -- vector ) #! Clone a vector of vectors. @@ -130,45 +96,39 @@ SYMBOL: cloned d-in [ deep-clone-vector ] change dataflow-graph off ; -: terminator? ( obj -- ? ) - dup word? [ "terminator" word-property ] [ drop f ] ifte ; - -: handle-terminator ( quot -- ) - [ terminator? ] some? [ - meta-d off meta-r off d-in off - ] when ; - -: propagate-type ( [ value | class ] -- ) +: propagate-type ( [[ value class ]] -- ) #! Type propagation is chained. [ unswons 2dup set-value-class - [ type-propagations get ] bind assoc propagate-type + value-type-prop assoc propagate-type ] when* ; : infer-branch ( value -- namespace ) + #! Return a namespace with inferencer variables: + #! meta-d, meta-r, d-in. They are set to f if + #! terminate was called. [ uncons propagate-type dup value-recursion recursive-state set copy-inference literal-value dup infer-quot - #values values-node - handle-terminator + active? [ + #values values-node + handle-terminator + ] [ + drop + ] ifte ] extend ; : (infer-branches) ( branchlist -- list ) - #! The branchlist is a list of pairs: - #! [ value | typeprop ] + #! The branchlist is a list of pairs: [[ value typeprop ]] #! value is either a literal or computed instance; typeprop - #! is a pair [ value | class ] indicating a type propagation + #! is a pair [[ value class ]] indicating a type propagation #! for the given branch. [ [ - inferring-base-case get [ - [ - infer-branch , - ] [ - [ drop ] when - ] catch + branches-can-fail? [ + [ infer-branch , ] [ [ drop ] when ] catch ] [ infer-branch , ] ifte @@ -184,9 +144,9 @@ SYMBOL: cloned #! the branches has an undecidable stack effect, we set the #! base case to this stack effect and try again. The inputs #! parameter is a vector. - (infer-branches) dup unify-effects unify-dataflow ; + (infer-branches) dup unify-effects unify-dataflow ; -: (with-block) ( label quot -- ) +: (with-block) ( label quot -- node ) #! Call a quotation in a new namespace, and transfer #! inference state from the outer scope. swap >r [ @@ -194,27 +154,40 @@ SYMBOL: cloned call d-in get meta-d get meta-r get get-dataflow ] with-scope - r> swap #label dataflow, [ node-label set ] bind - meta-r set meta-d set d-in set ; + r> swap #label dataflow, [ node-label set ] extend >r + meta-r set meta-d set d-in set r> ; -: static-branch? ( value -- ) - literal? inferring-base-case get not and ; +: boolean-value? ( value -- ? ) + #! Return if the value's boolean valuation is known. + value-class + dup \ f = swap + builtin-supertypes + \ f builtin-supertypes intersection not + or ; + +: boolean-value ( value -- ? ) + #! Only valid if boolean? returns true. + value-class \ f = not ; + +: static-branch? ( value -- ? ) + drop f ; +! boolean-value? branches-can-fail? not and ; : static-ifte ( true false -- ) #! If the branch taken is statically known, just infer #! along that branch. - dataflow-drop, pop-d literal-value [ drop ] [ nip ] ifte + dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte gensym [ dup value-recursion recursive-state set literal-value infer-quot - ] (with-block) ; + ] (with-block) drop ; : dynamic-ifte ( true false -- ) #! If branch taken is computed, infer along both paths and #! unify. - 2list >r 1 meta-d get vector-tail* #ifte r> + 2list >r 1 meta-d get vector-tail* \ ifte r> pop-d [ - dup \ object cons , + dup \ general-t cons , \ f cons , ] make-list zip ( condition ) infer-branches ; @@ -224,11 +197,11 @@ SYMBOL: cloned [ object general-list general-list ] ensure-d dataflow-drop, pop-d dataflow-drop, pop-d swap -! peek-d static-branch? [ -! static-ifte -! ] [ + peek-d static-branch? [ + static-ifte + ] [ dynamic-ifte - ( ] ifte ) ; + ] ifte ; \ ifte [ infer-ifte ] "infer" set-word-property @@ -236,15 +209,14 @@ SYMBOL: cloned dup value-recursion swap literal-value vector>list [ over ] map nip ; +USE: kernel-internals : infer-dispatch ( -- ) #! Infer effects for all branches, unify. [ object vector ] ensure-d dataflow-drop, pop-d vtable>list - >r 1 meta-d get vector-tail* #dispatch r> - pop-d ( n ) num-types [ dupd cons ] project nip zip - infer-branches ; + >r 1 meta-d get vector-tail* \ dispatch r> + pop-d drop [ unit ] map infer-branches ; -USE: kernel-internals \ dispatch [ infer-dispatch ] "infer" set-word-property \ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-property diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index ce083c0485..a4282c4399 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -49,9 +49,6 @@ SYMBOL: #call ( non-tail call ) SYMBOL: #call-label SYMBOL: #push ( literal ) -SYMBOL: #ifte -SYMBOL: #dispatch - ! This is purely a marker for values we retain after a ! conditional. It does not generate code, but merely alerts the ! dataflow optimizer to the fact these values must be retained. @@ -59,18 +56,6 @@ SYMBOL: #values SYMBOL: #return -SYMBOL: #drop -SYMBOL: #dup -SYMBOL: #swap -SYMBOL: #over -SYMBOL: #pick - -SYMBOL: #>r -SYMBOL: #r> - -SYMBOL: #slot -SYMBOL: #set-slot - SYMBOL: node-consume-d SYMBOL: node-produce-d SYMBOL: node-consume-r @@ -118,7 +103,7 @@ SYMBOL: node-param : dataflow-drop, ( -- ) #! Remove the top stack element and add a dataflow node #! noting this. - f #drop dataflow, [ 1 0 node-inputs ] bind ; + f \ drop dataflow, [ 1 0 node-inputs ] bind ; : apply-dataflow ( dataflow name default -- ) #! For the dataflow node, look up named word property, diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 4d66760ebe..bf8d7bd905 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -39,10 +39,14 @@ USE: hashtables USE: generic USE: prettyprint -! If this symbol is on, partial evalution of conditionals is -! disabled. +: max-recursion 0 ; + +! This variable takes a value from 0 up to max-recursion. SYMBOL: inferring-base-case +: branches-can-fail? ( -- ? ) + inferring-base-case get max-recursion > ; + ! Word properties that affect inference: ! - infer-effect -- must be set. controls number of inputs ! expected, and number of outputs produced. @@ -56,57 +60,44 @@ SYMBOL: d-in ! Recursive state. An alist, mapping words to labels. SYMBOL: recursive-state -GENERIC: literal-value ( value -- obj ) GENERIC: value= ( literal value -- ? ) -GENERIC: value-class ( value -- class ) GENERIC: value-class-and ( class value -- ) -GENERIC: set-value-class ( class value -- ) -! A value has the following slots in addition to those relating -! to generics above: +TUPLE: value class type-prop recursion ; -! An association list mapping values to [ value | class ] pairs -SYMBOL: type-propagations +C: value ( recursion -- value ) + [ set-value-recursion ] keep ; + +TUPLE: computed delegate ; -TRAITS: computed C: computed ( class -- value ) - [ - \ value-class set - gensym \ literal-value set - type-propagations off - ] extend ; -M: computed literal-value ( value -- obj ) - "Cannot use a computed value literally." throw ; + swap recursive-state get [ set-value-class ] keep + over set-computed-delegate ; + M: computed value= ( literal value -- ? ) 2drop f ; -M: computed value-class ( value -- class ) - [ \ value-class get ] bind ; -M: computed value-class-and ( class value -- ) - [ \ value-class [ class-and ] change ] bind ; -M: computed set-value-class ( class value -- ) - [ \ value-class set ] bind ; -TRAITS: literal +M: computed value-class-and ( class value -- ) + [ value-class class-and ] keep set-value-class ; + +TUPLE: literal value delegate ; + C: literal ( obj rstate -- value ) [ - recursive-state set - \ literal-value set - type-propagations off - ] extend ; -M: literal literal-value ( value -- obj ) - [ \ literal-value get ] bind ; + >r [ >r dup class r> set-value-class ] keep + r> set-literal-delegate + ] keep + [ set-literal-value ] keep ; + M: literal value= ( literal value -- ? ) literal-value = ; -M: literal value-class ( value -- class ) - literal-value class ; + M: literal value-class-and ( class value -- ) value-class class-and drop ; + M: literal set-value-class ( class value -- ) 2drop ; -: value-recursion ( value -- rstate ) - [ recursive-state get ] bind ; - : (ensure-types) ( typelist n stack -- ) pick [ 3dup >r >r car r> r> vector-nth value-class-and @@ -130,7 +121,7 @@ M: literal set-value-class ( class value -- ) ] ifte ; : vector-prepend ( values stack -- stack ) - >r list>vector dup r> vector-append ; + >r list>vector r> vector-append ; : ensure-d ( typelist -- ) dup meta-d get ensure-types @@ -138,17 +129,26 @@ M: literal set-value-class ( class value -- ) meta-d [ vector-prepend ] change d-in [ vector-prepend ] change ; -: effect ( -- [ in-types out-types ] ) +: (present-effect) ( vector -- list ) + [ value-class ] vector-map vector>list ; + +: present-effect ( [[ d-in meta-d ]] -- [ in-types out-types ] ) #! After inference is finished, collect information. - d-in get [ value-class ] vector-map vector>list - meta-d get [ value-class ] vector-map vector>list 2list ; + uncons >r (present-effect) r> (present-effect) 2list ; + +: simple-effect ( [[ d-in meta-d ]] -- [[ in# out# ]] ) + #! After inference is finished, collect information. + uncons vector-length >r vector-length r> cons ; + +: effect ( -- [[ d-in meta-d ]] ) + d-in get meta-d get cons ; : init-inference ( recursive-state -- ) init-interpreter 0 d-in set recursive-state set dataflow-graph off - inferring-base-case off ; + 0 inferring-base-case set ; DEFER: apply-word @@ -162,10 +162,31 @@ DEFER: apply-word #! Apply the object's stack effect to the inferencer state. dup word? [ apply-word ] [ apply-literal ] ifte ; +: active? ( -- ? ) + #! Is this branch not terminated? + d-in get meta-d get and ; + +: terminate ( -- ) + #! Ignore this branch's stack effect. + meta-d off meta-r off d-in off ; + +: terminator? ( obj -- ? ) + #! Does it throw an error? + dup word? [ "terminator" word-property ] [ drop f ] ifte ; + +: handle-terminator ( quot -- ) + #! If the quotation throws an error, do not count its stack + #! effect. + [ terminator? ] some? [ terminate ] when ; + : infer-quot ( quot -- ) #! Recursive calls to this word are made for nested #! quotations. - [ apply-object ] each ; + active? [ + [ unswons apply-object infer-quot ] when* + ] [ + drop + ] ifte ; : check-return ( -- ) #! Raise an error if word leaves values on return stack. @@ -184,13 +205,9 @@ DEFER: apply-word infer-quot #return values-node check-return ; -: infer ( quot -- [ in | out ] ) +: infer ( quot -- [[ in out ]] ) #! Stack effect of a quotation. - [ (infer) effect ] with-scope ; - -: try-infer ( quot -- effect/f ) - #! Push f if inference fails. - [ infer ] [ [ drop f ] when ] catch ; + [ (infer) effect present-effect ] with-scope ; : dataflow ( quot -- dataflow ) #! Data flow of a quotation. diff --git a/library/inference/stack.factor b/library/inference/stack.factor index 75d5e9386c..80fac97c55 100644 --- a/library/inference/stack.factor +++ b/library/inference/stack.factor @@ -33,29 +33,25 @@ USE: namespaces USE: words \ >r [ - f #>r dataflow, [ 1 0 node-inputs ] extend + f \ >r dataflow, [ 1 0 node-inputs ] extend pop-d push-r [ 0 1 node-outputs ] bind ] "infer" set-word-property \ r> [ - f #r> dataflow, [ 0 1 node-inputs ] extend + f \ r> dataflow, [ 0 1 node-inputs ] extend pop-r push-d [ 1 0 node-outputs ] bind ] "infer" set-word-property -: meta-infer ( word op -- ) - #! Mark a word as being partially evaluated. - dupd [ - over unit , \ car , - f , , - "infer-effect" word-property , - [ drop host-word ] , - \ with-dataflow , - ] make-list "infer" set-word-property ; +: partial-eval ( word -- ) + #! Partially evaluate a word. + f over dup + "infer-effect" word-property + [ host-word ] with-dataflow ; -\ drop #drop meta-infer -\ dup #dup meta-infer -\ swap #swap meta-infer -\ over #over meta-infer -\ pick #pick meta-infer +\ drop [ \ drop partial-eval ] "infer" set-word-property +\ dup [ \ dup partial-eval ] "infer" set-word-property +\ swap [ \ swap partial-eval ] "infer" set-word-property +\ over [ \ over partial-eval ] "infer" set-word-property +\ pick [ \ pick partial-eval ] "infer" set-word-property diff --git a/library/tools/heap-stats.factor b/library/inference/test.factor similarity index 69% rename from library/tools/heap-stats.factor rename to library/inference/test.factor index a8ab447470..6f325eb54f 100644 --- a/library/tools/heap-stats.factor +++ b/library/inference/test.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -25,27 +25,30 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: listener +IN: test +USE: errors +USE: inference USE: kernel USE: lists -USE: math USE: namespaces USE: prettyprint USE: stdio -USE: words -USE: vectors +USE: strings USE: unparser -USE: generic -: heap-stat. ( type instances bytes -- ) - dup 0 = [ - 3drop - ] [ - rot builtin-type word-name write ": " write - unparse write " bytes, " write - unparse write " instances" print - ] ifte ; +: try-infer ( quot -- effect error ) + [ infer f ] [ [ >r drop f r> ] when* ] catch ; -: heap-stats. ( -- ) - #! Print heap allocation breakdown. - 0 heap-stats [ dupd uncons heap-stat. 1 + ] each drop ; +: infer-fail ( quot error -- ) + "! " , dup string? [ unparse ] unless , "\n" , + [ [ infer ] cons . \ unit-test-fails . ] with-string , ; + +: infer-pass ( quot effect -- ) + [ unit . [ infer ] cons . \ unit-test . ] with-string , ; + +: infer>test ( quot -- str ) + #! Make a string representing a unit test for the stack + #! effect of a word. + [ + dup try-infer [ infer-fail ] [ infer-pass ] ?ifte + ] make-string ; diff --git a/library/inference/types.factor b/library/inference/types.factor index ea8557f604..709944114c 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -1,44 +1,8 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: stdio -USE: prettyprint +USING: errors generic interpreter kernel kernel-internals +lists math namespaces strings vectors words stdio prettyprint ; ! Enhanced inference of primitives relating to data types. ! Optimizes type checks and slot access. @@ -63,31 +27,29 @@ USE: prettyprint \ >string \ string infer-check ] "infer" set-word-property +: fast-slot? ( -- ? ) + #! If the slot number is literal and the object's type is + #! known, we can compile a slot access into a single + #! instruction (x86). + peek-d literal? + peek-next-d value-class builtin-supertypes length 1 = and ; + +: fast-slot ( -- ) + dataflow-drop, pop-d literal-value + peek-d value-class builtin-supertypes cons + \ slot [ [ object ] [ object ] ] (consume/produce) ; + +: computed-slot ( -- ) + \ slot dup "infer-effect" word-property consume/produce ; + \ slot [ [ object fixnum ] ensure-d - dataflow-drop, pop-d literal-value - peek-d value-class builtin-supertypes dup length 1 = [ - cons #slot dataflow, [ - 1 0 node-inputs - [ object ] consume-d - [ object ] produce-d - 1 0 node-outputs - ] bind - ] [ - "slot called without static type knowledge" throw - ] ifte + fast-slot? [ fast-slot ] [ computed-slot ] ifte ] "infer" set-word-property : type-value-map ( value -- ) - [ - num-types [ - dup builtin-type dup [ - pick swons cons , - ] [ - 2drop - ] ifte - ] times* - ] make-list nip ; + num-types [ dup builtin-type pick swons cons ] project + [ cdr cdr ] subset nip ; \ type [ [ object ] ensure-d @@ -96,7 +58,7 @@ USE: prettyprint 1 0 node-inputs [ object ] consume-d [ fixnum ] produce-d - r> peek-d [ type-propagations set ] bind + r> peek-d set-value-type-prop 1 0 node-outputs ] bind ] "infer" set-word-property diff --git a/library/inference/words.factor b/library/inference/words.factor index 5f002a098f..6a07495b72 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -1,54 +1,18 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: inference -USE: errors -USE: generic -USE: interpreter -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings -USE: vectors -USE: words -USE: hashtables -USE: parser -USE: prettyprint +USING: errors generic interpreter kernel lists math namespaces +strings vectors words hashtables parser prettyprint ; -: with-dataflow ( param op [ intypes outtypes ] quot -- ) +: with-dataflow ( param op [[ in# out# ]] quot -- ) #! Take input parameters, execute quotation, take output #! parameters, add node. The quotation is called with the #! stack effect. >r dup car ensure-d >r dataflow, r> r> rot - [ pick car swap dataflow-inputs ] keep - pick 2slip cdr car swap - dataflow-outputs ; inline + [ pick car swap [ length 0 node-inputs ] bind ] keep + pick >r >r nip call r> r> cdr car swap + [ length 0 node-outputs ] bind ; inline : consume-d ( typelist -- ) [ pop-d 2drop ] each ; @@ -57,6 +21,7 @@ USE: prettyprint [ push-d ] each ; : (consume/produce) ( param op effect ) + dup >r -rot r> [ unswons consume-d car produce-d ] with-dataflow ; : consume/produce ( word [ in-types out-types ] -- ) @@ -69,16 +34,16 @@ USE: prettyprint #! either execute the word in the meta interpreter (if it is #! side-effect-free and all parameters are literal), or #! simply apply its stack effect to the meta-interpreter. - over "infer" word-property dup [ + over "infer" word-property [ swap car ensure-d call drop ] [ - drop consume/produce - ] ifte ; + consume/produce + ] ifte* ; : no-effect ( word -- ) "Unknown stack effect: " swap word-name cat2 throw ; -: with-block ( word label quot -- ) +: with-block ( word label quot -- node ) #! Execute a quotation with the word on the stack, and add #! its dataflow contribution to a new block node in the IR. over [ @@ -88,28 +53,46 @@ USE: prettyprint r> call ] (with-block) ; -: inline-compound ( word -- effect ) +: recursive? ( word -- ? ) + dup word-parameter tree-contains? ; + +: inline-compound ( word -- effect node ) #! Infer the stack effect of a compound word in the current - #! inferencer instance. + #! inferencer instance. If the word in question is recursive + #! we infer its stack effect inside a new block. gensym [ word-parameter infer-quot effect ] with-block ; -: infer-compound ( word -- effect ) +: infer-compound ( word -- ) #! Infer a word's stack effect in a separate inferencer #! instance. [ - recursive-state get init-inference - dup dup inline-compound - [ "infer-effect" set-word-property ] keep - ] with-scope consume/produce ; + [ + recursive-state get init-inference + dup dup inline-compound drop present-effect + [ "infer-effect" set-word-property ] keep + ] with-scope consume/produce + ] [ + [ + >r branches-can-fail? [ + drop + ] [ + t "no-effect" set-word-property + ] ifte r> rethrow + ] when* + ] catch ; GENERIC: (apply-word) M: compound (apply-word) ( word -- ) #! Infer a compound word's stack effect. - dup "inline" word-property [ - inline-compound drop + dup "no-effect" word-property [ + no-effect ] [ - infer-compound + dup "inline" word-property [ + inline-compound 2drop + ] [ + infer-compound + ] ifte ] ifte ; M: promise (apply-word) ( word -- ) @@ -118,55 +101,46 @@ M: promise (apply-word) ( word -- ) M: symbol (apply-word) ( word -- ) apply-literal ; -: current-word ( -- word ) - #! Push word we're currently inferring effect of. - recursive-state get car car ; - -: check-recursion ( word -- ) - #! If at the location of the recursive call, we're taking - #! more items from the stack than producing, we have a - #! diverging recursion. Note that this check is not done for - #! mutually-recursive words. Generally they should be - #! avoided. - current-word = [ - d-in get vector-length - meta-d get vector-length > [ - current-word word-name " diverges." cat2 throw - ] when - ] when ; - -: decompose ( x y -- effect ) - #! Return a stack effect such that x*effect = y. - 2unlist >r - swap 2unlist >r - over length over length - head nip - r> append - r> 2list ; - -: base-case ( word -- effect ) - effect swap +: with-recursion ( quot -- ) [ - inferring-base-case on - copy-inference - inline-compound - inferring-base-case off - ] with-scope decompose ; + inferring-base-case inc + call + ] [ + inferring-base-case dec + rethrow + ] catch ; + +: base-case ( word label -- ) + [ + over inline-compound [ + drop + [ #call-label ] [ #call ] ?ifte + node-op set + node-param set + ] bind + ] with-recursion ; + +: no-base-case ( word -- ) + word-name " does not have a base case." cat2 throw ; : recursive-word ( word label -- ) #! Handle a recursive call, by either applying a previously #! inferred base case, or raising an error. If the recursive #! call is to a local block, emit a label call node. - inferring-base-case get [ - drop word-name " does not have a base case." cat2 throw + inferring-base-case get max-recursion > [ + drop no-base-case ] [ - 2dup [ drop #call-label ] [ nip #call ] ifte - rot base-case (consume/produce) + inferring-base-case get max-recursion = [ + base-case + ] [ + [ drop inline-compound 2drop ] with-recursion + ] ifte ] ifte ; : apply-word ( word -- ) #! Apply the word's stack effect to the inferencer state. dup recursive-state get assoc [ - dup check-recursion recursive-word + recursive-word ] [ dup "infer-effect" word-property [ apply-effect @@ -181,13 +155,18 @@ M: symbol (apply-word) ( word -- ) gensym dup [ drop pop-d dup value-recursion recursive-state set - literal-value infer-quot - ] with-block ; + literal-value + dup infer-quot + ] with-block drop handle-terminator ; \ call [ infer-call ] "infer" set-word-property +! These hacks will go away soon \ * [ [ number number ] [ number ] ] "infer-effect" set-word-property +\ - [ [ number number ] [ number ] ] "infer-effect" set-word-property +\ = [ [ object object ] [ object ] ] "infer-effect" set-word-property \ undefined-method t "terminator" set-word-property +\ undefined-method [ [ object word ] [ ] ] "infer-effect" set-word-property \ not-a-number t "terminator" set-word-property \ throw t "terminator" set-word-property diff --git a/library/io/ansi.factor b/library/io/ansi.factor index bd3d00dfd9..7068adafde 100644 --- a/library/io/ansi.factor +++ b/library/io/ansi.factor @@ -1,41 +1,14 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: ansi -USE: lists -USE: kernel -USE: namespaces -USE: stdio -USE: streams -USE: strings -USE: presentation -USE: generic +USING: lists kernel namespaces stdio streams strings +presentation generic ; -! Some words for outputting ANSI colors. +! raps the given stream in an ANSI stream. ANSI +! streams support the following character attributes: +! bold - if not f, text is boldface. +! ansi-fg - foreground color +! ansi-bg - background color ! black 0 ! red 1 @@ -75,21 +48,11 @@ USE: generic : ansi-attr-string ( string style -- string ) [ ansi-attrs , reset , ] make-string ; -TRAITS: ansi-stream +TUPLE: ansi-stream delegate ; -M: ansi-stream fwrite-attr ( string style stream -- ) - [ - [ default-style ] unless* ansi-attr-string - delegate get fwrite - ] bind ; - -C: ansi-stream ( stream -- stream ) - #! Wraps the given stream in an ANSI stream. ANSI streams - #! support the following character attributes: - #! bold - if not f, text is boldface. - #! ansi-fg - foreground color - #! ansi-bg - background color - [ delegate set ] extend ; +M: ansi-stream stream-write-attr ( string style stream -- ) + >r [ default-style ] unless* ansi-attr-string r> + ansi-stream-delegate stream-write ; IN: shells diff --git a/library/io/buffer.factor b/library/io/buffer.factor index 6ea7cc3da3..86c793f4dc 100644 --- a/library/io/buffer.factor +++ b/library/io/buffer.factor @@ -1,8 +1,6 @@ -! :folding=indent:collapseFolds=1: - ! $Id$ ! -! Copyright (C) 2004 Mackenzie Straight. +! Copyright (C) 2004, 2005 Mackenzie Straight. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -26,20 +24,10 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: kernel-internals +USING: alien errors generic kernel kernel-internals math namespaces strings + win32-api ; -USE: alien -USE: errors -USE: kernel -USE: kernel-internals -USE: math -USE: namespaces -USE: strings -USE: win32-api - -SYMBOL: buf-size -SYMBOL: buf-ptr -SYMBOL: buf-fill -SYMBOL: buf-pos +TUPLE: buffer size ptr fill pos ; : imalloc ( size -- address ) "int" "libc" "malloc" [ "int" ] alien-invoke ; @@ -50,97 +38,69 @@ SYMBOL: buf-pos : irealloc ( address size -- address ) "int" "libc" "realloc" [ "int" "int" ] alien-invoke ; -: ( size -- buffer ) - #! Allocates and returns a new buffer. - [ - dup buf-size set - imalloc buf-ptr set - 0 buf-fill set - 0 buf-pos set - ] extend ; +C: buffer ( size -- buffer ) + 2dup set-buffer-size + swap imalloc swap [ set-buffer-ptr ] keep + 0 swap [ set-buffer-fill ] keep + 0 swap [ set-buffer-pos ] keep ; : buffer-free ( buffer -- ) #! Frees the C memory associated with the buffer. - [ buf-ptr get ifree ] bind ; + buffer-ptr ifree ; : buffer-contents ( buffer -- string ) #! Returns the current contents of the buffer. - [ - buf-ptr get buf-pos get + - buf-fill get buf-pos get - - memory>string - ] bind ; + dup buffer-ptr over buffer-pos + + over buffer-fill pick buffer-pos - + memory>string nip ; : buffer-first-n ( count buffer -- string ) - [ - buf-fill get buf-pos get - min - buf-ptr get buf-pos get + - swap memory>string - ] bind ; + [ dup buffer-fill swap buffer-pos - min ] keep + dup buffer-ptr swap buffer-pos + swap memory>string ; : buffer-reset ( count buffer -- ) #! Reset the position to 0 and the fill pointer to count. - [ 0 buf-pos set buf-fill set ] bind ; + [ set-buffer-fill ] keep 0 swap set-buffer-pos ; : buffer-consume ( count buffer -- ) #! Consume count characters from the beginning of the buffer. - [ - buf-pos [ + buf-fill get min ] change - buf-pos get buf-fill get = [ - 0 buf-pos set 0 buf-fill set - ] when - ] bind ; + [ buffer-pos + ] keep [ buffer-fill min ] keep [ set-buffer-pos ] keep + dup buffer-pos over buffer-fill = [ + [ 0 swap set-buffer-pos ] keep [ 0 swap set-buffer-fill ] keep + ] when drop ; : buffer-length ( buffer -- length ) #! Returns the amount of unconsumed input in the buffer. - [ buf-fill get buf-pos get - 0 max ] bind ; - -: buffer-size ( buffer -- size ) - [ buf-size get ] bind ; + dup buffer-fill swap buffer-pos - 0 max ; : buffer-capacity ( buffer -- int ) #! Returns the amount of data that may be added to the buffer. - [ buf-size get buf-fill get - ] bind ; + dup buffer-size swap buffer-fill - ; : buffer-set ( string buffer -- ) - #! Set the contents of a buffer to string. - [ - dup buf-ptr get string>memory - str-length namespace buffer-reset - ] bind ; + 2dup buffer-ptr string>memory >r str-length r> buffer-reset ; + +: (check-overflow) ( string buffer -- ) + buffer-capacity swap str-length < [ "Buffer overflow" throw ] when ; : buffer-append ( string buffer -- ) - #! Appends a string to the end of the buffer. If it doesn't fit, - #! an error is thrown. - [ - dup buf-size get buf-fill get - swap str-length < [ - "Buffer overflow" throw - ] when - dup buf-ptr get buf-fill get + string>memory - buf-fill [ swap str-length + ] change - ] bind ; + 2dup (check-overflow) + [ dup buffer-ptr swap buffer-fill + string>memory ] 2keep + [ buffer-fill swap str-length + ] keep set-buffer-fill ; : buffer-append-char ( int buffer -- ) - #! Append a single character to a buffer. - [ - buf-ptr get buf-fill get + 0 set-alien-1 - buf-fill [ 1 + ] change - ] bind ; + #! Append a single character to a buffer + [ dup buffer-ptr swap buffer-fill + 0 set-alien-1 ] keep + [ buffer-fill 1 + ] keep set-buffer-fill ; : buffer-extend ( length buffer -- ) #! Increases the size of the buffer by length. - [ - buf-size get + dup buf-ptr get swap irealloc - buf-ptr set buf-size set - ] bind ; + [ buffer-size + dup ] keep [ buffer-ptr swap ] keep >r irealloc r> + [ set-buffer-ptr ] keep set-buffer-size ; -: buffer-fill ( count buffer -- ) +: buffer-inc-fill ( count buffer -- ) #! Increases the fill pointer by count. - [ buf-fill [ + ] change ] bind ; + [ buffer-fill + ] keep set-buffer-fill ; -: buffer-ptr ( buffer -- pointer ) - #! Returns the memory address of the buffer area. - [ buf-ptr get ] bind ; - -: buffer-pos ( buffer -- int ) - [ buf-ptr get buf-pos get + ] bind ; +: buffer-pos+ptr ( buffer -- int ) + [ buffer-ptr ] keep buffer-pos + ; diff --git a/library/io/files.factor b/library/io/files.factor index 2519ad5392..d66f7967f4 100644 --- a/library/io/files.factor +++ b/library/io/files.factor @@ -1,39 +1,8 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: files -USE: kernel -USE: hashtables -USE: lists -USE: namespaces -USE: presentation -USE: stdio -USE: strings -USE: unparser +USING: kernel hashtables lists namespaces presentation stdio +strings unparser ; : exists? ( file -- ? ) stat >boolean ; @@ -50,10 +19,10 @@ USE: unparser : file-actions ( -- list ) [ - [ "Push" | "" ] - [ "Run file" | "run-file" ] - [ "List directory" | "directory." ] - [ "Change directory" | "cd" ] + [[ "Push" "" ]] + [[ "Run file" "run-file" ]] + [[ "List directory" "directory." ]] + [[ "Change directory" "cd" ]] ] ; : set-mime-types ( assoc -- ) @@ -100,20 +69,20 @@ USE: unparser : dir. cwd directory. ; [ - [ "html" | "text/html" ] - [ "txt" | "text/plain" ] + [[ "html" "text/html" ]] + [[ "txt" "text/plain" ]] - [ "gif" | "image/gif" ] - [ "png" | "image/png" ] - [ "jpg" | "image/jpeg" ] - [ "jpeg" | "image/jpeg" ] + [[ "gif" "image/gif" ]] + [[ "png" "image/png" ]] + [[ "jpg" "image/jpeg" ]] + [[ "jpeg" "image/jpeg" ]] - [ "jar" | "application/octet-stream" ] - [ "zip" | "application/octet-stream" ] - [ "tgz" | "application/octet-stream" ] - [ "tar.gz" | "application/octet-stream" ] - [ "gz" | "application/octet-stream" ] + [[ "jar" "application/octet-stream" ]] + [[ "zip" "application/octet-stream" ]] + [[ "tgz" "application/octet-stream" ]] + [[ "tar.gz" "application/octet-stream" ]] + [[ "gz" "application/octet-stream" ]] - [ "factor" | "application/x-factor" ] - [ "factsp" | "application/x-factor-server-page" ] + [[ "factor" "application/x-factor" ]] + [[ "factsp" "application/x-factor-server-page" ]] ] set-mime-types diff --git a/library/io/io-internals.factor b/library/io/io-internals.factor index aa0f840320..a5d17f494b 100644 --- a/library/io/io-internals.factor +++ b/library/io/io-internals.factor @@ -58,14 +58,14 @@ BUILTIN: port 14 : blocking-read-line ( port -- line ) dup wait-to-read-line read-line-fd-8 dup [ sbuf>str ] when ; -: fill-fd# ( count port -- ) +: 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 ; +: 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 ; +: 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 ; @@ -76,5 +76,3 @@ BUILTIN: port 14 : blocking-copy ( in out -- ) [ add-copy-io-task (yield) ] callcc0 pending-io-error pending-io-error ; - - diff --git a/library/io/logging.factor b/library/io/logging.factor index 07b97e50c3..0c59236e98 100644 --- a/library/io/logging.factor +++ b/library/io/logging.factor @@ -36,19 +36,18 @@ USE: strings USE: unparser : log ( msg -- ) - "log" get dup [ tuck fprint fflush ] [ 2drop ] ifte ; + "log" get dup [ tuck stream-print stream-flush ] [ 2drop ] ifte ; : log-error ( error -- ) "Error: " swap cat2 log ; -: log-client ( -- ) - "client" get [ - "Accepted connection from " swap - "client" swap hash cat2 log +: log-client ( client-stream -- ) + client-stream-host [ + "Accepted connection from " swap cat2 log ] when* ; : with-logging ( quot -- ) [ stdio get "log" set call ] with-scope ; : with-log-file ( file quot -- ) - [ swap "log" set call ] with-scope ; + [ swap "log" set call ] with-scope ; diff --git a/library/io/network.factor b/library/io/network.factor index 2350719fed..634d8679e5 100644 --- a/library/io/network.factor +++ b/library/io/network.factor @@ -1,61 +1,32 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: streams -USE: io-internals -USE: errors -USE: hashtables -USE: kernel -USE: stdio -USE: strings -USE: namespaces -USE: unparser -USE: generic +USING: io-internals errors hashtables kernel stdio strings +namespaces unparser generic ; -TRAITS: server +TUPLE: server port ; GENERIC: accept -M: server fclose ( stream -- ) - [ "socket" get close-port ] bind ; +M: server stream-close ( stream -- ) + server-port close-port ; C: server ( port -- stream ) #! Starts listening on localhost:port. Returns a stream that - #! you can close with fclose, and accept connections from + #! you can close with stream-close, and accept connections from #! with accept. No other stream operations are supported. - [ server-socket "socket" set ] extend ; + [ >r server-socket r> set-server-port ] keep ; -: ( host port in out -- stream ) - [ ":" swap unparse cat3 "client" set ] extend ; +TUPLE: client-stream delegate host ; + +C: client-stream ( host port in out -- stream ) + #! stream-flush yields until connection is established. + [ >r r> set-client-stream-delegate ] keep + [ >r ":" swap unparse cat3 r> set-client-stream-host ] keep + dup stream-flush ; : ( host port -- stream ) - #! fflush yields until connection is established. - 2dup client-socket dup fflush ; + 2dup client-socket ; M: server accept ( server -- client ) #! Accept a connection from a server socket. - "socket" swap hash blocking-accept ; - + server-port blocking-accept ; diff --git a/library/io/presentation.factor b/library/io/presentation.factor index a55f5f876d..f37abe0392 100644 --- a/library/io/presentation.factor +++ b/library/io/presentation.factor @@ -39,7 +39,7 @@ USE: unparser [ uncons >r over " " r> cat3 cons ] map nip ; ! A style is an alist whose key/value pairs hold -! significance to the 'fwrite-attr' word when applied to a +! significance to the 'stream-write-attr' word when applied to a ! stream that supports attributed string output. : (style) ( name -- style ) "styles" get hash ; @@ -50,15 +50,15 @@ USE: unparser "styles" set [ - [ "font" | "Monospaced" ] + [[ "font" "Monospaced" ]] ] "default" set-style [ - [ "bold" | t ] + [[ "bold" t ]] ] default-style append "prompt" set-style [ - [ "ansi-fg" | "0" ] - [ "ansi-bg" | "2" ] - [ "fg" | [ 255 0 0 ] ] + [[ "ansi-fg" "0" ]] + [[ "ansi-bg" "2" ]] + [[ "fg" [ 255 0 0 ] ]] ] default-style append "comments" set-style diff --git a/library/io/stdio.factor b/library/io/stdio.factor index df04ef1a40..a00ce67de9 100644 --- a/library/io/stdio.factor +++ b/library/io/stdio.factor @@ -1,50 +1,19 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: stdio -USE: errors -USE: kernel -USE: lists -USE: namespaces -USE: streams -USE: generic -USE: strings +USING: errors kernel lists namespaces streams generic strings ; SYMBOL: stdio -: flush ( -- ) stdio get fflush ; -: read ( -- string ) stdio get freadln ; -: read1 ( count -- string ) stdio get fread1 ; -: read# ( count -- string ) stdio get fread# ; -: write ( string -- ) stdio get fwrite ; -: write-attr ( string style -- ) stdio get fwrite-attr ; -: print ( string -- ) stdio get fprint ; +: flush ( -- ) stdio get stream-flush ; +: read-line ( -- string ) stdio get stream-readln ; +: read1 ( -- char ) stdio get stream-read1 ; +: read ( count -- string ) stdio get stream-read ; +: write ( string -- ) stdio get stream-write ; +: write-attr ( string style -- ) stdio get stream-write-attr ; +: print ( string -- ) stdio get stream-print ; : terpri ( -- ) "\n" write ; -: close ( -- ) stdio get fclose ; +: close ( -- ) stdio get stream-close ; : write-icon ( resource -- ) #! Write an icon. Eg, /library/icons/File.png @@ -56,24 +25,14 @@ SYMBOL: stdio : with-string ( quot -- str ) #! Execute a quotation, and push a string containing all #! text printed by the quotation. - 1024 [ + 1024 [ call stdio get stream>str ] with-stream ; -TRAITS: stdio-stream +TUPLE: stdio-stream delegate ; -M: stdio-stream fauto-flush ( -- ) - [ delegate get fflush ] bind ; +M: stdio-stream stream-auto-flush ( -- ) + stdio-stream-delegate stream-flush ; -M: stdio-stream fclose ( -- ) +M: stdio-stream stream-close ( -- ) drop ; - -C: stdio-stream ( delegate -- stream ) - [ delegate set ] extend ; - -: with-prefix ( prefix quot -- ) - #! Each line of output from the given quotation is prefixed - #! with a string. - swap stdio get [ - stdio set call - ] with-scope ; inline diff --git a/library/io/stream-impl.factor b/library/io/stream-impl.factor index bd756b11c6..35f09c2750 100644 --- a/library/io/stream-impl.factor +++ b/library/io/stream-impl.factor @@ -1,81 +1,46 @@ -! :folding=indent:collapseFolds=1: +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: files +USING: io-internals errors hashtables kernel stdio strings +namespaces generic ; -! $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. +! We need this early during bootstrap. +: path+ ( path path -- path ) + #! Combine two paths. This will be implemented later. + "/" swap cat3 ; IN: stdio DEFER: stdio IN: streams -USE: io-internals -USE: errors -USE: hashtables -USE: kernel -USE: stdio -USE: strings -USE: namespaces -USE: generic -TRAITS: fd-stream +TUPLE: fd-stream in out ; -M: fd-stream fwrite-attr ( str style stream -- ) - [ drop "out" get blocking-write ] bind ; +M: fd-stream stream-write-attr ( str style stream -- ) + nip fd-stream-out blocking-write ; -M: fd-stream freadln ( stream -- str ) - [ "in" get dup [ blocking-read-line ] when ] bind ; +M: fd-stream stream-readln ( stream -- str ) + fd-stream-in dup [ blocking-read-line ] when ; -M: fd-stream fread# ( count stream -- str ) - [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ; +M: fd-stream stream-read ( count stream -- str ) + fd-stream-in dup [ blocking-read ] [ nip ] ifte ; -M: fd-stream fflush ( stream -- ) - [ "out" get [ blocking-flush ] when* ] bind ; +M: fd-stream stream-flush ( stream -- ) + fd-stream-out [ blocking-flush ] when* ; -M: fd-stream fauto-flush ( stream -- ) +M: fd-stream stream-auto-flush ( stream -- ) drop ; -M: fd-stream fclose ( -- ) - [ - "out" get [ dup blocking-flush close-port ] when* - "in" get [ close-port ] when* - ] bind ; +M: fd-stream stream-close ( stream -- ) + dup fd-stream-out [ dup blocking-flush close-port ] when* + fd-stream-in [ close-port ] when* ; -C: fd-stream ( in out -- stream ) - [ "out" set "in" set ] extend ; - -: ( path -- stream ) +: ( path -- stream ) t f open-file ; -: ( path -- stream ) +: ( path -- stream ) f t open-file ; -: ( path -- stream ) - ; - -: ( path -- stream ) - ; - : init-stdio ( -- ) stdin stdout stdio set ; @@ -83,15 +48,19 @@ C: fd-stream ( in out -- stream ) #! 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 ; + fd-stream-out >r fd-stream-in 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 ; + [ + 2dup (fcopy) + ] [ + -rot stream-close stream-close rethrow + ] catch ; : resource-path ( -- path ) "resource-path" get [ "." ] unless* ; : ( path -- stream ) - resource-path swap cat2 ; + resource-path swap path+ ; diff --git a/library/io/stream.factor b/library/io/stream.factor index c81c430413..45277f1b61 100644 --- a/library/io/stream.factor +++ b/library/io/stream.factor @@ -1,97 +1,55 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: stdio +DEFER: stdio IN: streams -USE: errors -USE: kernel -USE: namespaces -USE: strings -USE: generic -USE: lists +USING: errors kernel namespaces strings generic lists ; -GENERIC: fflush ( stream -- ) -GENERIC: fauto-flush ( stream -- ) -GENERIC: freadln ( stream -- string ) -GENERIC: fread# ( count stream -- string ) -GENERIC: fwrite-attr ( string style stream -- ) -GENERIC: fclose ( stream -- ) +GENERIC: stream-flush ( stream -- ) +GENERIC: stream-auto-flush ( stream -- ) +GENERIC: stream-readln ( stream -- string ) +GENERIC: stream-read ( count stream -- string ) +GENERIC: stream-write-attr ( string style stream -- ) +GENERIC: stream-close ( stream -- ) -: fread1 ( stream -- char/f ) - 1 swap fread# +: stream-read1 ( stream -- char/f ) + 1 swap stream-read dup f-or-"" [ drop f ] [ 0 swap str-nth ] ifte ; -: fwrite ( string stream -- ) - f swap fwrite-attr ; +: stream-write ( string stream -- ) + f swap stream-write-attr ; -: fprint ( string stream -- ) - [ fwrite ] keep - [ "\n" swap fwrite ] keep - fauto-flush ; +: stream-print ( string stream -- ) + [ stream-write ] keep + [ "\n" swap stream-write ] keep + stream-auto-flush ; -TRAITS: string-output-stream +! A stream that builds a string of all text written to it. +TUPLE: string-output buf ; -M: string-output-stream fwrite-attr ( string style stream -- ) - [ drop "buf" get sbuf-append ] bind ; +M: string-output stream-write-attr ( string style stream -- ) + nip string-output-buf sbuf-append ; -M: string-output-stream fclose ( stream -- ) - drop ; - -M: string-output-stream fflush ( stream -- ) - drop ; - -M: string-output-stream fauto-flush ( stream -- ) - drop ; +M: string-output stream-close ( stream -- ) drop ; +M: string-output stream-flush ( stream -- ) drop ; +M: string-output stream-auto-flush ( stream -- ) drop ; : stream>str ( stream -- string ) #! Returns the string written to the given string output #! stream. - [ "buf" get ] bind sbuf>str ; + string-output-buf sbuf>str ; -C: string-output-stream ( size -- stream ) +C: string-output ( size -- stream ) #! Creates a new stream for writing to a string buffer. - [ "buf" set ] extend ; + [ >r r> set-string-output-buf ] keep ; -! Prefix stream prefixes each line with a given string. -TRAITS: prefix-stream -SYMBOL: prefix -SYMBOL: last-newline +! Sometimes, we want to have a delegating stream that uses stdio +! words. +TUPLE: wrapper-stream delegate scope ; -M: prefix-stream fwrite-attr ( string style stream -- ) +C: wrapper-stream ( stream -- stream ) + 2dup set-wrapper-stream-delegate [ - last-newline get [ - prefix get delegate get fwrite last-newline off - ] when - - dupd delegate get fwrite-attr - - "\n" str-tail? [ - last-newline on - ] when - ] bind ; - -C: prefix-stream ( prefix stream -- stream ) - [ last-newline on delegate set prefix set ] extend ; + >r [ stdio set ] extend r> + set-wrapper-stream-scope + ] keep ; diff --git a/library/io/vocabulary-style.factor b/library/io/vocabulary-style.factor index 63a7c933e7..8d16f17ebd 100644 --- a/library/io/vocabulary-style.factor +++ b/library/io/vocabulary-style.factor @@ -40,67 +40,81 @@ USE: words : set-vocab-style ( style vocab -- ) >r default-style append r> "vocabularies" style set-hash ; +: browser-styles ( word -- style ) + #! Return the style values for the HTML word browser + dup word-vocabulary [ + swap word-name "browser-link-word" swons + swap "browser-link-vocab" swons + 2list + ] [ + drop [ ] + ] ifte* ; + : word-style ( word -- style ) - word-vocabulary [ vocab-style ] [ default-style ] ifte* ; + dup browser-styles swap word-vocabulary [ + vocab-style + ] [ + default-style + ] ifte* append ; "vocabularies" set-style [ - [ "ansi-fg" | "1" ] - [ "fg" | [ 204 0 0 ] ] + [[ "ansi-fg" "1" ]] + [[ "fg" [ 204 0 0 ] ]] ] "arithmetic" set-vocab-style [ - [ "ansi-fg" | "1" ] - [ "fg" | [ 255 0 0 ] ] + [[ "ansi-fg" "1" ]] + [[ "fg" [ 255 0 0 ] ]] ] "errors" set-vocab-style [ - [ "ansi-fg" | "4" ] - [ "fg" | [ 153 102 255 ] ] + [[ "ansi-fg" "4" ]] + [[ "fg" [ 153 102 255 ] ]] ] "hashtables" set-vocab-style [ - [ "ansi-fg" | "2" ] - [ "fg" | [ 0 102 153 ] ] + [[ "ansi-fg" "2" ]] + [[ "fg" [ 0 102 153 ] ]] ] "lists" set-vocab-style [ - [ "ansi-fg" | "1" ] - [ "fg" | [ 204 0 0 ] ] + [[ "ansi-fg" "1" ]] + [[ "fg" [ 204 0 0 ] ]] ] "math" set-vocab-style [ - [ "ansi-fg" | "6" ] - [ "fg" | [ 0 153 255 ] ] + [[ "ansi-fg" "6" ]] + [[ "fg" [ 0 153 255 ] ]] ] "namespaces" set-vocab-style [ - [ "ansi-fg" | "2" ] - [ "fg" | [ 102 204 255 ] ] + [[ "ansi-fg" "2" ]] + [[ "fg" [ 102 204 255 ] ]] ] "parser" set-vocab-style [ - [ "ansi-fg" | "2" ] - [ "fg" | [ 102 204 255 ] ] + [[ "ansi-fg" "2" ]] + [[ "fg" [ 102 204 255 ] ]] ] "prettyprint" set-vocab-style [ - [ "ansi-fg" | "2" ] - [ "fg" | [ 0 0 0 ] ] + [[ "ansi-fg" "2" ]] + [[ "fg" [ 0 0 0 ] ]] ] "stack" set-vocab-style [ - [ "ansi-fg" | "4" ] - [ "fg" | [ 204 0 204 ] ] + [[ "ansi-fg" "4" ]] + [[ "fg" [ 204 0 204 ] ]] ] "stdio" set-vocab-style [ - [ "ansi-fg" | "4" ] - [ "fg" | [ 102 0 204 ] ] + [[ "ansi-fg" "4" ]] + [[ "fg" [ 102 0 204 ] ]] ] "streams" set-vocab-style [ - [ "ansi-fg" | "6" ] - [ "fg" | [ 255 0 204 ] ] + [[ "ansi-fg" "6" ]] + [[ "fg" [ 255 0 204 ] ]] ] "strings" set-vocab-style [ - [ "ansi-fg" | "4" ] - [ "fg" | [ 102 204 255 ] ] + [[ "ansi-fg" "4" ]] + [[ "fg" [ 102 204 255 ] ]] ] "unparser" set-vocab-style [ - [ "ansi-fg" | "3" ] - [ "fg" | [ 2 185 2 ] ] + [[ "ansi-fg" "3" ]] + [[ "fg" [ 2 185 2 ] ]] ] "vectors" set-vocab-style [ - [ "fg" | [ 128 128 128 ] ] + [[ "fg" [ 128 128 128 ] ]] ] "syntax" set-vocab-style diff --git a/library/io/win32-console.factor b/library/io/win32-console.factor deleted file mode 100644 index 1492a8d9d4..0000000000 --- a/library/io/win32-console.factor +++ /dev/null @@ -1,89 +0,0 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Mackenzie Straight. -! -! 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: win32-console - -USE: lists -USE: vectors -USE: math -USE: kernel -USE: namespaces -USE: stdio -USE: streams -USE: presentation -USE: generic -USE: parser -USE: compiler -USE: win32-api -USE: win32-stream - -TRAITS: win32-console-stream -SYMBOL: handle - -: reset ( -- ) - handle get 7 SetConsoleTextAttribute drop ; - -: ansi>win32 ( ansi-attr -- win32-attr ) - #! Converts an ANSI color (0-based) to a combination of - #! _RED, _BLUE, and _GREEN bit flags. - { 0 4 2 6 1 5 3 7 } vector-nth ; - -: set-bold ( attr ? -- attr ) - #! Set or unset the bold bit (bit 3). - [ 8 bitor ] [ 8 bitnot bitand ] ifte ; - -: set-fg ( attr n -- attr ) - #! Set the foreground field (bits 0..2). - swap 7 bitnot bitand bitor ; - -: set-bg ( attr n -- attr ) - #! Set the background field (bits 4..6). - 4 shift swap 112 bitnot bitand bitor ; - -: char-attrs ( style -- attrs ) - #! Converts a style into a win32 text attribute bitfield. - 7 ! Default style is white FG, black BG, no extra bits - "bold" pick assoc [ set-bold ] when* - "ansi-fg" pick assoc [ str>number ansi>win32 set-fg ] when* - "ansi-bg" pick assoc [ str>number ansi>win32 set-bg ] when* - nip ; - -: set-attrs ( style -- ) - char-attrs handle get swap SetConsoleTextAttribute drop ; - -M: win32-console-stream fwrite-attr ( string style stream -- ) - [ - [ default-style ] unless* set-attrs - delegate get fwrite - reset - ] bind ; - -C: win32-console-stream ( stream -- stream ) - [ -11 GetStdHandle handle set delegate set ] extend ; - -! global [ [ ] smart-term-hook set ] bind - diff --git a/library/io/win32-io-internals.factor b/library/io/win32-io-internals.factor index 2796a6506f..5319d134d7 100644 --- a/library/io/win32-io-internals.factor +++ b/library/io/win32-io-internals.factor @@ -1,8 +1,6 @@ -! :folding=indent:collapseFolds=1: - ! $Id$ ! -! Copyright (C) 2004 Mackenzie Straight. +! Copyright (C) 2004, 2005 Mackenzie Straight. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -26,38 +24,24 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: win32-io-internals -USE: alien -USE: errors -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: namespaces -USE: prettyprint -USE: vectors -USE: win32-api +USING: alien errors kernel kernel-internals lists math namespaces threads + vectors win32-api stdio streams generic ; SYMBOL: completion-port SYMBOL: io-queue SYMBOL: free-list SYMBOL: callbacks -: handle-io-error ( -- ) - #! If a write or read call fails unexpectedly, throw an error. - GetLastError [ - ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS - ] contains? [ - win32-throw-error - ] unless ; +: expected-error? ( -- bool ) + [ + ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS WAIT_TIMEOUT + ] contains? ; -: win32-init-stdio ( -- ) - INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort - completion-port set - - [ - 32 callbacks set - f free-list set - ] extend io-queue set ; +: handle-io-error ( -- ) + GetLastError expected-error? [ win32-throw-error ] unless ; + +: queue-error ( len/status -- len/status ) + GetLastError expected-error? [ drop f ] unless ; : add-completion ( handle -- ) completion-port get NULL 1 CreateIoCompletionPort drop ; @@ -125,10 +109,53 @@ END-STRUCT callbacks get vector-nth cdr ] bind ; -: win32-next-io-task ( -- quot ) - completion-port get dup >r - dup >r INFINITE GetQueuedCompletionStatus - [ handle-io-error ] unless - r> r> indirect-pointer-value swap indirect-pointer-value - overlapped-ext-user-data get-io-callback call ; +: (wait-for-io) ( timeout -- error overlapped len ) + >r completion-port get + [ 0 swap set-indirect-pointer-value ] keep + + + pick over r> -rot >r >r GetQueuedCompletionStatus r> r> ; + +: overlapped>callback ( overlapped -- callback ) + indirect-pointer-value dup 0 = [ + drop f + ] [ + overlapped-ext-user-data get-io-callback + ] ifte ; + +: wait-for-io ( timeout -- callback len ) + (wait-for-io) overlapped>callback swap indirect-pointer-value + rot [ queue-error ] unless ; + +: win32-next-io-task ( -- ) + INFINITE wait-for-io swap call ; + +: win32-io-thread ( -- ) + 10 wait-for-io swap [ + [ schedule-thread call ] callcc0 2drop + ] [ + drop yield + ] ifte* + win32-io-thread ; + +TUPLE: null-stream ; +M: null-stream stream-flush drop ; +M: null-stream stream-auto-flush drop ; +M: null-stream stream-read 2drop f ; +M: null-stream stream-readln drop f ; +M: null-stream stream-write-attr 3drop ; +M: null-stream stream-close drop ; + +: win32-init-stdio ( -- ) + INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort + completion-port set + + << null-stream >> stdio set + + [ + 32 callbacks set + f free-list set + ] extend io-queue set + + [ win32-io-thread ] in-thread ; diff --git a/library/io/win32-server.factor b/library/io/win32-server.factor index 67b7ff4b83..23d4587c76 100644 --- a/library/io/win32-server.factor +++ b/library/io/win32-server.factor @@ -1,8 +1,6 @@ -! :folding=indent:collapseFolds=1: - ! $Id$ ! -! Copyright (C) 2004 Mackenzie Straight. +! Copyright (C) 2004, 2005 Mackenzie Straight. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -26,24 +24,12 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: win32-stream -USE: alien -USE: errors -USE: generic -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: namespaces -USE: prettyprint -USE: stdio -USE: streams -USE: strings -USE: threads -USE: unparser -USE: win32-api -USE: win32-io-internals +USING: alien errors generic kernel kernel-internals lists math namespaces + prettyprint stdio streams strings threads unparser win32-api + win32-io-internals ; -TRAITS: win32-server +TUPLE: win32-server this ; +TUPLE: win32-client-stream delegate host ; SYMBOL: winsock SYMBOL: socket @@ -76,33 +62,39 @@ SYMBOL: socket : listen-socket ( socket -- ) 20 wsa-listen 0 = [ handle-socket-error ] unless ; -: ( buf stream -- stream ) - [ - buffer-ptr 0 32 32 - dup >r dup >r - GetAcceptExSockaddrs r> r> drop - dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa - [ , ":" , unparse , ] make-string "client" set - ] extend ; +: sockaddr>string ( sockaddr -- string ) + dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa + [ , ":" , unparse , ] make-string ; + +: extract-remote-host ( buffer -- host ) + buffer-ptr 0 32 32 + dup >r + GetAcceptExSockaddrs r> indirect-pointer-value sockaddr>string ; + +C: win32-client-stream ( buf stream -- stream ) + [ set-win32-client-stream-delegate extract-remote-host ] keep + [ set-win32-client-stream-host ] keep ; + +M: win32-client-stream client-stream-host win32-client-stream-host ; C: win32-server ( port -- server ) - [ + swap [ maybe-init-winsock new-socket swap over bind-socket dup listen-socket dup add-completion socket set - ] extend ; + ] extend over set-win32-server-this ; -M: win32-server fclose ( server -- ) - [ socket get CloseHandle drop ] bind ; +M: win32-server stream-close ( server -- ) + win32-server-this [ socket get CloseHandle drop ] bind ; M: win32-server accept ( server -- client ) - [ + win32-server-this [ new-socket 64 [ alloc-io-task init-overlapped >r >r >r socket get r> r> buffer-ptr 0 32 32 NULL r> AcceptEx [ handle-socket-error ] unless (yield) - ] callcc0 + ] callcc1 pending-error drop swap dup add-completion dupd swap buffer-free ] bind ; diff --git a/library/io/win32-stream.factor b/library/io/win32-stream.factor index 3b8406abc1..f52c9c640e 100644 --- a/library/io/win32-stream.factor +++ b/library/io/win32-stream.factor @@ -1,8 +1,6 @@ -! :folding=indent:collapseFolds=1: - ! $Id$ ! -! Copyright (C) 2004 Mackenzie Straight. +! Copyright (C) 2004, 2005 Mackenzie Straight. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -26,23 +24,11 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: win32-stream -USE: alien -USE: continuations -USE: generic -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: namespaces -USE: prettyprint -USE: stdio -USE: streams -USE: strings -USE: threads -USE: win32-api -USE: win32-io-internals +USING: alien continuations generic kernel kernel-internals lists math + namespaces prettyprint stdio streams strings threads win32-api + win32-io-internals ; -TRAITS: win32-stream +TUPLE: win32-stream this ; ! FIXME: rewrite using tuples GENERIC: win32-stream-handle GENERIC: do-write @@ -52,6 +38,9 @@ SYMBOL: out-buffer SYMBOL: fileptr SYMBOL: file-size +: pending-error ( len/status -- len/status ) + dup [ win32-throw-error ] unless ; + : init-overlapped ( overlapped -- overlapped ) 0 over set-overlapped-ext-internal 0 over set-overlapped-ext-internal-high @@ -65,9 +54,9 @@ SYMBOL: file-size : flush-output ( -- ) [ alloc-io-task init-overlapped >r - handle get out-buffer get [ buffer-pos ] keep buffer-length + handle get out-buffer get [ buffer-pos+ptr ] keep buffer-length NULL r> WriteFile [ handle-io-error ] unless (yield) - ] callcc1 + ] callcc1 pending-error dup update-file-pointer out-buffer get [ buffer-consume ] keep @@ -92,13 +81,13 @@ M: string do-write ( str -- ) : fill-input ( -- ) [ alloc-io-task init-overlapped >r - handle get in-buffer get [ buffer-pos ] keep + handle get in-buffer get [ buffer-pos+ptr ] keep buffer-capacity file-size get [ fileptr get - min ] when* NULL r> ReadFile [ handle-io-error ] unless (yield) - ] callcc1 + ] callcc1 pending-error - dup in-buffer get buffer-fill update-file-pointer ; + dup in-buffer get buffer-inc-fill update-file-pointer ; : consume-input ( count -- str ) in-buffer get buffer-length 0 = [ fill-input ] when @@ -139,23 +128,23 @@ M: string do-write ( str -- ) ] ifte ] ifte ; -M: win32-stream fwrite-attr ( str style stream -- ) - nip [ do-write ] bind ; +M: win32-stream stream-write-attr ( str style stream -- ) + win32-stream-this nip [ do-write ] bind ; -M: win32-stream freadln ( stream -- str ) - [ 80 do-read-line ] bind ; +M: win32-stream stream-readln ( stream -- str ) + win32-stream-this [ 80 do-read-line ] bind ; -M: win32-stream fread# ( count stream -- str ) - [ dup swap do-read-count ] bind ; +M: win32-stream stream-read ( count stream -- str ) + win32-stream-this [ dup swap do-read-count ] bind ; -M: win32-stream fflush ( stream -- ) - [ maybe-flush-output ] bind ; +M: win32-stream stream-flush ( stream -- ) + win32-stream-this [ maybe-flush-output ] bind ; -M: win32-stream fauto-flush ( stream -- ) +M: win32-stream stream-auto-flush ( stream -- ) drop ; -M: win32-stream fclose ( stream -- ) - [ +M: win32-stream stream-close ( stream -- ) + win32-stream-this [ maybe-flush-output handle get CloseHandle drop in-buffer get buffer-free @@ -163,10 +152,10 @@ M: win32-stream fclose ( stream -- ) ] bind ; M: win32-stream win32-stream-handle ( stream -- handle ) - [ handle get ] bind ; + win32-stream-this [ handle get ] bind ; C: win32-stream ( handle -- stream ) - [ + swap [ dup NULL GetFileSize dup -1 = not [ file-size set ] [ drop f file-size set ] ifte @@ -174,12 +163,12 @@ C: win32-stream ( handle -- stream ) 4096 in-buffer set 4096 out-buffer set 0 fileptr set - ] extend ; + ] extend over set-win32-stream-this ; -: ( path -- stream ) +: ( path -- stream ) t f win32-open-file ; -: ( path -- stream ) +: ( path -- stream ) f t win32-open-file ; diff --git a/library/kernel.factor b/library/kernel.factor index 516a671cfd..84d6346898 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -1,39 +1,13 @@ -! :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-internals -USE: generic -USE: kernel -USE: vectors +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: kernel-internals USING: generic kernel vectors ; : dispatch ( n vtable -- ) - #! This word is unsafe in compiled code since n is not - #! bounds-checked. Do not call it directly. - vector-nth call ; + #! This word is unsafe since n is not bounds-checked. Do not + #! call it directly. + vector-array array-nth call ; + +BUILTIN: tuple 18 IN: kernel @@ -43,6 +17,9 @@ M: object hashcode drop 0 ; GENERIC: = ( obj obj -- ? ) M: object = eq? ; +GENERIC: clone ( obj -- obj ) +M: object clone ; + : cpu ( -- arch ) #! Returns one of "x86" or "unknown". 7 getenv ; @@ -57,7 +34,7 @@ M: object = eq? ; : num-types ( -- n ) #! One more than the maximum value from type primitive. - 17 ; + 19 ; : ? ( cond t f -- t/f ) #! Push t if cond is true, otherwise push f. @@ -67,12 +44,27 @@ M: object = eq? ; : and ( a b -- a&b ) f ? ; inline : not ( a -- ~a ) f t ? ; inline -: or ( a b -- a|b) t swap ? ; inline +: or ( a b -- a|b ) t swap ? ; inline : xor ( a b -- a^b ) dup not swap ? ; inline IN: syntax -BUILTIN: f 6 + +! The canonical t is a heap-allocated dummy object. It is always +! the first in the image. BUILTIN: t 7 +! In the runtime, the canonical f is represented as a null +! pointer with tag 3. So +! f address . ==> 3 +BUILTIN: f 9 + IN: kernel UNION: boolean f t ; +COMPLEMENT: general-t f + +IN: alien + +! See compiler/alien.factor for the rest; this needs to be here +! since primitive stack effects involve alien inputs/outputs. +BUILTIN: dll 15 +BUILTIN: alien 16 diff --git a/library/lists.factor b/library/lists.factor index 0fc947aa64..4107c8d7ea 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -1,34 +1,6 @@ -! :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: lists -USE: generic -USE: kernel -USE: math +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: lists USING: generic kernel math ; : 2list ( a b -- [ a b ] ) unit cons ; @@ -39,25 +11,19 @@ USE: math : 3list ( a b c -- [ a b c ] ) 2list cons ; +: 3unlist ( [ a b c ] -- a b c ) + uncons uncons car ; + : append ( [ list1 ] [ list2 ] -- [ list1 list2 ] ) over [ >r uncons r> append cons ] [ nip ] ifte ; -: some? ( list pred -- ? ) - #! Apply predicate to each element ,return remainder of list - #! from first occurrence where it is true, or return f. - over [ - dup >r over >r >r car r> call [ - r> r> drop - ] [ - r> cdr r> some? - ] ifte - ] [ - 2drop f - ] ifte ; inline +: contains? ( obj list -- ? ) + #! Test if a list contains an element equal to an object. + [ = ] some-with? >boolean ; -: contains? ( element list -- ? ) - #! Test if a list contains an element. - [ over = ] some? >boolean nip ; +: memq? ( obj list -- ? ) + #! Test if a list contains an object. + [ eq? ] some-with? >boolean ; : partition-add ( obj ? ret1 ret2 -- ret1 ret2 ) rot [ swapd cons ] [ >r cons r> ] ifte ; @@ -124,15 +90,20 @@ DEFER: tree-contains? #! ( X -- Y ) to each element into a new list. over [ (each) rot >r map r> swons ] [ drop ] ifte ; inline -: map-with ( obj list quot -- ) +: map-with ( obj list quot -- list ) #! Push each element of a proper list in turn, and collect #! return values of applying a quotation with effect #! ( obj elt -- obj ) to each element into a new list. - swap [ with rot ] map nip nip ; inline + swap [ with rot ] map 2nip ; inline : remove ( obj list -- list ) + #! Remove all occurrences of objects equal to this one from + #! the list. + [ = not ] subset-with ; + +: remq ( obj list -- list ) #! Remove all occurrences of the object from the list. - [ dupd = not ] subset nip ; + [ eq? not ] subset-with ; : length ( list -- length ) 0 swap [ drop 1 + ] each ; @@ -172,31 +143,19 @@ M: cons = ( obj cons -- ? ) ] ifte ] ifte ; -: cons-hashcode ( cons count -- hash ) - dup 0 number= [ - 2drop 0 - ] [ - over cons? [ - 1 - >r uncons r> tuck - cons-hashcode >r - cons-hashcode r> - bitxor - ] [ - drop hashcode - ] ifte - ] ifte ; +M: cons hashcode ( cons -- hash ) car hashcode ; -M: cons hashcode ( cons -- hash ) 4 cons-hashcode ; - -: project ( n quot -- list ) - #! Execute the quotation n times, passing the loop counter - #! the quotation as it ranges from 0..n-1. Collect results - #! in a new list. - [ ] rot [ -rot over >r >r call r> cons r> swap ] times* - nip reverse ; inline +: (count) ( i n -- list ) + 2dup >= [ 2drop [ ] ] [ >r dup 1 + r> (count) cons ] ifte ; : count ( n -- [ 0 ... n-1 ] ) - [ ] project ; + 0 swap (count) ; + +: project ( n quot -- list ) + >r count r> map ; inline + +: project-with ( elt n quot -- list ) + swap [ with rot ] project 2nip ; inline : head ( list n -- list ) #! Return the first n elements of the list. @@ -209,3 +168,8 @@ M: cons hashcode ( cons -- hash ) 4 cons-hashcode ; : intersection ( list list -- list ) #! Make a list of elements that occur in both lists. [ over contains? ] subset nip ; + +: difference ( list1 list2 -- list ) + #! Make a list of elements that occur in list2 but not + #! list1. + [ over contains? not ] subset nip ; diff --git a/library/math/arc-trig-hyp.factor b/library/math/arc-trig-hyp.factor index 7b093f741b..3467a7d8d1 100644 --- a/library/math/arc-trig-hyp.factor +++ b/library/math/arc-trig-hyp.factor @@ -1,34 +1,7 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: math -USE: kernel -USE: math -USE: math-internals +USING: kernel math math-internals ; ! Inverse trigonometric functions: ! acos asec asin acosec atan acot diff --git a/library/math/complex.factor b/library/math/complex.factor index 5caf6b9254..9f5e950c0f 100644 --- a/library/math/complex.factor +++ b/library/math/complex.factor @@ -1,54 +1,32 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: errors DEFER: throw -IN: math -USE: generic -USE: kernel -USE: kernel-internals -USE: math -USE: math-internals +IN: math-internals +USING: generic kernel kernel-internals math ; -GENERIC: real ( #{ re im } -- re ) +: (rect>) ( xr xi -- x ) + #! Does not perform a check that the arguments are reals. + #! Do not use in your own code. + dup 0 number= [ drop ] [ ] ifte ; inline + +IN: math + +GENERIC: real ( #{ re im }# -- re ) M: real real ; M: complex real 0 slot %real ; -GENERIC: imaginary ( #{ re im } -- im ) +GENERIC: imaginary ( #{ re im }# -- im ) M: real imaginary drop 0 ; M: complex imaginary 1 slot %real ; : rect> ( xr xi -- x ) over real? over real? and [ - dup 0 number= [ drop ] [ (rect>) ] ifte + (rect>) ] [ "Complex number must have real components" throw drop - ] ifte ; inline + ] ifte ; : >rect ( x -- xr xi ) dup real swap imaginary ; inline @@ -60,7 +38,7 @@ M: complex imaginary 1 slot %real ; >rect swap fatan2 ; : >polar ( z -- abs arg ) - >rect 2dup swap fatan2 >r mag2 r> ; + dup abs swap >rect swap fatan2 ; : cis ( theta -- cis ) dup fcos swap fsin rect> ; @@ -68,11 +46,21 @@ M: complex imaginary 1 slot %real ; : polar> ( abs arg -- z ) cis * ; +: absq >rect swap sq swap sq + ; + +: dot ( #{ x1 x2 }# #{ y1 y2 }# -- x1*y1+x2*y2 ) + over real over real * >r swap imaginary swap imaginary * r> + + ; + +: proj ( u v -- w ) + #! Orthogonal projection of u onto v. + [ [ dot ] keep absq /f ] keep * ; + IN: math-internals : 2>rect ( x y -- xr yr xi yi ) [ swap real swap real ] 2keep - swap imaginary swap imaginary ; inline + swap imaginary swap imaginary ; M: complex number= ( x y -- ? ) 2>rect number= [ number= ] [ 2drop f ] ifte ; @@ -80,19 +68,18 @@ M: complex number= ( x y -- ? ) : *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline : *im ( x y -- xi*yr xr*yi ) 2>rect >r * swap r> * ; inline -M: complex + 2>rect + >r + r> rect> ; -M: complex - 2>rect - >r - r> rect> ; -M: complex * ( x y -- x*y ) 2dup *re - -rot *im + rect> ; +M: complex + 2>rect + >r + r> (rect>) ; +M: complex - 2>rect - >r - r> (rect>) ; +M: complex * ( x y -- x*y ) 2dup *re - -rot *im + (rect>) ; -: abs^2 ( x -- y ) >rect sq swap sq + ; inline : complex/ ( x y -- r i m ) #! r = xr*yr+xi*yi, i = xi*yr-xr*yi, m = yr*yr+yi*yi - dup abs^2 >r 2dup *re + -rot *im - r> ; inline + dup absq >r 2dup *re + -rot *im - r> ; inline -M: complex / ( x y -- x/y ) complex/ tuck / >r / r> rect> ; -M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f r> rect> ; +M: complex / ( x y -- x/y ) complex/ tuck / >r / r> (rect>) ; +M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f r> (rect>) ; -M: complex abs ( z -- |z| ) >rect mag2 ; +M: complex abs ( z -- |z| ) absq fsqrt ; M: complex hashcode ( n -- n ) >rect >fixnum swap >fixnum bitxor ; diff --git a/library/math/constants.factor b/library/math/constants.factor index 9b68d43ec6..e0430a8535 100644 --- a/library/math/constants.factor +++ b/library/math/constants.factor @@ -1,35 +1,10 @@ -! :folding=indent:collapseFolds=0: - -! $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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: math USE: kernel -: i #{ 0 1 } ; inline -: -i #{ 0 -1 } ; inline +: i #{ 0 1 }# ; inline +: -i #{ 0 -1 }# ; inline : inf 1.0 0.0 / ; inline : -inf -1.0 0.0 / ; inline : e 2.7182818284590452354 ; inline diff --git a/library/math/float.factor b/library/math/float.factor index b05d1be45f..c37182f63a 100644 --- a/library/math/float.factor +++ b/library/math/float.factor @@ -1,34 +1,7 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: math-internals -USE: generic -USE: kernel -USE: math +USING: generic kernel math ; M: float number= float= ; M: float < float< ; diff --git a/library/math/integer.factor b/library/math/integer.factor index 520feaef39..4787234df5 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -1,37 +1,10 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: errors DEFER: throw IN: math-internals -USE: generic -USE: kernel -USE: math +USING: generic kernel math ; : fraction> ( a b -- a/b ) dup 1 number= [ diff --git a/library/math/math-combinators.factor b/library/math/math-combinators.factor deleted file mode 100644 index 5d61794463..0000000000 --- a/library/math/math-combinators.factor +++ /dev/null @@ -1,91 +0,0 @@ -! :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: math -USE: kernel - -: times ( n quot -- ) - #! Evaluate a quotation n times. - #! - #! In order to compile, the code must produce as many values - #! as it consumes. - tuck >r dup 0 <= [ r> 3drop ] [ 1 - slip r> times ] ifte ; - inline - -: (times) ( limit n quot -- ) - pick pick <= [ - 3drop - ] [ - rot pick 1 + pick 3slip (times) - ] ifte ; inline - -: times* ( n quot -- ) - #! Evaluate a quotation n times, pushing the index at each - #! iteration. The index ranges from 0 to n-1. - #! - #! In order to compile, the code must consume one more value - #! than it produces. - 0 swap (times) ; inline - -: fac ( n -- n! ) - 1 swap [ 1 + * ] times* ; - -: 2times-succ ( #{ a b } #{ c d } -- z ) - #! Lexicographically add #{ 0 1 } to a complex number. - #! If d + 1 == b, return #{ c+1 0 }. Otherwise, #{ c d+1 }. - 2dup imaginary 1 + swap imaginary = [ - nip real 1 + - ] [ - nip >rect 1 + rect> - ] ifte ; inline - -: 2times<= ( #{ a b } #{ c d } -- ? ) - swap real swap real <= ; inline - -: (2times) ( limit n quot -- ) - pick pick 2times<= [ - 3drop - ] [ - rot pick dupd 2times-succ pick 3slip (2times) - ] ifte ; inline - -: 2times* ( #{ w h } quot -- ) - #! Apply a quotation to each pair of complex numbers - #! #{ a b } such that a < w, b < h. - 0 swap (2times) ; inline - -: (repeat) ( i n quot -- ) - pick pick >= [ - 3drop - ] [ - [ swap >r call 1 + r> ] keep (repeat) - ] ifte ; - -: repeat ( n quot -- ) - #! Execute a quotation n times. The loop counter is kept on - #! the stack, and ranges from 0 to n-1. - 0 -rot (repeat) ; diff --git a/library/math/math.factor b/library/math/math.factor index d784356444..2cb9bb145d 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -1,34 +1,7 @@ -! :folding=indent:collapseFolds=0: - -! $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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: math -USE: generic -USE: kernel -USE: math-internals +USING: generic kernel math-internals ; ! Math operations 2GENERIC: number= ( x y -- ? ) @@ -58,16 +31,16 @@ GENERIC: bitnot ( n -- n ) ! Math types BUILTIN: fixnum 0 -BUILTIN: bignum 9 +BUILTIN: bignum 1 UNION: integer fixnum bignum ; BUILTIN: ratio 4 UNION: rational integer ratio ; -BUILTIN: float 10 +BUILTIN: float 5 UNION: real rational float ; -BUILTIN: complex 5 +BUILTIN: complex 6 UNION: number real complex ; M: real hashcode ( n -- n ) >fixnum ; @@ -98,10 +71,6 @@ M: number = ( n n -- ? ) number= ; #! Push the sign of a real number. dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ; -: mag2 ( x y -- mag ) - #! Returns the magnitude of the vector (x,y). - swap sq swap sq + fsqrt ; - GENERIC: abs ( z -- |z| ) M: real abs dup 0 < [ neg ] when ; @@ -114,3 +83,19 @@ M: real abs dup 0 < [ neg ] when ; : align ( offset width -- offset ) 2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ; + +: (repeat) ( i n quot -- ) + pick pick >= [ + 3drop + ] [ + [ swap >r call 1 + r> ] keep (repeat) + ] ifte ; inline + +: repeat ( n quot -- ) + #! Execute a quotation n times. The loop counter is kept on + #! the stack, and ranges from 0 to n-1. + 0 -rot (repeat) ; inline + +: times ( n quot -- ) + #! Evaluate a quotation n times. + swap [ >r dup slip r> ] repeat drop ; inline diff --git a/library/math/pow.factor b/library/math/pow.factor index a2d4529c55..eaf68852bb 100644 --- a/library/math/pow.factor +++ b/library/math/pow.factor @@ -1,34 +1,7 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: math -USE: math -USE: math-internals -USE: kernel +USING: math math-internals kernel ; ! Power-related functions: ! exp log sqrt pow diff --git a/library/math/ratio.factor b/library/math/ratio.factor index 3ba3151547..18d793801f 100644 --- a/library/math/ratio.factor +++ b/library/math/ratio.factor @@ -1,36 +1,7 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: math -USE: generic -USE: kernel -USE: kernel-internals -USE: math -USE: math-internals +USING: generic kernel kernel-internals math math-internals ; GENERIC: numerator ( a/b -- a ) M: integer numerator ; @@ -50,7 +21,7 @@ M: ratio number= ( a/b c/d -- ? ) 2>fraction number= [ number= ] [ 2drop f ] ifte ; : scale ( a/b c/d -- a*d b*c ) - 2>fraction >r * swap r> * swap ; inline + 2>fraction >r * swap r> * swap ; : ratio+d ( a/b c/d -- b*d ) denominator swap denominator * ; inline diff --git a/library/math/trig-hyp.factor b/library/math/trig-hyp.factor index b1c4d2a367..7c7bbf7c06 100644 --- a/library/math/trig-hyp.factor +++ b/library/math/trig-hyp.factor @@ -1,34 +1,7 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: math -USE: kernel -USE: math -USE: math-internals +USING: kernel math math-internals ; ! Trigonometric functions: ! cos sec sin cosec tan cot diff --git a/library/namespaces.factor b/library/namespaces.factor index c1f6ca523e..2a94d0939b 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -1,45 +1,19 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: namespaces -USE: hashtables -USE: kernel -USE: kernel-internals -USE: lists -USE: vectors +USING: hashtables kernel kernel-internals lists strings vectors +math ; ! Other languages have classes, objects, variables, etc. ! Factor has similar concepts. ! -! 5 "x" set -! "x" get 2 + . +! SYMBOL: x +! +! 5 x set +! x get 2 + . ! 7 -! 7 "x" set -! "x" get 2 + . +! 7 x set +! x get 2 + . ! 9 ! ! get ( name -- value ) and set ( value name -- ) search in @@ -60,7 +34,7 @@ USE: vectors : >n ( namespace -- n:namespace ) #! Push a namespace on the namespace stack. - >vector namestack cons set-namestack ; inline + >hashtable namestack cons set-namestack ; inline : n> ( n:namespace -- namespace ) #! Pop the top of the namespace stack. @@ -79,11 +53,11 @@ USE: vectors : (get) ( var ns -- value ) #! Internal word for searching the namestack. dup [ - 2dup car hash* dup [ - nip nip cdr ( found ) + 2dup car hash* [ + nip cdr ( found ) ] [ - drop cdr (get) ( keep looking ) - ] ifte + cdr (get) ( keep looking ) + ] ?ifte ] [ 2drop f ] ifte ; @@ -99,11 +73,7 @@ USE: vectors : 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 dup r> set - ] ifte ; + dup namespace hash [ >r dup r> set ] ?unless ; : change ( var quot -- ) #! Execute the quotation with the variable value on the @@ -130,3 +100,61 @@ USE: vectors : on ( var -- ) t put ; : off ( var -- ) f put ; +: inc ( var -- ) [ 1 + ] change ; +: dec ( var -- ) [ 1 - ] change ; + +: cons@ ( x var -- ) + #! Prepend x to the list stored in var. + [ cons ] change ; + +: unique@ ( elem var -- ) + #! Prepend an element to the proper list stored in a + #! variable if it is not already contained in the list. + [ unique ] change ; + +SYMBOL: list-buffer + +: make-rlist ( quot -- list ) + #! Call a quotation. The quotation can call , to prepend + #! objects to the list that is returned when the quotation + #! is done. + [ list-buffer off call list-buffer get ] with-scope ; + inline + +: make-list ( quot -- list ) + #! Return a list whose entries are in the same order that , + #! was called. + make-rlist reverse ; inline + +: make-string ( quot -- string ) + #! Call a quotation. The quotation can call , to prepend + #! objects to the list that is returned when the quotation + #! is done. + make-list cat ; inline + +: make-rstring ( quot -- string ) + #! Return a string whose entries are in the same order that , + #! was called. + make-rlist cat ; inline + +: make-vector ( quot -- list ) + #! Return a vector whose entries are in the same order that + #! , was called. + make-list list>vector ; inline + +: , ( obj -- ) + #! Append an object to the currently constructing list. + list-buffer cons@ ; + +: unique, ( obj -- ) + #! Append an object to the currently constructing list, only + #! if the object does not already occur in the list. + list-buffer unique@ ; + +: append, ( list -- ) + [ , ] each ; + +: literal, ( word -- ) + #! Append some code that pushes the word on the stack. Used + #! when building quotations. + unit , \ car , ; diff --git a/library/primitives.factor b/library/primitives.factor deleted file mode 100644 index ad52311f9b..0000000000 --- a/library/primitives.factor +++ /dev/null @@ -1,229 +0,0 @@ -! :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: alien -DEFER: alien -DEFER: dll - -USE: alien -USE: compiler -USE: errors -USE: files -USE: generic -USE: io-internals -USE: kernel -USE: kernel-internals -USE: lists -USE: math -USE: math-internals -USE: parser -USE: profiler -USE: random -USE: strings -USE: unparser -USE: vectors -USE: words - -[ - [ execute " word -- " f ] - [ call " quot -- " [ [ general-list ] [ ] ] ] - [ ifte " cond true false -- " [ [ object general-list general-list ] [ ] ] ] - [ cons " car cdr -- [ car | cdr ] " [ [ object object ] [ cons ] ] ] - [ " capacity -- vector" [ [ integer ] [ vector ] ] ] - [ vector-nth " n vector -- obj " [ [ integer vector ] [ object ] ] ] - [ set-vector-nth " obj n vector -- " [ [ object integer vector ] [ ] ] ] - [ str-nth " n str -- ch " [ [ integer string ] [ integer ] ] ] - [ str-compare " str str -- -1/0/1 " [ [ string string ] [ integer ] ] ] - [ str= " str str -- ? " [ [ string string ] [ boolean ] ] ] - [ index-of* " n str/ch str -- n " [ [ integer string text ] [ integer ] ] ] - [ substring " start end str -- str " [ [ integer integer string ] [ string ] ] ] - [ str-reverse " str -- str " [ [ string ] [ string ] ] ] - [ " capacity -- sbuf " [ [ integer ] [ sbuf ] ] ] - [ sbuf-length " sbuf -- n " [ [ sbuf ] [ integer ] ] ] - [ set-sbuf-length " n sbuf -- " [ [ integer sbuf ] [ ] ] ] - [ sbuf-nth " n sbuf -- ch " [ [ integer sbuf ] [ integer ] ] ] - [ set-sbuf-nth " ch n sbuf -- " [ [ integer integer sbuf ] [ ] ] ] - [ sbuf-append " ch/str sbuf -- " [ [ text sbuf ] [ ] ] ] - [ sbuf>str " sbuf -- str " [ [ sbuf ] [ string ] ] ] - [ sbuf-reverse " sbuf -- " [ [ sbuf ] [ ] ] ] - [ sbuf-clone " sbuf -- sbuf " [ [ sbuf ] [ sbuf ] ] ] - [ sbuf= " sbuf sbuf -- ? " [ [ sbuf sbuf ] [ boolean ] ] ] - [ sbuf-hashcode " sbuf -- n " [ [ sbuf ] [ fixnum ] ] ] - [ arithmetic-type " n n -- type " [ [ number number ] [ number number fixnum ] ] ] - [ >fixnum " n -- fixnum " [ [ number ] [ fixnum ] ] ] - [ >bignum " n -- bignum " [ [ number ] [ bignum ] ] ] - [ >float " n -- float " [ [ number ] [ float ] ] ] - [ (fraction>) " a b -- a/b " [ [ integer integer ] [ rational ] ] ] - [ str>float " str -- float " [ [ string ] [ float ] ] ] - [ (unparse-float) " float -- str " [ [ float ] [ string ] ] ] - [ (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 ] ] ] - [ fixnum* " x y -- x*y " [ [ fixnum fixnum ] [ integer ] ] ] - [ fixnum/i " x y -- x/y " [ [ fixnum fixnum ] [ integer ] ] ] - [ fixnum/f " x y -- x/y " [ [ fixnum fixnum ] [ integer ] ] ] - [ fixnum-mod " x y -- x%y " [ [ fixnum fixnum ] [ fixnum ] ] ] - [ fixnum/mod " x y -- x/y x%y " [ [ fixnum fixnum ] [ integer fixnum ] ] ] - [ fixnum-bitand " x y -- x&y " [ [ fixnum fixnum ] [ fixnum ] ] ] - [ fixnum-bitor " x y -- x|y " [ [ fixnum fixnum ] [ fixnum ] ] ] - [ fixnum-bitxor " x y -- x^y " [ [ fixnum fixnum ] [ fixnum ] ] ] - [ fixnum-bitnot " x -- ~x " [ [ fixnum ] [ fixnum ] ] ] - [ fixnum-shift " x n -- x< " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ] - [ fixnum>= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ] - [ bignum= " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ] - [ bignum+ " x y -- x+y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum- " x y -- x-y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum* " x y -- x*y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum/i " x y -- x/y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum/f " x y -- x/y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum-mod " x y -- x%y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum/mod " x y -- x/y x%y " [ [ bignum bignum ] [ bignum bignum ] ] ] - [ bignum-bitand " x y -- x&y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum-bitor " x y -- x|y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum-bitxor " x y -- x^y " [ [ bignum bignum ] [ bignum ] ] ] - [ bignum-bitnot " x -- ~x " [ [ bignum ] [ bignum ] ] ] - [ bignum-shift " x n -- x< " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ] - [ bignum>= " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ] - [ float= " x y -- ? " [ [ bignum bignum ] [ boolean ] ] ] - [ float+ " x y -- x+y " [ [ float float ] [ float ] ] ] - [ float- " x y -- x-y " [ [ float float ] [ float ] ] ] - [ float* " x y -- x*y " [ [ float float ] [ float ] ] ] - [ float/f " x y -- x/y " [ [ float float ] [ float ] ] ] - [ float< " x y -- ? " [ [ float float ] [ boolean ] ] ] - [ float<= " x y -- ? " [ [ float float ] [ boolean ] ] ] - [ float> " x y -- ? " [ [ float float ] [ boolean ] ] ] - [ float>= " x y -- ? " [ [ float float ] [ boolean ] ] ] - [ facos " x -- y " [ [ real ] [ float ] ] ] - [ fasin " x -- y " [ [ real ] [ float ] ] ] - [ fatan " x -- y " [ [ real ] [ float ] ] ] - [ fatan2 " x y -- z " [ [ real real ] [ float ] ] ] - [ fcos " x -- y " [ [ real ] [ float ] ] ] - [ fexp " x -- y " [ [ real ] [ float ] ] ] - [ fcosh " x -- y " [ [ real ] [ float ] ] ] - [ flog " x -- y " [ [ real ] [ float ] ] ] - [ fpow " x y -- z " [ [ real real ] [ float ] ] ] - [ fsin " x -- y " [ [ real ] [ float ] ] ] - [ fsinh " x -- y " [ [ real ] [ float ] ] ] - [ fsqrt " x -- y " [ [ real ] [ float ] ] ] - [ " -- 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 ] ] ] - [ over " x y -- x y x " [ [ object object ] [ object object object ] ] ] - [ pick " x y z -- x y z x " [ [ object object object ] [ object object object object ] ] ] - [ >r " x -- r:x " [ [ object ] [ ] ] ] - [ r> " r:x -- x " [ [ ] [ object ] ] ] - [ eq? " x y -- ? " [ [ object object ] [ boolean ] ] ] - [ getenv " n -- obj " [ [ fixnum ] [ object ] ] ] - [ setenv " obj n -- " [ [ object fixnum ] [ ] ] ] - [ 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 -- " [ [ 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 -- " [ [ port general-list ] [ ] ] ] - [ accept-fd " server -- host port in out " [ [ port ] [ string integer port port ] ] ] - [ can-read-line? " port -- ? " [ [ port ] [ boolean ] ] ] - [ add-read-line-io-task " port callback -- " [ [ port general-list ] [ ] ] ] - [ read-line-fd-8 " port -- sbuf " [ [ port ] [ sbuf ] ] ] - [ can-read-count? " n port -- ? " [ [ integer port ] [ boolean ] ] ] - [ add-read-count-io-task " n port callback -- " [ [ integer port general-list ] [ ] ] ] - [ read-count-fd-8 " n port -- sbuf " [ [ integer port ] [ sbuf ] ] ] - [ can-write? " n port -- ? " [ [ integer port ] [ boolean ] ] ] - [ add-write-io-task " port callback -- " [ [ port general-list ] [ ] ] ] - [ write-fd-8 " ch/str port -- " [ [ text port ] [ ] ] ] - [ add-copy-io-task " from to callback -- " [ [ port port general-list ] [ ] ] ] - [ pending-io-error " -- " [ [ ] [ ] ] ] - [ next-io-task " -- callback " [ [ ] [ general-list ] ] ] - [ room " -- free total free total " [ [ ] [ integer integer integer integer ] ] ] - [ os-env " str -- str " [ [ string ] [ object ] ] ] - [ 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 object ] [ integer ] ] ] - [ dlclose " dll -- " [ [ dll ] [ ] ] ] - [ " ptr -- alien " [ [ integer ] [ 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 ] ] ] - ! Note: a correct type spec for these would have [ X ] as - ! input, not [ object ]. However, we rely on the inferencer - ! to handle these specially, since they are also optimized - ! out in some cases, etc. - [ >cons " cons -- cons " [ [ object ] [ cons ] ] ] - [ >vector " vector -- vector " [ [ object ] [ vector ] ] ] - [ >string " string -- string " [ [ object ] [ 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> - "infer-effect" set-word-property -] each diff --git a/library/random.factor b/library/random.factor index 312c45a75f..616fdf2288 100644 --- a/library/random.factor +++ b/library/random.factor @@ -1,43 +1,14 @@ -! :folding=indent:collapseFolds=0: +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: random USING: kernel lists math ; -! $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: random -USE: kernel -USE: lists -USE: math - -: power-of-2? ( n -- ? ) - dup dup neg bitand = ; +: power-of-2? ( n -- ? ) dup dup neg bitand = ; : (random-int-0) ( n bits val -- n ) 3dup - + 1 < [ 2drop (random-int) 2dup swap mod (random-int-0) ] [ - nip nip + 2nip ] ifte ; : random-int-0 ( max -- n ) @@ -47,11 +18,6 @@ USE: math (random-int) 2dup swap mod (random-int-0) ] ifte ; -: random-int ( min max -- n ) - dupd swap - random-int-0 + ; - -: random-boolean ( -- ? ) - 0 1 random-int 0 = ; - -: random-digit ( -- digit ) - 0 9 random-int ; +: random-int ( min max -- n ) dupd swap - random-int-0 + ; +: random-boolean ( -- ? ) 0 1 random-int 0 = ; +: random-digit ( -- digit ) 0 9 random-int ; diff --git a/library/sbuf.factor b/library/sbuf.factor index c56f4c506d..a21fcd2566 100644 --- a/library/sbuf.factor +++ b/library/sbuf.factor @@ -1,47 +1,6 @@ -! :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: strings -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings - -: make-string ( quot -- string ) - #! Call a quotation. The quotation can call , to prepend - #! objects to the list that is returned when the quotation - #! is done. - make-list cat ; inline - -: make-rstring ( quot -- string ) - #! Return a string whose entries are in the same order that , - #! was called. - make-rlist cat ; inline +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: strings USING: kernel lists math namespaces strings ; : fill ( count char -- string ) #! Push a string that consists of the same character @@ -95,3 +54,6 @@ USE: strings : split-n ( n str -- list ) #! Split a string into n-character chunks. [ 0 -rot (split-n) ] make-list ; + +: ch>str ( ch -- str ) + 1 [ sbuf-append ] keep sbuf>str ; diff --git a/library/sdl/console.factor b/library/sdl/console.factor deleted file mode 100644 index 66664500c0..0000000000 --- a/library/sdl/console.factor +++ /dev/null @@ -1,277 +0,0 @@ -! A graphical console. -! -! To run this code, bootstrap Factor like so: -! -! ./f boot.image.le32 -! -libraries:sdl:name=libSDL.so -! -libraries:sdl-gfx:name=libSDL_gfx. -! -! (But all on one line) -! -! Then, start Factor as usual (./f factor.image) and enter this -! at the listener: -! -! USE: console -! start-console - -IN: console -USE: generic -USE: vectors -USE: sdl -USE: sdl-event -USE: sdl-gfx -USE: sdl-video -USE: namespaces -USE: math -USE: kernel -USE: strings -USE: alien -USE: sdl-keysym -USE: sdl-keyboard -USE: streams -USE: prettyprint -USE: listener -USE: threads -USE: stdio -USE: errors - -#! A namespace holding console state. -SYMBOL: console -#! A vector. New lines are pushed on the end. -SYMBOL: lines -#! An integer. Line at top of screen. -SYMBOL: first-line -#! Current X co-ordinate. -SYMBOL: x -#! Current Y co-ordinate. -SYMBOL: y -#! A string buffer. -SYMBOL: output-line -#! A string buffer. -SYMBOL: line-editor - -! Rendering -: background HEX: 0000dbff ; -: foreground HEX: 6d92ffff ; -: cursor HEX: ffff24ff ; - -#! The font size is hardcoded here. -: line-height 8 ; -: char-width 8 ; - -: next-line ( -- ) - 0 x set line-height y [ + ] change ; - -: draw-line ( str -- ) - [ surface get x get y get ] keep foreground stringColor - str-length char-width * x [ + ] change ; - -: clear-display ( -- ) - surface get 0 0 width get height get background boxColor ; - -: visible-lines ( -- n ) - height get line-height /i ; - -: available-lines ( -- ) - lines get vector-length first-line get - ; - -: draw-lines ( -- ) - visible-lines available-lines min [ - first-line get + - lines get vector-nth draw-line - next-line - ] times* ; - -: draw-cursor ( -- ) - surface get - x get - y get - x get char-width + - y get line-height + - cursor boxColor ; - -: draw-current ( -- ) - output-line get sbuf>str draw-line ; - -: draw-input ( -- ) - line-editor get sbuf>str draw-line draw-cursor ; - -: draw-console ( -- ) - [ - 0 x set - 0 y set - clear-display - draw-lines - draw-current - draw-input - ] with-surface ; - -: empty-buffer ( sbuf -- str ) - dup sbuf>str 0 rot set-sbuf-length ; - -: add-line ( text -- ) - lines get vector-push - lines get vector-length 1 + first-line get - visible-lines - - dup 0 >= [ - first-line [ + ] change - ] [ - drop - ] ifte ; - -: console-write ( text -- ) - "\n" split1 [ - swap output-line get sbuf-append - output-line get empty-buffer add-line - ] when* - output-line get sbuf-append ; - -! The console stream - -! Restoring this continuation returns to the -! top-level console event loop. -SYMBOL: redraw-continuation - -! Restoring this continuation with a string on the stack returns -! to the caller of freadln. -SYMBOL: input-continuation - -TRAITS: console-stream - -C: console-stream ( console console-continuation -- stream ) - [ - redraw-continuation set - console set - ] extend ; - -M: console-stream fflush ( stream -- ) - fauto-flush ; - -M: console-stream fauto-flush ( stream -- ) - [ - console get [ draw-console ] bind - ] bind ; - -M: console-stream freadln ( stream -- line ) - [ - [ - console get [ input-continuation set ] bind - redraw-continuation get dup [ - call - ] [ - drop f - ] ifte - ] callcc1 - ] bind ; - -M: console-stream fwrite-attr ( string style stream -- ) - [ - drop - console get [ console-write ] bind - ] bind ; - -M: console-stream fclose ( stream -- ) drop ; - -! Event handling -SYMBOL: event - -GENERIC: key-down ( key -- ) - -PREDICATE: integer null-key - dup 0 = swap 255 > or ; - -M: null-key key-down ( key -- ) - drop ; - -PREDICATE: integer return-key - SDLK_RETURN = ; - -M: return-key key-down ( key -- ) - drop - line-editor get empty-buffer - dup console-write "\n" console-write - input-continuation get call ; - -PREDICATE: integer backspace-key - SDLK_BACKSPACE = ; - -M: backspace-key key-down ( key -- ) - line-editor get dup sbuf-length 0 = [ - drop - ] [ - [ sbuf-length 1 - ] keep set-sbuf-length - ] ifte ; - -M: integer key-down ( key -- ) - line-editor get sbuf-append ; - -GENERIC: handle-event ( event -- ? ) - -PREDICATE: alien key-down-event - keyboard-event-type SDL_KEYDOWN = ; - -M: key-down-event handle-event ( event -- ? ) - keyboard-event-unicode key-down draw-console t ; - -PREDICATE: alien quit-event - quit-event-type SDL_QUIT = ; - -M: quit-event handle-event ( event -- ? ) - drop f ; - -M: alien handle-event ( event -- ? ) - drop t ; - -: check-event ( -- ? ) - #! Check if there is a pending event. - #! Return if we should continue or stop. - event get dup SDL_PollEvent [ - handle-event [ check-event ] [ f ] ifte - ] [ - drop t - ] ifte ; - -: init-console ( -- ) - event set - 0 first-line set - 80 lines set - 80 line-editor set - 80 output-line set - 1 SDL_EnableUNICODE drop - SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL - SDL_EnableKeyRepeat drop ; - -: console-loop ( -- ) - check-event [ console-loop ] when ; - -: console-quit ( -- ) - redraw-continuation off - input-continuation get [ f swap call ] when* - SDL_Quit ; - -SYMBOL: escape-continuation - -IN: shells - -: sdl ( -- ) - [ - 800 600 32 SDL_HWSURFACE init-screen - init-console - ] extend console set - - [ - escape-continuation set - - [ - console get swap - [ print-banner listener ] with-stream - SDL_Quit - ( return from start-console word ) - escape-continuation get call - ] callcc0 - - console get [ - draw-console - console-loop - console-quit - ] bind - ] callcc0 ; diff --git a/library/sdl/sdl-event.factor b/library/sdl/sdl-event.factor index 3781d023fa..a51c4613d4 100644 --- a/library/sdl/sdl-event.factor +++ b/library/sdl/sdl-event.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -27,6 +27,8 @@ IN: sdl-event USE: alien +USE: generic +USE: kernel BEGIN-ENUM: 0 ENUM: SDL_NOEVENT ! Unused (do not remove) @@ -100,6 +102,12 @@ BEGIN-STRUCT: keyboard-event FIELD: ushort unicode END-STRUCT +PREDICATE: alien key-down-event + keyboard-event-type SDL_KEYDOWN = ; + +PREDICATE: alien key-up-event + keyboard-event-type SDL_KEYUP = ; + BEGIN-STRUCT: motion-event FIELD: uchar type ! SDL_MOUSEMOTION FIELD: uchar which ! The mouse device index @@ -108,7 +116,10 @@ BEGIN-STRUCT: motion-event FIELD: ushort y FIELD: short xrel ! The relative motion in the X direction FIELD: short yrel ! The relative motion in the Y direction -END-STRUCT +END-STRUCT + +PREDICATE: alien motion-event + motion-event-type SDL_MOUSEMOTION = ; BEGIN-STRUCT: button-event FIELD: uchar type ! SDL_MOUSEBUTTONDOWN or SDL_MOUSEBUTTONUP @@ -119,6 +130,12 @@ BEGIN-STRUCT: button-event FIELD: ushort y ! The X/Y coordinates of the mouse at press time END-STRUCT +PREDICATE: alien button-down-event + button-event-type SDL_MOUSEBUTTONDOWN = ; + +PREDICATE: alien button-up-event + button-event-type SDL_MOUSEBUTTONUP = ; + BEGIN-STRUCT: joy-axis-event FIELD: uchar type ! SDL_JOYAXISMOTION FIELD: uchar which ! The joystick device index @@ -126,6 +143,9 @@ BEGIN-STRUCT: joy-axis-event FIELD: short value ! The axis value END-STRUCT +PREDICATE: alien joy-axis-event + joy-axis-event-type SDL_JOYAXISMOTION = ; + BEGIN-STRUCT: joy-ball-event FIELD: uchar type ! SDL_JOYBALLMOTION FIELD: uchar which ! The joystick device index @@ -134,6 +154,9 @@ BEGIN-STRUCT: joy-ball-event FIELD: short yrel ! The relative motion in the Y direction END-STRUCT +PREDICATE: alien joy-ball-event + joy-ball-event-type SDL_JOYBALLMOTION = ; + BEGIN-STRUCT: joy-hat-event FIELD: uchar type ! SDL_JOYHATMOTION FIELD: uchar which ! The joystick device index @@ -145,6 +168,9 @@ BEGIN-STRUCT: joy-hat-event ! Note that zero means the POV is centered. END-STRUCT +PREDICATE: alien joy-hat-event + joy-hat-event-type SDL_JOYHATMOTION = ; + BEGIN-STRUCT: joy-button-event FIELD: uchar type ! SDL_JOYBUTTONDOWN or SDL_JOYBUTTONUP FIELD: uchar which ! The joystick device index @@ -152,6 +178,12 @@ BEGIN-STRUCT: joy-button-event FIELD: uchar state ! SDL_PRESSED or SDL_RELEASED END-STRUCT +PREDICATE: alien joy-button-down-event + joy-button-event-type SDL_JOYBUTTONDOWN = ; + +PREDICATE: alien joy-button-up-event + joy-button-event-type SDL_JOYBUTTONUP = ; + BEGIN-STRUCT: resize-event FIELD: uchar type ! SDL_VIDEORESIZE FIELD: int w ! New width @@ -162,10 +194,16 @@ BEGIN-STRUCT: expose-event FIELD: uchar type ! SDL_VIDEOEXPOSE END-STRUCT +PREDICATE: alien resize-event + resize-event-type SDL_VIDEORESIZE = ; + BEGIN-STRUCT: quit-event FIELD: uchar type ! SDL_QUIT END-STRUCT +PREDICATE: alien quit-event + quit-event-type SDL_QUIT = ; + BEGIN-STRUCT: user-event FIELD: uchar type ! SDL_USREVENT through SDL_NUMEVENTS-1 FIELD: int code @@ -173,6 +211,9 @@ BEGIN-STRUCT: user-event FIELD: void* data2 END-STRUCT +PREDICATE: alien user-event + user-event-type SDL_QUIT = ; + BEGIN-STRUCT: event FIELD: uchar type END-STRUCT @@ -193,8 +234,8 @@ BEGIN-UNION: event MEMBER: user-event END-UNION -: SDL_WaitEvent ( event -- ) - "int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ; +: SDL_WaitEvent ( event -- ? ) + "bool" "sdl" "SDL_WaitEvent" [ "event*" ] alien-invoke ; : SDL_PollEvent ( event -- ? ) "bool" "sdl" "SDL_PollEvent" [ "event*" ] alien-invoke ; diff --git a/library/sdl/sdl-keyboard.factor b/library/sdl/sdl-keyboard.factor index 8efc1bcf53..6de8f49c2f 100644 --- a/library/sdl/sdl-keyboard.factor +++ b/library/sdl/sdl-keyboard.factor @@ -1,32 +1,8 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: sdl-keyboard -USE: alien +USING: alien lists sdl-keysym namespaces sdl-event kernel +math hashtables ; : SDL_EnableUNICODE ( enable -- ) "int" "sdl" "SDL_EnableUNICODE" [ "int" ] alien-invoke ; @@ -36,3 +12,23 @@ USE: alien : SDL_EnableKeyRepeat ( delay interval -- ) "int" "sdl" "SDL_EnableKeyRepeat" [ "int" "int" ] alien-invoke ; + +: modifiers, ( mod -- ) + modifiers get [ + uncons pick bitand 0 = [ drop ] [ unique, ] ifte + ] each + drop ; + +: keysym, ( sym -- ) + #! Return the original keysym number if its unknown. + [ keysyms get hash dup ] keep ? , ; + +: keyboard-event>binding ( event -- binding ) + #! Turn a key event into a binding, which is a list where + #! all elements but the last one are modifier names looked + #! up the modifiers alist, and the last element is a keysym + #! look up in the keysyms hash. + [ + dup keyboard-event-mod modifiers, + keyboard-event-sym keysym, + ] make-list ; diff --git a/library/sdl/sdl-keysym.factor b/library/sdl/sdl-keysym.factor index 26bdd269fc..d66063fd48 100644 --- a/library/sdl/sdl-keysym.factor +++ b/library/sdl/sdl-keysym.factor @@ -25,258 +25,272 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE ; EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: sdl-keysym +IN: sdl-keyboard +USE: namespaces -! The keyboard syms have been cleverly chosen to map to ASCII -: SDLK_UNKNOWN 0 ; -: SDLK_FIRST 0 ; -: SDLK_BACKSPACE 8 ; -: SDLK_TAB 9 ; -: SDLK_CLEAR 12 ; -: SDLK_RETURN 13 ; -: SDLK_PAUSE 19 ; -: SDLK_ESCAPE 27 ; -: SDLK_SPACE 32 ; -: SDLK_EXCLAIM 33 ; -: SDLK_QUOTEDBL 34 ; -: SDLK_HASH 35 ; -: SDLK_DOLLAR 36 ; -: SDLK_AMPERSAND 38 ; -: SDLK_QUOTE 39 ; -: SDLK_LEFTPAREN 40 ; -: SDLK_RIGHTPAREN 41 ; -: SDLK_ASTERISK 42 ; -: SDLK_PLUS 43 ; -: SDLK_COMMA 44 ; -: SDLK_MINUS 45 ; -: SDLK_PERIOD 46 ; -: SDLK_SLASH 47 ; -: SDLK_0 48 ; -: SDLK_1 49 ; -: SDLK_2 50 ; -: SDLK_3 51 ; -: SDLK_4 52 ; -: SDLK_5 53 ; -: SDLK_6 54 ; -: SDLK_7 55 ; -: SDLK_8 56 ; -: SDLK_9 57 ; -: SDLK_COLON 58 ; -: SDLK_SEMICOLON 59 ; -: SDLK_LESS 60 ; -: SDLK_EQUALS 61 ; -: SDLK_GREATER 62 ; -: SDLK_QUESTION 63 ; -: SDLK_AT 64 ; +! Here we smash left/right control/shift/alt for convinience. +! Later, something better needs to be done. -! Skip uppercase letters -: SDLK_LEFTBRACKET 91 ; -: SDLK_BACKSLASH 92 ; -: SDLK_RIGHTBRACKET 93 ; -: SDLK_CARET 94 ; -: SDLK_UNDERSCORE 95 ; -: SDLK_BACKQUOTE 96 ; -: SDLK_a 97 ; -: SDLK_b 98 ; -: SDLK_c 99 ; -: SDLK_d 100 ; -: SDLK_e 101 ; -: SDLK_f 102 ; -: SDLK_g 103 ; -: SDLK_h 104 ; -: SDLK_i 105 ; -: SDLK_j 106 ; -: SDLK_k 107 ; -: SDLK_l 108 ; -: SDLK_m 109 ; -: SDLK_n 110 ; -: SDLK_o 111 ; -: SDLK_p 112 ; -: SDLK_q 113 ; -: SDLK_r 114 ; -: SDLK_s 115 ; -: SDLK_t 116 ; -: SDLK_u 117 ; -: SDLK_v 118 ; -: SDLK_w 119 ; -: SDLK_x 120 ; -: SDLK_y 121 ; -: SDLK_z 122 ; -: SDLK_DELETE 127 ; +SYMBOL: modifiers -! End of ASCII mapped keysyms +[ + [[ "SHIFT" HEX: 0001 ]] + [[ "SHIFT" HEX: 0002 ]] + [[ "CTRL" HEX: 0040 ]] + [[ "CTRL" HEX: 0080 ]] + [[ "ALT" HEX: 0100 ]] + [[ "ALT" HEX: 0200 ]] + [[ "META" HEX: 0400 ]] + [[ "META" HEX: 0800 ]] + [[ "NUM" HEX: 1000 ]] + [[ "CAPS" HEX: 2000 ]] + [[ "MODE" HEX: 4000 ]] +] modifiers set -! International keyboard syms +SYMBOL: keysyms -: SDLK_WORLD_0 160 ; ! 0xA0 -: SDLK_WORLD_1 161 ; -: SDLK_WORLD_2 162 ; -: SDLK_WORLD_3 163 ; -: SDLK_WORLD_4 164 ; -: SDLK_WORLD_5 165 ; -: SDLK_WORLD_6 166 ; -: SDLK_WORLD_7 167 ; -: SDLK_WORLD_8 168 ; -: SDLK_WORLD_9 169 ; -: SDLK_WORLD_10 170 ; -: SDLK_WORLD_11 171 ; -: SDLK_WORLD_12 172 ; -: SDLK_WORLD_13 173 ; -: SDLK_WORLD_14 174 ; -: SDLK_WORLD_15 175 ; -: SDLK_WORLD_16 176 ; -: SDLK_WORLD_17 177 ; -: SDLK_WORLD_18 178 ; -: SDLK_WORLD_19 179 ; -: SDLK_WORLD_20 180 ; -: SDLK_WORLD_21 181 ; -: SDLK_WORLD_22 182 ; -: SDLK_WORLD_23 183 ; -: SDLK_WORLD_24 184 ; -: SDLK_WORLD_25 185 ; -: SDLK_WORLD_26 186 ; -: SDLK_WORLD_27 187 ; -: SDLK_WORLD_28 188 ; -: SDLK_WORLD_29 189 ; -: SDLK_WORLD_30 190 ; -: SDLK_WORLD_31 191 ; -: SDLK_WORLD_32 192 ; -: SDLK_WORLD_33 193 ; -: SDLK_WORLD_34 194 ; -: SDLK_WORLD_35 195 ; -: SDLK_WORLD_36 196 ; -: SDLK_WORLD_37 197 ; -: SDLK_WORLD_38 198 ; -: SDLK_WORLD_39 199 ; -: SDLK_WORLD_40 200 ; -: SDLK_WORLD_41 201 ; -: SDLK_WORLD_42 202 ; -: SDLK_WORLD_43 203 ; -: SDLK_WORLD_44 204 ; -: SDLK_WORLD_45 205 ; -: SDLK_WORLD_46 206 ; -: SDLK_WORLD_47 207 ; -: SDLK_WORLD_48 208 ; -: SDLK_WORLD_49 209 ; -: SDLK_WORLD_50 210 ; -: SDLK_WORLD_51 211 ; -: SDLK_WORLD_52 212 ; -: SDLK_WORLD_53 213 ; -: SDLK_WORLD_54 214 ; -: SDLK_WORLD_55 215 ; -: SDLK_WORLD_56 216 ; -: SDLK_WORLD_57 217 ; -: SDLK_WORLD_58 218 ; -: SDLK_WORLD_59 219 ; -: SDLK_WORLD_60 220 ; -: SDLK_WORLD_61 221 ; -: SDLK_WORLD_62 222 ; -: SDLK_WORLD_63 223 ; -: SDLK_WORLD_64 224 ; -: SDLK_WORLD_65 225 ; -: SDLK_WORLD_66 226 ; -: SDLK_WORLD_67 227 ; -: SDLK_WORLD_68 228 ; -: SDLK_WORLD_69 229 ; -: SDLK_WORLD_70 230 ; -: SDLK_WORLD_71 231 ; -: SDLK_WORLD_72 232 ; -: SDLK_WORLD_73 233 ; -: SDLK_WORLD_74 234 ; -: SDLK_WORLD_75 235 ; -: SDLK_WORLD_76 236 ; -: SDLK_WORLD_77 237 ; -: SDLK_WORLD_78 238 ; -: SDLK_WORLD_79 239 ; -: SDLK_WORLD_80 240 ; -: SDLK_WORLD_81 241 ; -: SDLK_WORLD_82 242 ; -: SDLK_WORLD_83 243 ; -: SDLK_WORLD_84 244 ; -: SDLK_WORLD_85 245 ; -: SDLK_WORLD_86 246 ; -: SDLK_WORLD_87 247 ; -: SDLK_WORLD_88 248 ; -: SDLK_WORLD_89 249 ; -: SDLK_WORLD_90 250 ; -: SDLK_WORLD_91 251 ; -: SDLK_WORLD_92 252 ; -: SDLK_WORLD_93 253 ; -: SDLK_WORLD_94 254 ; -: SDLK_WORLD_95 255 ; ! 0xFF - -! Numeric keypad -: SDLK_KP0 256 ; -: SDLK_KP1 257 ; -: SDLK_KP2 258 ; -: SDLK_KP3 259 ; -: SDLK_KP4 260 ; -: SDLK_KP5 261 ; -: SDLK_KP6 262 ; -: SDLK_KP7 263 ; -: SDLK_KP8 264 ; -: SDLK_KP9 265 ; -: SDLK_KP_PERIOD 266 ; -: SDLK_KP_DIVIDE 267 ; -: SDLK_KP_MULTIPLY 268 ; -: SDLK_KP_MINUS 269 ; -: SDLK_KP_PLUS 270 ; -: SDLK_KP_ENTER 271 ; -: SDLK_KP_EQUALS 272 ; - -! Arrows + Home/End pad -: SDLK_UP 273 ; -: SDLK_DOWN 274 ; -: SDLK_RIGHT 275 ; -: SDLK_LEFT 276 ; -: SDLK_INSERT 277 ; -: SDLK_HOME 278 ; -: SDLK_END 279 ; -: SDLK_PAGEUP 280 ; -: SDLK_PAGEDOWN 281 ; - -! Function keys -: SDLK_F1 282 ; -: SDLK_F2 283 ; -: SDLK_F3 284 ; -: SDLK_F4 285 ; -: SDLK_F5 286 ; -: SDLK_F6 287 ; -: SDLK_F7 288 ; -: SDLK_F8 289 ; -: SDLK_F9 290 ; -: SDLK_F10 291 ; -: SDLK_F11 292 ; -: SDLK_F12 293 ; -: SDLK_F13 294 ; -: SDLK_F14 295 ; -: SDLK_F15 296 ; - -! Key state modifier keys -: SDLK_NUMLOCK 300 ; -: SDLK_CAPSLOCK 301 ; -: SDLK_SCROLLOCK 302 ; -: SDLK_RSHIFT 303 ; -: SDLK_LSHIFT 304 ; -: SDLK_RCTRL 305 ; -: SDLK_LCTRL 306 ; -: SDLK_RALT 307 ; -: SDLK_LALT 308 ; -: SDLK_RMETA 309 ; -: SDLK_LMETA 310 ; -: SDLK_LSUPER 311 ; ! Left "Windows" key -: SDLK_RSUPER 312 ; ! Right "Windows" key -: SDLK_MODE 313 ; ! "Alt Gr" key -: SDLK_COMPOSE 314 ; ! Multi-key compose key - -! Miscellaneous function keys -: SDLK_HELP 315 ; -: SDLK_PRINT 316 ; -: SDLK_SYSREQ 317 ; -: SDLK_BREAK 318 ; -: SDLK_MENU 319 ; -: SDLK_POWER 320 ; ! Power Macintosh power key -: SDLK_EURO 321 ; ! Some european keyboards -: SDLK_UNDO 322 ; ! Atari keyboard has Undo - -! Add any other keys here +{{ + ! The keyboard syms have been cleverly chosen to map to ASCII + [[ 0 "UNKNOWN" ]] +! [[ 0 "FIRST" ]] + [[ 8 "BACKSPACE" ]] + [[ 9 "TAB" ]] + [[ 12 "CLEAR" ]] + [[ 13 "RETURN" ]] + [[ 19 "PAUSE" ]] + [[ 27 "ESCAPE" ]] + [[ 32 "SPACE" ]] + [[ 33 "EXCLAIM" ]] + [[ 34 "QUOTEDBL" ]] + [[ 35 "HASH" ]] + [[ 36 "DOLLAR" ]] + [[ 38 "AMPERSAND" ]] + [[ 39 "QUOTE" ]] + [[ 40 "LEFTPAREN" ]] + [[ 41 "RIGHTPAREN" ]] + [[ 42 "ASTERISK" ]] + [[ 43 "PLUS" ]] + [[ 44 "COMMA" ]] + [[ 45 "MINUS" ]] + [[ 46 "PERIOD" ]] + [[ 47 "SLASH" ]] + [[ 48 0 ]] + [[ 49 1 ]] + [[ 50 2 ]] + [[ 51 3 ]] + [[ 52 4 ]] + [[ 53 5 ]] + [[ 54 6 ]] + [[ 55 7 ]] + [[ 56 8 ]] + [[ 57 9 ]] + [[ 58 "COLON" ]] + [[ 59 "SEMICOLON" ]] + [[ 60 "LESS" ]] + [[ 61 "EQUALS" ]] + [[ 62 "GREATER" ]] + [[ 63 "QUESTION" ]] + [[ 64 "AT" ]] + ! Skip uppercase letters + [[ 91 "LEFTBRACKET" ]] + [[ 92 "BACKSLASH" ]] + [[ 93 "RIGHTBRACKET" ]] + [[ 94 "CARET" ]] + [[ 95 "UNDERSCORE" ]] + [[ 96 "BACKQUOTE" ]] + [[ 97 "a" ]] + [[ 98 "b" ]] + [[ 99 "c" ]] + [[ 100 "d" ]] + [[ 101 "e" ]] + [[ 102 "f" ]] + [[ 103 "g" ]] + [[ 104 "h" ]] + [[ 105 "i" ]] + [[ 106 "j" ]] + [[ 107 "k" ]] + [[ 108 "l" ]] + [[ 109 "m" ]] + [[ 110 "n" ]] + [[ 111 "o" ]] + [[ 112 "p" ]] + [[ 113 "q" ]] + [[ 114 "r" ]] + [[ 115 "s" ]] + [[ 116 "t" ]] + [[ 117 "u" ]] + [[ 118 "v" ]] + [[ 119 "w" ]] + [[ 120 "x" ]] + [[ 121 "y" ]] + [[ 122 "z" ]] + [[ 127 "DELETE" ]] + ! End of ASCII mapped keysyms + ! International keyboard syms + [[ 160 "WORLD_0" ]] ! 0xA0 + [[ 161 "WORLD_1" ]] + [[ 162 "WORLD_2" ]] + [[ 163 "WORLD_3" ]] + [[ 164 "WORLD_4" ]] + [[ 165 "WORLD_5" ]] + [[ 166 "WORLD_6" ]] + [[ 167 "WORLD_7" ]] + [[ 168 "WORLD_8" ]] + [[ 169 "WORLD_9" ]] + [[ 170 "WORLD_10" ]] + [[ 171 "WORLD_11" ]] + [[ 172 "WORLD_12" ]] + [[ 173 "WORLD_13" ]] + [[ 174 "WORLD_14" ]] + [[ 175 "WORLD_15" ]] + [[ 176 "WORLD_16" ]] + [[ 177 "WORLD_17" ]] + [[ 178 "WORLD_18" ]] + [[ 179 "WORLD_19" ]] + [[ 180 "WORLD_20" ]] + [[ 181 "WORLD_21" ]] + [[ 182 "WORLD_22" ]] + [[ 183 "WORLD_23" ]] + [[ 184 "WORLD_24" ]] + [[ 185 "WORLD_25" ]] + [[ 186 "WORLD_26" ]] + [[ 187 "WORLD_27" ]] + [[ 188 "WORLD_28" ]] + [[ 189 "WORLD_29" ]] + [[ 190 "WORLD_30" ]] + [[ 191 "WORLD_31" ]] + [[ 192 "WORLD_32" ]] + [[ 193 "WORLD_33" ]] + [[ 194 "WORLD_34" ]] + [[ 195 "WORLD_35" ]] + [[ 196 "WORLD_36" ]] + [[ 197 "WORLD_37" ]] + [[ 198 "WORLD_38" ]] + [[ 199 "WORLD_39" ]] + [[ 200 "WORLD_40" ]] + [[ 201 "WORLD_41" ]] + [[ 202 "WORLD_42" ]] + [[ 203 "WORLD_43" ]] + [[ 204 "WORLD_44" ]] + [[ 205 "WORLD_45" ]] + [[ 206 "WORLD_46" ]] + [[ 207 "WORLD_47" ]] + [[ 208 "WORLD_48" ]] + [[ 209 "WORLD_49" ]] + [[ 210 "WORLD_50" ]] + [[ 211 "WORLD_51" ]] + [[ 212 "WORLD_52" ]] + [[ 213 "WORLD_53" ]] + [[ 214 "WORLD_54" ]] + [[ 215 "WORLD_55" ]] + [[ 216 "WORLD_56" ]] + [[ 217 "WORLD_57" ]] + [[ 218 "WORLD_58" ]] + [[ 219 "WORLD_59" ]] + [[ 220 "WORLD_60" ]] + [[ 221 "WORLD_61" ]] + [[ 222 "WORLD_62" ]] + [[ 223 "WORLD_63" ]] + [[ 224 "WORLD_64" ]] + [[ 225 "WORLD_65" ]] + [[ 226 "WORLD_66" ]] + [[ 227 "WORLD_67" ]] + [[ 228 "WORLD_68" ]] + [[ 229 "WORLD_69" ]] + [[ 230 "WORLD_70" ]] + [[ 231 "WORLD_71" ]] + [[ 232 "WORLD_72" ]] + [[ 233 "WORLD_73" ]] + [[ 234 "WORLD_74" ]] + [[ 235 "WORLD_75" ]] + [[ 236 "WORLD_76" ]] + [[ 237 "WORLD_77" ]] + [[ 238 "WORLD_78" ]] + [[ 239 "WORLD_79" ]] + [[ 240 "WORLD_80" ]] + [[ 241 "WORLD_81" ]] + [[ 242 "WORLD_82" ]] + [[ 243 "WORLD_83" ]] + [[ 244 "WORLD_84" ]] + [[ 245 "WORLD_85" ]] + [[ 246 "WORLD_86" ]] + [[ 247 "WORLD_87" ]] + [[ 248 "WORLD_88" ]] + [[ 249 "WORLD_89" ]] + [[ 250 "WORLD_90" ]] + [[ 251 "WORLD_91" ]] + [[ 252 "WORLD_92" ]] + [[ 253 "WORLD_93" ]] + [[ 254 "WORLD_94" ]] + [[ 255 "WORLD_95" ]] ! 0xFF + ! Numeric keypad + [[ 256 "KP0" ]] + [[ 257 "KP1" ]] + [[ 258 "KP2" ]] + [[ 259 "KP3" ]] + [[ 260 "KP4" ]] + [[ 261 "KP5" ]] + [[ 262 "KP6" ]] + [[ 263 "KP7" ]] + [[ 264 "KP8" ]] + [[ 265 "KP9" ]] + [[ 266 "KP_PERIOD" ]] + [[ 267 "KP_DIVIDE" ]] + [[ 268 "KP_MULTIPLY" ]] + [[ 269 "KP_MINUS" ]] + [[ 270 "KP_PLUS" ]] + [[ 271 "KP_ENTER" ]] + [[ 272 "KP_EQUALS" ]] + ! Arrows + Home/End pad + [[ 273 "UP" ]] + [[ 274 "DOWN" ]] + [[ 275 "RIGHT" ]] + [[ 276 "LEFT" ]] + [[ 277 "INSERT" ]] + [[ 278 "HOME" ]] + [[ 279 "END" ]] + [[ 280 "PAGEUP" ]] + [[ 281 "PAGEDOWN" ]] + ! Function keys + [[ 282 "F1" ]] + [[ 283 "F2" ]] + [[ 284 "F3" ]] + [[ 285 "F4" ]] + [[ 286 "F5" ]] + [[ 287 "F6" ]] + [[ 288 "F7" ]] + [[ 289 "F8" ]] + [[ 290 "F9" ]] + [[ 291 "F10" ]] + [[ 292 "F11" ]] + [[ 293 "F12" ]] + [[ 294 "F13" ]] + [[ 295 "F14" ]] + [[ 296 "F15" ]] + ! Key state modifier keys + [[ 300 "NUMLOCK" ]] + [[ 301 "CAPSLOCK" ]] + [[ 302 "SCROLLOCK" ]] + [[ 303 "RSHIFT" ]] + [[ 304 "LSHIFT" ]] + [[ 305 "RCTRL" ]] + [[ 306 "LCTRL" ]] + [[ 307 "RALT" ]] + [[ 308 "LALT" ]] + [[ 309 "RMETA" ]] + [[ 310 "LMETA" ]] + [[ 311 "LSUPER" ]] ! Left "Windows" key + [[ 312 "RSUPER" ]] ! Right "Windows" key + [[ 313 "MODE" ]] ! "Alt Gr" key + [[ 314 "COMPOSE" ]] ! Multi-key compose key + ! Miscellaneous function keys + [[ 315 "HELP" ]] + [[ 316 "PRINT" ]] + [[ 317 "SYSREQ" ]] + [[ 318 "BREAK" ]] + [[ 319 "MENU" ]] + [[ 320 "POWER" ]] ! Power Macintosh power key + [[ 321 "EURO" ]] ! Some european keyboards + [[ 322 "UNDO" ]] ! Atari keyboard has Undo + ! Add any other keys here +}} keysyms set diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor new file mode 100644 index 0000000000..6c2590247d --- /dev/null +++ b/library/sdl/sdl-ttf.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: sdl-ttf +USE: alien + +: UNICODE_BOM_NATIVE HEX: FEFF ; +: UNICODE_BOM_SWAPPED HEX: FFFE ; + +: TTF_ByteSwappedUNICODE ( swapped -- ) + "void" "sdl-ttf" "TTF_ByteSwappedUNICODE" [ "int" ] alien-invoke ; + +: TTF_Init ( swapped -- ) + "void" "sdl-ttf" "TTF_Init" [ ] alien-invoke ; + +: TTF_OpenFont ( file ptsize -- font ) + "void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" ] alien-invoke ; + +: TTF_OpenFontIndex ( file ptsize index -- font ) + "void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" "long" ] alien-invoke ; + +: TTF_STYLE_NORMAL HEX: 00 ; +: TTF_STYLE_BOLD HEX: 01 ; +: TTF_STYLE_ITALIC HEX: 02 ; +: TTF_STYLE_UNDERLINE HEX: 04 ; + +: TTF_GetFontStyle ( font -- style ) + "int" "sdl-ttf" "TTF_GetFontStyle" [ "void*" ] alien-invoke ; + +: TTF_SetFontStyle ( font style -- ) + "void" "sdl-ttf" "TTF_SetFontStyle" [ "void*" "int" ] alien-invoke ; + +: TTF_FontHeight ( font -- n ) + "int" "sdl-ttf" "TTF_FontHeight" [ "void*" ] alien-invoke ; + +: TTF_FontAscent ( font -- n ) + "int" "sdl-ttf" "TTF_FontAscent" [ "void*" ] alien-invoke ; + +: TTF_FontDescent ( font -- n ) + "int" "sdl-ttf" "TTF_FontDescent" [ "void*" ] alien-invoke ; + +: TTF_FontLineSkip ( font -- n ) + "int" "sdl-ttf" "TTF_FontLineSkip" [ "void*" ] alien-invoke ; + +: TTF_FontFaces ( font -- n ) + "long" "sdl-ttf" "TTF_FontFaces" [ "void*" ] alien-invoke ; + +: TTF_FontFaceIsFixedWidth ( font -- ? ) + "bool" "sdl-ttf" "TTF_FontFaceIsFixedWidth" [ "void*" ] alien-invoke ; + +: TTF_FontFaceFamilyName ( font -- n ) + "char*" "sdl-ttf" "TTF_FontFaceFamilyName" [ "void*" ] alien-invoke ; + +: TTF_FontFaceStyleName ( font -- n ) + "char*" "sdl-ttf" "TTF_FontFaceStyleName" [ "void*" ] alien-invoke ; + +BEGIN-STRUCT: int-box + FIELD: int i +END-STRUCT + +: TTF_SizeUNICODE ( font text w h -- ? ) + "bool" "sdl-ttf" "TTF_SizeUNICODE" [ "void*" "ushort*" "int-box*" "int-box*" ] alien-invoke ; + +: TTF_RenderUNICODE_Solid ( font text fg -- surface ) + "surface*" "sdl-ttf" "TTF_RenderUNICODE_Solid" [ "void*" "ushort*" "int" ] alien-invoke ; + +: TTF_RenderGlyph_Solid ( font text fg -- surface ) + "surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "ushort" "int" ] alien-invoke ; + +: TTF_RenderUNICODE_Shaded ( font text fg bg -- surface ) + "surface*" "sdl-ttf" "TTF_RenderUNICODE_Shaded" [ "void*" "ushort*" "int" "int" ] alien-invoke ; + +: TTF_RenderGlyph_Shaded ( font text fg bg -- surface ) + "surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ; + +: TTF_RenderUNICODE_Blended ( font text fg -- surface ) + "surface*" "sdl-ttf" "TTF_RenderUNICODE_Blended" [ "void*" "ushort*" "int" ] alien-invoke ; + +: TTF_RenderGlyph_Blended ( font text fg -- surface ) + "surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ; + +: TTF_CloseFont ( font -- ) + "void" "sdl-ttf" "TTF_CloseFont" [ "void*" ] alien-invoke ; + +: TTF_Quit ( -- ) + "void" "sdl-ttf" "TTF_CloseFont" [ ] alien-invoke ; + +: TTF_WasInit ( -- ? ) + "bool" "sdl-ttf" "TTF_WasInit" [ ] alien-invoke ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 84ab7c2120..5a82231758 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -1,44 +1,9 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: sdl -USE: alien -USE: math -USE: namespaces -USE: compiler -USE: words -USE: parser -USE: kernel -USE: errors -USE: lists -USE: prettyprint -USE: sdl-event -USE: sdl-gfx -USE: sdl-video +USING: alien math namespaces compiler words parser kernel errors +lists prettyprint sdl-event sdl-gfx sdl-keyboard sdl-video +streams strings sdl-ttf hashtables ; SYMBOL: surface SYMBOL: width @@ -52,28 +17,43 @@ SYMBOL: surface : with-screen ( width height bpp flags quot -- ) #! Set up SDL graphics and call the quotation. + SDL_INIT_EVERYTHING SDL_Init drop TTF_Init + 1 SDL_EnableUNICODE drop + SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL + SDL_EnableKeyRepeat drop [ >r init-screen r> call SDL_Quit ] with-scope ; inline -: rgba ( r g b a -- n ) +: rgb ( [ r g b ] -- n ) + 3unlist + 255 swap 8 shift bitor swap 16 shift bitor swap 24 shift bitor ; -: black 0 0 0 255 rgba ; -: white 255 255 255 255 rgba ; -: red 255 0 0 255 rgba ; -: green 0 255 0 255 rgba ; -: blue 0 0 255 255 rgba ; +: make-color ( r g b -- color ) + #! Make an SDL_Color struct. This will go away soon in favor + #! of pass-by-value support in the FFI. + 255 24 shift + swap 16 shift bitor + swap 8 shift bitor + swap bitor ; + +: black [ 0 0 0 ] ; +: white [ 255 255 255 ] ; +: red [ 255 0 0 ] ; +: green [ 0 255 0 ] ; +: blue [ 0 0 255 ] ; : clear-surface ( color -- ) >r surface get 0 0 width get height get r> boxColor ; -: pixel-step ( quot #{ x y } -- ) - tuck >r call >r surface get r> r> >rect rot pixelColor ; - inline - -: with-pixels ( w h quot -- ) - -rot rect> [ over >r pixel-step r> ] 2times* drop ; inline +: with-pixels ( quot -- ) + width get [ + height get [ + [ rot dup slip swap surface get swap ] 2keep + [ rot pixelColor ] 2keep + ] repeat + ] repeat drop ; inline : with-surface ( quot -- ) #! Execute a quotation, locking the current surface if it @@ -87,7 +67,7 @@ SYMBOL: surface ] with-scope ; inline : event-loop ( event -- ) - dup SDL_WaitEvent 1 = [ + dup SDL_WaitEvent [ dup event-type SDL_QUIT = [ drop ] [ @@ -96,3 +76,80 @@ SYMBOL: surface ] [ drop ] ifte ; + +SYMBOL: fonts + +: null? ( alien -- ? ) + dup [ alien-address 0 = ] when ; + +: ( name ptsize -- font ) + >r resource-path swap cat2 r> TTF_OpenFont ; + +SYMBOL: logical-fonts + +: logical-font ( name -- name ) + dup logical-fonts get hash dup [ nip ] [ drop ] ifte ; + +global [ + {{ + [[ "Monospaced" "/fonts/VeraMono.ttf" ]] + [[ "Serif" "/fonts/VeraSe.ttf" ]] + [[ "Sans Serif" "/fonts/Vera.ttf" ]] + }} logical-fonts set +] bind + +: (lookup-font) ( [[ name ptsize ]] -- font ) + unswons logical-font swons dup get dup alien? [ + dup alien-address 0 = [ + drop f + ] when + ] when ; + +: lookup-font ( [[ name ptsize ]] -- font ) + fonts get [ + (lookup-font) [ + nip + ] [ + [ uncons dup ] keep set + ] ifte* + ] bind ; + +: make-rect ( x y w h -- rect ) + + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +: surface-rect ( x y surface -- rect ) + dup surface-w swap surface-h make-rect ; + +: draw-surface ( x y surface -- ) + surface get SDL_UnlockSurface + [ + [ surface-rect ] keep swap surface get 0 0 + ] keep surface-rect swap rot SDL_UpperBlit drop + surface get dup must-lock-surface? [ + SDL_LockSurface + ] when drop ; + +: draw-string ( x y font text fg -- width ) + over str-length 0 = [ + 2drop 3drop 0 + ] [ + >r >r lookup-font r> r> + TTF_RenderUNICODE_Blended + [ draw-surface ] keep + [ surface-w ] keep + SDL_FreeSurface + ] ifte ; + +: size-string ( font text -- w h ) + >r lookup-font r> dup str-length 0 = [ + drop TTF_FontHeight 0 swap + ] [ + [ TTF_SizeUNICODE drop ] 2keep + swap int-box-i swap int-box-i + ] ifte ; + +global [ fonts set ] bind diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor index 7f7ea3d696..a7c1722484 100644 --- a/library/sdl/sdl-video.factor +++ b/library/sdl/sdl-video.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -60,6 +60,13 @@ BEGIN-STRUCT: rect FIELD: ushort h END-STRUCT +BEGIN-STRUCT: color + FIELD: uchar r + FIELD: uchar g + FIELD: uchar b + FIELD: uchar unused +END-STRUCT + BEGIN-STRUCT: format FIELD: void* palette FIELD: uchar BitsPerPixel @@ -148,10 +155,9 @@ END-STRUCT ! SDL_SetGamma: float types -: SDL_FillRect ( surface rect color -- n ) - #! If rect is null, fills entire surface. - "bool" "sdl" "SDL_FillRect" - [ "surface*" "rect*" "uint" ] alien-invoke ; +: SDL_MapRGB ( surface r g b -- rgb ) + "uint" "sdl" "SDL_MapRGB" + [ "surface*" "uchar" "uchar" "uchar" ] alien-invoke ; : SDL_LockSurface ( surface -- ? ) "bool" "sdl" "SDL_LockSurface" [ "surface*" ] alien-invoke ; @@ -159,9 +165,21 @@ END-STRUCT : SDL_UnlockSurface ( surface -- ) "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-invoke ; -: SDL_MapRGB ( surface r g b -- rgb ) - "uint" "sdl" "SDL_MapRGB" - [ "surface*" "uchar" "uchar" "uchar" ] alien-invoke ; +: SDL_FreeSurface ( surface -- ) + "void" "sdl" "SDL_FreeSurface" [ "surface*" ] alien-invoke ; + +: SDL_UpperBlit ( src srcrect dst dstrect -- ) + #! The blit function should not be called on a locked + #! surface. + "int" "sdl" "SDL_UpperBlit" [ + "surface*" "rect*" + "surface*" "rect*" + ] alien-invoke ; + +: SDL_FillRect ( surface rect color -- n ) + #! If rect is null, fills entire surface. + "bool" "sdl" "SDL_FillRect" + [ "surface*" "rect*" "uint" ] alien-invoke ; : SDL_WM_SetCaption ( title icon -- ) "void" "sdl" "SDL_WM_SetCaption" diff --git a/library/stack.factor b/library/stack.factor index 19dfc2d7d4..2894406aaa 100644 --- a/library/stack.factor +++ b/library/stack.factor @@ -1,30 +1,5 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: kernel : 2drop ( x x -- ) drop drop ; inline @@ -35,7 +10,9 @@ IN: kernel : -rot ( x y z -- z x y ) swap >r swap r> ; inline : dupd ( x y -- x x y ) >r dup r> ; inline : swapd ( x y z -- y x z ) >r swap r> ; inline +: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline : nip ( x y -- y ) swap drop ; inline +: 2nip ( x y z -- z ) >r drop drop r> ; inline : tuck ( x y -- y x y ) dup >r swap r> ; inline : clear ( -- ) diff --git a/library/strings.factor b/library/strings.factor index 42e82b7ee4..46957765ff 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -1,36 +1,6 @@ -! :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: strings -USE: generic -USE: kernel -USE: kernel-internals -USE: lists -USE: math +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: strings USING: generic kernel kernel-internals lists math ; ! Define methods bound to primitives BUILTIN: string 12 @@ -134,12 +104,20 @@ UNION: text string integer ; rot str-head swap ] ifte ; -: str-each ( str [ code ] -- ) - #! Execute the code, with each character of the string +: (str>list) ( i str -- list ) + 2dup str-length >= [ + 2drop [ ] + ] [ + 2dup str-nth >r >r 1 + r> (str>list) r> swons + ] ifte ; + +: str>list ( str -- list ) + 0 swap (str>list) ; + +: str-each ( str quot -- ) + #! Execute the quotation with each character of the string #! pushed onto the stack. - over str-length [ - -rot 2dup >r >r >r str-nth r> call r> r> - ] times* 2drop ; inline + >r str>list r> each ; inline PREDICATE: integer blank " \t\n\r" str-contains? ; PREDICATE: integer letter CHAR: a CHAR: z between? ; diff --git a/library/syntax/generic.factor b/library/syntax/generic.factor new file mode 100644 index 0000000000..6aa102e6d0 --- /dev/null +++ b/library/syntax/generic.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. + +! Bootstrapping trick; see doc/bootstrap.txt. +IN: !syntax +USING: syntax generic kernel lists namespaces parser words ; + +: GENERIC: + #! GENERIC: bar creates a generic word bar. Add methods to + #! the generic word using M:. + [ single-combination ] + \ GENERIC: CREATE define-generic ; parsing + +: 2GENERIC: + #! 2GENERIC: bar creates a generic word bar. Add methods to + #! the generic word using M:. 2GENERIC words dispatch on + #! arithmetic types and should not be used for non-numerical + #! types. + [ arithmetic-combination ] + \ 2GENERIC: CREATE define-generic ; parsing + +: BUILTIN: + #! Followed by type name and type number. Define a built-in + #! type predicate with this number. + CREATE scan-word swap builtin-class ; parsing + +: COMPLEMENT: ( -- class predicate definition ) + #! Followed by a class name, then a complemented class. + CREATE + dup intern-symbol + dup predicate-word + [ dupd unit "predicate" set-word-property ] keep + scan-word define-complement ; parsing + +: UNION: ( -- class predicate definition ) + #! Followed by a class name, then a list of union members. + CREATE + dup intern-symbol + dup predicate-word + [ dupd unit "predicate" set-word-property ] keep + [ define-union ] [ ] ; parsing + +: PREDICATE: ( -- class predicate definition ) + #! Followed by a superclass name, then a class name. + scan-word + CREATE dup intern-symbol + dup rot "superclass" set-word-property + dup predicate-word + [ dupd unit "predicate" set-word-property ] keep + [ define-predicate ] [ ] ; parsing + +: TUPLE: + #! Followed by a tuple name, then slot names, then ; + scan + string-mode on + [ string-mode off define-tuple ] + f ; parsing + +: M: ( -- class generic [ ] ) + #! M: foo bar begins a definition of the bar generic word + #! specialized to the foo type. + scan-word scan-word [ define-method ] [ ] ; parsing + +: C: + #! Followed by a tuple name, then constructor code, then ; + #! Constructor code executes with the empty tuple on the + #! stack. + scan-word [ define-constructor ] f ; parsing diff --git a/library/syntax/parse-stream.factor b/library/syntax/parse-stream.factor index 2c84fa87d9..a9e7115075 100644 --- a/library/syntax/parse-stream.factor +++ b/library/syntax/parse-stream.factor @@ -41,7 +41,7 @@ USE: strings ! parse-stream : next-line ( -- str ) - "parse-stream" get freadln + "parse-stream" get stream-readln "line-number" [ 1 + ] change ; : (read-lines) ( quot -- ) @@ -57,7 +57,7 @@ USE: strings swap [ "parse-stream" set 0 "line-number" set (read-lines) ] [ - "parse-stream" get fclose rethrow + "parse-stream" get stream-close rethrow ] catch ; : file-vocabs ( -- ) @@ -75,7 +75,7 @@ USE: strings [ file-vocabs (parse-stream) ] with-scope ; : parse-file ( file -- quot ) - dup parse-stream ; + dup parse-stream ; : run-file ( file -- ) #! Run a file. The file is read with the default IN:/USE: @@ -83,7 +83,7 @@ USE: strings parse-file call ; : (parse-file) ( file -- quot ) - dup (parse-stream) ; + dup (parse-stream) ; : (run-file) ( file -- ) #! Run a file. The file is read with the same IN:/USE: as diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index b17e74006e..4d91472734 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -1,45 +1,10 @@ -! :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. +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. ! Bootstrapping trick; see doc/bootstrap.txt. IN: !syntax -USE: syntax - -USE: errors -USE: hashtables -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors -USE: unparser +USING: syntax errors generic hashtables kernel lists +math namespaces parser strings words vectors unparse ; : parsing ( -- ) #! Mark the most recently defined word to execute at parse @@ -55,29 +20,36 @@ USE: unparser ! ( and #! then add "stack-effect" and "documentation" ! properties to the current word if it is set. -! Constants -: t t parsed ; parsing -: f f parsed ; parsing +! Booleans +: t t swons ; parsing +: f f swons ; parsing ! Lists : [ f ; parsing -: ] reverse parsed ; parsing +: ] reverse swons ; parsing -: | ( syntax: | cdr ] ) - #! See the word 'parsed'. We push a special sentinel, and - #! 'parsed' acts accordingly. - "|" ; parsing +! Conses (whose cdr might not be a list) +: [[ f ; parsing +: ]] 2unlist swons swons ; parsing ! Vectors : { f ; parsing -: } reverse list>vector parsed ; parsing +: } reverse list>vector swons ; parsing ! Hashtables : {{ f ; parsing -: }} alist>hash parsed ; parsing +: }} alist>hash swons ; parsing + +! Tuples. +: << f ; parsing +: >> reverse literal-tuple swons ; parsing + +! Complex numbers +: #{ f ; parsing +: }# 2unlist swap rect> swons ; parsing ! Do not execute parsing word -: POSTPONE: ( -- ) scan-word parsed ; parsing +: POSTPONE: ( -- ) scan-word swons ; parsing : : #! Begin a word definition. Word name follows. @@ -95,43 +67,45 @@ USE: unparser : \ #! Parsed as a piece of code that pushes a word on the stack #! \ foo ==> [ foo ] car - scan-word unit parsed \ car parsed ; parsing + scan-word unit swons \ car swons ; parsing ! Vocabularies : DEFER: #! Create a word with no definition. Used for mutually #! recursive words. CREATE drop ; parsing + : FORGET: scan-word forget ; parsing : USE: #! Add vocabulary to search path. scan "use" cons@ ; parsing + +: USING: + #! A list of vocabularies terminated with ; + string-mode on + [ string-mode off [ "use" cons@ ] each ] + f ; parsing + : IN: #! Set vocabulary for new definitions. scan dup "use" cons@ "in" set ; parsing ! Char literal -: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing +: CHAR: ( -- ) 0 scan next-char drop swons ; parsing ! String literal -: parse-string ( -- ) - next-ch dup CHAR: " = [ - drop +: parse-string ( n str -- n ) + 2dup str-nth CHAR: " = [ + drop 1 + ] [ - parse-ch , parse-string + [ next-char swap , ] keep parse-string ] ifte ; : " - #! Note the ugly hack to carry the new value of 'pos' from - #! the make-string scope up to the original scope. - [ parse-string "col" get ] make-string - swap "col" set parsed ; parsing - -: #{ - #! Complex literal - #{ real imaginary #} - scan str>number scan str>number rect> "}" expect parsed ; - parsing + "col" [ + "line" get [ parse-string ] make-string swap + ] change swons ; parsing ! Comments : ( @@ -148,11 +122,11 @@ USE: unparser ! Reading numbers in other bases -: BASE: ( base -- ) +: (BASE) ( base -- ) #! Read a number in a specific base. - scan swap base> parsed ; + scan swap base> swons ; -: HEX: 16 BASE: ; parsing -: DEC: 10 BASE: ; parsing -: OCT: 8 BASE: ; parsing -: BIN: 2 BASE: ; parsing +: HEX: 16 (BASE) ; parsing +: DEC: 10 (BASE) ; parsing +: OCT: 8 (BASE) ; parsing +: BIN: 2 (BASE) ; parsing diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 4322ea64ec..d1223589a3 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -1,39 +1,8 @@ -! :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. - +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: parser -USE: errors -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: strings -USE: words -USE: unparser +USING: errors kernel lists math namespaces strings words +unparser ; ! The parser uses a number of variables: ! line - the line being parsed @@ -46,27 +15,7 @@ USE: unparser ! immediately. Otherwise it is appended to the parse tree. : parsing? ( word -- ? ) - dup word? [ - "parsing" word-property - ] [ - drop f - ] ifte ; - -: end? ( -- ? ) - "col" get "line" get str-length >= ; - -: (with-parser) ( quot -- ) - end? [ drop ] [ [ call ] keep (with-parser) ] ifte ; - -: with-parser ( text quot -- ) - #! Keep calling the quotation until we reach the end of the - #! input. - swap "line" set 0 "col" set - (with-parser) - "line" off "col" off ; - -: ch ( -- ch ) "col" get "line" get str-nth ; -: advance ( -- ) "col" [ 1 + ] change ; + dup word? [ "parsing" word-property ] [ drop f ] ifte ; : skip ( n line quot -- n ) #! Find the next character that satisfies the quotation, @@ -84,9 +33,6 @@ USE: unparser : skip-blank ( n line -- n ) [ blank? not ] skip ; -: skip-word ( n line -- n ) - [ blank? ] skip ; - : denotation? ( ch -- ? ) #! Hard-coded for now. Make this customizable later. #! A 'denotation' is a character that is treated as its @@ -97,55 +43,42 @@ USE: unparser #! Will call the parsing word ". "\"" str-contains? ; -: (scan) ( n line -- start end ) - dup >r skip-blank dup r> - 2dup str-length < [ - 2dup str-nth denotation? [ - drop 1 + - ] [ - skip-word - ] ifte +: skip-word ( n line -- n ) + 2dup str-nth denotation? [ + drop 1 + ] [ - drop + [ blank? ] skip ] ifte ; +: (scan) ( n line -- start end ) + [ skip-blank dup ] keep + 2dup str-length < [ skip-word ] [ drop ] ifte ; + : scan ( -- token ) "col" get "line" get dup >r (scan) dup "col" set - 2dup = [ - r> 3drop f - ] [ - r> substring - ] ifte ; + 2dup = [ r> 3drop f ] [ r> substring ] ifte ; + +! If this variable is on, the parser does not internalize words; +! it just appends strings to the parse tree as they are read. +SYMBOL: string-mode +global [ string-mode off ] bind : scan-word ( -- obj ) scan dup [ - dup "use" get search dup [ - nip - ] [ - drop str>number - ] ifte + dup ";" = not string-mode get and [ + dup "use" get search [ str>number ] ?unless + ] unless ] when ; -: parsed| ( parsed parsed obj -- parsed ) - #! Some ugly ugly code to handle [ a | b ] expressions. - >r unswons r> cons swap [ swons ] each swons ; - -: expect ( word -- ) - dup scan = not [ - "Expected " swap cat2 throw - ] [ - drop - ] ifte ; - -: parsed ( obj -- ) - over "|" = [ nip parsed| "]" expect ] [ swons ] ifte ; +: parse-loop ( -- ) + scan-word [ + dup parsing? [ execute ] [ swons ] ifte parse-loop + ] when* ; : (parse) ( str -- ) - [ - scan-word [ - dup parsing? [ execute ] [ parsed ] ifte - ] when* - ] with-parser ; + "line" set 0 "col" set + parse-loop + "line" off "col" off ; : parse ( str -- code ) #! Parse the string into a parse tree that can be executed. @@ -173,60 +106,51 @@ USE: unparser #! the parser is already line-tokenized. (until-eol) (until) ; -: next-ch ( -- ch ) - end? [ "Unexpected EOF" throw ] [ ch advance ] ifte ; +: save-location ( word -- ) + #! Remember where this word was defined. + dup set-word + dup "line-number" get "line" set-word-property + dup "col" get "col" set-word-property + "file" get "file" set-word-property ; -: next-word-ch ( -- ch ) - "col" get "line" get skip-blank "col" set next-ch ; +: create-in "in" get create ; : CREATE ( -- word ) - scan "in" get create dup set-word - dup f "documentation" set-word-property - dup f "stack-effect" set-word-property - dup "line-number" get "line" set-word-property - dup "col" get "col" set-word-property - dup "file" get "file" set-word-property ; - -! \x -: unicode-escape>ch ( -- esc ) - #! Read \u.... - next-ch digit> 16 * - next-ch digit> + 16 * - next-ch digit> + 16 * - next-ch digit> + ; - -: ascii-escape>ch ( ch -- esc ) - [ - [ CHAR: e | CHAR: \e ] - [ CHAR: n | CHAR: \n ] - [ CHAR: r | CHAR: \r ] - [ CHAR: t | CHAR: \t ] - [ CHAR: s | CHAR: \s ] - [ CHAR: \s | CHAR: \s ] - [ CHAR: 0 | CHAR: \0 ] - [ CHAR: \\ | CHAR: \\ ] - [ CHAR: \" | CHAR: \" ] - ] assoc ; + scan create-in dup save-location ; : escape ( ch -- esc ) - dup CHAR: u = [ - drop unicode-escape>ch + [ + [[ CHAR: e CHAR: \e ]] + [[ CHAR: n CHAR: \n ]] + [[ CHAR: r CHAR: \r ]] + [[ CHAR: t CHAR: \t ]] + [[ CHAR: s CHAR: \s ]] + [[ CHAR: \s CHAR: \s ]] + [[ CHAR: 0 CHAR: \0 ]] + [[ CHAR: \\ CHAR: \\ ]] + [[ CHAR: \" CHAR: \" ]] + ] assoc dup [ "Bad escape" throw ] unless ; + +: next-escape ( n str -- ch n ) + 2dup str-nth CHAR: u = [ + swap 1 + dup 4 + [ rot substring hex> ] keep ] [ - ascii-escape>ch + over 1 + >r str-nth escape r> ] ifte ; -: parse-escape ( -- ) - next-ch escape dup [ drop "Bad escape" throw ] unless ; - -: parse-ch ( ch -- ch ) - dup CHAR: \\ = [ drop parse-escape ] when ; +: next-char ( n str -- ch n ) + 2dup str-nth CHAR: \\ = [ + >r 1 + r> next-escape + ] [ + over 1 + >r str-nth r> + ] ifte ; : doc-comment-here? ( parsed -- ? ) not "in-definition" get and ; : parsed-stack-effect ( parsed str -- parsed ) over doc-comment-here? [ - word stack-effect [ + word "stack-effect" word-property [ drop ] [ word swap "stack-effect" set-word-property diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index a68c20793f..41f238b02f 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -1,84 +1,24 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: prettyprint -USE: errors -USE: generic -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: stdio -USE: strings -USE: presentation -USE: unparser -USE: vectors -USE: words -USE: hashtables + +! This using kernel-internals is pretty bad. Remove the +! kernel-internals usage as soon as the tuple class is moved +! to the generic vocabulary. +USING: errors generic kernel kernel-internals lists math +namespaces stdio strings presentation unparser vectors words +hashtables parser ; SYMBOL: prettyprint-limit +SYMBOL: one-line +SYMBOL: tab-size +SYMBOL: recursion-check GENERIC: prettyprint* ( indent obj -- indent ) M: object prettyprint* ( indent obj -- indent ) unparse write ; -: tab-size - #! Change this to suit your tastes. - 4 ; - -: indent ( indent -- ) - #! Print the given number of spaces. - " " fill write ; - -: prettyprint-newline ( indent -- ) - "\n" write indent ; - -: prettyprint-element ( indent obj -- indent ) - over prettyprint-limit get >= [ - unparse write - ] [ - prettyprint* - ] ifte " " write ; - -: ( indent -- indent ) - tab-size - - "prettyprint-single-line" get [ - dup prettyprint-newline - ] unless ; - : word-link ( word -- link ) [ dup word-name unparse , @@ -89,11 +29,11 @@ M: object prettyprint* ( indent obj -- indent ) : word-actions ( search -- list ) [ - [ "See" | "see" ] - [ "Push" | "" ] - [ "Execute" | "execute" ] - [ "jEdit" | "jedit" ] - [ "Usages" | "usages." ] + [[ "See" "see" ]] + [[ "Push" "" ]] + [[ "Execute" "execute" ]] + [[ "jEdit" "jedit" ]] + [[ "Usages" "usages." ]] ] ; : word-attrs ( word -- attrs ) @@ -105,82 +45,105 @@ M: object prettyprint* ( indent obj -- indent ) drop [ ] ] ifte ; -M: word prettyprint* ( indent word -- indent ) +: prettyprint-word ( word -- ) dup word-name swap dup word-attrs swap word-style append write-attr ; -: prettyprint-[ ( indent -- indent ) - \ [ prettyprint* \ ] prettyprint* ; +: indent ( indent -- ) + #! Print the given number of spaces. + " " fill write ; -: prettyprint-list ( indent list -- indent ) - #! Pretty-print a list, without [ and ]. +: prettyprint-newline ( indent -- ) + "\n" write indent ; + +: prettyprint-elements ( indent list -- indent ) + [ prettyprint* " " write ] each ; + +: ( indent -- indent ) + tab-size get - one-line get + [ dup prettyprint-newline ] unless ; + +: prettyprint-limit? ( indent -- ? ) + prettyprint-limit get dup [ >= ] [ nip ] ifte ; + +: check-recursion ( indent obj quot -- ? indent ) + #! We detect circular structure. + pick prettyprint-limit? >r + over recursion-check get memq? r> or [ + 2drop "..." write + ] [ + over recursion-check [ cons ] change + call + recursion-check [ cdr ] change + ] ifte ; + +: prettyprint-sequence ( indent start list end -- indent ) + #! Prettyprint a list, with start/end delimiters; eg, [ ], + #! or { }, or << >>. The body of the list is indented, + #! unless the list is empty. + over [ + >r + >r prettyprint-word prettyprint-elements + prettyprint> r> prettyprint-word + ] [ + >r >r prettyprint-word " " write + r> drop + r> prettyprint-word + ] ifte ; + +M: list prettyprint* ( indent list -- indent ) + [ + \ [ swap \ ] prettyprint-sequence + ] check-recursion ; + +M: cons prettyprint* ( indent cons -- indent ) + #! Here we turn the cons into a list of two elements. [ - uncons >r prettyprint-element r> - dup cons? [ - prettyprint-list - ] [ - [ - \ | prettyprint* - " " write prettyprint-element - ] when* - ] ifte - ] when* ; - -M: cons prettyprint* ( indent list -- indent ) - swap prettyprint-[ swap prettyprint-list prettyprint-] ; - -: prettyprint-{ ( indent -- indent ) - \ { prettyprint* \ } prettyprint* ; - -: prettyprint-vector ( indent list -- indent ) - #! Pretty-print a vector, without { and }. - [ prettyprint-element ] vector-each ; + \ [[ swap uncons 2list \ ]] prettyprint-sequence + ] check-recursion ; M: vector prettyprint* ( indent vector -- indent ) - dup vector-length 0 = [ - drop - \ { prettyprint* - " " write - \ } prettyprint* - ] [ - swap prettyprint-{ swap prettyprint-vector prettyprint-} - ] ifte ; - -: prettyprint-{{ ( indent -- indent ) - \ {{ prettyprint* \ }} prettyprint* ; + [ + \ { swap vector>list \ } prettyprint-sequence + ] check-recursion ; M: hashtable prettyprint* ( indent hashtable -- indent ) - hash>alist dup length 0 = [ - drop - \ {{ prettyprint* - " " write - \ }} prettyprint* - ] [ - swap prettyprint-{{ swap prettyprint-list prettyprint-}} - ] ifte ; + [ + \ {{ swap hash>alist \ }} prettyprint-sequence + ] check-recursion ; -: prettyprint-1 ( obj -- ) - 0 swap prettyprint* drop ; +M: tuple prettyprint* ( indent tuple -- indent ) + [ + \ << swap tuple>list \ >> prettyprint-sequence + ] check-recursion ; : prettyprint ( obj -- ) - prettyprint-1 terpri ; + [ + recursion-check off + 0 swap prettyprint* drop terpri + ] with-scope ; : vocab-link ( vocab -- link ) "vocabularies'" swap cat2 ; : . ( obj -- ) [ - "prettyprint-single-line" on + one-line on 16 prettyprint-limit set prettyprint ] with-scope ; @@ -191,7 +154,7 @@ M: hashtable prettyprint* ( indent hashtable -- indent ) : {.} ( vector -- ) #! Unparse each element on its own line. - stack>list [ . ] each ; + vector>list reverse [ . ] each ; : .s datastack {.} ; : .r callstack {.} ; @@ -203,4 +166,4 @@ M: hashtable prettyprint* ( indent hashtable -- indent ) : .o >oct print ; : .h >hex print ; -global [ 40 prettyprint-limit set ] bind +global [ 4 tab-size set ] bind diff --git a/library/syntax/see.factor b/library/syntax/see.factor index 32f288980c..c02d8039f1 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -1,47 +1,15 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: prettyprint -USE: generic -USE: kernel -USE: lists -USE: math -USE: stdio -USE: strings -USE: presentation -USE: unparser -USE: words +USING: generic kernel lists math namespaces stdio strings +presentation unparser words ; ! Prettyprinting words : vocab-actions ( search -- list ) [ - [ "Words" | "words." ] - [ "Use" | "\"use\" cons@" ] - [ "In" | "\"in\" set" ] + [[ "Words" "words." ]] + [[ "Use" "\"use\" cons@" ]] + [[ "In" "\"in\" set" ]] ] ; : vocab-attrs ( vocab -- attrs ) @@ -53,20 +21,20 @@ USE: words dup vocab-attrs write-attr ; : prettyprint-IN: ( word -- ) - \ IN: prettyprint* " " write + \ IN: prettyprint-word " " write word-vocabulary prettyprint-vocab " " write ; : prettyprint-: ( indent -- indent ) - \ : prettyprint* " " write - tab-size + ; + \ : prettyprint-word " " write + tab-size get + ; : prettyprint-; ( indent -- indent ) - \ ; prettyprint* - tab-size - ; + \ ; prettyprint-word + tab-size get - ; : prettyprint-prop ( word prop -- ) tuck word-name word-property [ - " " write prettyprint-1 + " " write prettyprint-word ] [ drop ] ifte ; @@ -76,19 +44,35 @@ USE: words \ parsing prettyprint-prop \ inline prettyprint-prop ; -: prettyprint-comment ( comment -- ) - "comments" style write-attr ; +: comment. ( comment -- ) "comments" style write-attr ; -: stack-effect. ( word -- ) - stack-effect [ +: infer-effect. ( indent effect -- indent ) + " " write + [ + "(" , + 2unlist >r [ " " , unparse , ] each r> + " --" , + [ " " , unparse , ] each + " )" , + ] make-string comment. ; + +: stack-effect. ( indent word -- indent ) + dup "stack-effect" word-property [ " " write - [ CHAR: ( , , CHAR: ) , ] make-string prettyprint-comment - ] when* ; + [ CHAR: ( , , CHAR: ) , ] make-string + comment. + ] [ + "infer-effect" word-property dup [ + infer-effect. + ] [ + drop + ] ifte + ] ?ifte ; : documentation. ( indent word -- indent ) - documentation [ + "documentation" word-property [ "\n" split [ - "#!" swap cat2 prettyprint-comment + "#!" swap cat2 comment. dup prettyprint-newline ] each ] when* ; @@ -99,42 +83,46 @@ USE: words ] keep documentation. ; : prettyprint-M: ( indent -- indent ) - \ M: prettyprint-1 " " write tab-size + ; + \ M: prettyprint-word " " write tab-size get + ; GENERIC: see ( word -- ) M: compound see ( word -- ) dup prettyprint-IN: 0 prettyprint-: swap - [ prettyprint-1 ] keep + [ prettyprint-word ] keep [ prettyprint-docs ] keep - [ word-parameter prettyprint-list prettyprint-; ] keep + [ + word-parameter prettyprint-elements + prettyprint-; + ] keep prettyprint-plist prettyprint-newline ; : see-method ( indent word class method -- indent ) >r >r >r prettyprint-M: - r> r> prettyprint-1 " " write - prettyprint-1 " " write + r> r> prettyprint-word " " write + prettyprint-word " " write dup prettyprint-newline - r> prettyprint-list + r> prettyprint-elements prettyprint-; terpri ; M: generic see ( word -- ) dup prettyprint-IN: 0 swap - dup "definer" word-property prettyprint-1 " " write - dup prettyprint-1 terpri + dup "definer" word-property prettyprint-word " " write + dup prettyprint-word terpri dup methods [ over >r uncons see-method r> ] each 2drop ; M: primitive see ( word -- ) dup prettyprint-IN: - "PRIMITIVE: " write dup prettyprint-1 stack-effect. terpri ; + "PRIMITIVE: " write dup prettyprint-word stack-effect. + terpri ; M: symbol see ( word -- ) dup prettyprint-IN: - \ SYMBOL: prettyprint-1 " " write . ; + \ SYMBOL: prettyprint-word " " write . ; M: undefined see ( word -- ) dup prettyprint-IN: - \ DEFER: prettyprint-1 " " write . ; + \ DEFER: prettyprint-word " " write . ; diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index 16e013b377..f58545638f 100644 --- a/library/syntax/unparser.factor +++ b/library/syntax/unparser.factor @@ -1,40 +1,8 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: unparser -USE: generic -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: parser -USE: stdio -USE: strings -USE: words +USING: generic kernel lists math namespaces parser stdio strings +words memory ; GENERIC: unparse ( obj -- str ) @@ -98,18 +66,18 @@ M: complex unparse ( num -- str ) real unparse , " " , imaginary unparse , - " }" , + " }#" , ] make-string ; : ch>ascii-escape ( ch -- esc ) [ - [ CHAR: \e | "\\e" ] - [ CHAR: \n | "\\n" ] - [ CHAR: \r | "\\r" ] - [ CHAR: \t | "\\t" ] - [ CHAR: \0 | "\\0" ] - [ CHAR: \\ | "\\\\" ] - [ CHAR: \" | "\\\"" ] + [[ CHAR: \e "\\e" ]] + [[ CHAR: \n "\\n" ]] + [[ CHAR: \r "\\r" ]] + [[ CHAR: \t "\\t" ]] + [[ CHAR: \0 "\\0" ]] + [[ CHAR: \\ "\\\\" ]] + [[ CHAR: \" "\\\"" ]] ] assoc ; : ch>unicode-escape ( ch -- esc ) @@ -117,11 +85,7 @@ M: complex unparse ( num -- str ) : unparse-ch ( ch -- ch/str ) dup quotable? [ - dup ch>ascii-escape dup [ - nip - ] [ - drop ch>unicode-escape - ] ifte + dup ch>ascii-escape [ ch>unicode-escape ] ?unless ] unless ; M: string unparse ( str -- str ) diff --git a/library/test/alien.factor b/library/test/alien.factor index fec1163c50..fec3cb3e08 100644 --- a/library/test/alien.factor +++ b/library/test/alien.factor @@ -14,9 +14,9 @@ USE: inference : alien-inference-1 "void" "foobar" "boo" [ "short" "short" ] alien-invoke ; -[ [ 2 | 0 ] ] [ [ alien-inference-1 ] infer old-effect ] unit-test +[ [[ 2 0 ]] ] [ [ alien-inference-1 ] infer old-effect ] unit-test : alien-inference-2 "int" "foobar" "boo" [ "short" "short" ] alien-invoke ; -[ [ 2 | 1 ] ] [ [ alien-inference-2 ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ alien-inference-2 ] infer old-effect ] unit-test diff --git a/library/test/benchmark/empty-loop.factor b/library/test/benchmark/empty-loop.factor index c9eb24ed22..43875a217a 100644 --- a/library/test/benchmark/empty-loop.factor +++ b/library/test/benchmark/empty-loop.factor @@ -8,7 +8,7 @@ USE: test [ ] times ; compiled : empty-loop-2 ( n -- ) - [ drop ] times* ; compiled + [ ] repeat ; compiled [ ] [ 5000000 empty-loop-1 ] unit-test [ ] [ 5000000 empty-loop-2 ] unit-test diff --git a/library/test/benchmark/fac.factor b/library/test/benchmark/fac.factor index 13f6f14379..5beeec8ff5 100644 --- a/library/test/benchmark/fac.factor +++ b/library/test/benchmark/fac.factor @@ -2,8 +2,25 @@ IN: scratchpad USE: math USE: test USE: compiler +USE: kernel -: fac-benchmark - 10000 fac 10000 [ 1 + / ] times* ; compiled +: (fac) ( n! i -- n! ) + dup 0 = [ + drop + ] [ + [ * ] keep 1 - (fac) + ] ifte ; -[ 1 ] [ fac-benchmark ] unit-test +: fac ( n -- n! ) + 1 swap (fac) ; + +: small-fac-benchmark + #! This tests fixnum math. + 1 swap [ 10 fac 10 [ [ 1 + / ] keep ] repeat max ] times ; compiled + +: big-fac-benchmark + 10000 fac 10000 [ [ 1 + / ] keep ] repeat ; compiled + +[ 1 ] [ big-fac-benchmark ] unit-test + +[ 1 ] [ 1000000 small-fac-benchmark ] unit-test diff --git a/library/test/benchmark/fib.factor b/library/test/benchmark/fib.factor index 48cfede1ca..8abc9cf52f 100644 --- a/library/test/benchmark/fib.factor +++ b/library/test/benchmark/fib.factor @@ -3,6 +3,17 @@ USE: compiler USE: kernel USE: math USE: test +USE: math-internals + +: fixnum-fib ( n -- nth fibonacci number ) + dup 1 fixnum<= [ + drop 1 + ] [ + 1 fixnum- dup fixnum-fib swap 1 fixnum- fixnum-fib fixnum+ + ] ifte ; + compiled + +[ 9227465 ] [ 34 fixnum-fib ] unit-test : fib ( n -- nth fibonacci number ) dup 1 <= [ drop 1 ] [ 1 - dup fib swap 1 - fib + ] ifte ; diff --git a/library/test/benchmark/hashtables.factor b/library/test/benchmark/hashtables.factor index 528e28cd1b..087cfb95b8 100644 --- a/library/test/benchmark/hashtables.factor +++ b/library/test/benchmark/hashtables.factor @@ -9,10 +9,10 @@ USE: compiler ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html : store-hash ( hashtable n -- ) - [ dup >hex swap pick set-hash ] times* drop ; compiled + [ [ dup >hex swap pick set-hash ] keep ] repeat drop ; compiled : lookup-hash ( hashtable n -- ) - [ unparse over hash drop ] times* drop ; compiled + [ [ unparse over hash drop ] keep ] repeat drop ; compiled : hashtable-benchmark ( n -- ) 60000 swap 2dup store-hash lookup-hash ; compiled diff --git a/library/test/benchmark/sort.factor b/library/test/benchmark/sort.factor index 55a8c9ae30..04448a9b44 100644 --- a/library/test/benchmark/sort.factor +++ b/library/test/benchmark/sort.factor @@ -2,6 +2,7 @@ IN: scratchpad USE: lists USE: kernel USE: math +USE: namespaces USE: random USE: test USE: compiler diff --git a/library/test/benchmark/strings.factor b/library/test/benchmark/strings.factor index bf12d7390e..f9aac6a36c 100644 --- a/library/test/benchmark/strings.factor +++ b/library/test/benchmark/strings.factor @@ -3,6 +3,7 @@ USE: kernel USE: math USE: test USE: lists +USE: namespaces USE: compiler ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html @@ -20,4 +21,4 @@ USE: compiler : string-benchmark ( n -- ) "abcdef" 10 [ 2dup string-step ] times 2drop ; compiled -[ ] [ 1000000 string-benchmark ] unit-test +[ ] [ 400000 string-benchmark ] unit-test diff --git a/library/test/benchmark/vectors.factor b/library/test/benchmark/vectors.factor index 80de85a7ae..2afe570946 100644 --- a/library/test/benchmark/vectors.factor +++ b/library/test/benchmark/vectors.factor @@ -7,7 +7,7 @@ USE: test ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html : fill-vector ( n -- vector ) - dup swap [ dup pick set-vector-nth ] times* ; compiled + dup swap [ [ dup pick set-vector-nth ] keep ] repeat ; compiled : copy-elt ( vec-y vec-x n -- ) #! Copy nth element from vec-x to vec-y. @@ -15,9 +15,9 @@ USE: test : copy-vector ( vec-y vec-x n -- ) #! Copy first n-1 elements from vec-x to vec-y. - [ >r 2dup r> copy-elt ] times* 2drop ; compiled + [ [ >r 2dup r> copy-elt ] keep ] repeat 2drop ; compiled : vector-benchmark ( n -- ) 0 over fill-vector rot copy-vector ; compiled -[ ] [ 4000000 vector-benchmark ] unit-test +[ ] [ 400000 vector-benchmark ] unit-test diff --git a/library/test/buffer.factor b/library/test/buffer.factor new file mode 100644 index 0000000000..3cdcfd776f --- /dev/null +++ b/library/test/buffer.factor @@ -0,0 +1,16 @@ +IN: scratchpad USING: test kernel kernel-internals ; + +: with-buffer ( size quot -- ) + >r r> keep buffer-free ; + +: buffer-test1 ( -- buffer ) + "quux" swap [ buffer-append ] keep ; + +: buffer-test2 ( -- buffer ) + 6 [ + "abcdef" swap [ buffer-append ] keep [ 3 swap buffer-consume ] keep + buffer-contents + ] with-buffer ; + +[ 8 ] [ 12 [ buffer-test1 buffer-capacity ] with-buffer ] unit-test +[ "def" ] [ buffer-test2 ] unit-test diff --git a/library/test/combinators.factor b/library/test/combinators.factor index f6f2dce321..620658900d 100644 --- a/library/test/combinators.factor +++ b/library/test/combinators.factor @@ -2,6 +2,8 @@ IN: scratchpad USE: kernel USE: math USE: test +USE: stdio +USE: prettyprint [ slip ] unit-test-fails [ 1 slip ] unit-test-fails @@ -25,3 +27,9 @@ USE: test [ 0 ] [ f [ 0 ] unless* ] unit-test [ t ] [ t [ "Hello" ] unless* ] unit-test + +[ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?ifte ] with-string ] unit-test +[ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?ifte ] with-string ] unit-test +[ "4\n" ] [ [ 3 4 [ . ] ?when ] with-string ] unit-test +[ 3 ] [ 3 f [ . ] ?when ] unit-test +[ t ] [ 3 t [ . ] ?unless ] unit-test diff --git a/library/test/compiler/asm-test.factor b/library/test/compiler/asm-test.factor deleted file mode 100644 index f83648cfc0..0000000000 --- a/library/test/compiler/asm-test.factor +++ /dev/null @@ -1,46 +0,0 @@ -IN: scratchpad -USE: compiler - -0 EAX I>R -0 ECX I>R - -0 EAX [I]>R -0 ECX [I]>R - -0 EAX I>[R] -0 ECX I>[R] - -EAX 0 R>[I] -ECX 0 R>[I] - -EAX EAX [R]>R -EAX ECX [R]>R -ECX EAX [R]>R -ECX ECX [R]>R - -EAX EAX R>[R] -EAX ECX R>[R] -ECX EAX R>[R] -ECX ECX R>[R] - -4 0 I+[I] -0 4 I+[I] - -4 EAX R+I -4 ECX R+I -65535 EAX R+I -65535 ECX R+I - -4 EAX R-I -4 ECX R-I -65535 EAX R-I -65535 ECX R-I - -EAX PUSH-R -ECX PUSH-R -EAX PUSH-[R] -ECX PUSH-[R] -65535 PUSH-I - -EAX JUMP-[R] -ECX JUMP-[R] diff --git a/library/test/compiler/generic.factor b/library/test/compiler/generic.factor index ce84439b30..0e7e36d106 100644 --- a/library/test/compiler/generic.factor +++ b/library/test/compiler/generic.factor @@ -6,107 +6,31 @@ USE: math USE: kernel USE: words -: single-combination-test - { - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ nip ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - } single-combination ; compiled +GENERIC: single-combination-test + +M: object single-combination-test drop ; +M: f single-combination-test nip ; + +\ single-combination-test compile [ 2 3 ] [ 2 3 t single-combination-test ] unit-test [ 2 3 ] [ 2 3 4 single-combination-test ] unit-test [ 2 f ] [ 2 3 f single-combination-test ] unit-test -: single-combination-literal-test - 4 { - [ drop ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - } single-combination ; compiled - -[ ] [ single-combination-literal-test ] unit-test - -: single-combination-test-alt - { - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ nip ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - } single-combination + ; compiled - -[ 5 ] [ 2 3 4 single-combination-test-alt ] unit-test -[ 7/2 ] [ 2 3 3/2 single-combination-test-alt ] unit-test - DEFER: single-combination-test-2 : single-combination-test-4 - not single-combination-test-2 ; + dup [ single-combination-test-2 ] when ; : single-combination-test-3 drop 3 ; -: single-combination-test-2 - { - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-4 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - } single-combination ; +GENERIC: single-combination-test-2 +M: object single-combination-test-2 single-combination-test-3 ; +M: f single-combination-test-2 single-combination-test-4 ; + +\ single-combination-test-2 compile [ 3 ] [ t single-combination-test-2 ] unit-test [ 3 ] [ 3 single-combination-test-2 ] unit-test -[ 3 ] [ f single-combination-test-2 ] unit-test +[ f ] [ f single-combination-test-2 ] unit-test diff --git a/library/test/compiler/ifte.factor b/library/test/compiler/ifte.factor index be661b9c8b..8271d18dec 100644 --- a/library/test/compiler/ifte.factor +++ b/library/test/compiler/ifte.factor @@ -37,12 +37,12 @@ USE: math-internals : dead-code-rec t [ - #{ 3 2 } + #{ 3 2 }# ] [ dead-code-rec ] ifte ; compiled -[ #{ 3 2 } ] [ dead-code-rec ] unit-test +[ #{ 3 2 }# ] [ dead-code-rec ] unit-test : one-rec [ f one-rec ] [ "hi" ] ifte ; compiled diff --git a/library/test/compiler/linearizer.factor b/library/test/compiler/linearizer.factor new file mode 100644 index 0000000000..7b238d5ce1 --- /dev/null +++ b/library/test/compiler/linearizer.factor @@ -0,0 +1,10 @@ +IN: scratchpad +USE: test +USE: kernel +USE: compiler +USE: inference +USE: words + +: foo [ drop ] each-word ; + +[ ] [ \ foo word-parameter dataflow linearize drop ] unit-test diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 82b33536fc..551b2af640 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -15,6 +15,8 @@ USE: lists [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test -[ [ [ 1 ] [ 2 ] ] ] [ [ t [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test +[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test [ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f ] map kill-mask ] unit-test + +[ t ] [ 3 [ 3 over [ ] [ ] ifte drop ] dataflow kill-set contains? ] unit-test diff --git a/library/test/compiler/simple.factor b/library/test/compiler/simple.factor index e24b3f09d4..764061a04e 100644 --- a/library/test/compiler/simple.factor +++ b/library/test/compiler/simple.factor @@ -6,6 +6,7 @@ USE: kernel USE: words USE: kernel USE: math-internals +USE: memory : no-op ; compiled diff --git a/library/test/compiler/simplifier.factor b/library/test/compiler/simplifier.factor index a1ed0ce704..5f8a64fe22 100644 --- a/library/test/compiler/simplifier.factor +++ b/library/test/compiler/simplifier.factor @@ -4,55 +4,72 @@ USE: test USE: inference USE: lists USE: kernel +USE: namespaces + +[ t ] [ \ >r [ [ r> ] [ >r ] ] next-physical? ] unit-test +[ f t ] [ [ [ r> ] [ >r ] ] \ >r cancel nip ] unit-test +[ [ [ >r ] [ r> ] ] f ] [ [ [ >r ] [ r> ] ] \ >r cancel nip ] unit-test + +[ [ [ #jump 123 ] [ #return ] ] t ] +[ [ [ #call 123 ] [ #return ] ] #return #jump reduce ] unit-test [ [ ] ] [ [ ] simplify ] unit-test [ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test -[ [ #jump | car ] ] [ [ [ #call | car ] [ #return ] ] simplify car ] unit-test +[ [[ #jump car ]] ] [ [ [[ #call car ]] [ #return ] ] simplify car ] unit-test [ [ [ #return ] ] ] -[ 123 [ [ #call | car ] [ #label | 123 ] [ #return ] ] find-label ] -unit-test - -[ [ [ #return ] ] ] -[ [ [ #label | 123 ] [ #return ] ] follow ] +[ + [ + 123 [ [[ #call car ]] [[ #label 123 ]] [ #return ] ] + simplifying set find-label cdr + ] with-scope +] unit-test [ [ [ #return ] ] ] [ [ - [ #jump-label | 123 ] - [ #call | car ] - [ #label | 123 ] - [ #return ] - ] follow + [ + [[ #jump-label 123 ]] + [[ #call car ]] + [[ #label 123 ]] + [ #return ] + ] dup simplifying set next-logical + ] with-scope ] unit-test [ - [ #jump | car ] + [ [[ #return f ]] ] ] [ [ - [ #call | car ] - [ #jump-label | 123 ] - [ #label | 123 ] + [[ #jump-label 123 ]] + [[ #label 123 ]] [ #return ] - ] simplify car + ] simplify ] unit-test [ - t -] [ + [ [[ #jump car ]] ] +] +[ [ - [ #push-immediate | 1 ] - ] push-next? >boolean + [[ #call car ]] + [[ #jump-label 123 ]] + [[ #label 123 ]] + [ #return ] + ] simplify ] unit-test [ - [ - [ #replace-immediate | 1 ] - [ #return ] - ] + [ [[ swap f ]] ] ] [ - [ drop 1 ] dataflow linearize simplify + [ + [[ #jump-label 1 ]] + [[ #label 1 ]] + [[ #jump-label 2 ]] + [[ #label 2 ]] + [[ swap f ]] + ] simplify ] unit-test diff --git a/library/test/compiler/stack.factor b/library/test/compiler/stack.factor index af6f937192..5e907b277f 100644 --- a/library/test/compiler/stack.factor +++ b/library/test/compiler/stack.factor @@ -7,16 +7,26 @@ USE: math USE: kernel ! Make sure that stack ops compile to correct code. -: compile-call ( quot -- word ) +: compile-1 ( quot -- word ) gensym [ swap define-compound ] keep dup compile execute ; -[ ] [ 1 [ drop ] compile-call ] unit-test -[ ] [ [ 1 drop ] compile-call ] unit-test -[ ] [ [ 1 2 2drop ] compile-call ] unit-test -[ ] [ 1 [ 2 2drop ] compile-call ] unit-test -[ ] [ 1 2 [ 2drop ] compile-call ] unit-test -[ 1 1 ] [ 1 [ dup ] compile-call ] unit-test -[ 1 1 ] [ [ 1 dup ] compile-call ] unit-test +[ ] [ 1 [ drop ] compile-1 ] unit-test +[ ] [ [ 1 drop ] compile-1 ] unit-test +[ ] [ [ 1 2 2drop ] compile-1 ] unit-test +[ ] [ 1 [ 2 2drop ] compile-1 ] unit-test +[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test +[ 2 1 ] [ [ 1 2 swap ] compile-1 ] unit-test +[ 2 1 ] [ 1 [ 2 swap ] compile-1 ] unit-test +[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test +[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test +[ 1 1 ] [ [ 1 dup ] compile-1 ] unit-test +[ 1 2 1 ] [ [ 1 2 over ] compile-1 ] unit-test +[ 1 2 1 ] [ 1 [ 2 over ] compile-1 ] unit-test +[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test +[ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-1 ] unit-test +[ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-1 ] unit-test +[ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-1 ] unit-test +[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test ! Test various kill combinations diff --git a/library/test/crashes.factor b/library/test/crashes.factor index c6a280851e..b7a70471df 100644 --- a/library/test/crashes.factor +++ b/library/test/crashes.factor @@ -1,18 +1,10 @@ IN: scratchpad -USE: errors -USE: kernel -USE: math -USE: namespaces -USE: parser -USE: strings -USE: test -USE: vectors -USE: lists -USE: words ! Various things that broke CFactor at various times. ! This should run without issue (and tests nothing useful) ! in Java Factor +USING: errors kernel lists math memory namespaces parser +prettyprint strings test vectors words ; "20 \"foo\" set" eval "garbage-collection" eval @@ -24,7 +16,7 @@ USE: words 10 "x" set [ -2 "x" get set-vector-length ] [ drop ] catch -[ "x" get vector-clone drop ] [ drop ] catch +[ "x" get clone drop ] [ drop ] catch 10 [ [ -1000000 ] [ drop ] catch ] times @@ -56,9 +48,12 @@ USE: words : callstack-overflow callstack-overflow f ; [ callstack-overflow ] unit-test-fails -[ [ cdr cons ] word-plist ] unit-test-fails +[ [ cdr cons ] word-props ] unit-test-fails ! Forgot to tag out of bounds index [ 1 { } vector-nth ] [ garbage-collection drop ] catch [ -1 { } set-vector-length ] [ garbage-collection drop ] catch [ 1 "" str-nth ] [ garbage-collection drop ] catch + +! ... and again +[ "" 10 str/ ] [ . ] catch diff --git a/library/test/dataflow.factor b/library/test/dataflow.factor index 07afb2df1e..0a769c7d73 100644 --- a/library/test/dataflow.factor +++ b/library/test/dataflow.factor @@ -15,19 +15,19 @@ USE: generic : dataflow-contains-op? ( object list -- ? ) #! Check if some dataflow node contains a given operation. - [ dupd node-op swap hash = ] some? nip ; + [ node-op swap hash = ] some-with? ; : dataflow-contains-param? ( object list -- ? ) #! Check if some dataflow node contains a given operation. [ - dupd [ + [ node-op get #label = [ node-param get dataflow-contains-param? ] [ node-param get = ] ifte ] bind - ] some? nip ; + ] some-with? ; [ t ] [ \ + [ 2 2 + ] dataflow dataflow-contains-param? >boolean @@ -41,7 +41,7 @@ USE: generic ! ] unit-test [ t ] [ - #ifte [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean + \ ifte [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean ] unit-test : dataflow-consume-d-len ( object -- n ) @@ -55,16 +55,16 @@ USE: generic [ t ] [ [ 2 ] dataflow car dataflow-produce-d-len 1 = ] unit-test : dataflow-ifte-node-consume-d ( list -- node ) - #ifte swap dataflow-contains-op? car [ node-consume-d get ] bind ; + \ ifte swap dataflow-contains-op? car [ node-consume-d get ] bind ; [ t ] [ - [ 2 [ swap ] [ nip "hi" ] ifte ] dataflow + [ [ swap ] [ nip "hi" ] ifte ] dataflow dataflow-ifte-node-consume-d length 1 = ] unit-test ! [ t ] [ ! [ { [ drop ] [ undefined-method ] [ drop ] [ undefined-method ] } generic ] dataflow -! #dispatch swap dataflow-contains-op? car [ +! \ dispatch swap dataflow-contains-op? car [ ! node-param get [ ! [ [ node-param get \ undefined-method = ] bind ] some? ! ] some? @@ -77,8 +77,8 @@ SYMBOL: #test [ 6 ] [ {{ - [ node-op | #test ] - [ node-param | 5 ] + [[ node-op #test ]] + [[ node-param 5 ]] }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow ] unit-test @@ -86,14 +86,14 @@ SYMBOL: #test [ 25 ] [ {{ - [ node-op | #test ] - [ node-param | 5 ] + [[ node-op #test ]] + [[ node-param 5 ]] }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow ] unit-test ! Somebody (cough) got the order of ifte nodes wrong. [ t ] [ - #ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car + \ ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car [ node-param get ] bind car car [ node-param get ] bind 1 = ] unit-test diff --git a/library/test/errors.factor b/library/test/errors.factor index 5e7a3fb4ac..b6193a06f4 100644 --- a/library/test/errors.factor +++ b/library/test/errors.factor @@ -25,4 +25,4 @@ USE: stdio [ [ "2 car" ] parse ] [ print-error ] catch -[ [ "\"\" { } vector-nth" ] parse ] [ type-check-error ] catch +! [ [ "\"\" { } vector-nth" ] parse ] [ type-check-error ] catch diff --git a/library/test/gadgets.factor b/library/test/gadgets.factor new file mode 100644 index 0000000000..7670858306 --- /dev/null +++ b/library/test/gadgets.factor @@ -0,0 +1,73 @@ +IN: scratchpad +USING: gadgets kernel lists math namespaces test ; + +[ t ] [ + [ + 2000 x set + 2000 y set + 2030 2040 rect> 10 20 300 400 inside? + ] with-scope +] unit-test +[ f ] [ + [ + 2000 x set + 2000 y set + 2500 2040 rect> 10 20 300 400 inside? + ] with-scope +] unit-test +[ t ] [ + [ + -10 x set + -20 y set + 0 0 rect> 10 20 300 400 inside? + ] with-scope +] unit-test +[ 11 11 41 41 ] [ + [ + 1 x set + 1 y set + 10 10 30 30 rect>screen + ] with-scope +] unit-test +[ t ] [ + [ + 0 x set + 0 y set + 0 0 rect> -10 -10 20 20 [ pick-up ] keep = + ] with-scope +] unit-test + +: funny-rect ( x -- rect ) + 10 10 30 + dup [ 255 0 0 ] foreground set-paint-property ; + +[ f ] [ + [ + 0 x set + 0 y set + 35 0 rect> + [ 10 30 50 70 ] [ funny-rect ] map + pick-up-list + ] with-scope +] unit-test + +[ 1 3 2 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y1 ] unit-test +[ 1 3 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/x2/y2 ] unit-test +[ 1 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x1/y1/y2 ] unit-test +[ 3 2 4 ] [ #{ 1 2 }# #{ 3 4 }# x2/y1/y2 ] unit-test + +[ -90 ] [ 10 10 -100 -200 shape-x ] unit-test +[ 20 ] [ 10 10 100 200 [ 20 30 rot move-shape ] keep shape-x ] unit-test +[ 30 ] [ 10 10 100 200 [ 20 30 rot move-shape ] keep shape-y ] unit-test +[ 20 ] [ 110 110 -100 -200 [ 20 30 rot move-shape ] keep shape-x ] unit-test +[ 30 ] [ 110 110 -100 -200 [ 20 30 rot move-shape ] keep shape-y ] unit-test +[ 10 ] [ 110 110 -100 -200 [ 400 400 rot resize-shape ] keep shape-x ] unit-test +[ 400 ] [ 110 110 -100 -200 [ 400 400 rot resize-shape ] keep shape-w ] unit-test + +[ t ] [ + [ + 100 x set + 100 y set + #{ 110 115 }# << line 0 0 100 150 >> inside? + ] with-scope +] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index d55899ffa1..ea3d5bd9f6 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -8,58 +8,7 @@ USE: math USE: words USE: lists USE: vectors - -TRAITS: test-traits -C: test-traits ; - -[ t ] [ test-traits? ] unit-test -[ f ] [ "hello" test-traits? ] unit-test -[ f ] [ test-traits? ] unit-test - -GENERIC: foo - -M: test-traits foo drop 12 ; - -TRAITS: another-test -C: another-test ; - -M: another-test foo drop 13 ; - -[ 12 ] [ foo ] unit-test -[ 13 ] [ foo ] unit-test - -TRAITS: quux -C: quux ; - -M: quux foo "foo" swap hash ; - -[ - "Hi" -] [ - [ - "Hi" "foo" set - ] extend foo -] unit-test - -TRAITS: ctr-test -C: ctr-test [ 5 "x" set ] extend ; - -[ - 5 -] [ - [ "x" get ] bind -] unit-test - -TRAITS: del1 -C: del1 ; - -GENERIC: super -M: del1 super drop 5 ; - -TRAITS: del2 -C: del2 ( delegate -- del2 ) [ delegate set ] extend ; - -[ 5 ] [ super ] unit-test +USE: alien GENERIC: class-of @@ -85,8 +34,8 @@ M: f bool>str drop "false" ; : str>bool [ - [ "true" | t ] - [ "false" | f ] + [[ "true" t ]] + [[ "false" f ]] ] assoc ; [ t ] [ t bool>str str>bool ] unit-test @@ -98,7 +47,7 @@ GENERIC: funny-length M: cons funny-length drop 0 ; M: nonempty-list funny-length length ; -[ 0 ] [ [ 1 2 | 3 ] funny-length ] unit-test +[ 0 ] [ [[ 1 [[ 2 3 ]] ]] funny-length ] unit-test [ 3 ] [ [ 1 2 3 ] funny-length ] unit-test [ "hello" funny-length ] unit-test-fails @@ -132,16 +81,29 @@ M: very-funny gooey sq ; [ fixnum ] [ fixnum fixnum class-and ] unit-test [ fixnum ] [ fixnum integer class-and ] unit-test [ fixnum ] [ integer fixnum class-and ] unit-test -[ vector fixnum class-and ] unit-test-fails +[ null ] [ vector fixnum class-and ] unit-test [ integer ] [ fixnum bignum class-or ] unit-test [ integer ] [ fixnum integer class-or ] unit-test [ rational ] [ ratio integer class-or ] unit-test [ number ] [ number object class-and ] unit-test [ number ] [ object number class-and ] unit-test -[ t ] [ del1 builtin-supertypes [ integer? ] all? ] unit-test - [ cons ] [ [ 1 2 ] class ] unit-test [ t ] [ \ generic \ compound class< ] unit-test [ f ] [ \ compound \ generic class< ] unit-test + +DEFER: bah +FORGET: bah +UNION: bah fixnum alien ; +[ bah ] [ fixnum alien class-or ] unit-test + +DEFER: complement-test +FORGET: complement-test +GENERIC: complement-test + +M: f complement-test drop "f" ; +M: general-t complement-test drop "general-t" ; + +[ "general-t" ] [ 5 complement-test ] unit-test +[ "f" ] [ f complement-test ] unit-test diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index d0cf97e16c..bffd04b84c 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -11,7 +11,7 @@ USE: vectors : silly-key/value dup dup * swap ; -1000 [ silly-key/value "testhash" get set-hash ] times* +1000 [ [ silly-key/value "testhash" get set-hash ] keep ] repeat [ f ] [ 1000 count [ silly-key/value "testhash" get hash = not ] subset ] @@ -22,13 +22,13 @@ unit-test unit-test [ f ] -[ [ 1 2 | 3 ] hashtable? ] +[ [[ 1 [[ 2 3 ]] ]] hashtable? ] unit-test ! Test some hashcodes. [ t ] [ [ 1 2 3 ] hashcode [ 1 2 3 ] hashcode = ] unit-test -[ t ] [ [ f | t ] hashcode [ f | t ] hashcode = ] unit-test +[ t ] [ [[ f t ]] hashcode [[ f t ]] hashcode = ] unit-test [ t ] [ [ 1 [ 2 3 ] 4 ] hashcode [ 1 [ 2 3 ] 4 ] hashcode = ] unit-test [ t ] [ 12 hashcode 12 hashcode = ] unit-test @@ -39,22 +39,48 @@ unit-test 16 "testhash" set -t #{ 2 3 } "testhash" get set-hash -f 100 fac "testhash" get set-hash +t #{ 2 3 }# "testhash" get set-hash +f 100000000000000000000000000 "testhash" get set-hash { } { [ { } ] } "testhash" get set-hash -[ t ] [ #{ 2 3 } "testhash" get hash ] unit-test -[ f ] [ 100 fac "testhash" get hash* cdr ] unit-test -[ { } ] [ { [ { } ] } vector-clone "testhash" get hash* cdr ] unit-test +[ t ] [ #{ 2 3 }# "testhash" get hash ] unit-test +[ f ] [ 100000000000000000000000000 "testhash" get hash* cdr ] unit-test +[ { } ] [ { [ { } ] } clone "testhash" get hash* cdr ] unit-test [ - [ "salmon" | "fish" ] - [ "crocodile" | "reptile" ] - [ "cow" | "mammal" ] - [ "visual basic" | "language" ] + [[ "salmon" "fish" ]] + [[ "crocodile" "reptile" ]] + [[ "cow" "mammal" ]] + [[ "visual basic" "language" ]] ] alist>hash "testhash" set [ f ] [ "visual basic" "testhash" get remove-hash "visual basic" "testhash" get hash* ] unit-test + +[ 4 ] [ + "hey" + {{ [[ "hey" 4 ]] [[ "whey" 5 ]] }} 2dup (hashcode) + >r buckets>list r> [ cdr ] times car assoc +] unit-test + +! Testing the hash element counting + + "counting" set +"value" "key" "counting" get set-hash +[ 1 ] [ "counting" get hash-size ] unit-test +"value" "key" "counting" get set-hash +[ 1 ] [ "counting" get hash-size ] unit-test +"key" "counting" get remove-hash +[ 0 ] [ "counting" get hash-size ] unit-test +"key" "counting" get remove-hash +[ 0 ] [ "counting" get hash-size ] unit-test + +[ t ] [ {{ }} dup = ] unit-test +[ f ] [ "xyz" {{ }} = ] unit-test +[ t ] [ {{ }} {{ }} = ] unit-test +[ f ] [ {{ [[ 1 3 ]] }} {{ }} = ] unit-test +[ f ] [ {{ }} {{ [[ 1 3 ]] }} = ] unit-test +[ t ] [ {{ [[ 1 3 ]] }} {{ [[ 1 3 ]] }} = ] unit-test +[ f ] [ {{ [[ 1 3 ]] }} {{ [[ 1 "hey" ]] }} = ] unit-test diff --git a/library/test/httpd/html.factor b/library/test/httpd/html.factor index 912b5fd3ff..cb84e8894e 100644 --- a/library/test/httpd/html.factor +++ b/library/test/httpd/html.factor @@ -23,7 +23,7 @@ USE: kernel [ [ "" - [ [ "icon" | "library/icons/File.png" ] ] + [ [[ "icon" "library/icons/File.png" ]] ] [ drop ] icon-tag ] with-string ] unit-test @@ -38,7 +38,7 @@ USE: kernel [ "car" ] [ [ - [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ] + [ [ "fg" 255 0 255 ] [[ "font" "Monospaced" ]] ] [ drop "car" write ] span-tag ] with-string @@ -56,7 +56,7 @@ USE: kernel [ [ "car" - [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ] + [ [ "fg" 255 0 255 ] [[ "font" "Monospaced" ]] ] html-write-attr ] with-string ] unit-test diff --git a/library/test/httpd/httpd.factor b/library/test/httpd/httpd.factor index 3ad02eee91..9d604042ba 100644 --- a/library/test/httpd/httpd.factor +++ b/library/test/httpd/httpd.factor @@ -20,16 +20,16 @@ USE: lists [ [ - [ "X-Spyware-Requested" | "yes" ] - [ "User-Agent" | "Internet Explorer 0.4alpha" ] + [[ "X-Spyware-Requested" "yes" ]] + [[ "User-Agent" "Internet Explorer 0.4alpha" ]] ] ] [ - [ [ "User-Agent" | "Internet Explorer 0.4alpha" ] ] + [ [[ "User-Agent" "Internet Explorer 0.4alpha" ]] ] "X-Spyware-Requested: yes" header-line ] unit-test -[ ] [ "404 not found" ] [ httpd-error ] test-word +[ ] [ "404 not found" httpd-error ] unit-test [ "arg" ] [ [ @@ -67,12 +67,12 @@ USE: lists [ ] [ "GET ../index.html" parse-request ] unit-test [ ] [ "POO" parse-request ] unit-test -[ [ [ "Foo" | "Bar" ] ] ] [ "Foo=Bar" query>alist ] unit-test +[ [ [[ "Foo" "Bar" ]] ] ] [ "Foo=Bar" query>alist ] unit-test -[ [ [ "Foo" | "Bar" ] [ "Baz" | "Quux" ] ] ] +[ [ [[ "Foo" "Bar" ]] [[ "Baz" "Quux" ]] ] ] [ "Foo=Bar&Baz=Quux" query>alist ] unit-test -[ [ [ "Baz" | " " ] ] ] +[ [ [[ "Baz" " " ]] ] ] [ "Baz=%20" query>alist ] unit-test [ [ [ "Foo" ] ] ] [ "Foo" query>alist ] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index bd4534aca8..24c4741313 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -11,43 +11,43 @@ USE: kernel USE: math-internals USE: generic -[ [ [ object object ] f ] ] -[ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ] -unit-test +! [ [ [ object object ] f ] ] +! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ] +! unit-test +! +! [ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ] +! [ +! [ [ vector ] [ cons vector cons integer object cons ] ] +! [ [ vector ] [ cons vector cons ] ] +! decompose +! ] unit-test +! +! [ [ [ object ] [ object ] ] ] +! [ +! [ [ object number ] [ object ] ] +! [ [ object number ] [ object ] ] +! decompose +! ] unit-test -[ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ] -[ - [ [ vector ] [ cons vector cons integer object cons ] ] - [ [ vector ] [ cons vector cons ] ] - decompose -] unit-test - -[ [ [ object ] [ object ] ] ] -[ - [ [ object number ] [ object ] ] - [ [ object number ] [ object ] ] - decompose -] unit-test - -: old-effect ( [ in-types out-types ] -- [ in | out ] ) +: old-effect ( [ in-types out-types ] -- [[ in out ]] ) uncons car length >r length r> cons ; -[ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer old-effect ] unit-test -[ [ 1 | 2 ] ] [ [ dup ] infer old-effect ] unit-test +[ [[ 0 2 ]] ] [ [ 2 "Hello" ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ dup ] infer old-effect ] unit-test -[ [ 1 | 2 ] ] [ [ [ dup ] call ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ [ dup ] call ] infer old-effect ] unit-test [ [ call ] infer old-effect ] unit-test-fails -[ [ 2 | 4 ] ] [ [ 2dup ] infer old-effect ] unit-test -[ [ 2 | 0 ] ] [ [ vector-push ] infer old-effect ] unit-test +[ [[ 2 4 ]] ] [ [ 2dup ] infer old-effect ] unit-test +[ [[ 2 0 ]] ] [ [ vector-push ] infer old-effect ] unit-test -[ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test +[ [[ 1 0 ]] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test [ [ ifte ] infer old-effect ] unit-test-fails [ [ [ ] ifte ] infer old-effect ] unit-test-fails [ [ [ 2 ] [ ] ifte ] infer old-effect ] unit-test-fails -[ [ 4 | 3 ] ] [ [ [ rot ] [ -rot ] ifte ] infer old-effect ] unit-test +[ [[ 4 3 ]] ] [ [ [ rot ] [ -rot ] ifte ] infer old-effect ] unit-test -[ [ 4 | 3 ] ] [ +[ [[ 4 3 ]] ] [ [ [ [ swap 3 ] [ nip 5 5 ] ifte @@ -57,14 +57,14 @@ unit-test ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ dup [ ] when ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ dup [ dup fixnum* ] when ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ [ dup fixnum* ] when ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ dup [ ] when ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ dup [ dup fixnum* ] when ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ [ dup fixnum* ] when ] infer old-effect ] unit-test -[ [ 1 | 0 ] ] [ [ [ drop ] when* ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ [ { { [ ] } } ] unless* ] infer old-effect ] unit-test +[ [[ 1 0 ]] ] [ [ [ drop ] when* ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ [ { { [ ] } } ] unless* ] infer old-effect ] unit-test -[ [ 0 | 1 ] ] [ +[ [[ 0 1 ]] ] [ [ [ 2 2 fixnum+ ] dup [ ] when call ] infer old-effect ] unit-test @@ -79,12 +79,12 @@ unit-test : simple-recursion-1 dup [ simple-recursion-1 ] [ ] ifte ; -[ [ 1 | 1 ] ] [ [ simple-recursion-1 ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ simple-recursion-1 ] infer old-effect ] unit-test : simple-recursion-2 dup [ ] [ simple-recursion-2 ] ifte ; -[ [ 1 | 1 ] ] [ [ simple-recursion-2 ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ simple-recursion-2 ] infer old-effect ] unit-test ! : bad-recursion-1 ! dup [ drop bad-recursion-1 5 ] [ ] ifte ; @@ -101,10 +101,10 @@ unit-test : funny-recursion dup [ funny-recursion 1 ] [ 2 ] ifte drop ; -[ [ 1 | 1 ] ] [ [ funny-recursion ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ funny-recursion ] infer old-effect ] unit-test ! Simple combinators -[ [ 1 | 2 ] ] [ [ [ car ] keep cdr ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ [ car ] keep cdr ] infer old-effect ] unit-test ! Mutual recursion DEFER: foe @@ -127,12 +127,12 @@ DEFER: foe 2drop f ] ifte ; -[ [ 2 | 1 ] ] [ [ fie ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ fie ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ foe ] infer old-effect ] unit-test ! This form should not have a stack effect -: bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; -[ [ bad-bin ] infer old-effect ] unit-test-fails +! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; +! [ [ bad-bin ] infer old-effect ] unit-test-fails : nested-when ( -- ) t [ @@ -141,7 +141,7 @@ DEFER: foe ] when ] when ; -[ [ 0 | 0 ] ] [ [ nested-when ] infer old-effect ] unit-test +[ [[ 0 0 ]] ] [ [ nested-when ] infer old-effect ] unit-test : nested-when* ( -- ) [ @@ -150,55 +150,55 @@ DEFER: foe ] when* ] when* ; -[ [ 1 | 0 ] ] [ [ nested-when* ] infer old-effect ] unit-test +[ [[ 1 0 ]] ] [ [ nested-when* ] infer old-effect ] unit-test SYMBOL: sym-test -[ [ 0 | 1 ] ] [ [ sym-test ] infer old-effect ] unit-test +[ [[ 0 1 ]] ] [ [ sym-test ] infer old-effect ] unit-test -[ [ 2 | 0 ] ] [ [ set-vector-length ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ 2list ] infer old-effect ] unit-test -[ [ 3 | 1 ] ] [ [ 3list ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ append ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ swons ] infer old-effect ] unit-test -[ [ 1 | 2 ] ] [ [ uncons ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ unit ] infer old-effect ] unit-test -[ [ 1 | 2 ] ] [ [ unswons ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ last* ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ last ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ list? ] infer old-effect ] unit-test +[ [[ 2 0 ]] ] [ [ set-vector-length ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ 2list ] infer old-effect ] unit-test +[ [[ 3 1 ]] ] [ [ 3list ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ append ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ swons ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ uncons ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ unit ] infer old-effect ] unit-test +[ [[ 1 2 ]] ] [ [ unswons ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ last* ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ last ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ list? ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ length ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ reverse ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ contains? ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ tree-contains? ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ remove ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ prune ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ length ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ reverse ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ tree-contains? ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ bitor ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ bitand ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ bitxor ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ mod ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ /i ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ /f ] infer old-effect ] unit-test -[ [ 2 | 2 ] ] [ [ /mod ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ + ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ - ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ * ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ / ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ < ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ <= ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ > ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ >= ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ number= ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ bitor ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ bitand ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ bitxor ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ mod ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ /i ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ /f ] infer old-effect ] unit-test +[ [[ 2 2 ]] ] [ [ /mod ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ + ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ - ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ * ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ / ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ < ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ <= ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ > ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ >= ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ number= ] infer old-effect ] unit-test -[ [ 2 | 1 ] ] [ [ = ] infer old-effect ] unit-test +[ [[ 2 1 ]] ] [ [ = ] infer old-effect ] unit-test -[ [ 1 | 0 ] ] [ [ >n ] infer old-effect ] unit-test -[ [ 0 | 1 ] ] [ [ n> ] infer old-effect ] unit-test +[ [[ 1 0 ]] ] [ [ >n ] infer old-effect ] unit-test +[ [[ 0 1 ]] ] [ [ n> ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ get ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ get ] infer old-effect ] unit-test : terminator-branch dup [ @@ -207,18 +207,23 @@ SYMBOL: sym-test not-a-number ] ifte ; -[ [ 1 | 1 ] ] [ [ terminator-branch ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ terminator-branch ] infer old-effect ] unit-test -[ [ 1 | 1 ] ] [ [ str>number ] infer old-effect ] unit-test +[ [[ 1 1 ]] ] [ [ str>number ] infer old-effect ] unit-test ! Type inference -[ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test -[ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test -[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test -[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test -[ [ [ general-list ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test -[ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test +! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test +! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test +! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test +! [ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test +! [ [ [ general-list ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test ! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test -[ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test +! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test + +! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test +! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test +! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test +! +! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test diff --git a/library/test/interpreter.factor b/library/test/interpreter.factor index e4cd6371da..52806eaf0f 100644 --- a/library/test/interpreter.factor +++ b/library/test/interpreter.factor @@ -33,7 +33,7 @@ USE: kernel ] unit-test [ { "Hey" "there" } ] [ - [ [ "Hey" | "there" ] uncons ] test-interpreter + [ [[ "Hey" "there" ]] uncons ] test-interpreter ] unit-test [ { t } ] [ @@ -44,8 +44,8 @@ USE: kernel [ "XYZ" "XuZ" = ] test-interpreter ] unit-test -[ { #{ 1 1.5 } { } #{ 1 1.5 } { } } ] [ - [ #{ 1 1.5 } { } 2dup ] test-interpreter +[ { #{ 1 1.5 }# { } #{ 1 1.5 }# { } } ] [ + [ #{ 1 1.5 }# { } 2dup ] test-interpreter ] unit-test [ { 4 } ] [ diff --git a/library/test/io/io.factor b/library/test/io/io.factor index 0d02dba5b3..b7e20607d4 100644 --- a/library/test/io/io.factor +++ b/library/test/io/io.factor @@ -9,7 +9,7 @@ USE: math [ 4 ] [ "/library/test/io/no-trailing-eol.factor" run-resource ] unit-test : lines-test ( stream -- line1 line2 ) - [ read read ] with-stream ; + [ read-line read-line ] with-stream ; [ "This is a line." @@ -29,7 +29,7 @@ USE: math "This is a line.\rThis is another line.\r" ] [ "/library/test/io/mac-os-eol.txt" - [ 500 read# ] with-stream + [ 500 read ] with-stream ] unit-test [ @@ -42,4 +42,4 @@ USE: math ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test -[ -1 read# ] unit-test-fails +[ -1 read ] unit-test-fails diff --git a/library/test/line-editor.factor b/library/test/line-editor.factor new file mode 100644 index 0000000000..19ac2ecf4b --- /dev/null +++ b/library/test/line-editor.factor @@ -0,0 +1,71 @@ +IN: scratchpad +USE: namespaces +USE: line-editor +USE: test +USE: strings +USE: kernel +USE: prettyprint + + "editor" set + +[ "Hello world" ] [ + "Hello world" 0 "editor" get [ line-insert ] bind + "editor" get [ line-text get ] bind +] unit-test + +[ t ] [ + "editor" get [ caret get ] bind + "Hello world" str-length = +] unit-test + +[ "Hello, crazy world" ] [ + "editor" get [ 0 caret set ] bind + ", crazy" 5 "editor" get [ line-insert ] bind + "editor" get [ line-text get ] bind +] unit-test + +[ 0 ] [ "editor" get [ caret get ] bind ] unit-test + +[ "Hello, crazy world" ] [ + "editor" get [ 5 caret set "Hello world" line-text set ] bind + ", crazy" 5 "editor" get [ line-insert ] bind + "editor" get [ line-text get ] bind +] unit-test + +[ "Hello, crazy" ] [ + "editor" get [ caret get line-text get str-head ] bind +] unit-test + +[ 0 ] +[ + [ + 0 caret set + 3 2 caret-remove + caret get + ] with-scope +] unit-test + +[ 3 ] +[ + [ + 4 caret set + 3 6 caret-remove + caret get + ] with-scope +] unit-test + +[ 5 ] +[ + [ + 8 caret set + 3 3 caret-remove + caret get + ] with-scope +] unit-test + +[ "Hellorld" ] +[ + "editor" get [ 0 caret set "Hello world" line-text set ] bind + 4 3 "editor" get [ line-remove ] bind + "editor" get [ line-text get ] bind +] unit-test diff --git a/library/test/lists/assoc.factor b/library/test/lists/assoc.factor index 386018deec..c758313cab 100644 --- a/library/test/lists/assoc.factor +++ b/library/test/lists/assoc.factor @@ -5,16 +5,16 @@ USE: namespaces USE: test [ - [ "monkey" | 1 ] - [ "banana" | 2 ] - [ "Java" | 3 ] - [ t | "true" ] - [ f | "false" ] - [ [ 1 2 ] | [ 2 1 ] ] + [[ "monkey" 1 ]] + [[ "banana" 2 ]] + [[ "Java" 3 ]] + [[ t "true" ]] + [[ f "false" ]] + [[ [ 1 2 ] [ 2 1 ] ]] ] "assoc" set [ t ] [ "assoc" get assoc? ] unit-test -[ f ] [ [ 1 2 3 | 4 ] assoc? ] unit-test +[ f ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] assoc? ] unit-test [ f ] [ "assoc" assoc? ] unit-test [ f ] [ "monkey" f assoc ] unit-test @@ -28,9 +28,9 @@ USE: test [ "is great" ] [ "Java" "assoc" get assoc ] unit-test [ - [ "one" | 1 ] - [ "two" | 2 ] - [ "four" | 4 ] + [[ "one" 1 ]] + [[ "two" 2 ]] + [[ "four" 4 ]] ] "value-alist" set [ diff --git a/library/test/lists/combinators.factor b/library/test/lists/combinators.factor index 54e4650b3f..bbf0875e48 100644 --- a/library/test/lists/combinators.factor +++ b/library/test/lists/combinators.factor @@ -40,3 +40,5 @@ USE: strings [ f ] [ [ 1 2 3 ] [ 10 > ] some? ] unit-test [ [ 2 3 4 ] ] [ 1 [ 1 2 3 ] [ + ] map-with ] unit-test + +[ [ 3 ] ] [ 2 [ 1 2 3 ] [ < ] subset-with ] unit-test diff --git a/library/test/lists/cons.factor b/library/test/lists/cons.factor index 47bd64dad4..f152daa4fb 100644 --- a/library/test/lists/cons.factor +++ b/library/test/lists/cons.factor @@ -7,28 +7,28 @@ USE: test [ f ] [ f cons? ] unit-test [ f ] [ t cons? ] unit-test -[ t ] [ [ t | f ] cons? ] unit-test +[ t ] [ [[ t f ]] cons? ] unit-test -[ [ 1 | 2 ] ] [ 1 2 cons ] unit-test +[ [[ 1 2 ]] ] [ 1 2 cons ] unit-test [ [ 1 ] ] [ 1 f cons ] unit-test -[ [ 1 | 2 ] ] [ 2 1 swons ] unit-test +[ [[ 1 2 ]] ] [ 2 1 swons ] unit-test [ [ 1 ] ] [ f 1 swons ] unit-test [ [ [ [ ] ] ] ] [ [ ] unit unit ] unit-test -[ 1 ] [ [ 1 | 2 ] car ] unit-test -[ 2 ] [ [ 1 | 2 ] cdr ] unit-test +[ 1 ] [ [[ 1 2 ]] car ] unit-test +[ 2 ] [ [[ 1 2 ]] cdr ] unit-test -[ 1 2 ] [ [ 1 | 2 ] uncons ] unit-test +[ 1 2 ] [ [[ 1 2 ]] uncons ] unit-test [ 1 [ 2 ] ] [ [ 1 2 ] uncons ] unit-test -[ 1 2 ] [ [ 2 | 1 ] unswons ] unit-test +[ 1 2 ] [ [[ 2 1 ]] unswons ] unit-test [ [ 2 ] 1 ] [ [ 1 2 ] unswons ] unit-test [ [ 1 2 ] ] [ 1 2 2list ] unit-test [ [ 1 2 3 ] ] [ 1 2 3 3list ] unit-test -[ 1 3 ] [ [ 1 | 2 ] [ 3 | 4 ] 2car ] unit-test -[ 2 4 ] [ [ 1 | 2 ] [ 3 | 4 ] 2cdr ] unit-test -[ 1 3 2 4 ] [ [ 1 | 2 ] [ 3 | 4 ] 2uncons ] unit-test +[ 1 3 ] [ [[ 1 2 ]] [[ 3 4 ]] 2car ] unit-test +[ 2 4 ] [ [[ 1 2 ]] [[ 3 4 ]] 2cdr ] unit-test +[ 1 3 2 4 ] [ [[ 1 2 ]] [[ 3 4 ]] 2uncons ] unit-test diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index d0ce247a65..212e537da5 100644 --- a/library/test/lists/lists.factor +++ b/library/test/lists/lists.factor @@ -10,7 +10,7 @@ USE: strings [ [ 1 ] ] [ [ 1 ] [ ] append ] unit-test [ [ 2 ] ] [ [ ] [ 2 ] append ] unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test -[ [ 1 2 3 | 4 ] ] [ [ 1 2 3 ] 4 append ] unit-test +[ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] ] [ [ 1 2 3 ] 4 append ] unit-test [ f ] [ 3 [ ] contains? ] unit-test [ f ] [ 3 [ 1 2 ] contains? ] unit-test @@ -19,11 +19,11 @@ USE: strings [ [ 3 ] ] [ [ 3 ] last* ] unit-test [ [ 3 ] ] [ [ 1 2 3 ] last* ] unit-test -[ [ 3 | 4 ] ] [ [ 1 2 3 | 4 ] last* ] unit-test +[ [[ 3 4 ]] ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] last* ] unit-test [ 3 ] [ [ 3 ] last ] unit-test [ 3 ] [ [ 1 2 3 ] last ] unit-test -[ 3 ] [ [ 1 2 3 | 4 ] last ] unit-test +[ 3 ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] last ] unit-test [ 0 ] [ [ ] length ] unit-test [ 3 ] [ [ 1 2 3 ] length ] unit-test @@ -31,7 +31,7 @@ USE: strings [ t ] [ f list? ] unit-test [ f ] [ t list? ] unit-test [ t ] [ [ 1 2 ] list? ] unit-test -[ f ] [ [ 1 | 2 ] list? ] unit-test +[ f ] [ [[ 1 2 ]] list? ] unit-test [ [ ] ] [ 1 [ ] remove ] unit-test [ [ ] ] [ 1 [ 1 ] remove ] unit-test @@ -49,7 +49,7 @@ USE: strings [ f ] [ 3 [ 1 [ 3 ] 2 ] tree-contains? not ] unit-test [ f ] [ 1 [ [ [ 1 ] ] 2 ] tree-contains? not ] unit-test [ f ] [ 2 [ 1 2 ] tree-contains? not ] unit-test -[ f ] [ 3 [ 1 2 | 3 ] tree-contains? not ] unit-test +[ f ] [ 3 [[ 1 [[ 2 3 ]] ]] tree-contains? not ] unit-test [ [ ] ] [ 0 count ] unit-test [ [ ] ] [ -10 count ] unit-test @@ -60,3 +60,5 @@ USE: strings [ [ 1 ] ] [ [ 1 ] 1 head ] unit-test [ [ 1 ] 2 head ] unit-test-fails [ [ 1 2 3 ] ] [ [ 1 2 3 4 ] 3 head ] unit-test + +[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] difference ] unit-test diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index e539095b9f..2f26ad1bd6 100644 --- a/library/test/lists/namespaces.factor +++ b/library/test/lists/namespaces.factor @@ -3,11 +3,11 @@ USE: lists USE: namespaces USE: test -[ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word -[ [ 1 | 2 ] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word -[ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word +[ [ 1 ] ] [ 1 f "x" set "x" cons@ "x" get ] unit-test +[ [[ 1 2 ]] ] [ 1 2 "x" set "x" cons@ "x" get ] unit-test +[ [ 1 2 ] ] [ 1 [ 2 ] "x" set "x" cons@ "x" get ] unit-test -[ [ [ 2 | 3 ] [ 1 | 2 ] ] ] [ +[ [ [[ 2 3 ]] [[ 1 2 ]] ] ] [ "x" off 2 1 "x" [ acons ] change 3 2 "x" [ acons ] change "x" get ] unit-test @@ -29,9 +29,9 @@ USE: test "x" get ] unit-test -[ [ "xyz" #{ 3 2 } 1/5 [ { } ] ] ] [ +[ [ "xyz" #{ 3 2 }# 1/5 [ { } ] ] ] [ [ "xyz" , "xyz" unique, - #{ 3 2 } , #{ 3 2 } unique, + #{ 3 2 }# , #{ 3 2 }# unique, 1/5 , 1/5 unique, [ { } unique, ] make-list , ] make-list ] unit-test diff --git a/library/test/math/complex.factor b/library/test/math/complex.factor index 0ee0b8bcb7..4f41d25ae1 100644 --- a/library/test/math/complex.factor +++ b/library/test/math/complex.factor @@ -3,47 +3,50 @@ USE: kernel USE: math USE: test -[ f ] [ #{ 5 12.5 } 5 ] [ = ] test-word -[ t ] [ #{ 1.0 2.0 } #{ 1 2 } ] [ = ] test-word -[ f ] [ #{ 1.0 2.3 } #{ 1 2 } ] [ = ] test-word +[ 1 #{ 0 1 }# rect> ] unit-test-fails +[ #{ 0 1 }# 1 rect> ] unit-test-fails -[ #{ 2 5 } ] [ 2 5 ] [ rect> ] test-word -[ 2 5 ] [ #{ 2 5 } ] [ >rect ] test-word -[ #{ 1/2 1 } ] [ 1/2 i ] [ + ] test-word -[ #{ 1/2 1 } ] [ i 1/2 ] [ + ] test-word -[ t ] [ #{ 11 64 } #{ 11 64 } ] [ = ] test-word -[ #{ 2 1 } ] [ 2 i ] [ + ] test-word -[ #{ 2 1 } ] [ i 2 ] [ + ] test-word -[ #{ 5 4 } ] [ #{ 2 2 } #{ 3 2 } ] [ + ] test-word -[ 5 ] [ #{ 2 2 } #{ 3 -2 } ] [ + ] test-word -[ #{ 1.0 1 } ] [ 1.0 i ] [ + ] test-word +[ f ] [ #{ 5 12.5 }# 5 = ] unit-test +[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# = ] unit-test +[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# = ] unit-test -[ #{ 1/2 -1 } ] [ 1/2 i ] [ - ] test-word -[ #{ -1/2 1 } ] [ i 1/2 ] [ - ] test-word -[ #{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word -[ #{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word -[ #{ 1/5 1/4 } ] [ #{ 3/5 1/2 } #{ 2/5 1/4 } ] [ - ] test-word -[ 4 ] [ #{ 5 10/3 } #{ 1 10/3 } ] [ - ] test-word -[ #{ 1.0 -1 } ] [ 1.0 i ] [ - ] test-word +[ #{ 2 5 }# ] [ 2 5 rect> ] unit-test +[ 2 5 ] [ #{ 2 5 }# >rect ] unit-test +[ #{ 1/2 1 }# ] [ 1/2 i + ] unit-test +[ #{ 1/2 1 }# ] [ i 1/2 + ] unit-test +[ t ] [ #{ 11 64 }# #{ 11 64 }# = ] unit-test +[ #{ 2 1 }# ] [ 2 i + ] unit-test +[ #{ 2 1 }# ] [ i 2 + ] unit-test +[ #{ 5 4 }# ] [ #{ 2 2 }# #{ 3 2 }# + ] unit-test +[ 5 ] [ #{ 2 2 }# #{ 3 -2 }# + ] unit-test +[ #{ 1.0 1 }# ] [ 1.0 i + ] unit-test -[ #{ 0 1 } ] [ i 1 ] [ * ] test-word -[ #{ 0 1 } ] [ 1 i ] [ * ] test-word -[ #{ 0 1.0 } ] [ 1.0 i ] [ * ] test-word -[ -1 ] [ i i ] [ * ] test-word -[ #{ 0 1 } ] [ 1 i ] [ * ] test-word -[ #{ 0 1 } ] [ i 1 ] [ * ] test-word -[ #{ 0 1/2 } ] [ 1/2 i ] [ * ] test-word -[ #{ 0 1/2 } ] [ i 1/2 ] [ * ] test-word -[ 2 ] [ #{ 1 1 } #{ 1 -1 } ] [ * ] test-word -[ 1 ] [ i -i ] [ * ] test-word +[ #{ 1/2 -1 }# ] [ 1/2 i - ] unit-test +[ #{ -1/2 1 }# ] [ i 1/2 - ] unit-test +[ #{ 1/3 1/4 }# ] [ 1 3 / 1 2 / i * + 1 4 / i * - ] unit-test +[ #{ -1/3 -1/4 }# ] [ 1 4 / i * 1 3 / 1 2 / i * + - ] unit-test +[ #{ 1/5 1/4 }# ] [ #{ 3/5 1/2 }# #{ 2/5 1/4 }# - ] unit-test +[ 4 ] [ #{ 5 10/3 }# #{ 1 10/3 }# - ] unit-test +[ #{ 1.0 -1 }# ] [ 1.0 i - ] unit-test -[ -1 ] [ i -i ] [ / ] test-word -[ #{ 0 1 } ] [ 1 -i ] [ / ] test-word -[ t ] [ #{ 12 13 } #{ 13 14 } / #{ 13 14 } * #{ 12 13 } ] [ = ] test-word +[ #{ 0 1 }# ] [ i 1 * ] unit-test +[ #{ 0 1 }# ] [ 1 i * ] unit-test +[ #{ 0 1.0 }# ] [ 1.0 i * ] unit-test +[ -1 ] [ i i * ] unit-test +[ #{ 0 1 }# ] [ 1 i * ] unit-test +[ #{ 0 1 }# ] [ i 1 * ] unit-test +[ #{ 0 1/2 }# ] [ 1/2 i * ] unit-test +[ #{ 0 1/2 }# ] [ i 1/2 * ] unit-test +[ 2 ] [ #{ 1 1 }# #{ 1 -1 }# * ] unit-test +[ 1 ] [ i -i * ] unit-test -[ #{ -3 4 } ] [ #{ 3 -4 } ] [ neg ] test-word +[ -1 ] [ i -i / ] unit-test +[ #{ 0 1 }# ] [ 1 -i / ] unit-test +[ t ] [ #{ 12 13 }# #{ 13 14 }# / #{ 13 14 }# * #{ 12 13 }# = ] unit-test -[ 5 ] [ #{ 3 4 } abs ] unit-test +[ #{ -3 4 }# ] [ #{ 3 -4 }# neg ] unit-test + +[ 5 ] [ #{ 3 4 }# abs ] unit-test [ 5 ] [ -5.0 abs ] unit-test ! Make sure arguments are sane diff --git a/library/test/math/irrational.factor b/library/test/math/irrational.factor index 41daa8b4c6..75985eabd7 100644 --- a/library/test/math/irrational.factor +++ b/library/test/math/irrational.factor @@ -9,7 +9,7 @@ USE: test [ 0.25 ] [ 2 -2 fpow ] unit-test [ 4.0 ] [ 16 sqrt ] unit-test -[ #{ 0 4.0 } ] [ -16 sqrt ] unit-test +[ #{ 0 4.0 }# ] [ -16 sqrt ] unit-test [ 4.0 ] [ 2 2 ^ ] unit-test [ 0.25 ] [ 2 -2 ^ ] unit-test diff --git a/library/test/math/math-combinators.factor b/library/test/math/math-combinators.factor index 6587bdc0bc..232248e079 100644 --- a/library/test/math/math-combinators.factor +++ b/library/test/math/math-combinators.factor @@ -2,19 +2,12 @@ IN: scratchpad USE: kernel USE: math USE: test +USE: namespaces -[ 0 1 2 3 4 ] [ 5 [ ] times* ] unit-test -[ ] [ 0 [ ] times* ] unit-test +[ ] [ 5 [ ] times ] unit-test +[ ] [ 0 [ ] times ] unit-test +[ ] [ -1 [ ] times ] unit-test -[ #{ 1 1 } ] [ #{ 2 3 } #{ 1 0 } 2times-succ ] unit-test -[ #{ 1 2 } ] [ #{ 2 3 } #{ 1 1 } 2times-succ ] unit-test -[ #{ 2 0 } ] [ #{ 3 3 } #{ 1 2 } 2times-succ ] unit-test -[ #{ 2 1 } ] [ #{ 3 3 } #{ 2 0 } 2times-succ ] unit-test -[ #{ 2 0 } ] [ #{ 2 2 } #{ 1 1 } 2times-succ ] unit-test - -[ #{ 0 0 } #{ 0 1 } #{ 1 0 } #{ 1 1 } ] -[ #{ 2 2 } [ ] 2times* ] unit-test - -[ #{ 0 0 } #{ 0 1 } #{ 0 2 } #{ 1 0 } #{ 1 1 } #{ 1 2 } - #{ 2 0 } #{ 2 1 } #{ 2 2 } ] -[ #{ 3 3 } [ ] 2times* ] unit-test +[ ] [ 5 [ ] repeat ] unit-test +[ [ 0 1 2 3 4 ] ] [ [ 5 [ dup , ] repeat ] make-list ] unit-test +[ [ ] ] [ [ -1 [ dup , ] repeat ] make-list ] unit-test diff --git a/library/test/memory.factor b/library/test/memory.factor new file mode 100644 index 0000000000..dcabd54094 --- /dev/null +++ b/library/test/memory.factor @@ -0,0 +1,14 @@ +IN: scratchpad +USE: kernel +USE: math +USE: memory +USE: generic +USE: lists + +num-types [ + [ + (instances) [ + class drop + ] each + ] keep +] repeat diff --git a/library/test/parse-number.factor b/library/test/parse-number.factor index 42555574c0..26a334f9ff 100644 --- a/library/test/parse-number.factor +++ b/library/test/parse-number.factor @@ -6,134 +6,108 @@ USE: test USE: unparser [ f ] -[ f ] -[ parse-number ] -test-word +[ f parse-number ] +unit-test [ f ] -[ "12345abcdef" ] -[ parse-number ] -test-word +[ "12345abcdef" parse-number ] +unit-test [ t ] -[ "-12" ] -[ parse-number 0 < ] -test-word +[ "-12" parse-number 0 < ] +unit-test [ f ] -[ "--12" ] -[ parse-number ] -test-word +[ "--12" parse-number ] +unit-test [ f ] -[ "-" ] -[ parse-number ] -test-word +[ "-" parse-number ] +unit-test [ f ] -[ "e" ] -[ parse-number ] -test-word +[ "e" parse-number ] +unit-test [ "100.0" ] -[ "1.0e2" ] -[ parse-number unparse ] -test-word +[ "1.0e2" parse-number unparse ] +unit-test [ "-100.0" ] -[ "-1.0e2" ] -[ parse-number unparse ] -test-word +[ "-1.0e2" parse-number unparse ] +unit-test [ "0.01" ] -[ "1.0e-2" ] -[ parse-number unparse ] -test-word +[ "1.0e-2" parse-number unparse ] +unit-test [ "-0.01" ] -[ "-1.0e-2" ] -[ parse-number unparse ] -test-word +[ "-1.0e-2" parse-number unparse ] +unit-test [ f ] -[ "-1e-2e4" ] -[ parse-number ] -test-word +[ "-1e-2e4" parse-number ] +unit-test [ "3.14" ] -[ "3.14" ] -[ parse-number unparse ] -test-word +[ "3.14" parse-number unparse ] +unit-test [ f ] -[ "." ] -[ parse-number ] -test-word +[ "." parse-number ] +unit-test [ f ] -[ ".e" ] -[ parse-number ] -test-word +[ ".e" parse-number ] +unit-test [ "101.0" ] -[ "1.01e2" ] -[ parse-number unparse ] -test-word +[ "1.01e2" parse-number unparse ] +unit-test [ "-101.0" ] -[ "-1.01e2" ] -[ parse-number unparse ] -test-word +[ "-1.01e2" parse-number unparse ] +unit-test [ "1.01" ] -[ "101.0e-2" ] -[ parse-number unparse ] -test-word +[ "101.0e-2" parse-number unparse ] +unit-test [ "-1.01" ] -[ "-101.0e-2" ] -[ parse-number unparse ] -test-word +[ "-101.0e-2" parse-number unparse ] +unit-test [ 5 ] -[ "10/2" ] -[ parse-number ] -test-word +[ "10/2" parse-number ] +unit-test [ -5 ] -[ "-10/2" ] -[ parse-number ] -test-word +[ "-10/2" parse-number ] +unit-test [ -5 ] -[ "10/-2" ] -[ parse-number ] -test-word +[ "10/-2" parse-number ] +unit-test [ 5 ] -[ "-10/-2" ] -[ parse-number ] -test-word +[ "-10/-2" parse-number ] +unit-test [ f ] -[ "10.0/2" ] -[ parse-number ] -test-word +[ "10.0/2" parse-number ] +unit-test [ f ] -[ "1e1/2" ] -[ parse-number ] -test-word +[ "1e1/2" parse-number ] +unit-test [ f ] -[ "e/2" ] -[ parse-number ] -test-word +[ "e/2" parse-number ] +unit-test [ "33/100" ] -[ "66/200" ] -[ parse-number unparse ] -test-word +[ "66/200" parse-number unparse ] +unit-test [ "12" bin> ] unit-test-fails [ "fdsf" bin> ] unit-test-fails diff --git a/library/test/parser.factor b/library/test/parser.factor index 182f4300f6..c18adda95b 100644 --- a/library/test/parser.factor +++ b/library/test/parser.factor @@ -7,58 +7,65 @@ USE: kernel USE: generic USE: words +[ CHAR: a 1 ] +[ 0 "abcd" next-char ] unit-test + +[ CHAR: \s 6 ] +[ 1 "\\u0020hello" next-escape ] unit-test + +[ CHAR: \n 2 ] +[ 1 "\\nhello" next-escape ] unit-test + +[ CHAR: \s 6 ] +[ 0 "\\u0020hello" next-char ] unit-test + [ [ 1 [ 2 [ 3 ] 4 ] 5 ] ] -[ "1\n[\n2\n[\n3\n]\n4\n]\n5" ] -[ parse ] -test-word +[ "1\n[\n2\n[\n3\n]\n4\n]\n5" parse ] +unit-test [ [ t t f f ] ] -[ "t t f f" ] -[ parse ] -test-word +[ "t t f f" parse ] +unit-test [ [ "hello world" ] ] -[ "\"hello world\"" ] -[ parse ] -test-word +[ "\"hello world\"" parse ] +unit-test [ [ "\n\r\t\\" ] ] -[ "\"\\n\\r\\t\\\\\"" ] -[ parse ] -test-word +[ "\"\\n\\r\\t\\\\\"" parse ] +unit-test [ "hello world" ] -[ "IN: scratchpad : hello \"hello world\" ;" ] -[ parse call "USE: scratchpad hello" eval ] -test-word +[ + "IN: scratchpad : hello \"hello world\" ;" + parse call "USE: scratchpad hello" eval +] unit-test [ ] -[ "! This is a comment, people." ] -[ parse call ] -test-word +[ "! This is a comment, people." parse call ] +unit-test [ ] -[ "( This is a comment, people. )" ] -[ parse call ] -test-word +[ "( This is a comment, people. )" parse call ] +unit-test ! Test escapes [ [ " " ] ] -[ "\"\\u0020\"" ] -[ parse ] -test-word +[ "\"\\u0020\"" parse ] +unit-test [ [ "'" ] ] -[ "\"\\u0027\"" ] -[ parse ] -test-word +[ "\"\\u0027\"" parse ] +unit-test + +[ "\\u123" parse ] unit-test-fails ! Test improper lists -[ 2 ] [ "[ 1 | 2 ]" parse car cdr ] unit-test -[ "hello" ] [ "[ 1 | \"hello\" ]" parse car cdr ] unit-test -[ #{ 1 2 } ] [ "[ 1 | #{ 1 2 } ]" parse car cdr ] unit-test +[ 2 ] [ "[[ 1 2 ]]" parse car cdr ] unit-test +[ "hello" ] [ "[[ 1 \"hello\" ]]" parse car cdr ] unit-test +[ #{ 1 2 }# ] [ "[[ 1 #{ 1 2 }# ]]" parse car cdr ] unit-test ! Test EOL comments in multiline strings. [ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test diff --git a/library/test/parsing-word.factor b/library/test/parsing-word.factor index dd0ceccaef..f4377e650a 100644 --- a/library/test/parsing-word.factor +++ b/library/test/parsing-word.factor @@ -18,5 +18,6 @@ DEFER: foo ! Test > 1 ( ) comment; only the first one should be used. [ t ] [ - "a" ": foo ( a ) ( b ) ;" parse drop word stack-effect str-contains? + "a" ": foo ( a ) ( b ) ;" parse drop word + "stack-effect" word-property str-contains? ] unit-test diff --git a/library/test/stream.factor b/library/test/stream.factor index e864c6d706..96f57482d1 100644 --- a/library/test/stream.factor +++ b/library/test/stream.factor @@ -7,34 +7,3 @@ USE: generic USE: kernel [ "xyzzy" ] [ [ "xyzzy" write ] with-string ] unit-test - -TRAITS: xyzzy-stream - -M: xyzzy-stream fwrite-attr ( str style stream -- ) - [ - drop "<" delegate get fwrite - delegate get fwrite - ">" delegate get fwrite - ] bind ; - -M: xyzzy-stream fclose ( stream -- ) - drop ; - -M: xyzzy-stream fflush ( stream -- ) - drop ; - -M: xyzzy-stream fauto-flush ( stream -- ) - drop ; - -C: xyzzy-stream ( stream -- stream ) - [ delegate set ] extend ; - -[ - "" -] [ - [ - stdio get [ - "xyzzy" write - ] with-stream - ] with-string -] unit-test diff --git a/library/test/styles.factor b/library/test/styles.factor index ff47fde10c..13a2d1ebaf 100644 --- a/library/test/styles.factor +++ b/library/test/styles.factor @@ -10,7 +10,7 @@ USE: test ] unit-test [ "Sans-Serif" ] [ [ - [ "font" | "Sans-Serif" ] + [[ "font" "Sans-Serif" ]] ] "fooquux" set-style "font" "fooquux" style assoc ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index 5757e6213d..992934a8e1 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -1,20 +1,8 @@ ! Factor test suite. -! Some of these words should be moved to the standard library. - IN: test -USE: errors -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: parser -USE: prettyprint -USE: stdio -USE: strings -USE: words -USE: vectors -USE: unparser +USING: errors kernel lists math memory namespaces parser +prettyprint stdio strings words vectors unparser ; : assert ( t -- ) [ "Assertion failed!" throw ] unless ; @@ -45,14 +33,6 @@ USE: unparser #! Assert that the quotation throws an error. [ [ not ] catch ] cons [ f ] swap unit-test ; -: test-word ( output input word -- ) - #! Old-style test. - append unit-test ; - -: do-not-test-word ( output input word -- ) - #! Flag for tests that are known not to work. - 3drop ; - : test ( name -- ) ! Run the given test. depth 1 - >r @@ -77,6 +57,7 @@ USE: unparser "strings" "namespaces" "generic" + "tuple" "files" "parser" "parse-number" @@ -111,10 +92,19 @@ USE: unparser "interpreter" "hsv" "alien" + "line-editor" + "gadgets" + "memory" ] [ test ] each - + + os "win32" = [ + [ + "buffer" + ] [ test ] each + ] when + cpu "x86" = [ [ "compiler/optimizer" @@ -124,6 +114,7 @@ USE: unparser "compiler/ifte" "compiler/generic" "compiler/bail-out" + "compiler/linearizer" ] [ test ] each diff --git a/library/test/tuple.factor b/library/test/tuple.factor new file mode 100644 index 0000000000..7a44b3d636 --- /dev/null +++ b/library/test/tuple.factor @@ -0,0 +1,58 @@ +IN: scratchpad +USING: generic kernel test math parser ; + +TUPLE: rect x y w h ; +C: rect + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +: move ( x rect -- ) + [ rect-x + ] keep set-rect-x ; + +[ f ] [ 10 20 30 40 dup clone 5 swap [ move ] keep = ] unit-test + +[ t ] [ 10 20 30 40 dup clone 0 swap [ move ] keep = ] unit-test + +GENERIC: delegation-test +M: object delegation-test drop 3 ; +TUPLE: quux-tuple ; +C: quux-tuple ; +M: quux-tuple delegation-test drop 4 ; +TUPLE: quuux-tuple delegate ; +C: quuux-tuple + [ set-quuux-tuple-delegate ] keep ; + +[ 3 ] [ delegation-test ] unit-test + +GENERIC: delegation-test-2 +TUPLE: quux-tuple-2 ; +C: quux-tuple-2 ; +M: quux-tuple-2 delegation-test-2 drop 4 ; +TUPLE: quuux-tuple-2 delegate ; +C: quuux-tuple-2 + [ set-quuux-tuple-2-delegate ] keep ; + +[ 4 ] [ delegation-test-2 ] unit-test + +! Make sure we handle changing shapes! + +[ + 100 +] [ + TUPLE: point x y ; + C: point [ set-point-y ] keep [ set-point-x ] keep ; + + 100 200 + + ! Use eval to sequence parsing explicitly + "TUPLE: point y x ;" eval + + point-x +] unit-test + +! Ensure we have a fresh word. +DEFER: losing-eq FORGET: losing-eq +[ t ] [ DEFER: losing-eq \ losing-eq TUPLE: losing-eq x y ; \ losing-eq eq? ] +unit-test diff --git a/library/test/unparser.factor b/library/test/unparser.factor index e540ff9dfa..4756c09b51 100644 --- a/library/test/unparser.factor +++ b/library/test/unparser.factor @@ -8,25 +8,22 @@ USE: kernel USE: io-internals [ "\"hello\\\\backslash\"" ] -[ "hello\\backslash" ] -[ unparse ] -test-word +[ "hello\\backslash" unparse ] +unit-test [ "\"\\u1234\"" ] -[ "\u1234" ] -[ unparse ] -test-word +[ "\u1234" unparse ] +unit-test [ "\"\\e\"" ] -[ "\e" ] -[ unparse ] -test-word +[ "\e" unparse ] +unit-test [ "1.0" ] [ 1.0 unparse ] unit-test [ "f" ] [ f unparse ] unit-test [ "t" ] [ t unparse ] unit-test [ "car" ] [ \ car unparse ] unit-test -[ "#{ 1/2 2/3 }" ] [ #{ 1/2 2/3 } unparse ] unit-test +[ "#{ 1/2 2/3 }#" ] [ #{ 1/2 2/3 }# unparse ] unit-test [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test [ ] [ { 1 2 3 } unparse drop ] unit-test diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 4cb177480e..9726a57c50 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -6,12 +6,14 @@ USE: test USE: vectors USE: strings USE: namespaces +USE: kernel-internals [ [ t f t ] vector-length ] unit-test-fails [ 3 ] [ { t f t } vector-length ] unit-test +[ -3 { } vector-nth ] unit-test-fails [ 3 { } vector-nth ] unit-test-fails -[ 3 #{ 1 2 } 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 @@ -35,14 +37,11 @@ USE: namespaces [ f ] [ [ 1 2 ] { 1 2 3 } = ] unit-test [ f ] [ { 1 2 } [ 1 2 3 ] = ] unit-test -[ [ 1 4 9 16 ] ] [ [ 1 2 3 4 ] ] -[ list>vector [ dup * ] vector-map vector>list ] test-word -[ t ] [ [ 1 2 3 4 ] ] -[ list>vector [ number? ] vector-all? ] test-word -[ f ] [ [ 1 2 3 4 ] ] -[ list>vector [ 3 > ] vector-all? ] test-word -[ t ] [ [ ] ] -[ list>vector [ 3 > ] vector-all? ] test-word +[ [ 1 4 9 16 ] ] +[ + [ 1 2 3 4 ] + list>vector [ dup * ] vector-map vector>list +] unit-test [ t ] [ { } hashcode { } hashcode = ] unit-test [ t ] [ { 1 2 3 } hashcode { 1 2 3 } hashcode = ] unit-test @@ -50,20 +49,12 @@ USE: namespaces [ t ] [ { } hashcode { } hashcode = ] unit-test [ { 1 2 3 4 5 6 } ] -[ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test +[ { 1 2 3 } { 4 5 6 } vector-append ] unit-test [ { "" "a" "aa" "aaa" } ] [ 4 [ CHAR: a fill ] vector-project ] unit-test -[ { 6 8 10 12 } ] -[ { 1 2 3 4 } { 5 6 7 8 } vector-zip [ uncons + ] vector-map ] -unit-test - -[ { [ 1 | 5 ] [ 2 | 6 ] [ 3 | 7 ] [ 4 | 8 ] } ] -[ { 1 2 3 4 } { 5 6 7 8 } vector-zip ] -unit-test - [ [ ] ] [ 0 { } vector-tail ] unit-test [ [ ] ] [ 2 { 1 2 } vector-tail ] unit-test [ [ 3 4 ] ] [ 2 { 1 2 3 4 } vector-tail ] unit-test @@ -82,3 +73,14 @@ unit-test [ "funny-stack" get vector-pop ] unit-test-fails [ ] [ "funky" "funny-stack" get vector-push ] unit-test [ "funky" ] [ "funny-stack" get vector-pop ] unit-test + +[ t ] [ + { 1 2 3 4 } dup vector-array array-capacity + >r clone vector-array array-capacity r> + = +] unit-test + +[ f ] [ + { 1 2 3 4 } dup clone + swap vector-array swap vector-array eq? +] unit-test diff --git a/library/test/words.factor b/library/test/words.factor index e8198c12e1..c4fe3179f7 100644 --- a/library/test/words.factor +++ b/library/test/words.factor @@ -11,10 +11,7 @@ USE: kernel "poo" [ "scratchpad" ] search execute ] unit-test -: words-test ( -- ? ) - t vocabs [ words [ word? and ] each ] each ; - -[ t ] [ ] [ words-test ] test-word +[ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test DEFER: plist-test @@ -28,7 +25,7 @@ DEFER: plist-test \ plist-test "sample-property" word-property ] unit-test -[ f ] [ 5 ] [ compound? ] test-word +[ f ] [ 5 compound? ] unit-test "create-test" "scratchpad" create { 1 2 } "testing" set-word-property [ { 1 2 } ] [ @@ -62,4 +59,4 @@ SYMBOL: a-symbol : test-last ( -- ) ; word word-name "last-word-test" set -[ "test-last" ] [ ] [ "last-word-test" get ] test-word +[ "test-last" ] [ "last-word-test" get ] unit-test diff --git a/library/threads.factor b/library/threads.factor index c9d2471ea1..dc224c5c7f 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -1,56 +1,24 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! Copyright (C) 2005 Mackenzie Straight. +! See http://factor.sf.net/license.txt for BSD license. IN: threads -USE: io-internals -USE: kernel -USE: kernel-internals -USE: lists -USE: namespaces - +USING: io-internals kernel kernel-internals lists dlists +namespaces ; + ! Core of the multitasker. Used by io-internals.factor and ! in-thread.factor. -: run-queue ( -- queue ) - 9 getenv ; - -: set-run-queue ( queue -- ) - 9 setenv ; +: run-queue ( -- queue ) 9 getenv ; +: set-run-queue ( queue -- ) 9 setenv ; : init-threads ( -- ) - f set-run-queue ; + set-run-queue ; : next-thread ( -- quot ) - #! Get and remove the next quotation from the run queue. - run-queue dup [ uncons set-run-queue ] when ; + run-queue dlist-pop-front ; : schedule-thread ( quot -- ) - #! Add a quotation to the run queue. - run-queue cons set-run-queue ; + run-queue dlist-push-end ; : (yield) ( -- ) #! If there is a quotation in the run queue, call it, diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 3c3931c0aa..b3ed8213cb 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -1,43 +1,7 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or wxithout -! 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: errors -USE: kernel -USE: kernel-internals -USE: lists -USE: namespaces -USE: prettyprint -USE: stdio -USE: strings -USE: unparser -USE: vectors -USE: words -USE: math -USE: generic +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: errors USING: kernel kernel-internals lists namespaces +prettyprint stdio strings unparser vectors words math generic ; : expired-error ( obj -- ) "Object did not survive image save/load: " write . ; @@ -62,8 +26,8 @@ USE: generic : type-check-error ( list -- ) "Type check error" print uncons car dup "Object: " write . - "Object type: " write class . - "Expected type: " write builtin-type . ; + "Object type: " write class prettyprint-word terpri + "Expected type: " write builtin-type prettyprint-word terpri ; : range-error ( list -- ) "Range check error" print @@ -93,6 +57,9 @@ USE: generic : port-closed-error ( obj -- ) "Port closed: " write . ; +: heap-scan-error ( obj -- ) + "Cannot do next-object outside begin/end-scan" write drop ; + GENERIC: error. ( error -- ) PREDICATE: cons kernel-error ( obj -- ? ) @@ -115,6 +82,7 @@ M: kernel-error error. ( error -- ) ffi-disabled-error ffi-error port-closed-error + heap-scan-error } vector-nth execute ; M: string error. ( error -- ) @@ -133,7 +101,7 @@ M: object error. ( error -- ) "error-line-number" get [ 1 ] unless* unparse , ] make-string print - "error-line" get print + "error-line" get dup string? [ print ] [ drop ] ifte [ "error-col" get " " fill , "^" , ] make-string print ; @@ -145,9 +113,9 @@ M: object error. ( error -- ) : :get ( var -- value ) "error-namestack" get (get) ; : debug-help ( -- ) - [ :s :r :n :c ] [ prettyprint-1 " " write ] each + [ :s :r :n :c ] [ prettyprint-word " " write ] each "show stacks at time of error." print - \ :get prettyprint-1 + \ :get prettyprint-word " ( var -- value ) inspects the error namestack." print ; : flush-error-handler ( error -- ) @@ -157,9 +125,7 @@ M: object error. ( error -- ) : print-error ( error -- ) #! Print the error. [ - "! " [ - in-parser? [ parse-dump ] when error. - ] with-prefix + in-parser? [ parse-dump ] when error. ] [ flush-error-handler ] catch ; @@ -175,6 +141,16 @@ M: object error. ( error -- ) [ dup save-error rethrow ] 5 setenv ( kernel calls on error ) kernel-error 12 setenv ; +: undefined-method ( object generic -- ) + #! We 2dup here to leave both values on the stack, for + #! post-mortem inspection. + 2dup [ + "The generic word " , + unparse , + " does not have a suitable method for " , + unparse , + ] make-string throw ; + ! So that stage 2 boot gives a useful error message if something ! fails after this file is loaded. init-error-handler diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 5f5748d84a..7aa137407b 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -1,40 +1,8 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: interpreter -USE: vectors -USE: namespaces -USE: kernel -USE: lists -USE: words -USE: errors -USE: strings -USE: prettyprint -USE: stdio +USING: errors kernel lists math namespaces prettyprint stdio +strings vectors words ; ! A Factor interpreter written in Factor. Used by compiler for ! partial evaluation, also for trace and step. @@ -48,6 +16,7 @@ SYMBOL: meta-d : push-d meta-d get vector-push ; : pop-d meta-d get vector-pop ; : peek-d meta-d get vector-peek ; +: peek-next-d meta-d get [ vector-length 2 - ] keep vector-nth ; SYMBOL: meta-n SYMBOL: meta-c @@ -63,8 +32,8 @@ SYMBOL: meta-cf : copy-interpreter ( -- ) #! Copy interpreter state from containing namespaces. - meta-r [ vector-clone ] change - meta-d [ vector-clone ] change + meta-r [ clone ] change + meta-d [ clone ] change meta-n [ ] change meta-c [ ] change ; @@ -72,7 +41,7 @@ SYMBOL: meta-cf meta-cf get not ; : done? ( -- ? ) - done-cf? meta-r get vector-empty? and ; + done-cf? meta-r get vector-length 0 = and ; ! Callframe. : up ( -- ) @@ -94,25 +63,21 @@ SYMBOL: meta-cf meta-cf [ [ push-r ] when* ] change ; : meta-word ( word -- ) - dup "meta-word" word-property dup [ - nip call + dup "meta-word" word-property [ + call ] [ - drop dup compound? [ + dup compound? [ word-parameter meta-call ] [ host-word ] ifte - ] ifte ; + ] ?ifte ; : do ( obj -- ) dup word? [ meta-word ] [ push-d ] ifte ; : meta-word-1 ( word -- ) - dup "meta-word" word-property dup [ - nip call - ] [ - drop host-word - ] ifte ; + dup "meta-word" word-property [ call ] [ host-word ] ?ifte ; : do-1 ( obj -- ) dup word? [ meta-word-1 ] [ push-d ] ifte ; @@ -136,12 +101,12 @@ SYMBOL: meta-cf : set-meta-word ( word quot -- ) "meta-word" set-word-property ; -\ datastack [ meta-d get vector-clone push-d ] set-meta-word -\ set-datastack [ pop-d vector-clone meta-d set ] set-meta-word +\ datastack [ meta-d get clone push-d ] set-meta-word +\ set-datastack [ pop-d clone meta-d set ] set-meta-word \ >r [ pop-d push-r ] set-meta-word \ r> [ pop-r push-d ] set-meta-word -\ callstack [ meta-r get vector-clone push-d ] set-meta-word -\ set-callstack [ pop-d vector-clone meta-r set ] set-meta-word +\ callstack [ meta-r get clone push-d ] set-meta-word +\ set-callstack [ pop-d clone meta-r set ] set-meta-word \ namestack [ meta-n get push-d ] set-meta-word \ set-namestack [ pop-d meta-n set ] set-meta-word \ catchstack [ meta-c get push-d ] set-meta-word @@ -205,15 +170,15 @@ SYMBOL: meta-cf : walk-banner ( -- ) "The following words control the single-stepper:" print - [ &s &r &n &c ] [ prettyprint-1 " " write ] each + [ &s &r &n &c ] [ prettyprint-word " " write ] each "show stepper stacks." print - \ &get prettyprint-1 + \ &get prettyprint-word " ( var -- value ) inspects the stepper namestack." print - \ step prettyprint-1 " -- single step over" print - \ into prettyprint-1 " -- single step into" print - \ (trace) prettyprint-1 " -- trace until end" print - \ (run) prettyprint-1 " -- run until end" print - \ exit prettyprint-1 " -- exit single-stepper" print ; + \ step prettyprint-word " -- single step over" print + \ into prettyprint-word " -- single step into" print + \ (trace) prettyprint-word " -- trace until end" print + \ (run) prettyprint-word " -- run until end" print + \ exit prettyprint-word " -- exit single-stepper" print ; : walk ( quot -- ) #! Single-step through execution of a quotation. diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index 58daed042b..343342a386 100644 --- a/library/tools/jedit-wire.factor +++ b/library/tools/jedit-wire.factor @@ -37,6 +37,7 @@ USE: streams USE: strings USE: words USE: generic +USE: listener ! Wire protocol for jEdit to evaluate Factor code. ! Packets are of the form: @@ -46,12 +47,12 @@ USE: generic ! ! jEdit sends a packet with code to eval, it receives the output ! captured with with-string. -USE: listener + : write-packet ( string -- ) dup str-length write-big-endian-32 write flush ; : read-packet ( -- string ) - read-big-endian-32 read# ; + read-big-endian-32 read ; : wire-server ( -- ) #! Repeatedly read jEdit requests and execute them. Return @@ -77,19 +78,22 @@ USE: listener dup str-length write-big-endian-32 write ; -TRAITS: jedit-stream +TUPLE: jedit-stream delegate ; -M: jedit-stream freadln ( stream -- str ) - [ CHAR: r write flush read-big-endian-32 read# ] bind ; +M: jedit-stream stream-readln ( stream -- str ) + wrapper-stream-scope + [ CHAR: r write flush read-big-endian-32 read ] bind ; -M: jedit-stream fwrite-attr ( str style stream -- ) +M: jedit-stream stream-write-attr ( str style stream -- ) + wrapper-stream-scope [ [ default-style ] unless* jedit-write-attr ] bind ; -M: jedit-stream fflush ( stream -- ) +M: jedit-stream stream-flush ( stream -- ) + wrapper-stream-scope [ CHAR: f write flush ] bind ; C: jedit-stream ( stream -- stream ) - [ dup delegate set stdio set ] extend ; + [ >r r> set-jedit-stream-delegate ] keep ; : stream-server ( -- ) #! Execute this in the inferior Factor. diff --git a/library/tools/jedit.factor b/library/tools/jedit.factor index 2e5603075e..8697365de0 100644 --- a/library/tools/jedit.factor +++ b/library/tools/jedit.factor @@ -1,72 +1,27 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: jedit -USE: kernel -USE: lists -USE: namespaces -USE: parser -USE: streams -USE: stdio -USE: strings -USE: unparser -USE: words +USING: files kernel lists namespaces parser streams stdio +strings unparser words ; : jedit-server-file ( -- path ) "jedit-server-file" get [ "~" get "/.jedit/server" cat2 ] unless* ; : jedit-server-info ( -- port auth ) - jedit-server-file [ - read drop - read parse-number - read parse-number + jedit-server-file [ + read-line drop + read-line parse-number + read-line parse-number ] with-stream ; -: bool, ( ? -- str ) - "true" "false" ? , ; - -: list>bsh-array, ( list -- code ) - "new String[] {" , - [ unparse , "," , ] each - "null}" , ; - -: make-jedit-request ( files dir params -- code ) +: make-jedit-request ( files params -- code ) [ - [ - "EditServer.handleClient(" , - "restore" get bool, "," , - "newView" get bool, "," , - "newPlainView" get bool, "," , - ( If the dir is not set, we don't want to send f ) - dup [ unparse ] [ drop "null" ] ifte , "," , - list>bsh-array, ");\n" , - ] make-string - ] bind ; + "EditServer.handleClient(false,false,false,null," , + "new String[] {" , + [ unparse , "," , ] each + "null});\n" , + ] make-string ; : send-jedit-request ( request -- ) jedit-server-info swap "localhost" swap [ @@ -75,36 +30,17 @@ USE: words write flush ] with-stream ; -: jedit-line/file ( line dir file -- ) - rot "+line:" swap unparse cat2 unit cons swap - [ - "restore" off - "newView" off - "newPlainView" off - ] extend make-jedit-request send-jedit-request ; +: jedit-line/file ( file line -- ) + unparse "+line:" swap cat2 2list + make-jedit-request send-jedit-request ; -: resource-path ( -- path ) - global [ "resource-path" get ] bind [ "." ] unless* ; - -: word-file ( path -- dir file ) - dup [ - "resource:/" ?str-head [ - resource-path swap - ] [ - f swap - ] ifte - ] [ - f - ] ifte ; - -: word-line/file ( word -- line dir file ) - #! Note that line numbers here start from 1 - dup "line" word-property swap "file" word-property - word-file ; +: jedit-file ( file -- ) + unit make-jedit-request send-jedit-request ; : jedit ( word -- ) - word-line/file dup [ - jedit-line/file + #! Note that line numbers here start from 1 + dup word-file dup [ + swap "line" word-property jedit-line/file ] [ - 3drop "Unknown source" print + 2drop "Unknown source" print ] ifte ; diff --git a/library/tools/listener.factor b/library/tools/listener.factor index 683f6ffe81..765031928d 100644 --- a/library/tools/listener.factor +++ b/library/tools/listener.factor @@ -1,44 +1,8 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: listener -USE: errors -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: parser -USE: stdio -USE: strings -USE: presentation -USE: words -USE: unparser -USE: vectors -USE: ansi +USING: errors kernel lists math memory namespaces parser stdio +strings presentation words unparser vectors ansi ; SYMBOL: cont-prompt SYMBOL: listener-prompt @@ -62,7 +26,7 @@ global [ : (read-multiline) ( quot depth -- quot ? ) #! Flag indicates EOF. - >r read dup [ + >r read-line dup [ (parse) depth r> dup >r <= [ ( we're done ) r> drop t ] [ @@ -87,19 +51,6 @@ global [ #! Run a listener loop that executes user input. quit-flag get [ quit-flag off ] [ listen listener ] ifte ; -: kb. 1024 /i unparse write " KB" write ; - -: (room.) ( free total -- ) - 2dup swap - swap ( free used total ) - kb. " total " write - kb. " used " write - kb. " free" print ; - -: room. ( -- ) - room - "Data space: " write (room.) - "Code space: " write (room.) ; - : print-banner ( -- ) "Factor " write version write " (OS: " write os write diff --git a/library/tools/memory.factor b/library/tools/memory.factor new file mode 100644 index 0000000000..3657e7193b --- /dev/null +++ b/library/tools/memory.factor @@ -0,0 +1,75 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: memory +USING: errors generic kernel lists math namespaces prettyprint +stdio unparser vectors words ; + +! Printing an overview of heap usage. + +: kb. 1024 /i unparse write " KB" write ; + +: (room.) ( free total -- ) + 2dup swap - swap ( free used total ) + kb. " total " write + kb. " used " write + kb. " free" print ; + +: room. ( -- ) + room + "Data space: " write (room.) + "Code space: " write (room.) ; + +! Some words for iterating through the heap. + +: (each-object) ( quot -- ) + next-object dup [ + swap dup slip (each-object) + ] [ + 2drop + ] ifte ; inline + +: each-object ( quot -- ) + #! Applies the quotation to each object in the image. + [ + begin-scan (each-object) + ] [ + end-scan rethrow + ] catch ; inline + +: instances ( class -- list ) + #! Return a list of all instances of a built-in or tuple + #! class in the image. + [ + [ + dup class pick = [ , ] [ drop ] ifte + ] each-object drop + ] make-list ; + +: vector+ ( n index vector -- ) + [ vector-nth + ] 2keep set-vector-nth ; + +: heap-stat-step ( counts sizes obj -- ) + [ dup size swap type rot vector+ ] keep + 1 swap type rot vector+ ; + +: zero-vector ( n -- vector ) + [ drop 0 ] vector-project ; + +: heap-stats ( -- stats ) + #! Return a list of instance count/total size pairs. + num-types zero-vector num-types zero-vector + [ >r 2dup r> heap-stat-step ] each-object + swap vector>list swap vector>list zip ; + +: heap-stat. ( type instances bytes -- ) + dup 0 = [ + 3drop + ] [ + rot builtin-type word-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. 1 + ] each drop ; diff --git a/library/tools/telnetd.factor b/library/tools/telnetd.factor index 95e146993b..e7dfbe016f 100644 --- a/library/tools/telnetd.factor +++ b/library/tools/telnetd.factor @@ -1,47 +1,11 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: telnetd -USE: errors -USE: listener -USE: kernel -USE: logging -USE: namespaces -USE: stdio -USE: streams -USE: threads -USE: parser +USING: errors listener kernel logging namespaces stdio streams +threads parser ; : telnet-client ( socket -- ) - dup [ - "client" set - log-client - listener - ] with-stream ; + dup [ log-client listener ] with-stream ; : telnet-connection ( socket -- ) [ telnet-client ] in-thread drop ; @@ -51,7 +15,7 @@ USE: parser : telnetd ( port -- ) [ - [ telnetd-loop ] [ swap fclose rethrow ] catch + [ telnetd-loop ] [ swap stream-close rethrow ] catch ] with-logging ; IN: shells diff --git a/library/tools/word-tools.factor b/library/tools/word-tools.factor index 073d41fd86..dbc6866674 100644 --- a/library/tools/word-tools.factor +++ b/library/tools/word-tools.factor @@ -1,48 +1,20 @@ -! :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. - +! Copyright (C) 2003, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: words -USE: generic -USE: inspector -USE: lists -USE: kernel -USE: namespaces -USE: prettyprint -USE: stdio -USE: strings -USE: unparser -USE: math +USING: files generic inspector lists kernel namespaces +prettyprint stdio streams strings unparser math hashtables +parser ; -: word-uses? ( of in -- ? ) +GENERIC: word-uses? ( of in -- ? ) +M: word word-uses? 2drop f ; +M: compound word-uses? ( of in -- ? ) 2dup = [ 2drop f ! Don't say that a word uses itself ] [ word-parameter tree-contains? ] ifte ; +M: generic word-uses? ( of in -- ? ) + "methods" word-property hash>alist tree-contains? ; : usages-in-vocab ( of vocab -- usages ) #! Push a list of all usages of a word in a vocabulary. @@ -102,3 +74,14 @@ USE: math : words. ( vocab -- ) words . ; + +: word-file ( word -- file ) + "file" word-property dup [ + "resource:/" ?str-head [ + resource-path swap path+ + ] when + ] when ; + +: reload ( word -- ) + #! Reload the source file the word originated from. + word-file run-file ; diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor new file mode 100644 index 0000000000..99aa6ffd91 --- /dev/null +++ b/library/ui/buttons.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: gadgets +USING: generic kernel lists math namespaces sdl ; + +: button-pressed ( button -- ) + dup f bevel-up? set-paint-property redraw ; + +: button-released ( button -- ) + dup t bevel-up? set-paint-property redraw ; + +: mouse-over? ( gadget -- ? ) my-hand hand-gadget child? ; + +: rollover-update ( button -- ) + dup mouse-over? blue black ? foreground set-paint-property ; + +: button-pressed? ( button -- ? ) + dup mouse-over? [ + my-hand hand-buttons 1 swap contains? [ + my-hand hand-clicked child? + ] [ + drop f + ] ifte + ] [ + drop f + ] ifte ; + +: bevel-update ( button -- ) + dup button-pressed? not bevel-up? set-paint-property ; + +: button-update ( button -- ) + dup rollover-update dup bevel-update redraw ; + +: button-clicked ( button -- ) + #! If the mouse is released while still inside the button, + #! fire an action gesture. + dup button-update + dup mouse-over? [ + [ action ] swap handle-gesture drop + ] [ + drop + ] ifte ; + +: button-actions ( button quot -- ) + dupd [ action ] set-action + dup [ button-clicked ] [ button-up 1 ] set-action + dup [ button-update ] [ button-down 1 ] set-action + dup [ button-update ] [ mouse-leave ] set-action + [ button-update ] [ mouse-enter ] set-action ; + +: