From 1cd285bcaa8112272ddb46fe641204599c08cbc6 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:57:14 -0600 Subject: [PATCH 001/168] Slots with declared type of callable or quotation now have an initial value [ ] --- core/slots/slots.factor | 1 + 1 file changed, 1 insertion(+) mode change 100644 => 100755 core/slots/slots.factor diff --git a/core/slots/slots.factor b/core/slots/slots.factor old mode 100644 new mode 100755 index f166378d9d..24ff1b0f8b --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -151,6 +151,7 @@ M: class initial-value* no-initial-value ; { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ simple-alien bootstrap-word over class<= ] [ ] } + { [ quotation bootstrap-word over class<= ] [ [ ] ] } [ dup initial-value* ] } cond nip ; From 49875b9cc7db5c1c514d0a85f8d3ed0917fc67d9 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:57:46 -0600 Subject: [PATCH 002/168] Use factor.exe or factor.com when deploying on Windows, depending on whether or not the UI is enabled --- basis/tools/deploy/backend/backend.factor | 2 +- basis/tools/deploy/macosx/macosx.factor | 2 +- basis/tools/deploy/unix/unix.factor | 2 +- basis/tools/deploy/windows/windows.factor | 23 ++++++++++++++--------- 4 files changed, 17 insertions(+), 12 deletions(-) mode change 100644 => 100755 basis/tools/deploy/backend/backend.factor mode change 100644 => 100755 basis/tools/deploy/macosx/macosx.factor mode change 100644 => 100755 basis/tools/deploy/unix/unix.factor diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor old mode 100644 new mode 100755 index 636e44062e..22d6eb2ffa --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -11,7 +11,7 @@ tools.deploy.config.editor bootstrap.image io.encodings.utf8 destructors accessors ; IN: tools.deploy.backend -: copy-vm ( executable bundle-name extension -- vm ) +: copy-vm ( executable bundle-name -- vm ) [ prepend-path ] dip append vm over copy-file ; : copy-fonts ( name dir -- ) diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor old mode 100644 new mode 100755 index 91b4d603af..8fe31ac6cc --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -54,7 +54,7 @@ IN: tools.deploy.macosx } cleave ] [ create-app-plist ] - [ "Contents/MacOS/" append-path "" copy-vm ] 2tri + [ "Contents/MacOS/" append-path copy-vm ] 2tri dup OCT: 755 set-file-permissions ; : deploy.app-image ( vocab bundle-name -- str ) diff --git a/basis/tools/deploy/unix/unix.factor b/basis/tools/deploy/unix/unix.factor old mode 100644 new mode 100755 index 9e0bb8ac68..c9bf308357 --- a/basis/tools/deploy/unix/unix.factor +++ b/basis/tools/deploy/unix/unix.factor @@ -8,7 +8,7 @@ IN: tools.deploy.unix : create-app-dir ( vocab bundle-name -- vm ) dup "" copy-fonts - "" copy-vm + copy-vm dup OCT: 755 set-file-permissions ; : bundle-name ( -- str ) diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 7ce635b1ba..0e9146b26e 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.directories kernel namespaces sequences system -tools.deploy.backend tools.deploy.config -tools.deploy.config.editor assocs hashtables prettyprint -combinators windows.shell32 windows.user32 ; +USING: io io.files io.pathnames io.directories kernel namespaces +sequences locals system splitting tools.deploy.backend +tools.deploy.config tools.deploy.config.editor assocs hashtables +prettyprint combinators windows.shell32 windows.user32 ; IN: tools.deploy.windows : copy-dll ( bundle-name -- ) @@ -15,13 +15,18 @@ IN: tools.deploy.windows "resource:zlib1.dll" } swap copy-files-into ; +:: copy-vm ( executable bundle-name extension -- vm ) + vm "." split1-last drop extension append + bundle-name executable ".exe" append append-path + [ copy-file ] keep ; + : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dll deploy-ui? get [ - dup copy-freetype - dup "" copy-fonts - ] when - ".exe" copy-vm ; + [ copy-freetype ] + [ "" copy-fonts ] + [ ".exe" copy-vm ] tri + ] [ ".com" copy-vm ] if ; M: winnt deploy* "resource:" [ From 5af6c10eedfd8eb348b04ce5b614495da6dc4469 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:58:03 -0600 Subject: [PATCH 003/168] Fix io.launcher.windows.nt test when run from factor.exe --- basis/io/launcher/windows/nt/nt-tests.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) mode change 100644 => 100755 basis/io/launcher/windows/nt/nt-tests.factor diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor old mode 100644 new mode 100755 index 4dd0eebed3..04202365fd --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests "out.txt" temp-file ascii file-lines first ] unit-test -[ ] [ +[ "( scratchpad ) " ] [ console-vm "-run=listener" 2array >>command +closed+ >>stdin - try-process + +stdout+ >>stderr + ascii [ input-stream get contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests "append-test" temp-file ascii file-contents ] unit-test + + From a4a6885189bb7a432d4c78638975f7b6a1c9564d Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Wed, 28 Jan 2009 01:58:57 -0600 Subject: [PATCH 004/168] Fix setters for value struct slots and add unit test for this case; this fixes an io.mmap regression on Windows --- basis/alien/arrays/arrays.factor | 2 +- basis/alien/c-types/c-types.factor | 26 +++++++++++++----------- basis/alien/structs/structs-tests.factor | 15 ++++++++++++++ basis/alien/structs/structs.factor | 12 +++++++++-- 4 files changed, 40 insertions(+), 15 deletions(-) mode change 100644 => 100755 basis/alien/arrays/arrays.factor mode change 100644 => 100755 basis/alien/c-types/c-types.factor mode change 100644 => 100755 basis/alien/structs/structs-tests.factor mode change 100644 => 100755 basis/alien/structs/structs.factor diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor old mode 100644 new mode 100755 index 8253d9458c..6a182f8dbf --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; -M: array c-type-boxer-quot drop f ; +M: array c-type-boxer-quot drop [ ] ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor old mode 100644 new mode 100755 index a4bc3d3f52..a44b5cf2b6 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry call ; +accessors combinators effects continuations fry call classes ; IN: alien.c-types DEFER: @@ -13,18 +13,20 @@ DEFER: *char : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type -class -boxer boxer-quot unboxer unboxer-quot -getter setter -reg-class size align stack-align? ; - -: new-c-type ( class -- type ) - new - int-regs >>reg-class - object >>class ; inline +{ class class initial: object } +boxer +{ boxer-quot callable } +unboxer +{ unboxer-quot callable } +{ getter callable } +{ setter callable } +{ reg-class initial: int-regs } +size +align +stack-align? ; : ( -- type ) - \ c-type new-c-type ; + \ c-type new ; SYMBOL: c-types @@ -224,7 +226,7 @@ M: f byte-length drop 0 ; TUPLE: long-long-type < c-type ; : ( -- type ) - long-long-type new-c-type ; + long-long-type new ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor old mode 100644 new mode 100755 index ec0c01c2e7..8bc570c448 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -42,3 +42,18 @@ C-UNION: barx [ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test ] when + +C-STRUCT: nested + { "int" "x" } ; + +C-STRUCT: nested-2 + { "nested" "y" } ; + +[ 4 ] [ + "nested-2" + "nested" + 4 over set-nested-x + over set-nested-2-y + nested-2-y + nested-x +] unit-test diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor old mode 100644 new mode 100755 index 698518b4e5..8ec694198d --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -2,10 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry -alien.c-types alien.structs.fields cpu.architecture math.order ; +alien.c-types alien.structs.fields cpu.architecture math.order +quotations ; IN: alien.structs -TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ; +TUPLE: struct-type +size +align +fields +{ boxer-quot callable } +{ unboxer-quot callable } +{ getter callable } +{ setter callable } ; M: struct-type heap-size size>> ; From 9fd675a632db492958366bc85e4e99e1646691c5 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 5 Feb 2009 10:28:57 +0100 Subject: [PATCH 005/168] FUEL: Accept '?' in prompts for word and vocabs. --- misc/fuel/fuel-completion.el | 33 ++++++++++++++++++++++++++------- misc/fuel/fuel-edit.el | 9 +-------- misc/fuel/fuel-help.el | 2 +- misc/fuel/fuel-markup.el | 3 ++- misc/fuel/fuel-scaffold.el | 2 +- misc/fuel/fuel-xref.el | 2 +- 6 files changed, 32 insertions(+), 19 deletions(-) diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el index e6ec8b2dc9..165a9d9b66 100644 --- a/misc/fuel/fuel-completion.el +++ b/misc/fuel/fuel-completion.el @@ -18,6 +18,15 @@ (require 'fuel-eval) (require 'fuel-log) + +;;; Aux: + +(defvar fuel-completion--minibuffer-map + (let ((map (make-keymap))) + (set-keymap-parent map minibuffer-local-completion-map) + (define-key map "?" 'self-insert-command) + map)) + ;;; Vocabs dictionary: @@ -33,7 +42,8 @@ fuel-completion--vocabs) (defun fuel-completion--read-vocab (&optional reload init-input history) - (let ((vocabs (fuel-completion--vocabs reload))) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs reload))) (completing-read "Vocab name: " vocabs nil nil init-input history))) (defsubst fuel-completion--vocab-list (prefix) @@ -170,12 +180,21 @@ terminates a current completion." (cons completions partial))) (defun fuel-completion--read-word (prompt &optional default history all) - (completing-read prompt - (if all fuel-completion--all-words-list-func - fuel-completion--word-list-func) - nil nil nil - history - (or default (fuel-syntax-symbol-at-point)))) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)) + (completing-read prompt + (if all fuel-completion--all-words-list-func + fuel-completion--word-list-func) + nil nil nil + history + (or default (fuel-syntax-symbol-at-point))))) + +(defun fuel-completion--read-vocab (refresh) + (let* ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs refresh)) + (prompt "Vocabulary name: ")) + (if vocabs + (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) + (read-string prompt nil fuel-edit--vocab-history)))) (defun fuel-completion--complete-symbol () "Complete the symbol at point. diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index e5f0ffd26f..5860fb998a 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -57,13 +57,6 @@ (fuel-edit--visit-file (car loc) fuel-edit-word-method) (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))) -(defun fuel-edit--read-vocabulary-name (refresh) - (let* ((vocabs (fuel-completion--vocabs refresh)) - (prompt "Vocabulary name: ")) - (if vocabs - (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) - (read-string prompt nil fuel-edit--vocab-history)))) - (defun fuel-edit--edit-article (name) (let ((cmd `(:fuel* (,name fuel-get-article-location) "fuel" t))) (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) @@ -80,7 +73,7 @@ When called interactively, asks for vocabulary with completion. With prefix argument, refreshes cached vocabulary list." (interactive "P") - (let* ((vocab (or vocab (fuel-edit--read-vocabulary-name refresh))) + (let* ((vocab (or vocab (fuel-completion--read-vocab refresh))) (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t))) (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index a82de388da..cfc8cab7f1 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -257,7 +257,7 @@ buffer." (defun fuel-help-vocab (vocab) "Ask for a vocabulary name and show its help page." - (interactive (list (fuel-edit--read-vocabulary-name nil))) + (interactive (list (fuel-completion--read-vocab nil))) (fuel-help--get-vocab vocab)) (defun fuel-help-next (&optional forget-current) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 4844233ae7..980ea111a6 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -282,7 +282,8 @@ (fuel-markup--insert-newline) (dolist (s (cdr e)) (fuel-markup--snippet (list '$snippet s)) - (newline))) + (newline)) + (newline)) (defun fuel-markup--markup-example (e) (fuel-markup--insert-newline) diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el index 05d825593c..ac400c5622 100644 --- a/misc/fuel/fuel-scaffold.el +++ b/misc/fuel/fuel-scaffold.el @@ -71,7 +71,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to `user-full-name') for the name to be inserted in the generated file." (interactive "P") (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) - (fuel-edit--read-vocabulary-name nil))) + (fuel-completion--read-vocab nil))) (cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help) "fuel")) (ret (fuel-eval--send/wait cmd)) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index 4d444ebe3e..faf1897304 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -244,7 +244,7 @@ With prefix argument, force reload of vocabulary list." With prefix argument, ask for the vocab." (interactive "P") (let ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) - (fuel-edit--read-vocabulary-name)))) + (fuel-completion--read-vocab nil)))) (when vocab (fuel-xref--show-vocab-words vocab (fuel-syntax--file-has-private))))) From 84846e21d840c7d6cc74db4d6e04c1062c640baf Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 5 Feb 2009 10:45:44 +0100 Subject: [PATCH 006/168] FUEL: Small nits. --- misc/fuel/fuel-completion.el | 12 +++++++----- misc/fuel/fuel-edit.el | 1 - 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el index 165a9d9b66..c21d25901f 100644 --- a/misc/fuel/fuel-completion.el +++ b/misc/fuel/fuel-completion.el @@ -188,13 +188,15 @@ terminates a current completion." history (or default (fuel-syntax-symbol-at-point))))) +(defvar fuel-completion--vocab-history nil) + (defun fuel-completion--read-vocab (refresh) - (let* ((minibuffer-local-completion-map fuel-completion--minibuffer-map) - (vocabs (fuel-completion--vocabs refresh)) - (prompt "Vocabulary name: ")) + (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map) + (vocabs (fuel-completion--vocabs refresh)) + (prompt "Vocabulary name: ")) (if vocabs - (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) - (read-string prompt nil fuel-edit--vocab-history)))) + (completing-read prompt vocabs nil nil nil fuel-completion--vocab-history) + (read-string prompt nil fuel-completion--vocab-history)))) (defun fuel-completion--complete-symbol () "Complete the symbol at point. diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index 5860fb998a..941f57140e 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -65,7 +65,6 @@ ;;; Editing commands: (defvar fuel-edit--word-history nil) -(defvar fuel-edit--vocab-history nil) (defvar fuel-edit--previous-location nil) (defun fuel-edit-vocabulary (&optional refresh vocab) From c24bc639d11f792f4eadd14e8fbe7e6da4584574 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 15:29:59 -0600 Subject: [PATCH 007/168] unit tests for alien.fortran --- basis/alien/fortran/fortran-tests.factor | 141 +++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 basis/alien/fortran/fortran-tests.factor diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor new file mode 100644 index 0000000000..29bd024930 --- /dev/null +++ b/basis/alien/fortran/fortran-tests.factor @@ -0,0 +1,141 @@ +USING: alien.fortran alien.syntax tools.test ; +IN: alien.fortran.tests + +C-STRUCT: fortran_test_struct + { "int" "foo" } + { "float" "bar" } + { "char[4]" "bas" } ; + +! F-RECORD: fortran_test_record +! { "integer" "foo" } +! { "real" "bar" } +! { "character*4" "bar" } + +! fortran-name>symbol-name + +[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test +[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + +! fortran-type>c-type + +[ "short" ] +[ "integer*2" fortran-type>c-type ] unit-test + +[ "int" ] +[ "integer*4" fortran-type>c-type ] unit-test + +[ "int" ] +[ "integer" fortran-type>c-type ] unit-test + +[ "longlong" ] +[ "iNteger*8" fortran-type>c-type ] unit-test + +[ "int[0]" ] +[ "integer(*)" fortran-type>c-type ] unit-test + +[ "int[0]" ] +[ "integer(3,*)" fortran-type>c-type ] unit-test + +[ "int[3]" ] +[ "integer(3)" fortran-type>c-type ] unit-test + +[ "int[6]" ] +[ "integer(3,2)" fortran-type>c-type ] unit-test + +[ "int[24]" ] +[ "integer(4,3,2)" fortran-type>c-type ] unit-test + +[ "char[1]" ] +[ "character" fortran-type>c-type ] unit-test + +[ "char[17]" ] +[ "character*17" fortran-type>c-type ] unit-test + +[ "char[17]" ] +[ "character(17)" fortran-type>c-type ] unit-test + +[ "int" ] +[ "logical" fortran-type>c-type ] unit-test + +[ "float" ] +[ "real" fortran-type>c-type ] unit-test + +[ "double" ] +[ "double precision" fortran-type>c-type ] unit-test + +[ "float" ] +[ "real*4" fortran-type>c-type ] unit-test + +[ "double" ] +[ "real*8" fortran-type>c-type ] unit-test + +[ "(fortran-complex)" ] +[ "complex" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "double complex" fortran-type>c-type ] unit-test + +[ "(fortran-complex)" ] +[ "complex*8" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "complex*16" fortran-type>c-type ] unit-test + +[ "(fortran-double-complex)" ] +[ "complex*16" fortran-type>c-type ] unit-test + +[ "fortran_test_struct" ] +[ "fortran_test_struct" fortran-type>c-type ] unit-test + +[ "fortran_test_record" ] +[ "fortran_test_record" fortran-type>c-type ] unit-test + +! fortran-arg-type>c-type + +[ "int*" { } ] +[ "integer" fortran-arg-type>c-type ] unit-test + +[ "int*" { } ] +[ "integer(3)" fortran-arg-type>c-type ] unit-test + +[ "int*" { } ] +[ "integer(*)" fortran-arg-type>c-type ] unit-test + +[ "fortran_test_struct*" { } ] +[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test + +[ "char*" { "long" } ] +[ "character" fortran-arg-type>c-type ] unit-test + +[ "char*" { "long" } ] +[ "character(17)" fortran-arg-type>c-type ] unit-test + +! fortran-ret-type>c-type + +[ "void" { "char*" "long" } ] +[ "character(17)" fortran-ret-type>c-type ] unit-test + +[ "int" { } ] +[ "integer" fortran-ret-type>c-type ] unit-test + +[ "int" { } ] +[ "logical" fortran-ret-type>c-type ] unit-test + +[ "double" { } ] +[ "real" fortran-ret-type>c-type ] unit-test + +[ "double" { } ] +[ "double precision" fortran-ret-type>c-type ] unit-test + +[ "void" { "(fortran-complex)*" } ] +[ "complex" fortran-ret-type>c-type ] unit-test + +[ "void" { "(fortran-double-complex)*" } ] +[ "double complex" fortran-ret-type>c-type ] unit-test + +[ "void" { "int*" } ] +[ "integer(*)" fortran-ret-type>c-type ] unit-test + +[ "void" { "fortran_test_record*" } ] +[ "fortran_test_record" fortran-ret-type>c-type ] unit-test + From 4f1dc5cd0c46693d31ab51f7deaf6b2af41f8089 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 15:31:58 -0600 Subject: [PATCH 008/168] implement fortran-name>symbol-name and fortran-type>c-type --- basis/alien/fortran/fortran.factor | 140 +++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 basis/alien/fortran/fortran.factor diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor new file mode 100644 index 0000000000..d83df9bd45 --- /dev/null +++ b/basis/alien/fortran/fortran.factor @@ -0,0 +1,140 @@ +USING: accessors alien alien.c-types alien.syntax arrays ascii +assocs combinators fry kernel macros math.parser sequences splitting ; +IN: alien.fortran + +! XXX this currently only supports the gfortran/f2c abi. +! XXX we should also support ifort at some point for commercial BLASes + +C-STRUCT: (fortran-complex) + { "float" "r" } + { "float" "i" } ; +C-STRUCT: (fortran-double-complex) + { "double" "r" } + { "double" "i" } ; + +: fortran-c-abi ( -- abi ) "cdecl" ; + +: fortran-name>symbol-name ( fortran-name -- c-name ) + >lower CHAR: _ over member? + [ "__" append ] [ "_" append ] if ; + +ERROR: invalid-fortran-type type ; + +c-types H{ + { "character" character-type } + { "integer" integer-type } + { "logical" logical-type } + { "real" real-type } + { "double precision" double-precision-type } + { "complex" real-complex-type } + { "double complex" double-complex-type } +} + +: append-dimensions ( base-c-type type -- c-type ) + dims>> + [ product number>string "[" "]" surround append ] when* ; + +MACRO: size-case-type ( cases -- ) + [ invalid-fortran-type ] suffix + '[ [ size>> _ case ] [ append-dimensions ] bi ] ; + +: simple-type ( type base-c-type -- c-type ) + swap + [ dup size>> [ invalid-fortran-type ] [ drop ] if ] + [ append-dimensions ] bi ; + +: new-fortran-type ( dims size class -- type ) + new [ (>>size) ] [ (>>dims) ] [ ] tri ; + +GENERIC: (fortran-type>c-type) ( type -- c-type ) + +M: integer-type (fortran-type>c-type) + { + { f [ "int" ] } + { 2 [ "short" ] } + { 4 [ "int" ] } + { 8 [ "longlong" ] } + } size-case-type ; +M: real-type (fortran-type>c-type) + { + { f [ "float" ] } + { 4 [ "float" ] } + { 8 [ "double" ] } + } size-case-type ; +M: complex-type (fortran-type>c-type) + { + { f [ "(fortran-complex)" ] } + { 8 [ "(fortran-complex)" ] } + { 16 [ "(fortran-double-complex)" ] } + } size-case-type ; + +M: double-precision-type (fortran-type>c-type) + "double" simple-type ; +M: double-complex-type (fortran-type>c-type) + "(fortran-double-complex)" simple-type ; +M: misc-type (fortran-type>c-type) + dup name>> simple-type ; + +: fix-character-type ( character-type -- character-type' ) + clone dup size>> + [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ] + [ dup dims>> [ ] [ { 1 } >>dims ] if ] if ; + +M: character-type (fortran-type>c-type) + fix-character-type "char" simple-type ; + +: dimension>number ( string -- number ) + dup "*" = [ drop 0 ] [ string>number ] if ; + +: parse-dims ( string -- string' dim ) + "(" split1 dup + [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ; + +: parse-size ( string -- string' size ) + "*" split1 dup [ string>number ] when ; + +: parse-fortran-type ( fortran-type-string -- type ) + parse-dims swap parse-size swap + dup >lower fortran>c-types at* + [ nip new-fortran-type ] [ drop misc-type boa ] if ; + +: c-type>pointer ( c-type -- c-type* ) + "[" split1 drop "*" append ; + +GENERIC: added-c-args ( type -- args ) + +M: fortran-type added-c-args drop { } ; +M: character-type added-c-args drop { "long" } ; + +PRIVATE> + +: fortran-type>c-type ( fortran-type -- c-type ) + parse-fortran-type (fortran-type>c-type) ; + +: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) { } ; +: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) { } ; + +: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; + +! : F-RECORD: ... ; parsing +! : F-ABI: ... ; parsing +! : F-SUBROUTINE: ... ; parsing +! : F-FUNCTION: ... ; parsing + From 4429c17f63840647ce2467dbb385126fd9a081ef Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 16:39:23 -0600 Subject: [PATCH 009/168] implement fortran-arg-type>c-type and fortran-ret-type>c-type --- basis/alien/fortran/fortran.factor | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index d83df9bd45..0c30258895 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -123,13 +123,38 @@ GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; M: character-type added-c-args drop { "long" } ; +GENERIC: added-c-arg-values ( type -- arg-values ) + +M: fortran-type added-c-arg-values drop { } ; +M: character-type added-c-arg-values + fix-character-type dims>> first 1array ; + +GENERIC: returns-by-value? ( type -- ? ) + +M: fortran-type returns-by-value? drop f ; +M: number-type returns-by-value? dims>> not ; +M: complex-type returns-by-value? drop f ; + +GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) + +M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; +M: real-type (fortran-ret-type>c-type) drop "double" ; + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) parse-fortran-type (fortran-type>c-type) ; -: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) { } ; -: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) { } ; +: fortran-arg-type>c-type ( fortran-type -- c-type added-args ) + parse-fortran-type + [ (fortran-type>c-type) c-type>pointer ] + [ added-c-args ] bi ; +: fortran-ret-type>c-type ( fortran-type -- c-type added-args ) + parse-fortran-type dup returns-by-value? + [ (fortran-ret-type>c-type) { } ] [ + "void" swap + [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix + ] if ; : fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; From 7b1f16ae5ed2ee0b788456db20a84eb7922f14d2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Feb 2009 18:51:50 -0600 Subject: [PATCH 010/168] fortran records --- basis/alien/fortran/fortran-tests.factor | 62 ++++++++++++++++++------ basis/alien/fortran/fortran.factor | 28 +++++++++-- basis/alien/structs/structs.factor | 7 ++- 3 files changed, 75 insertions(+), 22 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 29bd024930..11f0a2efc7 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,15 +1,11 @@ -USING: alien.fortran alien.syntax tools.test ; +USING: accessors alien alien.c-types alien.fortran alien.structs +alien.syntax arrays assocs kernel namespaces sequences tools.test ; IN: alien.fortran.tests -C-STRUCT: fortran_test_struct - { "int" "foo" } - { "float" "bar" } - { "char[4]" "bas" } ; - -! F-RECORD: fortran_test_record -! { "integer" "foo" } -! { "real" "bar" } -! { "character*4" "bar" } +F-RECORD: fortran_test_record + { "integer" "foo" } + { "real" "bar" } + { "character*4" "bas" } ; ! fortran-name>symbol-name @@ -25,7 +21,7 @@ C-STRUCT: fortran_test_struct [ "integer*4" fortran-type>c-type ] unit-test [ "int" ] -[ "integer" fortran-type>c-type ] unit-test +[ "INTEGER" fortran-type>c-type ] unit-test [ "longlong" ] [ "iNteger*8" fortran-type>c-type ] unit-test @@ -84,9 +80,6 @@ C-STRUCT: fortran_test_struct [ "(fortran-double-complex)" ] [ "complex*16" fortran-type>c-type ] unit-test -[ "fortran_test_struct" ] -[ "fortran_test_struct" fortran-type>c-type ] unit-test - [ "fortran_test_record" ] [ "fortran_test_record" fortran-type>c-type ] unit-test @@ -101,8 +94,8 @@ C-STRUCT: fortran_test_struct [ "int*" { } ] [ "integer(*)" fortran-arg-type>c-type ] unit-test -[ "fortran_test_struct*" { } ] -[ "fortran_test_struct" fortran-arg-type>c-type ] unit-test +[ "fortran_test_record*" { } ] +[ "fortran_test_record" fortran-arg-type>c-type ] unit-test [ "char*" { "long" } ] [ "character" fortran-arg-type>c-type ] unit-test @@ -139,3 +132,40 @@ C-STRUCT: fortran_test_struct [ "void" { "fortran_test_record*" } ] [ "fortran_test_record" fortran-ret-type>c-type ] unit-test +! fortran-sig>c-sig + +[ "double" { "int*" "char*" "float*" "double*" "long" } ] +[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] +unit-test + +[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ] +[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] +unit-test + +[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ] +[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] +unit-test + +! fortran-record>c-struct + +[ { + { "double" "ex" } + { "float" "wye" } + { "int" "zee" } + { "char[20]" "woo" } +} ] [ + { + { "DOUBLE PRECISION" "EX" } + { "REAL" "WYE" } + { "INTEGER" "ZEE" } + { "CHARACTER(20)" "WOO" } + } fortran-record>c-struct +] unit-test + +! F-RECORD: + +[ 12 ] [ "fortran_test_record" heap-size ] unit-test +[ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test +[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test +[ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test + diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 0c30258895..327db12909 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,5 +1,6 @@ -USING: accessors alien alien.c-types alien.syntax arrays ascii -assocs combinators fry kernel macros math.parser sequences splitting ; +USING: accessors alien alien.c-types alien.structs alien.syntax +arrays ascii assocs combinators fry kernel lexer macros math.parser +namespaces parser sequences splitting vectors vocabs.parser ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -65,9 +66,12 @@ MACRO: size-case-type ( cases -- ) GENERIC: (fortran-type>c-type) ( type -- c-type ) +M: f (fortran-type>c-type) ; + M: integer-type (fortran-type>c-type) { { f [ "int" ] } + { 1 [ "char" ] } { 2 [ "short" ] } { 4 [ "int" ] } { 8 [ "longlong" ] } @@ -140,6 +144,9 @@ GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) drop "double" ; +: suffix! ( seq elt -- seq ) over push ; inline +: append! ( seq-a seq-b -- seq-a ) over push-all ; inline + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) @@ -156,10 +163,21 @@ PRIVATE> [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix ] if ; -: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) ; +: fortran-arg-types>c-types ( fortran-types -- c-types ) + [ length 1 ] keep + [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each + append >array ; -! : F-RECORD: ... ; parsing -! : F-ABI: ... ; parsing +: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args ) + [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ; + +: fortran-record>c-struct ( record -- struct ) + [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; + +: define-record ( name vocab fields -- ) + [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; + +: F-RECORD: scan in get parse-definition define-record ; parsing ! : F-SUBROUTINE: ... ; parsing ! : F-FUNCTION: ... ; parsing diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 42923fb28b..cb3f90d358 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays generic hashtables kernel kernel.private +USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order ; IN: alien.structs @@ -61,3 +61,8 @@ M: struct-type stack-size [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep compute-struct-align f (define-struct) ; + +: offset-of ( field struct -- offset ) + c-types get at fields>> + [ name>> = ] with find nip offset>> ; + From 7e2ac604e718b29bf3e6e8052ac75e22390d92e1 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 6 Feb 2009 10:06:22 -0600 Subject: [PATCH 011/168] some initial work on invoking fortran functions --- basis/alien/fortran/fortran-tests.factor | 46 +++++++++++++-- basis/alien/fortran/fortran.factor | 72 ++++++++++++++++++++---- 2 files changed, 103 insertions(+), 15 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 11f0a2efc7..a1f2443b30 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,3 +1,4 @@ +! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.fortran alien.structs alien.syntax arrays assocs kernel namespaces sequences tools.test ; IN: alien.fortran.tests @@ -11,6 +12,7 @@ F-RECORD: fortran_test_record [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test +[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test ! fortran-type>c-type @@ -57,7 +59,7 @@ F-RECORD: fortran_test_record [ "real" fortran-type>c-type ] unit-test [ "double" ] -[ "double precision" fortran-type>c-type ] unit-test +[ "double-precision" fortran-type>c-type ] unit-test [ "float" ] [ "real*4" fortran-type>c-type ] unit-test @@ -69,7 +71,7 @@ F-RECORD: fortran_test_record [ "complex" fortran-type>c-type ] unit-test [ "(fortran-double-complex)" ] -[ "double complex" fortran-type>c-type ] unit-test +[ "double-complex" fortran-type>c-type ] unit-test [ "(fortran-complex)" ] [ "complex*8" fortran-type>c-type ] unit-test @@ -118,13 +120,13 @@ F-RECORD: fortran_test_record [ "real" fortran-ret-type>c-type ] unit-test [ "double" { } ] -[ "double precision" fortran-ret-type>c-type ] unit-test +[ "double-precision" fortran-ret-type>c-type ] unit-test [ "void" { "(fortran-complex)*" } ] [ "complex" fortran-ret-type>c-type ] unit-test [ "void" { "(fortran-double-complex)*" } ] -[ "double complex" fortran-ret-type>c-type ] unit-test +[ "double-complex" fortran-ret-type>c-type ] unit-test [ "void" { "int*" } ] [ "integer(*)" fortran-ret-type>c-type ] unit-test @@ -155,7 +157,7 @@ unit-test { "char[20]" "woo" } } ] [ { - { "DOUBLE PRECISION" "EX" } + { "DOUBLE-PRECISION" "EX" } { "REAL" "WYE" } { "INTEGER" "ZEE" } { "CHARACTER(20)" "WOO" } @@ -169,3 +171,37 @@ unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test [ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test +! fortran-arg>c-args + +[ B{ 128 } { } ] +[ 128 "integer*1" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ? +[ 128 "integer*2" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ? +[ 128 "integer*4" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ? +[ 128 "integer*8" fortran-arg>c-args ] unit-test + +[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ] +[ "hello" "character*5" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ? +[ 1.0 "real" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ? +[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test + +little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ? +[ 1.0 "double-precision" fortran-arg>c-args ] unit-test + +little-endian? +[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] +[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ? +[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test + +[ B{ 1 0 0 0 2 0 0 0 } { } ] +[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test + diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 327db12909..faec9b5b86 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,6 +1,7 @@ +! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.structs alien.syntax arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser ; +namespaces parser sequences splitting vectors vocabs.parser locals ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -43,9 +44,9 @@ CONSTANT: fortran>c-types H{ { "integer" integer-type } { "logical" logical-type } { "real" real-type } - { "double precision" double-precision-type } + { "double-precision" double-precision-type } { "complex" real-complex-type } - { "double complex" double-complex-type } + { "double-complex" double-complex-type } } : append-dimensions ( base-c-type type -- c-type ) @@ -82,7 +83,7 @@ M: real-type (fortran-type>c-type) { 4 [ "float" ] } { 8 [ "double" ] } } size-case-type ; -M: complex-type (fortran-type>c-type) +M: real-complex-type (fortran-type>c-type) { { f [ "(fortran-complex)" ] } { 8 [ "(fortran-complex)" ] } @@ -127,12 +128,6 @@ GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; M: character-type added-c-args drop { "long" } ; -GENERIC: added-c-arg-values ( type -- arg-values ) - -M: fortran-type added-c-arg-values drop { } ; -M: character-type added-c-arg-values - fix-character-type dims>> first 1array ; - GENERIC: returns-by-value? ( type -- ? ) M: fortran-type returns-by-value? drop f ; @@ -147,6 +142,56 @@ M: real-type (fortran-ret-type>c-type) drop "double" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline +: ( complex -- byte-array ) + "(fortran-complex)" c-object + [ [ real-part ] dip set-(fortran-complex)-r ] + [ [ imaginary-part ] dip set-(fortran-complex)-i ] + [ ] tri ; + +: ( complex -- byte-array ) + "(fortran-double-complex)" c-object + [ [ real-part ] dip set-(fortran-complex)-r ] + [ [ imaginary-part ] dip set-(fortran-complex)-i ] + [ ] tri ; + +GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot ) + +M: integer-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type [fortran-arg>c-args] + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case ; + +M: + PRIVATE> : fortran-type>c-type ( fortran-type -- c-type ) @@ -178,6 +223,13 @@ PRIVATE> [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; : F-RECORD: scan in get parse-definition define-record ; parsing + +:: define-fortran-function ( return library function parameters -- ) + ; + +: F-SUBROUTINE: + + ! : F-SUBROUTINE: ... ; parsing ! : F-FUNCTION: ... ; parsing From 118f2de4667d47a79563b7a3d9c07308781c14b5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 6 Feb 2009 19:05:56 -0600 Subject: [PATCH 012/168] fortran-invoke sketch --- basis/alien/complex/complex-tests.factor | 2 +- basis/alien/complex/functor/functor.factor | 14 +- basis/alien/fortran/fortran-tests.factor | 170 ++++++++++++++------ basis/alien/fortran/fortran.factor | 178 +++++++++++++++------ 4 files changed, 260 insertions(+), 104 deletions(-) diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index bfb2c1137c..0bff73b898 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -15,4 +15,4 @@ C-STRUCT: complex-holder C{ 1.0 2.0 } "h" set ] unit-test -[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test \ No newline at end of file +[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 1d12bb0ff4..c6644eba1d 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary set-T-real DEFINES set-${T}-real set-T-imaginary DEFINES set-${T}-imaginary ->T DEFINES >${T} -T> DEFINES ${T}> + DEFINES <${T}> +*T DEFINES *${T} WHERE -: >T ( z -- alien ) +: ( z -- alien ) >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline -: T> ( alien -- z ) +: *T ( alien -- z ) [ T-real ] [ T-imaginary ] bi rect> ; inline T in get @@ -28,8 +28,8 @@ T in get define-struct T c-type -T> 1quotation >>boxer-quot ->T 1quotation >>unboxer-quot + 1quotation >>boxer-quot +*T 1quotation >>unboxer-quot drop -;FUNCTOR \ No newline at end of file +;FUNCTOR diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index a1f2443b30..0a86cba7e3 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,12 +1,13 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.fortran alien.structs -alien.syntax arrays assocs kernel namespaces sequences tools.test ; +alien.syntax arrays assocs kernel macros namespaces sequences +tools.test fry ; IN: alien.fortran.tests -F-RECORD: fortran_test_record - { "integer" "foo" } - { "real" "bar" } - { "character*4" "bas" } ; +RECORD: FORTRAN_TEST_RECORD + { "INTEGER" "FOO" } + { "REAL(2)" "BAR" } + { "CHARACTER*4" "BAS" } ; ! fortran-name>symbol-name @@ -67,19 +68,16 @@ F-RECORD: fortran_test_record [ "double" ] [ "real*8" fortran-type>c-type ] unit-test -[ "(fortran-complex)" ] +[ "complex-float" ] [ "complex" fortran-type>c-type ] unit-test -[ "(fortran-double-complex)" ] +[ "complex-double" ] [ "double-complex" fortran-type>c-type ] unit-test -[ "(fortran-complex)" ] +[ "complex-float" ] [ "complex*8" fortran-type>c-type ] unit-test -[ "(fortran-double-complex)" ] -[ "complex*16" fortran-type>c-type ] unit-test - -[ "(fortran-double-complex)" ] +[ "complex-double" ] [ "complex*16" fortran-type>c-type ] unit-test [ "fortran_test_record" ] @@ -122,10 +120,10 @@ F-RECORD: fortran_test_record [ "double" { } ] [ "double-precision" fortran-ret-type>c-type ] unit-test -[ "void" { "(fortran-complex)*" } ] +[ "void" { "complex-float*" } ] [ "complex" fortran-ret-type>c-type ] unit-test -[ "void" { "(fortran-double-complex)*" } ] +[ "void" { "complex-double*" } ] [ "double-complex" fortran-ret-type>c-type ] unit-test [ "void" { "int*" } ] @@ -144,7 +142,7 @@ unit-test [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test -[ "void" { "(fortran-complex)*" "char*" "char*" "int*" "long" "long" } ] +[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ] [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] unit-test @@ -164,44 +162,126 @@ unit-test } fortran-record>c-struct ] unit-test -! F-RECORD: +! RECORD: -[ 12 ] [ "fortran_test_record" heap-size ] unit-test +[ 16 ] [ "fortran_test_record" heap-size ] unit-test [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test -[ 8 ] [ "bas" "fortran_test_record" offset-of ] unit-test +[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test -! fortran-arg>c-args +! fortran-invoke -[ B{ 128 } { } ] -[ 128 "integer*1" fortran-arg>c-args ] unit-test +: fortran-invoke-expansion ( return library function parameters -- quot ) + '[ _ _ _ _ fortran-invoke ] expand-macros ; inline -little-endian? [ B{ 128 0 } { } ] [ B{ 0 128 } { } ] ? -[ 128 "integer*2" fortran-arg>c-args ] unit-test +[ [ + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ] + [ ] + [ 1 0 ? ] + } spread ] + [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] + } 5 ncleave + ! [fortran-invoke] + [ + "void" "foopack" "funtimes_" + { "char*" "int*" "float*" "complex-float*" "short*" "long" } + alien-invoke + ] 6 nkeep + ! [fortran-results>] + { + [ drop ] + [ drop ] + [ *float ] + [ drop ] + [ drop ] + [ drop ] + } spread +] ] [ + f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 128 0 0 0 } { } ] [ B{ 0 0 0 128 } { } ] ? -[ 128 "integer*4" fortran-arg>c-args ] unit-test +[ [ + ! [fortran-invoke] + "double" "foopack" "fun_times__" + { "float*" } + alien-invoke +] ] [ + "REAL" "foopack" "FUN_TIMES" { "REAL(*)" } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 128 0 0 0 0 0 0 0 } { } ] [ B{ 0 0 0 0 0 0 0 128 } { } ] ? -[ 128 "integer*8" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ "complex-float" ] 1 ndip + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "complex-float*" "float*" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + { + [ *complex-float ] + [ drop ] + } spread +] ] [ + "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" } + fortran-invoke-expansion +] unit-test -[ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } { 5 } ] -[ "hello" "character*5" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ 20 20 ] 1 ndip + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "char*" "long" "float*" } + alien-invoke + ] 3 nkeep + ! [fortran-results>] + { + [ ] + [ ascii alien>nstring ] + [ drop ] + } spread +] ] [ + "CHARACTER*20" "foopack" "FUN_TIMES" { } + fortran-invoke-expansion +] unit-test -little-endian? [ B{ 0 0 128 63 } { } ] [ B{ 63 128 0 0 } { } ] ? -[ 1.0 "real" fortran-arg>c-args ] unit-test - -little-endian? [ B{ 0 0 128 63 0 0 0 64 } { } ] [ B{ 63 128 0 0 64 0 0 0 } { } ] ? -[ C{ 1.0 2.0 } "complex" fortran-arg>c-args ] unit-test - -little-endian? [ B{ 0 0 0 0 0 0 240 63 } { } ] [ B{ 63 240 0 0 0 0 0 0 } { } ] ? -[ 1.0 "double-precision" fortran-arg>c-args ] unit-test - -little-endian? -[ B{ 0 0 0 0 0 0 240 63 0 0 0 0 0 0 0 64 } { } ] -[ B{ 63 240 0 0 0 0 0 0 64 0 0 0 0 0 0 0 } { } ] ? -[ C{ 1.0 2.0 } "double-complex" fortran-arg>c-args ] unit-test - -[ B{ 1 0 0 0 2 0 0 0 } { } ] -[ B{ 1 0 0 0 2 0 0 0 } "integer(2)" fortran-arg>c-args ] unit-test +[ [ + ! [] + [ 10 10 ] 2 ndip + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + } spread ] + [ { [ length ] [ drop ] } spread ] + } 2 ncleave + ! [fortran-invoke] + [ + "void" "foopack" "fun_times__" + { "char*" "long" "char*" "float*" "long" } + alien-invoke + ] 5 nkeep + ! [fortran-results>] + { + [ ] + [ ascii alien>nstring ] + [ ] + [ *float swap ] + [ ascii alien>nstring ] + } spread +] ] [ + "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" } + fortran-invoke-expansion +] unit-test diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index faec9b5b86..b0bbedd716 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,20 +1,15 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.structs alien.syntax arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser locals ; +namespaces parser sequences splitting vectors vocabs.parser locals +io.encodings.ascii io.encodings.string ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. ! XXX we should also support ifort at some point for commercial BLASes -C-STRUCT: (fortran-complex) - { "float" "r" } - { "float" "i" } ; -C-STRUCT: (fortran-double-complex) - { "double" "r" } - { "double" "i" } ; - -: fortran-c-abi ( -- abi ) "cdecl" ; +: alien>nstring ( alien len encoding -- string ) + [ memory>byte-array ] dip decode ; : fortran-name>symbol-name ( fortran-name -- c-name ) >lower CHAR: _ over member? @@ -22,9 +17,11 @@ C-STRUCT: (fortran-double-complex) ERROR: invalid-fortran-type type ; +DEFER: fortran-sig>c-sig + > [ invalid-fortran-type ] [ drop ] if ] [ append-dimensions ] bi ; -: new-fortran-type ( dims size class -- type ) - new [ (>>size) ] [ (>>dims) ] [ ] tri ; +: new-fortran-type ( out? dims size class -- type ) + new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ; GENERIC: (fortran-type>c-type) ( type -- c-type ) -M: f (fortran-type>c-type) ; +M: f (fortran-type>c-type) drop "void" ; M: integer-type (fortran-type>c-type) { @@ -85,9 +82,9 @@ M: real-type (fortran-type>c-type) } size-case-type ; M: real-complex-type (fortran-type>c-type) { - { f [ "(fortran-complex)" ] } - { 8 [ "(fortran-complex)" ] } - { 16 [ "(fortran-double-complex)" ] } + { f [ "complex-float" ] } + { 8 [ "complex-float" ] } + { 16 [ "complex-double" ] } } size-case-type ; M: double-precision-type (fortran-type>c-type) @@ -108,6 +105,9 @@ M: character-type (fortran-type>c-type) : dimension>number ( string -- number ) dup "*" = [ drop 0 ] [ string>number ] if ; +: parse-out ( string -- string' out? ) + "!" ?head ; + : parse-dims ( string -- string' dim ) "(" split1 dup [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ; @@ -115,10 +115,13 @@ M: character-type (fortran-type>c-type) : parse-size ( string -- string' size ) "*" split1 dup [ string>number ] when ; -: parse-fortran-type ( fortran-type-string -- type ) - parse-dims swap parse-size swap +: (parse-fortran-type) ( fortran-type-string -- type ) + parse-out swap parse-dims swap parse-size swap dup >lower fortran>c-types at* - [ nip new-fortran-type ] [ drop misc-type boa ] if ; + [ nip new-fortran-type ] [ drop f misc-type boa ] if ; + +: parse-fortran-type ( fortran-type-string/f -- type/f ) + dup [ (parse-fortran-type) ] when ; : c-type>pointer ( c-type -- c-type* ) "[" split1 drop "*" append ; @@ -130,33 +133,23 @@ M: character-type added-c-args drop { "long" } ; GENERIC: returns-by-value? ( type -- ? ) +M: f returns-by-value? drop t ; M: fortran-type returns-by-value? drop f ; M: number-type returns-by-value? dims>> not ; M: complex-type returns-by-value? drop f ; GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) +M: f (fortran-ret-type>c-type) drop "void" ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; M: real-type (fortran-ret-type>c-type) drop "double" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline -: ( complex -- byte-array ) - "(fortran-complex)" c-object - [ [ real-part ] dip set-(fortran-complex)-r ] - [ [ imaginary-part ] dip set-(fortran-complex)-i ] - [ ] tri ; +GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) -: ( complex -- byte-array ) - "(fortran-double-complex)" c-object - [ [ real-part ] dip set-(fortran-complex)-r ] - [ [ imaginary-part ] dip set-(fortran-complex)-i ] - [ ] tri ; - -GENERIC: [fortran-arg>c-args] ( type -- main-quot added-quot ) - -M: integer-type [fortran-arg>c-args] +M: integer-type (fortran-arg>c-args) size>> { { f [ [ ] [ drop ] ] } { 1 [ [ ] [ drop ] ] } @@ -166,7 +159,10 @@ M: integer-type [fortran-arg>c-args] [ invalid-fortran-type ] } case ; -M: real-type [fortran-arg>c-args] +M: logical-type (fortran-arg>c-args) + call-next-method [ [ 1 0 ? ] prepend ] dip ; + +M: real-type (fortran-arg>c-args) size>> { { f [ [ ] [ drop ] ] } { 4 [ [ ] [ drop ] ] } @@ -174,23 +170,92 @@ M: real-type [fortran-arg>c-args] [ invalid-fortran-type ] } case ; -M: real-complex-type [fortran-arg>c-args] +M: real-complex-type (fortran-arg>c-args) size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } [ invalid-fortran-type ] } case ; -M: real-complex-type [fortran-arg>c-args] +M: double-precision-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +M: double-complex-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +M: character-type (fortran-arg>c-args) + drop [ ascii string>alien ] [ length ] ; + +M: misc-type (fortran-arg>c-args) + drop [ ] [ drop ] ; + +GENERIC: (fortran-result>) ( type -- quot ) + +M: integer-type (fortran-result>) size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } + { f [ [ *int ] ] } + { 1 [ [ *char ] ] } + { 2 [ [ *short ] ] } + { 4 [ [ *int ] ] } + { 8 [ [ *longlong ] ] } [ invalid-fortran-type ] } case ; -M: +M: logical-type (fortran-result>) + call-next-method [ zero? not ] append ; + +M: real-type (fortran-result>) + size>> { + { f [ [ *float ] ] } + { 4 [ [ *float ] ] } + { 8 [ [ *double ] ] } + [ invalid-fortran-type ] + } case ; + +M: real-complex-type (fortran-result>) + size>> { + { f [ [ *complex-float ] ] } + { 8 [ [ *complex-float ] ] } + { 16 [ [ *complex-double ] ] } + [ invalid-fortran-type ] + } case ; + +M: double-precision-type (fortran-result>) + drop [ *double ] ; + +M: double-complex-type (fortran-result>) + drop [ *complex-double ] ; + +M: character-type (fortran-result>) + drop [ ascii alien>nstring ] ; + +M: misc-type (fortran-result>) + drop [ ] ; + +GENERIC: () ( type -- quot ) + +M: fortran-type () + (fortran-type>c-type) '[ _ ] ; + +: [] ( return parameters -- quot ) + [ parse-fortran-type ] dip + over returns-by-value? + [ 2drop [ ] ] + [ [ () ] [ '[ _ _ ndip ] ] bi* ] if ; + +: [fortran-args>c-args] ( parameters -- quot ) + [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 + [ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi + '[ _ _ ncleave ] ; + +:: [fortran-invoke] ( return library function parameters -- quot ) + return parameters fortran-sig>c-sig :> c-parameters :> c-return + function fortran-name>symbol-name :> c-function + [ c-return library c-function c-parameters alien-invoke ] ; + +: [fortran-results>] ( return parameters -- quot ) + 2drop [ ] ; PRIVATE> @@ -219,17 +284,28 @@ PRIVATE> : fortran-record>c-struct ( record -- struct ) [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ; -: define-record ( name vocab fields -- ) +: define-fortran-record ( name vocab fields -- ) [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; -: F-RECORD: scan in get parse-definition define-record ; parsing +: RECORD: scan in get parse-definition define-fortran-record ; parsing + +MACRO: fortran-invoke ( return library function parameters -- ) + { + [ 2nip [] ] + [ nip nip nip [fortran-args>c-args] ] + [ [fortran-invoke] ] + [ 2nip [fortran-results>] ] + } 4 ncleave 3append ; :: define-fortran-function ( return library function parameters -- ) - ; + function create-in dup reset-generic + return library function parameters return parse-arglist + [ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ; -: F-SUBROUTINE: - - -! : F-SUBROUTINE: ... ; parsing -! : F-FUNCTION: ... ; parsing +: SUBROUTINE: + f "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter define-fortran-function ; parsing +: FUNCTION: + scan "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter define-fortran-function ; parsing From f36ec3f0c5da15143f2f6bd1ab3ca88006f14255 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 7 Feb 2009 23:04:55 -0600 Subject: [PATCH 013/168] Add nsum, nspread and nweave to generalizations --- .../generalizations-docs.factor | 52 +++++++++++++++---- .../generalizations-tests.factor | 9 ++++ basis/generalizations/generalizations.factor | 19 ++++++- 3 files changed, 67 insertions(+), 13 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 912f69587e..ac8e14c05a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -30,6 +30,10 @@ HELP: narray { nsequence narray } related-words +HELP: nsum +{ $values { "n" integer } } +{ $description "Adds the top " { $snippet "n" } " stack values." } ; + HELP: firstn { $values { "n" integer } } { $description "A generalization of " { $link first } ", " @@ -238,6 +242,11 @@ HELP: ncleave } } ; +HELP: nspread +{ $values { "quots" "a sequence of quotations" } { "n" integer } } +{ $description "A generalization of " { $link spread } " that can work for any quotation arity." +} ; + HELP: mnswap { $values { "m" integer } { "n" integer } } { $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } @@ -250,6 +259,17 @@ HELP: mnswap } } ; +HELP: nweave +{ $values { "n" integer } } +{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." } +{ $examples + { $example + "USING: arrays kernel generalizations prettyprint ;" + "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ." + "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }" + } +} ; + HELP: n*quot { $values { "n" integer } { "seq" sequence } @@ -299,18 +319,14 @@ HELP: ntuck } { $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; -ARTICLE: "generalizations" "Generalized shuffle words and combinators" -"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " -"macros where the arity of the input quotations depends on an " -"input parameter." -$nl -"Generalized sequence operations:" +ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsection narray } { $subsection nsequence } { $subsection firstn } { $subsection nappend } -{ $subsection nappend-as } -"Generated stack shuffle operations:" +{ $subsection nappend-as } ; + +ARTICLE: "shuffle-generalizations" "Generalized shuffle words" { $subsection ndup } { $subsection npick } { $subsection nrot } @@ -319,14 +335,28 @@ $nl { $subsection ndrop } { $subsection ntuck } { $subsection mnswap } -"Generalized combinators:" +{ $subsection nweave } ; + +ARTICLE: "combinator-generalizations" "Generalized combinators" { $subsection ndip } { $subsection nslip } { $subsection nkeep } { $subsection napply } { $subsection ncleave } -"Generalized quotation construction:" +{ $subsection nspread } ; + +ARTICLE: "other-generalizations" "Additional generalizations" { $subsection ncurry } -{ $subsection nwith } ; +{ $subsection nwith } +{ $subsection nsum } ; + +ARTICLE: "generalizations" "Generalized shuffle words and combinators" +"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " +"macros where the arity of the input quotations depends on an " +"input parameter." +{ $subsection "sequence-generalizations" } +{ $subsection "shuffle-generalizations" } +{ $subsection "combinator-generalizations" } +{ $subsection "other-generalizations" } ; ABOUT: "generalizations" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 35e02f08b4..7ede271d01 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -53,3 +53,12 @@ IN: generalizations.tests [ 4 nappend ] must-infer [ 4 { } nappend-as ] must-infer + +[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test +{ 4 1 } [ 4 nsum ] must-infer-as + +[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test +{ 3 5 } [ 2 nweave ] must-infer-as + +[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ] +[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test \ No newline at end of file diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 4692fd20db..9b2b2456c2 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo +! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private math combinators @@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- ) MACRO: narray ( n -- ) '[ _ { } nsequence ] ; +MACRO: nsum ( n -- ) + 1- [ + ] n*quot ; + MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ [ [ '[ [ _ ] dip nth-unsafe ] ] map ] @@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- ) [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi compose ; +MACRO: nspread ( quots n -- ) + over empty? [ 2drop [ ] ] [ + [ [ but-last ] dip ] + [ [ peek ] dip ] 2bi + swap + '[ [ _ _ nspread ] _ ndip @ ] + ] if ; + MACRO: napply ( quot n -- ) swap spread>quot ; MACRO: mnswap ( m n -- ) - 1+ '[ _ -nrot ] spread>quot ; + 1+ '[ _ -nrot ] swap '[ _ _ napply ] ; + +MACRO: nweave ( n -- ) + [ dup [ '[ _ _ mnswap ] ] with map ] keep + '[ _ _ ncleave ] ; : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline From aa6166adf20004d792503fd90e8778047d5f7578 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 8 Feb 2009 00:20:56 -0600 Subject: [PATCH 014/168] Fix typo --- extra/websites/concatenative/concatenative.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index c1d62c6cda..35a1129338 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -65,7 +65,7 @@ SYMBOL: dh-file "concatenative.org" 25 smtp-server set-global "noreply@concatenative.org" lost-password-from set-global "website@concatenative.org" insomniac-sender set-global - "slava@factorcode.org" insomniac-recipients set-global + { "slava@factorcode.org" } insomniac-recipients set-global init-factor-db ; : init-testing ( -- ) From 16312f67111b3954507865cf5cba2aceb379db9d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 10:35:30 -0600 Subject: [PATCH 015/168] clean up stream-seek with some suggestions from slava --- basis/io/backend/unix/unix.factor | 4 ++-- basis/io/backend/windows/nt/nt.factor | 8 ++++---- basis/io/buffers/buffers.factor | 3 --- basis/io/ports/ports.factor | 13 +++++++++---- 4 files changed, 15 insertions(+), 13 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 3372f15cd9..f5e6426859 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -46,14 +46,14 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; -M: unix (stream-seek) ( n seek-type stream -- ) +M: unix seek-handle ( n seek-type handle -- ) swap { { io:seek-absolute [ SEEK_SET ] } { io:seek-relative [ SEEK_CUR ] } { io:seek-end [ SEEK_END ] } [ io:bad-seek-type ] } case - [ handle>> fd>> swap ] dip lseek io-error ; + [ fd>> swap ] dip lseek io-error ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 7b96e883dd..107f1902e3 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -87,11 +87,11 @@ ERROR: invalid-file-size n ; : handle>file-size ( handle -- n ) 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; -M: winnt (stream-seek) ( n seek-type stream -- ) +M: winnt seek-handle ( n seek-type handle -- ) swap { - { seek-absolute [ handle>> (>>ptr) ] } - { seek-relative [ handle>> [ + ] change-ptr drop ] } - { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] } + { seek-absolute [ (>>ptr) ] } + { seek-relative [ [ + ] change-ptr drop ] } + { seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] } [ bad-seek-type ] } case ; diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index a647f27dfc..4df081b17d 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -21,9 +21,6 @@ M: buffer dispose* ptr>> free ; : buffer-reset ( n buffer -- ) swap >>fill 0 >>pos drop ; -: buffer-reset-hard ( buffer -- ) - 0 >>fill 0 >>pos drop ; - : buffer-capacity ( buffer -- n ) [ size>> ] [ fill>> ] bi - ; inline diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 1f7fc5f115..1a58d4200b 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -120,12 +120,17 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) -HOOK: (stream-seek) os ( n seek-type stream -- ) +HOOK: seek-handle os ( n seek-type handle -- ) -M: port stream-seek ( n seek-type stream -- ) - dup check-disposed - [ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ; +M: input-port stream-seek ( n seek-type stream -- ) + [ check-disposed ] + [ buffer>> 0 swap buffer-reset ] + [ handle>> seek-handle ] tri ; +M: output-port stream-seek ( n seek-type stream -- ) + [ check-disposed ] + [ stream-flush ] + [ handle>> seek-handle ] tri ; GENERIC: shutdown ( handle -- ) From 69f4899e11cd69c01c572d9acd68e1ed20029cf9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:51:02 -0600 Subject: [PATCH 016/168] document stream seeking --- core/io/io-docs.factor | 53 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 52 insertions(+), 1 deletion(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index d7534ddb50..5d8aa6a88f 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -68,6 +68,51 @@ HELP: stream-copy { $description "Copies the contents of one stream into another, closing both streams when done." } $io-error ; + +HELP: stream-seek +{ $values + { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" } +} +{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl + "Three methods of seeking are supported:" + { $list { $link seek-absolute } { $link seek-relative } { $link seek-end } } +} +{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ; + +HELP: seek-absolute +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the beginning of the stream." } ; + +HELP: seek-end +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ; + +HELP: seek-relative +{ $values + + { "value" "a seek singleton" } +} +{ $description "Seeks to an offset from the current position of the stream pointer." } ; + + +HELP: seek-input +{ $values + { "n" integer } { "seek-type" "a seek singleton" } +} +{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ; + +HELP: seek-output +{ $values + { "n" integer } { "seek-type" "a seek singleton" } +} +{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ; + HELP: input-stream { $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ; @@ -196,6 +241,8 @@ $nl { $subsection stream-write } "This word is only required for string output streams:" { $subsection stream-nl } +"This word is for streams that allow seeking:" +{ $subsection stream-seek } "For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "." { $see-also "io.timeouts" } ; @@ -249,6 +296,8 @@ $nl { $subsection read-partial } "If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:" { $subsection readln } +"Seeking on the default input stream:" +{ $subsection seek-input } "A pair of combinators for rebinding the " { $link input-stream } " variable:" { $subsection with-input-stream } { $subsection with-input-stream* } @@ -256,7 +305,7 @@ $nl { $subsection output-stream } "Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user." $nl -"Words writing to the default input stream:" +"Words writing to the default output stream:" { $subsection flush } { $subsection write1 } { $subsection write } @@ -265,6 +314,8 @@ $nl { $subsection print } { $subsection nl } { $subsection bl } +"Seeking on the default output stream:" +{ $subsection seek-output } "A pair of combinators for rebinding the " { $link output-stream } " variable:" { $subsection with-output-stream } { $subsection with-output-stream* } From fef602b1857ab649d882461e76522388cefb24a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:58:39 -0600 Subject: [PATCH 017/168] remove superfluous flush from io tests --- core/io/io-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 8bfc52432d..d227ebeadf 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -16,7 +16,7 @@ IN: io.tests "seek-test1" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush 0 seek-absolute seek-output + B{ 1 2 3 4 5 } write 0 seek-absolute seek-output B{ 3 } write ] with-file-writer ] [ @@ -29,7 +29,7 @@ IN: io.tests "seek-test2" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush -1 seek-relative seek-output + B{ 1 2 3 4 5 } write -1 seek-relative seek-output B{ 3 } write ] with-file-writer ] [ @@ -42,7 +42,7 @@ IN: io.tests "seek-test3" unique-file binary [ [ - B{ 1 2 3 4 5 } write flush 1 seek-relative seek-output + B{ 1 2 3 4 5 } write 1 seek-relative seek-output B{ 3 } write ] with-file-writer ] [ From bba15986972c5b3918fc56cbea83b489c533f199 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 13:59:32 -0600 Subject: [PATCH 018/168] move io tests into io.files --- core/io/files/files-tests.factor | 65 ++++++++++++++++++++++++++++++++ core/io/io-tests.factor | 63 ------------------------------- 2 files changed, 65 insertions(+), 63 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index f9702fd133..423eb38144 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -75,3 +75,68 @@ USE: debugger.threads [ t ] [ "quux-test.txt" temp-file exists? ] unit-test [ ] [ "quux-test.txt" temp-file delete-file ] unit-test + +! File seeking tests +[ B{ 3 2 3 4 5 } ] +[ + "seek-test1" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write 0 seek-absolute seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 3 } ] +[ + "seek-test2" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write -1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 1 2 3 4 5 0 3 } ] +[ + "seek-test3" unique-file binary + [ + [ + B{ 1 2 3 4 5 } write 1 seek-relative seek-output + B{ 3 } write + ] with-file-writer + ] [ + file-contents + ] 2bi +] unit-test + +[ B{ 3 } ] +[ + B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ + set-file-contents + ] [ + [ + -3 seek-end seek-input 1 read + ] with-file-reader + ] 2bi +] unit-test + +[ B{ 2 } ] +[ + B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ + set-file-contents + ] [ + [ + 3 seek-absolute seek-input + -2 seek-relative seek-input + 1 read + ] with-file-reader + ] 2bi +] unit-test + diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index d227ebeadf..9e931279d7 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -10,66 +10,3 @@ IN: io.tests ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test - -[ B{ 3 2 3 4 5 } ] -[ - "seek-test1" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write 0 seek-absolute seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 1 2 3 4 3 } ] -[ - "seek-test2" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write -1 seek-relative seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 1 2 3 4 5 0 3 } ] -[ - "seek-test3" unique-file binary - [ - [ - B{ 1 2 3 4 5 } write 1 seek-relative seek-output - B{ 3 } write - ] with-file-writer - ] [ - file-contents - ] 2bi -] unit-test - -[ B{ 3 } ] -[ - B{ 1 2 3 4 5 } "seek-test4" unique-file binary [ - set-file-contents - ] [ - [ - -3 seek-end seek-input 1 read - ] with-file-reader - ] 2bi -] unit-test - -[ B{ 2 } ] -[ - B{ 1 2 3 4 5 } "seek-test5" unique-file binary [ - set-file-contents - ] [ - [ - 3 seek-absolute seek-input - -2 seek-relative seek-input - 1 read - ] with-file-reader - ] 2bi -] unit-test From 08ad6ca1162f54d7264d95dc02740405b4c332c2 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 8 Feb 2009 23:22:23 +0100 Subject: [PATCH 019/168] FUEL: use factor.com instead of factor.exe as default binary under Windows. --- misc/fuel/fuel-connection.el | 8 ++++++-- misc/fuel/fuel-listener.el | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 14c4d0b36f..f180d0f2b4 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -144,8 +144,12 @@ (add-hook 'comint-redirect-hook 'fuel-con--comint-redirect-hook nil t)) -(defadvice comint-redirect-setup (after fuel-con--advice activate) - (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex)) +(defadvice comint-redirect-setup + (after fuel-con--advice (output-buffer comint-buffer finished-regexp &optional echo)) + (with-current-buffer comint-buffer + (when fuel-con--connection + (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex)))) +(ad-activate 'comint-redirect-setup) (defun fuel-con--comint-preoutput-filter (str) (when (string-match fuel-con--comint-finished-regex str) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index d0898de04f..b8bf4d4b7f 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -32,7 +32,7 @@ (defcustom fuel-listener-factor-binary (expand-file-name (cond ((eq system-type 'windows-nt) - "factor.exe") + "factor.com") ((eq system-type 'darwin) "Factor.app/Contents/MacOS/factor") (t "factor")) From da45cbe96d1a3f242abefd125eac56301c0a6937 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 17:13:28 -0600 Subject: [PATCH 020/168] Rewriting basis/wrap with Knuth's algorithm. Minor API changes will probably break Slava's unmerged UI changes --- basis/wrap/wrap-docs.factor | 28 +++--- basis/wrap/wrap-tests.factor | 87 +++++++++++------ basis/wrap/wrap.factor | 181 ++++++++++++++++++++++++++--------- 3 files changed, 212 insertions(+), 84 deletions(-) diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index c94e12907f..09ddec36ed 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -10,10 +10,10 @@ ARTICLE: "wrap" "Word wrapping" { $subsection wrap-lines } { $subsection wrap-string } { $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called words." -{ $subsection wrap } -{ $subsection word } -{ $subsection } ; +"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called elements." +{ $subsection wrap-elements } +{ $subsection element } +{ $subsection } ; HELP: wrap-lines { $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } @@ -27,15 +27,15 @@ HELP: wrap-indented-string { $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } } { $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ; -HELP: wrap -{ $values { "words" { "a sequence of " { $instance word } "s" } } { "width" integer } { "lines" "a sequence of sequences of words" } } -{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given width. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; +HELP: wrap-elements +{ $values { "elements" { "a sequence of " { $instance element } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } +{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; -HELP: word -{ $class-description "A word, for the purposes of " { $vocab-link "wrap" } ", is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link } "." } -{ $see-also wrap } ; +HELP: element +{ $class-description "An element is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link } "." } +{ $see-also wrap-elements } ; -HELP: -{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } } -{ $description "Creates a " { $link word } " object with the given parameters." } -{ $see-also wrap } ; +HELP: +{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "element" element } } +{ $description "Creates an " { $link element } " object with the given parameters." } +{ $see-also wrap-elements } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index ba5168a1c2..98d0b712f7 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -6,49 +6,77 @@ IN: wrap.tests [ { { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 2 t } + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 2 t } } { - T{ word f 4 10 f } - T{ word f 5 10 f } + T{ element f 4 10 f } + T{ element f 5 10 f } } } ] [ { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 2 t } - T{ word f 4 10 f } - T{ word f 5 10 f } - } 35 wrap [ { } like ] map + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 2 t } + T{ element f 4 10 f } + T{ element f 5 10 f } + } 35 35 wrap-elements [ { } like ] map ] unit-test [ { { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 3 9 t } + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 9 t } + T{ element f 3 9 t } + T{ element f 3 9 t } } { - T{ word f 4 10 f } - T{ word f 5 10 f } + T{ element f 4 10 f } + T{ element f 5 10 f } } } ] [ { - T{ word f 1 10 f } - T{ word f 2 10 f } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 3 9 t } - T{ word f 4 10 f } - T{ word f 5 10 f } - } 35 wrap [ { } like ] map + T{ element f 1 10 f } + T{ element f 2 10 f } + T{ element f 3 9 t } + T{ element f 3 9 t } + T{ element f 3 9 t } + T{ element f 4 10 f } + T{ element f 5 10 f } + } 35 35 wrap-elements [ { } like ] map +] unit-test + +[ + { + { + T{ element f 1 10 t } + T{ element f 1 10 f } + T{ element f 3 9 t } + } + { + T{ element f 2 10 f } + T{ element f 3 9 t } + } + { + T{ element f 4 10 f } + T{ element f 5 10 f } + } + } +] [ + { + T{ element f 1 10 t } + T{ element f 1 10 f } + T{ element f 3 9 t } + T{ element f 2 10 f } + T{ element f 3 9 t } + T{ element f 4 10 f } + T{ element f 5 10 f } + } 35 35 wrap-elements [ { } like ] map ] unit-test [ @@ -75,8 +103,13 @@ word wrap."> " " wrap-indented-string ] unit-test -[ "this text\nhas lots of\nspaces" ] +[ "this text\nhas lots\nof spaces" ] [ "this text has lots of spaces" 12 wrap-string ] unit-test [ "hello\nhow\nare\nyou\ntoday?" ] [ "hello how are you today?" 3 wrap-string ] unit-test + +[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test +[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test +[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test +[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index e93509b58e..458d2f86d1 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,70 +1,165 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel namespaces make splitting -math math.order fry assocs accessors ; +USING: kernel sequences math arrays locals fry accessors splitting +make combinators.short-circuit namespaces grouping splitting.monotonic ; IN: wrap -! Word wrapping/line breaking -- not Unicode-aware - -TUPLE: word key width break? ; - -C: word - word -: break-here? ( column word -- ? ) - break?>> not [ width get > ] [ drop f ] if ; +: word-length ( word -- n ) + [ black>> ] [ white>> ] bi + ; -: walk ( n words -- n ) - ! If on a break, take the rest of the breaks - ! If not on a break, go back until you hit a break - 2dup bounds-check? [ - 2dup nth break?>> - [ [ break?>> not ] find-from drop ] - [ [ break?>> ] find-last-from drop 1+ ] if - ] [ drop ] if ; +TUPLE: cons cdr car ; ! This order works out better +C: cons -: find-optimal-break ( words -- n ) - [ 0 ] keep - [ [ width>> + dup ] keep break-here? ] find drop nip - [ 1 max swap walk ] [ drop f ] if* ; +: >cons< ( cons -- cdr car ) + [ cdr>> ] [ car>> ] bi ; -: (wrap) ( words -- ) +: list-each ( list quot -- ) + over [ + [ [ car>> ] dip call ] + [ [ cdr>> ] dip list-each ] 2bi + ] [ 2drop ] if ; inline recursive + +: singleton? ( list -- ? ) + { [ ] [ cdr>> not ] } 1&& ; + +: ( elt -- list ) + f swap ; + +: list>array ( list -- array ) + [ [ , ] list-each ] { } make ; + +: lists>arrays ( lists -- arrays ) + [ [ list>array , ] list-each ] { } make ; + +TUPLE: paragraph lines head-width tail-cost ; +C: paragraph + +SYMBOL: line-max +SYMBOL: line-ideal + +: deviation ( length -- n ) + line-ideal get - sq ; + +: top-fits? ( paragraph -- ? ) + [ head-width>> ] + [ lines>> singleton? line-ideal line-max ? get ] bi <= ; + +: fits? ( paragraph -- ? ) + ! Make this not count spaces at end + { [ lines>> car>> singleton? ] [ top-fits? ] } 1|| ; + +:: min-by ( seq quot -- elt ) + f 1.0/0.0 seq [| key value new | + new quot call :> newvalue + newvalue value < [ new newvalue ] [ key value ] if + ] each drop ; inline + +: paragraph-cost ( paragraph -- cost ) + [ head-width>> deviation ] + [ tail-cost>> ] bi + ; + +: min-cost ( paragraphs -- paragraph ) + [ paragraph-cost ] min-by ; + +: new-line ( paragraph word -- paragraph ) + [ [ lines>> ] [ ] bi* ] + [ nip black>> ] + [ drop paragraph-cost ] 2tri + ; + +: glue ( paragraph word -- paragraph ) + [ [ lines>> >cons< ] dip ] + [ [ head-width>> ] [ word-length ] bi* + ] + [ drop tail-cost>> ] 2tri + ; + +: wrap-step ( paragraphs word -- paragraphs ) + [ '[ _ glue ] map ] + [ [ min-cost ] dip new-line ] + 2bi prefix + [ fits? ] filter ; + +: 1paragraph ( word -- paragraph ) + [ ] + [ black>> ] bi + 0 ; + +: post-process ( paragraph -- array ) + lines>> lists>arrays + [ [ contents>> ] map ] map ; + +: initialize ( words -- words paragraph ) + unclip-slice 1paragraph 1array ; + +: wrap ( words line-max line-ideal -- paragraph ) [ - dup find-optimal-break - [ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* - ] unless-empty ; + line-ideal set + line-max set + initialize + [ wrap-step ] reduce + min-cost + post-process + ] with-scope ; -: intersperse ( seq elt -- seq' ) - [ '[ _ , ] [ , ] interleave ] { } make ; +PRIVATE> + +TUPLE: element key width break? ; +C: element + +> ] map sum ; + +: make-word ( whites blacks -- word ) + [ append ] [ [ elements-length ] bi@ ] 2bi ; + +: ?first2 ( seq -- first/f second/f ) + [ 0 swap ?nth ] + [ 1 swap ?nth ] bi ; + +: split-elements ( seq -- half-words ) + [ [ break?>> ] bi@ = ] monotonic-split ; + +: ?first-break ( seq -- newseq f/word ) + dup first first break?>> + [ unclip-slice f swap make-word ] + [ f ] if ; + +: make-words ( seq f/word -- words ) + [ 2 [ ?first2 make-word ] map ] dip + [ prefix ] when* ; + +: elements>words ( seq -- newseq ) + split-elements ?first-break make-words ; + +PRIVATE> + +: wrap-elements ( elements line-max line-ideal -- lines ) + [ elements>words ] 2dip wrap [ concat ] map ; + + ] map - " " 1 t intersperse + [ dup length 1 ] map ] map ; : join-words ( wrapped-lines -- lines ) - [ - [ break?>> ] trim-slice - [ key>> ] map concat - ] map ; + [ " " join ] map ; : join-lines ( strings -- string ) "\n" join ; PRIVATE> -: wrap ( words width -- lines ) - width [ - [ (wrap) ] { } make - ] with-variable ; - : wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ wrap join-words ] map concat ; + [ split-lines ] dip '[ _ dup wrap join-words ] map concat ; : wrap-string ( string width -- newstring ) wrap-lines join-lines ; From c069add10b86dc8038354e5b91c1b2d3a8da5c87 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 17:34:17 -0600 Subject: [PATCH 021/168] fix using lists --- core/io/files/files-tests.factor | 10 ++++------ core/io/io-tests.factor | 4 +--- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 423eb38144..d7fc3851e2 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,8 +1,7 @@ -USING: tools.test io.files io.files.private io.files.temp -io.directories io.encodings.8-bit arrays make system -io.encodings.binary io threads kernel continuations -io.encodings.ascii sequences strings accessors -io.encodings.utf8 math destructors namespaces ; +USING: arrays debugger.threads destructors io io.directories +io.encodings.8-bit io.encodings.ascii io.encodings.binary +io.files io.files.private io.files.temp io.files.unique kernel +make math sequences system threads tools.test ; IN: io.files.tests \ exists? must-infer @@ -139,4 +138,3 @@ USE: debugger.threads ] with-file-reader ] 2bi ] unit-test - diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 9e931279d7..cf6b935215 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,6 +1,4 @@ -USING: arrays io io.files kernel math parser strings system -tools.test words namespaces make io.encodings.8-bit -io.encodings.binary sequences io.files.unique ; +USING: io parser tools.test words ; IN: io.tests [ f ] [ From 83252cce04ef5864f6c38eb2343b94e974d5a05c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 17:37:54 -0600 Subject: [PATCH 022/168] working on tiff --- extra/graphics/tiff/tiff.factor | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index e66ebcc6bd..f0b3f9337e 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,20 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint ; +sorting.slots math.order math.parser prettyprint classes ; IN: graphics.tiff TUPLE: tiff endianness the-answer ifd-offset -ifds -processed-ifds ; +ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries next ; +TUPLE: ifd count ifd-entries next processed-tags strips ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; @@ -137,8 +136,6 @@ ERROR: bad-planar-configuration n ; TUPLE: new-subfile-type n ; CONSTRUCTOR: new-subfile-type ( n -- object ) ; - - ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -176,6 +173,12 @@ ERROR: bad-tiff-magic bytes ; [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ] with-tiff-endianness ; +: read-strips ( ifd -- ifd ) + dup processed-tags>> + [ [ strip-byte-counts instance? ] find nip n>> ] + [ [ strip-offsets instance? ] find nip n>> ] bi + [ seek-absolute seek-input read ] { } 2map-as >>strips ; + ! ERROR: unhandled-ifd-entry data n ; : unhandled-ifd-entry ; @@ -207,17 +210,18 @@ ERROR: bad-tiff-magic bytes ; [ unhandled-ifd-entry swap 2array ] } case ; -: process-ifd ( ifd -- processed-ifd ) - ifd-entries>> [ process-ifd-entry ] map ; +: process-ifd ( ifd -- ifd ) + dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; : (load-tiff) ( path -- tiff ) binary [ read-header read-ifds - dup ifds>> [ process-ifd ] map - >>processed-ifds + dup ifds>> [ process-ifd read-strips drop ] each ] with-file-reader ; : load-tiff ( path -- tiff ) (load-tiff) ; + +! TODO: duplicate ifds = error, seeking out of bounds = error From 0e8986176f7597d23b5908968c7785ad3b4a02a2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 18:24:22 -0600 Subject: [PATCH 023/168] Adding failing unit test to wrap (must-infer) --- basis/wrap/wrap-tests.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index 98d0b712f7..933238fddc 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -113,3 +113,6 @@ word wrap."> [ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test [ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test + +\ wrap-string must-infer +\ wrap-elements must-infer From 1818ea5136cd5515772b4c29d6c978378ffae1d2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 18:42:11 -0600 Subject: [PATCH 024/168] update README.txt --- README.txt | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/README.txt b/README.txt index 98616539d2..d60bf03130 100755 --- a/README.txt +++ b/README.txt @@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI. * Running Factor on Windows XP/Vista +The Factor runtime is compiled into two binaries: + + factor.com - a Windows console application + factor.exe - a Windows native application, without a console + If you did not download the binary package, you can bootstrap Factor in -the command prompt: +the command prompt using the console application: - factor.exe -i=boot..image + factor.com -i=boot..image -Once bootstrapped, double-clicking factor.exe starts the Factor UI. +Once bootstrapped, double-clicking factor.exe or factor.com starts +the Factor UI. To run the listener in the command prompt: - factor.exe -run=listener + factor.com -run=listener * The Factor FAQ From b529df965234019bfdd98a472636dd875bc910a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Feb 2009 20:18:30 -0600 Subject: [PATCH 025/168] handle seeking before the file start on windows, add a unit test for this --- basis/io/backend/windows/nt/nt.factor | 11 ++++++++--- core/io/files/files-tests.factor | 6 ++++++ 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 107f1902e3..6f283ac1bb 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -87,11 +87,16 @@ ERROR: invalid-file-size n ; : handle>file-size ( handle -- n ) 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; +ERROR: seek-before-start n ; + +: set-seek-ptr ( n handle -- ) + [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ; + M: winnt seek-handle ( n seek-type handle -- ) swap { - { seek-absolute [ (>>ptr) ] } - { seek-relative [ [ + ] change-ptr drop ] } - { seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] } + { seek-absolute [ set-seek-ptr ] } + { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] } + { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] } [ bad-seek-type ] } case ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d7fc3851e2..152d1bb85d 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -138,3 +138,9 @@ USE: debugger.threads ] with-file-reader ] 2bi ] unit-test + +[ + "seek-test6" unique-file binary [ + -10 seek-absolute seek-input + ] with-file-reader +] must-fail From ea46845ac16fdce6122812b3733a029e9b090dea Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 20:32:11 -0600 Subject: [PATCH 026/168] Slight furnace cleanup --- basis/furnace/chloe-tags/chloe-tags.factor | 13 ++++++++++--- basis/furnace/utilities/utilities-docs.factor | 6 +++--- basis/furnace/utilities/utilities.factor | 12 ++++++------ 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index d7d9ae9ebb..8003ab208b 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -81,11 +81,18 @@ CHLOE: a CHLOE: base compile-a-url [ [XML /> XML] ] [xml-code] ; +: hidden-nested-fields ( -- xml ) + nested-forms get " " join f like nested-forms-key + hidden-form-field ; + +: render-hidden ( for -- xml ) + "," split [ hidden render>xml ] map ; + : compile-hidden-form-fields ( for -- ) '[ - _ [ "," split [ hidden render>xml ] map ] [ f ] if* - nested-forms get " " join f like nested-forms-key hidden-form-field>xml - [ [ modify-form ] each-responder ] with-string-writer + _ render-hidden + hidden-nested-fields + form-modifications [XML
<-><-><->
XML] ] [code] ; diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index d2291786df..62f73d4f09 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -20,8 +20,8 @@ HELP: each-responder { $description "Applies the quotation to each responder involved in processing the current request." } ; HELP: hidden-form-field -{ $values { "value" string } { "name" string } } -{ $description "Renders an HTML hidden form field tag." } +{ $values { "value" string } { "name" string } { "xml" "an XML chunk" } } +{ $description "Renders an HTML hidden form field tag as XML." } { $notes "This word is used by session management, conversation scope and asides." } { $examples { $example @@ -38,7 +38,7 @@ HELP: link-attr { $examples "Conversation scope adds attributes to link tags." } ; HELP: modify-form -{ $values { "responder" "a responder" } } +{ $values { "responder" "a responder" } { "xml/f" "an XML chunk or f" } } { $contract "Emits hidden form fields using " { $link hidden-form-field } "." } { $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } { $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index a2d4c4d996..2f998e039a 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -77,18 +77,18 @@ GENERIC: link-attr ( tag responder -- ) M: object link-attr 2drop ; -GENERIC: modify-form ( responder -- ) +GENERIC: modify-form ( responder -- xml/f ) -M: object modify-form drop ; +M: object modify-form f ; -: hidden-form-field>xml ( value name -- xml ) +: form-modifications ( -- xml ) + [ [ modify-form [ , ] when ] each-responder ] { } make ; + +: hidden-form-field ( value name -- xml ) over [ [XML name=<->/> XML] ] [ drop ] if ; -: hidden-form-field ( value name -- ) - hidden-form-field>xml write-xml ; - : nested-forms-key "__n" ; : request-params ( request -- assoc ) From c3f5dc2e96d52cdc4e361f08ae201540365ce5b2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 21:17:59 -0600 Subject: [PATCH 027/168] Help-lint edit for furnace.utilities --- basis/furnace/utilities/utilities.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 2f998e039a..4fc68f7735 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -79,10 +79,10 @@ M: object link-attr 2drop ; GENERIC: modify-form ( responder -- xml/f ) -M: object modify-form f ; +M: object modify-form drop f ; : form-modifications ( -- xml ) - [ [ modify-form [ , ] when ] each-responder ] { } make ; + [ [ modify-form [ , ] when* ] each-responder ] { } make ; : hidden-form-field ( value name -- xml ) over [ From b65b88364c46b8c21b4f36e302bc406e0861bf49 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 22:12:11 -0600 Subject: [PATCH 028/168] Updating lots of things to use call( -- ) --- basis/alien/c-types/c-types.factor | 4 ++-- basis/cocoa/messages/messages.factor | 4 ++-- .../compiler/tree/propagation/inlining/inlining.factor | 7 ++++--- basis/help/lint/lint.factor | 10 +++++----- basis/html/templates/chloe/chloe.factor | 4 ++-- basis/html/templates/chloe/compiler/compiler.factor | 6 +++--- basis/html/templates/fhtml/fhtml.factor | 4 ++-- basis/ui/tools/interactor/interactor.factor | 5 ++--- basis/ui/ui.factor | 4 ++-- 9 files changed, 24 insertions(+), 24 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index cf5daa1562..89b3572daf 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry ; +accessors combinators effects continuations fry call ; IN: alien.c-types DEFER: @@ -258,7 +258,7 @@ M: long-long-type box-return ( type -- ) unclip [ [ dup word? [ - def>> { } swap with-datastack first + def>> call( -- object ) ] when ] map ] dip prefix diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index a0b0e89a0d..60bdde262c 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien kernel math namespaces make parser quotations sequences strings words cocoa.runtime io macros memoize io.encodings.utf8 effects libc libc.private parser lexer init core-foundation fry -generalizations specialized-arrays.direct.alien ; +generalizations specialized-arrays.direct.alien call ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -83,7 +83,7 @@ class-init-hooks global [ H{ } clone or ] change-at : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ - drop over class-init-hooks get at [ assert-depth ] when* + drop over class-init-hooks get at [ call( -- ) ] when* 2dup execute dup [ 2nip ] [ 2drop "No such class: " prepend throw ] if diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index f3b3238b4e..06d8d4f733 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math math.order +USING: accessors kernel arrays sequences math math.order call math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart @@ -181,8 +181,9 @@ SYMBOL: history "custom-inlining" word-prop ; : inline-custom ( #call word -- ? ) - [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack - first object swap eliminate-dispatch ; + [ dup ] [ "custom-inlining" word-prop ] bi* + call( #call -- word/quot/f ) + object swap eliminate-dispatch ; : inline-instance-check ( #call word -- ? ) over in-d>> second value-info literal>> dup class? diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index b5f8b78ea3..57f64459c8 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate macros math sets eval vocabs.parser words.symbol values grouping unicode.categories -sequences.deep ; +sequences.deep call ; IN: help.lint SYMBOL: vocabs-quot @@ -15,9 +15,9 @@ SYMBOL: vocabs-quot : check-example ( element -- ) [ rest [ - but-last "\n" join 1vector - [ (eval>string) ] with-datastack - peek "\n" ?tail drop + but-last "\n" join + [ (eval>string) ] call( code -- output ) + "\n" ?tail drop ] keep peek assert= ] vocabs-quot get call ; @@ -145,7 +145,7 @@ M: help-error error. bi ; : check-something ( obj quot -- ) - flush '[ _ assert-depth ] swap '[ _ , ] recover ; inline + flush '[ _ call( -- ) ] swap '[ _ , ] recover ; inline : check-word ( word -- ) [ with-file-vocabs ] vocabs-quot set diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index 89d00e1f6e..eafa3c3a5d 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml -logging continuations +logging call xml.data xml.writer xml.syntax strings html.forms html @@ -130,6 +130,6 @@ TUPLE: cached-template path last-modified quot ; template-cache get clear-assoc ; M: chloe call-template* - template-quot assert-depth ; + template-quot call( -- ) ; INSTANCE: chloe template diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 394b5ef359..1a1abc9f7b 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs namespaces make kernel sequences accessors combinators strings splitting io io.streams.string present -xml.writer xml.data xml.entities html.forms -html.templates html.templates.chloe.syntax continuations ; +xml.writer xml.data xml.entities html.forms call +html.templates html.templates.chloe.syntax ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) @@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ; : compile-chloe-tag ( tag -- ) dup main>> dup tags get at - [ curry assert-depth ] + [ curry call( -- ) ] [ unknown-chloe-tag ] ?if ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index c419c4a197..e76a812bef 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors -assocs fry vocabs.parser parser lexer io io.files +assocs fry vocabs.parser parser lexer io io.files call io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml @@ -72,6 +72,6 @@ TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - '[ _ path>> utf8 file-contents eval-template ] assert-depth ; + '[ _ path>> utf8 file-contents eval-template ] call( -- ) ; INSTANCE: fhtml template diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index 40da6ebafc..eb2eef3742 100644 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -5,7 +5,7 @@ hashtables io io.styles kernel math math.order math.vectors models models.delay namespaces parser lexer prettyprint quotations sequences strings threads listener classes.tuple ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar -ui.gadgets.presentations ui.gadgets.worlds ui.gestures +ui.gadgets.presentations ui.gadgets.worlds ui.gestures call definitions calendar concurrency.flags concurrency.mailboxes ui.tools.workspace accessors sets destructors fry vocabs.parser ; IN: ui.tools.interactor @@ -82,8 +82,7 @@ M: interactor model-changed mailbox>> mailbox-put ; : clear-input ( interactor -- ) - #! The with-datastack is a kludge to make it infer. Stupid. - model>> 1array [ clear-doc ] with-datastack drop ; + model>> [ clear-doc ] call( model -- ) ; : interactor-finish ( interactor -- ) [ editor-string ] keep diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 37ce4ea499..78f150987f 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init combinators hashtables -concurrency.flags sets accessors calendar ; +concurrency.flags sets accessors calendar call ; IN: ui ! Assoc mapping aliens to gadgets @@ -140,7 +140,7 @@ SYMBOL: ui-hook layout-queued redraw-worlds send-queued-gestures - ] assert-depth + ] call( -- ) ] [ ui-error ] recover ; SYMBOL: ui-thread From af9f5112d45beb02023aee377f3d0fbf6b2ceae5 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 22:39:22 -0600 Subject: [PATCH 029/168] Adding call( -- ) --- basis/call/call-tests.factor | 10 ++++++++++ basis/call/call.factor | 24 ++++++++++++++++++++++++ 2 files changed, 34 insertions(+) create mode 100644 basis/call/call-tests.factor create mode 100644 basis/call/call.factor diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor new file mode 100644 index 0000000000..4a59a6d2fb --- /dev/null +++ b/basis/call/call-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: math tools.test call kernel ; +IN: call.tests + +[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test +[ 1 2 [ + ] call( -- z ) ] must-fail +[ 1 2 [ + ] call( x y -- z a ) ] must-fail +[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test +[ [ + ] call( x y -- z ) ] must-infer diff --git a/basis/call/call.factor b/basis/call/call.factor new file mode 100644 index 0000000000..363b024dff --- /dev/null +++ b/basis/call/call.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel macros fry summary sequences generalizations accessors +continuations effects.parser parser ; +IN: call + +ERROR: wrong-values values quot length-required ; + +M: wrong-values summary + drop "Wrong number of values returned from quotation" ; + + + +MACRO: call-effect ( effect -- quot ) + [ in>> length ] [ out>> length ] bi + '[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ; + +: call( + ")" parse-effect parsed \ call-effect parsed ; parsing From c4aa14b9d96d0a55b6c94e2441d952cf056ddfcc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 23:06:03 -0600 Subject: [PATCH 030/168] Making lazy lists compile, and using them where applicable --- basis/persistent/deques/deques.factor | 14 ++-- basis/wrap/wrap-docs.factor | 26 +++---- basis/wrap/wrap-tests.factor | 84 +++++++++++------------ basis/wrap/wrap.factor | 97 ++++++++++++--------------- extra/lists/lazy/lazy-tests.factor | 8 ++- extra/lists/lazy/lazy.factor | 22 +++--- extra/lists/lists.factor | 5 +- extra/promises/promises.factor | 10 +-- 8 files changed, 125 insertions(+), 141 deletions(-) diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index be63d807b9..ece1cda772 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -1,6 +1,6 @@ ! Copyback (C) 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math ; +USING: kernel accessors math lists ; QUALIFIED: sequences IN: persistent.deques @@ -9,25 +9,23 @@ IN: persistent.deques ! same source, it could take O(m) amortized time per update. cons : each ( list quot: ( elt -- ) -- ) over - [ [ [ car>> ] dip call ] [ [ cdr>> ] dip ] 2bi each ] + [ [ [ car ] dip call ] [ [ cdr ] dip ] 2bi each ] [ 2drop ] if ; inline recursive : reduce ( list start quot -- end ) swapd each ; inline : reverse ( list -- reversed ) - f [ swap ] reduce ; + f [ swap cons ] reduce ; : length ( list -- length ) 0 [ drop 1+ ] reduce ; : cut ( list index -- back front-reversed ) - f swap [ [ [ cdr>> ] [ car>> ] bi ] dip ] times ; + f swap [ [ [ cdr ] [ car ] bi ] dip cons ] times ; : split-reverse ( list -- back-reversed front ) dup length 2/ cut [ reverse ] bi@ ; @@ -49,7 +47,7 @@ PRIVATE> > ] [ back>> ] bi deque boa ; inline + [ front>> cons ] [ back>> ] bi deque boa ; inline PRIVATE> : push-front ( deque item -- newdeque ) @@ -60,7 +58,7 @@ PRIVATE> > car>> ] [ [ front>> cdr>> ] [ back>> ] bi deque boa ] bi ; inline + [ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline : transfer ( deque -- item newdeque ) back>> [ split-reverse deque boa remove ] diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index 09ddec36ed..59c0352bc7 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -10,10 +10,10 @@ ARTICLE: "wrap" "Word wrapping" { $subsection wrap-lines } { $subsection wrap-string } { $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called elements." -{ $subsection wrap-elements } -{ $subsection element } -{ $subsection } ; +"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments." +{ $subsection wrap-segments } +{ $subsection segment } +{ $subsection } ; HELP: wrap-lines { $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } @@ -27,15 +27,15 @@ HELP: wrap-indented-string { $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } } { $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ; -HELP: wrap-elements -{ $values { "elements" { "a sequence of " { $instance element } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } +HELP: wrap-segments +{ $values { "segments" { "a sequence of " { $instance segment } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } { $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; -HELP: element -{ $class-description "An element is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link } "." } -{ $see-also wrap-elements } ; +HELP: segment +{ $class-description "A segment is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link } "." } +{ $see-also wrap-segments } ; -HELP: -{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "element" element } } -{ $description "Creates an " { $link element } " object with the given parameters." } -{ $see-also wrap-elements } ; +HELP: +{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "segment" segment } } +{ $description "Creates a " { $link segment } " object with the given parameters." } +{ $see-also wrap-segments } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor index 933238fddc..eeea3850d5 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/wrap-tests.factor @@ -6,77 +6,77 @@ IN: wrap.tests [ { { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 2 t } + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 2 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 2 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 2 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ { { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 3 9 t } + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 3 9 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 f } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 3 9 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 f } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 3 9 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ { { - T{ element f 1 10 t } - T{ element f 1 10 f } - T{ element f 3 9 t } + T{ segment f 1 10 t } + T{ segment f 1 10 f } + T{ segment f 3 9 t } } { - T{ element f 2 10 f } - T{ element f 3 9 t } + T{ segment f 2 10 f } + T{ segment f 3 9 t } } { - T{ element f 4 10 f } - T{ element f 5 10 f } + T{ segment f 4 10 f } + T{ segment f 5 10 f } } } ] [ { - T{ element f 1 10 t } - T{ element f 1 10 f } - T{ element f 3 9 t } - T{ element f 2 10 f } - T{ element f 3 9 t } - T{ element f 4 10 f } - T{ element f 5 10 f } - } 35 35 wrap-elements [ { } like ] map + T{ segment f 1 10 t } + T{ segment f 1 10 f } + T{ segment f 3 9 t } + T{ segment f 2 10 f } + T{ segment f 3 9 t } + T{ segment f 4 10 f } + T{ segment f 5 10 f } + } 35 35 wrap-segments [ { } like ] map ] unit-test [ @@ -115,4 +115,4 @@ word wrap."> [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test \ wrap-string must-infer -\ wrap-elements must-infer +\ wrap-segments must-infer diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 458d2f86d1..f54c858bf4 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,39 +1,28 @@ -USING: kernel sequences math arrays locals fry accessors splitting -make combinators.short-circuit namespaces grouping splitting.monotonic ; +USING: kernel sequences math arrays locals fry accessors +lists splitting call make combinators.short-circuit namespaces +grouping splitting.monotonic ; IN: wrap word +TUPLE: element contents black white ; +C: element -: word-length ( word -- n ) +: element-length ( element -- n ) [ black>> ] [ white>> ] bi + ; -TUPLE: cons cdr car ; ! This order works out better -C: cons +: swons ( cdr car -- cons ) + swap cons ; -: >cons< ( cons -- cdr car ) - [ cdr>> ] [ car>> ] bi ; +: unswons ( cons -- cdr car ) + [ cdr ] [ car ] bi ; -: list-each ( list quot -- ) - over [ - [ [ car>> ] dip call ] - [ [ cdr>> ] dip list-each ] 2bi - ] [ 2drop ] if ; inline recursive - -: singleton? ( list -- ? ) - { [ ] [ cdr>> not ] } 1&& ; - -: ( elt -- list ) - f swap ; - -: list>array ( list -- array ) - [ [ , ] list-each ] { } make ; +: 1list? ( list -- ? ) + { [ ] [ cdr +nil+ = ] } 1&& ; : lists>arrays ( lists -- arrays ) - [ [ list>array , ] list-each ] { } make ; + [ list>seq ] lmap>array ; TUPLE: paragraph lines head-width tail-cost ; C: paragraph @@ -46,11 +35,11 @@ SYMBOL: line-ideal : top-fits? ( paragraph -- ? ) [ head-width>> ] - [ lines>> singleton? line-ideal line-max ? get ] bi <= ; + [ lines>> 1list? line-ideal line-max ? get ] bi <= ; : fits? ( paragraph -- ? ) ! Make this not count spaces at end - { [ lines>> car>> singleton? ] [ top-fits? ] } 1|| ; + { [ lines>> car 1list? ] [ top-fits? ] } 1|| ; :: min-by ( seq quot -- elt ) f 1.0/0.0 seq [| key value new | @@ -65,26 +54,26 @@ SYMBOL: line-ideal : min-cost ( paragraphs -- paragraph ) [ paragraph-cost ] min-by ; -: new-line ( paragraph word -- paragraph ) - [ [ lines>> ] [ ] bi* ] +: new-line ( paragraph element -- paragraph ) + [ [ lines>> ] [ 1list ] bi* swons ] [ nip black>> ] [ drop paragraph-cost ] 2tri ; -: glue ( paragraph word -- paragraph ) - [ [ lines>> >cons< ] dip ] - [ [ head-width>> ] [ word-length ] bi* + ] +: glue ( paragraph element -- paragraph ) + [ [ lines>> unswons ] dip swons swons ] + [ [ head-width>> ] [ element-length ] bi* + ] [ drop tail-cost>> ] 2tri ; -: wrap-step ( paragraphs word -- paragraphs ) +: wrap-step ( paragraphs element -- paragraphs ) [ '[ _ glue ] map ] [ [ min-cost ] dip new-line ] 2bi prefix [ fits? ] filter ; -: 1paragraph ( word -- paragraph ) - [ ] +: 1paragraph ( element -- paragraph ) + [ 1list 1list ] [ black>> ] bi 0 ; @@ -92,10 +81,10 @@ SYMBOL: line-ideal lines>> lists>arrays [ [ contents>> ] map ] map ; -: initialize ( words -- words paragraph ) +: initialize ( elements -- elements paragraph ) unclip-slice 1paragraph 1array ; -: wrap ( words line-max line-ideal -- paragraph ) +: wrap ( elements line-max line-ideal -- paragraph ) [ line-ideal set line-max set @@ -107,50 +96,50 @@ SYMBOL: line-ideal PRIVATE> -TUPLE: element key width break? ; -C: element +TUPLE: segment key width break? ; +C: segment > ] map sum ; -: make-word ( whites blacks -- word ) - [ append ] [ [ elements-length ] bi@ ] 2bi ; +: make-element ( whites blacks -- element ) + [ append ] [ [ segments-length ] bi@ ] 2bi ; : ?first2 ( seq -- first/f second/f ) [ 0 swap ?nth ] [ 1 swap ?nth ] bi ; -: split-elements ( seq -- half-words ) +: split-segments ( seq -- half-elements ) [ [ break?>> ] bi@ = ] monotonic-split ; -: ?first-break ( seq -- newseq f/word ) +: ?first-break ( seq -- newseq f/element ) dup first first break?>> - [ unclip-slice f swap make-word ] + [ unclip-slice f swap make-element ] [ f ] if ; -: make-words ( seq f/word -- words ) - [ 2 [ ?first2 make-word ] map ] dip +: make-elements ( seq f/element -- elements ) + [ 2 [ ?first2 make-element ] map ] dip [ prefix ] when* ; -: elements>words ( seq -- newseq ) - split-elements ?first-break make-words ; +: segments>elements ( seq -- newseq ) + split-segments ?first-break make-elements ; PRIVATE> -: wrap-elements ( elements line-max line-ideal -- lines ) - [ elements>words ] 2dip wrap [ concat ] map ; +: wrap-segments ( segments line-max line-ideal -- lines ) + [ segments>elements ] 2dip wrap [ concat ] map ; ] map + [ dup length 1 ] map ] map ; -: join-words ( wrapped-lines -- lines ) +: join-elements ( wrapped-lines -- lines ) [ " " join ] map ; : join-lines ( strings -- string ) @@ -159,7 +148,7 @@ PRIVATE> PRIVATE> : wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ dup wrap join-words ] map concat ; + [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; : wrap-string ( string width -- newstring ) wrap-lines join-lines ; diff --git a/extra/lists/lazy/lazy-tests.factor b/extra/lists/lazy/lazy-tests.factor index 5749f94364..03221841c1 100644 --- a/extra/lists/lazy/lazy-tests.factor +++ b/extra/lists/lazy/lazy-tests.factor @@ -1,6 +1,5 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. -! USING: lists lists.lazy tools.test kernel math io sequences ; IN: lists.lazy.tests @@ -27,3 +26,10 @@ IN: lists.lazy.tests [ { 4 5 6 } ] [ 3 { 1 2 3 } >list [ + ] lazy-map-with list>array ] unit-test + +[ [ ] lmap ] must-infer +[ [ ] lmap>array ] must-infer +[ [ drop ] foldr ] must-infer +[ [ drop ] foldl ] must-infer +[ [ drop ] leach ] must-infer +[ lnth ] must-infer diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index e60fcbaadf..213285e643 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -1,12 +1,7 @@ -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! See http://factorcode.org/license.txt for BSD license. -! -! Updated by Matthew Willis, July 2006 -! Updated by Chris Double, September 2006 -! Updated by James Cash, June 2008 -! USING: kernel sequences math vectors arrays namespaces make -quotations promises combinators io lists accessors ; +quotations promises combinators io lists accessors call ; IN: lists.lazy M: promise car ( promise -- car ) @@ -86,7 +81,7 @@ C: lazy-map M: lazy-map car ( lazy-map -- car ) [ cons>> car ] keep - quot>> call ; + quot>> call( old -- new ) ; M: lazy-map cdr ( lazy-map -- cdr ) [ cons>> cdr ] keep @@ -130,7 +125,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> uncons ] keep quot>> tuck call + [ cons>> uncons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -150,7 +145,7 @@ M: lazy-while cdr ( lazy-while -- cdr ) [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- bool ) - [ car ] keep quot>> call not ; + [ car ] keep quot>> call( elt -- ? ) not ; TUPLE: lazy-filter cons quot ; @@ -160,7 +155,7 @@ C: lazy-filter over nil? [ 2drop nil ] [ ] if ; : car-filter? ( lazy-filter -- ? ) - [ cons>> car ] [ quot>> ] bi call ; + [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ; : skip ( lazy-filter -- ) dup cons>> cdr >>cons drop ; @@ -221,7 +216,7 @@ M: lazy-from-by car ( lazy-from-by -- car ) M: lazy-from-by cdr ( lazy-from-by -- cdr ) [ n>> ] keep - quot>> dup slip lfrom-by ; + quot>> [ call( old -- new ) ] keep lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) drop f ; @@ -355,7 +350,8 @@ M: lazy-io car ( lazy-io -- car ) dup car>> dup [ nip ] [ - drop dup stream>> over quot>> call + drop dup stream>> over quot>> + call( stream -- value ) >>car ] if ; diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index bf822889e3..5568b9d53e 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words locals ; - IN: lists ! List Protocol @@ -46,7 +45,7 @@ M: object nil? drop f ; : 2car ( cons -- car caar ) [ car ] [ cdr car ] bi ; -: 3car ( cons -- car caar caaar ) +: 3car ( cons -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; : lnth ( n list -- elt ) @@ -109,4 +108,4 @@ M: object nil? drop f ; [ 2over call [ tuck [ call ] 2dip ] when pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive -INSTANCE: cons list \ No newline at end of file +INSTANCE: cons list diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index 38366697ea..bec2761e53 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -1,10 +1,6 @@ -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -! -! Updated by Matthew Willis, July 2006 -! Updated by Chris Double, September 2006 - -USING: arrays kernel sequences math vectors arrays namespaces +USING: arrays kernel sequences math vectors arrays namespaces call make quotations parser effects stack-checker words accessors ; IN: promises @@ -24,7 +20,7 @@ TUPLE: promise quot forced? value ; #! promises quotation on the stack. Re-forcing the promise #! will return the same value and not recall the quotation. dup forced?>> [ - dup quot>> call >>value + dup quot>> call( -- value ) >>value t >>forced? ] unless value>> ; From 89e3eb6fa312ce7fd2ab777d8768fb9cd3e5ce2c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 8 Feb 2009 23:49:05 -0600 Subject: [PATCH 031/168] Moving lists to basis --- basis/html/templates/chloe/compiler/compiler.factor | 2 +- basis/html/templates/fhtml/fhtml.factor | 2 +- {extra => basis}/lists/authors.txt | 0 {extra => basis}/lists/lazy/authors.txt | 0 {extra => basis}/lists/lazy/examples/authors.txt | 0 {extra => basis}/lists/lazy/examples/examples-tests.factor | 0 {extra => basis}/lists/lazy/examples/examples.factor | 0 {extra => basis}/lists/lazy/lazy-docs.factor | 0 {extra => basis}/lists/lazy/lazy-tests.factor | 0 {extra => basis}/lists/lazy/lazy.factor | 0 {extra => basis}/lists/lazy/old-doc.html | 0 {extra => basis}/lists/lazy/summary.txt | 0 {extra => basis}/lists/lazy/tags.txt | 0 {extra => basis}/lists/lists-docs.factor | 0 {extra => basis}/lists/lists-tests.factor | 0 {extra => basis}/lists/lists.factor | 0 {extra => basis}/lists/summary.txt | 0 {extra => basis}/lists/tags.txt | 0 18 files changed, 2 insertions(+), 2 deletions(-) rename {extra => basis}/lists/authors.txt (100%) rename {extra => basis}/lists/lazy/authors.txt (100%) rename {extra => basis}/lists/lazy/examples/authors.txt (100%) rename {extra => basis}/lists/lazy/examples/examples-tests.factor (100%) rename {extra => basis}/lists/lazy/examples/examples.factor (100%) rename {extra => basis}/lists/lazy/lazy-docs.factor (100%) rename {extra => basis}/lists/lazy/lazy-tests.factor (100%) rename {extra => basis}/lists/lazy/lazy.factor (100%) rename {extra => basis}/lists/lazy/old-doc.html (100%) rename {extra => basis}/lists/lazy/summary.txt (100%) rename {extra => basis}/lists/lazy/tags.txt (100%) rename {extra => basis}/lists/lists-docs.factor (100%) rename {extra => basis}/lists/lists-tests.factor (100%) rename {extra => basis}/lists/lists.factor (100%) rename {extra => basis}/lists/summary.txt (100%) rename {extra => basis}/lists/tags.txt (100%) diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 1a1abc9f7b..3cb7523bdc 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ; : compile-chloe-tag ( tag -- ) dup main>> dup tags get at - [ curry call( -- ) ] + [ call( tag -- ) ] [ unknown-chloe-tag ] ?if ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index e76a812bef..78202d6460 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -72,6 +72,6 @@ TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - '[ _ path>> utf8 file-contents eval-template ] call( -- ) ; + [ path>> utf8 file-contents eval-template ] call( filename -- ) ; INSTANCE: fhtml template diff --git a/extra/lists/authors.txt b/basis/lists/authors.txt similarity index 100% rename from extra/lists/authors.txt rename to basis/lists/authors.txt diff --git a/extra/lists/lazy/authors.txt b/basis/lists/lazy/authors.txt similarity index 100% rename from extra/lists/lazy/authors.txt rename to basis/lists/lazy/authors.txt diff --git a/extra/lists/lazy/examples/authors.txt b/basis/lists/lazy/examples/authors.txt similarity index 100% rename from extra/lists/lazy/examples/authors.txt rename to basis/lists/lazy/examples/authors.txt diff --git a/extra/lists/lazy/examples/examples-tests.factor b/basis/lists/lazy/examples/examples-tests.factor similarity index 100% rename from extra/lists/lazy/examples/examples-tests.factor rename to basis/lists/lazy/examples/examples-tests.factor diff --git a/extra/lists/lazy/examples/examples.factor b/basis/lists/lazy/examples/examples.factor similarity index 100% rename from extra/lists/lazy/examples/examples.factor rename to basis/lists/lazy/examples/examples.factor diff --git a/extra/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor similarity index 100% rename from extra/lists/lazy/lazy-docs.factor rename to basis/lists/lazy/lazy-docs.factor diff --git a/extra/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor similarity index 100% rename from extra/lists/lazy/lazy-tests.factor rename to basis/lists/lazy/lazy-tests.factor diff --git a/extra/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor similarity index 100% rename from extra/lists/lazy/lazy.factor rename to basis/lists/lazy/lazy.factor diff --git a/extra/lists/lazy/old-doc.html b/basis/lists/lazy/old-doc.html similarity index 100% rename from extra/lists/lazy/old-doc.html rename to basis/lists/lazy/old-doc.html diff --git a/extra/lists/lazy/summary.txt b/basis/lists/lazy/summary.txt similarity index 100% rename from extra/lists/lazy/summary.txt rename to basis/lists/lazy/summary.txt diff --git a/extra/lists/lazy/tags.txt b/basis/lists/lazy/tags.txt similarity index 100% rename from extra/lists/lazy/tags.txt rename to basis/lists/lazy/tags.txt diff --git a/extra/lists/lists-docs.factor b/basis/lists/lists-docs.factor similarity index 100% rename from extra/lists/lists-docs.factor rename to basis/lists/lists-docs.factor diff --git a/extra/lists/lists-tests.factor b/basis/lists/lists-tests.factor similarity index 100% rename from extra/lists/lists-tests.factor rename to basis/lists/lists-tests.factor diff --git a/extra/lists/lists.factor b/basis/lists/lists.factor similarity index 100% rename from extra/lists/lists.factor rename to basis/lists/lists.factor diff --git a/extra/lists/summary.txt b/basis/lists/summary.txt similarity index 100% rename from extra/lists/summary.txt rename to basis/lists/summary.txt diff --git a/extra/lists/tags.txt b/basis/lists/tags.txt similarity index 100% rename from extra/lists/tags.txt rename to basis/lists/tags.txt From 57ac121d2b87ab5c3cfd541ec898403e4a0ce273 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 00:33:30 -0600 Subject: [PATCH 032/168] adding execute( -- ) and documentation for basis/call --- basis/call/call-docs.factor | 32 ++++++++++++++++++++++++++++++++ basis/call/call-tests.factor | 5 +++++ basis/call/call.factor | 8 +++++++- 3 files changed, 44 insertions(+), 1 deletion(-) create mode 100644 basis/call/call-docs.factor diff --git a/basis/call/call-docs.factor b/basis/call/call-docs.factor new file mode 100644 index 0000000000..463bfdac09 --- /dev/null +++ b/basis/call/call-docs.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax quotations effects words ; +IN: call + +ABOUT: "call" + +ARTICLE: "call" "Calling code with known stack effects" +"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +{ $subsection call-effect } +{ $subsection execute-effect } ; + +HELP: call( +{ $syntax "[ ] call( foo -- bar )" } +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; + +HELP: call-effect +{ $values { "quot" quotation } { "effect" effect } } +{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ; + +HELP: execute( +{ $syntax "word execute( foo -- bar )" } +{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ; + +HELP: execute-effect +{ $values { "word" word } { "effect" effect } } +{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ; + +{ execute-effect call-effect } related-words +{ POSTPONE: call( POSTPONE: execute( } related-words diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor index 4a59a6d2fb..a2bd11b06a 100644 --- a/basis/call/call-tests.factor +++ b/basis/call/call-tests.factor @@ -8,3 +8,8 @@ IN: call.tests [ 1 2 [ + ] call( x y -- z a ) ] must-fail [ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test [ [ + ] call( x y -- z ) ] must-infer + +[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test +[ 1 2 \ + execute( -- z ) ] must-fail +[ 1 2 \ + execute( x y -- z a ) ] must-fail +[ \ + execute( x y -- z ) ] must-infer diff --git a/basis/call/call.factor b/basis/call/call.factor index 363b024dff..9b49acf64a 100644 --- a/basis/call/call.factor +++ b/basis/call/call.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel macros fry summary sequences generalizations accessors -continuations effects.parser parser ; +continuations effects.parser parser words ; IN: call ERROR: wrong-values values quot length-required ; @@ -22,3 +22,9 @@ MACRO: call-effect ( effect -- quot ) : call( ")" parse-effect parsed \ call-effect parsed ; parsing + +: execute-effect ( word effect -- ) + [ [ execute ] curry ] dip call-effect ; inline + +: execute( + ")" parse-effect parsed \ execute-effect parsed ; parsing From 3e5ec77439381fe12318d4faecc925a953f7cace Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 01:12:32 -0600 Subject: [PATCH 033/168] Splitting up basis/wrap into three vocabs --- basis/wrap/strings/strings-docs.factor | 25 +++++ basis/wrap/strings/strings-tests.factor | 41 ++++++++ basis/wrap/strings/strings.factor | 29 ++++++ basis/wrap/words/words-docs.factor | 25 +++++ basis/wrap/words/words-tests.factor | 82 ++++++++++++++++ basis/wrap/words/words.factor | 40 ++++++++ basis/wrap/wrap-docs.factor | 36 +------- basis/wrap/wrap-tests.factor | 118 ------------------------ basis/wrap/wrap.factor | 66 +------------ basis/xml/writer/writer.factor | 2 +- 10 files changed, 248 insertions(+), 216 deletions(-) create mode 100644 basis/wrap/strings/strings-docs.factor create mode 100644 basis/wrap/strings/strings-tests.factor create mode 100644 basis/wrap/strings/strings.factor create mode 100644 basis/wrap/words/words-docs.factor create mode 100644 basis/wrap/words/words-tests.factor create mode 100644 basis/wrap/words/words.factor delete mode 100644 basis/wrap/wrap-tests.factor diff --git a/basis/wrap/strings/strings-docs.factor b/basis/wrap/strings/strings-docs.factor new file mode 100644 index 0000000000..e20780d3ac --- /dev/null +++ b/basis/wrap/strings/strings-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup strings math ; +IN: wrap.strings + +ABOUT: "wrap.strings" + +ARTICLE: "wrap.strings" "String word wrapping" +"The " { $vocab-link "wrap.strings" } " vocabulary implements word wrapping for simple strings, assumed to be in monospace font." +{ $subsection wrap-lines } +{ $subsection wrap-string } +{ $subsection wrap-indented-string } ; + +HELP: wrap-lines +{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } +{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ; + +HELP: wrap-string +{ $values { "string" string } { "width" integer } { "newstring" string } } +{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ; + +HELP: wrap-indented-string +{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } } +{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ; + diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor new file mode 100644 index 0000000000..0bea9b5d32 --- /dev/null +++ b/basis/wrap/strings/strings-tests.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: wrap.strings tools.test multiline ; +IN: wrap.strings.tests + +[ + <" This is a +long piece +of text +that we +wish to +word wrap."> +] [ + <" This is a long piece of text that we wish to word wrap."> 10 + wrap-string +] unit-test + +[ + <" This is a + long piece + of text + that we + wish to + word wrap."> +] [ + <" This is a long piece of text that we wish to word wrap."> 12 + " " wrap-indented-string +] unit-test + +[ "this text\nhas lots\nof spaces" ] +[ "this text has lots of spaces" 12 wrap-string ] unit-test + +[ "hello\nhow\nare\nyou\ntoday?" ] +[ "hello how are you today?" 3 wrap-string ] unit-test + +[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test +[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test +[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test +[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test + +\ wrap-string must-infer diff --git a/basis/wrap/strings/strings.factor b/basis/wrap/strings/strings.factor new file mode 100644 index 0000000000..7009352f2a --- /dev/null +++ b/basis/wrap/strings/strings.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: wrap kernel sequences fry splitting math ; +IN: wrap.strings + + ] map + ] map ; + +: join-elements ( wrapped-lines -- lines ) + [ " " join ] map ; + +: join-lines ( strings -- string ) + "\n" join ; + +PRIVATE> + +: wrap-lines ( lines width -- newlines ) + [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; + +: wrap-string ( string width -- newstring ) + wrap-lines join-lines ; + +: wrap-indented-string ( string width indent -- newstring ) + [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ; diff --git a/basis/wrap/words/words-docs.factor b/basis/wrap/words/words-docs.factor new file mode 100644 index 0000000000..422aea0ac3 --- /dev/null +++ b/basis/wrap/words/words-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup math kernel ; +IN: wrap.words + +ABOUT: "wrap.words" + +ARTICLE: "wrap.words" "Word object wrapping" +"The " { $vocab-link "wrap.words" } " vocabulary implements word wrapping on abstract word objects, which have certain properties making it a more suitable input representation than strings." +{ $subsection wrap-words } +{ $subsection word } +{ $subsection } ; + +HELP: wrap-words +{ $values { "words" { "a sequence of " { $instance word } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } +{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; + +HELP: word +{ $class-description "A word is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link } "." } +{ $see-also wrap-words } ; + +HELP: +{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } } +{ $description "Creates a " { $link word } " object with the given parameters." } +{ $see-also wrap-words } ; diff --git a/basis/wrap/words/words-tests.factor b/basis/wrap/words/words-tests.factor new file mode 100644 index 0000000000..7598b382ba --- /dev/null +++ b/basis/wrap/words/words-tests.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test wrap.words sequences ; +IN: wrap.words.tests + +[ + { + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 2 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 2 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +[ + { + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 3 9 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 3 9 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +[ + { + { + T{ word f 1 10 t } + T{ word f 1 10 f } + T{ word f 3 9 t } + } + { + T{ word f 2 10 f } + T{ word f 3 9 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 t } + T{ word f 1 10 f } + T{ word f 3 9 t } + T{ word f 2 10 f } + T{ word f 3 9 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 35 wrap-words [ { } like ] map +] unit-test + +\ wrap-words must-infer diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor new file mode 100644 index 0000000000..00f257a5cf --- /dev/null +++ b/basis/wrap/words/words.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences kernel splitting.monotonic accessors wrap grouping ; +IN: wrap.words + +TUPLE: word key width break? ; +C: word + +> ] map sum ; + +: make-element ( whites blacks -- element ) + [ append ] [ [ words-length ] bi@ ] 2bi ; + +: ?first2 ( seq -- first/f second/f ) + [ 0 swap ?nth ] + [ 1 swap ?nth ] bi ; + +: split-words ( seq -- half-elements ) + [ [ break?>> ] bi@ = ] monotonic-split ; + +: ?first-break ( seq -- newseq f/element ) + dup first first break?>> + [ unclip-slice f swap make-element ] + [ f ] if ; + +: make-elements ( seq f/element -- elements ) + [ 2 [ ?first2 make-element ] map ] dip + [ prefix ] when* ; + +: words>elements ( seq -- newseq ) + split-words ?first-break make-elements ; + +PRIVATE> + +: wrap-words ( words line-max line-ideal -- lines ) + [ words>elements ] 2dip wrap [ concat ] map ; + diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index 59c0352bc7..feac7c51a7 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -6,36 +6,6 @@ IN: wrap ABOUT: "wrap" ARTICLE: "wrap" "Word wrapping" -"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. There is support for simple string wrapping, with the following words:" -{ $subsection wrap-lines } -{ $subsection wrap-string } -{ $subsection wrap-indented-string } -"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called segments." -{ $subsection wrap-segments } -{ $subsection segment } -{ $subsection } ; - -HELP: wrap-lines -{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } } -{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ; - -HELP: wrap-string -{ $values { "string" string } { "width" integer } { "newstring" string } } -{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ; - -HELP: wrap-indented-string -{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } } -{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ; - -HELP: wrap-segments -{ $values { "segments" { "a sequence of " { $instance segment } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } } -{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ; - -HELP: segment -{ $class-description "A segment is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Elements can be created with " { $link } "." } -{ $see-also wrap-segments } ; - -HELP: -{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "segment" segment } } -{ $description "Creates a " { $link segment } " object with the given parameters." } -{ $see-also wrap-segments } ; +"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. Wrapping can take place based on simple strings, assumed to be monospace, or abstract word objects." +{ $vocab-subsection "String word wrapping" "wrap.strings" } +{ $vocab-subsection "Word object wrapping" "wrap.words" } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor deleted file mode 100644 index eeea3850d5..0000000000 --- a/basis/wrap/wrap-tests.factor +++ /dev/null @@ -1,118 +0,0 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test wrap multiline sequences ; -IN: wrap.tests - -[ - { - { - T{ segment f 1 10 f } - T{ segment f 2 10 f } - T{ segment f 3 2 t } - } - { - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } - } -] [ - { - T{ segment f 1 10 f } - T{ segment f 2 10 f } - T{ segment f 3 2 t } - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } 35 35 wrap-segments [ { } like ] map -] unit-test - -[ - { - { - T{ segment f 1 10 f } - T{ segment f 2 10 f } - T{ segment f 3 9 t } - T{ segment f 3 9 t } - T{ segment f 3 9 t } - } - { - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } - } -] [ - { - T{ segment f 1 10 f } - T{ segment f 2 10 f } - T{ segment f 3 9 t } - T{ segment f 3 9 t } - T{ segment f 3 9 t } - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } 35 35 wrap-segments [ { } like ] map -] unit-test - -[ - { - { - T{ segment f 1 10 t } - T{ segment f 1 10 f } - T{ segment f 3 9 t } - } - { - T{ segment f 2 10 f } - T{ segment f 3 9 t } - } - { - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } - } -] [ - { - T{ segment f 1 10 t } - T{ segment f 1 10 f } - T{ segment f 3 9 t } - T{ segment f 2 10 f } - T{ segment f 3 9 t } - T{ segment f 4 10 f } - T{ segment f 5 10 f } - } 35 35 wrap-segments [ { } like ] map -] unit-test - -[ - <" This is a -long piece -of text -that we -wish to -word wrap."> -] [ - <" This is a long piece of text that we wish to word wrap."> 10 - wrap-string -] unit-test - -[ - <" This is a - long piece - of text - that we - wish to - word wrap."> -] [ - <" This is a long piece of text that we wish to word wrap."> 12 - " " wrap-indented-string -] unit-test - -[ "this text\nhas lots\nof spaces" ] -[ "this text has lots of spaces" 12 wrap-string ] unit-test - -[ "hello\nhow\nare\nyou\ntoday?" ] -[ "hello how are you today?" 3 wrap-string ] unit-test - -[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test -[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test -[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test -[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test - -\ wrap-string must-infer -\ wrap-segments must-infer diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index f54c858bf4..55fe10283a 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,10 +1,10 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences math arrays locals fry accessors lists splitting call make combinators.short-circuit namespaces grouping splitting.monotonic ; IN: wrap - element @@ -93,65 +93,3 @@ SYMBOL: line-ideal min-cost post-process ] with-scope ; - -PRIVATE> - -TUPLE: segment key width break? ; -C: segment - -> ] map sum ; - -: make-element ( whites blacks -- element ) - [ append ] [ [ segments-length ] bi@ ] 2bi ; - -: ?first2 ( seq -- first/f second/f ) - [ 0 swap ?nth ] - [ 1 swap ?nth ] bi ; - -: split-segments ( seq -- half-elements ) - [ [ break?>> ] bi@ = ] monotonic-split ; - -: ?first-break ( seq -- newseq f/element ) - dup first first break?>> - [ unclip-slice f swap make-element ] - [ f ] if ; - -: make-elements ( seq f/element -- elements ) - [ 2 [ ?first2 make-element ] map ] dip - [ prefix ] when* ; - -: segments>elements ( seq -- newseq ) - split-segments ?first-break make-elements ; - -PRIVATE> - -: wrap-segments ( segments line-max line-ideal -- lines ) - [ segments>elements ] 2dip wrap [ concat ] map ; - - ] map - ] map ; - -: join-elements ( wrapped-lines -- lines ) - [ " " join ] map ; - -: join-lines ( strings -- string ) - "\n" join ; - -PRIVATE> - -: wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; - -: wrap-string ( string width -- newstring ) - wrap-lines join-lines ; - -: wrap-indented-string ( string width indent -- newstring ) - [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ; diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 4b80e0818e..4f5bad1aa5 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings assocs combinators io io.streams.string accessors -xml.data wrap xml.entities unicode.categories fry ; +xml.data wrap.strings xml.entities unicode.categories fry ; IN: xml.writer SYMBOL: sensitive-tags From 25d20c6000d36dc0d04c52ad5b2998bb23a1af2b Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 8 Feb 2009 23:45:59 -0800 Subject: [PATCH 034/168] Update docs for GENERIC: GENERIC# and HOOK to show stack effect decl --- core/syntax/syntax-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index e08821bddd..035622454f 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -551,12 +551,12 @@ HELP: BIN: { $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ; HELP: GENERIC: -{ $syntax "GENERIC: word" } +{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" } { $values { "word" "a new word to define" } } { $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ; HELP: GENERIC# -{ $syntax "GENERIC# word n" } +{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" } { $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } } { $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } { $notes @@ -571,7 +571,7 @@ HELP: MATH: { $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ; HELP: HOOK: -{ $syntax "HOOK: word variable" } +{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " } { $values { "word" "a new word to define" } { "variable" word } } { $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." } { $examples From 3bc557467e7b01b472bc4372927634a84489847a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 11:40:05 -0600 Subject: [PATCH 035/168] shuffle( -- ) arbitrary stack shuffling word --- basis/shuffle/shuffle-tests.factor | 2 ++ basis/shuffle/shuffle.factor | 23 +++++++++++++++++++++-- 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index f190544e19..8202146b3d 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -3,3 +3,5 @@ USING: shuffle tools.test ; [ 8 ] [ 5 6 7 8 3nip ] unit-test [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test + +[ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index b195e4abf9..632c09e338 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -1,9 +1,28 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generalizations ; - +USING: accessors assocs effects.parser generalizations +hashtables kernel locals locals.backend macros make math +parser sequences ; IN: shuffle +locals-assoc ( sequence -- assoc ) + dup length dup 1- [ - ] curry map zip >hashtable ; + +PRIVATE> + +MACRO: shuffle-effect ( effect -- ) + [ out>> ] [ in>> >locals-assoc ] bi + [ + [ nip assoc-size , \ load-locals , ] + [ [ at , \ get-local , ] curry each ] + [ nip assoc-size , \ drop-locals , ] 2tri + ] [ ] make ; + +: shuffle( + ")" parse-effect parsed \ shuffle-effect parsed ; parsing + : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline : nipd ( a b c -- b c ) rot drop ; inline From 4dd500b5b1ab7d96fb1608f176782a5f57a1abc5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 13:29:50 -0600 Subject: [PATCH 036/168] fortran-invoke works(?) --- basis/alien/fortran/fortran-tests.factor | 98 ++++++------ basis/alien/fortran/fortran.factor | 194 +++++++++++++++-------- 2 files changed, 184 insertions(+), 108 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 0a86cba7e3..9b618ef513 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,7 +1,9 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.fortran alien.structs -alien.syntax arrays assocs kernel macros namespaces sequences -tools.test fry ; +USING: accessors alien alien.c-types alien.complex +alien.fortran alien.strings alien.structs alien.syntax arrays +assocs byte-arrays combinators fry generalizations +io.encodings.ascii kernel macros macros.expander namespaces +sequences shuffle tools.test ; IN: alien.fortran.tests RECORD: FORTRAN_TEST_RECORD @@ -169,17 +171,14 @@ unit-test [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test -! fortran-invoke - -: fortran-invoke-expansion ( return library function parameters -- quot ) - '[ _ _ _ _ fortran-invoke ] expand-macros ; inline +! (fortran-invoke) [ [ ! [fortran-args>c-args] { [ { [ ascii string>alien ] - [ ] + [ ] [ ] [ ] [ 1 0 ? ] @@ -188,100 +187,109 @@ unit-test } 5 ncleave ! [fortran-invoke] [ - "void" "foopack" "funtimes_" - { "char*" "int*" "float*" "complex-float*" "short*" "long" } + "void" "funpack" "funtimes_" + { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } alien-invoke ] 6 nkeep ! [fortran-results>] + shuffle( aa ba ca da ea ab -- aa ab ba ca da ea ) { + [ drop ] [ drop ] [ drop ] [ *float ] [ drop ] [ drop ] - [ drop ] } spread ] ] [ - f "foopack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } - fortran-invoke-expansion + f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } + (fortran-invoke) ] unit-test [ [ + ! [fortran-args>c-args] + { + [ { [ ] } spread ] + [ { [ drop ] } spread ] + } 1 ncleave ! [fortran-invoke] - "double" "foopack" "fun_times__" - { "float*" } - alien-invoke + [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ] + 1 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ ] [ drop ] } spread ] ] [ - "REAL" "foopack" "FUN_TIMES" { "REAL(*)" } - fortran-invoke-expansion + "REAL" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) ] unit-test [ [ ! [] [ "complex-float" ] 1 ndip + ! [fortran-args>c-args] + { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] [ - "void" "foopack" "fun_times__" + "void" "funpack" "fun_times__" { "complex-float*" "float*" } alien-invoke ] 2 nkeep ! [fortran-results>] - { - [ *complex-float ] - [ drop ] - } spread + shuffle( reta aa -- reta aa ) + { [ *complex-float ] [ drop ] } spread ] ] [ - "COMPLEX" "foopack" "FUN_TIMES" { "REAL(*)" } - fortran-invoke-expansion + "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) ] unit-test [ [ ! [] - [ 20 20 ] 1 ndip + [ 20 20 ] 0 ndip ! [fortran-invoke] [ - "void" "foopack" "fun_times__" - { "char*" "long" "float*" } + "void" "funpack" "fun_times__" + { "char*" "long" } alien-invoke - ] 3 nkeep + ] 2 nkeep ! [fortran-results>] - { - [ ] - [ ascii alien>nstring ] - [ drop ] - } spread + shuffle( reta retb -- reta retb ) + { [ ] [ ascii alien>nstring ] } spread ] ] [ - "CHARACTER*20" "foopack" "FUN_TIMES" { } - fortran-invoke-expansion + "CHARACTER*20" "funpack" "FUN_TIMES" { } + (fortran-invoke) ] unit-test [ [ ! [] - [ 10 10 ] 2 ndip + [ 10 10 ] 3 ndip ! [fortran-args>c-args] { [ { [ ascii string>alien ] [ ] + [ ascii string>alien ] } spread ] - [ { [ length ] [ drop ] } spread ] - } 2 ncleave + [ { [ length ] [ drop ] [ length ] } spread ] + } 3 ncleave ! [fortran-invoke] [ - "void" "foopack" "fun_times__" - { "char*" "long" "char*" "float*" "long" } + "void" "funpack" "fun_times__" + { "char*" "long" "char*" "float*" "char*" "long" "long" } alien-invoke - ] 5 nkeep + ] 7 nkeep ! [fortran-results>] + shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) { [ ] [ ascii alien>nstring ] [ ] - [ *float swap ] + [ ascii alien>nstring ] + [ *float ] + [ ] [ ascii alien>nstring ] } spread ] ] [ - "CHARACTER*10" "foopack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" } - fortran-invoke-expansion + "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" } + (fortran-invoke) ] unit-test diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index b0bbedd716..85fa0e536e 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -1,8 +1,11 @@ ! (c) 2009 Joe Groff, see BSD license -USING: accessors alien alien.c-types alien.structs alien.syntax -arrays ascii assocs combinators fry kernel lexer macros math.parser -namespaces parser sequences splitting vectors vocabs.parser locals -io.encodings.ascii io.encodings.string ; +USING: accessors alien alien.c-types alien.complex alien.parser +alien.strings alien.structs alien.syntax arrays ascii assocs +byte-arrays combinators combinators.short-circuit fry generalizations +kernel lexer macros math math.parser namespaces parser sequences +splitting stack-checker vectors vocabs.parser words locals +io.encodings.ascii io.encodings.string shuffle effects math.ranges +math.order sorting ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. @@ -18,6 +21,8 @@ IN: alien.fortran ERROR: invalid-fortran-type type ; DEFER: fortran-sig>c-sig +DEFER: fortran-ret-type>c-type +DEFER: fortran-arg-type>c-type c-type) M: double-precision-type (fortran-type>c-type) "double" simple-type ; M: double-complex-type (fortran-type>c-type) - "(fortran-double-complex)" simple-type ; + "complex-double" simple-type ; M: misc-type (fortran-type>c-type) dup name>> simple-type ; @@ -118,7 +123,7 @@ M: character-type (fortran-type>c-type) : (parse-fortran-type) ( fortran-type-string -- type ) parse-out swap parse-dims swap parse-size swap dup >lower fortran>c-types at* - [ nip new-fortran-type ] [ drop f misc-type boa ] if ; + [ nip new-fortran-type ] [ drop misc-type boa ] if ; : parse-fortran-type ( fortran-type-string/f -- type/f ) dup [ (parse-fortran-type) ] when ; @@ -149,40 +154,49 @@ M: real-type (fortran-ret-type>c-type) drop "double" ; GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot ) +: args?dims ( type quot -- main-quot added-quot ) + [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline + M: integer-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 1 [ [ ] [ drop ] ] } - { 2 [ [ ] [ drop ] ] } - { 4 [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: logical-type (fortran-arg>c-args) - call-next-method [ [ 1 0 ? ] prepend ] dip ; + [ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ; M: real-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 4 [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: real-complex-type (fortran-arg>c-args) - size>> { - { f [ [ ] [ drop ] ] } - { 8 [ [ ] [ drop ] ] } - { 16 [ [ ] [ drop ] ] } - [ invalid-fortran-type ] - } case ; + [ + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; M: double-precision-type (fortran-arg>c-args) - drop [ ] [ drop ] ; + [ drop [ ] [ drop ] ] args?dims ; M: double-complex-type (fortran-arg>c-args) - drop [ ] [ drop ] ; + [ drop [ ] [ drop ] ] args?dims ; M: character-type (fortran-arg>c-args) drop [ ascii string>alien ] [ length ] ; @@ -190,72 +204,122 @@ M: character-type (fortran-arg>c-args) M: misc-type (fortran-arg>c-args) drop [ ] [ drop ] ; -GENERIC: (fortran-result>) ( type -- quot ) +GENERIC: (fortran-result>) ( type -- quots ) + +: result?dims ( type quot -- quot ) + [ dup dims>> [ drop { [ ] } ] ] dip if ; inline M: integer-type (fortran-result>) - size>> { - { f [ [ *int ] ] } - { 1 [ [ *char ] ] } - { 2 [ [ *short ] ] } - { 4 [ [ *int ] ] } - { 8 [ [ *longlong ] ] } + [ size>> { + { f [ { [ *int ] } ] } + { 1 [ { [ *char ] } ] } + { 2 [ { [ *short ] } ] } + { 4 [ { [ *int ] } ] } + { 8 [ { [ *longlong ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: logical-type (fortran-result>) - call-next-method [ zero? not ] append ; + [ call-next-method first [ zero? not ] append 1array ] result?dims ; M: real-type (fortran-result>) - size>> { - { f [ [ *float ] ] } - { 4 [ [ *float ] ] } - { 8 [ [ *double ] ] } + [ size>> { + { f [ { [ *float ] } ] } + { 4 [ { [ *float ] } ] } + { 8 [ { [ *double ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: real-complex-type (fortran-result>) - size>> { - { f [ [ *complex-float ] ] } - { 8 [ [ *complex-float ] ] } - { 16 [ [ *complex-double ] ] } + [ size>> { + { f [ { [ *complex-float ] } ] } + { 8 [ { [ *complex-float ] } ] } + { 16 [ { [ *complex-double ] } ] } [ invalid-fortran-type ] - } case ; + } case ] result?dims ; M: double-precision-type (fortran-result>) - drop [ *double ] ; + [ drop { [ *double ] } ] result?dims ; M: double-complex-type (fortran-result>) - drop [ *complex-double ] ; + [ drop { [ *complex-double ] } ] result?dims ; M: character-type (fortran-result>) - drop [ ascii alien>nstring ] ; + drop { [ ] [ ascii alien>nstring ] } ; M: misc-type (fortran-result>) - drop [ ] ; + drop { [ ] } ; GENERIC: () ( type -- quot ) M: fortran-type () - (fortran-type>c-type) '[ _ ] ; + (fortran-type>c-type) \ [ ] 2sequence ; + +M: character-type () + fix-character-type dims>> product dup + [ \ ] dip [ ] 3sequence ; : [] ( return parameters -- quot ) [ parse-fortran-type ] dip over returns-by-value? [ 2drop [ ] ] - [ [ () ] [ '[ _ _ ndip ] ] bi* ] if ; + [ [ () ] [ length \ ndip [ ] 3sequence ] bi* ] if ; : [fortran-args>c-args] ( parameters -- quot ) - [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 - [ [ '[ _ spread ] ] bi@ 2array ] [ length ] bi - '[ _ _ ncleave ] ; + [ [ ] ] [ + [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2 + [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi + \ ncleave [ ] 3sequence + ] if-empty ; -:: [fortran-invoke] ( return library function parameters -- quot ) +:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot ) return parameters fortran-sig>c-sig :> c-parameters :> c-return function fortran-name>symbol-name :> c-function - [ c-return library c-function c-parameters alien-invoke ] ; + [args>args] + c-return library c-function c-parameters \ alien-invoke + 5 [ ] nsequence + c-parameters length \ nkeep + [ ] 3sequence ; + +: [fortran-out-param>] ( parameter -- quot ) + parse-fortran-type + [ (fortran-result>) ] [ out?>> ] bi + [ ] [ [ drop [ drop ] ] map ] if ; + +: [fortran-return>] ( return -- quot ) + parse-fortran-type { + { [ dup not ] [ drop { } ] } + { [ dup returns-by-value? ] [ drop { [ ] } ] } + [ (fortran-result>) ] + } cond ; + +: letters ( -- seq ) CHAR: a CHAR: z [a,b] ; + +: (shuffle-map) ( return parameters -- ret par ) + [ + fortran-ret-type>c-type length swap "void" = [ 1+ ] unless + letters swap head [ "ret" swap suffix ] map + ] [ + [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip + [ first2 letters swap head [ "" 2sequence ] with map ] map concat + ] bi* ; + +: (fortran-in-shuffle) ( ret par -- seq ) + [ [ second ] bi@ <=> ] sort append ; + +: (fortran-out-shuffle) ( ret par -- seq ) + append ; + +: [fortran-result-shuffle] ( return parameters -- quot ) + (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi + \ shuffle-effect [ ] 2sequence ; : [fortran-results>] ( return parameters -- quot ) - 2drop [ ] ; + [ [fortran-result-shuffle] ] + [ drop [fortran-return>] ] + [ nip [ [fortran-out-param>] ] map concat ] 2tri + append + \ spread [ ] 2sequence append ; PRIVATE> @@ -289,22 +353,26 @@ PRIVATE> : RECORD: scan in get parse-definition define-fortran-record ; parsing -MACRO: fortran-invoke ( return library function parameters -- ) +: (fortran-invoke) ( return library function parameters -- quot ) { [ 2nip [] ] [ nip nip nip [fortran-args>c-args] ] [ [fortran-invoke] ] [ 2nip [fortran-results>] ] - } 4 ncleave 3append ; + } 4 ncleave 4 nappend ; + +MACRO: fortran-invoke ( return library function parameters -- ) + (fortran-invoke) ; :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic return library function parameters return parse-arglist - [ '[ _ _ _ _ fortran-invoke ] ] dip define-declared ; + [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; : SUBROUTINE: f "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing + : FUNCTION: scan "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing From 0522f63e5fe9154bbfada242e65f14f262650c9e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:20:29 -0600 Subject: [PATCH 037/168] alien.fortran metadata --- basis/alien/fortran/authors.txt | 1 + basis/alien/fortran/summary.txt | 1 + basis/alien/fortran/tags.txt | 2 ++ 3 files changed, 4 insertions(+) create mode 100644 basis/alien/fortran/authors.txt create mode 100644 basis/alien/fortran/summary.txt create mode 100644 basis/alien/fortran/tags.txt diff --git a/basis/alien/fortran/authors.txt b/basis/alien/fortran/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/alien/fortran/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/alien/fortran/summary.txt b/basis/alien/fortran/summary.txt new file mode 100644 index 0000000000..8ed8b0ca00 --- /dev/null +++ b/basis/alien/fortran/summary.txt @@ -0,0 +1 @@ +GNU Fortran/G77/F2C alien interface diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt new file mode 100644 index 0000000000..2a9b5def7a --- /dev/null +++ b/basis/alien/fortran/tags.txt @@ -0,0 +1,2 @@ +fortran +ffi From 3b83d9f760304b55617f7664db5d795fdcce34dc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:20:52 -0600 Subject: [PATCH 038/168] fortran ffi for blas --- basis/math/blas/ffi/authors.txt | 1 + basis/math/blas/ffi/ffi.factor | 528 ++++++++++++++++++++++++++++++++ basis/math/blas/ffi/summary.txt | 1 + basis/math/blas/ffi/tags.txt | 3 + 4 files changed, 533 insertions(+) create mode 100644 basis/math/blas/ffi/authors.txt create mode 100644 basis/math/blas/ffi/ffi.factor create mode 100644 basis/math/blas/ffi/summary.txt create mode 100644 basis/math/blas/ffi/tags.txt diff --git a/basis/math/blas/ffi/authors.txt b/basis/math/blas/ffi/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/math/blas/ffi/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor new file mode 100644 index 0000000000..7b0138357a --- /dev/null +++ b/basis/math/blas/ffi/ffi.factor @@ -0,0 +1,528 @@ +USING: alien alien.fortran kernel system combinators ; +IN: math.blas.ffi + +<< +"blas" { + { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } + { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } + [ "libblas.so" "cdecl" add-library ] +} cond +>> + +LIBRARY: blas + +! Level 1 BLAS (scalar-vector and vector-vector) + +FUNCTION: REAL SDSDOT + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-PRECISION DSDOT + ( INTEGER N, DOUBLE-PRECISION-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: REAL SDOT + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +FUNCTION: DOUBLE-PRECISION DDOT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; + +FUNCTION: COMPLEX CDOTU + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +FUNCTION: COMPLEX CDOTC + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: DOUBLE-COMPLEX ZDOTU + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: DOUBLE-COMPLEX ZDOTC + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; + +FUNCTION: REAL SNRM2 + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; +FUNCTION: REAL SASUM + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; + +FUNCTION: DOUBLE-PRECISION DNRM2 + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +FUNCTION: DOUBLE-PRECISION DASUM + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; + +FUNCTION: REAL SCNRM2 + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: REAL SCASUM + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; + +FUNCTION: DOUBLE-PRECISION DZNRM2 + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: DOUBLE-PRECISION DZASUM + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +FUNCTION: INTEGER ISAMAX + ( INTEGER N, REAL(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER IDAMAX + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER ICAMAX + ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ; +FUNCTION: INTEGER IZAMAX + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: SSWAP + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SCOPY + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SAXPY + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; + +SUBROUTINE: DSWAP + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DCOPY + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DAXPY + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; + +SUBROUTINE: CSWAP + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CCOPY + ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CAXPY + ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: ZSWAP + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZCOPY + ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZAXPY + ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; + +SUBROUTINE: SSCAL + ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: DSCAL + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: CSCAL + ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZSCAL + ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CSSCAL + ( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZDSCAL + ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: SROTG + ( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ; +SUBROUTINE: SROTMG + ( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ; +SUBROUTINE: SROT + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ; +SUBROUTINE: SROTM + ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ; + +SUBROUTINE: DROTG + ( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ; +SUBROUTINE: DROTMG + ( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ; +SUBROUTINE: DROT + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ; +SUBROUTINE: DROTM + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ; + +! LEVEL 2 BLAS (MATRIX-VECTOR) + +SUBROUTINE: SGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX, REAL BETA, + REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, REAL ALPHA, + REAL(*) A, INTEGER LDA, REAL(*) X, + INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: STRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X, + INTEGER INCX ) ; +SUBROUTINE: STBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA, + REAL(*) X, INTEGER INCX ) ; +SUBROUTINE: STPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; + +SUBROUTINE: DGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA, + DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, + INTEGER INCX ) ; +SUBROUTINE: DTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) X, INTEGER INCX ) ; +SUBROUTINE: DTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; + +SUBROUTINE: CGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, + COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, COMPLEX ALPHA, + COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, + INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, + INTEGER INCX ) ; +SUBROUTINE: CTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: CTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; + +SUBROUTINE: ZGEMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZGBMV ( CHARACTER*1 ORDER, + CHARACTER*1 TRANSA, INTEGER M, INTEGER N, + INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA, + DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, + INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, + INTEGER INCX ) ; +SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; +SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO, + CHARACTER*1 TRANSA, CHARACTER*1 DIAG, + INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ; + + +SUBROUTINE: SSYMV ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SSBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SSPMV ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) AP, + REAL(*) X, INTEGER INCX, + REAL BETA, REAL(*) Y, INTEGER INCY ) ; +SUBROUTINE: SGER ( INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) X, INTEGER INCX, + REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ; +SUBROUTINE: SSYR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) A, INTEGER LDA ) ; +SUBROUTINE: SSPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) AP ) ; +SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A, + INTEGER LDA ) ; +SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, REAL(*) X, + INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ; + +SUBROUTINE: DSYMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DSBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DSPMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP, + DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; +SUBROUTINE: DGER ( INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, + DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ; +SUBROUTINE: DSYR ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ; +SUBROUTINE: DSPR ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) AP ) ; +SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, + INTEGER LDA ) ; +SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, + INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ; + + +SUBROUTINE: CHEMV ( CHARACTER*1 UPLO, + INTEGER N, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CHBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CHPMV ( CHARACTER*1 UPLO, + INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP, + COMPLEX(*) X, INTEGER INCX, + COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: CGERU ( INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CGERC ( INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHER ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, COMPLEX(*) X, + INTEGER INCX, COMPLEX(*) A ) ; +SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, + COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ; + +SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO, + INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO, + INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP, + DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; +SUBROUTINE: ZGERU ( INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZGERC ( INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHER ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHPR ( CHARACTER*1 UPLO, + INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, + INTEGER INCX, DOUBLE-COMPLEX(*) A ) ; +SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ; +SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, + DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ; + +! LEVEL 3 BLAS (MATRIX-MATRIX) + +SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, REAL ALPHA, REAL(*) A, + INTEGER LDA, REAL(*) B, INTEGER LDB, + REAL BETA, REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB, REAL BETA, + REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL BETA, REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB, REAL BETA, + REAL(*) C, INTEGER LDC ) ; +SUBROUTINE: STRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB ) ; +SUBROUTINE: STRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + REAL ALPHA, REAL(*) A, INTEGER LDA, + REAL(*) B, INTEGER LDB ) ; + +SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, + INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA, + DOUBLE-PRECISION(*) C, INTEGER LDC ) ; +SUBROUTINE: DTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB ) ; +SUBROUTINE: DTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, + DOUBLE-PRECISION(*) B, INTEGER LDB ) ; + +SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, COMPLEX ALPHA, COMPLEX(*) A, + INTEGER LDA, COMPLEX(*) B, INTEGER LDB, + COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB ) ; +SUBROUTINE: CTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB ) ; + +SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA, + CHARACTER*1 TRANSB, INTEGER M, INTEGER N, + INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, + INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB ) ; +SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, CHARACTER*1 TRANSA, + CHARACTER*1 DIAG, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB ) ; + +SUBROUTINE: CHEMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, COMPLEX BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CHERK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, COMPLEX(*) A, INTEGER LDA, + REAL BETA, COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: CHER2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, + COMPLEX(*) B, INTEGER LDB, REAL BETA, + COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE, + CHARACTER*1 UPLO, INTEGER M, INTEGER N, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHERK ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; +SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO, + CHARACTER*1 TRANS, INTEGER N, INTEGER K, + DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, + DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA, + DOUBLE-COMPLEX(*) C, INTEGER LDC ) ; diff --git a/basis/math/blas/ffi/summary.txt b/basis/math/blas/ffi/summary.txt new file mode 100644 index 0000000000..8c0106b173 --- /dev/null +++ b/basis/math/blas/ffi/summary.txt @@ -0,0 +1 @@ +Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt new file mode 100644 index 0000000000..f468a9989d --- /dev/null +++ b/basis/math/blas/ffi/tags.txt @@ -0,0 +1,3 @@ +math +bindings +fortran From 35b526cc7a034fb945342ab53c247a04abc4791c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 14:29:09 -0600 Subject: [PATCH 039/168] Docs for lists, consolidating list functionality in lists, minor API changes --- basis/lists/lazy/lazy.factor | 4 +- basis/lists/lists-docs.factor | 133 ++++++++++++++---- basis/lists/lists-tests.factor | 20 +-- basis/lists/lists.factor | 123 ++++++++++------ basis/persistent/deques/deques-docs.factor | 2 + basis/persistent/deques/deques.factor | 47 +++---- basis/urls/urls-docs.factor | 4 +- basis/wrap/wrap.factor | 14 +- core/math/math-docs.factor | 2 +- .../parser-combinators.factor | 2 +- extra/project-euler/134/134.factor | 2 +- 11 files changed, 221 insertions(+), 132 deletions(-) diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 213285e643..5adb7a8be5 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -125,7 +125,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> uncons ] keep quot>> tuck call( elt -- ? ) + [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -284,7 +284,7 @@ DEFER: lconcat dup nil? [ drop nil ] [ - uncons swap (lconcat) + uncons (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 8807c8cf8a..8494d7c352 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -1,15 +1,68 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel help.markup help.syntax ; - +USING: kernel help.markup help.syntax arrays sequences math quotations ; IN: lists -{ car cons cdr nil nil? list? uncons } related-words +ABOUT: "lists" + +ARTICLE: "lists" "Lists" +"The " { $vocab-link "lists" } " vocabulary implements linked lists. There are simple strict linked lists, but a generic list protocol allows the implementation of lazy lists as well." +{ $subsection { "lists" "protocol" } } +{ $subsection { "lists" "strict" } } +{ $subsection { "lists" "manipulation" } } +{ $subsection { "lists" "combinators" } } +{ $vocab-subsection "Lazy lists" "lists.lazy" } ; + +ARTICLE: { "lists" "protocol" } "The list protocol" +"Lists are instances of a mixin class" +{ $subsection list } +"Instances of the mixin must implement the following words:" +{ $subsection car } +{ $subsection cdr } +{ $subsection nil? } ; + +ARTICLE: { "lists" "strict" } "Strict lists" +"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:" +{ $subsection cons } +{ $subsection swons } +{ $subsection sequence>cons } +{ $subsection deep-sequence>cons } +{ $subsection 1list } +{ $subsection 2list } +{ $subsection 3list } ; + +ARTICLE: { "lists" "combinators" } "Combinators for lists" +"Several combinators exist for list traversal." +{ $subsection leach } +{ $subsection lmap } +{ $subsection foldl } +{ $subsection foldr } +{ $subsection lmap>array } +{ $subsection lmap-as } +{ $subsection traverse } ; + +ARTICLE: { "lists" "manipulation" } "Manipulating lists" +"To get at the contents of a list:" +{ $subsection uncons } +{ $subsection unswons } +{ $subsection lnth } +{ $subsection cadr } +{ $subsection llength } +"To get a new list from an old one:" +{ $subsection lreverse } +{ $subsection lappend } +{ $subsection lcut } ; HELP: cons -{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } +{ $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" "a cons object" } } { $description "Constructs a cons cell." } ; +HELP: swons +{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" "a cons object" } } +{ $description "Constructs a cons cell." } ; + +{ cons swons uncons unswons } related-words + HELP: car { $values { "cons" "a cons object" } { "car" "the first item in the list" } } { $description "Returns the first item in the list." } ; @@ -17,7 +70,9 @@ HELP: car HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $description "Returns the tail of the list." } ; - + +{ car cdr } related-words + HELP: nil { $values { "symbol" "The empty cons (+nil+)" } } { $description "Returns a symbol representing the empty list" } ; @@ -26,6 +81,8 @@ HELP: nil? { $values { "object" object } { "?" "a boolean" } } { $description "Return true if the cons object is the nil cons." } ; +{ nil nil? } related-words + HELP: list? ( object -- ? ) { $values { "object" "an object" } { "?" "a boolean" } } { $description "Returns true if the object conforms to the list protocol." } ; @@ -43,7 +100,7 @@ HELP: 2list HELP: 3list { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } { $description "Create a list with 3 elements." } ; - + HELP: lnth { $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } { $description "Outputs the nth element of the list." } @@ -55,7 +112,11 @@ HELP: llength { $see-also lnth cons car cdr } ; HELP: uncons -{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } } +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } ; + +HELP: unswons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; { leach foldl lmap>array } related-words @@ -75,30 +136,52 @@ HELP: foldr HELP: lmap { $values { "list" "a cons object" } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } } { $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; - + HELP: lreverse -{ $values { "list" "a cons object" } { "newlist" "a new cons object" } } -{ $description "Reverses the input list, outputing a new, reversed list" } ; - -HELP: list>seq -{ $values { "list" "a cons object" } { "array" "an array object" } } +{ $values { "list" list } { "newlist" list } } +{ $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ; + +HELP: list>array +{ $values { "list" "a cons object" } { "array" array } } { $description "Turns the given cons object into an array, maintaing order." } ; - -HELP: seq>list -{ $values { "seq" "a sequence" } { "list" "a cons object" } } + +HELP: sequence>cons +{ $values { "sequence" sequence } { "list" cons } } { $description "Turns the given array into a cons object, maintaing order." } ; - -HELP: cons>seq -{ $values { "cons" "a cons object" } { "array" "an array object" } } + +HELP: deep-list>array +{ $values { "list" list } { "array" array } } { $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ; - -HELP: seq>cons -{ $values { "seq" "a sequence object" } { "cons" "a cons object" } } + +HELP: deep-sequence>cons +{ $values { "sequence" sequence } { "cons" cons } } { $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; - + HELP: traverse { $values { "list" "a cons object" } { "pred" { $quotation "( list/elt -- ? )" } } { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } } { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" - " returns true for with the result of applying quot to." } ; - + " returns true for with the result of applying quot to." } ; + +HELP: list +{ $class-description "The class of lists. All lists are expected to conform to " { $link { "lists" "protocol" } } "." } ; + +HELP: cadr +{ $values { "list" list } { "elt" object } } +{ $description "Returns the second element of the list, ie the car of the cdr." } ; + +HELP: lappend +{ $values { "list1" list } { "list2" list } { "newlist" list } } +{ $description "Appends the two lists to form a new list. The first list must be finite. The result is a strict cons cell, and the first list is exausted." } ; + +HELP: lcut +{ $values { "list" list } { "index" integer } { "before" cons } { "after" cons } } +{ $description "Analogous to " { $link cut } ", this word cuts a list into two pieces at the given index." } ; + +HELP: lmap>array +{ $values { "list" list } { "quot" quotation } { "array" array } } +{ $description "Executes the quotation on each element of the list, collecting the results in an array." } ; + +HELP: lmap-as +{ $values { "list" list } { "quot" quotation } { "exemplar" sequence } { "sequence" sequence } } +{ $description "Executes the quotation on each element of the list, collecting the results in a sequence of the type given by the exemplar." } ; diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 4a08a4d1e3..404a776505 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -5,7 +5,7 @@ USING: tools.test lists math ; IN: lists.tests { { 3 4 5 6 7 } } [ - { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq + { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array ] unit-test { { 3 4 5 6 } } [ @@ -38,33 +38,33 @@ IN: lists.tests +nil+ } } } +nil+ } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons + { 1 2 { 3 4 { 5 } } } deep-sequence>cons ] unit-test { { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons deep-list>array ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ - { 1 2 3 4 } seq>cons [ 1+ ] lmap + { 1 2 3 4 } sequence>cons [ 1+ ] lmap ] unit-test { 15 } [ - { 1 2 3 4 5 } seq>list 0 [ + ] foldr + { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr ] unit-test { { 5 4 3 2 1 } } [ - { 1 2 3 4 5 } seq>list lreverse list>seq + { 1 2 3 4 5 } sequence>cons lreverse list>array ] unit-test { 5 } [ - { 1 2 3 4 5 } seq>list llength + { 1 2 3 4 5 } sequence>cons llength ] unit-test { { 3 4 { 5 6 { 7 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons [ atom? ] [ 2 + ] traverse deep-list>array ] unit-test { { 1 2 3 4 5 6 } } [ - { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq -] unit-test \ No newline at end of file + { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array +] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 5568b9d53e..784bc95bfe 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,15 +1,16 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes words locals ; +USING: kernel sequences accessors math arrays vectors classes words +combinators.short-circuit combinators ; IN: lists ! List Protocol MIXIN: list -GENERIC: car ( cons -- car ) -GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( object -- ? ) +GENERIC: car ( cons -- car ) +GENERIC: cdr ( cons -- cdr ) +GENERIC: nil? ( object -- ? ) -TUPLE: cons car cdr ; +TUPLE: cons { car read-only } { cdr read-only } ; C: cons cons @@ -18,41 +19,53 @@ M: cons car ( cons -- car ) M: cons cdr ( cons -- cdr ) cdr>> ; - -SYMBOL: +nil+ -M: word nil? +nil+ eq? ; + +SINGLETON: +nil+ +M: +nil+ nil? drop t ; M: object nil? drop f ; - -: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; + +: atom? ( obj -- ? ) + { [ list? ] [ nil? ] } 1|| not ; : nil ( -- symbol ) +nil+ ; - -: uncons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; - + +: uncons ( cons -- car cdr ) + [ car ] [ cdr ] bi ; + +: swons ( cdr car -- cons ) + swap cons ; + +: unswons ( cons -- cdr car ) + uncons swap ; + : 1list ( obj -- cons ) nil cons ; - + +: 1list? ( list -- ? ) + { [ nil? not ] [ cdr nil? ] } 1&& ; + : 2list ( a b -- cons ) nil cons cons ; : 3list ( a b c -- cons ) nil cons cons cons ; - -: cadr ( cons -- elt ) + +: cadr ( list -- elt ) cdr car ; - -: 2car ( cons -- car caar ) + +: 2car ( list -- car caar ) [ car ] [ cdr car ] bi ; - -: 3car ( cons -- car cadr caddr ) + +: 3car ( list -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; : lnth ( n list -- elt ) swap [ cdr ] times car ; - + + : leach ( list quot: ( elt -- ) -- ) over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive @@ -71,41 +84,59 @@ M: object nil? drop f ; : llength ( list -- n ) 0 [ drop 1+ ] foldl ; - + : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; - + : lappend ( list1 list2 -- newlist ) [ lreverse ] dip [ swap cons ] foldl ; - -: seq>list ( seq -- list ) + +: lcut ( list index -- before after ) + [ +nil+ ] dip + [ [ [ cdr ] [ car ] bi ] dip cons ] times + lreverse swap ; + +: sequence>cons ( sequence -- list ) nil [ swap cons ] reduce ; - + +cons ( seq -- cons ) - [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; - +PRIVATE> + +: deep-sequence>cons ( sequence -- cons ) + [ ] keep nil + [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + +array) ( acc cons quot: ( elt -- elt' ) -- newcons ) over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; + [ [ unswons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline recursive - -: lmap>array ( cons quot -- newcons ) - { } -rot (lmap>array) ; inline - -: lmap-as ( cons quot exemplar -- seq ) +PRIVATE> + +: lmap>array ( list quot -- array ) + [ { } ] 2dip (lmap>array) ; inline + +: lmap-as ( list quot exemplar -- sequence ) [ lmap>array ] dip like ; - -: cons>seq ( cons -- array ) - [ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ; - -: list>seq ( list -- array ) + +: deep-list>array ( list -- array ) + [ + { + { [ dup list? ] [ deep-list>array ] } + { [ dup nil? ] [ drop { } ] } + [ ] + } cond + ] lmap>array ; + +: list>array ( list -- array ) [ ] lmap>array ; - + : traverse ( list pred quot: ( list/elt -- result ) -- result ) - [ 2over call [ tuck [ call ] 2dip ] when - pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive - + [ + 2over call [ tuck [ call ] 2dip ] when + pick list? [ traverse ] [ 2drop ] if + ] 2curry lmap ; inline recursive + INSTANCE: cons list diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor index 43018bed16..f1027d107b 100644 --- a/basis/persistent/deques/deques-docs.factor +++ b/basis/persistent/deques/deques-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences ; IN: persistent.deques diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index ece1cda772..8f93ae1ab8 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -1,7 +1,6 @@ -! Copyback (C) 2008 Daniel Ehrenberg +! Copyright (C) 2008 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors math lists ; -QUALIFIED: sequences +USING: kernel accessors math lists sequences combinators.short-circuit ; IN: persistent.deques ! Amortized O(1) push/pop on both ends for single-threaded access @@ -9,30 +8,13 @@ IN: persistent.deques ! same source, it could take O(m) amortized time per update. TUPLE: deque { front read-only } { back read-only } ; -: ( -- deque ) T{ deque } ; +: ( -- deque ) + T{ deque f +nil+ +nil+ } ; : deque-empty? ( deque -- ? ) - [ front>> ] [ back>> ] bi or not ; + { [ front>> nil? ] [ back>> nil? ] } 1&& ; [ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline : transfer ( deque -- item newdeque ) - back>> [ split-reverse deque boa remove ] - [ "Popping from an empty deque" throw ] if* ; inline + back>> dup nil? + [ "Popping from an empty deque" throw ] + [ split-reverse deque boa remove ] if ; inline : pop ( deque -- item newdeque ) - dup front>> [ remove ] [ transfer ] if ; inline + dup front>> nil? [ transfer ] [ remove ] if ; inline PRIVATE> : pop-front ( deque -- item newdeque ) @@ -74,12 +57,14 @@ PRIVATE> : pop-back ( deque -- item newdeque ) [ pop ] flipped ; -: peek-front ( deque -- item ) pop-front drop ; +: peek-front ( deque -- item ) + pop-front drop ; -: peek-back ( deque -- item ) pop-back drop ; +: peek-back ( deque -- item ) + pop-back drop ; : sequence>deque ( sequence -- deque ) - [ push-back ] sequences:reduce ; + [ push-back ] reduce ; : deque>sequence ( deque -- sequence ) - [ dup deque-empty? not ] [ pop-front swap ] [ ] sequences:produce nip ; + [ dup deque-empty? not ] [ pop-front swap ] [ ] produce nip ; diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index f6c25980ea..437a9419e3 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -82,8 +82,8 @@ HELP: parse-host { $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." } { $examples { $example - "USING: prettyprint urls ;" - "\"sbcl.org:80\" parse-host .s" + "USING: prettyprint urls kernel ;" + "\"sbcl.org:80\" parse-host .s 2drop" "\"sbcl.org\"\n80" } } ; diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 55fe10283a..6e5bf31075 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -12,18 +12,6 @@ C: element : element-length ( element -- n ) [ black>> ] [ white>> ] bi + ; -: swons ( cdr car -- cons ) - swap cons ; - -: unswons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; - -: 1list? ( list -- ? ) - { [ ] [ cdr +nil+ = ] } 1&& ; - -: lists>arrays ( lists -- arrays ) - [ list>seq ] lmap>array ; - TUPLE: paragraph lines head-width tail-cost ; C: paragraph @@ -78,7 +66,7 @@ SYMBOL: line-ideal 0 ; : post-process ( paragraph -- array ) - lines>> lists>arrays + lines>> deep-list>array [ [ contents>> ] map ] map ; : initialize ( elements -- elements paragraph ) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 7d0666328f..94ff2c1f29 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -254,7 +254,7 @@ HELP: fp-infinity? { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } { $examples { $example "USING: math prettyprint ;" "1/0. fp-infinity? ." "t" } - { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi [ \"negative infinity\" print ] when" "negative infinity" } + { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; { fp-nan? fp-infinity? } related-words diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 8afbb2d03b..347ab638ff 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -17,7 +17,7 @@ ERROR: cannot-parse input ; : parse-1 ( input parser -- result ) dupd parse dup nil? [ - rot cannot-parse + swap cannot-parse ] [ nip car parsed>> ] if ; diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index e00e86865d..0f009919d9 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -39,7 +39,7 @@ IN: project-euler.134 PRIVATE> : euler134 ( -- answer ) - 0 5 lprimes-from uncons swap [ 1000000 > ] luntil + 0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time From 42265cbc62fbb50ee8b8a201603fb78624678160 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 14:35:44 -0600 Subject: [PATCH 040/168] start hacking on math.blas.vectors to switch to fortran --- basis/alien/fortran/fortran.factor | 10 ++++++++++ basis/math/blas/vectors/vectors.factor | 25 +++++++++++++------------ 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 85fa0e536e..00dd8583fc 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -11,6 +11,14 @@ IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. ! XXX we should also support ifort at some point for commercial BLASes +<< +: add-f2c-libraries ( -- ) + "I77" "libI77.so" "cdecl" add-library + "F77" "libF77.so" "cdecl" add-library ; + +os netbsd? [ add-f2c-libraries ] when +>> + : alien>nstring ( alien len encoding -- string ) [ memory>byte-array ] dip decode ; @@ -377,3 +385,5 @@ MACRO: fortran-invoke ( return library function parameters -- ) scan "c-library" get scan ";" parse-tokens [ "()" subseq? not ] filter define-fortran-function ; parsing +: LIBRARY: + scan "c-library" set ; parsing diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 4e61f4478e..d111023456 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,10 +1,13 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators -combinators.short-circuit fry kernel math math.blas.cblas +combinators.short-circuit fry kernel math math.blas.ffi math.complex math.functions math.order sequences.complex sequences.complex-components sequences sequences.private functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double -specialized-arrays.direct.float specialized-arrays.direct.double ; +specialized-arrays.direct.float specialized-arrays.direct.double +specialized-arrays.complex-float specialized-arrays.complex-double +specialized-arrays.direct.complex-float +specialized-arrays.direct.complex-double ; IN: math.blas.vectors TUPLE: blas-vector-base underlying length inc ; @@ -130,9 +133,9 @@ FUNCTOR: (define-blas-vector) ( TYPE T -- ) IS >ARRAY IS >${TYPE}-array -XCOPY IS cblas_${T}copy -XSWAP IS cblas_${T}swap -IXAMAX IS cblas_i${T}amax +XCOPY IS ${T}COPY +XSWAP IS ${T}SWAP +IXAMAX IS I${T}AMAX VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> @@ -264,16 +267,14 @@ M: VECTOR n*V! : define-real-blas-vector ( TYPE T -- ) [ (define-blas-vector) ] [ (define-real-blas-vector) ] 2bi ; -:: define-complex-blas-vector ( TYPE C S -- ) - TYPE (define-complex-helpers) - TYPE "-complex" append - [ C (define-blas-vector) ] - [ C S (define-complex-blas-vector) ] bi ; +: define-complex-blas-vector ( TYPE C S -- ) + [ drop (define-blas-vector) ] + [ (define-complex-blas-vector) ] 3bi ; "float" "s" define-real-blas-vector "double" "d" define-real-blas-vector -"float" "c" "s" define-complex-blas-vector -"double" "z" "d" define-complex-blas-vector +"complex-float" "c" "s" define-complex-blas-vector +"complex-double" "z" "d" define-complex-blas-vector >> From 975f197558c5efc49e43c87477b50bcaea64d962 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 14:37:22 -0600 Subject: [PATCH 041/168] Fixing help-lint bugs --- .../generalizations-docs.factor | 20 +++++++++---------- core/kernel/kernel-docs.factor | 2 +- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index ac8e14c05a..376ae5bed2 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -58,7 +58,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } + { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" } "Some core words expressed in terms of " { $link npick } ":" { $table { { $link dup } { $snippet "1 npick" } } @@ -75,7 +75,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" } "Some core words expressed in terms of " { $link ndup } ":" { $table { { $link dup } { $snippet "1 ndup" } } @@ -91,7 +91,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" } "Some core words expressed in terms of " { $link nnip } ":" { $table { { $link nip } { $snippet "1 nnip" } } @@ -106,7 +106,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" } "Some core words expressed in terms of " { $link ndrop } ":" { $table { { $link drop } { $snippet "1 ndrop" } } @@ -121,7 +121,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" } "Some core words expressed in terms of " { $link nrot } ":" { $table { { $link swap } { $snippet "1 nrot" } } @@ -135,7 +135,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" } "Some core words expressed in terms of " { $link -nrot } ":" { $table { { $link swap } { $snippet "1 -nrot" } } @@ -151,8 +151,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" } "Some core words expressed in terms of " { $link ndip } ":" { $table { { $link dip } { $snippet "1 ndip" } } @@ -168,7 +168,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nslip } ":" { $table { { $link slip } { $snippet "1 nslip" } } @@ -184,7 +184,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nkeep } ":" { $table { { $link keep } { $snippet "1 nkeep" } } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 71183093ee..b8191004db 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -658,7 +658,7 @@ HELP: loop "hi hi hi" } "A fun loop:" { $example "USING: kernel prettyprint math ; " - "3 [ dup . 7 + 11 mod dup 3 = not ] loop" + "3 [ dup . 7 + 11 mod dup 3 = not ] loop drop" "3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" } } ; From 32481f8e2f2909a50788532c58f8d9deff479ed9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:01:41 -0600 Subject: [PATCH 042/168] my stuped, let me show u it --- basis/alien/complex/functor/functor.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index c6644eba1d..31af0291b4 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -28,8 +28,8 @@ T in get define-struct T c-type - 1quotation >>boxer-quot -*T 1quotation >>unboxer-quot + 1quotation >>unboxer-quot +*T 1quotation >>boxer-quot drop ;FUNCTOR From d24b03098a58526dc43c2cb11142498ef512ed84 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:11:27 -0600 Subject: [PATCH 043/168] specialized arrays for complex types --- basis/specialized-arrays/complex-double/complex-double.factor | 4 ++++ basis/specialized-arrays/complex-float/complex-float.factor | 4 ++++ .../direct/complex-double/complex-double.factor | 4 ++++ .../direct/complex-float/complex-float.factor | 4 ++++ 4 files changed, 16 insertions(+) create mode 100644 basis/specialized-arrays/complex-double/complex-double.factor create mode 100644 basis/specialized-arrays/complex-float/complex-float.factor create mode 100644 basis/specialized-arrays/direct/complex-double/complex-double.factor create mode 100644 basis/specialized-arrays/direct/complex-float/complex-float.factor diff --git a/basis/specialized-arrays/complex-double/complex-double.factor b/basis/specialized-arrays/complex-double/complex-double.factor new file mode 100644 index 0000000000..00b07fb9b3 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-double + +<< "complex-double" define-array >> diff --git a/basis/specialized-arrays/complex-float/complex-float.factor b/basis/specialized-arrays/complex-float/complex-float.factor new file mode 100644 index 0000000000..5348343bae --- /dev/null +++ b/basis/specialized-arrays/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-float + +<< "complex-float" define-array >> diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor new file mode 100644 index 0000000000..58af77b0c0 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-double + +<< "complex-double" define-direct-array >> diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor new file mode 100644 index 0000000000..d881c1e0d4 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-float + +<< "complex-float" define-direct-array >> From 462b208475382fc240648a92a296c95be90d8520 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 15:31:57 -0600 Subject: [PATCH 044/168] Cleaning up strict list combinators --- basis/lists/lists-tests.factor | 5 ++-- basis/lists/lists.factor | 47 +++++++++++++++++++--------------- basis/wrap/words/words.factor | 2 +- 3 files changed, 30 insertions(+), 24 deletions(-) diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 404a776505..13d2e03e0f 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lists math ; - +USING: tools.test lists math kernel ; IN: lists.tests { { 3 4 5 6 7 } } [ @@ -68,3 +67,5 @@ IN: lists.tests { { 1 2 3 4 5 6 } } [ { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array ] unit-test + +[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 784bc95bfe..4b0abb7f2d 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words -combinators.short-circuit combinators ; +combinators.short-circuit combinators locals ; IN: lists ! List Protocol @@ -25,7 +25,7 @@ M: +nil+ nil? drop t ; M: object nil? drop f ; : atom? ( obj -- ? ) - { [ list? ] [ nil? ] } 1|| not ; + list? not ; : nil ( -- symbol ) +nil+ ; @@ -76,10 +76,10 @@ PRIVATE> : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result ) swapd leach ; inline -: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) - pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ - [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi - call +:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) + list nil? [ identity ] [ + list cdr identity quot foldr + list car quot call ] if ; inline recursive : llength ( list -- n ) @@ -92,7 +92,7 @@ PRIVATE> [ lreverse ] dip [ swap cons ] foldl ; : lcut ( list index -- before after ) - [ +nil+ ] dip + [ nil ] dip [ [ [ cdr ] [ car ] bi ] dip cons ] times lreverse swap ; @@ -109,23 +109,27 @@ PRIVATE> [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; array) ( acc cons quot: ( elt -- elt' ) -- newcons ) - over nil? [ 2drop ] - [ [ unswons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; - inline recursive +:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc ) + list nil? [ acc ] [ + list car quot call acc push + acc list cdr quot (lmap>vector) + ] if ; inline recursive + +: lmap>vector ( list quot -- array ) + [ V{ } clone ] 2dip (lmap>vector) ; inline PRIVATE> -: lmap>array ( list quot -- array ) - [ { } ] 2dip (lmap>array) ; inline - : lmap-as ( list quot exemplar -- sequence ) - [ lmap>array ] dip like ; + [ lmap>vector ] dip like ; inline + +: lmap>array ( list quot -- array ) + { } lmap-as ; inline : deep-list>array ( list -- array ) [ { - { [ dup list? ] [ deep-list>array ] } { [ dup nil? ] [ drop { } ] } + { [ dup list? ] [ deep-list>array ] } [ ] } cond ] lmap>array ; @@ -133,10 +137,11 @@ PRIVATE> : list>array ( list -- array ) [ ] lmap>array ; -: traverse ( list pred quot: ( list/elt -- result ) -- result ) - [ - 2over call [ tuck [ call ] 2dip ] when - pick list? [ traverse ] [ 2drop ] if - ] 2curry lmap ; inline recursive +:: traverse ( list pred quot: ( list/elt -- result ) -- result ) + list [| elt | + elt dup pred call [ quot call ] when + dup list? [ pred quot traverse ] when + ] lmap ; inline recursive INSTANCE: cons list +INSTANCE: +nil+ list diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor index 00f257a5cf..bcf4460170 100644 --- a/basis/wrap/words/words.factor +++ b/basis/wrap/words/words.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel splitting.monotonic accessors wrap grouping ; +USING: sequences kernel splitting.monotonic accessors grouping wrap ; IN: wrap.words TUPLE: word key width break? ; From db6706434d711e5313ca1618302a8f83c9c3d817 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:38:07 -0600 Subject: [PATCH 045/168] tweak specialized-arrays to box values returned by nth --- basis/alien/c-types/c-types.factor | 3 +++ basis/alien/structs/fields/fields.factor | 5 +---- basis/specialized-arrays/direct/functor/functor.factor | 2 +- basis/specialized-arrays/functor/functor.factor | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 89b3572daf..a4bc3d3f52 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -185,6 +185,9 @@ M: f byte-length drop 0 ; [ "Cannot read struct fields with this type" throw ] ] unless* ; +: c-type-getter-boxer ( name -- quot ) + [ c-getter ] [ c-type-boxer-quot ] bi append ; + : c-setter ( name -- quot ) c-type-setter [ [ "Cannot write struct fields with this type" throw ] diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index f5537fa239..0477683442 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : define-getter ( type spec -- ) [ set-reader-props ] keep [ reader>> ] - [ - type>> - [ c-getter ] [ c-type-boxer-quot ] bi append - ] + [ type>> c-type-getter-boxer ] [ ] tri (( c-ptr -- value )) define-struct-slot-word ; diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 0c3999db44..e7e891fede 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -14,7 +14,7 @@ A' IS ${T}-array A DEFINES-CLASS direct-${T}-array DEFINES <${A}> -NTH [ T dup c-getter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 3c2c53db31..09433a3b51 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -22,7 +22,7 @@ A DEFINES-CLASS ${T}-array byte-array>A DEFINES byte-array>${A} A{ DEFINES ${A}{ -NTH [ T dup c-getter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] WHERE From 85620fc74118037dd35e908bd210e74ec03ea173 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:51:47 -0600 Subject: [PATCH 046/168] C CONVERT VECTORS TO USE FORTRAN BLAS BINDINGS C INSTEAD OF CBLAS --- basis/math/blas/vectors/vectors.factor | 83 ++++++++------------------ 1 file changed, 25 insertions(+), 58 deletions(-) diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index d111023456..9a2f9a4350 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,4 +1,4 @@ -USING: accessors alien alien.c-types arrays byte-arrays combinators +USING: accessors alien alien.c-types arrays ascii byte-arrays combinators combinators.short-circuit fry kernel math math.blas.ffi math.complex math.functions math.order sequences.complex sequences.complex-components sequences sequences.private @@ -141,7 +141,12 @@ VECTOR DEFINES-CLASS ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector -XVECTOR{ DEFINES ${T}vector{ +t [ T >lower ] + +XVECTOR{ DEFINES ${t}vector{ + +XAXPY IS ${T}AXPY +XSCAL IS ${T}SCAL WHERE @@ -170,6 +175,11 @@ M: VECTOR (blas-direct-array) [ [ length>> ] [ inc>> ] bi * ] bi ; +M: VECTOR n*V+V! + (prepare-axpy) [ XAXPY ] dip ; +M: VECTOR n*V! + (prepare-scal) [ XSCAL ] dip ; + : XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing M: VECTOR pprint-delims @@ -181,11 +191,9 @@ M: VECTOR pprint-delims FUNCTOR: (define-real-blas-vector) ( TYPE T -- ) VECTOR IS ${TYPE}-blas-vector -XDOT IS cblas_${T}dot -XNRM2 IS cblas_${T}nrm2 -XASUM IS cblas_${T}asum -XAXPY IS cblas_${T}axpy -XSCAL IS cblas_${T}scal +XDOT IS ${T}DOT +XNRM2 IS ${T}NRM2 +XASUM IS ${T}ASUM WHERE @@ -197,33 +205,6 @@ M: VECTOR Vnorm (prepare-nrm2) XNRM2 ; M: VECTOR Vasum (prepare-nrm2) XASUM ; -M: VECTOR n*V+V! - (prepare-axpy) [ XAXPY ] dip ; -M: VECTOR n*V! - (prepare-scal) [ XSCAL ] dip ; - -;FUNCTOR - - -FUNCTOR: (define-complex-helpers) ( TYPE -- ) - - DEFINES ->COMPLEX-ARRAY DEFINES >${TYPE}-complex-array -ARG>COMPLEX DEFINES arg>${TYPE}-complex -COMPLEX>ARG DEFINES ${TYPE}-complex>arg - IS ->ARRAY IS >${TYPE}-array - -WHERE - -: ( alien len -- sequence ) - 1 shift ; -: >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY ; -: COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY underlying>> ; -: ARG>COMPLEX ( alien -- complex ) - 2 first2 rect> ; ;FUNCTOR @@ -231,35 +212,21 @@ WHERE FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- ) VECTOR IS ${TYPE}-blas-vector -XDOTU_SUB IS cblas_${C}dotu_sub -XDOTC_SUB IS cblas_${C}dotc_sub -XXNRM2 IS cblas_${S}${C}nrm2 -XXASUM IS cblas_${S}${C}asum -XAXPY IS cblas_${C}axpy -XSCAL IS cblas_${C}scal -TYPE>ARG IS ${TYPE}>arg -ARG>TYPE IS arg>${TYPE} +XDOTU IS ${C}DOTU +XDOTC IS ${C}DOTC +XXNRM2 IS ${S}${C}NRM2 +XXASUM IS ${S}${C}ASUM WHERE M: VECTOR V. - (prepare-dot) TYPE - [ XDOTU_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTU ; M: VECTOR V.conj - (prepare-dot) TYPE - [ XDOTC_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTC ; M: VECTOR Vnorm (prepare-nrm2) XXNRM2 ; M: VECTOR Vasum (prepare-nrm2) XXASUM ; -M: VECTOR n*V+V! - [ TYPE>ARG ] 2dip - (prepare-axpy) [ XAXPY ] dip ; -M: VECTOR n*V! - [ TYPE>ARG ] dip - (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR @@ -271,10 +238,10 @@ M: VECTOR n*V! [ drop (define-blas-vector) ] [ (define-complex-blas-vector) ] 3bi ; -"float" "s" define-real-blas-vector -"double" "d" define-real-blas-vector -"complex-float" "c" "s" define-complex-blas-vector -"complex-double" "z" "d" define-complex-blas-vector +"float" "S" define-real-blas-vector +"double" "D" define-real-blas-vector +"complex-float" "C" "S" define-complex-blas-vector +"complex-double" "Z" "D" define-complex-blas-vector >> From 08b02fadc9ea836e6fb65da5da841ac1ce236fb6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 15:51:59 -0600 Subject: [PATCH 047/168] typos --- basis/alien/fortran/fortran.factor | 2 +- basis/math/blas/ffi/ffi.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 00dd8583fc..c7688fbe3a 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -5,7 +5,7 @@ byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces parser sequences splitting stack-checker vectors vocabs.parser words locals io.encodings.ascii io.encodings.string shuffle effects math.ranges -math.order sorting ; +math.order sorting system ; IN: alien.fortran ! XXX this currently only supports the gfortran/f2c abi. diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 7b0138357a..03043e54ed 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -27,9 +27,9 @@ FUNCTION: COMPLEX CDOTU FUNCTION: COMPLEX CDOTC ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: DOUBLE-COMPLEX ZDOTU +FUNCTION: DOUBLE-COMPLEX ZDOTU ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: DOUBLE-COMPLEX ZDOTC +FUNCTION: DOUBLE-COMPLEX ZDOTC ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; FUNCTION: REAL SNRM2 From 0c589061ad895c6a3e8d1914ddc29cd49659cdbf Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 16:18:24 -0600 Subject: [PATCH 048/168] More docs for lazy lists, getting rid of lazy-map-with --- basis/lists/lazy/lazy-docs.factor | 55 ++++++++++++++++--- basis/lists/lazy/lazy-tests.factor | 2 +- basis/lists/lazy/lazy.factor | 7 +-- .../parser-combinators.factor | 8 +-- 4 files changed, 54 insertions(+), 18 deletions(-) diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index c402cdf15b..08fe3bbcba 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -1,11 +1,54 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. - USING: help.markup help.syntax sequences strings lists ; IN: lists.lazy +ABOUT: "lists.lazy" + +ARTICLE: "lists.lazy" "Lazy lists" +"The " { $vocab-link "lists.lazy" } " vocabulary implements lazy lists and standard operations to manipulate them." +{ $subsection { "lists.lazy" "construction" } } +{ $subsection { "lists.lazy" "manipulation" } } +{ $subsection { "lists.lazy" "combinators" } } +{ $subsection { "lists.lazy" "io" } } ; + +ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists" +"The following combinators create lazy lists from other lazy lists:" +{ $subsection lmap } +{ $subsection lfilter } +{ $subsection luntil } +{ $subsection lwhile } +{ $subsection lfrom-by } +{ $subsection lcomp } +{ $subsection lcomp* } ; + +ARTICLE: { "lists.lazy" "io" } "Lazy list I/O" +"Input from a stream can be read through a lazy list, using the following words:" +{ $subsection lcontents } +{ $subsection llines } ; + +ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists" +"Words for constructing lazy lists:" +{ $subsection lazy-cons } +{ $subsection 1lazy-list } +{ $subsection 2lazy-list } +{ $subsection 3lazy-list } +{ $subsection seq>list } +{ $subsection >list } +{ $subsection lfrom } ; + +ARTICLE: { "lists.lazy" "manipulation" } "Manipulating lazy lists" +"To make new lazy lists from old ones:" +{ $subsection } +{ $subsection lappend } +{ $subsection lconcat } +{ $subsection lcartesian-product } +{ $subsection lcartesian-product* } +{ $subsection lmerge } +{ $subsection ltake } ; + HELP: lazy-cons -{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } +{ $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } { $see-also cons car cdr nil nil? } ; @@ -28,16 +71,12 @@ HELP: { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $see-also cons car cdr nil nil? } ; -{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lazy-map { $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; -HELP: lazy-map-with -{ $values { "value" "an object" } { "list" "a cons object" } { "quot" { $quotation "( obj elt -- X )" } } { "result" "resulting cons object" } } -{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ; - HELP: ltake { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } { $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; @@ -86,7 +125,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index 03221841c1..f4e55cba19 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -24,7 +24,7 @@ IN: lists.lazy.tests ] unit-test [ { 4 5 6 } ] [ - 3 { 1 2 3 } >list [ + ] lazy-map-with list>array + 3 { 1 2 3 } >list [ + ] with lazy-map list>array ] unit-test [ [ ] lmap ] must-infer diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 5adb7a8be5..d3b08a11fb 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -90,9 +90,6 @@ M: lazy-map cdr ( lazy-map -- cdr ) M: lazy-map nil? ( lazy-map -- bool ) cons>> nil? ; -: lazy-map-with ( value list quot -- result ) - with lazy-map ; - TUPLE: lazy-take n cons ; C: lazy-take @@ -301,14 +298,14 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ; + swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ; : lcartesian-product* ( lists -- result ) dup nil? [ drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat + swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat ] reduce ] if ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 347ab638ff..99e8099f38 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -149,8 +149,8 @@ TUPLE: and-parser parsers ; [ parsed>> ] dip [ parsed>> 2array ] keep unparsed>> - ] lazy-map-with - ] lazy-map-with lconcat ; + ] with lazy-map + ] with lazy-map lconcat ; M: and-parser parse ( input parser -- list ) #! Parse 'input' by sequentially combining the @@ -173,7 +173,7 @@ M: or-parser parse ( input parser1 -- list ) #! of parser1 and parser2 being applied to the same #! input. This implements the choice parsing operator. parsers>> 0 swap seq>list - [ parse ] lazy-map-with lconcat ; + [ parse ] with lazy-map lconcat ; : trim-head-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -218,7 +218,7 @@ M: apply-parser parse ( input parser -- result ) -rot parse [ [ parsed>> swap call ] keep unparsed>> - ] lazy-map-with ; + ] with lazy-map ; TUPLE: some-parser p1 ; From d45f0c83eb94675ac655a15ebb93c7fa5335f2f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 16:19:09 -0600 Subject: [PATCH 049/168] more work on tiff files. --- extra/graphics/tiff/tiff-tests.factor | 4 +- extra/graphics/tiff/tiff.factor | 174 ++++++++++++++++++++++---- 2 files changed, 151 insertions(+), 27 deletions(-) diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor index daee9a5d9e..f800b4d213 100755 --- a/extra/graphics/tiff/tiff-tests.factor +++ b/extra/graphics/tiff/tiff-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Your name. +! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test graphics.tiff ; IN: graphics.tiff.tests @@ -6,4 +6,6 @@ IN: graphics.tiff.tests : tiff-test-path ( -- path ) "resource:extra/graphics/tiff/rgb.tiff" ; +: tiff-test-path2 ( -- path ) + "resource:extra/graphics/tiff/octagon.tiff" ; diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index f0b3f9337e..9461403805 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -2,7 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint classes ; +sorting.slots math.order math.parser prettyprint classes +io.binary assocs math math.bitwise byte-arrays grouping ; +USE: multiline + IN: graphics.tiff TUPLE: tiff @@ -14,13 +17,14 @@ ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; -TUPLE: ifd count ifd-entries next processed-tags strips ; +TUPLE: ifd count ifd-entries next +processed-tags strips buffer ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; -TUPLE: ifd-entry tag type count offset ; +TUPLE: ifd-entry tag type count offset/value ; -CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ; +CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; TUPLE: photometric-interpretation color ; @@ -132,6 +136,44 @@ ERROR: bad-planar-configuration n ; [ bad-predictor ] } case ; +TUPLE: sample-format n ; +CONSTRUCTOR: sample-format ( n -- object ) ; +ERROR: bad-sample-format n ; + +SINGLETONS: sample-unsigned-integer sample-signed-integer +sample-ieee-float sample-undefined-data ; + +: lookup-sample-format ( seq -- object ) + [ + { + { 1 [ sample-unsigned-integer ] } + { 2 [ sample-signed-integer ] } + { 3 [ sample-ieee-float ] } + { 4 [ sample-undefined-data ] } + [ bad-sample-format ] + } case + ] map ; + + +TUPLE: extra-samples n ; +CONSTRUCTOR: extra-samples ( n -- object ) ; +ERROR: bad-extra-samples n ; + +SINGLETONS: unspecified-alpha-data associated-alpha-data +unassociated-alpha-data ; + +: lookup-extra-samples ( seq -- object ) + { + { 0 [ unspecified-alpha-data ] } + { 1 [ associated-alpha-data ] } + { 2 [ unassociated-alpha-data ] } + [ bad-extra-samples ] + } case ; + + +TUPLE: orientation n ; +CONSTRUCTOR: orientation ( n -- object ) ; + TUPLE: new-subfile-type n ; CONSTRUCTOR: new-subfile-type ( n -- object ) ; @@ -157,6 +199,7 @@ ERROR: bad-tiff-magic bytes ; : push-ifd ( tiff ifd -- tiff ) over ifds>> push ; + ! over [ dup class ] [ ifds>> ] bi* set-at ; : read-ifd ( -- ifd ) 2 read endian> @@ -165,29 +208,96 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> ; : read-ifds ( tiff -- tiff ) - [ - dup ifd-offset>> seek-absolute seek-input - 2 read endian> - dup [ read-ifd ] replicate - 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi - ] with-tiff-endianness ; + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + +ERROR: no-tag class ; + +: ?at ( key assoc -- value/key ? ) + dupd at* [ nip t ] [ drop f ] if ; inline + +: find-tag ( idf class -- tag ) + swap processed-tags>> + ?at [ no-tag ] unless ; : read-strips ( ifd -- ifd ) - dup processed-tags>> - [ [ strip-byte-counts instance? ] find nip n>> ] - [ [ strip-offsets instance? ] find nip n>> ] bi - [ seek-absolute seek-input read ] { } 2map-as >>strips ; + dup + [ strip-byte-counts find-tag n>> ] + [ strip-offsets find-tag n>> ] bi + 2dup [ integer? ] both? [ + seek-absolute seek-input read 1array + ] [ + [ seek-absolute seek-input read ] { } 2map-as + ] if >>strips ; ! ERROR: unhandled-ifd-entry data n ; : unhandled-ifd-entry ; +ERROR: unknown-ifd-type n ; + +: bytes>bits ( n/byte-array -- n ) + dup byte-array? [ byte-array>bignum ] when ; + +: value-length ( ifd-entry -- n ) + [ count>> ] [ type>> ] bi { + { 1 [ ] } + { 2 [ ] } + { 3 [ 2 * ] } + { 4 [ 4 * ] } + { 5 [ 8 * ] } + { 6 [ ] } + { 7 [ ] } + { 8 [ 2 * ] } + { 9 [ 4 * ] } + { 10 [ 8 * ] } + { 11 [ 4 * ] } + { 12 [ 8 * ] } + [ unknown-ifd-type ] + } case ; + +ERROR: bad-small-ifd-type n ; + +: adjust-offset/value ( ifd-entry -- obj ) + [ offset/value>> 4 >endian ] [ type>> ] bi + { + { 1 [ 1 head endian> ] } + { 3 [ 2 head endian> ] } + { 4 [ endian> ] } + { 6 [ 1 head endian> 8 >signed ] } + { 8 [ 2 head endian> 16 >signed ] } + { 9 [ endian> 32 >signed ] } + { 11 [ endian> bits>float ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ endian> 32 >signed ] map ] } + { 10 [ 8 group [ "ii" unpack first2 / ] map ] } + { 11 [ 4 group [ "f" unpack ] map ] } + { 12 [ 8 group [ "d" unpack ] map ] } + [ unknown-ifd-type ] + } case ; + : ifd-entry-value ( ifd-entry -- n ) - dup count>> 1 = [ - offset>> + dup value-length 4 <= [ + adjust-offset/value ] [ - [ offset>> seek-absolute seek-input ] [ count>> read ] bi + [ offset/value>> seek-absolute seek-input ] + [ value-length read ] + [ type>> ] tri offset-bytes>obj ] if ; : process-ifd-entry ( ifd-entry -- object ) @@ -199,6 +309,7 @@ ERROR: bad-tiff-magic bytes ; { 259 [ lookup-compression ] } { 262 [ lookup-photometric-interpretation ] } { 273 [ ] } + { 274 [ ] } { 277 [ ] } { 278 [ ] } { 279 [ ] } @@ -207,21 +318,32 @@ ERROR: bad-tiff-magic bytes ; { 284 [ ] } { 296 [ lookup-resolution-unit ] } { 317 [ lookup-predictor ] } + { 338 [ lookup-extra-samples ] } + { 339 [ lookup-sample-format ] } [ unhandled-ifd-entry swap 2array ] } case ; : process-ifd ( ifd -- ifd ) - dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ; + dup ifd-entries>> + [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; + +/* +: ifd-strips>buffer ( ifd -- ifd ) + [ + [ rows-per-strip find-tag n>> ] + [ image-length find-tag n>> ] bi + ] [ + strips>> [ length ] keep + ] bi assemble-image ; +*/ : (load-tiff) ( path -- tiff ) binary [ - read-header - read-ifds - dup ifds>> [ process-ifd read-strips drop ] each + read-header [ + read-ifds + dup ifds>> [ process-ifd read-strips drop ] each + ] with-tiff-endianness ] with-file-reader ; -: load-tiff ( path -- tiff ) - (load-tiff) ; - -! TODO: duplicate ifds = error, seeking out of bounds = error +: load-tiff ( path -- tiff ) (load-tiff) ; From 41e0db098caff53221560f50bb46855123b2c43a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 16:19:43 -0600 Subject: [PATCH 050/168] make pack/unpack public --- basis/pack/pack.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 9078817206..27cba6d6e7 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -87,12 +87,12 @@ CONSTANT: packed-length-table { CHAR: D 8 } } +PRIVATE> + MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as '[ [ [ _ spread ] input - : ch>packed-length ( ch -- n ) packed-length-table at ; inline @@ -113,14 +113,14 @@ PRIVATE> : start/end ( seq -- seq1 seq2 ) [ 0 [ + ] accumulate nip dup ] keep v+ ; inline +PRIVATE> + MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map '[ [ _ cleave ] output>array ] ; -PRIVATE> - : unpack-native ( seq str -- seq ) '[ _ _ unpack ] with-native-endian ; inline From ebdd135d6281e0758d2641e005fbff4253de5749 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:36:46 -0600 Subject: [PATCH 051/168] gfortran returns float for REAL functions, not double like f2c --- basis/alien/fortran/fortran-tests.factor | 6 +++--- basis/alien/fortran/fortran.factor | 6 ++++-- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 9b618ef513..1b2ffda4a9 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -116,7 +116,7 @@ RECORD: FORTRAN_TEST_RECORD [ "int" { } ] [ "logical" fortran-ret-type>c-type ] unit-test -[ "double" { } ] +[ "float" { } ] [ "real" fortran-ret-type>c-type ] unit-test [ "double" { } ] @@ -136,7 +136,7 @@ RECORD: FORTRAN_TEST_RECORD ! fortran-sig>c-sig -[ "double" { "int*" "char*" "float*" "double*" "long" } ] +[ "float" { "int*" "char*" "float*" "double*" "long" } ] [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] unit-test @@ -213,7 +213,7 @@ unit-test [ { [ drop ] } spread ] } 1 ncleave ! [fortran-invoke] - [ "double" "funpack" "fun_times__" { "float*" } alien-invoke ] + [ "float" "funpack" "fun_times__" { "float*" } alien-invoke ] 1 nkeep ! [fortran-results>] shuffle( reta aa -- reta aa ) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index c7688fbe3a..9327c7b02c 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -155,7 +155,9 @@ GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) M: f (fortran-ret-type>c-type) drop "void" ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; -M: real-type (fortran-ret-type>c-type) drop "double" ; +! XXX F2C claims to return double for REAL typed functions +! XXX OSX Accelerate.framework uses float +! M: real-type (fortran-ret-type>c-type) drop "double" ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline @@ -374,7 +376,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic - return library function parameters return parse-arglist + return library function parameters return [ "void" ] unless* parse-arglist [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ; : SUBROUTINE: From 4623e9bd683df29dd7fc405e0679db4d8fd47967 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:01 -0600 Subject: [PATCH 052/168] another typo --- basis/math/blas/ffi/ffi.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 03043e54ed..7e0694ae4f 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -16,7 +16,7 @@ LIBRARY: blas FUNCTION: REAL SDSDOT ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: DOUBLE-PRECISION DSDOT - ( INTEGER N, DOUBLE-PRECISION-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; + ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: REAL SDOT ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ; FUNCTION: DOUBLE-PRECISION DDOT From ddf8afbb7ee49c8b3b894928168ab6c113417190 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:12 -0600 Subject: [PATCH 053/168] more typos --- .../direct/complex-double/complex-double.factor | 2 +- .../direct/complex-float/complex-float.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor index 58af77b0c0..ae8d2b5fb3 100644 --- a/basis/specialized-arrays/direct/complex-double/complex-double.factor +++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor @@ -1,4 +1,4 @@ -USING: specialized-arrays.float specialized-arrays.direct.functor ; +USING: specialized-arrays.complex-double specialized-arrays.direct.functor ; IN: specialized-arrays.direct.complex-double << "complex-double" define-direct-array >> diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor index d881c1e0d4..8971196297 100644 --- a/basis/specialized-arrays/direct/complex-float/complex-float.factor +++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor @@ -1,4 +1,4 @@ -USING: specialized-arrays.float specialized-arrays.direct.functor ; +USING: specialized-arrays.complex-float specialized-arrays.direct.functor ; IN: specialized-arrays.direct.complex-float << "complex-float" define-direct-array >> From ad843a1bcf53f3a21f3ec13dbf24b5507dff0bc7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:37:45 -0600 Subject: [PATCH 054/168] iXamax returns a 1-based array index. decrement that shit --- basis/math/blas/vectors/vectors-docs.factor | 16 ++++++++-------- basis/math/blas/vectors/vectors.factor | 5 ++--- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index b37a4b966e..296437c32b 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -37,8 +37,8 @@ HELP: blas-vector-base { $list { { $link float-blas-vector } } { { $link double-blas-vector } } - { { $link float-complex-blas-vector } } - { { $link double-complex-blas-vector } } + { { $link complex-float-blas-vector } } + { { $link complex-double-blas-vector } } } "All of these subclasses share the same tuple layout:" { $list @@ -51,10 +51,10 @@ HELP: float-blas-vector { $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; HELP: double-blas-vector { $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: float-complex-blas-vector -{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; -HELP: double-complex-blas-vector -{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ; +HELP: complex-float-blas-vector +{ $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; +HELP: complex-double-blas-vector +{ $class-description "A vector of double-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ; HELP: n*V+V! { $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } } @@ -145,11 +145,11 @@ HELP: dvector{ HELP: cvector{ { $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; +{ $description "Construct a literal " { $link complex-float-blas-vector } "." } ; HELP: zvector{ { $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; +{ $description "Construct a literal " { $link complex-double-blas-vector } "." } ; { POSTPONE: svector{ POSTPONE: dvector{ diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 9a2f9a4350..a373ec7c5a 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,7 +1,6 @@ USING: accessors alien alien.c-types arrays ascii byte-arrays combinators combinators.short-circuit fry kernel math math.blas.ffi -math.complex math.functions math.order sequences.complex -sequences.complex-components sequences sequences.private +math.complex math.functions math.order sequences sequences.private functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double specialized-arrays.direct.float specialized-arrays.direct.double @@ -165,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX ; + (prepare-nrm2) IXAMAX 1- ; M: VECTOR (blas-vector-like) drop ; From 5a90a0aae5aeb1646eebddb5d4231b534cd0b797 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 16:41:23 -0600 Subject: [PATCH 055/168] Fixing bug in render-hidden --- basis/furnace/chloe-tags/chloe-tags.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 8003ab208b..562fe5a614 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -86,7 +86,7 @@ CHLOE: base hidden-form-field ; : render-hidden ( for -- xml ) - "," split [ hidden render>xml ] map ; + [ "," split [ hidden render>xml ] map ] [ f ] if* ; : compile-hidden-form-fields ( for -- ) '[ From 1279d6e8ea2fff622ca556c6f7fa4b266a923ca9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 16:46:02 -0600 Subject: [PATCH 056/168] Fixing furnace test/docs --- basis/furnace/furnace-tests.factor | 4 ++-- basis/furnace/utilities/utilities-docs.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index f01260c68b..c591b848ec 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -1,7 +1,7 @@ IN: furnace.tests USING: http http.server.dispatchers http.server.responses http.server furnace furnace.utilities tools.test kernel -namespaces accessors io.streams.string urls ; +namespaces accessors io.streams.string urls xml.writer ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; @@ -31,7 +31,7 @@ M: base-path-check-responder call-responder* ] unit-test [ "" ] -[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] +[ "&&&" "foo" hidden-form-field xml>string ] unit-test [ f ] [ request [ referrer ] with-variable ] unit-test diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index db44963f6e..e7fdaf64d6 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -25,8 +25,8 @@ HELP: hidden-form-field { $notes "This word is used by session management, conversation scope and asides." } { $examples { $example - "USING: furnace.utilities io ;" - "\"bar\" \"foo\" hidden-form-field nl" + "USING: furnace.utilities io xml.writer ;" + "\"bar\" \"foo\" hidden-form-field write-xml nl" "" } } ; From 35c54a91ac5d937795b2ff9912f8d0aa719fb6bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:59:00 -0600 Subject: [PATCH 057/168] oops, leftover ORDER arguments from converting from CBLAS --- basis/math/blas/ffi/ffi.factor | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 7e0694ae4f..77cee1aa82 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -122,13 +122,11 @@ SUBROUTINE: DROTM ! LEVEL 2 BLAS (MATRIX-VECTOR) -SUBROUTINE: SGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, REAL ALPHA, REAL(*) A, INTEGER LDA, REAL(*) X, INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; -SUBROUTINE: SGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, REAL ALPHA, REAL(*) A, INTEGER LDA, REAL(*) X, INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ; @@ -155,13 +153,11 @@ SUBROUTINE: STPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ; -SUBROUTINE: DGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; -SUBROUTINE: DGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ; @@ -188,13 +184,11 @@ SUBROUTINE: DTPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ; -SUBROUTINE: CGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: CGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X, INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ; @@ -221,13 +215,11 @@ SUBROUTINE: CTPSV ( CHARACTER*1 UPLO, CHARACTER*1 TRANSA, CHARACTER*1 DIAG, INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ; -SUBROUTINE: ZGEMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; -SUBROUTINE: ZGBMV ( CHARACTER*1 ORDER, - CHARACTER*1 TRANSA, INTEGER M, INTEGER N, +SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N, INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ; From d160b80dacbcf7e598613930fb83781df8804e7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 16:59:26 -0600 Subject: [PATCH 058/168] convert math.blas.matrices to use fortran calls --- basis/math/blas/matrices/matrices-docs.factor | 40 +++++------ basis/math/blas/matrices/matrices.factor | 72 +++++++++---------- 2 files changed, 54 insertions(+), 58 deletions(-) diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index f20a565e1f..b6e118836e 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -14,34 +14,34 @@ ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" { $subsection float-blas-vector } { $subsection double-blas-vector } -{ $subsection float-complex-blas-vector } -{ $subsection double-complex-blas-vector } +{ $subsection complex-float-blas-vector } +{ $subsection complex-double-blas-vector } "These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:" { $subsection float-blas-matrix } { $subsection double-blas-matrix } -{ $subsection float-complex-blas-matrix } -{ $subsection double-complex-blas-matrix } +{ $subsection complex-float-blas-matrix } +{ $subsection complex-double-blas-matrix } "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:" { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" { $subsection } { $subsection } "BLAS vectors and matrices can also be constructed from other Factor sequences:" { $subsection >float-blas-vector } { $subsection >double-blas-vector } -{ $subsection >float-complex-blas-vector } -{ $subsection >double-complex-blas-vector } +{ $subsection >complex-float-blas-vector } +{ $subsection >complex-double-blas-vector } { $subsection >float-blas-matrix } { $subsection >double-blas-matrix } -{ $subsection >float-complex-blas-matrix } -{ $subsection >double-complex-blas-matrix } ; +{ $subsection >complex-float-blas-matrix } +{ $subsection >complex-double-blas-matrix } ; ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" "Transposing and slicing matrices:" @@ -87,8 +87,8 @@ HELP: blas-matrix-base { $list { { $link float-blas-matrix } } { { $link double-blas-matrix } } - { { $link float-complex-blas-matrix } } - { { $link double-complex-blas-matrix } } + { { $link complex-float-blas-matrix } } + { { $link complex-double-blas-matrix } } } "All of these subclasses share the same tuple layout:" { $list @@ -104,14 +104,14 @@ HELP: float-blas-matrix { $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; HELP: double-blas-matrix { $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; -HELP: float-complex-blas-matrix +HELP: complex-float-blas-matrix { $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; -HELP: double-complex-blas-matrix +HELP: complex-double-blas-matrix { $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ; { - float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix - float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector + float-blas-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix + float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector } related-words HELP: Mwidth @@ -272,7 +272,7 @@ HELP: cmatrix{ { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } } "> } -{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; +{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: zmatrix{ { $syntax <" zmatrix{ @@ -281,7 +281,7 @@ HELP: zmatrix{ { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } } "> } -{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; +{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; { POSTPONE: smatrix{ POSTPONE: dmatrix{ diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index d9653fca6f..6a948b6fe1 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -1,11 +1,13 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel locals macros -math math.blas.cblas math.blas.vectors math.blas.vectors.private +math math.blas.ffi math.blas.vectors math.blas.vectors.private math.complex math.functions math.order functors words sequences sequences.merged sequences.private shuffle specialized-arrays.direct.float specialized-arrays.direct.double specialized-arrays.float specialized-arrays.double -parser prettyprint.backend prettyprint.custom ; +specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double +specialized-arrays.complex-float specialized-arrays.complex-double +parser prettyprint.backend prettyprint.custom ascii ; IN: math.blas.matrices TUPLE: blas-matrix-base underlying ld rows cols transpose ; @@ -25,7 +27,7 @@ GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C ) > [ CblasTrans ] [ CblasNoTrans ] if ; + transpose>> [ "T" ] [ "N" ] if ; GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) @@ -38,19 +40,18 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-gemv) - ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc - y ) + ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc + y ) A x y (validate-gemv) - CblasColMajor A (blas-transpose) A rows>> A cols>> - alpha >c-arg call + alpha A underlying>> A ld>> x underlying>> x inc>> - beta >c-arg call + beta y underlying>> y inc>> y ; inline @@ -64,13 +65,12 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-ger) - ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld - A ) + ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld + A ) x y A (validate-ger) - CblasColMajor A rows>> A cols>> - alpha >c-arg call + alpha x underlying>> x inc>> y underlying>> @@ -89,21 +89,20 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) unless ; :: (prepare-gemm) - ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld - C ) + ( alpha A B beta C -- A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld + C ) A B C (validate-gemm) - CblasColMajor A (blas-transpose) B (blas-transpose) C rows>> C cols>> A Mwidth - alpha >c-arg call + alpha A underlying>> A ld>> B underlying>> B ld>> - beta >c-arg call + beta C underlying>> C ld>> C f >>transpose ; inline @@ -250,16 +249,18 @@ FUNCTOR: (define-blas-matrix) ( TYPE T U C -- ) VECTOR IS ${TYPE}-blas-vector IS <${TYPE}-blas-vector> >ARRAY IS >${TYPE}-array -TYPE>ARG IS ${TYPE}>arg -XGEMV IS cblas_${T}gemv -XGEMM IS cblas_${T}gemm -XGERU IS cblas_${T}ger${U} -XGERC IS cblas_${T}ger${C} +XGEMV IS ${T}GEMV +XGEMM IS ${T}GEMM +XGERU IS ${T}GER${U} +XGERC IS ${T}GER${C} MATRIX DEFINES-CLASS ${TYPE}-blas-matrix DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix -XMATRIX{ DEFINES ${T}matrix{ + +t [ T >lower ] + +XMATRIX{ DEFINES ${t}matrix{ WHERE @@ -277,21 +278,16 @@ M: MATRIX (blas-vector-like) drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY underlying>> ] (>matrix) - ; + [ >ARRAY underlying>> ] (>matrix) ; M: VECTOR n*M.V+n*V! - [ TYPE>ARG ] (prepare-gemv) - [ XGEMV ] dip ; + (prepare-gemv) [ XGEMV ] dip ; M: MATRIX n*M.M+n*M! - [ TYPE>ARG ] (prepare-gemm) - [ XGEMM ] dip ; + (prepare-gemm) [ XGEMM ] dip ; M: MATRIX n*V(*)V+M! - [ TYPE>ARG ] (prepare-ger) - [ XGERU ] dip ; + (prepare-ger) [ XGERU ] dip ; M: MATRIX n*V(*)Vconj+M! - [ TYPE>ARG ] (prepare-ger) - [ XGERC ] dip ; + (prepare-ger) [ XGERC ] dip ; : XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing @@ -304,12 +300,12 @@ M: MATRIX pprint-delims : define-real-blas-matrix ( TYPE T -- ) "" "" (define-blas-matrix) ; : define-complex-blas-matrix ( TYPE T -- ) - "u" "c" (define-blas-matrix) ; + "U" "C" (define-blas-matrix) ; -"float" "s" define-real-blas-matrix -"double" "d" define-real-blas-matrix -"float-complex" "c" define-complex-blas-matrix -"double-complex" "z" define-complex-blas-matrix +"float" "S" define-real-blas-matrix +"double" "D" define-real-blas-matrix +"complex-float" "C" define-complex-blas-matrix +"complex-double" "Z" define-complex-blas-matrix >> From 4325f5a7a9a08c6c9b67eccd2141acf6b353138f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:04:37 -0600 Subject: [PATCH 059/168] kill math.blas.cblas --- basis/math/blas/cblas/authors.txt | 1 - basis/math/blas/cblas/cblas.factor | 574 ------------------ basis/math/blas/cblas/summary.txt | 1 - basis/math/blas/cblas/tags.txt | 2 - basis/math/blas/matrices/matrices-docs.factor | 2 +- 5 files changed, 1 insertion(+), 579 deletions(-) delete mode 100644 basis/math/blas/cblas/authors.txt delete mode 100644 basis/math/blas/cblas/cblas.factor delete mode 100644 basis/math/blas/cblas/summary.txt delete mode 100644 basis/math/blas/cblas/tags.txt diff --git a/basis/math/blas/cblas/authors.txt b/basis/math/blas/cblas/authors.txt deleted file mode 100644 index f13c9c1e77..0000000000 --- a/basis/math/blas/cblas/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor deleted file mode 100644 index 2a2e9e3a72..0000000000 --- a/basis/math/blas/cblas/cblas.factor +++ /dev/null @@ -1,574 +0,0 @@ -USING: alien alien.c-types alien.syntax kernel system -combinators ; -IN: math.blas.cblas - -<< -: load-atlas ( -- ) - "atlas" "libatlas.so" "cdecl" add-library ; -: load-fortran ( -- ) - "I77" "libI77.so" "cdecl" add-library - "F77" "libF77.so" "cdecl" add-library ; -: load-blas ( -- ) - "blas" "libblas.so" "cdecl" add-library ; - -"cblas" { - { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } - { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] } - { [ os netbsd? ] [ - load-fortran load-blas - "/usr/local/lib/libcblas.so" "cdecl" add-library - ] } - { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] } - [ "libblas.so" "cdecl" add-library ] -} cond ->> - -LIBRARY: cblas - -TYPEDEF: int CBLAS_ORDER -CONSTANT: CblasRowMajor 101 -CONSTANT: CblasColMajor 102 - -TYPEDEF: int CBLAS_TRANSPOSE -CONSTANT: CblasNoTrans 111 -CONSTANT: CblasTrans 112 -CONSTANT: CblasConjTrans 113 - -TYPEDEF: int CBLAS_UPLO -CONSTANT: CblasUpper 121 -CONSTANT: CblasLower 122 - -TYPEDEF: int CBLAS_DIAG -CONSTANT: CblasNonUnit 131 -CONSTANT: CblasUnit 132 - -TYPEDEF: int CBLAS_SIDE -CONSTANT: CblasLeft 141 -CONSTANT: CblasRight 142 - -TYPEDEF: int CBLAS_INDEX - -C-STRUCT: float-complex - { "float" "real" } - { "float" "imag" } ; -C-STRUCT: double-complex - { "double" "real" } - { "double" "imag" } ; - -! Level 1 BLAS (scalar-vector and vector-vector) - -FUNCTION: float cblas_sdsdot - ( int N, float alpha, float* X, int incX, float* Y, int incY ) ; -FUNCTION: double cblas_dsdot - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: float cblas_sdot - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: double cblas_ddot - ( int N, double* X, int incX, double* Y, int incY ) ; - -FUNCTION: void cblas_cdotu_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; -FUNCTION: void cblas_cdotc_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; - -FUNCTION: void cblas_zdotu_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ; -FUNCTION: void cblas_zdotc_sub - ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ; - -FUNCTION: float cblas_snrm2 - ( int N, float* X, int incX ) ; -FUNCTION: float cblas_sasum - ( int N, float* X, int incX ) ; - -FUNCTION: double cblas_dnrm2 - ( int N, double* X, int incX ) ; -FUNCTION: double cblas_dasum - ( int N, double* X, int incX ) ; - -FUNCTION: float cblas_scnrm2 - ( int N, void* X, int incX ) ; -FUNCTION: float cblas_scasum - ( int N, void* X, int incX ) ; - -FUNCTION: double cblas_dznrm2 - ( int N, void* X, int incX ) ; -FUNCTION: double cblas_dzasum - ( int N, void* X, int incX ) ; - -FUNCTION: CBLAS_INDEX cblas_isamax - ( int N, float* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_idamax - ( int N, double* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_icamax - ( int N, void* X, int incX ) ; -FUNCTION: CBLAS_INDEX cblas_izamax - ( int N, void* X, int incX ) ; - -FUNCTION: void cblas_sswap - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: void cblas_scopy - ( int N, float* X, int incX, float* Y, int incY ) ; -FUNCTION: void cblas_saxpy - ( int N, float alpha, float* X, int incX, float* Y, int incY ) ; - -FUNCTION: void cblas_dswap - ( int N, double* X, int incX, double* Y, int incY ) ; -FUNCTION: void cblas_dcopy - ( int N, double* X, int incX, double* Y, int incY ) ; -FUNCTION: void cblas_daxpy - ( int N, double alpha, double* X, int incX, double* Y, int incY ) ; - -FUNCTION: void cblas_cswap - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_ccopy - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_caxpy - ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; - -FUNCTION: void cblas_zswap - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_zcopy - ( int N, void* X, int incX, void* Y, int incY ) ; -FUNCTION: void cblas_zaxpy - ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ; - -FUNCTION: void cblas_sscal - ( int N, float alpha, float* X, int incX ) ; -FUNCTION: void cblas_dscal - ( int N, double alpha, double* X, int incX ) ; -FUNCTION: void cblas_cscal - ( int N, void* alpha, void* X, int incX ) ; -FUNCTION: void cblas_zscal - ( int N, void* alpha, void* X, int incX ) ; -FUNCTION: void cblas_csscal - ( int N, float alpha, void* X, int incX ) ; -FUNCTION: void cblas_zdscal - ( int N, double alpha, void* X, int incX ) ; - -FUNCTION: void cblas_srotg - ( float* a, float* b, float* c, float* s ) ; -FUNCTION: void cblas_srotmg - ( float* d1, float* d2, float* b1, float b2, float* P ) ; -FUNCTION: void cblas_srot - ( int N, float* X, int incX, float* Y, int incY, float c, float s ) ; -FUNCTION: void cblas_srotm - ( int N, float* X, int incX, float* Y, int incY, float* P ) ; - -FUNCTION: void cblas_drotg - ( double* a, double* b, double* c, double* s ) ; -FUNCTION: void cblas_drotmg - ( double* d1, double* d2, double* b1, double b2, double* P ) ; -FUNCTION: void cblas_drot - ( int N, double* X, int incX, double* Y, int incY, double c, double s ) ; -FUNCTION: void cblas_drotm - ( int N, double* X, int incX, double* Y, int incY, double* P ) ; - -! Level 2 BLAS (matrix-vector) - -FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - float alpha, float* A, int lda, - float* X, int incX, float beta, - float* Y, int incY ) ; -FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, float alpha, - float* A, int lda, float* X, - int incX, float beta, float* Y, int incY ) ; -FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* Ap, float* X, int incX ) ; -FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* A, int lda, float* X, - int incX ) ; -FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, float* A, int lda, - float* X, int incX ) ; -FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, float* Ap, float* X, int incX ) ; - -FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - double alpha, double* A, int lda, - double* X, int incX, double beta, - double* Y, int incY ) ; -FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, double alpha, - double* A, int lda, double* X, - int incX, double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* Ap, double* X, int incX ) ; -FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* A, int lda, double* X, - int incX ) ; -FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, double* A, int lda, - double* X, int incX ) ; -FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, double* Ap, double* X, int incX ) ; - -FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - void* alpha, void* A, int lda, - void* X, int incX, void* beta, - void* Y, int incY ) ; -FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, void* alpha, - void* A, int lda, void* X, - int incX, void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; -FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, void* X, - int incX ) ; -FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; - -FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - void* alpha, void* A, int lda, - void* X, int incX, void* beta, - void* Y, int incY ) ; -FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order, - CBLAS_TRANSPOSE TransA, int M, int N, - int KL, int KU, void* alpha, - void* A, int lda, void* X, - int incX, void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; -FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* A, int lda, void* X, - int incX ) ; -FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, int K, void* A, int lda, - void* X, int incX ) ; -FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag, - int N, void* Ap, void* X, int incX ) ; - - -FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* A, - int lda, float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, float alpha, float* A, - int lda, float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* Ap, - float* X, int incX, - float beta, float* Y, int incY ) ; -FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N, - float alpha, float* X, int incX, - float* Y, int incY, float* A, int lda ) ; -FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* A, int lda ) ; -FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Ap ) ; -FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Y, int incY, float* A, - int lda ) ; -FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, float* X, - int incX, float* Y, int incY, float* A ) ; - -FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* A, - int lda, double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, double alpha, double* A, - int lda, double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* Ap, - double* X, int incX, - double beta, double* Y, int incY ) ; -FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N, - double alpha, double* X, int incX, - double* Y, int incY, double* A, int lda ) ; -FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* A, int lda ) ; -FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Ap ) ; -FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Y, int incY, double* A, - int lda ) ; -FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, double* X, - int incX, double* Y, int incY, double* A ) ; - - -FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* Ap, - void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, void* X, int incX, - void* A, int lda ) ; -FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, float alpha, void* X, - int incX, void* A ) ; -FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* Ap ) ; - -FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, int K, void* alpha, void* A, - int lda, void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, void* alpha, void* Ap, - void* X, int incX, - void* beta, void* Y, int incY ) ; -FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, void* X, int incX, - void* A, int lda ) ; -FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - int N, double alpha, void* X, - int incX, void* A ) ; -FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* A, int lda ) ; -FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N, - void* alpha, void* X, int incX, - void* Y, int incY, void* Ap ) ; - -! Level 3 BLAS (matrix-matrix) - -FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, float alpha, float* A, - int lda, float* B, int ldb, - float beta, float* C, int ldc ) ; -FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb, float beta, - float* C, int ldc ) ; -FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, float* A, int lda, - float beta, float* C, int ldc ) ; -FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, float* A, int lda, - float* B, int ldb, float beta, - float* C, int ldc ) ; -FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb ) ; -FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - float alpha, float* A, int lda, - float* B, int ldb ) ; - -FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, double alpha, double* A, - int lda, double* B, int ldb, - double beta, double* C, int ldc ) ; -FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb, double beta, - double* C, int ldc ) ; -FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, double* A, int lda, - double beta, double* C, int ldc ) ; -FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, double* A, int lda, - double* B, int ldb, double beta, - double* C, int ldc ) ; -FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb ) ; -FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - double alpha, double* A, int lda, - double* B, int ldb ) ; - -FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, void* alpha, void* A, - int lda, void* B, int ldb, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; -FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; - -FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA, - CBLAS_TRANSPOSE TransB, int M, int N, - int K, void* alpha, void* A, - int lda, void* B, int ldb, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* beta, void* C, int ldc ) ; -FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; -FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA, - CBLAS_DIAG Diag, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb ) ; - -FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - float alpha, void* A, int lda, - float beta, void* C, int ldc ) ; -FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, float beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side, - CBLAS_UPLO Uplo, int M, int N, - void* alpha, void* A, int lda, - void* B, int ldb, void* beta, - void* C, int ldc ) ; -FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - double alpha, void* A, int lda, - double beta, void* C, int ldc ) ; -FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, - CBLAS_TRANSPOSE Trans, int N, int K, - void* alpha, void* A, int lda, - void* B, int ldb, double beta, - void* C, int ldc ) ; - diff --git a/basis/math/blas/cblas/summary.txt b/basis/math/blas/cblas/summary.txt deleted file mode 100644 index c72e78eb0d..0000000000 --- a/basis/math/blas/cblas/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt deleted file mode 100644 index 241ec1ecda..0000000000 --- a/basis/math/blas/cblas/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -math -bindings diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index b6e118836e..17d2f9ccd1 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -8,7 +8,7 @@ ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" { $subsection "math.blas.vectors" } "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:" { $subsection "math.blas.matrices" } -"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ; +"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ; ARTICLE: "math.blas-types" "BLAS interface types" "BLAS vectors come in single- and double-precision, real and complex flavors:" From bfc2af7ea13679158f5a88df190f4730b5dde946 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:22:43 -0600 Subject: [PATCH 060/168] remove unnecessary calls to underlying>> from math.blas --- basis/math/blas/vectors/vectors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index a373ec7c5a..84b5fd9e6f 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -33,7 +33,7 @@ GENERIC: (blas-direct-array) ( blas-vector -- direct-array ) : shorter-length ( v1 v2 -- length ) [ length>> ] bi@ min ; inline : data-and-inc ( v -- data inc ) - [ underlying>> ] [ inc>> ] bi ; inline + [ ] [ inc>> ] bi ; inline : datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc ) [ data-and-inc ] bi@ ; inline From fecc9890985d2d75f04de117356e4f85f616ebfd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:23:56 -0600 Subject: [PATCH 061/168] get rid of underlying>>s, again --- basis/math/blas/matrices/matrices.factor | 28 ++++++++++++------------ 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 6a948b6fe1..6fad545501 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -47,19 +47,19 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) A rows>> A cols>> alpha - A underlying>> + A A ld>> - x underlying>> + x x inc>> beta - y underlying>> + y y inc>> y ; inline : (validate-ger) ( x y A -- ) { - [ nip [ length>> ] [ Mheight ] bi* = ] - [ nipd [ length>> ] [ Mwidth ] bi* = ] + [ [ length>> ] [ drop ] [ Mheight ] tri* = ] + [ [ drop ] [ length>> ] [ Mwidth ] tri* = ] } 3&& [ "Mismatched vertices and matrix in vector outer product" throw ] unless ; @@ -71,19 +71,19 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) A rows>> A cols>> alpha - x underlying>> + x x inc>> - y underlying>> + y y inc>> - A underlying>> + A A ld>> A f >>transpose ; inline : (validate-gemm) ( A B C -- ) { - [ drop [ Mwidth ] [ Mheight ] bi* = ] - [ nip [ Mheight ] bi@ = ] - [ nipd [ Mwidth ] bi@ = ] + [ [ Mwidth ] [ Mheight ] [ drop ] tri* = ] + [ [ Mheight ] [ drop ] [ Mheight ] tri* = ] + [ [ drop ] [ Mwidth ] [ Mwidth ] tri* = ] } 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ; @@ -98,12 +98,12 @@ GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) C cols>> A Mwidth alpha - A underlying>> + A A ld>> - B underlying>> + B B ld>> beta - C underlying>> + C C ld>> C f >>transpose ; inline From 296a1ce0a93e9c66dd0220e436df76c7b31c9ddc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:26:12 -0600 Subject: [PATCH 062/168] unit tests for complex specialized-arrays --- .../complex-double/complex-double-tests.factor | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 basis/specialized-arrays/complex-double/complex-double-tests.factor diff --git a/basis/specialized-arrays/complex-double/complex-double-tests.factor b/basis/specialized-arrays/complex-double/complex-double-tests.factor new file mode 100644 index 0000000000..9f2bcc99b7 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double-tests.factor @@ -0,0 +1,13 @@ +USING: kernel sequences specialized-arrays.complex-double tools.test ; +IN: specialized-arrays.complex-double.tests + +[ C{ 3.0 2.0 } ] +[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } second ] unit-test + +[ C{ 1.0 0.0 } ] +[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } first ] unit-test + +[ complex-double-array{ 1.0 C{ 6.0 -7.0 } 5.0 } ] [ + complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } + dup [ C{ 6.0 -7.0 } 1 ] dip set-nth +] unit-test From 4ee82b19f66a4b6ac27a946466cc3d68442c2bbf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 17:47:55 -0600 Subject: [PATCH 063/168] rewrite shuffle( -- ) to avoid locals primitives --- basis/shuffle/shuffle.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 632c09e338..d375ec9c20 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -1,23 +1,22 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs effects.parser generalizations +USING: accessors assocs combinators effects.parser generalizations hashtables kernel locals locals.backend macros make math parser sequences ; IN: shuffle locals-assoc ( sequence -- assoc ) - dup length dup 1- [ - ] curry map zip >hashtable ; +: >index-assoc ( sequence -- assoc ) + dup length zip >hashtable ; PRIVATE> MACRO: shuffle-effect ( effect -- ) - [ out>> ] [ in>> >locals-assoc ] bi + [ out>> ] [ in>> >index-assoc ] bi [ - [ nip assoc-size , \ load-locals , ] - [ [ at , \ get-local , ] curry each ] - [ nip assoc-size , \ drop-locals , ] 2tri + [ nip assoc-size , \ narray , ] + [ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi ] [ ] make ; : shuffle( From efc88c5b696f070916cbdd835f01a175f08b3c01 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 9 Feb 2009 18:11:42 -0600 Subject: [PATCH 064/168] Remove nipd, 3nip, 4nip and tuckd from basis/shuffle --- basis/csv/csv-tests.factor | 4 ++-- basis/db/postgresql/lib/lib.factor | 6 +++--- basis/math/polynomials/polynomials.factor | 4 ++-- basis/regexp/traversal/traversal.factor | 5 ++--- basis/shuffle/shuffle-tests.factor | 2 -- basis/shuffle/shuffle.factor | 8 -------- extra/project-euler/002/002.factor | 4 ++-- extra/reports/noise/noise.factor | 3 --- 8 files changed, 11 insertions(+), 25 deletions(-) diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 4d78c2af86..50bc3836f5 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -1,11 +1,11 @@ -USING: io.streams.string csv tools.test shuffle kernel strings +USING: io.streams.string csv tools.test kernel strings io.pathnames io.files.unique io.encodings.utf8 io.files io.directories ; IN: csv.tests ! I like to name my unit tests : named-unit-test ( name output input -- ) - nipd unit-test ; inline + unit-test drop ; inline ! tests nicked from the wikipedia csv article ! http://en.wikipedia.org/wiki/Comma-separated_values diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 05114a4deb..0d50d1ab2c 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -3,7 +3,7 @@ USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators -libc shuffle calendar.format byte-arrays destructors prettyprint +libc calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.encodings.utf8 alien.strings io.streams.byte-array summary present urls specialized-arrays.uint specialized-arrays.alien db.private ; @@ -117,7 +117,7 @@ M: postgresql-result-null summary ( obj -- str ) : pq-get-string ( handle row column -- obj ) 3dup PQgetvalue utf8 alien>string - dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ; + dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ; : pq-get-number ( handle row column -- obj ) pq-get-string dup [ string>number ] when ; @@ -134,7 +134,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) : pq-get-blob ( handle row column -- obj/f ) [ PQgetvalue ] 3keep 3dup PQgetlength dup 0 > [ - 3nip + [ 3drop ] dip [ memory>byte-array >string 0 diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 1ece3d915e..749bde3a10 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel make math math.order math.vectors sequences shuffle +USING: arrays kernel make math math.order math.vectors sequences splitting vectors ; IN: math.polynomials @@ -75,7 +75,7 @@ PRIVATE> PRIVATE> : pgcd ( p q -- a d ) - swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ; + [ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ; : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index d8c25eda18..104a6c2ce1 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators kernel math quotations sequences regexp.parser regexp.classes fry arrays -combinators.short-circuit regexp.utils prettyprint regexp.nfa -shuffle ; +combinators.short-circuit regexp.utils prettyprint regexp.nfa ; IN: regexp.traversal TUPLE: dfa-traverser @@ -170,7 +169,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) ] [ drop ] if ; : match-default ( transition from-state table -- to-state/f ) - nipd transitions>> at t swap at ; + [ drop ] 2dip transitions>> at t swap at ; : match-transition ( obj from-state dfa -- to-state/f ) { [ match-literal ] [ match-class ] [ match-default ] } 3|| ; diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index f190544e19..f8f83a9c08 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -1,5 +1,3 @@ USING: shuffle tools.test ; -[ 8 ] [ 5 6 7 8 3nip ] unit-test -[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test [ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index b195e4abf9..10fb8b01dd 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -6,14 +6,6 @@ IN: shuffle : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline -: nipd ( a b c -- b c ) rot drop ; inline - -: 3nip ( a b c d -- d ) 3 nnip ; inline - -: 4nip ( a b c d e -- e ) 4 nnip ; inline - : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline : 4drop ( a b c d -- ) 3drop drop ; inline - -: tuckd ( x y z -- z x y z ) 2 ntuck ; inline diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index da20c874b5..9c462b6b2e 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences shuffle ; +USING: kernel math sequences ; IN: project-euler.002 ! http://projecteuler.net/index.php?section=problems&id=2 @@ -41,7 +41,7 @@ PRIVATE> ! ------------------- : fib-upto* ( n -- seq ) - 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce 3nip + 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce [ 3drop ] dip but-last-slice { 0 1 } prepend ; : euler002a ( -- answer ) diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 3e47adac0b..89e00f88c5 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -25,7 +25,6 @@ IN: reports.noise { 3drop 1 } { 3dup 2 } { 3keep 3 } - { 3nip 4 } { 3slip 3 } { 4drop 2 } { 4dup 3 } @@ -50,7 +49,6 @@ IN: reports.noise { ndrop 2 } { ndup 3 } { nip 2 } - { nipd 3 } { nkeep 5 } { npick 6 } { nrot 5 } @@ -66,7 +64,6 @@ IN: reports.noise { swap 1 } { swapd 3 } { tuck 2 } - { tuckd 4 } { with 1/2 } { bi 1/2 } From b5a96dccdf7f44ce9f3df5eac2d2f5767dc3c6ef Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 9 Feb 2009 18:36:36 -0600 Subject: [PATCH 065/168] Slight cleanup in xml-rpc --- basis/xml-rpc/xml-rpc.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 9632cbb1ac..690ebe94f8 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -126,11 +126,11 @@ TAG: int xml>item children>number ; TAG: double xml>item children>number ; TAG: boolean xml>item - dup children>string { - { [ dup "1" = ] [ 2drop t ] } - { [ "0" = ] [ drop f ] } + children>string { + { "1" [ t ] } + { "0" [ f ] } [ "Bad boolean" server-error ] - } cond ; + } case ; : unstruct-member ( tag -- ) children-tags first2 From 3672bcb08f12e4d4059d988152c9fc3956adab08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 18:39:46 -0600 Subject: [PATCH 066/168] loading some tiff files works! --- extra/graphics/tiff/tiff.factor | 6 ++++-- extra/graphics/viewer/viewer.factor | 30 ++++++++++++++++++++++------- 2 files changed, 27 insertions(+), 9 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index 9461403805..b4e57d4ed6 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -14,6 +14,7 @@ the-answer ifd-offset ifds ; + CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; @@ -327,8 +328,9 @@ ERROR: bad-small-ifd-type n ; dup ifd-entries>> [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; +: strips>buffer ( ifd -- ifd ) + dup strips>> concat >>buffer ; /* -: ifd-strips>buffer ( ifd -- ifd ) [ [ rows-per-strip find-tag n>> ] [ image-length find-tag n>> ] bi @@ -342,7 +344,7 @@ ERROR: bad-small-ifd-type n ; read-header [ read-ifds - dup ifds>> [ process-ifd read-strips drop ] each + dup ifds>> [ process-ifd read-strips strips>buffer drop ] each ] with-tiff-endianness ] with-file-reader ; diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 8e0b1ec43c..90425722da 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators graphics.bitmap kernel math math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render ; +ui.gadgets.panes ui.render graphics.tiff sequences ; IN: graphics.viewer TUPLE: graphics-gadget < gadget image ; @@ -21,6 +21,14 @@ M: graphics-gadget draw-gadget* ( gadget -- ) \ graphics-gadget new-gadget swap >>image ; +: bits>gl-params ( n -- gl-bgr gl-format ) + { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case ; + M: bitmap draw-image ( bitmap -- ) dup height>> 0 < [ 0 0 glRasterPos2i @@ -32,12 +40,7 @@ M: bitmap draw-image ( bitmap -- ) [ width>> ] keep [ [ height>> abs ] keep - bit-count>> { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case + bit-count>> bits>gl-params ] keep array>> glDrawPixels ; M: bitmap width ( bitmap -- ) width>> ; @@ -48,3 +51,16 @@ M: bitmap height ( bitmap -- ) height>> ; : bitmap-window ( path -- gadget ) load-bitmap [ "bitmap" open-window ] keep ; + +M: tiff width ( tiff -- ) ifds>> first image-width find-tag n>> ; +M: tiff height ( tiff -- ) ifds>> first image-length find-tag n>> ; + +M: tiff draw-image ( tiff -- ) + [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip + ifds>> first + { + [ image-width find-tag n>> ] + [ image-length find-tag n>> ] + [ bits-per-sample find-tag n>> sum bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; From 03f7a72d41fb448943f771b3a5f535f6560bbfb8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 18:44:36 -0600 Subject: [PATCH 067/168] alien.fortran docs --- basis/alien/fortran/fortran-docs.factor | 56 +++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 basis/alien/fortran/fortran-docs.factor diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor new file mode 100644 index 0000000000..1b942d30c5 --- /dev/null +++ b/basis/alien/fortran/fortran-docs.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2009 Joe Groff +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations sequences strings ; +QUALIFIED-WITH: alien.syntax c +IN: alien.fortran + +ARTICLE: "alien.fortran-types" "Fortran types" +"The Fortran FFI recognizes the following Fortran types:" +{ $list + { { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." } + { { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." } + { { $snippet "REAL" } " specifies a single-precision floating-point real value." } + { { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." } + { { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." } + { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } + { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } + { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } + { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameters." } +} +"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; + +HELP: FUNCTION: +{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: SUBROUTINE: +{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: LIBRARY: +{ $syntax "LIBRARY: name" } +{ $values { "name" "a logical library name" } } +{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions." } ; + +HELP: RECORD: +{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } +{ $description "Defines a Fortran record type with the given slots." } ; + +HELP: fortran-invoke +{ $values + { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } +} +{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." } +; + +ARTICLE: "alien.fortran" "Fortran FFI" +"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code shared libraries written in Fortran." +{ $subsection "alien.fortran-types" } +{ $subsection POSTPONE: LIBRARY: } +{ $subsection POSTPONE: FUNCTION: } +{ $subsection POSTPONE: SUBROUTINE: } +{ $subsection POSTPONE: RECORD: } +{ $subsection fortran-invoke } +; + +ABOUT: "alien.fortran" From f7d9f2ab2e5ea2a4bf519733cf0f79d04fa1f944 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 19:02:20 -0600 Subject: [PATCH 068/168] typo in alien.fortran docs --- basis/alien/fortran/fortran-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 1b942d30c5..4accbf5965 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -44,7 +44,7 @@ HELP: fortran-invoke ; ARTICLE: "alien.fortran" "Fortran FFI" -"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code shared libraries written in Fortran." +"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." { $subsection "alien.fortran-types" } { $subsection POSTPONE: LIBRARY: } { $subsection POSTPONE: FUNCTION: } From fbba25e968c0513605092fa1500fbcb8761a8540 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 19:16:46 -0600 Subject: [PATCH 069/168] clean up tiff --- extra/graphics/tiff/tiff.factor | 262 ++++++++++------------------ extra/graphics/viewer/viewer.factor | 10 +- 2 files changed, 96 insertions(+), 176 deletions(-) diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor index b4e57d4ed6..0481af8747 100755 --- a/extra/graphics/tiff/tiff.factor +++ b/extra/graphics/tiff/tiff.factor @@ -4,183 +4,121 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian tools.hexdump constructors sequences arrays sorting.slots math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays grouping ; -USE: multiline - IN: graphics.tiff -TUPLE: tiff -endianness -the-answer -ifd-offset -ifds ; - +TUPLE: tiff endianness the-answer ifd-offset ifds ; CONSTRUCTOR: tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next processed-tags strips buffer ; - CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset/value ; - CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; - -TUPLE: photometric-interpretation color ; - -CONSTRUCTOR: photometric-interpretation ( color -- object ) ; - -SINGLETONS: white-is-zero black-is-zero rgb palette-color ; - +SINGLETONS: photometric-interpretation +photometric-interpretation-white-is-zero +photometric-interpretation-black-is-zero +photometric-interpretation-rgb +photometric-interpretation-palette-color ; ERROR: bad-photometric-interpretation n ; - : lookup-photometric-interpretation ( n -- singleton ) { - { 0 [ white-is-zero ] } - { 1 [ black-is-zero ] } - { 2 [ rgb ] } - { 3 [ palette-color ] } + { 0 [ photometric-interpretation-white-is-zero ] } + { 1 [ photometric-interpretation-black-is-zero ] } + { 2 [ photometric-interpretation-rgb ] } + { 3 [ photometric-interpretation-palette-color ] } [ bad-photometric-interpretation ] - } case ; - - -TUPLE: compression method ; - -CONSTRUCTOR: compression ( method -- object ) ; - -SINGLETONS: no-compression CCITT-2 pack-bits lzw ; + } case ; +SINGLETONS: compression +compression-none +compression-CCITT-2 +compression-lzw +compression-pack-bits ; ERROR: bad-compression n ; - : lookup-compression ( n -- compression ) { - { 1 [ no-compression ] } - { 2 [ CCITT-2 ] } - { 5 [ lzw ] } - { 32773 [ pack-bits ] } + { 1 [ compression-none ] } + { 2 [ compression-CCITT-2 ] } + { 5 [ compression-lzw ] } + { 32773 [ compression-pack-bits ] } [ bad-compression ] - } case ; - -TUPLE: image-length n ; -CONSTRUCTOR: image-length ( n -- object ) ; - -TUPLE: image-width n ; -CONSTRUCTOR: image-width ( n -- object ) ; - -TUPLE: x-resolution n ; -CONSTRUCTOR: x-resolution ( n -- object ) ; - -TUPLE: y-resolution n ; -CONSTRUCTOR: y-resolution ( n -- object ) ; - -TUPLE: rows-per-strip n ; -CONSTRUCTOR: rows-per-strip ( n -- object ) ; - -TUPLE: strip-offsets n ; -CONSTRUCTOR: strip-offsets ( n -- object ) ; - -TUPLE: strip-byte-counts n ; -CONSTRUCTOR: strip-byte-counts ( n -- object ) ; - -TUPLE: bits-per-sample n ; -CONSTRUCTOR: bits-per-sample ( n -- object ) ; - -TUPLE: samples-per-pixel n ; -CONSTRUCTOR: samples-per-pixel ( n -- object ) ; - -SINGLETONS: no-resolution-unit -inch-resolution-unit -centimeter-resolution-unit ; - -TUPLE: resolution-unit type ; -CONSTRUCTOR: resolution-unit ( type -- object ) ; + } case ; +SINGLETONS: resolution-unit +resolution-unit-none +resolution-unit-inch +resolution-unit-centimeter ; ERROR: bad-resolution-unit n ; - : lookup-resolution-unit ( n -- object ) { - { 1 [ no-resolution-unit ] } - { 2 [ inch-resolution-unit ] } - { 3 [ centimeter-resolution-unit ] } + { 1 [ resolution-unit-none ] } + { 2 [ resolution-unit-inch ] } + { 3 [ resolution-unit-centimeter ] } [ bad-resolution-unit ] - } case ; - - -TUPLE: predictor type ; -CONSTRUCTOR: predictor ( type -- object ) ; - -SINGLETONS: no-predictor horizontal-differencing-predictor ; + } case ; +SINGLETONS: predictor +predictor-none +predictor-horizontal-differencing ; ERROR: bad-predictor n ; - : lookup-predictor ( n -- object ) { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } + { 1 [ predictor-none ] } + { 2 [ predictor-horizontal-differencing ] } [ bad-predictor ] - } case ; - - -TUPLE: planar-configuration type ; -CONSTRUCTOR: planar-configuration ( type -- object ) ; - -SINGLETONS: chunky planar ; + } case ; +SINGLETONS: planar-configuration +planar-configuration-chunky +planar-configuration-planar ; ERROR: bad-planar-configuration n ; - : lookup-planar-configuration ( n -- object ) { - { 1 [ no-predictor ] } - { 2 [ horizontal-differencing-predictor ] } - [ bad-predictor ] - } case ; + { 1 [ planar-configuration-chunky ] } + { 2 [ planar-configuration-planar ] } + [ bad-planar-configuration ] + } case ; -TUPLE: sample-format n ; -CONSTRUCTOR: sample-format ( n -- object ) ; ERROR: bad-sample-format n ; - -SINGLETONS: sample-unsigned-integer sample-signed-integer -sample-ieee-float sample-undefined-data ; - +SINGLETONS: sample-format +sample-format-unsigned-integer +sample-format-signed-integer +sample-format-ieee-float +sample-format-undefined-data ; : lookup-sample-format ( seq -- object ) [ { - { 1 [ sample-unsigned-integer ] } - { 2 [ sample-signed-integer ] } - { 3 [ sample-ieee-float ] } - { 4 [ sample-undefined-data ] } + { 1 [ sample-format-unsigned-integer ] } + { 2 [ sample-format-signed-integer ] } + { 3 [ sample-format-ieee-float ] } + { 4 [ sample-format-undefined-data ] } [ bad-sample-format ] } case - ] map ; + ] map ; - -TUPLE: extra-samples n ; -CONSTRUCTOR: extra-samples ( n -- object ) ; ERROR: bad-extra-samples n ; - -SINGLETONS: unspecified-alpha-data associated-alpha-data -unassociated-alpha-data ; - +SINGLETONS: extra-samples +extra-samples-unspecified-alpha-data +extra-samples-associated-alpha-data +extra-samples-unassociated-alpha-data ; : lookup-extra-samples ( seq -- object ) { - { 0 [ unspecified-alpha-data ] } - { 1 [ associated-alpha-data ] } - { 2 [ unassociated-alpha-data ] } + { 0 [ extra-samples-unspecified-alpha-data ] } + { 1 [ extra-samples-associated-alpha-data ] } + { 2 [ extra-samples-unassociated-alpha-data ] } [ bad-extra-samples ] - } case ; + } case ; - -TUPLE: orientation n ; -CONSTRUCTOR: orientation ( n -- object ) ; - - -TUPLE: new-subfile-type n ; -CONSTRUCTOR: new-subfile-type ( n -- object ) ; +SINGLETONS: image-length image-width x-resolution y-resolution +rows-per-strip strip-offsets strip-byte-counts bits-per-sample +samples-per-pixel new-subfile-type orientation +unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; - : tiff-endianness ( byte-array -- ? ) { { B{ CHAR: M CHAR: M } [ big-endian ] } @@ -188,9 +126,6 @@ ERROR: bad-tiff-magic bytes ; [ bad-tiff-magic ] } case ; -: with-tiff-endianness ( tiff quot -- tiff ) - [ dup endianness>> ] dip with-endianness ; inline - : read-header ( tiff -- tiff ) 2 read tiff-endianness [ >>endianness ] keep [ @@ -198,9 +133,7 @@ ERROR: bad-tiff-magic bytes ; 4 read endian> >>ifd-offset ] with-endianness ; -: push-ifd ( tiff ifd -- tiff ) - over ifds>> push ; - ! over [ dup class ] [ ifds>> ] bi* set-at ; +: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; : read-ifd ( -- ifd ) 2 read endian> @@ -221,23 +154,18 @@ ERROR: no-tag class ; dupd at* [ nip t ] [ drop f ] if ; inline : find-tag ( idf class -- tag ) - swap processed-tags>> - ?at [ no-tag ] unless ; + swap processed-tags>> ?at [ no-tag ] unless ; : read-strips ( ifd -- ifd ) dup - [ strip-byte-counts find-tag n>> ] - [ strip-offsets find-tag n>> ] bi + [ strip-byte-counts find-tag ] + [ strip-offsets find-tag ] bi 2dup [ integer? ] both? [ seek-absolute seek-input read 1array ] [ [ seek-absolute seek-input read ] { } 2map-as ] if >>strips ; -! ERROR: unhandled-ifd-entry data n ; - -: unhandled-ifd-entry ; - ERROR: unknown-ifd-type n ; : bytes>bits ( n/byte-array -- n ) @@ -301,51 +229,43 @@ ERROR: bad-small-ifd-type n ; [ type>> ] tri offset-bytes>obj ] if ; -: process-ifd-entry ( ifd-entry -- object ) +: process-ifd-entry ( ifd-entry -- value class ) [ ifd-entry-value ] [ tag>> ] bi { - { 254 [ ] } - { 256 [ ] } - { 257 [ ] } - { 258 [ ] } - { 259 [ lookup-compression ] } - { 262 [ lookup-photometric-interpretation ] } - { 273 [ ] } - { 274 [ ] } - { 277 [ ] } - { 278 [ ] } - { 279 [ ] } - { 282 [ ] } - { 283 [ ] } - { 284 [ ] } - { 296 [ lookup-resolution-unit ] } - { 317 [ lookup-predictor ] } - { 338 [ lookup-extra-samples ] } - { 339 [ lookup-sample-format ] } - [ unhandled-ifd-entry swap 2array ] + { 254 [ new-subfile-type ] } + { 256 [ image-width ] } + { 257 [ image-length ] } + { 258 [ bits-per-sample ] } + { 259 [ lookup-compression compression ] } + { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 273 [ strip-offsets ] } + { 274 [ orientation ] } + { 277 [ samples-per-pixel ] } + { 278 [ rows-per-strip ] } + { 279 [ strip-byte-counts ] } + { 282 [ x-resolution ] } + { 283 [ y-resolution ] } + { 284 [ planar-configuration ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 317 [ lookup-predictor predictor ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + [ nip unhandled-ifd-entry ] } case ; : process-ifd ( ifd -- ifd ) dup ifd-entries>> - [ process-ifd-entry [ class ] keep ] H{ } map>assoc >>processed-tags ; + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; : strips>buffer ( ifd -- ifd ) dup strips>> concat >>buffer ; -/* - [ - [ rows-per-strip find-tag n>> ] - [ image-length find-tag n>> ] bi - ] [ - strips>> [ length ] keep - ] bi assemble-image ; -*/ : (load-tiff) ( path -- tiff ) binary [ - read-header [ + read-header dup endianness>> [ read-ifds dup ifds>> [ process-ifd read-strips strips>buffer drop ] each - ] with-tiff-endianness + ] with-endianness ] with-file-reader ; : load-tiff ( path -- tiff ) (load-tiff) ; diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor index 90425722da..517ab4e010 100644 --- a/extra/graphics/viewer/viewer.factor +++ b/extra/graphics/viewer/viewer.factor @@ -52,15 +52,15 @@ M: bitmap height ( bitmap -- ) height>> ; : bitmap-window ( path -- gadget ) load-bitmap [ "bitmap" open-window ] keep ; -M: tiff width ( tiff -- ) ifds>> first image-width find-tag n>> ; -M: tiff height ( tiff -- ) ifds>> first image-length find-tag n>> ; +M: tiff width ( tiff -- ) ifds>> first image-width find-tag ; +M: tiff height ( tiff -- ) ifds>> first image-length find-tag ; M: tiff draw-image ( tiff -- ) [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip ifds>> first { - [ image-width find-tag n>> ] - [ image-length find-tag n>> ] - [ bits-per-sample find-tag n>> sum bits>gl-params ] + [ image-width find-tag ] + [ image-length find-tag ] + [ bits-per-sample find-tag sum bits>gl-params ] [ buffer>> ] } cleave glDrawPixels ; From 045cd614c669a892a5c45ec3526c95f1f96f7d5c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 19:18:18 -0600 Subject: [PATCH 070/168] make more taxes vocabs load by default --- extra/taxes/usa/futa/futa.factor | 3 +-- extra/taxes/usa/usa.factor | 4 +++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/taxes/usa/futa/futa.factor b/extra/taxes/usa/futa/futa.factor index 7368aef825..9b862a8960 100644 --- a/extra/taxes/usa/futa/futa.factor +++ b/extra/taxes/usa/futa/futa.factor @@ -11,5 +11,4 @@ IN: taxes.usa.futa : futa-tax ( salary w4 -- x ) drop futa-base-rate min - futa-tax-rate futa-tax-offset-credit - - * ; + futa-tax-rate futa-tax-offset-credit - * ; diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index 27ff4aef98..efdb969c01 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.intervals -namespaces sequences money math.order taxes.usa.w4 ; +namespaces sequences money math.order taxes.usa.w4 +taxes.usa.futa math.finance taxes.usa.fica +taxes.usa.federal ; IN: taxes.usa ! Withhold: FICA, Medicare, Federal (FICA is social security) From 0d67f41ae6cc8551ea09e73bcdbf5a662e6f4d7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 19:28:21 -0600 Subject: [PATCH 071/168] update specialized-arrays docs --- basis/specialized-arrays/specialized-arrays-docs.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor index 1c1b3dbc59..9015cccd8f 100644 --- a/basis/specialized-arrays/specialized-arrays-docs.factor +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -28,6 +28,8 @@ $nl { $snippet "ulonglong" } { $snippet "float" } { $snippet "double" } + { $snippet "complex-float" } + { $snippet "complex-double" } { $snippet "void*" } { $snippet "bool" } } From 992da4c9675a3d346b5a69dfdb659190434e744f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:19:18 -0600 Subject: [PATCH 072/168] Fix copy-vm word on Unix --- basis/tools/deploy/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 22d6eb2ffa..ff851edce6 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -12,7 +12,7 @@ destructors accessors ; IN: tools.deploy.backend : copy-vm ( executable bundle-name -- vm ) - [ prepend-path ] dip append vm over copy-file ; + prepend-path vm over copy-file ; : copy-fonts ( name dir -- ) deploy-ui? get [ From a1e45570f5e425dd62a72cfd41781ae391b8e85d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:57:26 -0600 Subject: [PATCH 073/168] rename graphics to images, add an word to load a path --- extra/images/authors.txt | 1 + extra/images/backend/authors.txt | 1 + extra/images/backend/backend.factor | 18 ++ extra/images/bitmap/authors.txt | 1 + extra/images/bitmap/bitmap-tests.factor | 30 +++ extra/images/bitmap/bitmap.factor | 146 ++++++++++++ extra/images/images.factor | 13 ++ extra/images/tags.txt | 1 + extra/images/test-images/1bit.bmp | Bin 0 -> 1662 bytes extra/images/test-images/octagon.tiff | Bin 0 -> 4334 bytes extra/images/test-images/rgb.tiff | Bin 0 -> 7916 bytes extra/images/test-images/rgb4bit.bmp | Bin 0 -> 5318 bytes extra/images/test-images/rgb8bit.bmp | Bin 0 -> 11078 bytes extra/images/test-images/thiswayup24.bmp | Bin 0 -> 60054 bytes extra/images/tiff/authors.txt | 1 + extra/images/tiff/tiff-tests.factor | 11 + extra/images/tiff/tiff.factor | 283 +++++++++++++++++++++++ extra/images/viewer/authors.txt | 1 + extra/images/viewer/viewer.factor | 69 ++++++ 19 files changed, 576 insertions(+) create mode 100644 extra/images/authors.txt create mode 100644 extra/images/backend/authors.txt create mode 100644 extra/images/backend/backend.factor create mode 100755 extra/images/bitmap/authors.txt create mode 100644 extra/images/bitmap/bitmap-tests.factor create mode 100755 extra/images/bitmap/bitmap.factor create mode 100644 extra/images/images.factor create mode 100644 extra/images/tags.txt create mode 100644 extra/images/test-images/1bit.bmp create mode 100644 extra/images/test-images/octagon.tiff create mode 100755 extra/images/test-images/rgb.tiff create mode 100644 extra/images/test-images/rgb4bit.bmp create mode 100644 extra/images/test-images/rgb8bit.bmp create mode 100644 extra/images/test-images/thiswayup24.bmp create mode 100755 extra/images/tiff/authors.txt create mode 100755 extra/images/tiff/tiff-tests.factor create mode 100755 extra/images/tiff/tiff.factor create mode 100755 extra/images/viewer/authors.txt create mode 100644 extra/images/viewer/viewer.factor diff --git a/extra/images/authors.txt b/extra/images/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/images/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/images/backend/authors.txt b/extra/images/backend/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/images/backend/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor new file mode 100644 index 0000000000..ef2a9a4248 --- /dev/null +++ b/extra/images/backend/backend.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel ; +IN: images.backend + +TUPLE: image width height depth pitch buffer ; + +GENERIC: load-image* ( path tuple -- image ) + +: load-image ( path class -- image ) + new load-image* ; + +: new-image ( width height depth buffer class -- image ) + new + swap >>buffer + swap >>depth + swap >>height + swap >>width ; inline diff --git a/extra/images/bitmap/authors.txt b/extra/images/bitmap/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/bitmap/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor new file mode 100644 index 0000000000..6865bfee3c --- /dev/null +++ b/extra/images/bitmap/bitmap-tests.factor @@ -0,0 +1,30 @@ +USING: images.bitmap images.viewer io.encodings.binary +io.files io.files.unique kernel tools.test ; +IN: images.bitmap.tests + +: test-bitmap32-alpha ( -- path ) + "resource:extra/images/bitmap/test-images/32alpha.bmp" ; + +: test-bitmap24 ( -- path ) + "resource:extra/images/bitmap/test-images/thiswayup24.bmp" ; + +: test-bitmap16 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb16bit.bmp" ; + +: test-bitmap8 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb8bit.bmp" ; + +: test-bitmap4 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb4bit.bmp" ; + +: test-bitmap1 ( -- path ) + "resource:extra/images/bitmap/test-images/1bit.bmp" ; + +[ t ] +[ + test-bitmap24 + [ binary file-contents ] [ load-bitmap ] bi + + "test-bitmap24" unique-file + [ save-bitmap ] [ binary file-contents ] bi = +] unit-test diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor new file mode 100755 index 0000000000..220cdc153f --- /dev/null +++ b/extra/images/bitmap/bitmap.factor @@ -0,0 +1,146 @@ +! Copyright (C) 2007, 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types arrays byte-arrays columns +combinators fry grouping io io.binary io.encodings.binary +io.files kernel libc macros math math.bitwise math.functions +namespaces opengl opengl.gl prettyprint sequences strings +summary ui ui.gadgets.panes images.backend ; +IN: images.bitmap + +TUPLE: bitmap-image < image ; + +! Currently can only handle 24/32bit bitmaps. +! Handles row-reversed bitmaps (their height is negative) + +TUPLE: bitmap magic size reserved offset header-length width +height planes bit-count compression size-image +x-pels y-pels color-used color-important rgb-quads color-index +alpha-channel-zero? +buffer ; + +: array-copy ( bitmap array -- bitmap array' ) + over size-image>> abs memory>byte-array ; + +MACRO: (nbits>bitmap) ( bits -- ) + [ -3 shift ] keep '[ + bitmap new + 2over * _ * >>size-image + swap >>height + swap >>width + swap array-copy [ >>buffer ] [ >>color-index ] bi + _ >>bit-count + ] ; + +: bgr>bitmap ( array height width -- bitmap ) + 24 (nbits>bitmap) ; + +: bgra>bitmap ( array height width -- bitmap ) + 32 (nbits>bitmap) ; + +: 8bit>buffer ( bitmap -- array ) + [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-index>> >array ] bi [ swap nth ] with map concat ; + +ERROR: bmp-not-supported n ; + +: raw-bitmap>buffer ( bitmap -- array ) + dup bit-count>> + { + { 32 [ color-index>> ] } + { 24 [ color-index>> ] } + { 16 [ bmp-not-supported ] } + { 8 [ 8bit>buffer ] } + { 4 [ bmp-not-supported ] } + { 2 [ bmp-not-supported ] } + { 1 [ bmp-not-supported ] } + } case >byte-array ; + +ERROR: bitmap-magic ; + +M: bitmap-magic summary + drop "First two bytes of bitmap stream must be 'BM'" ; + +: read2 ( -- n ) 2 read le> ; +: read4 ( -- n ) 4 read le> ; + +: parse-file-header ( bitmap -- bitmap ) + 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic + read4 >>size + read4 >>reserved + read4 >>offset ; + +: parse-bitmap-header ( bitmap -- bitmap ) + read4 >>header-length + read4 >>width + read4 >>height + read2 >>planes + read2 >>bit-count + read4 >>compression + read4 >>size-image + read4 >>x-pels + read4 >>y-pels + read4 >>color-used + read4 >>color-important ; + +: rgb-quads-length ( bitmap -- n ) + [ offset>> 14 - ] [ header-length>> ] bi - ; + +: color-index-length ( bitmap -- n ) + { + [ width>> ] + [ planes>> * ] + [ bit-count>> * 31 + 32 /i 4 * ] + [ height>> abs * ] + } cleave ; + +: parse-bitmap ( bitmap -- bitmap ) + dup rgb-quads-length read >>rgb-quads + dup color-index-length read >>color-index ; + +: load-bitmap ( path -- bitmap ) + binary [ + bitmap new + parse-file-header parse-bitmap-header parse-bitmap + ] with-file-reader ; + +: alpha-channel-zero? ( bitmap -- ? ) + buffer>> 4 3 [ 0 = ] all? ; + +: bitmap>image ( bitmap -- bitmap-image ) + { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave + bitmap-image new-image ; + +M: bitmap-image load-image* ( path bitmap -- bitmap-image ) + drop load-bitmap + dup raw-bitmap>buffer >>buffer + dup alpha-channel-zero? >>alpha-channel-zero? + bitmap>image ; + +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; + +: save-bitmap ( bitmap path -- ) + binary [ + B{ CHAR: B CHAR: M } write + [ + buffer>> length 14 + 40 + write4 + 0 write4 + 54 write4 + 40 write4 + ] [ + { + [ width>> write4 ] + [ height>> write4 ] + [ planes>> 1 or write2 ] + [ bit-count>> 24 or write2 ] + [ compression>> 0 or write4 ] + [ size-image>> write4 ] + [ x-pels>> 0 or write4 ] + [ y-pels>> 0 or write4 ] + [ color-used>> 0 or write4 ] + [ color-important>> 0 or write4 ] + [ rgb-quads>> write ] + [ color-index>> write ] + } cleave + ] bi + ] with-file-writer ; diff --git a/extra/images/images.factor b/extra/images/images.factor new file mode 100644 index 0000000000..eb4fc63fee --- /dev/null +++ b/extra/images/images.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: constructors kernel splitting unicode.case combinators +accessors images.bitmap images.tiff images.backend io.backend +io.pathnames ; +IN: images + +: ( path -- image ) + normalize-path dup "." split1-last nip >lower + { + { "bmp" [ bitmap-image load-image ] } + { "tiff" [ tiff-image load-image ] } + } case ; diff --git a/extra/images/tags.txt b/extra/images/tags.txt new file mode 100644 index 0000000000..04b54a06f4 --- /dev/null +++ b/extra/images/tags.txt @@ -0,0 +1 @@ +bitmap graphics diff --git a/extra/images/test-images/1bit.bmp b/extra/images/test-images/1bit.bmp new file mode 100644 index 0000000000000000000000000000000000000000..2f244c1d058bfd63c99009e24e43db3d2af59902 GIT binary patch literal 1662 zcmd6mu}&N@5QY~a(QcXY+PnZo8WyGJ9a2QJkP4yX)=xlQ0r3D)UI5Obx(-^kP>P00mA^ zwBUF^jlQ?E;2?IzW6rM6HrH!wQhyj)b6UoD@XeYt9ody`K1_Mt%?}f{KVbJy%jcAj zt>KGpdF1)G8#sXx#Xjmy4aWdZ=sgF-W=L!giOF7nXWqQfqxQZB=n3}M&%h;db954z z5E@tMx~mVf%2{3&6~$+BXh5o3M#kinNOWWu>rFlx|3%95W4uyouK-4#SClXoB~%*C^4(}0onQG*9L-9b-!uM&JH<>m6OjuQDiV1l8blvI&dpWsH&fqeed;%iU%z`!sV;|oL`;1cM@txn1q zeNvtP$iOI5M`t`8&@TI<PT&zE=wk>n#+W#})qlnu6j zqKlaxW~`Q2))-G*FH&~!a+~whBxMUv@;vdku#nh6UAzYFMb4TYyweT-0k9zwR(&q} gI+mcb*Vx}V%YV4a?71qPKl;*mGj7Ahc<-2B0n`=D`~Uy| literal 0 HcmV?d00001 diff --git a/extra/images/test-images/octagon.tiff b/extra/images/test-images/octagon.tiff new file mode 100644 index 0000000000000000000000000000000000000000..2b4ba3950db91cabdca87201b034b9d5bb97bdb3 GIT binary patch literal 4334 zcmebEWzb?^5a9U#|33ph%)r3Fk)M>iq_wp1aC33PQDSjsblTPcPoE|G*KPfGV*9@T zxG*8RtFp_tf4uVg|Cj6UNWvgJmDy$6gS`C~;Bx~m`$7ID*KU|wL2dw<5$x?Z50@LT z*-s6-G2GzeKNp)D(Cw$D-B{c(2i*{EN+;M>;{vx~ f5E45W%m%sb8PE)%?GWg(_8bGqA21r|GB5-H7Z-?3 literal 0 HcmV?d00001 diff --git a/extra/images/test-images/rgb.tiff b/extra/images/test-images/rgb.tiff new file mode 100755 index 0000000000000000000000000000000000000000..71cbaa9d6e807156f7da39a5b116c9edb3b0c9e1 GIT binary patch literal 7916 zcmeHMcT^MWw+#r=t3X6RRC<#hYUoXR4bnxLK!S7xL9Q1Cgh&@qz)BGldhfkA=^#Z! zK)@iqNqZASuUB2~z4iWmzr{LhhA%Uj$#>4#XP|nBx#_MiZEA7RYB3o_UO{CL} z`4T$qJq*th{=a--LJ$twGab&~cKEvCxzs}f`5@Q@BhyF!+F=vt__71{97L%+4=m~D z9hNH{W8PYvFe3@79lyErV~3@*N%(>r?VZKZG6v9RZ*Ra8q*7{>GX|VIe3PpS&ivIS z?^&LeK8z>{n<{)a0r?nEQ~udCf$vVwgS=r^3G-_E+gFv%6EeNwXFF*rvu!upuv%ip*n(QxuB?^&#g&vGP+-HfAYmMg3;dw@dhhE- z7lwbw-s{xtPa_7r)H!eP`Og6gK+u9n01s3Mwe9YxK(>9joB zKdeLc<9)C@<7q0Hep4&BWl`vzmVJm$=HO><-HG59e(!f5if>oVZ3om$S$LU4yFUfB z6l=gYlP)(zSA5i*kFB}`&gj8--?pg!q=9lx+FljysPXB#G^_Z^{Jl=egHLZQq*MH? zz&b1YcLJ@dTns|TBqR4c*JPu(iMM5XZYP`);$PR#kngFaC#sJ^^AU;>)~n*xtyJ8_ zgN8LKgf-rzkuIv|$0MT6L^gz+X{JKj(Z6uh5RYky!n@H76=YN&;B{jqFI3Gn_ns-> zAw9#=76VV-Z^ral&R6F99bBr?r|#!f?Gx%}&eFp}zpivgw~@)XYqp4XMaSU&;ws2# z5J+~KQY~4Mk25G((Th^x1stmt|j!3 zn3?TIU2Z-`Rj)OL3|sh^%W!}nw#+C9n_&)Zl6+=1yy&%BG_v5cbKZ3439PDsAoe%t z#*CG4U{?J7rL!l)Kkw*nibUKm4yda4545WJw0(U_=79*PN46{W?3mDv0TTSwoF_Nt zxRx}mPAdSeBB}1~A4rySZO}MX9%TrnO5;^xeO)D}(L=2q4Yweb`9fnuR;$x_5sY@j zQ)X19O2);=MaLPRSBv3At~M_k2GX}KCVLjO<;}!oDr>#$;OwC8y!F>#zxagnd-|N? zAq#GNxhg*6bn)yDpWIWv)H`bKr1t~5&qp+|tUHoU6EOS^ED7D5XUbBvC3Mj+M}tgT zIwMoSCx+alb2+#uJ*T1aw1|J8o1<8s#a*iNu93(r(8azoEr2oKdCal2S^{+ zTjmlfAs3;83uWe75d|hW_ttk4Iz?d>S?^XMyU-Hm3i6NdZ>Pv|By@e+xVlL%YZatw zxv~`?29;GsA*Q`gy;~OrXCkO44(Fc9B|6nOThCLl zSSY(_wv|;q->`NBA?wKAmtFaq-^-h;L;dedY4C^ zmx~eaXwoylG@^P*wdfSO(GHh*^!AFk)mQgvag}qE@AG$_A#LnZiP$fp>4cL)>eaZB zz3f^s2H_lRd8}&lS8_0EVqG3FAv`K)pg8B=dI*0I>7~)4RnE)eEs(2iVhj*g*nLt|BIWMV+WdGTc5dgoSZ-=&yzFhx<>^Gg0Jc^bAq5qa103 z5%49dqze)%6&njDY1!!S8WOt+Jy)5FDT5LRsyx@2U;k>v9-#R0PnBC&T{-@-PKF6L zHYJNB9_da$Dz`Z8YyY&>1uU^Schk4p+-19*{PcuV{q)VVWf9CjS8hGQ#3yjSUaih~ zPXm;N{pX|vE6;pV$Q#wHAdEl)*QAYJM!`FqBEtB{Z|(hxJ9)cCX(!T9V?^ zzEn}CS#JvN`#q>Zb-wFCHif3val~CudYtpe5kGOXqVk6dCBr;EoovJo451$!=twn> zXd{cvSW7VRipLzyq;j@z^jYFNp^{yZb*Z$*59v?*Q%a~%LvUMD!sJLU#f!~Q@tj+*kO;6TGBYT4MnWKI}*+*BwowPYUChPr0f(W zt0t@D9%<;QB%)~4z|fxNME$+(E*~`c16|rq_5YS_CE8#;aL-ldNbVrOlWyY25n$?}ZY972532(Q(wWr;q zTIKb&^VZeLz(4?;{Q^uMMtBTEx5o2!wX%Z3#lM&yK0VZlC|xLfxL1ED7sX3pV@^m4|G4^YcZtKcK?CN`73|acryP!g9=M+|zHN!Nn_81g1t$JtN3sMo3 z#zwhvetY_A!`fH}yQTqw>V<2m)?Y^K|~ggp&d6t}(CC;y`wqLm_OjV06%O*r;&) zUmZ|inMv^#-r`bi>YBfU%rFV#cI=}Mny%SG7U;xIvI{7q&z{Y=(uR}89HrH13qnZG zCs||;FKjS~+ur7iNpXP;F{S3@_RS6qhpd6cwnxmQ_!@;Rn9 zmX}o(t?$mdmp_RVV%r9z4B>Nq9Cc&s&quQ%sF0!eTiCYH zr;29YNrH)U*&t_T{;R)1g!Wk8$nyRjE7^=80-Rr10EFqZ+=YvJ;C+2Q>M%tXfzV27 zDW*`RRDqq1uq(94E2%4-;9~25XFjg7Z@8QI(WzLX>qso6XWr9e{AmJgG#KgXn-c2a{0K2~%i1*M zX>4qL|5wS$8i(TOnQecEr|67$`HiQacT&cilPcG0ND3PFWk@?%ODhnsUhm3B!5Ks4 z1pHZ(cy4Knl8jBJ~ZoImFYoiuGR?%I}%~henp-PZbe_Kh1MZ!$Rs5> zCy>`EPg9Rcm1UN5HH3w>y6pS1<^I_N*VXXw)PGVO?=~^7acaikUy4(<6SyK0!E^di zEBiOaF+tnTgI@YgfaJ4QyY&(2H4oDG-qeEK3856#68)`%=M&NL4TV?nSZWY6rjr zU7nKWU0Vis?W#BSj3Q*zKSyW#+!j~{U)mf4n2}}qd$T&sj@gbsdfRe%b^nG)RUq@H z{i9k+QoP{OTt?DNXx9b>{wo(0-)RL(BpXqY08a<8BB7bW+XjKf^SyQa(om|#XkN`V zae+#mGfI^H#^6%zMr-=!XtV<@RHtH(QIh|j7+9r`q~@Yp3=idRiowrR=k9Y#ikE)@!e6@(oy!n)bSFp55QYUVS~$r*D4|d-0zeEUfQBVOI=MgK3nGUfx;k z2?ObapK0T1%?eE69z=*cga3%V$)@}?VNF{_F1Z8F3HxOE+d)B7x$7014&cb<>Ac+& zvG+z9??ATLwdQ$&$Bd9zru25pJo?eCNE~$9sE|olFd#)@gTErU!y=;h3ZjxYI4~rA z&~{P!ad+QveeiPO*MnJtv}=pskkz2MaYu^j3%^cRYrU&8BlG!>dMzt{3(_^<1jUtg zUycgdoX_93{z2JWhUfWE9gX0v7yKXBI;$v%8&22cD%>OykBXfosBH^hCU2y|lG5li z$=m4V&j*A#+BWm^q6j$K+1wl{9Nfliq!HsW)ydAby?gN$l}#XxLe%|uiO9e#cLwv%q8tHwzN?1u=F(YQQ>GZFygKdnBAzJUX$D1zi`%<}j7dCHg z(%H%88)v~v?P4bEbH*jeh2zt?;6WD{cy4Z0d_RTh5lhQ^kI~LGNgxh)zJ682yi=NDgZpDccfJmN-73-wOGy3uRUA`qGT){-M zs8b_TUsdQ!-Q})#Gk50dKn4l2p}K9$1nd6{VAi2{c;~6|=nQs<|Ck4%)4dlw8PwJxVzeAI5cDftMNqyvmhbQjRmnZ{WoKSn0j z5aLZ3kVU3WVv=diOFk*uH}yN3PDUmYhyo({2J24=>P2@xhqYQP?n=$6es9N7Tq(~i zSIf!RLe3!ijsdLr?#uqquSPBC+LiOhT-@j_hOn}=gLfrUwG3b7w7W0NqJ4f zRn=*cMVo#T)iaSv6MzQ7y6L zpJN!{>SNF_;+OK&0V9Kn^e zf#b1Kh<0?Fvxwio^{jt5Tt+j(sKZX7*EqZHvglXo>f6uewyDx)fvA~0(w>VJqOD{<4i$%hd~86zvVtfBA0SZxw^a9*n>W8%Y> z>A{g~#_-aECHEuPvzl%1og)4Xe4Gr<|E~EAdrnEI)_*9){IKPkJK=_l;LqbXyR|E+ z!3efw&5VD?5+LnZyK~YCxv@sKWqupKrD-{?`wd?IY5bNt^oC}%>Lr%c*~8w<7XQfg z1Dgyhfa|hpFPJ5NI2pe+Uqd85u-CW7x z`Qg_MUz|)sA(OA-+Lo}nj@8xOZ&bXV9i!6jc6Ib$3gkH^br#ig;1^y~9$%lzxU6%$ zU)lan>eQi(oh3rTQF7QhN33HUV`N=$#ju>p{27dm_HmK=?<2}j*Am*$ z1xbyTdp1EMXk+*t;Q;piNC?9ILI|qD( z0xS-&Bfu5`D+KHfV0QrfejWA*2L4w8>~Fws1C|chbHG>u<2*T*0oM@%hCMm~Yxi(L zAbva$r~w}YswV(}&_uwSkbpqMWFSx|IS3>{0X!41BtTEhrvia?s6ik<8W3oc7FYv= zKvMJ|kkvU5D1-rcPe8w-03Cwxj(-pE0N{t6IzEpAo`iF9J_Rh}0_UfIqbCyxbn0Xs zcmdGqlXKvuKvXz*Am9O@A>bO?lXdJpbig|Bbs%EEz$e%E0oRk literal 0 HcmV?d00001 diff --git a/extra/images/test-images/rgb4bit.bmp b/extra/images/test-images/rgb4bit.bmp new file mode 100644 index 0000000000000000000000000000000000000000..0c6f00d06c025f6947899450afd91ace50e5b57a GIT binary patch literal 5318 zcmeH~J&xNj5QP;WN5~=4`v3&C50FFT3~?!6!4ht%;Vp6o}HvQbsetmbdm>Jba9`$>-CBW z&sXO?^>E{lhR9!(7a2zZE6-lcLCee=>GUfm*FpgFiOoJB;bmNH8kGz;lh9PADMtQ8LMIPr= zXg4}Uqs}^pqnuRP#EkO(krh!9^0kd57)N6zE6X#g6{4#dWUvKPGk8B|T2&OMaBU`Hog@}yCzSE?j_kY5ozzDdN&9^7!Rfd<~Nxb9m1`KP%+#GM8WL1Ugcx?c$r6yKiRhNYa{z z;u{%M*33`}Dz9KU-R}OvRzR|Q%B3OG4yLF=zP3^Z8GkYP&uMXERL-1k{?e{>`2>{r zXBYFNxa@j74)(^93d{zP*LoAcfxoXDV-do2s*vMm{E9N{zTBqwN zG1#7Iu*qn1FvMHgqeHitXfRDk6byN03)|m^F=c{JojpwQf{_*}O{7SdJ+KHc+c-;MVPqYwvxXF0!fj`A0o{+JNRhIw zhhH771rGBRM=g4>Jhcy1TLtv8%G#IcT;J`yria!-J7_cDVz(Y_*u}!5Rek=$$@DOrpS`!Ue5OClje^DA@<`&||frp?(E6`xTf`9`LAs?I3L<1HC9C!%%NUbIsupr>TL&(RC ziHHFU0uDTc{3tk0G+;r%frpSE6R(K|EC@L85Yi(gK@$yF5OCljC{O-gX)s_xz(M?k z{Ag)SG+;r%frpSEJEMsPEC@L85b`5wHPL_t0S6vJeq2Qp4OkFx;34Ek*=eEy3jz*2 zg#4I$O*CLZz^O0)4(h@>K~Je6{i$JyE#MP}Vt@5|TU~K{LG*Zv&s(|Tp58ji=Xs3z zCiTzo=xei<$Jcs|`@9#**2gO4Fny21H}C#hM=`7ITa8IC&NjW&%%^qhzG3Ke7hR$h zN~6q`M;tGcJc}c@0^70Y4#30y8Q|C zy=ie2&f=5B?4>m=p0~DnB;o066nSzUQ8jurS&T*-LZ8RIQYE4Lhq~g^c`RD22rW$G zQD3}kFU19!#i=fjrPtM>%JSsPW4S)nxASVfMehojBC)ci#672{$)) zs$Hj9bg7W4#wwlZQM60kU+L95s&s9v-m-T=RX*>z!h)x^UVC@AX?;y2t?ql91U4+1 zsm{6^1U4)=MRex-@|YE5q5G=ULUHC(=eNn)j*wzjr;>#IgV2AB2{8lx*Di6(ITJ5Hjk=w)u;ol zc4_0W;Z>6IXntf@l2-#oKgP8L%G&;Cd?k4`Q108|(c}>CT9j<%Q+rz;m-?p70=qmm zS)?R7*{*Z7@BIT~nX+vAy-e&}={sHs#|9e{ZsoQzy_pqb@<)vosqQn-@u4Rc98fFWRvas2os*BV7p%Oa#Sl zm0wg9X~oi~(tiDpOUI4()as$RbaKH{Iim_kTLlwAaSO_?s4ARd(Nk%9k-8Jrog+rZqi6H)kO8H6v z7zWA=Q}+QcKE&?EuerLmjmj}qIM!2QlF(Ag01M*NpQ+^F=*1D( zGX+S2<&aOZgo%{{lpw@I5UM;2+8cwDPO!BjKG*2}oYay(3yWxMk#GxLf>j9_d<2%D zahS5&qQukQh@5nYen)zv2oI}=APGm8-Lq3dNTXU6j!J|HG6HgwWh*s`d*^o{XPltl z%X7HV@6vOmQL07u&PAkkK+gu`uh*jimWi`)^i4QORcu>D!zv+&a)$)rp$s`6eu823 zyo%3yB(yDpty5DuvKnC7H7_!S)@3FHN>$vtop%Y(jvK!NU9A#!$`7eRyEwchIvVO3 zSq-oxTDYu`h0~=a1eM!w*vYXVoydgw;fEOZ(5+$#HV)lJ!Q|A$O0(b~C|2q6g;3!X z%Uwfzc6{{jm3k)MiLG^;v;-SZ)bf)2STzd{0`Jp8M51p_Xk`VTD4MwKPw9U4_|PGC z4T)bY-BnqFjf?&{Ek8BQf`cIU^jQ(=o1|LiE!007ICU$9Kln6m&uMhMH_8bIhX&LUQ!XaTr0uBN)nO^3nrdeJjWYhzae4is5R)Om7C}NDO3|^BRlgL|Ztl8QA8<&Y+2V&?t@V5LA=m8l?v-4vb-QkV zyFTn*={(oHTKDRV39Nf{##9gW{K(%cnSflab-NC|35T0~@YOne7R&Is39Nf{+$@*V z-xFB(>hD>s=(q{Uz52+j^;rMy{kThTj?+ipD;dSQTIbw{qg>a$I%<;3=Z8#S{bc=+ zgS^=`*1fvff&83y*46qsXL+Zcy!~Fiy@5NO#?R^Hy~irm-`l{?Imp6JblUb?5Y1EG zc(S_3`POfv#9^J(QPDr4Ns1ni5P_D7IWcuP>K~fSfp085*Kn@FAF@H1AP8GR7J;ROV3E+(S|5qQM?i$Lm+z`u z+1DYx?KdF@T4E!F(^6<2fmQ<{gq#p0tzBBajVEtP%~j01kw`zgwqnVFi`S@BykHTe6`l zsnSh_h8DE3ce7a=dnO@5)|c>PnfvG2#C9}wSs~k4aaOI~6c4i@XiHDTEl*cGMJsh%9L0UsBev*toY=NH@wLc=mYxr!$Sl&tw$4Nk z6TvlAs4*$pt(y?SR0vYtiDhmp*_>c260@i!l{G|cIh*_M`JicF$&@;3xu?WVt;iFH zBqe+IS&v*ZBB_hgTj4-K*7j7Me8bJs)~x5&>!D&u{u4{v(x`mDHgOnACFIdfd4An| zyZlV0H)`+t9{j`vp{_zs3*4_w9EMT}xz&6fubXd|-z&e1JM-@Ibo^-PRp&(#!{4)VH+)u;CMsff#Bxul_DNLuxQung6a>maU0v-TDavT@wD6u zZ7j8DnN)vcYBRG%8w!RgaEgJL=u7+%w46h#Tf;DZd~II>eTfDF;kwMT!s!x1TN2vF zrVU$#hVbocTwPVjR4`0+4T%6N31El-WX;kS*;9junU#&Ts7KIDk{aTGYy&dK5`iV} ziMOx6@g?X!o}+Rv^i1I>s1kg=wt}c!nXvUjO#!zmfF}hHGf#>2MJ<~JC_xLioH~tE zUg#V1k~w7i+P(z(CO#l5N0$Uj$|II<3BuG@2}560Nld^&10YjssC0$=_!=z8KoB6M zK?^6EEbC0tP7BGWyWGBSUzUVe2TJLZK;e5tO@JdH+}7&GVq)KrpA@20DBlAAsluFn;VN55{RV)h&>IRfK%i{mnzLXT)xaHJ4GsEEfwpg@?T5^~UGQjt=$4BgHEAMR>t6~gPKuNT&P6DH;?0llG* zr;)vZXo$e|-O$k`jVUKhxT2VZGID$G+-Sa;Ee!-G*w19HwjK zyC`NK-v>_1qKVR`wbR0Sd)xPI)`g$TeD9X!O!bukO0egdmQM@o-ERA~Rxh-eb^>~` zJI|Novb3))M==R0d&qKI_v(;24w~o%7!-ZGHueh5xs6sI;;(x(G_G5b>ifds ; + +TUPLE: ifd count ifd-entries next +processed-tags strips buffer ; +CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; + +TUPLE: ifd-entry tag type count offset/value ; +CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; + +SINGLETONS: photometric-interpretation +photometric-interpretation-white-is-zero +photometric-interpretation-black-is-zero +photometric-interpretation-rgb +photometric-interpretation-palette-color ; +ERROR: bad-photometric-interpretation n ; +: lookup-photometric-interpretation ( n -- singleton ) + { + { 0 [ photometric-interpretation-white-is-zero ] } + { 1 [ photometric-interpretation-black-is-zero ] } + { 2 [ photometric-interpretation-rgb ] } + { 3 [ photometric-interpretation-palette-color ] } + [ bad-photometric-interpretation ] + } case ; + +SINGLETONS: compression +compression-none +compression-CCITT-2 +compression-lzw +compression-pack-bits ; +ERROR: bad-compression n ; +: lookup-compression ( n -- compression ) + { + { 1 [ compression-none ] } + { 2 [ compression-CCITT-2 ] } + { 5 [ compression-lzw ] } + { 32773 [ compression-pack-bits ] } + [ bad-compression ] + } case ; + +SINGLETONS: resolution-unit +resolution-unit-none +resolution-unit-inch +resolution-unit-centimeter ; +ERROR: bad-resolution-unit n ; +: lookup-resolution-unit ( n -- object ) + { + { 1 [ resolution-unit-none ] } + { 2 [ resolution-unit-inch ] } + { 3 [ resolution-unit-centimeter ] } + [ bad-resolution-unit ] + } case ; + +SINGLETONS: predictor +predictor-none +predictor-horizontal-differencing ; +ERROR: bad-predictor n ; +: lookup-predictor ( n -- object ) + { + { 1 [ predictor-none ] } + { 2 [ predictor-horizontal-differencing ] } + [ bad-predictor ] + } case ; + +SINGLETONS: planar-configuration +planar-configuration-chunky +planar-configuration-planar ; +ERROR: bad-planar-configuration n ; +: lookup-planar-configuration ( n -- object ) + { + { 1 [ planar-configuration-chunky ] } + { 2 [ planar-configuration-planar ] } + [ bad-planar-configuration ] + } case ; + +SINGLETONS: sample-format +sample-format-unsigned-integer +sample-format-signed-integer +sample-format-ieee-float +sample-format-undefined-data ; +ERROR: bad-sample-format n ; +: lookup-sample-format ( sequence -- object ) + [ + { + { 1 [ sample-format-unsigned-integer ] } + { 2 [ sample-format-signed-integer ] } + { 3 [ sample-format-ieee-float ] } + { 4 [ sample-format-undefined-data ] } + [ bad-sample-format ] + } case + ] map ; + +SINGLETONS: extra-samples +extra-samples-unspecified-alpha-data +extra-samples-associated-alpha-data +extra-samples-unassociated-alpha-data ; +ERROR: bad-extra-samples n ; +: lookup-extra-samples ( sequence -- object ) + { + { 0 [ extra-samples-unspecified-alpha-data ] } + { 1 [ extra-samples-associated-alpha-data ] } + { 2 [ extra-samples-unassociated-alpha-data ] } + [ bad-extra-samples ] + } case ; + +SINGLETONS: image-length image-width x-resolution y-resolution +rows-per-strip strip-offsets strip-byte-counts bits-per-sample +samples-per-pixel new-subfile-type orientation +unhandled-ifd-entry ; + +ERROR: bad-tiff-magic bytes ; +: tiff-endianness ( byte-array -- ? ) + { + { B{ CHAR: M CHAR: M } [ big-endian ] } + { B{ CHAR: I CHAR: I } [ little-endian ] } + [ bad-tiff-magic ] + } case ; + +: read-header ( tiff -- tiff ) + 2 read tiff-endianness [ >>endianness ] keep + [ + 2 read endian> >>the-answer + 4 read endian> >>ifd-offset + ] with-endianness ; + +: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; + +: read-ifd ( -- ifd ) + 2 read endian> + 2 read endian> + 4 read endian> + 4 read endian> ; + +: read-ifds ( tiff -- tiff ) + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + +ERROR: no-tag class ; + +: ?at ( key assoc -- value/key ? ) + dupd at* [ nip t ] [ drop f ] if ; inline + +: find-tag ( idf class -- tag ) + swap processed-tags>> ?at [ no-tag ] unless ; + +: read-strips ( ifd -- ifd ) + dup + [ strip-byte-counts find-tag ] + [ strip-offsets find-tag ] bi + 2dup [ integer? ] both? [ + seek-absolute seek-input read 1array + ] [ + [ seek-absolute seek-input read ] { } 2map-as + ] if >>strips ; + +ERROR: unknown-ifd-type n ; + +: bytes>bits ( n/byte-array -- n ) + dup byte-array? [ byte-array>bignum ] when ; + +: value-length ( ifd-entry -- n ) + [ count>> ] [ type>> ] bi { + { 1 [ ] } + { 2 [ ] } + { 3 [ 2 * ] } + { 4 [ 4 * ] } + { 5 [ 8 * ] } + { 6 [ ] } + { 7 [ ] } + { 8 [ 2 * ] } + { 9 [ 4 * ] } + { 10 [ 8 * ] } + { 11 [ 4 * ] } + { 12 [ 8 * ] } + [ unknown-ifd-type ] + } case ; + +ERROR: bad-small-ifd-type n ; + +: adjust-offset/value ( ifd-entry -- obj ) + [ offset/value>> 4 >endian ] [ type>> ] bi + { + { 1 [ 1 head endian> ] } + { 3 [ 2 head endian> ] } + { 4 [ endian> ] } + { 6 [ 1 head endian> 8 >signed ] } + { 8 [ 2 head endian> 16 >signed ] } + { 9 [ endian> 32 >signed ] } + { 11 [ endian> bits>float ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ endian> 32 >signed ] map ] } + { 10 [ 8 group [ "ii" unpack first2 / ] map ] } + { 11 [ 4 group [ "f" unpack ] map ] } + { 12 [ 8 group [ "d" unpack ] map ] } + [ unknown-ifd-type ] + } case ; + +: ifd-entry-value ( ifd-entry -- n ) + dup value-length 4 <= [ + adjust-offset/value + ] [ + [ offset/value>> seek-absolute seek-input ] + [ value-length read ] + [ type>> ] tri offset-bytes>obj + ] if ; + +: process-ifd-entry ( ifd-entry -- value class ) + [ ifd-entry-value ] [ tag>> ] bi { + { 254 [ new-subfile-type ] } + { 256 [ image-width ] } + { 257 [ image-length ] } + { 258 [ bits-per-sample ] } + { 259 [ lookup-compression compression ] } + { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 273 [ strip-offsets ] } + { 274 [ orientation ] } + { 277 [ samples-per-pixel ] } + { 278 [ rows-per-strip ] } + { 279 [ strip-byte-counts ] } + { 282 [ x-resolution ] } + { 283 [ y-resolution ] } + { 284 [ planar-configuration ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 317 [ lookup-predictor predictor ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + [ nip unhandled-ifd-entry ] + } case ; + +: process-ifd ( ifd -- ifd ) + dup ifd-entries>> + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; + +: strips>buffer ( ifd -- ifd ) + dup strips>> concat >>buffer ; + +: ifd>image ( ifd -- image ) + { + [ image-width find-tag ] + [ image-length find-tag ] + [ bits-per-sample find-tag sum ] + [ buffer>> ] + } cleave tiff-image new-image ; + +: parsed-tiff>images ( tiff -- sequence ) + ifds>> [ ifd>image ] map ; + +! tiff files can store several images -- we just take the first for now +M: tiff-image load-image* ( path tiff-image -- image ) + drop binary [ + + read-header dup endianness>> [ + read-ifds + dup ifds>> [ process-ifd read-strips strips>buffer drop ] each + ] with-endianness + ] with-file-reader + parsed-tiff>images first ; diff --git a/extra/images/viewer/authors.txt b/extra/images/viewer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/viewer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor new file mode 100644 index 0000000000..4d5df4874a --- /dev/null +++ b/extra/images/viewer/viewer.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators images.bitmap kernel math +math.functions namespaces opengl opengl.gl ui ui.gadgets +ui.gadgets.panes ui.render images.tiff sequences multiline +images.backend images io.pathnames strings ; +IN: images.viewer + +TUPLE: image-gadget < gadget { image image } ; + +GENERIC: draw-image ( image -- ) + +M: image-gadget pref-dim* + image>> + [ width>> ] [ height>> ] bi + [ abs ] bi@ 2array ; + +M: image-gadget draw-gadget* ( gadget -- ) + origin get [ image>> draw-image ] with-translation ; + +: ( image -- gadget ) + \ image-gadget new-gadget + swap >>image ; + +: bits>gl-params ( n -- gl-bgr gl-format ) + { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case ; + +M: bitmap-image draw-image ( bitmap -- ) + { + [ + height>> dup 0 < [ + drop + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + ] [ + 0 swap abs glRasterPos2i + 1.0 1.0 glPixelZoom + ] if + ] + [ width>> abs ] + [ height>> abs ] + [ depth>> bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; + +: image-window ( path -- gadget ) + [ dup ] [ open-window ] bi ; + +M: tiff-image draw-image ( tiff -- ) + 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom + { + [ height>> ] + [ width>> ] + [ depth>> bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; + +GENERIC: image. ( image -- ) + +M: string image. ( image -- ) gadget. ; + +M: pathname image. ( image -- ) gadget. ; + +M: image image. ( image -- ) gadget. ; From 4ff9557351d5026a84f31ad447dd1f9c4d3595b2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:57:59 -0600 Subject: [PATCH 074/168] remove the grpahics vocab --- extra/graphics/authors.txt | 1 - extra/graphics/bitmap/authors.txt | 1 - extra/graphics/bitmap/bitmap-tests.factor | 30 -- extra/graphics/bitmap/bitmap.factor | 139 --------- extra/graphics/bitmap/test-images/1bit.bmp | Bin 1662 -> 0 bytes extra/graphics/bitmap/test-images/rgb4bit.bmp | Bin 5318 -> 0 bytes extra/graphics/bitmap/test-images/rgb8bit.bmp | Bin 11078 -> 0 bytes .../bitmap/test-images/thiswayup24.bmp | Bin 60054 -> 0 bytes extra/graphics/tags.txt | 1 - extra/graphics/tiff/authors.txt | 1 - extra/graphics/tiff/rgb.tiff | Bin 7916 -> 0 bytes extra/graphics/tiff/tiff-tests.factor | 11 - extra/graphics/tiff/tiff.factor | 271 ------------------ extra/graphics/viewer/authors.txt | 1 - extra/graphics/viewer/viewer.factor | 66 ----- 15 files changed, 522 deletions(-) delete mode 100644 extra/graphics/authors.txt delete mode 100755 extra/graphics/bitmap/authors.txt delete mode 100644 extra/graphics/bitmap/bitmap-tests.factor delete mode 100755 extra/graphics/bitmap/bitmap.factor delete mode 100644 extra/graphics/bitmap/test-images/1bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/rgb4bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/rgb8bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/thiswayup24.bmp delete mode 100644 extra/graphics/tags.txt delete mode 100755 extra/graphics/tiff/authors.txt delete mode 100755 extra/graphics/tiff/rgb.tiff delete mode 100755 extra/graphics/tiff/tiff-tests.factor delete mode 100755 extra/graphics/tiff/tiff.factor delete mode 100755 extra/graphics/viewer/authors.txt delete mode 100644 extra/graphics/viewer/viewer.factor diff --git a/extra/graphics/authors.txt b/extra/graphics/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/graphics/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/bitmap/authors.txt b/extra/graphics/bitmap/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/graphics/bitmap/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor deleted file mode 100644 index f8a125e855..0000000000 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -USING: graphics.bitmap graphics.viewer io.encodings.binary -io.files io.files.unique kernel tools.test ; -IN: graphics.bitmap.tests - -: test-bitmap32-alpha ( -- path ) - "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ; - -: test-bitmap24 ( -- path ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ; - -: test-bitmap16 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ; - -: test-bitmap8 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ; - -: test-bitmap4 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ; - -: test-bitmap1 ( -- path ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" ; - -[ t ] -[ - test-bitmap24 - [ binary file-contents ] [ load-bitmap ] bi - - "test-bitmap24" unique-file - [ save-bitmap ] [ binary file-contents ] bi = -] unit-test diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor deleted file mode 100755 index f8008dc7c1..0000000000 --- a/extra/graphics/bitmap/bitmap.factor +++ /dev/null @@ -1,139 +0,0 @@ -! Copyright (C) 2007, 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types arrays byte-arrays columns -combinators fry grouping io io.binary io.encodings.binary -io.files kernel libc macros math math.bitwise math.functions -namespaces opengl opengl.gl prettyprint sequences strings -summary ui ui.gadgets.panes ; -IN: graphics.bitmap - -! Currently can only handle 24/32bit bitmaps. -! Handles row-reversed bitmaps (their height is negative) - -TUPLE: bitmap magic size reserved offset header-length width -height planes bit-count compression size-image -x-pels y-pels color-used color-important rgb-quads color-index -alpha-channel-zero? -array ; - -: array-copy ( bitmap array -- bitmap array' ) - over size-image>> abs memory>byte-array ; - -MACRO: (nbits>bitmap) ( bits -- ) - [ -3 shift ] keep '[ - bitmap new - 2over * _ * >>size-image - swap >>height - swap >>width - swap array-copy [ >>array ] [ >>color-index ] bi - _ >>bit-count - ] ; - -: bgr>bitmap ( array height width -- bitmap ) - 24 (nbits>bitmap) ; - -: bgra>bitmap ( array height width -- bitmap ) - 32 (nbits>bitmap) ; - -: 8bit>array ( bitmap -- array ) - [ rgb-quads>> 4 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; - -ERROR: bmp-not-supported n ; - -: raw-bitmap>array ( bitmap -- array ) - dup bit-count>> - { - { 32 [ color-index>> ] } - { 24 [ color-index>> ] } - { 16 [ bmp-not-supported ] } - { 8 [ 8bit>array ] } - { 4 [ bmp-not-supported ] } - { 2 [ bmp-not-supported ] } - { 1 [ bmp-not-supported ] } - } case >byte-array ; - -ERROR: bitmap-magic ; - -M: bitmap-magic summary - drop "First two bytes of bitmap stream must be 'BM'" ; - -: read2 ( -- n ) 2 read le> ; -: read4 ( -- n ) 4 read le> ; - -: parse-file-header ( bitmap -- bitmap ) - 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic - read4 >>size - read4 >>reserved - read4 >>offset ; - -: parse-bitmap-header ( bitmap -- bitmap ) - read4 >>header-length - read4 >>width - read4 >>height - read2 >>planes - read2 >>bit-count - read4 >>compression - read4 >>size-image - read4 >>x-pels - read4 >>y-pels - read4 >>color-used - read4 >>color-important ; - -: rgb-quads-length ( bitmap -- n ) - [ offset>> 14 - ] [ header-length>> ] bi - ; - -: color-index-length ( bitmap -- n ) - { - [ width>> ] - [ planes>> * ] - [ bit-count>> * 31 + 32 /i 4 * ] - [ height>> abs * ] - } cleave ; - -: parse-bitmap ( bitmap -- bitmap ) - dup rgb-quads-length read >>rgb-quads - dup color-index-length read >>color-index ; - -: (load-bitmap) ( path -- bitmap ) - binary [ - bitmap new - parse-file-header parse-bitmap-header parse-bitmap - ] with-file-reader ; - -: alpha-channel-zero? ( bitmap -- ? ) - array>> 4 3 [ 0 = ] all? ; - -: load-bitmap ( path -- bitmap ) - (load-bitmap) - dup raw-bitmap>array >>array - dup alpha-channel-zero? >>alpha-channel-zero? ; - -: write2 ( n -- ) 2 >le write ; -: write4 ( n -- ) 4 >le write ; - -: save-bitmap ( bitmap path -- ) - binary [ - B{ CHAR: B CHAR: M } write - [ - array>> length 14 + 40 + write4 - 0 write4 - 54 write4 - 40 write4 - ] [ - { - [ width>> write4 ] - [ height>> write4 ] - [ planes>> 1 or write2 ] - [ bit-count>> 24 or write2 ] - [ compression>> 0 or write4 ] - [ size-image>> write4 ] - [ x-pels>> 0 or write4 ] - [ y-pels>> 0 or write4 ] - [ color-used>> 0 or write4 ] - [ color-important>> 0 or write4 ] - [ rgb-quads>> write ] - [ color-index>> write ] - } cleave - ] bi - ] with-file-writer ; diff --git a/extra/graphics/bitmap/test-images/1bit.bmp b/extra/graphics/bitmap/test-images/1bit.bmp deleted file mode 100644 index 2f244c1d058bfd63c99009e24e43db3d2af59902..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1662 zcmd6mu}&N@5QY~a(QcXY+PnZo8WyGJ9a2QJkP4yX)=xlQ0r3D)UI5Obx(-^kP>P00mA^ zwBUF^jlQ?E;2?IzW6rM6HrH!wQhyj)b6UoD@XeYt9ody`K1_Mt%?}f{KVbJy%jcAj zt>KGpdF1)G8#sXx#Xjmy4aWdZ=sgF-W=L!giOF7nXWqQfqxQZB=n3}M&%h;db954z z5E@tMx~mVf%2{3&6~$+BXh5o3M#kinNOWWu>rFlx|3%95W4uyouK-4#SClXoB~%*C^4(}0onQG*9L-9b-!uM&JH<>m6OjuQDiV1l8blvI&dpWsH&fqeed;%iU%z`!sV;|oL`;1cM@txn1q zeNvtP$iOI5M`t`8&@TI<PT&zE=wk>n#+W#})qlnu6j zqKlaxW~`Q2))-G*FH&~!a+~whBxMUv@;vdku#nh6UAzYFMb4TYyweT-0k9zwR(&q} gI+mcb*Vx}V%YV4a?71qPKl;*mGj7Ahc<-2B0n`=D`~Uy| diff --git a/extra/graphics/bitmap/test-images/rgb4bit.bmp b/extra/graphics/bitmap/test-images/rgb4bit.bmp deleted file mode 100644 index 0c6f00d06c025f6947899450afd91ace50e5b57a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5318 zcmeH~J&xNj5QP;WN5~=4`v3&C50FFT3~?!6!4ht%;Vp6o}HvQbsetmbdm>Jba9`$>-CBW z&sXO?^>E{lhR9!(7a2zZE6-lcLCee=>GUfm*FpgFiOoJB;bmNH8kGz;lh9PADMtQ8LMIPr= zXg4}Uqs}^pqnuRP#EkO(krh!9^0kd57)N6zE6X#g6{4#dWUvKPGk8B|T2&OMaBU`Hog@}yCzSE?j_kY5ozzDdN&9^7!Rfd<~Nxb9m1`KP%+#GM8WL1Ugcx?c$r6yKiRhNYa{z z;u{%M*33`}Dz9KU-R}OvRzR|Q%B3OG4yLF=zP3^Z8GkYP&uMXERL-1k{?e{>`2>{r zXBYFNxa@j74)(^93d{zP*LoAcfxoXDV-do2s*vMm{E9N{zTBqwN zG1#7Iu*qn1FvMHgqeHitXfRDk6byN03)|m^F=c{JojpwQf{_*}O{7SdJ+KHc+c-;MVPqYwvxXF0!fj`A0o{+JNRhIw zhhH771rGBRM=g4>Jhcy1TLtv8%G#IcT;J`yria!-J7_cDVz(Y_*u}!5Rek=$$@DOrpS`!Ue5OClje^DA@<`&||frp?(E6`xTf`9`LAs?I3L<1HC9C!%%NUbIsupr>TL&(RC ziHHFU0uDTc{3tk0G+;r%frpSE6R(K|EC@L85Yi(gK@$yF5OCljC{O-gX)s_xz(M?k z{Ag)SG+;r%frpSEJEMsPEC@L85b`5wHPL_t0S6vJeq2Qp4OkFx;34Ek*=eEy3jz*2 zg#4I$O*CLZz^O0)4(h@>K~Je6{i$JyE#MP}Vt@5|TU~K{LG*Zv&s(|Tp58ji=Xs3z zCiTzo=xei<$Jcs|`@9#**2gO4Fny21H}C#hM=`7ITa8IC&NjW&%%^qhzG3Ke7hR$h zN~6q`M;tGcJc}c@0^70Y4#30y8Q|C zy=ie2&f=5B?4>m=p0~DnB;o066nSzUQ8jurS&T*-LZ8RIQYE4Lhq~g^c`RD22rW$G zQD3}kFU19!#i=fjrPtM>%JSsPW4S)nxASVfMehojBC)ci#672{$)) zs$Hj9bg7W4#wwlZQM60kU+L95s&s9v-m-T=RX*>z!h)x^UVC@AX?;y2t?ql91U4+1 zsm{6^1U4)=MRex-@|YE5q5G=ULUHC(=eNn)j*wzjr;>#IgV2AB2{8lx*Di6(ITJ5Hjk=w)u;ol zc4_0W;Z>6IXntf@l2-#oKgP8L%G&;Cd?k4`Q108|(c}>CT9j<%Q+rz;m-?p70=qmm zS)?R7*{*Z7@BIT~nX+vAy-e&}={sHs#|9e{ZsoQzy_pqb@<)vosqQn-@u4Rc98fFWRvas2os*BV7p%Oa#Sl zm0wg9X~oi~(tiDpOUI4()as$RbaKH{Iim_kTLlwAaSO_?s4ARd(Nk%9k-8Jrog+rZqi6H)kO8H6v z7zWA=Q}+QcKE&?EuerLmjmj}qIM!2QlF(Ag01M*NpQ+^F=*1D( zGX+S2<&aOZgo%{{lpw@I5UM;2+8cwDPO!BjKG*2}oYay(3yWxMk#GxLf>j9_d<2%D zahS5&qQukQh@5nYen)zv2oI}=APGm8-Lq3dNTXU6j!J|HG6HgwWh*s`d*^o{XPltl z%X7HV@6vOmQL07u&PAkkK+gu`uh*jimWi`)^i4QORcu>D!zv+&a)$)rp$s`6eu823 zyo%3yB(yDpty5DuvKnC7H7_!S)@3FHN>$vtop%Y(jvK!NU9A#!$`7eRyEwchIvVO3 zSq-oxTDYu`h0~=a1eM!w*vYXVoydgw;fEOZ(5+$#HV)lJ!Q|A$O0(b~C|2q6g;3!X z%Uwfzc6{{jm3k)MiLG^;v;-SZ)bf)2STzd{0`Jp8M51p_Xk`VTD4MwKPw9U4_|PGC z4T)bY-BnqFjf?&{Ek8BQf`cIU^jQ(=o1|LiE!007ICU$9Kln6m&uMhMH_8bIhX&LUQ!XaTr0uBN)nO^3nrdeJjWYhzae4is5R)Om7C}NDO3|^BRlgL|Ztl8QA8<&Y+2V&?t@V5LA=m8l?v-4vb-QkV zyFTn*={(oHTKDRV39Nf{##9gW{K(%cnSflab-NC|35T0~@YOne7R&Is39Nf{+$@*V z-xFB(>hD>s=(q{Uz52+j^;rMy{kThTj?+ipD;dSQTIbw{qg>a$I%<;3=Z8#S{bc=+ zgS^=`*1fvff&83y*46qsXL+Zcy!~Fiy@5NO#?R^Hy~irm-`l{?Imp6JblUb?5Y1EG zc(S_3`POfv#9^J(QPDr4Ns1ni5P_D7IWcuP>K~fSfp085*Kn@FAF@H1AP8GR7J;ROV3E+(S|5qQM?i$Lm+z`u z+1DYx?KdF@T4E!F(^6<2fmQ<{gq#p0tzBBajVEtP%~j01kw`zgwqnVFi`S@BykHTe6`l zsnSh_h8DE3ce7a=dnO@5)|c>PnfvG2#C9}wSs~k4aaOI~6c4i@XiHDTEl*cGMJsh%9L0UsBev*toY=NH@wLc=mYxr!$Sl&tw$4Nk z6TvlAs4*$pt(y?SR0vYtiDhmp*_>c260@i!l{G|cIh*_M`JicF$&@;3xu?WVt;iFH zBqe+IS&v*ZBB_hgTj4-K*7j7Me8bJs)~x5&>!D&u{u4{v(x`mDHgOnACFIdfd4An| zyZlV0H)`+t9{j`vp{_zs3*4_w9EMT}xz&6fubXd|-z&e1JM-@Ibo^-PRp&(#!{4)VH+)u;CMsff#Bxul_DNLuxQung6a>maU0v-TDavT@wD6u zZ7j8DnN)vcYBRG%8w!RgaEgJL=u7+%w46h#Tf;DZd~II>eTfDF;kwMT!s!x1TN2vF zrVU$#hVbocTwPVjR4`0+4T%6N31El-WX;kS*;9junU#&Ts7KIDk{aTGYy&dK5`iV} ziMOx6@g?X!o}+Rv^i1I>s1kg=wt}c!nXvUjO#!zmfF}hHGf#>2MJ<~JC_xLioH~tE zUg#V1k~w7i+P(z(CO#l5N0$Uj$|II<3BuG@2}560Nld^&10YjssC0$=_!=z8KoB6M zK?^6EEbC0tP7BGWyWGBSUzUVe2TJLZK;e5tO@JdH+}7&GVq)KrpA@20DBlAAsluFn;VN55{RV)h&>IRfK%i{mnzLXT)xaHJ4GsEEfwpg@?T5^~UGQjt=$4BgHEAMR>t6~gPKuNT&P6DH;?0llG* zr;)vZXo$e|-O$k`jVUKhxT2VZGID$G+-Sa;Ee!-G*w19HwjK zyC`NK-v>_1qKVR`wbR0Sd)xPI)`g$TeD9X!O!bukO0egdmQM@o-ERA~Rxh-eb^>~` zJI|Novb3))M==R0d&qKI_v(;24w~o%7!-ZGHueh5xs6sI;;(x(G_G5b4#XP|nBx#_MiZEA7RYB3o_UO{CL} z`4T$qJq*th{=a--LJ$twGab&~cKEvCxzs}f`5@Q@BhyF!+F=vt__71{97L%+4=m~D z9hNH{W8PYvFe3@79lyErV~3@*N%(>r?VZKZG6v9RZ*Ra8q*7{>GX|VIe3PpS&ivIS z?^&LeK8z>{n<{)a0r?nEQ~udCf$vVwgS=r^3G-_E+gFv%6EeNwXFF*rvu!upuv%ip*n(QxuB?^&#g&vGP+-HfAYmMg3;dw@dhhE- z7lwbw-s{xtPa_7r)H!eP`Og6gK+u9n01s3Mwe9YxK(>9joB zKdeLc<9)C@<7q0Hep4&BWl`vzmVJm$=HO><-HG59e(!f5if>oVZ3om$S$LU4yFUfB z6l=gYlP)(zSA5i*kFB}`&gj8--?pg!q=9lx+FljysPXB#G^_Z^{Jl=egHLZQq*MH? zz&b1YcLJ@dTns|TBqR4c*JPu(iMM5XZYP`);$PR#kngFaC#sJ^^AU;>)~n*xtyJ8_ zgN8LKgf-rzkuIv|$0MT6L^gz+X{JKj(Z6uh5RYky!n@H76=YN&;B{jqFI3Gn_ns-> zAw9#=76VV-Z^ral&R6F99bBr?r|#!f?Gx%}&eFp}zpivgw~@)XYqp4XMaSU&;ws2# z5J+~KQY~4Mk25G((Th^x1stmt|j!3 zn3?TIU2Z-`Rj)OL3|sh^%W!}nw#+C9n_&)Zl6+=1yy&%BG_v5cbKZ3439PDsAoe%t z#*CG4U{?J7rL!l)Kkw*nibUKm4yda4545WJw0(U_=79*PN46{W?3mDv0TTSwoF_Nt zxRx}mPAdSeBB}1~A4rySZO}MX9%TrnO5;^xeO)D}(L=2q4Yweb`9fnuR;$x_5sY@j zQ)X19O2);=MaLPRSBv3At~M_k2GX}KCVLjO<;}!oDr>#$;OwC8y!F>#zxagnd-|N? zAq#GNxhg*6bn)yDpWIWv)H`bKr1t~5&qp+|tUHoU6EOS^ED7D5XUbBvC3Mj+M}tgT zIwMoSCx+alb2+#uJ*T1aw1|J8o1<8s#a*iNu93(r(8azoEr2oKdCal2S^{+ zTjmlfAs3;83uWe75d|hW_ttk4Iz?d>S?^XMyU-Hm3i6NdZ>Pv|By@e+xVlL%YZatw zxv~`?29;GsA*Q`gy;~OrXCkO44(Fc9B|6nOThCLl zSSY(_wv|;q->`NBA?wKAmtFaq-^-h;L;dedY4C^ zmx~eaXwoylG@^P*wdfSO(GHh*^!AFk)mQgvag}qE@AG$_A#LnZiP$fp>4cL)>eaZB zz3f^s2H_lRd8}&lS8_0EVqG3FAv`K)pg8B=dI*0I>7~)4RnE)eEs(2iVhj*g*nLt|BIWMV+WdGTc5dgoSZ-=&yzFhx<>^Gg0Jc^bAq5qa103 z5%49dqze)%6&njDY1!!S8WOt+Jy)5FDT5LRsyx@2U;k>v9-#R0PnBC&T{-@-PKF6L zHYJNB9_da$Dz`Z8YyY&>1uU^Schk4p+-19*{PcuV{q)VVWf9CjS8hGQ#3yjSUaih~ zPXm;N{pX|vE6;pV$Q#wHAdEl)*QAYJM!`FqBEtB{Z|(hxJ9)cCX(!T9V?^ zzEn}CS#JvN`#q>Zb-wFCHif3val~CudYtpe5kGOXqVk6dCBr;EoovJo451$!=twn> zXd{cvSW7VRipLzyq;j@z^jYFNp^{yZb*Z$*59v?*Q%a~%LvUMD!sJLU#f!~Q@tj+*kO;6TGBYT4MnWKI}*+*BwowPYUChPr0f(W zt0t@D9%<;QB%)~4z|fxNME$+(E*~`c16|rq_5YS_CE8#;aL-ldNbVrOlWyY25n$?}ZY972532(Q(wWr;q zTIKb&^VZeLz(4?;{Q^uMMtBTEx5o2!wX%Z3#lM&yK0VZlC|xLfxL1ED7sX3pV@^m4|G4^YcZtKcK?CN`73|acryP!g9=M+|zHN!Nn_81g1t$JtN3sMo3 z#zwhvetY_A!`fH}yQTqw>V<2m)?Y^K|~ggp&d6t}(CC;y`wqLm_OjV06%O*r;&) zUmZ|inMv^#-r`bi>YBfU%rFV#cI=}Mny%SG7U;xIvI{7q&z{Y=(uR}89HrH13qnZG zCs||;FKjS~+ur7iNpXP;F{S3@_RS6qhpd6cwnxmQ_!@;Rn9 zmX}o(t?$mdmp_RVV%r9z4B>Nq9Cc&s&quQ%sF0!eTiCYH zr;29YNrH)U*&t_T{;R)1g!Wk8$nyRjE7^=80-Rr10EFqZ+=YvJ;C+2Q>M%tXfzV27 zDW*`RRDqq1uq(94E2%4-;9~25XFjg7Z@8QI(WzLX>qso6XWr9e{AmJgG#KgXn-c2a{0K2~%i1*M zX>4qL|5wS$8i(TOnQecEr|67$`HiQacT&cilPcG0ND3PFWk@?%ODhnsUhm3B!5Ks4 z1pHZ(cy4Knl8jBJ~ZoImFYoiuGR?%I}%~henp-PZbe_Kh1MZ!$Rs5> zCy>`EPg9Rcm1UN5HH3w>y6pS1<^I_N*VXXw)PGVO?=~^7acaikUy4(<6SyK0!E^di zEBiOaF+tnTgI@YgfaJ4QyY&(2H4oDG-qeEK3856#68)`%=M&NL4TV?nSZWY6rjr zU7nKWU0Vis?W#BSj3Q*zKSyW#+!j~{U)mf4n2}}qd$T&sj@gbsdfRe%b^nG)RUq@H z{i9k+QoP{OTt?DNXx9b>{wo(0-)RL(BpXqY08a<8BB7bW+XjKf^SyQa(om|#XkN`V zae+#mGfI^H#^6%zMr-=!XtV<@RHtH(QIh|j7+9r`q~@Yp3=idRiowrR=k9Y#ikE)@!e6@(oy!n)bSFp55QYUVS~$r*D4|d-0zeEUfQBVOI=MgK3nGUfx;k z2?ObapK0T1%?eE69z=*cga3%V$)@}?VNF{_F1Z8F3HxOE+d)B7x$7014&cb<>Ac+& zvG+z9??ATLwdQ$&$Bd9zru25pJo?eCNE~$9sE|olFd#)@gTErU!y=;h3ZjxYI4~rA z&~{P!ad+QveeiPO*MnJtv}=pskkz2MaYu^j3%^cRYrU&8BlG!>dMzt{3(_^<1jUtg zUycgdoX_93{z2JWhUfWE9gX0v7yKXBI;$v%8&22cD%>OykBXfosBH^hCU2y|lG5li z$=m4V&j*A#+BWm^q6j$K+1wl{9Nfliq!HsW)ydAby?gN$l}#XxLe%|uiO9e#cLwv%q8tHwzN?1u=F(YQQ>GZFygKdnBAzJUX$D1zi`%<}j7dCHg z(%H%88)v~v?P4bEbH*jeh2zt?;6WD{cy4Z0d_RTh5lhQ^kI~LGNgxh)zJ682yi=NDgZpDccfJmN-73-wOGy3uRUA`qGT){-M zs8b_TUsdQ!-Q})#Gk50dKn4l2p}K9$1nd6{VAi2{c;~6|=nQs<|Ck4%)4dlw8PwJxVzeAI5cDftMNqyvmhbQjRmnZ{WoKSn0j z5aLZ3kVU3WVv=diOFk*uH}yN3PDUmYhyo({2J24=>P2@xhqYQP?n=$6es9N7Tq(~i zSIf!RLe3!ijsdLr?#uqquSPBC+LiOhT-@j_hOn}=gLfrUwG3b7w7W0NqJ4f zRn=*cMVo#T)iaSv6MzQ7y6L zpJN!{>SNF_;+OK&0V9Kn^e zf#b1Kh<0?Fvxwio^{jt5Tt+j(sKZX7*EqZHvglXo>f6uewyDx)fvA~0(w>VJqOD{<4i$%hd~86zvVtfBA0SZxw^a9*n>W8%Y> z>A{g~#_-aECHEuPvzl%1og)4Xe4Gr<|E~EAdrnEI)_*9){IKPkJK=_l;LqbXyR|E+ z!3efw&5VD?5+LnZyK~YCxv@sKWqupKrD-{?`wd?IY5bNt^oC}%>Lr%c*~8w<7XQfg z1Dgyhfa|hpFPJ5NI2pe+Uqd85u-CW7x z`Qg_MUz|)sA(OA-+Lo}nj@8xOZ&bXV9i!6jc6Ib$3gkH^br#ig;1^y~9$%lzxU6%$ zU)lan>eQi(oh3rTQF7QhN33HUV`N=$#ju>p{27dm_HmK=?<2}j*Am*$ z1xbyTdp1EMXk+*t;Q;piNC?9ILI|qD( z0xS-&Bfu5`D+KHfV0QrfejWA*2L4w8>~Fws1C|chbHG>u<2*T*0oM@%hCMm~Yxi(L zAbva$r~w}YswV(}&_uwSkbpqMWFSx|IS3>{0X!41BtTEhrvia?s6ik<8W3oc7FYv= zKvMJ|kkvU5D1-rcPe8w-03Cwxj(-pE0N{t6IzEpAo`iF9J_Rh}0_UfIqbCyxbn0Xs zcmdGqlXKvuKvXz*Am9O@A>bO?lXdJpbig|Bbs%EEz$e%E0oRk diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor deleted file mode 100755 index f800b4d213..0000000000 --- a/extra/graphics/tiff/tiff-tests.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test graphics.tiff ; -IN: graphics.tiff.tests - -: tiff-test-path ( -- path ) - "resource:extra/graphics/tiff/rgb.tiff" ; - -: tiff-test-path2 ( -- path ) - "resource:extra/graphics/tiff/octagon.tiff" ; - diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor deleted file mode 100755 index 0481af8747..0000000000 --- a/extra/graphics/tiff/tiff.factor +++ /dev/null @@ -1,271 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators io io.encodings.binary io.files -kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint classes -io.binary assocs math math.bitwise byte-arrays grouping ; -IN: graphics.tiff - -TUPLE: tiff endianness the-answer ifd-offset ifds ; - -CONSTRUCTOR: tiff ( -- tiff ) - V{ } clone >>ifds ; - -TUPLE: ifd count ifd-entries next -processed-tags strips buffer ; -CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; - -TUPLE: ifd-entry tag type count offset/value ; -CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; - -SINGLETONS: photometric-interpretation -photometric-interpretation-white-is-zero -photometric-interpretation-black-is-zero -photometric-interpretation-rgb -photometric-interpretation-palette-color ; -ERROR: bad-photometric-interpretation n ; -: lookup-photometric-interpretation ( n -- singleton ) - { - { 0 [ photometric-interpretation-white-is-zero ] } - { 1 [ photometric-interpretation-black-is-zero ] } - { 2 [ photometric-interpretation-rgb ] } - { 3 [ photometric-interpretation-palette-color ] } - [ bad-photometric-interpretation ] - } case ; - -SINGLETONS: compression -compression-none -compression-CCITT-2 -compression-lzw -compression-pack-bits ; -ERROR: bad-compression n ; -: lookup-compression ( n -- compression ) - { - { 1 [ compression-none ] } - { 2 [ compression-CCITT-2 ] } - { 5 [ compression-lzw ] } - { 32773 [ compression-pack-bits ] } - [ bad-compression ] - } case ; - -SINGLETONS: resolution-unit -resolution-unit-none -resolution-unit-inch -resolution-unit-centimeter ; -ERROR: bad-resolution-unit n ; -: lookup-resolution-unit ( n -- object ) - { - { 1 [ resolution-unit-none ] } - { 2 [ resolution-unit-inch ] } - { 3 [ resolution-unit-centimeter ] } - [ bad-resolution-unit ] - } case ; - -SINGLETONS: predictor -predictor-none -predictor-horizontal-differencing ; -ERROR: bad-predictor n ; -: lookup-predictor ( n -- object ) - { - { 1 [ predictor-none ] } - { 2 [ predictor-horizontal-differencing ] } - [ bad-predictor ] - } case ; - -SINGLETONS: planar-configuration -planar-configuration-chunky -planar-configuration-planar ; -ERROR: bad-planar-configuration n ; -: lookup-planar-configuration ( n -- object ) - { - { 1 [ planar-configuration-chunky ] } - { 2 [ planar-configuration-planar ] } - [ bad-planar-configuration ] - } case ; - -ERROR: bad-sample-format n ; -SINGLETONS: sample-format -sample-format-unsigned-integer -sample-format-signed-integer -sample-format-ieee-float -sample-format-undefined-data ; -: lookup-sample-format ( seq -- object ) - [ - { - { 1 [ sample-format-unsigned-integer ] } - { 2 [ sample-format-signed-integer ] } - { 3 [ sample-format-ieee-float ] } - { 4 [ sample-format-undefined-data ] } - [ bad-sample-format ] - } case - ] map ; - -ERROR: bad-extra-samples n ; -SINGLETONS: extra-samples -extra-samples-unspecified-alpha-data -extra-samples-associated-alpha-data -extra-samples-unassociated-alpha-data ; -: lookup-extra-samples ( seq -- object ) - { - { 0 [ extra-samples-unspecified-alpha-data ] } - { 1 [ extra-samples-associated-alpha-data ] } - { 2 [ extra-samples-unassociated-alpha-data ] } - [ bad-extra-samples ] - } case ; - -SINGLETONS: image-length image-width x-resolution y-resolution -rows-per-strip strip-offsets strip-byte-counts bits-per-sample -samples-per-pixel new-subfile-type orientation -unhandled-ifd-entry ; - -ERROR: bad-tiff-magic bytes ; -: tiff-endianness ( byte-array -- ? ) - { - { B{ CHAR: M CHAR: M } [ big-endian ] } - { B{ CHAR: I CHAR: I } [ little-endian ] } - [ bad-tiff-magic ] - } case ; - -: read-header ( tiff -- tiff ) - 2 read tiff-endianness [ >>endianness ] keep - [ - 2 read endian> >>the-answer - 4 read endian> >>ifd-offset - ] with-endianness ; - -: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; - -: read-ifd ( -- ifd ) - 2 read endian> - 2 read endian> - 4 read endian> - 4 read endian> ; - -: read-ifds ( tiff -- tiff ) - dup ifd-offset>> seek-absolute seek-input - 2 read endian> - dup [ read-ifd ] replicate - 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; - -ERROR: no-tag class ; - -: ?at ( key assoc -- value/key ? ) - dupd at* [ nip t ] [ drop f ] if ; inline - -: find-tag ( idf class -- tag ) - swap processed-tags>> ?at [ no-tag ] unless ; - -: read-strips ( ifd -- ifd ) - dup - [ strip-byte-counts find-tag ] - [ strip-offsets find-tag ] bi - 2dup [ integer? ] both? [ - seek-absolute seek-input read 1array - ] [ - [ seek-absolute seek-input read ] { } 2map-as - ] if >>strips ; - -ERROR: unknown-ifd-type n ; - -: bytes>bits ( n/byte-array -- n ) - dup byte-array? [ byte-array>bignum ] when ; - -: value-length ( ifd-entry -- n ) - [ count>> ] [ type>> ] bi { - { 1 [ ] } - { 2 [ ] } - { 3 [ 2 * ] } - { 4 [ 4 * ] } - { 5 [ 8 * ] } - { 6 [ ] } - { 7 [ ] } - { 8 [ 2 * ] } - { 9 [ 4 * ] } - { 10 [ 8 * ] } - { 11 [ 4 * ] } - { 12 [ 8 * ] } - [ unknown-ifd-type ] - } case ; - -ERROR: bad-small-ifd-type n ; - -: adjust-offset/value ( ifd-entry -- obj ) - [ offset/value>> 4 >endian ] [ type>> ] bi - { - { 1 [ 1 head endian> ] } - { 3 [ 2 head endian> ] } - { 4 [ endian> ] } - { 6 [ 1 head endian> 8 >signed ] } - { 8 [ 2 head endian> 16 >signed ] } - { 9 [ endian> 32 >signed ] } - { 11 [ endian> bits>float ] } - [ bad-small-ifd-type ] - } case ; - -: offset-bytes>obj ( bytes type -- obj ) - { - { 1 [ ] } ! blank - { 2 [ ] } ! read c strings here - { 3 [ 2 [ endian> ] map ] } - { 4 [ 4 [ endian> ] map ] } - { 5 [ 8 [ "II" unpack first2 / ] map ] } - { 6 [ [ 8 >signed ] map ] } - { 7 [ ] } ! blank - { 8 [ 2 [ endian> 16 >signed ] map ] } - { 9 [ 4 [ endian> 32 >signed ] map ] } - { 10 [ 8 group [ "ii" unpack first2 / ] map ] } - { 11 [ 4 group [ "f" unpack ] map ] } - { 12 [ 8 group [ "d" unpack ] map ] } - [ unknown-ifd-type ] - } case ; - -: ifd-entry-value ( ifd-entry -- n ) - dup value-length 4 <= [ - adjust-offset/value - ] [ - [ offset/value>> seek-absolute seek-input ] - [ value-length read ] - [ type>> ] tri offset-bytes>obj - ] if ; - -: process-ifd-entry ( ifd-entry -- value class ) - [ ifd-entry-value ] [ tag>> ] bi { - { 254 [ new-subfile-type ] } - { 256 [ image-width ] } - { 257 [ image-length ] } - { 258 [ bits-per-sample ] } - { 259 [ lookup-compression compression ] } - { 262 [ lookup-photometric-interpretation photometric-interpretation ] } - { 273 [ strip-offsets ] } - { 274 [ orientation ] } - { 277 [ samples-per-pixel ] } - { 278 [ rows-per-strip ] } - { 279 [ strip-byte-counts ] } - { 282 [ x-resolution ] } - { 283 [ y-resolution ] } - { 284 [ planar-configuration ] } - { 296 [ lookup-resolution-unit resolution-unit ] } - { 317 [ lookup-predictor predictor ] } - { 338 [ lookup-extra-samples extra-samples ] } - { 339 [ lookup-sample-format sample-format ] } - [ nip unhandled-ifd-entry ] - } case ; - -: process-ifd ( ifd -- ifd ) - dup ifd-entries>> - [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; - -: strips>buffer ( ifd -- ifd ) - dup strips>> concat >>buffer ; - -: (load-tiff) ( path -- tiff ) - binary [ - - read-header dup endianness>> [ - read-ifds - dup ifds>> [ process-ifd read-strips strips>buffer drop ] each - ] with-endianness - ] with-file-reader ; - -: load-tiff ( path -- tiff ) (load-tiff) ; diff --git a/extra/graphics/viewer/authors.txt b/extra/graphics/viewer/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/graphics/viewer/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor deleted file mode 100644 index 517ab4e010..0000000000 --- a/extra/graphics/viewer/viewer.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators graphics.bitmap kernel math -math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render graphics.tiff sequences ; -IN: graphics.viewer - -TUPLE: graphics-gadget < gadget image ; - -GENERIC: draw-image ( image -- ) -GENERIC: width ( image -- w ) -GENERIC: height ( image -- h ) - -M: graphics-gadget pref-dim* - image>> [ width ] keep height abs 2array ; - -M: graphics-gadget draw-gadget* ( gadget -- ) - origin get [ image>> draw-image ] with-translation ; - -: ( bitmap -- gadget ) - \ graphics-gadget new-gadget - swap >>image ; - -: bits>gl-params ( n -- gl-bgr gl-format ) - { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case ; - -M: bitmap draw-image ( bitmap -- ) - dup height>> 0 < [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 over height>> abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - [ width>> ] keep - [ - [ height>> abs ] keep - bit-count>> bits>gl-params - ] keep array>> glDrawPixels ; - -M: bitmap width ( bitmap -- ) width>> ; -M: bitmap height ( bitmap -- ) height>> ; - -: bitmap. ( path -- ) - load-bitmap gadget. ; - -: bitmap-window ( path -- gadget ) - load-bitmap [ "bitmap" open-window ] keep ; - -M: tiff width ( tiff -- ) ifds>> first image-width find-tag ; -M: tiff height ( tiff -- ) ifds>> first image-length find-tag ; - -M: tiff draw-image ( tiff -- ) - [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip - ifds>> first - { - [ image-width find-tag ] - [ image-length find-tag ] - [ bits-per-sample find-tag sum bits>gl-params ] - [ buffer>> ] - } cleave glDrawPixels ; From 72b343ce03c39b765926de373eee0aee12dbf9b6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:15:57 -0600 Subject: [PATCH 075/168] fix images tests --- extra/images/bitmap/bitmap-tests.factor | 13 +++++-------- extra/images/bitmap/bitmap.factor | 11 ++++++++--- extra/images/tiff/tiff-tests.factor | 5 ++--- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor index 6865bfee3c..a2b3188749 100644 --- a/extra/images/bitmap/bitmap-tests.factor +++ b/extra/images/bitmap/bitmap-tests.factor @@ -2,23 +2,20 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test ; IN: images.bitmap.tests -: test-bitmap32-alpha ( -- path ) - "resource:extra/images/bitmap/test-images/32alpha.bmp" ; - : test-bitmap24 ( -- path ) - "resource:extra/images/bitmap/test-images/thiswayup24.bmp" ; + "resource:extra/images/test-images/thiswayup24.bmp" ; : test-bitmap16 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb16bit.bmp" ; + "resource:extra/images/test-images/rgb16bit.bmp" ; : test-bitmap8 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb8bit.bmp" ; + "resource:extra/images/test-images/rgb8bit.bmp" ; : test-bitmap4 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb4bit.bmp" ; + "resource:extra/images/test-images/rgb4bit.bmp" ; : test-bitmap1 ( -- path ) - "resource:extra/images/bitmap/test-images/1bit.bmp" ; + "resource:extra/images/test-images/1bit.bmp" ; [ t ] [ diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 220cdc153f..eb31dcd385 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -97,7 +97,7 @@ M: bitmap-magic summary dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index ; -: load-bitmap ( path -- bitmap ) +: load-bitmap-data ( path -- bitmap ) binary [ bitmap new parse-file-header parse-bitmap-header parse-bitmap @@ -106,14 +106,19 @@ M: bitmap-magic summary : alpha-channel-zero? ( bitmap -- ? ) buffer>> 4 3 [ 0 = ] all? ; +: process-bitmap-data ( bitmap -- bitmap ) + dup raw-bitmap>buffer >>buffer + dup alpha-channel-zero? >>alpha-channel-zero? ; + +: load-bitmap ( path -- bitmap ) + load-bitmap-data process-bitmap-data ; + : bitmap>image ( bitmap -- bitmap-image ) { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap - dup raw-bitmap>buffer >>buffer - dup alpha-channel-zero? >>alpha-channel-zero? bitmap>image ; : write2 ( n -- ) 2 >le write ; diff --git a/extra/images/tiff/tiff-tests.factor b/extra/images/tiff/tiff-tests.factor index dcc4b05eab..9905e7ad79 100755 --- a/extra/images/tiff/tiff-tests.factor +++ b/extra/images/tiff/tiff-tests.factor @@ -4,8 +4,7 @@ USING: tools.test images.tiff ; IN: images.tiff.tests : tiff-test-path ( -- path ) - "resource:extra/images/tiff/rgb.tiff" ; + "resource:extra/images/test-images/rgb.tiff" ; : tiff-test-path2 ( -- path ) - "resource:extra/images/tiff/octagon.tiff" ; - + "resource:extra/images/test-images/octagon.tiff" ; From d887ff67888bd42e1ebecfd0a1316b90dbed9d5e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:26:52 -0600 Subject: [PATCH 076/168] fix screen capture --- extra/cap/cap.factor | 4 ++-- extra/images/bitmap/bitmap.factor | 32 +++++++++++++++---------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index 716435775d..1f62441028 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays kernel math namespaces -opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer +opengl.gl sequences math.vectors ui images.bitmap images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ; IN: cap @@ -27,4 +27,4 @@ IN: cap [ screenshot ] dip save-bitmap ; : screenshot. ( window -- ) - [ screenshot ] [ title>> ] bi open-window ; + [ screenshot ] [ title>> ] bi open-window ; diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index eb31dcd385..50975b2bb3 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -21,22 +21,6 @@ buffer ; : array-copy ( bitmap array -- bitmap array' ) over size-image>> abs memory>byte-array ; -MACRO: (nbits>bitmap) ( bits -- ) - [ -3 shift ] keep '[ - bitmap new - 2over * _ * >>size-image - swap >>height - swap >>width - swap array-copy [ >>buffer ] [ >>color-index ] bi - _ >>bit-count - ] ; - -: bgr>bitmap ( array height width -- bitmap ) - 24 (nbits>bitmap) ; - -: bgra>bitmap ( array height width -- bitmap ) - 32 (nbits>bitmap) ; - : 8bit>buffer ( bitmap -- array ) [ rgb-quads>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; @@ -121,6 +105,22 @@ M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap bitmap>image ; +MACRO: (nbits>bitmap) ( bits -- ) + [ -3 shift ] keep '[ + bitmap new + 2over * _ * >>size-image + swap >>height + swap >>width + swap array-copy [ >>buffer ] [ >>color-index ] bi + _ >>bit-count bitmap>image + ] ; + +: bgr>bitmap ( array height width -- bitmap ) + 24 (nbits>bitmap) ; + +: bgra>bitmap ( array height width -- bitmap ) + 32 (nbits>bitmap) ; + : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; From e82f3a8518cef06407e9a3fd128eb8ef2f638eb6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:40:29 -0600 Subject: [PATCH 077/168] update ui.offscreen and ui.render --- extra/ui/offscreen/offscreen.factor | 2 +- extra/ui/render/test/test.factor | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 89c1c7f860..cf9370ed7f 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,5 +1,5 @@ ! (c) 2008 Joe Groff, see license for details -USING: accessors continuations graphics.bitmap kernel math +USING: accessors continuations images.bitmap kernel math sequences ui.gadgets ui.gadgets.worlds ui ui.backend destructors ; IN: ui.offscreen diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor index 2267c22a20..dcbc5b9600 100755 --- a/extra/ui/render/test/test.factor +++ b/extra/ui/render/test/test.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors colors arrays kernel sequences math byte-arrays -namespaces grouping fry cap graphics.bitmap +namespaces grouping fry cap images.bitmap ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons -ui.render ui opengl opengl.gl ; +ui.render ui opengl opengl.gl images ; IN: ui.render.test SINGLETON: line-test @@ -30,7 +30,7 @@ SYMBOL: render-output : bitmap= ( bitmap1 bitmap2 -- ? ) [ - [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi + [ [ buffer>> ] [ stride 4 align ] bi group ] [ stride ] bi '[ _ head twiddle ] map ] bi@ = ; @@ -38,7 +38,7 @@ SYMBOL: render-output screenshot [ render-output set-global ] [ - "resource:extra/ui/render/test/reference.bmp" load-bitmap + "resource:extra/ui/render/test/reference.bmp" bitmap= "is perfect" "needs work" ? "Your UI rendering " prepend message-window From 064e4c8d0969e325ed3ed58624e46ec13e25895d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:41:07 -0600 Subject: [PATCH 078/168] update offscreen docs --- extra/ui/offscreen/offscreen-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor index 5d800981bf..4123a83675 100644 --- a/extra/ui/offscreen/offscreen-docs.factor +++ b/extra/ui/offscreen/offscreen-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations ui.gadgets -graphics.bitmap strings ui.gadgets.worlds ; +images.bitmap strings ui.gadgets.worlds ; IN: ui.offscreen HELP: From 9f49b19306c89e5c692e21cc19e440d8c9baed99 Mon Sep 17 00:00:00 2001 From: Tim Wawrzynczak Date: Mon, 9 Feb 2009 21:50:04 -0600 Subject: [PATCH 079/168] Added extra/id3 vocab --- extra/id3/authors.txt | 0 extra/id3/id3-docs.factor | 10 ++ extra/id3/id3-tests.factor | 182 +++++++++++++++++++++++++++++++++++++ extra/id3/id3.factor | 154 +++++++++++++++++++++++++++++++ extra/id3/tests/blah.mp3 | Bin 0 -> 145 bytes extra/id3/tests/blah2.mp3 | Bin 0 -> 400 bytes extra/id3/tests/blah3.mp3 | Bin 0 -> 300 bytes 7 files changed, 346 insertions(+) create mode 100644 extra/id3/authors.txt create mode 100644 extra/id3/id3-docs.factor create mode 100644 extra/id3/id3-tests.factor create mode 100644 extra/id3/id3.factor create mode 100644 extra/id3/tests/blah.mp3 create mode 100644 extra/id3/tests/blah2.mp3 create mode 100644 extra/id3/tests/blah3.mp3 diff --git a/extra/id3/authors.txt b/extra/id3/authors.txt new file mode 100644 index 0000000000..e69de29bb2 diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor new file mode 100644 index 0000000000..1c77967ed1 --- /dev/null +++ b/extra/id3/id3-docs.factor @@ -0,0 +1,10 @@ +IN: id3 +USING: help.markup help.syntax sequences kernel ; + +HELP: id3-parse-mp3-file +{ $values { "path" "a path string" } { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no ID3 information." } + +ARTICLE: "id3" "ID3 tags" +{ $emphasis "id3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" + +ABOUT: "id3" diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor new file mode 100644 index 0000000000..d84f2c8726 --- /dev/null +++ b/extra/id3/id3-tests.factor @@ -0,0 +1,182 @@ +! Copyright (C) 2009 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test id3 ; +IN: id3.tests + +[ T{ mp3v2-file + { header T{ header f t 0 502 } } + { frames + { + T{ frame + { frame-id "COMM" } + { flags B{ 0 0 } } + { size 19 } + { data "eng, AG# 08E1C12E" } + } + T{ frame + { frame-id "TIT2" } + { flags B{ 0 0 } } + { size 15 } + { data "Stormy Weather" } + } + T{ frame + { frame-id "TRCK" } + { flags B{ 0 0 } } + { size 3 } + { data "32" } + } + T{ frame + { frame-id "TCON" } + { flags B{ 0 0 } } + { size 5 } + { data "(96)" } + } + T{ frame + { frame-id "TALB" } + { flags B{ 0 0 } } + { size 28 } + { data "Night and Day Frank Sinatra" } + } + T{ frame + { frame-id "PRIV" } + { flags B{ 0 0 } } + { size 39 } + { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" } + } + T{ frame + { frame-id "PRIV" } + { flags B{ 0 0 } } + { size 41 } + { data "WM/MediaClassSecondaryID" } + } + T{ frame + { frame-id "TPE1" } + { flags B{ 0 0 } } + { size 14 } + { data "Frank Sinatra" } + } + } + } +} +] [ "resource:extra/id3/tests/blah3.mp3" id3-parse-mp3-file ] unit-test + +[ + T{ mp3v2-file + { header + T{ header { version t } { flags 0 } { size 1405 } } + } + { frames + { + T{ frame + { frame-id "TIT2" } + { flags B{ 0 0 } } + { size 22 } + { data "Anthem of the Trinity" } + } + T{ frame + { frame-id "TPE1" } + { flags B{ 0 0 } } + { size 12 } + { data "Terry Riley" } + } + T{ frame + { frame-id "TALB" } + { flags B{ 0 0 } } + { size 11 } + { data "Shri Camel" } + } + T{ frame + { frame-id "TCON" } + { flags B{ 0 0 } } + { size 10 } + { data "Classical" } + } + T{ frame + { frame-id "UFID" } + { flags B{ 0 0 } } + { size 23 } + { data "http://musicbrainz.org" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 23 } + { data "MusicBrainz Artist Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 22 } + { data "musicbrainz_artistid" } + } + T{ frame + { frame-id "TRCK" } + { flags B{ 0 0 } } + { size 2 } + { data "1" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 22 } + { data "MusicBrainz Album Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 21 } + { data "musicbrainz_albumid" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 29 } + { data "MusicBrainz Album Artist Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 27 } + { data "musicbrainz_albumartistid" } + } + T{ frame + { frame-id "TPOS" } + { flags B{ 0 0 } } + { size 2 } + { data "1" } + } + T{ frame + { frame-id "TSOP" } + { flags B{ 0 0 } } + { size 1 } + } + T{ frame + { frame-id "TMED" } + { flags B{ 0 0 } } + { size 4 } + { data "DIG" } + } + } + } +} +] [ "resource:extra/id3/tests/blah2.mp3" id3-parse-mp3-file ] unit-test + +[ + T{ mp3v1-file + { title + "BLAH\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { artist + "ARTIST\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { album + "ALBUM\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { year "2009" } + { comment + "COMMENT\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { genre 89 } + } +] [ "resource:extra/id3/tests/blah.mp3" id3-parse-mp3-file ] unit-test + diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor new file mode 100644 index 0000000000..b2c2ec0621 --- /dev/null +++ b/extra/id3/id3.factor @@ -0,0 +1,154 @@ +! Copyright (C) 2009 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ; +IN: id3 + +! tuples + +TUPLE: header version flags size ; + +TUPLE: frame frame-id flags size data ; + +TUPLE: mp3v2-file header frames ; + +TUPLE: mp3v1-file title artist album year comment genre ; + +: ( -- object ) mp3v1-file new ; + +: ( header frames -- object ) mp3v2-file boa ; + +:
( -- object ) header new ; + +: ( -- object ) frame new ; + +28bitword ( seq -- int ) + 0 [ swap 7 shift bitor ] reduce ; + +: filter-text-data ( data -- filtered ) + [ printable? ] filter ; + +! frame details stuff + +: valid-frame-id? ( id -- ? ) + [ [ digit? ] [ LETTER? ] bi or ] all? ; + +: read-frame-id ( mmap -- id ) + 4 head-slice ; + +: read-frame-size ( mmap -- size ) + [ 4 8 ] dip subseq ; + +: read-frame-flags ( mmap -- flags ) + [ 8 10 ] dip subseq ; + +: read-frame-data ( frame mmap -- frame data ) + [ 10 over size>> 10 + ] dip filter-text-data ; + +! read whole frames + +: (read-frame) ( mmap -- frame ) + [ ] dip + { + [ read-frame-id ascii decode >>frame-id ] + [ read-frame-flags >byte-array >>flags ] + [ read-frame-size >28bitword >>size ] + [ read-frame-data ascii decode >>data ] + } cleave ; + +: read-frame ( mmap -- frame/f ) + dup read-frame-id valid-frame-id? [ (read-frame) ] [ drop f ] if ; + +: remove-frame ( mmap frame -- mmap ) + size>> 10 + tail-slice ; + +: read-frames ( mmap -- frames ) + [ dup read-frame dup ] + [ [ remove-frame ] keep ] + [ drop ] produce nip ; + +! header stuff + +: read-header-supported-version? ( mmap -- ? ) + 3 tail-slice [ { 4 } head? ] [ { 3 } head? ] bi or ; + +: read-header-flags ( mmap -- flags ) + 5 swap nth ; + +: read-header-size ( mmap -- size ) + [ 6 10 ] dip >28bitword ; + +: read-v2-header ( mmap -- id3header ) + [
] dip + { + [ read-header-supported-version? >>version ] + [ read-header-flags >>flags ] + [ read-header-size >>size ] + } cleave ; + +: drop-header ( mmap -- seq1 seq2 ) + dup 10 tail-slice swap ; + +: read-v2-tag-data ( seq -- mp3v2-file ) + drop-header read-v2-header swap read-frames ; + +! v1 information + +: skip-to-v1-data ( seq -- seq ) + 125 tail-slice* ; + +: read-title ( seq -- title ) + 30 head-slice ; + +: read-artist ( seq -- title ) + [ 30 60 ] dip subseq ; + +: read-album ( seq -- album ) + [ 60 90 ] dip subseq ; + +: read-year ( seq -- year ) + [ 90 94 ] dip subseq ; + +: read-comment ( seq -- comment ) + [ 94 124 ] dip subseq ; + +: read-genre ( seq -- genre ) + [ 124 ] dip nth ; + +: (read-v1-tag-data) ( seq -- mp3-file ) + [ ] dip + { + [ read-title ascii decode >>title ] + [ read-artist ascii decode >>artist ] + [ read-album ascii decode >>album ] + [ read-year ascii decode >>year ] + [ read-comment ascii decode >>comment ] + [ read-genre >fixnum >>genre ] + } cleave ; + +: read-v1-tag-data ( seq -- mp3-file ) + skip-to-v1-data (read-v1-tag-data) ; + +PRIVATE> + +! main stuff + +: id3-parse-mp3-file ( path -- object ) + [ + { + { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) + { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) + [ drop f ] ! ( mmap -- f ) + } cond + ] with-mapped-uchar-file ; + +! end diff --git a/extra/id3/tests/blah.mp3 b/extra/id3/tests/blah.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..3a60bffd340b9c8c0620dacefa74910529ad2b5e GIT binary patch literal 145 zcmZQzKm#F;?oK|A9%!OST*sgg&)^Uw0TiaAk5i~GiU=~t$iTqT+27aK)en~ekpNBc B2y*}c literal 0 HcmV?d00001 diff --git a/extra/id3/tests/blah2.mp3 b/extra/id3/tests/blah2.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..5d274299820c2dbab156db61c5e52bb83fc4fc80 GIT binary patch literal 400 zcmZutv2MaJ6m*+Tl(l6*NdAH%=*AWjKo-zM#7NnYQv$K%1mu_@Nc?-xq^J~li=Xc9 zolnR7&liGeoH*lsEboLkZeg-Cr@IZsOSzVXG!+j=J@8HNJk`3Q3#rnIyR#wCSD;a* zCG|v}D((ee))SzoL|Mvjp_XIj18WhI8M7aByZHflqJ=DuA3MDzJdWd9K<1Vjo+;{T zBTGZs`XWF;a&@~BXMqI2@TTCN@oVqb%xeFcspODfdA;3wS>9UJSvn8T?-I2ix%|Zn ag9w5;RuqKTpKOQok?jNJJ3gCWtLFzj*kz#r literal 0 HcmV?d00001 diff --git a/extra/id3/tests/blah3.mp3 b/extra/id3/tests/blah3.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..19aaa94dc692ddbd4d329d6e073609bdda0cd6dd GIT binary patch literal 300 zcmeZtF=l1}0_HMje_vl9Ll}rt^U@h~6dc`^6$~s~4V?{*TthrVjDQmSKpb3>UzA&^ z5T2S?l95^z66EX+6a<-JY!u?`?+0YC0Ow^E~4K literal 0 HcmV?d00001 From 17724be48c5a8d3ba0a4a6126663d5cb0dc632e9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 22:05:44 -0600 Subject: [PATCH 080/168] factor out a load-tiff word --- extra/images/tiff/tiff.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index a220475081..4be81af095 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -271,13 +271,15 @@ ERROR: bad-small-ifd-type n ; : parsed-tiff>images ( tiff -- sequence ) ifds>> [ ifd>image ] map ; -! tiff files can store several images -- we just take the first for now -M: tiff-image load-image* ( path tiff-image -- image ) - drop binary [ +: load-tiff ( path -- parsed-tiff ) + binary [ read-header dup endianness>> [ read-ifds dup ifds>> [ process-ifd read-strips strips>buffer drop ] each ] with-endianness - ] with-file-reader - parsed-tiff>images first ; + ] with-file-reader ; + +! tiff files can store several images -- we just take the first for now +M: tiff-image load-image* ( path tiff-image -- image ) + drop load-tiff parsed-tiff>images first ; From e5e98cc5cb348431743058125e6fe06e4e7245ea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 22:05:58 -0600 Subject: [PATCH 081/168] undo load breakage --- extra/taxes/usa/usa.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index efdb969c01..bbfc332868 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.intervals namespaces sequences money math.order taxes.usa.w4 -taxes.usa.futa math.finance taxes.usa.fica -taxes.usa.federal ; +taxes.usa.futa math.finance ; IN: taxes.usa ! Withhold: FICA, Medicare, Federal (FICA is social security) From 204f5195f708b459cf176b1cc24366f93acb51fd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 22:08:35 -0600 Subject: [PATCH 082/168] mark blas libs unportable till i sort out all the fortran abis --- basis/alien/fortran/tags.txt | 1 + basis/math/blas/ffi/tags.txt | 1 + basis/math/blas/matrices/tags.txt | 1 + basis/math/blas/vectors/tags.txt | 2 ++ 4 files changed, 5 insertions(+) diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt index 2a9b5def7a..58465edeb5 100644 --- a/basis/alien/fortran/tags.txt +++ b/basis/alien/fortran/tags.txt @@ -1,2 +1,3 @@ fortran ffi +unportable diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt index f468a9989d..a4a4ea88ab 100644 --- a/basis/math/blas/ffi/tags.txt +++ b/basis/math/blas/ffi/tags.txt @@ -1,3 +1,4 @@ math bindings fortran +unportable diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 241ec1ecda..5118958180 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,2 +1,3 @@ math bindings +unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index ede10ab61b..5118958180 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1 +1,3 @@ math +bindings +unportable From 0ba4a08ea95d23c1970c15af06e2d897073b0e7f Mon Sep 17 00:00:00 2001 From: Tim Wawrzynczak Date: Mon, 9 Feb 2009 22:38:27 -0600 Subject: [PATCH 083/168] Fixed authors.txt and id3-docs --- extra/id3/authors.txt | 2 ++ extra/id3/id3-docs.factor | 13 ++++++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/extra/id3/authors.txt b/extra/id3/authors.txt index e69de29bb2..ece617b969 100644 --- a/extra/id3/authors.txt +++ b/extra/id3/authors.txt @@ -0,0 +1,2 @@ +Tim Wawrzynczak + diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index 1c77967ed1..94128dc3b2 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -1,10 +1,17 @@ -IN: id3 +! Copyright (C) 2008 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax sequences kernel ; +IN: id3 HELP: id3-parse-mp3-file -{ $values { "path" "a path string" } { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no ID3 information." } +{ $values + { "path" "a path string" } + { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no (supported) ID3 information." } } +{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file" } ; ARTICLE: "id3" "ID3 tags" -{ $emphasis "id3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" +{ $emphasis "ID3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" +"Parsing an MP3 file: " +{ $subsection id3-parse-mp3-file } ; ABOUT: "id3" From c51a5d7678c365a87981c1df1b05d51ecb589e97 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 10 Feb 2009 01:46:02 -0600 Subject: [PATCH 084/168] Making basis/wrap not try to align the last line --- basis/wrap/strings/strings-tests.factor | 4 +++- basis/wrap/wrap.factor | 6 ++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor index 0bea9b5d32..e66572dc1b 100644 --- a/basis/wrap/strings/strings-tests.factor +++ b/basis/wrap/strings/strings-tests.factor @@ -27,7 +27,7 @@ word wrap."> " " wrap-indented-string ] unit-test -[ "this text\nhas lots\nof spaces" ] +[ "this text\nhas lots of\nspaces" ] [ "this text has lots of spaces" 12 wrap-string ] unit-test [ "hello\nhow\nare\nyou\ntoday?" ] @@ -39,3 +39,5 @@ word wrap."> [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test \ wrap-string must-infer + +[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 6e5bf31075..0b7f869141 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -36,8 +36,10 @@ SYMBOL: line-ideal ] each drop ; inline : paragraph-cost ( paragraph -- cost ) - [ head-width>> deviation ] - [ tail-cost>> ] bi + ; + dup lines>> 1list? [ drop 0 ] [ + [ head-width>> deviation ] + [ tail-cost>> ] bi + + ] if ; : min-cost ( paragraphs -- paragraph ) [ paragraph-cost ] min-by ; From bac9705da1e9bbd13953461c0d6bcc67ff2551e0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 10:37:46 -0600 Subject: [PATCH 085/168] spiff up id3 docs a bit, and fix help-lint --- extra/id3/id3-docs.factor | 12 ++++++------ extra/id3/id3-tests.factor | 6 +++--- extra/id3/id3.factor | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index 94128dc3b2..da69c2ced3 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -3,15 +3,15 @@ USING: help.markup help.syntax sequences kernel ; IN: id3 -HELP: id3-parse-mp3-file +HELP: file-id3-tags { $values { "path" "a path string" } - { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no (supported) ID3 information." } } -{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file" } ; + { "object/f" "a tuple storing ID3 metadata or f" } } +{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ; ARTICLE: "id3" "ID3 tags" -{ $emphasis "ID3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" -"Parsing an MP3 file: " -{ $subsection id3-parse-mp3-file } ; +"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl +"Parsing ID3 tags from an MP3 file:" +{ $subsection file-id3-tags } ; ABOUT: "id3" diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index d84f2c8726..b9d45b1b04 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -58,7 +58,7 @@ IN: id3.tests } } } -] [ "resource:extra/id3/tests/blah3.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test [ T{ mp3v2-file @@ -159,7 +159,7 @@ IN: id3.tests } } } -] [ "resource:extra/id3/tests/blah2.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test [ T{ mp3v1-file @@ -178,5 +178,5 @@ IN: id3.tests } { genre 89 } } -] [ "resource:extra/id3/tests/blah.mp3" id3-parse-mp3-file ] unit-test +] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index b2c2ec0621..64e1ff1d10 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -142,7 +142,7 @@ PRIVATE> ! main stuff -: id3-parse-mp3-file ( path -- object ) +: file-id3-tags ( path -- object/f ) [ { { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) From 1708d10c9a94e0af4ac1da04c0494aafc0fa33cc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 13:02:33 -0600 Subject: [PATCH 086/168] add initialize word to namespaces. foo global [ [ bar ] unless* ] curry => foo [ bar ] initialize --- core/namespaces/namespaces-docs.factor | 9 +++++++-- core/namespaces/namespaces-tests.factor | 11 +++++++++++ core/namespaces/namespaces.factor | 5 ++++- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 1cc3d86e98..ff0542a7b8 100644 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private sequences words namespaces.private quotations vectors -math.parser math ; +math.parser math words.symbol ; IN: namespaces ARTICLE: "namespaces-combinators" "Namespace combinators" @@ -20,7 +20,8 @@ ARTICLE: "namespaces-global" "Global variables" { $subsection namespace } { $subsection global } { $subsection get-global } -{ $subsection set-global } ; +{ $subsection set-global } +{ $subsection initialize } ; ARTICLE: "namespaces.private" "Namespace implementation details" "The namestack holds namespaces." @@ -159,3 +160,7 @@ HELP: ndrop HELP: init-namespaces { $description "Resets the name stack to its initial state, holding a single copy of the global namespace." } $low-level-note ; + +HELP: initialize +{ $values { "variable" symbol } { "quot" quotation } } +{ $description "If " { $snippet "variable" } " does not have a value in the global namespace, calls " { $snippet "quot" } " and assigns the result to " { $snippet "variable" } " in the global namespace." } ; diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor index 4c11e2389f..616ddef7fc 100644 --- a/core/namespaces/namespaces-tests.factor +++ b/core/namespaces/namespaces-tests.factor @@ -12,3 +12,14 @@ H{ } clone "test-namespace" set [ f ] [ H{ } clone [ f "some-global" set "some-global" get ] bind ] unit-test + +SYMBOL: test-initialize +test-initialize [ 1 ] initialize +test-initialize [ 2 ] initialize + +[ 1 ] [ test-initialize get-global ] unit-test + +f test-initialize set-global +test-initialize [ 5 ] initialize + +[ 5 ] [ test-initialize get-global ] unit-test diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 36559095cb..24095fd382 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -37,4 +37,7 @@ PRIVATE> H{ } clone >n call ndrop ; inline : with-variable ( value key quot -- ) - [ associate >n ] dip call ndrop ; inline + [ associate >n ] dip call ndrop ; inline + +: initialize ( variable quot -- ) + [ global ] [ [ unless* ] curry ] bi* change-at ; From 8a144b7b948d72239b484dabeefc016bf9c1ea58 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 13:11:06 -0600 Subject: [PATCH 087/168] support different fortran ABIs --- basis/alien/fortran/fortran-docs.factor | 27 +- basis/alien/fortran/fortran-tests.factor | 546 +++++++++++++---------- basis/alien/fortran/fortran.factor | 92 +++- basis/math/blas/ffi/ffi.factor | 8 +- 4 files changed, 418 insertions(+), 255 deletions(-) diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 4accbf5965..c5d124e198 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -1,9 +1,19 @@ ! Copyright (C) 2009 Joe Groff ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations sequences strings ; +USING: help.markup help.syntax kernel quotations sequences strings words.symbol ; QUALIFIED-WITH: alien.syntax c IN: alien.fortran +ARTICLE: "alien.fortran-abis" "Fortran ABIs" +"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:" +{ $list + { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." } + { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." } + { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." } + { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." } +} +"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ; + ARTICLE: "alien.fortran-types" "Fortran types" "The Fortran FFI recognizes the following Fortran types:" { $list @@ -15,7 +25,7 @@ ARTICLE: "alien.fortran-types" "Fortran types" { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } - { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameters." } + { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." } } "When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; @@ -30,15 +40,20 @@ HELP: SUBROUTINE: HELP: LIBRARY: { $syntax "LIBRARY: name" } { $values { "name" "a logical library name" } } -{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions." } ; +{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ; HELP: RECORD: { $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } -{ $description "Defines a Fortran record type with the given slots." } ; +{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ; + +HELP: add-fortran-library +{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } } +{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." } +; HELP: fortran-invoke { $values - { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } + { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } } { $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." } ; @@ -46,6 +61,8 @@ HELP: fortran-invoke ARTICLE: "alien.fortran" "Fortran FFI" "The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." { $subsection "alien.fortran-types" } +{ $subsection "alien.fortran-abis" } +{ $subsection add-fortran-library } { $subsection POSTPONE: LIBRARY: } { $subsection POSTPONE: FUNCTION: } { $subsection POSTPONE: SUBROUTINE: } diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor index 1b2ffda4a9..177d1077c2 100644 --- a/basis/alien/fortran/fortran-tests.factor +++ b/basis/alien/fortran/fortran-tests.factor @@ -1,295 +1,381 @@ ! (c) 2009 Joe Groff, see BSD license USING: accessors alien alien.c-types alien.complex -alien.fortran alien.strings alien.structs alien.syntax arrays -assocs byte-arrays combinators fry generalizations -io.encodings.ascii kernel macros macros.expander namespaces -sequences shuffle tools.test ; +alien.fortran alien.fortran.private alien.strings alien.structs +arrays assocs byte-arrays combinators fry +generalizations io.encodings.ascii kernel macros +macros.expander namespaces sequences shuffle tools.test ; IN: alien.fortran.tests +<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >> +LIBRARY: (alien.fortran-tests) RECORD: FORTRAN_TEST_RECORD { "INTEGER" "FOO" } { "REAL(2)" "BAR" } { "CHARACTER*4" "BAS" } ; -! fortran-name>symbol-name +intel-unix-abi fortran-abi [ -[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test -[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test -[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + ! fortran-name>symbol-name -! fortran-type>c-type + [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test -[ "short" ] -[ "integer*2" fortran-type>c-type ] unit-test + ! fortran-type>c-type -[ "int" ] -[ "integer*4" fortran-type>c-type ] unit-test + [ "short" ] + [ "integer*2" fortran-type>c-type ] unit-test -[ "int" ] -[ "INTEGER" fortran-type>c-type ] unit-test + [ "int" ] + [ "integer*4" fortran-type>c-type ] unit-test -[ "longlong" ] -[ "iNteger*8" fortran-type>c-type ] unit-test + [ "int" ] + [ "INTEGER" fortran-type>c-type ] unit-test -[ "int[0]" ] -[ "integer(*)" fortran-type>c-type ] unit-test + [ "longlong" ] + [ "iNteger*8" fortran-type>c-type ] unit-test -[ "int[0]" ] -[ "integer(3,*)" fortran-type>c-type ] unit-test + [ "int[0]" ] + [ "integer(*)" fortran-type>c-type ] unit-test -[ "int[3]" ] -[ "integer(3)" fortran-type>c-type ] unit-test + [ "int[0]" ] + [ "integer(3,*)" fortran-type>c-type ] unit-test -[ "int[6]" ] -[ "integer(3,2)" fortran-type>c-type ] unit-test + [ "int[3]" ] + [ "integer(3)" fortran-type>c-type ] unit-test -[ "int[24]" ] -[ "integer(4,3,2)" fortran-type>c-type ] unit-test + [ "int[6]" ] + [ "integer(3,2)" fortran-type>c-type ] unit-test -[ "char[1]" ] -[ "character" fortran-type>c-type ] unit-test + [ "int[24]" ] + [ "integer(4,3,2)" fortran-type>c-type ] unit-test -[ "char[17]" ] -[ "character*17" fortran-type>c-type ] unit-test + [ "char" ] + [ "character" fortran-type>c-type ] unit-test -[ "char[17]" ] -[ "character(17)" fortran-type>c-type ] unit-test + [ "char" ] + [ "character*1" fortran-type>c-type ] unit-test -[ "int" ] -[ "logical" fortran-type>c-type ] unit-test + [ "char[17]" ] + [ "character*17" fortran-type>c-type ] unit-test -[ "float" ] -[ "real" fortran-type>c-type ] unit-test + [ "char[17]" ] + [ "character(17)" fortran-type>c-type ] unit-test -[ "double" ] -[ "double-precision" fortran-type>c-type ] unit-test + [ "int" ] + [ "logical" fortran-type>c-type ] unit-test -[ "float" ] -[ "real*4" fortran-type>c-type ] unit-test + [ "float" ] + [ "real" fortran-type>c-type ] unit-test -[ "double" ] -[ "real*8" fortran-type>c-type ] unit-test + [ "double" ] + [ "double-precision" fortran-type>c-type ] unit-test -[ "complex-float" ] -[ "complex" fortran-type>c-type ] unit-test + [ "float" ] + [ "real*4" fortran-type>c-type ] unit-test -[ "complex-double" ] -[ "double-complex" fortran-type>c-type ] unit-test + [ "double" ] + [ "real*8" fortran-type>c-type ] unit-test -[ "complex-float" ] -[ "complex*8" fortran-type>c-type ] unit-test + [ "complex-float" ] + [ "complex" fortran-type>c-type ] unit-test -[ "complex-double" ] -[ "complex*16" fortran-type>c-type ] unit-test + [ "complex-double" ] + [ "double-complex" fortran-type>c-type ] unit-test -[ "fortran_test_record" ] -[ "fortran_test_record" fortran-type>c-type ] unit-test + [ "complex-float" ] + [ "complex*8" fortran-type>c-type ] unit-test -! fortran-arg-type>c-type + [ "complex-double" ] + [ "complex*16" fortran-type>c-type ] unit-test -[ "int*" { } ] -[ "integer" fortran-arg-type>c-type ] unit-test + [ "fortran_test_record" ] + [ "fortran_test_record" fortran-type>c-type ] unit-test -[ "int*" { } ] -[ "integer(3)" fortran-arg-type>c-type ] unit-test + ! fortran-arg-type>c-type -[ "int*" { } ] -[ "integer(*)" fortran-arg-type>c-type ] unit-test + [ "int*" { } ] + [ "integer" fortran-arg-type>c-type ] unit-test -[ "fortran_test_record*" { } ] -[ "fortran_test_record" fortran-arg-type>c-type ] unit-test + [ "int*" { } ] + [ "integer(3)" fortran-arg-type>c-type ] unit-test -[ "char*" { "long" } ] -[ "character" fortran-arg-type>c-type ] unit-test + [ "int*" { } ] + [ "integer(*)" fortran-arg-type>c-type ] unit-test -[ "char*" { "long" } ] -[ "character(17)" fortran-arg-type>c-type ] unit-test + [ "fortran_test_record*" { } ] + [ "fortran_test_record" fortran-arg-type>c-type ] unit-test -! fortran-ret-type>c-type + [ "char*" { } ] + [ "character" fortran-arg-type>c-type ] unit-test -[ "void" { "char*" "long" } ] -[ "character(17)" fortran-ret-type>c-type ] unit-test + [ "char*" { } ] + [ "character(1)" fortran-arg-type>c-type ] unit-test -[ "int" { } ] -[ "integer" fortran-ret-type>c-type ] unit-test + [ "char*" { "long" } ] + [ "character(17)" fortran-arg-type>c-type ] unit-test -[ "int" { } ] -[ "logical" fortran-ret-type>c-type ] unit-test + ! fortran-ret-type>c-type -[ "float" { } ] -[ "real" fortran-ret-type>c-type ] unit-test + [ "char" { } ] + [ "character(1)" fortran-ret-type>c-type ] unit-test -[ "double" { } ] -[ "double-precision" fortran-ret-type>c-type ] unit-test + [ "void" { "char*" "long" } ] + [ "character(17)" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-float*" } ] -[ "complex" fortran-ret-type>c-type ] unit-test + [ "int" { } ] + [ "integer" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-double*" } ] -[ "double-complex" fortran-ret-type>c-type ] unit-test + [ "int" { } ] + [ "logical" fortran-ret-type>c-type ] unit-test -[ "void" { "int*" } ] -[ "integer(*)" fortran-ret-type>c-type ] unit-test + [ "float" { } ] + [ "real" fortran-ret-type>c-type ] unit-test -[ "void" { "fortran_test_record*" } ] -[ "fortran_test_record" fortran-ret-type>c-type ] unit-test + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test -! fortran-sig>c-sig + [ "double" { } ] + [ "double-precision" fortran-ret-type>c-type ] unit-test -[ "float" { "int*" "char*" "float*" "double*" "long" } ] -[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] -unit-test + [ "void" { "complex-float*" } ] + [ "complex" fortran-ret-type>c-type ] unit-test -[ "void" { "char*" "long" "char*" "char*" "int*" "long" "long" } ] -[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] -unit-test + [ "void" { "complex-double*" } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test -[ "void" { "complex-float*" "char*" "char*" "int*" "long" "long" } ] -[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] -unit-test + [ "void" { "int*" } ] + [ "integer(*)" fortran-ret-type>c-type ] unit-test -! fortran-record>c-struct + [ "void" { "fortran_test_record*" } ] + [ "fortran_test_record" fortran-ret-type>c-type ] unit-test -[ { - { "double" "ex" } - { "float" "wye" } - { "int" "zee" } - { "char[20]" "woo" } -} ] [ - { - { "DOUBLE-PRECISION" "EX" } - { "REAL" "WYE" } - { "INTEGER" "ZEE" } - { "CHARACTER(20)" "WOO" } - } fortran-record>c-struct -] unit-test + ! fortran-sig>c-sig -! RECORD: + [ "float" { "int*" "char*" "float*" "double*" "long" } ] + [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] + unit-test -[ 16 ] [ "fortran_test_record" heap-size ] unit-test -[ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test -[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test -[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test + [ "char" { "char*" "char*" "int*" "long" } ] + [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test -! (fortran-invoke) + [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ] + [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test -[ [ - ! [fortran-args>c-args] - { - [ { - [ ascii string>alien ] - [ ] - [ ] - [ ] - [ 1 0 ? ] - } spread ] - [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] - } 5 ncleave - ! [fortran-invoke] - [ - "void" "funpack" "funtimes_" - { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } - alien-invoke - ] 6 nkeep - ! [fortran-results>] - shuffle( aa ba ca da ea ab -- aa ab ba ca da ea ) - { - [ drop ] - [ drop ] - [ drop ] - [ *float ] - [ drop ] - [ drop ] - } spread -] ] [ - f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } - (fortran-invoke) -] unit-test + [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ] + [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test -[ [ - ! [fortran-args>c-args] - { - [ { [ ] } spread ] - [ { [ drop ] } spread ] - } 1 ncleave - ! [fortran-invoke] - [ "float" "funpack" "fun_times__" { "float*" } alien-invoke ] - 1 nkeep - ! [fortran-results>] - shuffle( reta aa -- reta aa ) - { [ ] [ drop ] } spread -] ] [ - "REAL" "funpack" "FUN_TIMES" { "REAL(*)" } - (fortran-invoke) -] unit-test + ! fortran-record>c-struct -[ [ - ! [] - [ "complex-float" ] 1 ndip - ! [fortran-args>c-args] - { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave - ! [fortran-invoke] - [ - "void" "funpack" "fun_times__" - { "complex-float*" "float*" } - alien-invoke - ] 2 nkeep - ! [fortran-results>] - shuffle( reta aa -- reta aa ) - { [ *complex-float ] [ drop ] } spread -] ] [ - "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" } - (fortran-invoke) -] unit-test + [ { + { "double" "ex" } + { "float" "wye" } + { "int" "zee" } + { "char[20]" "woo" } + } ] [ + { + { "DOUBLE-PRECISION" "EX" } + { "REAL" "WYE" } + { "INTEGER" "ZEE" } + { "CHARACTER(20)" "WOO" } + } fortran-record>c-struct + ] unit-test -[ [ - ! [] - [ 20 20 ] 0 ndip - ! [fortran-invoke] - [ - "void" "funpack" "fun_times__" - { "char*" "long" } - alien-invoke - ] 2 nkeep - ! [fortran-results>] - shuffle( reta retb -- reta retb ) - { [ ] [ ascii alien>nstring ] } spread -] ] [ - "CHARACTER*20" "funpack" "FUN_TIMES" { } - (fortran-invoke) -] unit-test + ! RECORD: -[ [ - ! [] - [ 10 10 ] 3 ndip - ! [fortran-args>c-args] - { - [ { - [ ascii string>alien ] - [ ] - [ ascii string>alien ] - } spread ] - [ { [ length ] [ drop ] [ length ] } spread ] - } 3 ncleave - ! [fortran-invoke] - [ - "void" "funpack" "fun_times__" - { "char*" "long" "char*" "float*" "char*" "long" "long" } - alien-invoke - ] 7 nkeep - ! [fortran-results>] - shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) - { - [ ] - [ ascii alien>nstring ] - [ ] - [ ascii alien>nstring ] - [ *float ] - [ ] - [ ascii alien>nstring ] - } spread -] ] [ - "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" } - (fortran-invoke) -] unit-test + [ 16 ] [ "fortran_test_record" heap-size ] unit-test + [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test + [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test + [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test + ! (fortran-invoke) + + [ [ + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ] + [ ] + [ 1 0 ? ] + } spread ] + [ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ] + } 5 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "funtimes_" + { "char*" "longlong*" "float*" "complex-float*" "short*" "long" } + alien-invoke + ] 6 nkeep + ! [fortran-results>] + shuffle( aa ba ca da ea ab -- aa ab ba ca da ea ) + { + [ drop ] + [ drop ] + [ drop ] + [ *float ] + [ drop ] + [ drop ] + } spread + ] ] [ + f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" } + (fortran-invoke) + ] unit-test + + [ [ + ! [fortran-args>c-args] + { + [ { [ ] } spread ] + [ { [ drop ] } spread ] + } 1 ncleave + ! [fortran-invoke] + [ "float" "funpack" "fun_times_" { "float*" } alien-invoke ] + 1 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ ] [ drop ] } spread + ] ] [ + "REAL" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ "complex-float" ] 1 ndip + ! [fortran-args>c-args] + { [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "complex-float*" "float*" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + shuffle( reta aa -- reta aa ) + { [ *complex-float ] [ drop ] } spread + ] ] [ + "COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ 20 20 ] 0 ndip + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "char*" "long" } + alien-invoke + ] 2 nkeep + ! [fortran-results>] + shuffle( reta retb -- reta retb ) + { [ ] [ ascii alien>nstring ] } spread + ] ] [ + "CHARACTER*20" "funpack" "FUN_TIMES" { } + (fortran-invoke) + ] unit-test + + [ [ + ! [] + [ 10 10 ] 3 ndip + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ascii string>alien ] + } spread ] + [ { [ length ] [ drop ] [ length ] } spread ] + } 3 ncleave + ! [fortran-invoke] + [ + "void" "funpack" "fun_times_" + { "char*" "long" "char*" "float*" "char*" "long" "long" } + alien-invoke + ] 7 nkeep + ! [fortran-results>] + shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb ) + { + [ ] + [ ascii alien>nstring ] + [ ] + [ ascii alien>nstring ] + [ *float ] + [ ] + [ ascii alien>nstring ] + } spread + ] ] [ + "CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" } + (fortran-invoke) + ] unit-test + +] with-variable ! intel-unix-abi + +intel-windows-abi fortran-abi [ + + [ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + +] with-variable + +f2c-abi fortran-abi [ + + [ "char[1]" ] + [ "character(1)" fortran-type>c-type ] unit-test + + [ "char*" { "long" } ] + [ "character" fortran-arg-type>c-type ] unit-test + + [ "void" { "char*" "long" } ] + [ "character" fortran-ret-type>c-type ] unit-test + + [ "double" { } ] + [ "real" fortran-ret-type>c-type ] unit-test + + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test + + [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + +] with-variable + +gfortran-abi fortran-abi [ + + [ "float" { } ] + [ "real" fortran-ret-type>c-type ] unit-test + + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test + + [ "complex-float" { } ] + [ "complex" fortran-ret-type>c-type ] unit-test + + [ "complex-double" { } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test + + [ "char[1]" ] + [ "character(1)" fortran-type>c-type ] unit-test + + [ "char*" { "long" } ] + [ "character" fortran-arg-type>c-type ] unit-test + + [ "void" { "char*" "long" } ] + [ "character" fortran-ret-type>c-type ] unit-test + + [ "complex-float" { } ] + [ "complex" fortran-ret-type>c-type ] unit-test + + [ "complex-double" { } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test + + [ "void" { "complex-double*" } ] + [ "double-complex(3)" fortran-ret-type>c-type ] unit-test + +] with-variable diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 9327c7b02c..cdf64ecb10 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -5,11 +5,10 @@ byte-arrays combinators combinators.short-circuit fry generalizations kernel lexer macros math math.parser namespaces parser sequences splitting stack-checker vectors vocabs.parser words locals io.encodings.ascii io.encodings.string shuffle effects math.ranges -math.order sorting system ; +math.order sorting strings system ; IN: alien.fortran -! XXX this currently only supports the gfortran/f2c abi. -! XXX we should also support ifort at some point for commercial BLASes +SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ; << : add-f2c-libraries ( -- ) @@ -22,18 +21,55 @@ os netbsd? [ add-f2c-libraries ] when : alien>nstring ( alien len encoding -- string ) [ memory>byte-array ] dip decode ; -: fortran-name>symbol-name ( fortran-name -- c-name ) - >lower CHAR: _ over member? - [ "__" append ] [ "_" append ] if ; - ERROR: invalid-fortran-type type ; DEFER: fortran-sig>c-sig DEFER: fortran-ret-type>c-type DEFER: fortran-arg-type>c-type +DEFER: fortran-name>symbol-name + +SYMBOL: library-fortran-abis +SYMBOL: fortran-abi +library-fortran-abis [ H{ } clone ] initialize lower "_" append ; +: lowercase-name-with-extra-underscore ( name -- name' ) + >lower CHAR: _ over member? + [ "__" append ] [ "_" append ] if ; + +HOOK: fortran-c-abi fortran-abi ( -- abi ) +M: f2c-abi fortran-c-abi "cdecl" ; +M: gfortran-abi fortran-c-abi "cdecl" ; +M: intel-unix-abi fortran-c-abi "cdecl" ; +M: intel-windows-abi fortran-c-abi "cdecl" ; + +HOOK: real-functions-return-double? fortran-abi ( -- ? ) +M: f2c-abi real-functions-return-double? t ; +M: gfortran-abi real-functions-return-double? f ; +M: intel-unix-abi real-functions-return-double? f ; +M: intel-windows-abi real-functions-return-double? f ; + +HOOK: complex-functions-return-by-value? fortran-abi ( -- ? ) +M: f2c-abi complex-functions-return-by-value? f ; +M: gfortran-abi complex-functions-return-by-value? t ; +M: intel-unix-abi complex-functions-return-by-value? f ; +M: intel-windows-abi complex-functions-return-by-value? f ; + +HOOK: character(1)-maps-to-char? fortran-abi ( -- ? ) +M: f2c-abi character(1)-maps-to-char? f ; +M: gfortran-abi character(1)-maps-to-char? f ; +M: intel-unix-abi character(1)-maps-to-char? t ; +M: intel-windows-abi character(1)-maps-to-char? t ; + +HOOK: mangle-name fortran-abi ( name -- name' ) +M: f2c-abi mangle-name lowercase-name-with-extra-underscore ; +M: gfortran-abi mangle-name lowercase-name-with-underscore ; +M: intel-unix-abi mangle-name lowercase-name-with-underscore ; +M: intel-windows-abi mangle-name >upper ; + TUPLE: fortran-type dims size out? ; TUPLE: number-type < fortran-type ; @@ -107,10 +143,14 @@ M: double-complex-type (fortran-type>c-type) M: misc-type (fortran-type>c-type) dup name>> simple-type ; +: single-char? ( character-type -- ? ) + { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ; + : fix-character-type ( character-type -- character-type' ) clone dup size>> [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ] - [ dup dims>> [ ] [ { 1 } >>dims ] if ] if ; + [ dup dims>> [ ] [ f >>dims ] if ] if + dup single-char? [ f >>dims ] when ; M: character-type (fortran-type>c-type) fix-character-type "char" simple-type ; @@ -142,22 +182,23 @@ M: character-type (fortran-type>c-type) GENERIC: added-c-args ( type -- args ) M: fortran-type added-c-args drop { } ; -M: character-type added-c-args drop { "long" } ; +M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ; GENERIC: returns-by-value? ( type -- ? ) M: f returns-by-value? drop t ; M: fortran-type returns-by-value? drop f ; M: number-type returns-by-value? dims>> not ; -M: complex-type returns-by-value? drop f ; +M: character-type returns-by-value? fix-character-type single-char? ; +M: complex-type returns-by-value? + { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ; GENERIC: (fortran-ret-type>c-type) ( type -- c-type ) M: f (fortran-ret-type>c-type) drop "void" ; M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ; -! XXX F2C claims to return double for REAL typed functions -! XXX OSX Accelerate.framework uses float -! M: real-type (fortran-ret-type>c-type) drop "double" ; +M: real-type (fortran-ret-type>c-type) + drop real-functions-return-double? [ "double" ] [ "float" ] if ; : suffix! ( seq elt -- seq ) over push ; inline : append! ( seq-a seq-b -- seq-a ) over push-all ; inline @@ -209,7 +250,9 @@ M: double-complex-type (fortran-arg>c-args) [ drop [ ] [ drop ] ] args?dims ; M: character-type (fortran-arg>c-args) - drop [ ascii string>alien ] [ length ] ; + fix-character-type single-char? + [ [ first ] [ drop ] ] + [ [ ascii string>alien ] [ length ] ] if ; M: misc-type (fortran-arg>c-args) drop [ ] [ drop ] ; @@ -255,7 +298,9 @@ M: double-complex-type (fortran-result>) [ drop { [ *complex-double ] } ] result?dims ; M: character-type (fortran-result>) - drop { [ ] [ ascii alien>nstring ] } ; + fix-character-type single-char? + [ { [ *char 1string ] } ] + [ { [ ] [ ascii alien>nstring ] } ] if ; M: misc-type (fortran-result>) drop { [ ] } ; @@ -331,8 +376,18 @@ M: character-type () append \ spread [ ] 2sequence append ; +: (add-fortran-library) ( fortran-abi name -- ) + library-fortran-abis get-global set-at ; + PRIVATE> +: add-fortran-library ( name soname fortran-abi -- ) + [ fortran-abi [ fortran-c-abi ] with-variable add-library ] + [ nip swap (add-fortran-library) ] 3bi ; + +: fortran-name>symbol-name ( fortran-name -- c-name ) + mangle-name ; + : fortran-type>c-type ( fortran-type -- c-type ) parse-fortran-type (fortran-type>c-type) ; @@ -344,7 +399,7 @@ PRIVATE> parse-fortran-type dup returns-by-value? [ (fortran-ret-type>c-type) { } ] [ "void" swap - [ added-c-args ] [ (fortran-ret-type>c-type) c-type>pointer ] bi prefix + [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix ] if ; : fortran-arg-types>c-types ( fortran-types -- c-types ) @@ -388,4 +443,7 @@ MACRO: fortran-invoke ( return library function parameters -- ) [ "()" subseq? not ] filter define-fortran-function ; parsing : LIBRARY: - scan "c-library" set ; parsing + scan + [ "c-library" set ] + [ library-fortran-abis get-global at fortran-abi set ] bi ; parsing + diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor index 77cee1aa82..1749103ce4 100644 --- a/basis/math/blas/ffi/ffi.factor +++ b/basis/math/blas/ffi/ffi.factor @@ -3,9 +3,11 @@ IN: math.blas.ffi << "blas" { - { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } - { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - [ "libblas.so" "cdecl" add-library ] + { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] } + { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] } + { [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] } + { [ os freebsd? ] [ "libblas.so" gfortran-abi add-fortran-library ] } + [ "libblas.so" f2c-abi add-fortran-library ] } cond >> From 0279270dda37a45323bdb3170970ec62abab3005 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 15:11:39 -0600 Subject: [PATCH 088/168] un-unportable the blas stuff --- basis/alien/fortran/tags.txt | 1 - basis/math/blas/ffi/tags.txt | 1 - basis/math/blas/matrices/tags.txt | 1 - basis/math/blas/vectors/tags.txt | 1 - 4 files changed, 4 deletions(-) diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt index 58465edeb5..2a9b5def7a 100644 --- a/basis/alien/fortran/tags.txt +++ b/basis/alien/fortran/tags.txt @@ -1,3 +1,2 @@ fortran ffi -unportable diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt index a4a4ea88ab..f468a9989d 100644 --- a/basis/math/blas/ffi/tags.txt +++ b/basis/math/blas/ffi/tags.txt @@ -1,4 +1,3 @@ math bindings fortran -unportable diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable From 07caee3405a9ae8c2f9aa2125b74aac279d41131 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Feb 2009 16:16:12 -0600 Subject: [PATCH 089/168] Update some existing code to use initialize --- basis/cocoa/cocoa.factor | 2 +- basis/cocoa/messages/messages.factor | 8 ++++---- basis/compiler/utilities/utilities.factor | 2 +- basis/concurrency/messaging/messaging.factor | 2 +- basis/help/help.factor | 2 +- basis/help/topics/topics.factor | 4 ++-- basis/html/templates/chloe/syntax/syntax.factor | 2 +- basis/http/server/server.factor | 2 +- basis/io/encodings/iana/iana.factor | 4 ++-- basis/tools/annotations/annotations.factor | 2 +- basis/ui/cocoa/cocoa.factor | 6 +++--- basis/ui/gadgets/worlds/worlds.factor | 2 +- core/alien/alien.factor | 2 +- core/compiler/units/units.factor | 4 +--- core/io/backend/backend.factor | 2 +- core/parser/parser.factor | 2 +- core/strings/parser/parser.factor | 6 +++--- core/words/words.factor | 4 ++-- extra/mason/config/config.factor | 4 ++-- 19 files changed, 30 insertions(+), 32 deletions(-) diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 44252a3b19..01f134e283 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -29,7 +29,7 @@ SYMBOL: super-sent-messages SYMBOL: frameworks -frameworks global [ V{ } clone or ] change-at +frameworks [ V{ } clone ] initialize [ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 60bdde262c..529efeb564 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -19,8 +19,8 @@ IN: cocoa.messages SYMBOL: message-senders SYMBOL: super-message-senders -message-senders global [ H{ } assoc-like ] change-at -super-message-senders global [ H{ } assoc-like ] change-at +message-senders [ H{ } clone ] initialize +super-message-senders [ H{ } clone ] initialize : cache-stub ( method function hash -- ) [ @@ -53,7 +53,7 @@ MEMO: ( name -- sel ) f \ selector boa ; SYMBOL: objc-methods -objc-methods global [ H{ } assoc-like ] change-at +objc-methods [ H{ } clone ] initialize : lookup-method ( selector -- method ) dup objc-methods get at @@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection SYMBOL: class-init-hooks -class-init-hooks global [ H{ } clone or ] change-at +class-init-hooks [ H{ } clone or ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index ec4ced8c9f..31faaef480 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -24,4 +24,4 @@ IN: compiler.utilities SYMBOL: yield-hook -yield-hook global [ [ ] or ] change-at +yield-hook [ [ ] ] initialize diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 61a3c38991..ce7f7d6110 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -85,4 +85,4 @@ PRIVATE> : get-process ( name -- process ) dup registered-processes at [ ] [ thread ] ?if ; -\ registered-processes global [ H{ } assoc-like ] change-at +\ registered-processes [ H{ } clone ] initialize diff --git a/basis/help/help.factor b/basis/help/help.factor index 272bdc1db3..f980032a8b 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -118,7 +118,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; SYMBOL: help-hook -help-hook global [ [ print-topic ] or ] change-at +help-hook [ [ print-topic ] ] initialize : help ( topic -- ) help-hook get call ; diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index e6b19d5baa..8c687eb1d5 100644 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -27,11 +27,11 @@ M: link summary ! Help articles SYMBOL: articles -articles global [ H{ } assoc-like ] change-at +articles [ H{ } clone ] initialize SYMBOL: article-xref -article-xref global [ H{ } assoc-like ] change-at +article-xref [ H{ } clone ] initialize GENERIC: article-name ( topic -- string ) GENERIC: article-title ( topic -- string ) diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index f149c3fe47..faf8bed66b 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -11,7 +11,7 @@ html.templates ; SYMBOL: tags -tags global [ H{ } clone or ] change-at +tags [ H{ } clone ] initialize : define-chloe-tag ( name quot -- ) swap tags get set-at ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index b6ee70057b..f2f3deead2 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -161,7 +161,7 @@ C: trivial-responder M: trivial-responder call-responder* nip response>> clone ; -main-responder global [ <404> or ] change-at +main-responder [ <404> ] initialize : invert-slice ( slice -- slice' ) dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index a56bd1194b..6afae92429 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -47,8 +47,8 @@ PRIVATE> "resource:basis/io/encodings/iana/character-sets" utf8 make-aliases aliases set-global -n>e-table global [ initial-n>e or ] change-at -e>n-table global [ initial-e>n or ] change-at +n>e-table [ initial-n>e ] initialize +e>n-table [ initial-e>n ] initialize : register-encoding ( descriptor name -- ) [ diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index ecf3ba0a76..b436be5163 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -87,7 +87,7 @@ M: word annotate-methods SYMBOL: word-timing -word-timing global [ H{ } clone or ] change-at +word-timing [ H{ } clone ] initialize : reset-word-timing ( -- ) word-timing get clear-assoc ; diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 331c0a698c..2fc8856b26 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -141,9 +141,9 @@ CLASS: { SYMBOL: cocoa-init-hook -cocoa-init-hook global [ - [ "MiniFactor.nib" load-nib install-app-delegate ] or -] change-at +cocoa-init-hook [ + [ "MiniFactor.nib" load-nib install-app-delegate ] +] initialize M: cocoa-ui-backend ui "UI" assert.app [ diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 732a438203..f57fb60bcd 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -81,7 +81,7 @@ SYMBOL: ui-error-hook : ui-error ( error -- ) ui-error-hook get [ call ] [ die ] if* ; -ui-error-hook global [ [ rethrow ] or ] change-at +ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 93d1a8e306..52e9cd0f30 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -51,7 +51,7 @@ M: alien equal? SYMBOL: libraries -libraries global [ H{ } assoc-like ] change-at +libraries [ H{ } clone ] initialize TUPLE: library path abi dll ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 999b783c48..ac3e99e24c 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -178,6 +178,4 @@ SYMBOL: remake-generics-hook : default-recompile-hook ( words -- alist ) [ f ] { } map>assoc ; -recompile-hook global -[ [ default-recompile-hook ] or ] -change-at +recompile-hook [ [ default-recompile-hook ] ] initialize diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index fd5567cfa2..2f0bb1063f 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -8,7 +8,7 @@ SYMBOL: io-backend SINGLETON: c-io-backend -io-backend global [ c-io-backend or ] change-at +io-backend [ c-io-backend ] initialize HOOK: init-io io-backend ( -- ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 4be7cfa891..971ba245dd 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -200,7 +200,7 @@ SYMBOL: interactive-vocabs SYMBOL: print-use-hook -print-use-hook global [ [ ] or ] change-at +print-use-hook [ [ ] ] initialize : parse-fresh ( lines -- quot ) [ diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 4062e16e3d..8c9d0b5557 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -22,9 +22,9 @@ ERROR: bad-escape ; SYMBOL: name>char-hook -name>char-hook global [ - [ "Unicode support not available" throw ] or -] change-at +name>char-hook [ + [ "Unicode support not available" throw ] +] initialize : unicode-escape ( str -- ch str' ) "{" ?head-slice [ diff --git a/core/words/words.factor b/core/words/words.factor index 3197d0a6f6..8648664031 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -96,11 +96,11 @@ M: word uses ( word -- seq ) SYMBOL: compiled-crossref -compiled-crossref global [ H{ } assoc-like ] change-at +compiled-crossref [ H{ } clone ] initialize SYMBOL: compiled-generic-crossref -compiled-generic-crossref global [ H{ } assoc-like ] change-at +compiled-generic-crossref [ H{ } clone ] initialize : (compiled-xref) ( word dependencies word-prop variable -- ) [ [ set-word-prop ] curry ] diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index b1739d85fa..51b09543f4 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -81,7 +81,7 @@ SYMBOL: upload-directory ! Optional: override ssh and scp command names SYMBOL: scp-command -scp-command global [ "scp" or ] change-at +scp-command [ "scp" ] initialize SYMBOL: ssh-command -ssh-command global [ "ssh" or ] change-at +ssh-command [ "ssh" ] initialize From a0421edf97056f14a1dceb9f0e90a553cbf28ca4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 16:39:24 -0600 Subject: [PATCH 090/168] set fortran abi in fortran-invoke macro --- basis/alien/fortran/fortran.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index cdf64ecb10..a2ffc55c02 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -418,8 +418,12 @@ PRIVATE> : RECORD: scan in get parse-definition define-fortran-record ; parsing +: set-fortran-abi ( library -- ) + library-fortran-abis get-global at fortran-abi set ; + : (fortran-invoke) ( return library function parameters -- quot ) { + [ 2drop nip set-fortran-abi ] [ 2nip [] ] [ nip nip nip [fortran-args>c-args] ] [ [fortran-invoke] ] @@ -445,5 +449,5 @@ MACRO: fortran-invoke ( return library function parameters -- ) : LIBRARY: scan [ "c-library" set ] - [ library-fortran-abis get-global at fortran-abi set ] bi ; parsing + [ set-fortran-abi ] bi ; parsing From 9060905983c9d11c7a26cce5a027278da2f08b58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Feb 2009 16:52:27 -0600 Subject: [PATCH 091/168] Fix bootstrap --- basis/cocoa/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 529efeb564..ce66467203 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection SYMBOL: class-init-hooks -class-init-hooks [ H{ } clone or ] initialize +class-init-hooks [ H{ } clone ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ From 8bad9f014ac500647a3c10b06956a3956f86e187 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 16:59:55 -0600 Subject: [PATCH 092/168] case now throws the value it can't find --- core/combinators/combinators-tests.factor | 16 +++++++++++++++- core/combinators/combinators.factor | 4 ++-- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 1a73e22e31..beb50f1162 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -323,4 +323,18 @@ DEFER: corner-case-1 [ t ] [ \ corner-case-1 optimized>> ] unit-test [ 4 ] [ 2 corner-case-1 ] unit-test -[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test \ No newline at end of file +[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test + +: test-case-8 ( n -- ) + { + { 1 [ "foo" ] } + } case ; + +[ 3 test-case-8 ] +[ object>> 3 = ] must-fail-with + +[ + 3 { + { 1 [ "foo" ] } + } case +] [ object>> 3 = ] must-fail-with diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e356a6d246..daf247d678 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -49,7 +49,7 @@ ERROR: no-cond ; reverse [ no-cond ] swap alist>quot ; ! case -ERROR: no-case ; +ERROR: no-case object ; : case-find ( obj assoc -- obj' ) [ @@ -66,7 +66,7 @@ ERROR: no-case ; case-find { { [ dup array? ] [ nip second call ] } { [ dup callable? ] [ call ] } - { [ dup not ] [ no-case ] } + { [ dup not ] [ drop no-case ] } } cond ; : linear-case-quot ( default assoc -- quot ) From 970953be1f3dcd874f35c131c6b00adafa43e4cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:17:36 -0600 Subject: [PATCH 093/168] fix tiff/bitmaps color order --- extra/images/backend/backend.factor | 7 +++++-- extra/images/bitmap/bitmap.factor | 12 +++++++++++- extra/images/tiff/tiff.factor | 12 +++++++++++- extra/images/viewer/viewer.factor | 20 +++++++++++++------- 4 files changed, 40 insertions(+), 11 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index ef2a9a4248..5e05db0f4d 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -3,16 +3,19 @@ USING: accessors kernel ; IN: images.backend -TUPLE: image width height depth pitch buffer ; +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; + +TUPLE: image width height depth pitch component-order buffer ; GENERIC: load-image* ( path tuple -- image ) : load-image ( path class -- image ) new load-image* ; -: new-image ( width height depth buffer class -- image ) +: new-image ( width height depth component-order buffer class -- image ) new swap >>buffer + swap >>component-order swap >>depth swap >>height swap >>width ; inline diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 50975b2bb3..14d52fdaf8 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -97,8 +97,18 @@ M: bitmap-magic summary : load-bitmap ( path -- bitmap ) load-bitmap-data process-bitmap-data ; +ERROR: unknown-component-order bitmap ; + +: bitmap>component-order ( bitmap -- object ) + bit-count>> { + { 32 [ BGRA ] } + { 24 [ BGR ] } + { 8 [ BGR ] } + [ unknown-component-order ] + } case ; + : bitmap>image ( bitmap -- bitmap-image ) - { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave + { [ width>> ] [ height>> ] [ bit-count>> ] [ bitmap>component-order ] [ buffer>> ] } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index 4be81af095..922e302040 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.binary io.files -kernel pack endian tools.hexdump constructors sequences arrays +kernel pack endian constructors sequences arrays sorting.slots math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays grouping images.backend ; @@ -260,17 +260,27 @@ ERROR: bad-small-ifd-type n ; : strips>buffer ( ifd -- ifd ) dup strips>> concat >>buffer ; +ERROR: unknown-component-order ifd ; + +: ifd-component-order ( ifd -- byte-order ) + bits-per-sample find-tag sum { + { 32 [ RGBA ] } + [ unknown-component-order ] + } case ; + : ifd>image ( ifd -- image ) { [ image-width find-tag ] [ image-length find-tag ] [ bits-per-sample find-tag sum ] + [ ifd-component-order ] [ buffer>> ] } cleave tiff-image new-image ; : parsed-tiff>images ( tiff -- sequence ) ifds>> [ ifd>image ] map ; + : load-tiff ( path -- parsed-tiff ) binary [ diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 4d5df4874a..0b01d75748 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -22,12 +22,18 @@ M: image-gadget draw-gadget* ( gadget -- ) \ image-gadget new-gadget swap >>image ; -: bits>gl-params ( n -- gl-bgr gl-format ) +: gl-component-order ( singletons -- n ) { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + { BGR [ GL_BGR ] } + { RGB [ GL_BGR ] } + { BGRA [ GL_BGRA ] } + { RGBA [ GL_RGBA ] } + ! { RGBX [ GL_RGBX ] } + ! { BGRX [ GL_BGRX ] } + ! { ARGB [ GL_ARGB ] } + ! { ABGR [ GL_ABGR ] } + ! { XRGB [ GL_XRGB ] } + ! { XBGR [ GL_XBGR ] } } case ; M: bitmap-image draw-image ( bitmap -- ) @@ -44,7 +50,7 @@ M: bitmap-image draw-image ( bitmap -- ) ] [ width>> abs ] [ height>> abs ] - [ depth>> bits>gl-params ] + [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] [ buffer>> ] } cleave glDrawPixels ; @@ -56,7 +62,7 @@ M: tiff-image draw-image ( tiff -- ) { [ height>> ] [ width>> ] - [ depth>> bits>gl-params ] + [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] [ buffer>> ] } cleave glDrawPixels ; From 46bfb5c8eab23c26fd5b2b98c62db491b4253354 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:20:36 -0600 Subject: [PATCH 094/168] clean up --- extra/images/images.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/images/images.factor b/extra/images/images.factor index eb4fc63fee..4b4673333f 100644 --- a/extra/images/images.factor +++ b/extra/images/images.factor @@ -6,8 +6,7 @@ io.pathnames ; IN: images : ( path -- image ) - normalize-path dup "." split1-last nip >lower - { + dup file-extension >lower { { "bmp" [ bitmap-image load-image ] } { "tiff" [ tiff-image load-image ] } } case ; From c2e6ef0366fde96c9cddc3141af42f5023cf80de Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:23:21 -0600 Subject: [PATCH 095/168] remove dead pathname --- extra/images/bitmap/bitmap-tests.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor index a2b3188749..a7deae3178 100644 --- a/extra/images/bitmap/bitmap-tests.factor +++ b/extra/images/bitmap/bitmap-tests.factor @@ -5,9 +5,6 @@ IN: images.bitmap.tests : test-bitmap24 ( -- path ) "resource:extra/images/test-images/thiswayup24.bmp" ; -: test-bitmap16 ( -- path ) - "resource:extra/images/test-images/rgb16bit.bmp" ; - : test-bitmap8 ( -- path ) "resource:extra/images/test-images/rgb8bit.bmp" ; From cf99c7afd1bdd8e9d1d173f594b5efff6f19eac7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 17:25:02 -0600 Subject: [PATCH 096/168] no locals in bit-arrays --- basis/bit-arrays/bit-arrays.factor | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index f1ba71ce1e..3da22e09d6 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types accessors math alien.accessors kernel -kernel.private locals sequences sequences.private byte-arrays +kernel.private sequences sequences.private byte-arrays parser prettyprint.custom fry ; IN: bit-arrays @@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ; : ?{ \ } [ >bit-array ] parse-literal ; parsing -:: integer>bit-array ( n -- bit-array ) - n zero? [ 0 ] [ - [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | - [ n' zero? ] [ - n' out underlying>> i set-alien-unsigned-1 - n' -8 shift n'! - i 1+ i! - ] [ ] until - out - ] +: integer>bit-array ( n -- bit-array ) + dup 0 = [ + + ] [ + [ log2 1+ 0 ] keep + [ dup 0 = ] [ + [ pick underlying>> pick set-alien-unsigned-1 ] keep + [ 1+ ] [ -8 shift ] bi* + ] [ ] until 2drop ] if ; : bit-array>integer ( bit-array -- n ) From a1e521b54ee51f3a2e2a9329923e3d97b04551fb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:42:21 -0600 Subject: [PATCH 097/168] working on images protocol --- extra/images/backend/backend.factor | 44 ++++++++++++++++----- extra/images/bitmap/bitmap.factor | 21 +++++----- extra/images/images.factor | 17 +++++++-- extra/images/tiff/tiff.factor | 24 ++++++------ extra/images/viewer/viewer.factor | 59 +++++------------------------ 5 files changed, 77 insertions(+), 88 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 5e05db0f4d..fb859f31a5 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,21 +1,47 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel ; +USING: accessors kernel grouping fry sequences combinators ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; +! RGBA -TUPLE: image width height depth pitch component-order buffer ; +TUPLE: image dim component-order bitmap ; + +TUPLE: normalized-image < image ; GENERIC: load-image* ( path tuple -- image ) -: load-image ( path class -- image ) - new load-image* ; +GENERIC: >image ( object -- image ) -: new-image ( width height depth component-order buffer class -- image ) +: no-op ( -- ) ; + +: normalize-component-order ( image -- image ) + dup component-order>> + { + { RGBA [ no-op ] } + { BGRA [ + [ + [ 4 [ [ 0 3 ] dip reverse-here ] each ] + [ RGBA >>component-order ] bi + ] change-bitmap + ] } + { RGB [ + [ 3 [ 255 suffix ] map concat ] change-bitmap + ] } + { BGR [ + [ + 3 dup [ [ 0 3 ] dip reverse-here ] each + [ 255 suffix ] map concat + ] change-bitmap + ] } + } case RGBA >>component-order ; + +: normalize-image ( image -- image ) + normalize-component-order ; + +: new-image ( dim component-order bitmap class -- image ) new - swap >>buffer + swap >>bitmap swap >>component-order - swap >>depth - swap >>height - swap >>width ; inline + swap >>dim ; inline diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 14d52fdaf8..7b59827d02 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -15,7 +15,6 @@ TUPLE: bitmap-image < image ; TUPLE: bitmap magic size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index -alpha-channel-zero? buffer ; : array-copy ( bitmap array -- bitmap array' ) @@ -87,12 +86,8 @@ M: bitmap-magic summary parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader ; -: alpha-channel-zero? ( bitmap -- ? ) - buffer>> 4 3 [ 0 = ] all? ; - : process-bitmap-data ( bitmap -- bitmap ) - dup raw-bitmap>buffer >>buffer - dup alpha-channel-zero? >>alpha-channel-zero? ; + dup raw-bitmap>buffer >>buffer ; : load-bitmap ( path -- bitmap ) load-bitmap-data process-bitmap-data ; @@ -107,13 +102,15 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: bitmap>image ( bitmap -- bitmap-image ) - { [ width>> ] [ height>> ] [ bit-count>> ] [ bitmap>component-order ] [ buffer>> ] } cleave - bitmap-image new-image ; +M: bitmap >image ( bitmap -- bitmap-image ) + { + [ [ width>> ] [ height>> ] bi 2array ] + [ bitmap>component-order ] + [ buffer>> ] + } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) - drop load-bitmap - bitmap>image ; + drop load-bitmap >image ; MACRO: (nbits>bitmap) ( bits -- ) [ -3 shift ] keep '[ @@ -122,7 +119,7 @@ MACRO: (nbits>bitmap) ( bits -- ) swap >>height swap >>width swap array-copy [ >>buffer ] [ >>color-index ] bi - _ >>bit-count bitmap>image + _ >>bit-count >image ] ; : bgr>bitmap ( array height width -- bitmap ) diff --git a/extra/images/images.factor b/extra/images/images.factor index 4b4673333f..3df7b5d2d1 100644 --- a/extra/images/images.factor +++ b/extra/images/images.factor @@ -5,8 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend io.pathnames ; IN: images -: ( path -- image ) - dup file-extension >lower { - { "bmp" [ bitmap-image load-image ] } - { "tiff" [ tiff-image load-image ] } +ERROR: unknown-image-extension extension ; + +: image-class ( path -- class ) + file-extension >lower { + { "bmp" [ bitmap-image ] } + { "tiff" [ tiff-image ] } + [ unknown-image-extension ] } case ; + +: load-image ( path -- image ) + dup image-class new load-image* ; + +: ( path -- image ) + load-image normalize-image ; diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index 922e302040..dc40f648cc 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -13,7 +13,7 @@ TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ; CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ; TUPLE: ifd count ifd-entries next -processed-tags strips buffer ; +processed-tags strips bitmap ; CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; TUPLE: ifd-entry tag type count offset/value ; @@ -257,39 +257,37 @@ ERROR: bad-small-ifd-type n ; dup ifd-entries>> [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; -: strips>buffer ( ifd -- ifd ) - dup strips>> concat >>buffer ; +: strips>bitmap ( ifd -- ifd ) + dup strips>> concat >>bitmap ; ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag sum { { 32 [ RGBA ] } + { 24 [ RGB ] } [ unknown-component-order ] } case ; -: ifd>image ( ifd -- image ) +M: ifd >image ( ifd -- image ) { - [ image-width find-tag ] - [ image-length find-tag ] - [ bits-per-sample find-tag sum ] + [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order ] - [ buffer>> ] + [ bitmap>> ] } cleave tiff-image new-image ; -: parsed-tiff>images ( tiff -- sequence ) - ifds>> [ ifd>image ] map ; - +M: parsed-tiff >image ( image -- image ) + ifds>> [ >image ] map first ; : load-tiff ( path -- parsed-tiff ) binary [ read-header dup endianness>> [ read-ifds - dup ifds>> [ process-ifd read-strips strips>buffer drop ] each + dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each ] with-endianness ] with-file-reader ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) - drop load-tiff parsed-tiff>images first ; + drop load-tiff >image ; diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 0b01d75748..f99c34f509 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators images.bitmap kernel math -math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render images.tiff sequences multiline -images.backend images io.pathnames strings ; +USING: accessors images images.backend io.pathnames kernel +namespaces opengl opengl.gl sequences strings ui ui.gadgets +ui.gadgets.panes ui.render ; IN: images.viewer TUPLE: image-gadget < gadget { image image } ; -GENERIC: draw-image ( image -- ) - M: image-gadget pref-dim* - image>> - [ width>> ] [ height>> ] bi - [ abs ] bi@ 2array ; + image>> dim>> ; + +: draw-image ( tiff -- ) + 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom + [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ] + [ bitmap>> ] bi glDrawPixels ; M: image-gadget draw-gadget* ( gadget -- ) origin get [ image>> draw-image ] with-translation ; @@ -22,50 +22,9 @@ M: image-gadget draw-gadget* ( gadget -- ) \ image-gadget new-gadget swap >>image ; -: gl-component-order ( singletons -- n ) - { - { BGR [ GL_BGR ] } - { RGB [ GL_BGR ] } - { BGRA [ GL_BGRA ] } - { RGBA [ GL_RGBA ] } - ! { RGBX [ GL_RGBX ] } - ! { BGRX [ GL_BGRX ] } - ! { ARGB [ GL_ARGB ] } - ! { ABGR [ GL_ABGR ] } - ! { XRGB [ GL_XRGB ] } - ! { XBGR [ GL_XBGR ] } - } case ; - -M: bitmap-image draw-image ( bitmap -- ) - { - [ - height>> dup 0 < [ - drop - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 swap abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - ] - [ width>> abs ] - [ height>> abs ] - [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] - [ buffer>> ] - } cleave glDrawPixels ; - : image-window ( path -- gadget ) [ dup ] [ open-window ] bi ; -M: tiff-image draw-image ( tiff -- ) - 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom - { - [ height>> ] - [ width>> ] - [ component-order>> gl-component-order GL_UNSIGNED_BYTE ] - [ buffer>> ] - } cleave glDrawPixels ; - GENERIC: image. ( image -- ) M: string image. ( image -- ) gadget. ; From 1d5f6901c1224a8f964c148a5615739c87193297 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:48:10 -0600 Subject: [PATCH 098/168] fix bitmap drawing --- extra/images/backend/backend.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index fb859f31a5..796e9a3a66 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel grouping fry sequences combinators ; +USING: accessors kernel grouping fry sequences combinators +images.bitmap math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; @@ -37,8 +38,17 @@ GENERIC: >image ( object -- image ) ] } } case RGBA >>component-order ; +GENERIC: normalize-scan-line-order ( image -- image ) + +M: image normalize-scan-line-order ; +M: bitmap-image normalize-scan-line-order + dup + [ bitmap>> ] [ dim>> first 4 * ] bi reverse concat + >>bitmap ; + : normalize-image ( image -- image ) - normalize-component-order ; + normalize-component-order + normalize-scan-line-order ; : new-image ( dim component-order bitmap class -- image ) new From 7d60fcc5989134f95a57299615e94be2fbdfabd7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 18:52:28 -0600 Subject: [PATCH 099/168] clean up some image code --- extra/images/backend/backend.factor | 7 +++---- extra/images/viewer/viewer.factor | 11 +++++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 796e9a3a66..2e626b73e6 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -5,7 +5,6 @@ images.bitmap math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; -! RGBA TUPLE: image dim component-order bitmap ; @@ -42,9 +41,9 @@ GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; M: bitmap-image normalize-scan-line-order - dup - [ bitmap>> ] [ dim>> first 4 * ] bi reverse concat - >>bitmap ; + dup dim>> '[ + _ first 4 * reverse concat + ] change-bitmap ; : normalize-image ( image -- image ) normalize-component-order diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index f99c34f509..92277dfdef 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -25,10 +25,13 @@ M: image-gadget draw-gadget* ( gadget -- ) : image-window ( path -- gadget ) [ dup ] [ open-window ] bi ; -GENERIC: image. ( image -- ) +GENERIC: image. ( object -- ) -M: string image. ( image -- ) gadget. ; +: default-image. ( path -- ) + gadget. ; -M: pathname image. ( image -- ) gadget. ; +M: string image. ( image -- ) default-image. ; -M: image image. ( image -- ) gadget. ; +M: pathname image. ( image -- ) default-image. ; + +M: image image. ( image -- ) default-image. ; From 72c898e2b52d6e523acd16495f41f8c3983afe92 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 10 Feb 2009 19:05:08 -0600 Subject: [PATCH 100/168] Code for letting you test the todo list --- extra/webapps/todo/todo.factor | 52 +++++++++++++++++++++++++++++++++- extra/webapps/todo/todo.xml | 11 +++++++ 2 files changed, 62 insertions(+), 1 deletion(-) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index e1f6c8735a..6ef60c198f 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -106,7 +106,8 @@ todo "TODO" : ( -- responder ) todo-list new-dispatcher - "" add-responder + "list" add-responder + URL" /list" "" add-responder "view" add-responder "new" add-responder "edit" add-responder @@ -115,3 +116,52 @@ todo "TODO" { todo-list "todo" } >>template "view your todo list" >>description ; + +USING: furnace.auth.features.registration +furnace.auth.features.edit-profile +furnace.auth.features.deactivate-user +db.sqlite +furnace.alloy +io.servers.connection +io.sockets.secure ; + +: ( responder -- responder' ) + "Todo list" + "Todo list" >>name + allow-registration + allow-edit-profile + allow-deactivation ; + +: todo-db ( -- db ) "resource:todo.db" ; + +: init-todo-db ( -- ) + todo-db [ + init-furnace-tables + todo ensure-table + ] with-db ; + +: ( -- config ) + ! This is only suitable for testing! + + "resource:basis/openssl/test/dh1024.pem" >>dh-file + "resource:basis/openssl/test/server.pem" >>key-file + "password" >>password ; + +: ( -- responder ) + init-todo-db + + + todo-db ; + +: ( -- threaded-server ) + + >>secure-config + 8080 >>insecure + 8431 >>secure ; + +: run-todo ( -- ) + main-responder set-global + todo-db start-expiring + start-server ; + +MAIN: run-todo diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index f7500cdad2..00ed63560c 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -2,7 +2,14 @@ + + + + + + +
List Items @@ -19,4 +26,8 @@ + + + + From 94f6d28f34d7a3f0a31a9c3c35ba354d54e69704 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 19:34:02 -0600 Subject: [PATCH 101/168] fix a method --- extra/images/backend/backend.factor | 5 ----- extra/images/bitmap/bitmap.factor | 5 +++++ 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 2e626b73e6..6d73a253ae 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -40,11 +40,6 @@ GENERIC: >image ( object -- image ) GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; -M: bitmap-image normalize-scan-line-order - dup dim>> '[ - _ first 4 * reverse concat - ] change-bitmap ; - : normalize-image ( image -- image ) normalize-component-order normalize-scan-line-order ; diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 7b59827d02..46f90e33f8 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -112,6 +112,11 @@ M: bitmap >image ( bitmap -- bitmap-image ) M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap >image ; +M: bitmap-image normalize-scan-line-order + dup dim>> '[ + _ first 4 * reverse concat + ] change-bitmap ; + MACRO: (nbits>bitmap) ( bits -- ) [ -3 shift ] keep '[ bitmap new From 5dd4bbcf42dab7018c3840f53feaefe923d2bd1b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Feb 2009 19:58:53 -0600 Subject: [PATCH 102/168] Defuse RTLD_GLOBAL time bomb in os-unix.c --- vm/os-unix.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-unix.c b/vm/os-unix.c index b49f7637af..97c29d8c6e 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -36,7 +36,7 @@ void init_ffi(void) void ffi_dlopen(F_DLL *dll) { - dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY|RTLD_GLOBAL); + dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY); } void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol) From 610c43a3c3c6abf312ca15aa7aef30f187bf0549 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 10 Feb 2009 20:49:10 -0600 Subject: [PATCH 103/168] remove circular using --- extra/images/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor index 6d73a253ae..756b98efee 100644 --- a/extra/images/backend/backend.factor +++ b/extra/images/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel grouping fry sequences combinators -images.bitmap math ; +math ; IN: images.backend SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; From 76761c4c618ca6d48f17b9eda3379214641e2f59 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Feb 2009 04:59:29 -0600 Subject: [PATCH 104/168] Document html:simple-page --- basis/html/html-docs.factor | 6 ++++++ basis/html/html.factor | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) create mode 100644 basis/html/html-docs.factor diff --git a/basis/html/html-docs.factor b/basis/html/html-docs.factor new file mode 100644 index 0000000000..8c4b2934d0 --- /dev/null +++ b/basis/html/html-docs.factor @@ -0,0 +1,6 @@ +IN: html +USING: help.markup help.syntax strings ; + +HELP: simple-page +{ $values { "title" string } { "head" "XML data" } { "body" "XML data" } } +{ $description "Constructs a simple XHTML page with a " { $snippet "head" } " and " { $snippet "body" } " tag. The given XML data is spliced into the two child tags, and a title is also added to the head tag." } ; \ No newline at end of file diff --git a/basis/html/html.factor b/basis/html/html.factor index e86b4917d7..e446c66d8c 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -15,7 +15,7 @@ IN: html <-> - XML> ; inline + XML> ; : render-error ( message -- xml ) [XML <-> XML] ; From 049753f0cc416fd85196fb2bd2cca9889ed6fff3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Feb 2009 04:59:36 -0600 Subject: [PATCH 105/168] Tweak quotations docs --- core/quotations/quotations-docs.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index f2629a36c4..2a03b7c74f 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -7,6 +7,9 @@ ARTICLE: "quotations" "Quotations" $nl "Concretely, a quotation is an immutable sequence of objects, some of which may be words, together with a block of machine code which may be executed to achieve the effect of evaluating the quotation. The machine code is generated by a fast non-optimizing quotation compiler which is always running and is transparent to the developer." $nl +"Quotations form a class of objects, however in most cases, methods should dispatch on " { $link callable } " instead, so that " { $link curry } " and " { $link compose } " values can participate." +{ $subsection quotation } +{ $subsection quotation? } "Quotations evaluate sequentially from beginning to end. Literals are pushed on the stack and words are executed. Details can be found in " { $link "evaluator" } "." $nl "Quotation literal syntax is documented in " { $link "syntax-quots" } "." From ab6ec008dd42a9d86abdc71c680565ed12201efc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Feb 2009 04:59:47 -0600 Subject: [PATCH 106/168] Remove sorting.slots from images.tiff USING: list --- extra/images/tiff/tiff.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index dc40f648cc..dac071b4b4 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators io io.encodings.binary io.files -kernel pack endian constructors sequences arrays -sorting.slots math.order math.parser prettyprint classes -io.binary assocs math math.bitwise byte-arrays grouping -images.backend ; +USING: accessors combinators io io.encodings.binary io.files kernel +pack endian constructors sequences arrays math.order math.parser +prettyprint classes io.binary assocs math math.bitwise byte-arrays +grouping images.backend ; IN: images.tiff TUPLE: tiff-image < image ; From 6ae2694f510302c46bf4d8cc2a9f3a7e6598730b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Feb 2009 05:01:04 -0600 Subject: [PATCH 107/168] Move images vocab, and constructors (which it depends on) to basis --- {extra => basis}/constructors/authors.txt | 0 {extra => basis}/constructors/constructors-tests.factor | 0 {extra => basis}/constructors/constructors.factor | 0 {extra => basis}/images/authors.txt | 0 {extra => basis}/images/backend/authors.txt | 0 {extra => basis}/images/backend/backend.factor | 0 {extra => basis}/images/bitmap/authors.txt | 0 {extra => basis}/images/bitmap/bitmap-tests.factor | 0 {extra => basis}/images/bitmap/bitmap.factor | 0 {extra => basis}/images/images.factor | 0 {extra => basis}/images/tags.txt | 0 {extra => basis}/images/tiff/authors.txt | 0 {extra => basis}/images/tiff/tiff-tests.factor | 0 {extra => basis}/images/tiff/tiff.factor | 0 14 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/constructors/authors.txt (100%) rename {extra => basis}/constructors/constructors-tests.factor (100%) rename {extra => basis}/constructors/constructors.factor (100%) rename {extra => basis}/images/authors.txt (100%) rename {extra => basis}/images/backend/authors.txt (100%) rename {extra => basis}/images/backend/backend.factor (100%) rename {extra => basis}/images/bitmap/authors.txt (100%) rename {extra => basis}/images/bitmap/bitmap-tests.factor (100%) rename {extra => basis}/images/bitmap/bitmap.factor (100%) rename {extra => basis}/images/images.factor (100%) rename {extra => basis}/images/tags.txt (100%) rename {extra => basis}/images/tiff/authors.txt (100%) rename {extra => basis}/images/tiff/tiff-tests.factor (100%) rename {extra => basis}/images/tiff/tiff.factor (100%) diff --git a/extra/constructors/authors.txt b/basis/constructors/authors.txt similarity index 100% rename from extra/constructors/authors.txt rename to basis/constructors/authors.txt diff --git a/extra/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor similarity index 100% rename from extra/constructors/constructors-tests.factor rename to basis/constructors/constructors-tests.factor diff --git a/extra/constructors/constructors.factor b/basis/constructors/constructors.factor similarity index 100% rename from extra/constructors/constructors.factor rename to basis/constructors/constructors.factor diff --git a/extra/images/authors.txt b/basis/images/authors.txt similarity index 100% rename from extra/images/authors.txt rename to basis/images/authors.txt diff --git a/extra/images/backend/authors.txt b/basis/images/backend/authors.txt similarity index 100% rename from extra/images/backend/authors.txt rename to basis/images/backend/authors.txt diff --git a/extra/images/backend/backend.factor b/basis/images/backend/backend.factor similarity index 100% rename from extra/images/backend/backend.factor rename to basis/images/backend/backend.factor diff --git a/extra/images/bitmap/authors.txt b/basis/images/bitmap/authors.txt similarity index 100% rename from extra/images/bitmap/authors.txt rename to basis/images/bitmap/authors.txt diff --git a/extra/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor similarity index 100% rename from extra/images/bitmap/bitmap-tests.factor rename to basis/images/bitmap/bitmap-tests.factor diff --git a/extra/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor similarity index 100% rename from extra/images/bitmap/bitmap.factor rename to basis/images/bitmap/bitmap.factor diff --git a/extra/images/images.factor b/basis/images/images.factor similarity index 100% rename from extra/images/images.factor rename to basis/images/images.factor diff --git a/extra/images/tags.txt b/basis/images/tags.txt similarity index 100% rename from extra/images/tags.txt rename to basis/images/tags.txt diff --git a/extra/images/tiff/authors.txt b/basis/images/tiff/authors.txt similarity index 100% rename from extra/images/tiff/authors.txt rename to basis/images/tiff/authors.txt diff --git a/extra/images/tiff/tiff-tests.factor b/basis/images/tiff/tiff-tests.factor similarity index 100% rename from extra/images/tiff/tiff-tests.factor rename to basis/images/tiff/tiff-tests.factor diff --git a/extra/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor similarity index 100% rename from extra/images/tiff/tiff.factor rename to basis/images/tiff/tiff.factor From aba1dbabcf35be21a60191f0088912f82530c523 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Philipp=20Br=C3=BCschweiler?= Date: Wed, 11 Feb 2009 20:56:09 +0100 Subject: [PATCH 108/168] infix: added meta information and fixed up docs somewhat --- extra/infix/ast/ast.factor | 2 + extra/infix/authors.txt | 1 + extra/infix/infix-docs.factor | 55 +++++++++++++++++++- extra/infix/infix-tests.factor | 2 + extra/infix/infix.factor | 2 + extra/infix/parser/parser-tests.factor | 2 + extra/infix/parser/parser.factor | 2 + extra/infix/summary.txt | 1 + extra/infix/tags.txt | 1 + extra/infix/tokenizer/tokenizer-tests.factor | 2 + extra/infix/tokenizer/tokenizer.factor | 2 + 11 files changed, 71 insertions(+), 1 deletion(-) create mode 100644 extra/infix/authors.txt create mode 100644 extra/infix/summary.txt create mode 100644 extra/infix/tags.txt diff --git a/extra/infix/ast/ast.factor b/extra/infix/ast/ast.factor index 0bc22feeb7..1908b3d39b 100644 --- a/extra/infix/ast/ast.factor +++ b/extra/infix/ast/ast.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. IN: infix.ast TUPLE: ast-number value ; diff --git a/extra/infix/authors.txt b/extra/infix/authors.txt new file mode 100644 index 0000000000..156a81af57 --- /dev/null +++ b/extra/infix/authors.txt @@ -0,0 +1 @@ +Philipp Brüschweiler diff --git a/extra/infix/infix-docs.factor b/extra/infix/infix-docs.factor index 7a4febb514..4a2ec963ee 100644 --- a/extra/infix/infix-docs.factor +++ b/extra/infix/infix-docs.factor @@ -1,4 +1,6 @@ -USING: help.syntax help.markup prettyprint locals ; +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup math prettyprint locals sequences ; IN: infix HELP: [infix @@ -36,3 +38,54 @@ HELP: [infix| } ; { POSTPONE: [infix POSTPONE: [infix| } related-words + +ARTICLE: "infix" "Infix notation" +"The " { $vocab-link "infix" } " vocabulary implements support for infix notation in Factor source code." +{ $subsection POSTPONE: [infix } +{ $subsection POSTPONE: [infix| } +$nl +"The usual infix math operators are supported:" +{ $list + { $link + } + { $link - } + { $link * } + { $link / } + { { $snippet "%" } ", which is the infix operator for " { $link mod } "." } +} +"The standard precedence rules apply: Grouping with parentheses before " { $snippet "*" } ", " { $snippet "/" } "and " { $snippet "%" } " before " { $snippet "+" } " and " { $snippet "-" } "." +{ $example + "USING: infix prettyprint ;" + "[infix 5-40/10*2 infix] ." + "-3" +} +$nl +"You can call Factor words in infix expressions just as you would in C. There are some restrictions on which words are legal to use though:" +{ $list + "The word must return exactly one value." + "The word name must consist of the letters a-z, A-Z, _ or 0-9, and the first character can't be a number." +} +{ $example + "USING: infix locals math math.functions prettyprint ;" + ":: binary_entropy ( p -- h )" + " [infix -(p*log(p) + (1-p)*log(1-p)) / log(2) infix] ;" + "[infix binary_entropy( sqrt(0.25) ) infix] ." + "1.0" +} +$nl +"You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation." +{ $example + "USING: arrays infix prettyprint ;" + "[infix| myarr [ { 1 2 3 4 } ] | myarr[4/2]*3 infix] ." + "9" +} +"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:" +{ $example + "USING: arrays infix locals prettyprint ;" + ":: add-2nd-element ( x y -- res )" + " [infix x[1] + y[1] infix] ;" + "{ 1 2 3 } 5 add-2nd-element ." + "3" +} +; + +ABOUT: "infix" diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor index 5ee6468131..7e8e2dfcc9 100644 --- a/extra/infix/infix-tests.factor +++ b/extra/infix/infix-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix infix.private kernel locals math math.functions tools.test ; IN: infix.tests diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor index 31cd1cbe1f..3e2ba49e3c 100644 --- a/extra/infix/infix.factor +++ b/extra/infix/infix.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.short-circuit effects fry infix.parser infix.ast kernel locals.parser locals.types math multiline namespaces parser quotations diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor index 0a0288c41b..d6b5d0559c 100644 --- a/extra/infix/parser/parser-tests.factor +++ b/extra/infix/parser/parser-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix.ast infix.parser infix.tokenizer tools.test ; IN: infix.parser.tests diff --git a/extra/infix/parser/parser.factor b/extra/infix/parser/parser.factor index beaf3c335d..2f9ab03d18 100644 --- a/extra/infix/parser/parser.factor +++ b/extra/infix/parser/parser.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences strings vectors ; IN: infix.parser diff --git a/extra/infix/summary.txt b/extra/infix/summary.txt new file mode 100644 index 0000000000..63d366d203 --- /dev/null +++ b/extra/infix/summary.txt @@ -0,0 +1 @@ +Support for infix notation in Factor programs diff --git a/extra/infix/tags.txt b/extra/infix/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/infix/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor index 7e1fb005ef..f9c908414a 100644 --- a/extra/infix/tokenizer/tokenizer-tests.factor +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix.ast infix.tokenizer tools.test ; IN: infix.tokenizer.tests diff --git a/extra/infix/tokenizer/tokenizer.factor b/extra/infix/tokenizer/tokenizer.factor index 8c1a1b4a18..f5bce4b6d7 100644 --- a/extra/infix/tokenizer/tokenizer.factor +++ b/extra/infix/tokenizer/tokenizer.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Philipp Brüschweiler +! See http://factorcode.org/license.txt for BSD license. USING: infix.ast kernel peg peg.ebnf math.parser sequences strings ; IN: infix.tokenizer From 31d86e300cf0ade1ee73657449c95fd349d62414 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 11 Feb 2009 13:56:54 -0600 Subject: [PATCH 109/168] fix html help-lint --- basis/html/html-docs.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/html/html-docs.factor b/basis/html/html-docs.factor index 8c4b2934d0..83fe4d3a63 100644 --- a/basis/html/html-docs.factor +++ b/basis/html/html-docs.factor @@ -1,6 +1,7 @@ +USING: help.markup help.syntax strings xml.data ; IN: html -USING: help.markup help.syntax strings ; HELP: simple-page -{ $values { "title" string } { "head" "XML data" } { "body" "XML data" } } -{ $description "Constructs a simple XHTML page with a " { $snippet "head" } " and " { $snippet "body" } " tag. The given XML data is spliced into the two child tags, and a title is also added to the head tag." } ; \ No newline at end of file +{ $values { "title" string } { "head" "XML data" } { "body" "XML data" } +{ "xml" xml } } +{ $description "Constructs a simple XHTML page with a " { $snippet "head" } " and " { $snippet "body" } " tag. The given XML data is spliced into the two child tags, and a title is also added to the head tag." } ; From ed1ace93e7f595370d71f580f85fac3813a423a5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 11 Feb 2009 14:01:52 -0600 Subject: [PATCH 110/168] add checksums.txt to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 435595f502..22dda8efb4 100644 --- a/.gitignore +++ b/.gitignore @@ -24,3 +24,4 @@ build-support/wordsize *.bak .#* *.swo +checksums.txt From 94a5582edc79d19b18b552e628e4e91304b85c27 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 11 Feb 2009 14:05:57 -0600 Subject: [PATCH 111/168] tweak fortran-invoke so that unit tests can set fortran-abi without being shouted over --- basis/alien/fortran/fortran.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index a2ffc55c02..915b7d3d4f 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -423,7 +423,6 @@ PRIVATE> : (fortran-invoke) ( return library function parameters -- quot ) { - [ 2drop nip set-fortran-abi ] [ 2nip [] ] [ nip nip nip [fortran-args>c-args] ] [ [fortran-invoke] ] @@ -431,7 +430,7 @@ PRIVATE> } 4 ncleave 4 nappend ; MACRO: fortran-invoke ( return library function parameters -- ) - (fortran-invoke) ; + { [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ; :: define-fortran-function ( return library function parameters -- ) function create-in dup reset-generic From 633ffaa9ddde3c00f3e52044199493903630458c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 11 Feb 2009 14:06:46 -0600 Subject: [PATCH 112/168] play horseshoes in math.blas.vectors tests to deal with excessively accurate x87 math --- basis/math/blas/vectors/vectors-tests.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/math/blas/vectors/vectors-tests.factor b/basis/math/blas/vectors/vectors-tests.factor index da271a4fc7..ef2f7ad6f9 100644 --- a/basis/math/blas/vectors/vectors-tests.factor +++ b/basis/math/blas/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.vectors sequences tools.test ; +USING: kernel math.blas.vectors math.functions sequences tools.test ; IN: math.blas.vectors.tests ! clone @@ -126,11 +126,11 @@ unit-test ! Vnorm -[ 5.0 ] [ svector{ 3.0 4.0 } Vnorm ] unit-test -[ 5.0 ] [ dvector{ 3.0 4.0 } Vnorm ] unit-test +[ t ] [ svector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test +[ t ] [ dvector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test -[ 13.0 ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test -[ 13.0 ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test +[ t ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test +[ t ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test ! Vasum From e8657995b650b3eab66a5310aca126e444de61c8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 11 Feb 2009 18:35:08 -0600 Subject: [PATCH 113/168] code annotations toy --- extra/annotations/annotations.factor | 41 ++++++++++++++++++++++++++++ extra/annotations/authors.txt | 2 ++ extra/annotations/summary.txt | 1 + extra/annotations/tags.txt | 2 ++ 4 files changed, 46 insertions(+) create mode 100644 extra/annotations/annotations.factor create mode 100644 extra/annotations/authors.txt create mode 100644 extra/annotations/summary.txt create mode 100644 extra/annotations/tags.txt diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor new file mode 100644 index 0000000000..5102a36a71 --- /dev/null +++ b/extra/annotations/annotations.factor @@ -0,0 +1,41 @@ +! (c)2009 Joe Groff, Doug Coleman. see BSD license +USING: accessors combinators.short-circuit definitions functors +kernel lexer namespaces parser prettyprint sequences words ; +IN: annotations + +<< + +: (parse-annotation) ( accum -- accum ) + lexer get [ line-text>> parsed ] [ next-line ] bi ; + +: (non-annotation-usage) ( word -- usages ) + smart-usage + [ { [ word? ] [ vocabulary>> "annotations" = not ] } 1&& ] + filter ; + +FUNCTOR: define-annotation ( NAME -- ) + +(NAME) DEFINES (${NAME}) +!NAME DEFINES !${NAME} +NAMEs DEFINES ${NAME}s +NAMEs. DEFINES ${NAME}s. + +WHERE + +: (NAME) ( str -- ) drop ; inline +: !NAME (parse-annotation) \ (NAME) parsed ; parsing + +: NAMEs ( -- usages ) + \ (NAME) (non-annotation-usage) ; +: NAMEs. ( -- ) + NAMEs sorted-definitions. ; + +;FUNCTOR + +{ + "XXX" "TODO" "FIXME" "BUG" "REVIEW" "LICENSE" + "AUTHOR" "BROKEN" "HACK" "LOL" "NOTE" +} [ define-annotation ] each + +>> + diff --git a/extra/annotations/authors.txt b/extra/annotations/authors.txt new file mode 100644 index 0000000000..0bc3c5ad4d --- /dev/null +++ b/extra/annotations/authors.txt @@ -0,0 +1,2 @@ +Joe Groff +Doug Coleman diff --git a/extra/annotations/summary.txt b/extra/annotations/summary.txt new file mode 100644 index 0000000000..732ed6f988 --- /dev/null +++ b/extra/annotations/summary.txt @@ -0,0 +1 @@ +Code annotation comment syntax diff --git a/extra/annotations/tags.txt b/extra/annotations/tags.txt new file mode 100644 index 0000000000..278296de5e --- /dev/null +++ b/extra/annotations/tags.txt @@ -0,0 +1,2 @@ +comments +annotation From 6c723642bd5ae573ded152c9bee1bdfa50178fd3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 11 Feb 2009 18:42:01 -0600 Subject: [PATCH 114/168] annotations tests --- extra/annotations/annotations-tests.factor | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 extra/annotations/annotations-tests.factor diff --git a/extra/annotations/annotations-tests.factor b/extra/annotations/annotations-tests.factor new file mode 100644 index 0000000000..72fd0f8b74 --- /dev/null +++ b/extra/annotations/annotations-tests.factor @@ -0,0 +1,17 @@ +USING: annotations math sorting tools.test ; +IN: annotations.tests + +: three ( -- x ) + !BROKEN find a dictionary + "threa" ; + +: four ( -- x ) + !BROKEN this code is broken + 2 2 + 1+ ; + +: five ( -- x ) + !TODO return 5 + f ; + +[ { four three } ] [ BROKENs natural-sort ] unit-test +[ { five } ] [ TODOs ] unit-test From 87c9ab72c325d2ea376a9ea5dd45bbd6db161b9e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 11 Feb 2009 18:58:42 -0600 Subject: [PATCH 115/168] don't want to filter nonword annotation usages --- extra/annotations/annotations-tests.factor | 16 +++++++++++++--- extra/annotations/annotations.factor | 2 +- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/extra/annotations/annotations-tests.factor b/extra/annotations/annotations-tests.factor index 72fd0f8b74..d5a13e48d8 100644 --- a/extra/annotations/annotations-tests.factor +++ b/extra/annotations/annotations-tests.factor @@ -1,9 +1,12 @@ -USING: annotations math sorting tools.test ; +USING: accessors annotations combinators.short-circuit +io.pathnames kernel math sequences sorting tools.test ; IN: annotations.tests +!NOTE testing toplevel form + : three ( -- x ) - !BROKEN find a dictionary - "threa" ; + !BROKEN english plz + "þrij" ; : four ( -- x ) !BROKEN this code is broken @@ -13,5 +16,12 @@ IN: annotations.tests !TODO return 5 f ; +[ t ] [ + NOTEs { + [ length 1 = ] + [ first string>> file-name "annotations-tests.factor" = ] + } 1&& +] unit-test + [ { four three } ] [ BROKENs natural-sort ] unit-test [ { five } ] [ TODOs ] unit-test diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor index 5102a36a71..c61250b89d 100644 --- a/extra/annotations/annotations.factor +++ b/extra/annotations/annotations.factor @@ -10,7 +10,7 @@ IN: annotations : (non-annotation-usage) ( word -- usages ) smart-usage - [ { [ word? ] [ vocabulary>> "annotations" = not ] } 1&& ] + [ { [ word? ] [ vocabulary>> "annotations" = ] } 1&& not ] filter ; FUNCTOR: define-annotation ( NAME -- ) From ff33f38a0296c5122f89080312f0fab4e656536e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 11 Feb 2009 19:58:28 -0600 Subject: [PATCH 116/168] annotations docs --- extra/annotations/annotations-docs.factor | 42 +++++++++++++++++++++++ extra/annotations/annotations.factor | 6 ++-- 2 files changed, 46 insertions(+), 2 deletions(-) create mode 100644 extra/annotations/annotations-docs.factor diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor new file mode 100644 index 0000000000..c340554119 --- /dev/null +++ b/extra/annotations/annotations-docs.factor @@ -0,0 +1,42 @@ +USING: accessors arrays combinators definitions generalizations +help help.markup help.topics kernel sequences sorting vocabs +words ; +IN: annotations + + + +"Code annotations" +{ + "The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism." +} +annotation-tags natural-sort +[ + [ \ $subsection swap comment-word 2array ] map append + "To look up annotations:" suffix +] [ + [ \ $subsection swap comment-usage.-word 2array ] map append +] bi +
"annotations" add-article + +"annotations" vocab "annotations" >>help drop + +annotation-tags [ + { + [ [ \ $syntax ] dip "!" " your comment here" surround 2array ] + [ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ] + [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ] + [ comment-word set-word-help ] + + [ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ] + [ comment-usage.-word set-word-help ] + + [ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ] + [ comment-usage-word set-word-help ] + + [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ] + } cleave +] each diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor index c61250b89d..6685e4e036 100644 --- a/extra/annotations/annotations.factor +++ b/extra/annotations/annotations.factor @@ -32,10 +32,12 @@ WHERE ;FUNCTOR -{ +CONSTANT: annotation-tags { "XXX" "TODO" "FIXME" "BUG" "REVIEW" "LICENSE" "AUTHOR" "BROKEN" "HACK" "LOL" "NOTE" -} [ define-annotation ] each +} + +annotation-tags [ define-annotation ] each >> From 0bc16d0cf82757516eff54ab37bb8823c52901cc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 11 Feb 2009 20:11:33 -0600 Subject: [PATCH 117/168] documentation ambiguity --- basis/math/blas/vectors/vectors-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index 296437c32b..badc317189 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -93,7 +93,7 @@ HELP: Viamax HELP: Vamax { $values { "x" blas-vector-base } { "max" number } } -{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ; +{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the element closest to the beginning. Corresponds to the IxAMAX routines in BLAS." } ; { Viamax Vamax } related-words From 19eb0471bb27673b09a96724045c25f1506eafe4 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 01:31:54 -0600 Subject: [PATCH 118/168] Creating XML component --- basis/html/components/components-docs.factor | 6 +++++- basis/html/components/components.factor | 5 +++++ basis/html/templates/chloe/chloe-docs.factor | 5 +++-- basis/html/templates/chloe/chloe.factor | 1 + 4 files changed, 14 insertions(+), 3 deletions(-) diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index b432cc0cc6..37dbeba6c1 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -57,7 +57,10 @@ HELP: hidden { $description "Hidden components render as a hidden form field. For example, a page for editing a weblog post might contain a hidden field with the post ID." } ; HELP: html -{ $description "HTML components render HTML verbatim, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ; +{ $description "HTML components render HTML verbatim from a string, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ; + +HELP: xml +{ $description "XML components render XML verbatim, from an XML chunk. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ; HELP: inspector { $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ; @@ -90,6 +93,7 @@ $nl { $subsection inspector } { $subsection comparison } { $subsection html } +{ $subsection xml } "Tuple components:" { $subsection field } { $subsection password } diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index 2b18e28351..9dddb85619 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -171,3 +171,8 @@ M: comparison render* SINGLETON: html M: html render* 2drop ; + +! XML component +SINGLETON: xml + +M: xml render* 2drop ; diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index 18e6db66f6..fcfd454478 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -1,8 +1,8 @@ IN: html.templates.chloe -USING: help.markup help.syntax html.components html.forms +USING: xml.data help.markup help.syntax html.components html.forms html.templates html.templates.chloe.syntax html.templates.chloe.compiler html.templates.chloe.components -math xml.data strings quotations namespaces ; +math strings quotations namespaces ; HELP: { $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } } @@ -70,6 +70,7 @@ ARTICLE: "html.templates.chloe.tags.component" "Component Chloe tags" { { $snippet "t:field" } { $link field } } { { $snippet "t:hidden" } { $link hidden } } { { $snippet "t:html" } { $link html } } + { { $snippet "t:xml" } { $link xml } } { { $snippet "t:inspector" } { $link inspector } } { { $snippet "t:label" } { $link label } } { { $snippet "t:link" } { $link link } } diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index eafa3c3a5d..439b207063 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -95,6 +95,7 @@ COMPONENT: password COMPONENT: choice COMPONENT: checkbox COMPONENT: code +COMPONENT: xml SYMBOL: template-cache From 6215c38676f038d1313fe14d8058a1c9e7fb407c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 01:32:06 -0600 Subject: [PATCH 119/168] Fixing minor CSV bug --- basis/csv/csv-tests.factor | 5 ++--- basis/csv/csv.factor | 9 ++++++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 50bc3836f5..6ba8e2d5b8 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -7,9 +7,6 @@ IN: csv.tests : named-unit-test ( name output input -- ) unit-test drop ; inline -! tests nicked from the wikipedia csv article -! http://en.wikipedia.org/wiki/Comma-separated_values - "Fields are separated by commas" [ { { "1997" "Ford" "E350" } } ] [ "1997,Ford,E350" csv ] named-unit-test @@ -90,3 +87,5 @@ IN: csv.tests { { "writing,some,csv,tests" } } dup "csv-test2-" unique-file utf8 [ csv>file ] [ file>csv ] 2bi = ] unit-test + +[ { { "hello" "" "" "" "goodbye" "" } } ] [ "hello,,\"\",,goodbye," csv ] unit-test diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index 152b3dcbba..5902999a76 100755 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -46,13 +46,15 @@ DEFER: quoted-field ( -- endchar ) : (row) ( -- sep ) field , - dup delimiter get = [ drop (row) ] when ; + dup delimiter> = [ drop (row) ] when ; : row ( -- eof? array[string] ) [ (row) ] { } make ; : (csv) ( -- ) - row harvest [ , ] unless-empty [ (csv) ] when ; + row + dup [ empty? ] all? [ drop ] [ , ] if + [ (csv) ] when ; PRIVATE> @@ -60,7 +62,8 @@ PRIVATE> [ row nip ] with-input-stream ; : csv ( stream -- rows ) - [ [ (csv) ] { } make ] with-input-stream ; + [ [ (csv) ] { } make ] with-input-stream + dup peek { "" } = [ but-last ] when ; : file>csv ( path encoding -- csv ) csv ; From eaaf2af7b77233698f41fc1388ec8462ab6e75cc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 01:39:14 -0600 Subject: [PATCH 120/168] Fixing db.sqlite bug: database schema don't need primary keys --- basis/db/sqlite/sqlite-tests.factor | 22 ++++++++++++++++++++++ basis/db/sqlite/sqlite.factor | 12 +++++++----- 2 files changed, 29 insertions(+), 5 deletions(-) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 6fb1cd19ad..69d5f1dd43 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -73,3 +73,25 @@ IN: db.sqlite.tests "select * from person" sql-query length ] with-db ] unit-test + +! You don't need a primary key +USING: accessors arrays sorting ; +TUPLE: things one two ; + +things "THINGS" { + { "one" "ONE" INTEGER +not-null+ } + { "two" "TWO" INTEGER +not-null+ } +} define-persistent + +[ { { 0 0 } { 0 1 } { 1 0 } { 1 1 } } ] [ + test.db [ + things create-table + 0 0 things boa insert-tuple + 0 1 things boa insert-tuple + 1 1 things boa insert-tuple + 1 0 things boa insert-tuple + f f things boa select-tuples + [ [ one>> ] [ two>> ] bi 2array ] map natural-sort + things drop-table + ] with-db +] unit-test diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index fe3bb64d45..9b05cf9825 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -138,11 +138,13 @@ M: sqlite-db-connection create-sql-statement ( class -- statement ) modifiers 0% ] interleave - ", " 0% - find-primary-key - "primary key(" 0% - [ "," 0% ] [ column-name>> 0% ] interleave - "));" 0% + find-primary-key [ + ", " 0% + "primary key(" 0% + [ "," 0% ] [ column-name>> 0% ] interleave + ")" 0% + ] unless-empty + ");" 0% ] query-make ; M: sqlite-db-connection drop-sql-statement ( class -- statement ) From dd57fe7a2310c58ce10ea8e53916dc0b9d593580 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 02:19:31 -0600 Subject: [PATCH 121/168] editors: better error message if definition does not have an associated source file when editing a word-link, go to the word itself if the word has no help --- basis/editors/editors.factor | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 53887bd353..d060a3dfe6 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser lexer kernel namespaces sequences definitions io.files io.backend io.pathnames io summary continuations tools.crossref tools.vocabs prettyprint source-files assocs -vocabs vocabs.loader splitting accessors ; +vocabs vocabs.loader splitting accessors debugger prettyprint +help.topics ; IN: editors TUPLE: no-edit-hook ; @@ -29,11 +30,21 @@ SYMBOL: edit-hook [ (normalize-path) ] dip edit-hook get-global [ call ] [ no-edit-hook edit-location ] if* ; +ERROR: cannot-find-source definition ; + +M: cannot-find-source error. + "Cannot find source for ``" write + definition>> pprint-short + "''" print ; + : edit ( defspec -- ) - where [ first2 edit-location ] when* ; + dup where + [ first2 edit-location ] + [ dup word-link? [ name>> edit ] [ cannot-find-source ] if ] + ?if ; : edit-vocab ( name -- ) - vocab-source-path 1 edit-location ; + >vocab-link edit ; GENERIC: error-file ( error -- file ) From 13af3b48019a91d27d32b30136f96865c7de6cad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 02:19:41 -0600 Subject: [PATCH 122/168] combinators.smart: add map-reduce-outputs --- basis/combinators/smart/smart-tests.factor | 4 +++- basis/combinators/smart/smart.factor | 6 ++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 69a3a821e5..1cca697dde 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -44,4 +44,6 @@ IN: combinators.smart.tests \ nested-smart-combo-test must-infer -[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test \ No newline at end of file +[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test + +[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test \ No newline at end of file diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index e93d84e394..e7bdd75ced 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -21,6 +21,12 @@ MACRO: reduce-outputs ( quot operation -- newquot ) : sum-outputs ( quot -- n ) [ + ] reduce-outputs ; inline +MACRO: map-reduce-outputs ( quot mapper reducer -- newquot ) + [ dup infer out>> ] 2dip + [ swap '[ _ _ napply ] ] + [ [ 1 [-] ] dip n*quot ] bi-curry* bi + '[ @ @ @ ] ; + MACRO: append-outputs-as ( quot exemplar -- newquot ) [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ; From 22205159470b9ea159dfb6209bc9609eb83e2a5e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 02:41:37 -0600 Subject: [PATCH 123/168] Re-organize images and images.backend into images and images.loader --- basis/images/backend/authors.txt | 1 - basis/images/backend/backend.factor | 51 ----------------- basis/images/bitmap/bitmap-tests.factor | 8 +-- basis/images/bitmap/bitmap.factor | 4 +- basis/images/images.factor | 52 +++++++++++++----- basis/images/loader/authors.txt | 1 + basis/images/loader/loader.factor | 21 +++++++ {extra => basis}/images/test-images/1bit.bmp | Bin .../images/test-images/octagon.tiff | Bin {extra => basis}/images/test-images/rgb.tiff | Bin .../images/test-images/rgb4bit.bmp | Bin .../images/test-images/rgb8bit.bmp | Bin .../images/test-images/thiswayup24.bmp | Bin basis/images/tiff/tiff.factor | 8 +-- extra/images/viewer/viewer.factor | 2 +- 15 files changed, 71 insertions(+), 77 deletions(-) delete mode 100644 basis/images/backend/authors.txt delete mode 100644 basis/images/backend/backend.factor create mode 100644 basis/images/loader/authors.txt create mode 100644 basis/images/loader/loader.factor rename {extra => basis}/images/test-images/1bit.bmp (100%) rename {extra => basis}/images/test-images/octagon.tiff (100%) rename {extra => basis}/images/test-images/rgb.tiff (100%) rename {extra => basis}/images/test-images/rgb4bit.bmp (100%) rename {extra => basis}/images/test-images/rgb8bit.bmp (100%) rename {extra => basis}/images/test-images/thiswayup24.bmp (100%) diff --git a/basis/images/backend/authors.txt b/basis/images/backend/authors.txt deleted file mode 100644 index b4bd0e7b35..0000000000 --- a/basis/images/backend/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman \ No newline at end of file diff --git a/basis/images/backend/backend.factor b/basis/images/backend/backend.factor deleted file mode 100644 index 756b98efee..0000000000 --- a/basis/images/backend/backend.factor +++ /dev/null @@ -1,51 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel grouping fry sequences combinators -math ; -IN: images.backend - -SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; - -TUPLE: image dim component-order bitmap ; - -TUPLE: normalized-image < image ; - -GENERIC: load-image* ( path tuple -- image ) - -GENERIC: >image ( object -- image ) - -: no-op ( -- ) ; - -: normalize-component-order ( image -- image ) - dup component-order>> - { - { RGBA [ no-op ] } - { BGRA [ - [ - [ 4 [ [ 0 3 ] dip reverse-here ] each ] - [ RGBA >>component-order ] bi - ] change-bitmap - ] } - { RGB [ - [ 3 [ 255 suffix ] map concat ] change-bitmap - ] } - { BGR [ - [ - 3 dup [ [ 0 3 ] dip reverse-here ] each - [ 255 suffix ] map concat - ] change-bitmap - ] } - } case RGBA >>component-order ; - -GENERIC: normalize-scan-line-order ( image -- image ) - -M: image normalize-scan-line-order ; -: normalize-image ( image -- image ) - normalize-component-order - normalize-scan-line-order ; - -: new-image ( dim component-order bitmap class -- image ) - new - swap >>bitmap - swap >>component-order - swap >>dim ; inline diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index a7deae3178..102c13c295 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -3,16 +3,16 @@ io.files io.files.unique kernel tools.test ; IN: images.bitmap.tests : test-bitmap24 ( -- path ) - "resource:extra/images/test-images/thiswayup24.bmp" ; + "resource:basis/images/test-images/thiswayup24.bmp" ; : test-bitmap8 ( -- path ) - "resource:extra/images/test-images/rgb8bit.bmp" ; + "resource:basis/images/test-images/rgb8bit.bmp" ; : test-bitmap4 ( -- path ) - "resource:extra/images/test-images/rgb4bit.bmp" ; + "resource:basis/images/test-images/rgb4bit.bmp" ; : test-bitmap1 ( -- path ) - "resource:extra/images/test-images/1bit.bmp" ; + "resource:basis/images/test-images/1bit.bmp" ; [ t ] [ diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 46f90e33f8..5530fa12b7 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns combinators fry grouping io io.binary io.encodings.binary io.files kernel libc macros math math.bitwise math.functions namespaces opengl opengl.gl prettyprint sequences strings -summary ui ui.gadgets.panes images.backend ; +summary ui ui.gadgets.panes images ; IN: images.bitmap TUPLE: bitmap-image < image ; @@ -102,7 +102,7 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -M: bitmap >image ( bitmap -- bitmap-image ) +: >image ( bitmap -- bitmap-image ) { [ [ width>> ] [ height>> ] bi 2array ] [ bitmap>component-order ] diff --git a/basis/images/images.factor b/basis/images/images.factor index 3df7b5d2d1..9f4d14e7bf 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,21 +1,45 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images.backend io.backend -io.pathnames ; IN: images -ERROR: unknown-image-extension extension ; +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; -: image-class ( path -- class ) - file-extension >lower { - { "bmp" [ bitmap-image ] } - { "tiff" [ tiff-image ] } - [ unknown-image-extension ] - } case ; +TUPLE: image dim component-order bitmap ; -: load-image ( path -- image ) - dup image-class new load-image* ; +GENERIC: load-image* ( path tuple -- image ) -: ( path -- image ) - load-image normalize-image ; +: normalize-component-order ( image -- image ) + dup component-order>> + { + { RGBA [ ] } + { BGRA [ + [ + [ 4 [ [ 0 3 ] dip reverse-here ] each ] + [ RGBA >>component-order ] bi + ] change-bitmap + ] } + { RGB [ + [ 3 [ 255 suffix ] map concat ] change-bitmap + ] } + { BGR [ + [ + 3 dup [ [ 0 3 ] dip reverse-here ] each + [ 255 suffix ] map concat + ] change-bitmap + ] } + } case + RGBA >>component-order ; + +GENERIC: normalize-scan-line-order ( image -- image ) + +M: image normalize-scan-line-order ; + +: normalize-image ( image -- image ) + normalize-component-order + normalize-scan-line-order ; + +: new-image ( dim component-order bitmap class -- image ) + new + swap >>bitmap + swap >>component-order + swap >>dim ; inline diff --git a/basis/images/loader/authors.txt b/basis/images/loader/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/images/loader/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor new file mode 100644 index 0000000000..7aeba9f24a --- /dev/null +++ b/basis/images/loader/loader.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: constructors kernel splitting unicode.case combinators +accessors images.bitmap images.tiff images io.backend +io.pathnames ; +IN: images.loader + +ERROR: unknown-image-extension extension ; + +: image-class ( path -- class ) + file-extension >lower { + { "bmp" [ bitmap-image ] } + { "tiff" [ tiff-image ] } + [ unknown-image-extension ] + } case ; + +: load-image ( path -- image ) + dup image-class new load-image* ; + +: ( path -- image ) + load-image normalize-image ; diff --git a/extra/images/test-images/1bit.bmp b/basis/images/test-images/1bit.bmp similarity index 100% rename from extra/images/test-images/1bit.bmp rename to basis/images/test-images/1bit.bmp diff --git a/extra/images/test-images/octagon.tiff b/basis/images/test-images/octagon.tiff similarity index 100% rename from extra/images/test-images/octagon.tiff rename to basis/images/test-images/octagon.tiff diff --git a/extra/images/test-images/rgb.tiff b/basis/images/test-images/rgb.tiff similarity index 100% rename from extra/images/test-images/rgb.tiff rename to basis/images/test-images/rgb.tiff diff --git a/extra/images/test-images/rgb4bit.bmp b/basis/images/test-images/rgb4bit.bmp similarity index 100% rename from extra/images/test-images/rgb4bit.bmp rename to basis/images/test-images/rgb4bit.bmp diff --git a/extra/images/test-images/rgb8bit.bmp b/basis/images/test-images/rgb8bit.bmp similarity index 100% rename from extra/images/test-images/rgb8bit.bmp rename to basis/images/test-images/rgb8bit.bmp diff --git a/extra/images/test-images/thiswayup24.bmp b/basis/images/test-images/thiswayup24.bmp similarity index 100% rename from extra/images/test-images/thiswayup24.bmp rename to basis/images/test-images/thiswayup24.bmp diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index dac071b4b4..c81d052a7f 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -3,7 +3,7 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian constructors sequences arrays math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays -grouping images.backend ; +grouping images ; IN: images.tiff TUPLE: tiff-image < image ; @@ -268,14 +268,14 @@ ERROR: unknown-component-order ifd ; [ unknown-component-order ] } case ; -M: ifd >image ( ifd -- image ) +: ifd>image ( ifd -- image ) { [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order ] [ bitmap>> ] } cleave tiff-image new-image ; -M: parsed-tiff >image ( image -- image ) +: tiff>image ( image -- image ) ifds>> [ >image ] map first ; : load-tiff ( path -- parsed-tiff ) @@ -289,4 +289,4 @@ M: parsed-tiff >image ( image -- image ) ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) - drop load-tiff >image ; + drop load-tiff tiff>image ; diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 92277dfdef..0795900150 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors images images.backend io.pathnames kernel +USING: accessors images images.loader io.pathnames kernel namespaces opengl opengl.gl sequences strings ui ui.gadgets ui.gadgets.panes ui.render ; IN: images.viewer From 7361bb90fa79283b6eea5b373e7b385382cc41e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 02:41:47 -0600 Subject: [PATCH 124/168] images: fix load errors --- basis/images/images.factor | 1 + basis/images/tiff/tiff.factor | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 9f4d14e7bf..5fdc9ee5e9 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,5 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors grouping sequences combinators ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c81d052a7f..dd4319a474 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -276,7 +276,7 @@ ERROR: unknown-component-order ifd ; } cleave tiff-image new-image ; : tiff>image ( image -- image ) - ifds>> [ >image ] map first ; + ifds>> [ ifd>image ] map first ; : load-tiff ( path -- parsed-tiff ) binary [ From 421631eebbe226c01f2cc8c3aecf5309cd1f55f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 04:16:08 -0600 Subject: [PATCH 125/168] bootstrap.image: update documentation (found by mnestic) --- basis/bootstrap/image/image-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/bootstrap/image/image-docs.factor b/basis/bootstrap/image/image-docs.factor index 3856382ffb..835c39c171 100644 --- a/basis/bootstrap/image/image-docs.factor +++ b/basis/bootstrap/image/image-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io io.files io.pathnames ; +USING: help.markup help.syntax io io.files io.pathnames strings ; IN: bootstrap.image ARTICLE: "bootstrap.image" "Bootstrapping new images" @@ -14,7 +14,7 @@ $nl ABOUT: "bootstrap.image" HELP: make-image -{ $values { "arch" "a string" } } +{ $values { "arch" string } } { $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:" -{ $code "x86.32" "x86.64" "ppc" "arm" } +{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" } "The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ; From a550c9874c2ffc9c1f43e59c989f2c1951f43d63 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 04:23:35 -0600 Subject: [PATCH 126/168] kernel: add {bi,tri}-curry{,*,@} combinators from new_ui branch --- core/kernel/kernel.factor | 111 ++++++++++++++++++++++---------------- 1 file changed, 65 insertions(+), 46 deletions(-) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index be1de76650..06fe289281 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel.private slots.private math.private classes.tuple.private ; @@ -51,7 +51,7 @@ DEFER: if ! Default : ?if ( default cond true false -- ) - pick [ roll 2drop call ] [ 2nip call ] if ; inline + pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline ! Slippers and dippers. ! Not declared inline because the compiler special-cases them @@ -138,6 +138,69 @@ DEFER: if : 2tri@ ( u v w y x z quot -- ) dup dup 2tri* ; inline +! Quotation building +: 2curry ( obj1 obj2 quot -- curry ) + curry curry ; inline + +: 3curry ( obj1 obj2 obj3 quot -- curry ) + curry curry curry ; inline + +: with ( param obj quot -- obj curry ) + swapd [ swapd call ] 2curry ; inline + +: prepose ( quot1 quot2 -- compose ) + swap compose ; inline + +! Curried cleavers + + +: bi-curry ( x p q -- p' q' ) [ [curry] ] bi@ bi ; inline + +: tri-curry ( x p q r -- p' q' r' ) [ [curry] ] tri@ tri ; inline + +: bi-curry* ( x y p q -- p' q' ) [ [curry] ] bi@ bi* ; inline + +: tri-curry* ( x y z p q r -- p' q' r' ) [ [curry] ] tri@ tri* ; inline + +: bi-curry@ ( x y q -- p' q' ) [curry] bi@ ; inline + +: tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline + +! Booleans +: not ( obj -- ? ) [ f ] [ t ] if ; inline + +: and ( obj1 obj2 -- ? ) over ? ; inline + +: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline + +: or ( obj1 obj2 -- ? ) dupd ? ; inline + +: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline + +: both? ( x y quot -- ? ) bi@ and ; inline + +: either? ( x y quot -- ? ) bi@ or ; inline + +: most ( x y quot -- z ) + [ 2dup ] dip call [ drop ] [ nip ] if ; inline + +! Loops +: loop ( pred: ( -- ? ) -- ) + [ call ] keep [ loop ] curry when ; inline recursive + +: do ( pred body tail -- pred body tail ) + over 3dip ; inline + +: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) + [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive + +: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) + [ [ not ] compose ] 2dip while ; inline + ! Object protocol GENERIC: hashcode* ( depth obj -- code ) @@ -171,50 +234,6 @@ GENERIC: new ( class -- tuple ) GENERIC: boa ( ... class -- tuple ) -! Quotation building -: 2curry ( obj1 obj2 quot -- curry ) - curry curry ; inline - -: 3curry ( obj1 obj2 obj3 quot -- curry ) - curry curry curry ; inline - -: with ( param obj quot -- obj curry ) - swapd [ swapd call ] 2curry ; inline - -: prepose ( quot1 quot2 -- compose ) - swap compose ; inline - -! Booleans -: not ( obj -- ? ) [ f ] [ t ] if ; inline - -: and ( obj1 obj2 -- ? ) over ? ; inline - -: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline - -: or ( obj1 obj2 -- ? ) dupd ? ; inline - -: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline - -: both? ( x y quot -- ? ) bi@ and ; inline - -: either? ( x y quot -- ? ) bi@ or ; inline - -: most ( x y quot -- z ) - [ 2dup ] dip call [ drop ] [ nip ] if ; inline - -! Loops -: loop ( pred: ( -- ? ) -- ) - dup slip swap [ loop ] [ drop ] if ; inline recursive - -: do ( pred body tail -- pred body tail ) - over 3dip ; inline - -: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) - [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive - -: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) - [ [ not ] compose ] 2dip while ; inline - ! Error handling -- defined early so that other files can ! throw errors before continuations are loaded : throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ; From cf9e7d1e75e748319123f5addaabc90f4594e50c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 04:25:33 -0600 Subject: [PATCH 127/168] Add byte-order slot to image tuple; rename to load-image, add for making images from scratch --- basis/images/bitmap/bitmap.factor | 10 +++++----- basis/images/images.factor | 10 +++------- basis/images/loader/loader.factor | 5 +---- basis/images/tiff/tiff.factor | 3 ++- extra/images/viewer/viewer.factor | 6 +++--- 5 files changed, 14 insertions(+), 20 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 5530fa12b7..c9bb15192b 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2007, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays byte-arrays columns -combinators fry grouping io io.binary io.encodings.binary -io.files kernel libc macros math math.bitwise math.functions -namespaces opengl opengl.gl prettyprint sequences strings -summary ui ui.gadgets.panes images ; +combinators fry grouping io io.binary io.encodings.binary io.files +kernel macros math math.bitwise math.functions namespaces sequences +strings images endian summary ; IN: images.bitmap TUPLE: bitmap-image < image ; @@ -106,8 +105,9 @@ ERROR: unknown-component-order bitmap ; { [ [ width>> ] [ height>> ] bi 2array ] [ bitmap>component-order ] + [ drop little-endian ] ! XXX [ buffer>> ] - } cleave bitmap-image new-image ; + } cleave bitmap-image boa ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap >image ; diff --git a/basis/images/images.factor b/basis/images/images.factor index 5fdc9ee5e9..a2d90cc131 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -5,7 +5,9 @@ IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; -TUPLE: image dim component-order bitmap ; +TUPLE: image dim component-order byte-order bitmap ; + +: ( -- image ) image new ; inline GENERIC: load-image* ( path tuple -- image ) @@ -38,9 +40,3 @@ M: image normalize-scan-line-order ; : normalize-image ( image -- image ) normalize-component-order normalize-scan-line-order ; - -: new-image ( dim component-order bitmap class -- image ) - new - swap >>bitmap - swap >>component-order - swap >>dim ; inline diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 7aeba9f24a..9e3f901269 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -15,7 +15,4 @@ ERROR: unknown-image-extension extension ; } case ; : load-image ( path -- image ) - dup image-class new load-image* ; - -: ( path -- image ) - load-image normalize-image ; + dup image-class new load-image* normalize-image ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index dd4319a474..b4daf675f1 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -272,8 +272,9 @@ ERROR: unknown-component-order ifd ; { [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order ] + [ drop big-endian ] ! XXX [ bitmap>> ] - } cleave tiff-image new-image ; + } cleave tiff-image boa ; : tiff>image ( image -- image ) ifds>> [ ifd>image ] map first ; diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index 0795900150..06e4c686f3 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -23,15 +23,15 @@ M: image-gadget draw-gadget* ( gadget -- ) swap >>image ; : image-window ( path -- gadget ) - [ dup ] [ open-window ] bi ; + [ load-image dup ] [ open-window ] bi ; GENERIC: image. ( object -- ) : default-image. ( path -- ) gadget. ; -M: string image. ( image -- ) default-image. ; +M: string image. ( image -- ) load-image default-image. ; -M: pathname image. ( image -- ) default-image. ; +M: pathname image. ( image -- ) load-image default-image. ; M: image image. ( image -- ) default-image. ; From facd455e9229d54a916781b1de30549913d61459 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 12 Feb 2009 06:25:07 -0600 Subject: [PATCH 128/168] Working on complex float support in FFI on NetBSD --- basis/alien/structs/structs.factor | 5 +++-- basis/compiler/alien/alien.factor | 2 +- basis/cpu/architecture/architecture.factor | 2 +- basis/cpu/ppc/ppc.factor | 2 +- basis/cpu/x86/32/32.factor | 9 ++++++--- basis/cpu/x86/64/unix/unix.factor | 2 +- basis/cpu/x86/64/winnt/winnt.factor | 3 ++- 7 files changed, 15 insertions(+), 10 deletions(-) diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 8ec694198d..9c28b71cc6 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -13,7 +13,8 @@ fields { boxer-quot callable } { unboxer-quot callable } { getter callable } -{ setter callable } ; +{ setter callable } +return-in-registers ; M: struct-type heap-size size>> ; @@ -37,7 +38,7 @@ M: struct-type box-parameter [ %box-large-struct ] [ box-parameter ] if-value-struct ; : if-small-struct ( c-type true false -- ? ) - [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline + [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline M: struct-type unbox-return [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index 4a41014ab2..59901cf79a 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -5,7 +5,7 @@ alien.c-types alien.structs cpu.architecture ; IN: compiler.alien : large-struct? ( ctype -- ? ) - dup c-struct? [ struct-small-enough? not ] [ drop f ] if ; + dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ; : alien-parameters ( params -- seq ) dup parameters>> diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 5670110f04..2c9675426b 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -152,7 +152,7 @@ HOOK: %loop-entry cpu ( -- ) HOOK: small-enough? cpu ( n -- ? ) ! Is this structure small enough to be returned in registers? -HOOK: struct-small-enough? cpu ( c-type -- ? ) +HOOK: return-struct-in-registers? cpu ( c-type -- ? ) ! Do we pass this struct by value or hidden reference? HOOK: value-struct? cpu ( c-type -- ? ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index b177c71d77..f245bcb7e1 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -659,7 +659,7 @@ M: ppc %callback-value ( ctype -- ) M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; -M: ppc struct-small-enough? ( size -- ? ) drop f ; +M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ; M: ppc %box-small-struct drop "No small structs" throw ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index affd39ffc5..c409cfb164 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -48,9 +48,12 @@ M: x86.32 %alien-invoke (CALL) rel-dlsym ; M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; -M: x86.32 struct-small-enough? ( size -- ? ) - heap-size { 1 2 4 8 } member? - os { linux netbsd solaris } member? not and ; +M: x86.32 return-struct-in-registers? ( c-type -- ? ) + c-type + [ return-in-registers?>> ] + [ heap-size { 1 2 4 8 } member? ] bi + os { linux netbsd solaris } member? not + and and ; : struct-return@ ( n -- operand ) [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ; diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index f5fb5b9640..eea960d03d 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -44,7 +44,7 @@ M: struct-type flatten-value-type ( type -- seq ) flatten-small-struct ] if ; -M: x86.64 struct-small-enough? ( size -- ? ) +M: x86.64 return-struct-in-registers? ( c-type -- ? ) heap-size 2 cells <= ; M: x86.64 dummy-stack-params? f ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 4c6af6c1e7..8091be65ae 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -10,7 +10,8 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ; M: x86.64 reserved-area-size 4 cells ; -M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ; +M: x86.64 return-struct-in-registers? ( c-type -- ? ) + heap-size { 1 2 4 8 } member? ; M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ; From 3c1ddde1f903f9feab002865bd6817677dbc9d23 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 12 Feb 2009 08:10:21 -0600 Subject: [PATCH 129/168] Fix complex float support on NetBSD --- basis/alien/complex/complex.factor | 11 +++++++++-- basis/alien/structs/structs.factor | 4 +++- basis/cpu/x86/32/32.factor | 2 +- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index 60a84b9394..079ad57aa5 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -1,6 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.complex.functor sequences kernel ; +USING: alien.c-types alien.complex.functor accessors +sequences kernel ; IN: alien.complex -<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >> \ No newline at end of file +<< +{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each + +! This overrides the fact that small structures are never returned +! in registers on NetBSD, Linux and Solaris running on 32-bit x86. +"complex-float" c-type t >>return-in-registers? drop + >> diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 9c28b71cc6..3e26e4fb39 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -14,7 +14,9 @@ fields { unboxer-quot callable } { getter callable } { setter callable } -return-in-registers ; +return-in-registers? ; + +M: struct-type c-type ; M: struct-type heap-size size>> ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index c409cfb164..f881792ac6 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -53,7 +53,7 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? ) [ return-in-registers?>> ] [ heap-size { 1 2 4 8 } member? ] bi os { linux netbsd solaris } member? not - and and ; + and or ; : struct-return@ ( n -- operand ) [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ; From 76ae3fd22448f7166e19f7f594f24794bed0c8ae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 08:39:52 -0600 Subject: [PATCH 130/168] Fix compile error in ui.render.test; images API changed... --- extra/ui/render/test/test.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor index dcbc5b9600..bd3c082652 100755 --- a/extra/ui/render/test/test.factor +++ b/extra/ui/render/test/test.factor @@ -4,7 +4,7 @@ USING: accessors colors arrays kernel sequences math byte-arrays namespaces grouping fry cap images.bitmap ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons -ui.render ui opengl opengl.gl images ; +ui.render ui opengl opengl.gl images images.loader ; IN: ui.render.test SINGLETON: line-test @@ -38,7 +38,7 @@ SYMBOL: render-output screenshot [ render-output set-global ] [ - "resource:extra/ui/render/test/reference.bmp" + "resource:extra/ui/render/test/reference.bmp" load-image bitmap= "is perfect" "needs work" ? "Your UI rendering " prepend message-window From 2c88d339d0c70fa965350a4d015d600fc0f5acff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 09:20:32 -0600 Subject: [PATCH 131/168] Improve type inference for struct returns --- basis/alien/structs/structs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index 8ec694198d..234ad64a34 100755 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry alien.c-types alien.structs.fields cpu.architecture math.order -quotations ; +quotations byte-arrays ; IN: alien.structs TUPLE: struct-type @@ -17,7 +17,7 @@ fields M: struct-type heap-size size>> ; -M: struct-type c-type-class drop object ; +M: struct-type c-type-class drop byte-array ; M: struct-type c-type-align align>> ; From 489bb32a9848baf04c336c03c08a16c0c445847e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Feb 2009 09:48:50 -0600 Subject: [PATCH 132/168] Fix potential load order issue with alien.complex; it used a slot defined in alien.structs but didn't reference that file by name --- basis/alien/complex/complex.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index 079ad57aa5..c80ead73f0 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.complex.functor accessors +USING: alien.c-types alien.structs alien.complex.functor accessors sequences kernel ; IN: alien.complex From d46764d34612c2232edd78a424d74080171bb7bc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 16:36:29 -0600 Subject: [PATCH 133/168] use CONSTANT: in db --- basis/db/postgresql/ffi/ffi.factor | 98 +++++++++++++++--------------- basis/db/sqlite/ffi/ffi.factor | 96 ++++++++++++++--------------- 2 files changed, 97 insertions(+), 97 deletions(-) diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor index 4358d7f3de..fc407b06bd 100644 --- a/basis/db/postgresql/ffi/ffi.factor +++ b/basis/db/postgresql/ffi/ffi.factor @@ -11,46 +11,46 @@ IN: db.postgresql.ffi } cond "cdecl" add-library >> ! ConnSatusType -: CONNECTION_OK HEX: 0 ; inline -: CONNECTION_BAD HEX: 1 ; inline -: CONNECTION_STARTED HEX: 2 ; inline -: CONNECTION_MADE HEX: 3 ; inline -: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline -: CONNECTION_AUTH_OK HEX: 5 ; inline -: CONNECTION_SETENV HEX: 6 ; inline -: CONNECTION_SSL_STARTUP HEX: 7 ; inline -: CONNECTION_NEEDED HEX: 8 ; inline +CONSTANT: CONNECTION_OK HEX: 0 +CONSTANT: CONNECTION_BAD HEX: 1 +CONSTANT: CONNECTION_STARTED HEX: 2 +CONSTANT: CONNECTION_MADE HEX: 3 +CONSTANT: CONNECTION_AWAITING_RESPONSE HEX: 4 +CONSTANT: CONNECTION_AUTH_OK HEX: 5 +CONSTANT: CONNECTION_SETENV HEX: 6 +CONSTANT: CONNECTION_SSL_STARTUP HEX: 7 +CONSTANT: CONNECTION_NEEDED HEX: 8 ! PostgresPollingStatusType -: PGRES_POLLING_FAILED HEX: 0 ; inline -: PGRES_POLLING_READING HEX: 1 ; inline -: PGRES_POLLING_WRITING HEX: 2 ; inline -: PGRES_POLLING_OK HEX: 3 ; inline -: PGRES_POLLING_ACTIVE HEX: 4 ; inline +CONSTANT: PGRES_POLLING_FAILED HEX: 0 +CONSTANT: PGRES_POLLING_READING HEX: 1 +CONSTANT: PGRES_POLLING_WRITING HEX: 2 +CONSTANT: PGRES_POLLING_OK HEX: 3 +CONSTANT: PGRES_POLLING_ACTIVE HEX: 4 ! ExecStatusType; -: PGRES_EMPTY_QUERY HEX: 0 ; inline -: PGRES_COMMAND_OK HEX: 1 ; inline -: PGRES_TUPLES_OK HEX: 2 ; inline -: PGRES_COPY_OUT HEX: 3 ; inline -: PGRES_COPY_IN HEX: 4 ; inline -: PGRES_BAD_RESPONSE HEX: 5 ; inline -: PGRES_NONFATAL_ERROR HEX: 6 ; inline -: PGRES_FATAL_ERROR HEX: 7 ; inline +CONSTANT: PGRES_EMPTY_QUERY HEX: 0 +CONSTANT: PGRES_COMMAND_OK HEX: 1 +CONSTANT: PGRES_TUPLES_OK HEX: 2 +CONSTANT: PGRES_COPY_OUT HEX: 3 +CONSTANT: PGRES_COPY_IN HEX: 4 +CONSTANT: PGRES_BAD_RESPONSE HEX: 5 +CONSTANT: PGRES_NONFATAL_ERROR HEX: 6 +CONSTANT: PGRES_FATAL_ERROR HEX: 7 ! PGTransactionStatusType; -: PQTRANS_IDLE HEX: 0 ; inline -: PQTRANS_ACTIVE HEX: 1 ; inline -: PQTRANS_INTRANS HEX: 2 ; inline -: PQTRANS_INERROR HEX: 3 ; inline -: PQTRANS_UNKNOWN HEX: 4 ; inline +CONSTANT: PQTRANS_IDLE HEX: 0 +CONSTANT: PQTRANS_ACTIVE HEX: 1 +CONSTANT: PQTRANS_INTRANS HEX: 2 +CONSTANT: PQTRANS_INERROR HEX: 3 +CONSTANT: PQTRANS_UNKNOWN HEX: 4 ! PGVerbosity; -: PQERRORS_TERSE HEX: 0 ; inline -: PQERRORS_DEFAULT HEX: 1 ; inline -: PQERRORS_VERBOSE HEX: 2 ; inline +CONSTANT: PQERRORS_TERSE HEX: 0 +CONSTANT: PQERRORS_DEFAULT HEX: 1 +CONSTANT: PQERRORS_VERBOSE HEX: 2 -: InvalidOid 0 ; inline +CONSTANT: InvalidOid 0 TYPEDEF: int ConnStatusType TYPEDEF: int ExecStatusType @@ -348,21 +348,21 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ; FUNCTION: int PQenv2encoding ( ) ; ! From git, include/catalog/pg_type.h -: BOOL-OID 16 ; inline -: BYTEA-OID 17 ; inline -: CHAR-OID 18 ; inline -: NAME-OID 19 ; inline -: INT8-OID 20 ; inline -: INT2-OID 21 ; inline -: INT4-OID 23 ; inline -: TEXT-OID 23 ; inline -: OID-OID 26 ; inline -: FLOAT4-OID 700 ; inline -: FLOAT8-OID 701 ; inline -: VARCHAR-OID 1043 ; inline -: DATE-OID 1082 ; inline -: TIME-OID 1083 ; inline -: TIMESTAMP-OID 1114 ; inline -: TIMESTAMPTZ-OID 1184 ; inline -: INTERVAL-OID 1186 ; inline -: NUMERIC-OID 1700 ; inline +CONSTANT: BOOL-OID 16 +CONSTANT: BYTEA-OID 17 +CONSTANT: CHAR-OID 18 +CONSTANT: NAME-OID 19 +CONSTANT: INT8-OID 20 +CONSTANT: INT2-OID 21 +CONSTANT: INT4-OID 23 +CONSTANT: TEXT-OID 23 +CONSTANT: OID-OID 26 +CONSTANT: FLOAT4-OID 700 +CONSTANT: FLOAT8-OID 701 +CONSTANT: VARCHAR-OID 1043 +CONSTANT: DATE-OID 1082 +CONSTANT: TIME-OID 1083 +CONSTANT: TIMESTAMP-OID 1114 +CONSTANT: TIMESTAMPTZ-OID 1184 +CONSTANT: INTERVAL-OID 1186 +CONSTANT: NUMERIC-OID 1700 diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index 9f033a1d3c..341995634e 100644 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -13,33 +13,33 @@ IN: db.sqlite.ffi } cond "cdecl" add-library >> ! Return values from sqlite functions -: SQLITE_OK 0 ; inline ! Successful result -: SQLITE_ERROR 1 ; inline ! SQL error or missing database -: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite -: SQLITE_PERM 3 ; inline ! Access permission denied -: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort -: SQLITE_BUSY 5 ; inline ! The database file is locked -: SQLITE_LOCKED 6 ; inline ! A table in the database is locked -: SQLITE_NOMEM 7 ; inline ! A malloc() failed -: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database -: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt() -: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred -: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed -: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found -: SQLITE_FULL 13 ; inline ! Insertion failed because database is full -: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file -: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error -: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty -: SQLITE_SCHEMA 17 ; inline ! The database schema changed -: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table -: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation -: SQLITE_MISMATCH 20 ; inline ! Data type mismatch -: SQLITE_MISUSE 21 ; inline ! Library used incorrectly -: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host -: SQLITE_AUTH 23 ; inline ! Authorization denied -: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error -: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range -: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file +CONSTANT: SQLITE_OK 0 ! Successful result +CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database +CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite +CONSTANT: SQLITE_PERM 3 ! Access permission denied +CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort +CONSTANT: SQLITE_BUSY 5 ! The database file is locked +CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked +CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed +CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database +CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt() +CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred +CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed +CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found +CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full +CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file +CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error +CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty +CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed +CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table +CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation +CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch +CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly +CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host +CONSTANT: SQLITE_AUTH 23 ! Authorization denied +CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error +CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range +CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file : sqlite-error-messages ( -- seq ) { "Successful result" @@ -72,32 +72,32 @@ IN: db.sqlite.ffi } ; ! Return values from sqlite3_step -: SQLITE_ROW 100 ; inline -: SQLITE_DONE 101 ; inline +CONSTANT: SQLITE_ROW 100 +CONSTANT: SQLITE_DONE 101 ! Return values from the sqlite3_column_type function -: SQLITE_INTEGER 1 ; inline -: SQLITE_FLOAT 2 ; inline -: SQLITE_TEXT 3 ; inline -: SQLITE_BLOB 4 ; inline -: SQLITE_NULL 5 ; inline +CONSTANT: SQLITE_INTEGER 1 +CONSTANT: SQLITE_FLOAT 2 +CONSTANT: SQLITE_TEXT 3 +CONSTANT: SQLITE_BLOB 4 +CONSTANT: SQLITE_NULL 5 ! Values for the 'destructor' parameter of the 'bind' routines. -: SQLITE_STATIC 0 ; inline -: SQLITE_TRANSIENT -1 ; inline +CONSTANT: SQLITE_STATIC 0 +CONSTANT: SQLITE_TRANSIENT -1 -: SQLITE_OPEN_READONLY HEX: 00000001 ; inline -: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline -: SQLITE_OPEN_CREATE HEX: 00000004 ; inline -: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline -: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline -: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline -: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline -: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline -: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline -: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline -: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline -: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline +CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001 +CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002 +CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004 +CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 +CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 +CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100 +CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200 +CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 +CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 +CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 +CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 +CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 TYPEDEF: void sqlite3 TYPEDEF: void sqlite3_stmt From 1f6c50fd9192a2614d88830c5c04eb0d18cab1e3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 16:40:45 -0600 Subject: [PATCH 134/168] use constant in tar, remove ignore-errors --- extra/tar/tar.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index a4413c07b3..37c022fe43 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -5,8 +5,8 @@ system tools.hexdump io.encodings.binary summary accessors io.backend byte-arrays ; IN: tar -: zero-checksum 256 ; inline -: block-size 512 ; inline +CONSTANT: zero-checksum 256 +CONSTANT: block-size 512 TUPLE: tar-header name mode uid gid size mtime checksum typeflag linkname magic version uname gname devmajor devminor prefix ; @@ -89,8 +89,7 @@ M: unknown-typeflag summary ( obj -- str ) ! Symlink : typeflag-2 ( header -- ) - [ name>> ] [ linkname>> ] bi - [ make-link ] 2curry ignore-errors ; + [ name>> ] [ linkname>> ] bi make-link ; ! character special : typeflag-3 ( header -- ) unknown-typeflag ; From c4f45e3f74687bf705143a39fd0e861ed7d81dba Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 17:13:01 -0600 Subject: [PATCH 135/168] Fixing bug in db (don't use unparse!), adding still-failing unit test --- basis/db/queries/queries.factor | 2 +- basis/db/sqlite/sqlite-tests.factor | 23 +++++++++++++++++++++++ basis/db/types/types.factor | 2 +- 3 files changed, 25 insertions(+), 2 deletions(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 495c25ea68..c714f43687 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -48,7 +48,7 @@ M: retryable execute-statement* ( statement type -- ) : query-make ( class quot -- statements ) #! query, input, outputs, secondary queries - over unparse "table" set + over db-table "table" set [ sql-props ] dip [ 0 sql-counter rot with-variable ] curry { "" { } { } { } } nmake diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 69d5f1dd43..657415c048 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -95,3 +95,26 @@ things "THINGS" { things drop-table ] with-db ] unit-test + +! Tables can have different names than the name of the tuple +TUPLE: foo slot ; +C: foo +foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent + +TUPLE: hi bye ; +C: hi +hi "HELLO" +{ { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } } } define-persistent + +[ T{ foo { slot 1 } } T{ hi { bye 1 } } ] [ + test.db [ + foo create-table + hi create-table + 1 insert-tuple + f select-tuple + 1 insert-tuple + f select-tuple + hi drop-table + foo drop-table + ] with-db +] unit-test diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index b5a7db987a..51e4b42bdc 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -165,7 +165,7 @@ ERROR: no-column column ; : >reference-string ( string pair -- string ) first2 - [ [ unparse " " glue ] [ db-columns ] bi ] dip + [ [ db-table " " glue ] [ db-columns ] bi ] dip swap [ column-name>> = ] with find nip [ no-column ] unless* column-name>> "(" ")" surround append ; From 8993e0536b2d1e3c5fdbdcd67707bb2388c53c81 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 17:29:31 -0600 Subject: [PATCH 136/168] rename db-table to db-table-name, use db-table-name instead of class name in creating triggers for sqlite --- basis/db/queries/queries.factor | 4 +-- basis/db/sqlite/sqlite.factor | 48 ++++++++++++++++----------------- basis/db/types/types.factor | 4 +-- 3 files changed, 28 insertions(+), 28 deletions(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index c714f43687..2730340bfc 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -44,11 +44,11 @@ M: retryable execute-statement* ( statement type -- ) ] bi attempt-all drop ; : sql-props ( class -- columns table ) - [ db-columns ] [ db-table ] bi ; + [ db-columns ] [ db-table-name ] bi ; : query-make ( class quot -- statements ) #! query, input, outputs, secondary queries - over db-table "table" set + over db-table-name "table-name" set [ sql-props ] dip [ 0 sql-counter rot with-variable ] curry { "" { } { } { } } nmake diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 9b05cf9825..d006145ea8 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -225,11 +225,11 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger ( -- string ) [ <" - CREATE TRIGGER fki_${table}_${foreign-table}_id - BEFORE INSERT ON ${table} + CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id + BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -237,12 +237,12 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger-not-null ( -- string ) [ <" - CREATE TRIGGER fki_${table}_${foreign-table}_id - BEFORE INSERT ON ${table} + CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id + BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') WHERE NEW.${foreign-table-id} IS NOT NULL - AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -250,11 +250,11 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : update-trigger ( -- string ) [ <" - CREATE TRIGGER fku_${table}_${foreign-table}_id - BEFORE UPDATE ON ${table} + CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id + BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -262,12 +262,12 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : update-trigger-not-null ( -- string ) [ <" - CREATE TRIGGER fku_${table}_${foreign-table}_id - BEFORE UPDATE ON ${table} + CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id + BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') WHERE NEW.${foreign-table-id} IS NOT NULL - AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; "> interpolate ] with-string-writer ; @@ -275,11 +275,11 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : delete-trigger-restrict ( -- string ) [ <" - CREATE TRIGGER fkd_${table}_${foreign-table}_id - BEFORE DELETE ON ${foreign-table} + CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id + BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN - SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"') - WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; + SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; END; "> interpolate ] with-string-writer ; @@ -287,10 +287,10 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : delete-trigger-cascade ( -- string ) [ <" - CREATE TRIGGER fkd_${table}_${foreign-table}_id - BEFORE DELETE ON ${foreign-table} + CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id + BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN - DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id}; + DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id}; END; "> interpolate ] with-string-writer ; @@ -323,7 +323,7 @@ M: sqlite-db-connection compound ( string seq -- new-string ) { "default" [ first number>string " " glue ] } { "references" [ [ >reference-string ] keep - first2 [ "foreign-table" set ] + first2 [ db-table-name "foreign-table-name" set ] [ "foreign-table-id" set ] bi* create-sqlite-triggers ] } diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 51e4b42bdc..e39a5977ef 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -49,7 +49,7 @@ ERROR: no-slot ; ERROR: not-persistent class ; -: db-table ( class -- object ) +: db-table-name ( class -- object ) dup "db-table" word-prop [ ] [ not-persistent ] ?if ; : db-columns ( class -- object ) @@ -165,7 +165,7 @@ ERROR: no-column column ; : >reference-string ( string pair -- string ) first2 - [ [ db-table " " glue ] [ db-columns ] bi ] dip + [ [ db-table-name " " glue ] [ db-columns ] bi ] dip swap [ column-name>> = ] with find nip [ no-column ] unless* column-name>> "(" ")" surround append ; From 745e011ccc11d25e97937fcb8678f2db0f6fc5f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 17:44:04 -0600 Subject: [PATCH 137/168] add lzw compression --- basis/compression/lzw/authors.txt | 1 + basis/compression/lzw/lzw-tests.factor | 10 ++ basis/compression/lzw/lzw.factor | 190 +++++++++++++++++++++++++ 3 files changed, 201 insertions(+) create mode 100644 basis/compression/lzw/authors.txt create mode 100644 basis/compression/lzw/lzw-tests.factor create mode 100644 basis/compression/lzw/lzw.factor diff --git a/basis/compression/lzw/authors.txt b/basis/compression/lzw/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/compression/lzw/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor new file mode 100644 index 0000000000..6cb41b97a0 --- /dev/null +++ b/basis/compression/lzw/lzw-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors tools.test compression.lzw ; +IN: compression.lzw.tests + +[ V{ 7 258 8 8 258 6 } ] +[ B{ 7 7 7 8 8 7 7 6 6 } lzw-compress output>> ] unit-test + +[ B{ 7 7 7 8 8 7 7 6 6 } ] +[ V{ 7 258 8 8 258 6 } lzw-uncompress output>> ] unit-test diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor new file mode 100644 index 0000000000..fe24e97007 --- /dev/null +++ b/basis/compression/lzw/lzw.factor @@ -0,0 +1,190 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs bitstreams byte-vectors combinators io +io.encodings.binary io.streams.byte-array kernel math sequences +vectors ; +IN: compression.lzw + +CONSTANT: clear-code 256 +CONSTANT: end-of-information 257 + +TUPLE: lzw input output end-of-input? table count k omega omega-k #bits +code old-code ; + +SYMBOL: table-full + +ERROR: index-too-big n ; + +: lzw-bit-width ( n -- n' ) + { + { [ dup 510 <= ] [ drop 9 ] } + { [ dup 1022 <= ] [ drop 10 ] } + { [ dup 2046 <= ] [ drop 11 ] } + { [ dup 4094 <= ] [ drop 12 ] } + [ drop table-full ] + } cond ; + +: lzw-bit-width-compress ( lzw -- n ) + count>> lzw-bit-width ; + +: lzw-bit-width-uncompress ( lzw -- n ) + table>> length lzw-bit-width ; + +: initial-compress-table ( -- assoc ) + 258 iota [ [ 1vector ] keep ] H{ } map>assoc ; + +: initial-uncompress-table ( -- seq ) + 258 iota [ 1vector ] V{ } map-as ; + +: reset-lzw ( lzw -- lzw ) + 257 >>count + V{ } clone >>omega + V{ } clone >>omega-k + 9 >>#bits ; + +: reset-lzw-compress ( lzw -- lzw ) + f >>k + initial-compress-table >>table reset-lzw ; + +: reset-lzw-uncompress ( lzw -- lzw ) + initial-uncompress-table >>table reset-lzw ; + +: ( input -- obj ) + lzw new + swap >>input + binary >>output + reset-lzw-compress ; + +: ( input -- obj ) + lzw new + swap >>input + BV{ } clone >>output + reset-lzw-uncompress ; + +: push-k ( lzw -- lzw ) + [ ] + [ k>> ] + [ omega>> clone [ push ] keep ] tri >>omega-k ; + +: omega-k-in-table? ( lzw -- ? ) + [ omega-k>> ] [ table>> ] bi key? ; + +ERROR: not-in-table ; + +: write-output ( lzw -- ) + [ + [ omega>> ] [ table>> ] bi at* [ not-in-table ] unless + ] [ + [ lzw-bit-width-compress ] + [ output>> write-bits ] bi + ] bi ; + +: omega-k>omega ( lzw -- lzw ) + dup omega-k>> clone >>omega ; + +: k>omega ( lzw -- lzw ) + dup k>> 1vector >>omega ; + +: add-omega-k ( lzw -- ) + [ [ 1+ ] change-count count>> ] + [ omega-k>> clone ] + [ table>> ] tri set-at ; + +: lzw-compress-char ( lzw k -- ) + >>k push-k dup omega-k-in-table? [ + omega-k>omega drop + ] [ + [ write-output ] + [ add-omega-k ] + [ k>omega drop ] tri + ] if ; + +: (lzw-compress-chars) ( lzw -- ) + dup lzw-bit-width-compress table-full = [ + drop + ] [ + dup input>> stream-read1 + [ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ] + [ t >>end-of-input? drop ] if* + ] if ; + +: lzw-compress-chars ( lzw -- ) + { + [ [ clear-code lzw-compress-char ] [ reset-lzw-compress drop ] bi ] + [ (lzw-compress-chars) ] + [ end-of-information lzw-compress-char ] + [ ] + } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; + +: lzw-compress ( byte-array -- seq ) + binary + [ lzw-compress-chars ] [ output>> stream>> ] bi ; + +: lookup-old-code ( lzw -- vector ) + [ old-code>> ] [ table>> ] bi nth ; + +: lookup-code ( lzw -- vector ) + [ code>> ] [ table>> ] bi nth ; + +: code-in-table? ( lzw -- ? ) + [ code>> ] [ table>> length ] bi < ; + +: code>old-code ( lzw -- lzw ) + dup code>> >>old-code ; + +: write-code ( lzw -- ) + [ lookup-code ] [ output>> ] bi push-all ; + +: add-to-table ( seq lzw -- ) table>> push ; + +: lzw-read ( lzw -- lzw n ) + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits ; + +DEFER: lzw-uncompress-char +: handle-clear-code ( lzw -- ) + reset-lzw-uncompress + lzw-read dup end-of-information = [ + 2drop + ] [ + >>code + [ write-code ] + [ code>old-code ] bi + lzw-uncompress-char + ] if ; + +: handle-uncompress-code ( lzw -- lzw ) + dup code-in-table? [ + [ write-code ] + [ + [ + [ lookup-old-code ] + [ lookup-code first ] bi suffix + ] [ add-to-table ] bi + ] [ code>old-code ] tri + ] [ + [ + [ lookup-old-code dup first suffix ] keep + [ output>> push-all ] [ add-to-table ] 2bi + ] [ code>old-code ] bi + ] if ; + +: lzw-uncompress-char ( lzw -- ) + lzw-read [ + >>code + dup code>> end-of-information = [ + drop + ] [ + dup code>> clear-code = [ + handle-clear-code + ] [ + handle-uncompress-code + lzw-uncompress-char + ] if + ] if + ] [ + drop + ] if* ; + +: lzw-uncompress ( seq -- byte-array ) + binary + [ lzw-uncompress-char ] [ output>> ] bi ; From 6ffe298189c5c16d0515b696a8d1d6fa0aec57d9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 17:44:15 -0600 Subject: [PATCH 138/168] support lzw uncompression in images.tiff --- basis/images/images.factor | 3 +-- basis/images/tiff/tiff.factor | 22 ++++++++++++++++++++-- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index a2d90cc131..46c0936644 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -17,8 +17,7 @@ GENERIC: load-image* ( path tuple -- image ) { RGBA [ ] } { BGRA [ [ - [ 4 [ [ 0 3 ] dip reverse-here ] each ] - [ RGBA >>component-order ] bi + 4 dup [ [ 0 3 ] dip reverse-here ] each ] change-bitmap ] } { RGB [ diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index b4daf675f1..0b749d0ade 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -3,7 +3,7 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian constructors sequences arrays math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays -grouping images ; +grouping images compression.lzw fry ; IN: images.tiff TUPLE: tiff-image < image ; @@ -256,6 +256,20 @@ ERROR: bad-small-ifd-type n ; dup ifd-entries>> [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; +ERROR: unhandled-compression compression ; + +: (uncompress-strips) ( strips compression -- uncompressed-strips ) + { + { compression-none [ ] } + { compression-lzw [ [ lzw-uncompress ] map ] } + [ unhandled-compression ] + } case ; + +: uncompress-strips ( ifd -- ifd ) + dup '[ + _ compression find-tag (uncompress-strips) + ] change-strips ; + : strips>bitmap ( ifd -- ifd ) dup strips>> concat >>bitmap ; @@ -284,7 +298,11 @@ ERROR: unknown-component-order ifd ; read-header dup endianness>> [ read-ifds - dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each + dup ifds>> [ + process-ifd read-strips + uncompress-strips + strips>bitmap drop + ] each ] with-endianness ] with-file-reader ; From 18276a863b81aeca6d6f8fcd6bca29c78f21ac98 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 17:44:43 -0600 Subject: [PATCH 139/168] initial bitstreams checkin --- basis/bitstreams/authors.txt | 1 + basis/bitstreams/bitstreams-tests.factor | 31 +++++++++ basis/bitstreams/bitstreams.factor | 87 ++++++++++++++++++++++++ 3 files changed, 119 insertions(+) create mode 100644 basis/bitstreams/authors.txt create mode 100644 basis/bitstreams/bitstreams-tests.factor create mode 100644 basis/bitstreams/bitstreams.factor diff --git a/basis/bitstreams/authors.txt b/basis/bitstreams/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/bitstreams/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor new file mode 100644 index 0000000000..8fac3f52f9 --- /dev/null +++ b/basis/bitstreams/bitstreams-tests.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors bitstreams io io.streams.string kernel tools.test +grouping compression.lzw multiline ; +IN: bitstreams.tests + +[ 1 ] +[ B{ 254 } read-bit ] unit-test + +[ 254 ] +[ B{ 254 } 8 swap read-bits ] unit-test + +[ 4095 ] +[ B{ 255 255 } 12 swap read-bits ] unit-test + +[ B{ 254 } ] +[ + 254 8 rot + [ write-bits ] keep stream>> >byte-array +] unit-test + + +/* +[ + +] [ + B{ 7 7 7 8 8 7 7 9 7 } + [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ] + [ lzw-compress ] bi +] unit-test +*/ diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor new file mode 100644 index 0000000000..ae980795bc --- /dev/null +++ b/basis/bitstreams/bitstreams.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays destructors fry io kernel locals +math sequences ; +IN: bitstreams + +TUPLE: bitstream stream current-bits #bits disposed ; +TUPLE: bitstream-reader < bitstream ; + +: reset-bitstream ( stream -- stream ) + 0 >>#bits 0 >>current-bits ; inline + +: new-bitstream ( stream class -- bitstream ) + new + swap >>stream + reset-bitstream ; inline + +M: bitstream-reader dispose ( stream -- ) + stream>> dispose ; + +: ( stream -- bitstream ) + bitstream-reader new-bitstream ; inline + +: read-next-byte ( bitstream -- bitstream ) + dup stream>> stream-read1 + [ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline + +: maybe-read-next-byte ( bitstream -- bitstream ) + dup #bits>> 0 = [ read-next-byte ] when ; inline + +: shift-one-bit ( bitstream -- n ) + [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline + +: next-bit ( bitstream -- n ) + maybe-read-next-byte [ + shift-one-bit + ] [ + [ 1- ] change-#bits maybe-read-next-byte drop + ] bi ; inline + +: read-bit ( bitstream -- n ) + dup #bits>> 1 = [ + [ current-bits>> 1 bitand ] + [ read-next-byte drop ] bi + ] [ + next-bit + ] if ; inline + +: bits>integer ( seq -- n ) + 0 [ [ 1 shift ] dip bitor ] reduce ; inline + +: read-bits ( width bitstream -- n ) + '[ _ read-bit ] replicate bits>integer ; inline + + +TUPLE: bitstream-writer < bitstream ; + +: ( stream -- bitstream ) + bitstream-writer new-bitstream ; inline + +: write-bit ( n bitstream -- ) + [ 1 shift bitor ] change-current-bits + [ 1+ ] change-#bits + dup #bits>> 8 = [ + [ [ current-bits>> ] [ stream>> stream-write1 ] bi ] + [ reset-bitstream drop ] bi + ] [ + drop + ] if ; inline + +ERROR: invalid-bit-width n ; + +:: write-bits ( n width bitstream -- ) + n 0 < [ n invalid-bit-width ] when + n 0 = [ + width [ 0 bitstream write-bit ] times + ] [ + width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times + n-length [ + n-length swap - 1- neg n swap shift 1 bitand + bitstream write-bit + ] each + ] if ; + +: flush-bits ( bitstream -- ) stream>> stream-flush ; + +: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ; From 81d0f52e32d96b5d699608f9332d8d3010252d95 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 21:43:25 -0600 Subject: [PATCH 140/168] remove bad lzw tests, real tests still to come.. --- basis/compression/lzw/lzw-tests.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor index 6cb41b97a0..698e35d87e 100644 --- a/basis/compression/lzw/lzw-tests.factor +++ b/basis/compression/lzw/lzw-tests.factor @@ -2,9 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors tools.test compression.lzw ; IN: compression.lzw.tests - -[ V{ 7 258 8 8 258 6 } ] -[ B{ 7 7 7 8 8 7 7 6 6 } lzw-compress output>> ] unit-test - -[ B{ 7 7 7 8 8 7 7 6 6 } ] -[ V{ 7 258 8 8 258 6 } lzw-uncompress output>> ] unit-test From 127ff76c085959ae0e4284016643894d7550d0b7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 21:45:34 -0600 Subject: [PATCH 141/168] add using --- basis/bitstreams/bitstreams-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 8fac3f52f9..2aadf7b02d 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors bitstreams io io.streams.string kernel tools.test -grouping compression.lzw multiline ; +grouping compression.lzw multiline byte-arrays ; IN: bitstreams.tests [ 1 ] @@ -16,7 +16,7 @@ IN: bitstreams.tests [ B{ 254 } ] [ 254 8 rot - [ write-bits ] keep stream>> >byte-array + [ write-bits ] keep output>> >byte-array ] unit-test From d09567e31eb83a378d7902a9b70b2a34030379ee Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 21:59:59 -0600 Subject: [PATCH 142/168] Failing test case for db.sqlite --- basis/db/sqlite/sqlite-tests.factor | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 657415c048..e05d992014 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -101,20 +101,29 @@ TUPLE: foo slot ; C: foo foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent -TUPLE: hi bye ; +TUPLE: hi bye try ; C: hi -hi "HELLO" -{ { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } } } define-persistent +hi "HELLO" { + { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } } + { "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } } +} define-persistent -[ T{ foo { slot 1 } } T{ hi { bye 1 } } ] [ +[ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } ] [ test.db [ foo create-table hi create-table 1 insert-tuple f select-tuple - 1 insert-tuple + 1 1 insert-tuple f select-tuple hi drop-table foo drop-table ] with-db ] unit-test + +[ ] [ + test.db [ + hi create-table + hi drop-table + ] with-db +] unit-test From b5cb425708166bce4c86479c57dee27290131812 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:10:32 -0600 Subject: [PATCH 143/168] new bitstream api works, refactor time --- basis/bitstreams/bitstreams-tests.factor | 24 +++++++--------- basis/bitstreams/bitstreams.factor | 35 +++++++++++++++--------- 2 files changed, 32 insertions(+), 27 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 2aadf7b02d..d55910b131 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -1,31 +1,27 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors bitstreams io io.streams.string kernel tools.test -grouping compression.lzw multiline byte-arrays ; +grouping compression.lzw multiline byte-arrays io.encodings.binary +io.streams.byte-array ; IN: bitstreams.tests -[ 1 ] +[ 1 t ] [ B{ 254 } read-bit ] unit-test -[ 254 ] +[ 254 8 t ] [ B{ 254 } 8 swap read-bits ] unit-test -[ 4095 ] +[ 4095 12 t ] [ B{ 255 255 } 12 swap read-bits ] unit-test [ B{ 254 } ] [ 254 8 rot - [ write-bits ] keep output>> >byte-array + [ write-bits ] keep stream>> >byte-array ] unit-test +[ 255 8 t ] +[ B{ 255 } binary 8 swap read-bits ] unit-test -/* -[ - -] [ - B{ 7 7 7 8 8 7 7 9 7 } - [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ] - [ lzw-compress ] bi -] unit-test -*/ +[ 255 8 f ] +[ B{ 255 } binary 9 swap read-bits ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index ae980795bc..7113b650fd 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -4,7 +4,7 @@ USING: accessors byte-arrays destructors fry io kernel locals math sequences ; IN: bitstreams -TUPLE: bitstream stream current-bits #bits disposed ; +TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ; TUPLE: bitstream-reader < bitstream ; : reset-bitstream ( stream -- stream ) @@ -22,8 +22,12 @@ M: bitstream-reader dispose ( stream -- ) bitstream-reader new-bitstream ; inline : read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 - [ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline + dup stream>> stream-read1 [ + >>current-bits 8 >>#bits + ] [ + 0 >>#bits + t >>end-of-stream? + ] if* ; : maybe-read-next-byte ( bitstream -- bitstream ) dup #bits>> 0 = [ read-next-byte ] when ; inline @@ -31,17 +35,19 @@ M: bitstream-reader dispose ( stream -- ) : shift-one-bit ( bitstream -- n ) [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline -: next-bit ( bitstream -- n ) - maybe-read-next-byte [ - shift-one-bit +: next-bit ( bitstream -- n/f ? ) + maybe-read-next-byte + dup end-of-stream?>> [ + drop f ] [ - [ 1- ] change-#bits maybe-read-next-byte drop - ] bi ; inline + [ shift-one-bit ] + [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi + ] if dup >boolean ; -: read-bit ( bitstream -- n ) +: read-bit ( bitstream -- n ? ) dup #bits>> 1 = [ [ current-bits>> 1 bitand ] - [ read-next-byte drop ] bi + [ read-next-byte drop ] bi t ] [ next-bit ] if ; inline @@ -49,9 +55,12 @@ M: bitstream-reader dispose ( stream -- ) : bits>integer ( seq -- n ) 0 [ [ 1 shift ] dip bitor ] reduce ; inline -: read-bits ( width bitstream -- n ) - '[ _ read-bit ] replicate bits>integer ; inline - +: read-bits ( width bitstream -- n width ? ) + [ + '[ _ read-bit drop ] replicate + [ f = ] trim-tail + [ bits>integer ] [ length ] bi + ] 2keep drop over = ; TUPLE: bitstream-writer < bitstream ; From 12ee26566ea3abe8b039d6c4420c08a2c54e9ed6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:11:11 -0600 Subject: [PATCH 144/168] working on lzw compression --- basis/compression/lzw/lzw.factor | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index fe24e97007..67248474d3 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -110,9 +110,23 @@ ERROR: not-in-table ; : lzw-compress-chars ( lzw -- ) { - [ [ clear-code lzw-compress-char ] [ reset-lzw-compress drop ] bi ] + ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ] + [ + [ clear-code ] dip + [ lzw-bit-width-compress ] + [ output>> write-bits ] bi + ] [ (lzw-compress-chars) ] - [ end-of-information lzw-compress-char ] + [ + [ k>> ] + [ lzw-bit-width-compress ] + [ output>> write-bits ] tri + ] + [ + [ end-of-information ] dip + [ lzw-bit-width-compress ] + [ output>> write-bits ] bi + ] [ ] } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; @@ -138,7 +152,7 @@ ERROR: not-in-table ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) From 237f16b4db03d50d03558fa2ad9ec9c9b9ff8169 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:13:34 -0600 Subject: [PATCH 145/168] move zlib to zlib.compression and update --- basis/compression/zlib/authors.txt | 1 + basis/compression/zlib/ffi/authors.txt | 1 + basis/compression/zlib/ffi/ffi.factor | 30 +++++++++++++++ basis/compression/zlib/zlib-tests.factor | 9 +++++ basis/compression/zlib/zlib.factor | 48 ++++++++++++++++++++++++ 5 files changed, 89 insertions(+) create mode 100755 basis/compression/zlib/authors.txt create mode 100755 basis/compression/zlib/ffi/authors.txt create mode 100755 basis/compression/zlib/ffi/ffi.factor create mode 100755 basis/compression/zlib/zlib-tests.factor create mode 100755 basis/compression/zlib/zlib.factor diff --git a/basis/compression/zlib/authors.txt b/basis/compression/zlib/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/compression/zlib/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/compression/zlib/ffi/authors.txt b/basis/compression/zlib/ffi/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/compression/zlib/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/compression/zlib/ffi/ffi.factor b/basis/compression/zlib/ffi/ffi.factor new file mode 100755 index 0000000000..d369c22e4c --- /dev/null +++ b/basis/compression/zlib/ffi/ffi.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.syntax combinators system ; +IN: compression.zlib.ffi + +<< "zlib" { + { [ os winnt? ] [ "zlib1.dll" ] } + { [ os macosx? ] [ "libz.dylib" ] } + { [ os unix? ] [ "libz.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: zlib + +CONSTANT: Z_OK 0 +CONSTANT: Z_STREAM_END 1 +CONSTANT: Z_NEED_DICT 2 +CONSTANT: Z_ERRNO -1 +CONSTANT: Z_STREAM_ERROR -2 +CONSTANT: Z_DATA_ERROR -3 +CONSTANT: Z_MEM_ERROR -4 +CONSTANT: Z_BUF_ERROR -5 +CONSTANT: Z_VERSION_ERROR -6 + +TYPEDEF: void Bytef +TYPEDEF: ulong uLongf +TYPEDEF: ulong uLong + +FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; +FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ; +FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; diff --git a/basis/compression/zlib/zlib-tests.factor b/basis/compression/zlib/zlib-tests.factor new file mode 100755 index 0000000000..1baeba73d9 --- /dev/null +++ b/basis/compression/zlib/zlib-tests.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test compression.zlib classes ; +IN: compression.zlib.tests + +: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; + +[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test +[ t ] [ compress-me compress compressed instance? ] unit-test diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor new file mode 100755 index 0000000000..7818173498 --- /dev/null +++ b/basis/compression/zlib/zlib.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.syntax byte-arrays combinators +kernel math math.functions sequences system accessors +libc ; +QUALIFIED: compression.zlib.ffi +IN: compression.zlib + +TUPLE: compressed data length ; + +: ( data length -- compressed ) + compressed new + swap >>length + swap >>data ; + +ERROR: zlib-failed n string ; + +: zlib-error-message ( n -- * ) + dup compression.zlib.ffi:Z_ERRNO = [ + drop errno "native libc error" + ] [ + dup { + "no error" "libc_error" + "stream error" "data error" + "memory error" "buffer error" "zlib version error" + } ?nth + ] if zlib-failed ; + +: zlib-error ( n -- ) + dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; + +: compressed-size ( byte-array -- n ) + length 1001/1000 * ceiling 12 + ; + +: compress ( byte-array -- compressed ) + [ + [ compressed-size dup length ] keep [ + dup length compression.zlib.ffi:compress zlib-error + ] 3keep drop *ulong head + ] keep length ; + +: uncompress ( compressed -- byte-array ) + [ + length>> [ ] keep 2dup + ] [ + data>> dup length + compression.zlib.ffi:uncompress zlib-error + ] bi *ulong head ; From 1682a5512ac7027f49c18ec9d536eeeba03101d4 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 22:26:44 -0600 Subject: [PATCH 146/168] Minor docs fix and cleanup in http.server.static --- basis/http/server/static/static-docs.factor | 2 +- basis/http/server/static/static.factor | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor index fbe20b5fcd..bbad56a6f1 100644 --- a/basis/http/server/static/static-docs.factor +++ b/basis/http/server/static/static-docs.factor @@ -38,7 +38,7 @@ $nl "If all you want to do is serve files from a directory, the following phrase does the trick:" { $code "USING: namespaces http.server http.server.static ;" - "/var/www/mysite.com/ main-responder set" + "\"/var/www/mysite.com/\" main-responder set" "8080 httpd" } { $subsection "http.server.static.extend" } ; diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 53d3d4f917..5d5ad7d2b8 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ; [ file-responder get hook>> call ] [ 2drop <304> ] if ; : serving-path ( filename -- filename ) - file-responder get root>> trim-tail-separators - "/" - rot "" or trim-head-separators 3append ; + [ file-responder get root>> trim-tail-separators "/" ] dip + "" or trim-head-separators 3append ; : serve-file ( filename -- response ) dup mime-type From 2bb9448ebcbb98acfdbaac7ab6c1536ea907d631 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Feb 2009 22:39:26 -0600 Subject: [PATCH 147/168] add set-basic-auth to http, and make http-request stuff the response body in the error message on failure --- basis/http/client/client-docs.factor | 3 +-- basis/http/client/client.factor | 7 +++++-- basis/http/http-docs.factor | 6 ++++++ basis/http/http-tests.factor | 5 +++++ basis/http/http.factor | 7 ++++++- 5 files changed, 23 insertions(+), 5 deletions(-) diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 9a8aa48738..0d7f7851e2 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -56,8 +56,7 @@ HELP: http-request HELP: with-http-request { $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } } -{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." } -{ $errors "Throws an error if the HTTP request fails." } ; +{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ; ARTICLE: "http.client.get" "GET requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index cc1c67c31e..4099e3d84c 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -141,12 +141,15 @@ ERROR: download-failed response ; : check-response ( response -- response ) dup code>> success? [ download-failed ] unless ; +: check-response-with-body ( response body -- response body ) + [ >>body check-response ] keep ; + : with-http-request ( request quot -- response ) - [ (with-http-request) check-response ] with-destructors ; inline + [ (with-http-request) ] with-destructors ; inline : http-request ( request -- response data ) [ [ % ] with-http-request ] B{ } make - over content-charset>> decode ; + over content-charset>> decode check-response-with-body ; : ( url -- request ) "GET" ; diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index fc3f65fa56..210066176f 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -113,6 +113,12 @@ HELP: set-header { $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." } { $side-effects "request/response" } ; +HELP: set-basic-auth +{ $values { "request" request } { "username" string } { "password" string } } +{ $description "Sets the " { $snippet "Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." } +{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." } +{ $side-effects "request" } ; + ARTICLE: "http.cookies" "HTTP cookies" "Every " { $link request } " and " { $link response } " instance can contain cookies." $nl diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 49acdb639c..4f685945aa 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -359,3 +359,8 @@ SYMBOL: a ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test [ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test + +! Test basic auth +[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test + + diff --git a/basis/http/http.factor b/basis/http/http.factor index 2b5414b299..d4acd282f8 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -7,7 +7,8 @@ calendar.format present urls fry io io.encodings io.encodings.iana io.encodings.binary io.encodings.8-bit io.crlf unicode.case unicode.categories -http.parsers ; +http.parsers +base64 ; IN: http : (read-header) ( -- alist ) @@ -142,6 +143,9 @@ cookies ; : set-header ( request/response value key -- request/response ) pick header>> set-at ; +: set-basic-auth ( request username password -- request ) + ":" glue >base64 "Basic " prepend "Authorization" set-header ; + : ( -- request ) request new "1.1" >>version @@ -156,6 +160,7 @@ cookies ; : header ( request/response key -- value ) swap header>> at ; + TUPLE: response version code From 7f8e890f1f05458f8357e218158cea01d7f4a075 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Feb 2009 22:39:48 -0600 Subject: [PATCH 148/168] twitta --- extra/twitter/twitter.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 extra/twitter/twitter.factor diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor new file mode 100644 index 0000000000..eceb40c1c2 --- /dev/null +++ b/extra/twitter/twitter.factor @@ -0,0 +1,22 @@ +USING: accessors assocs hashtables http http.client json.reader +kernel namespaces urls.encoding ; +IN: twitter + +SYMBOLS: twitter-username twitter-password ; + +: set-twitter-credentials ( username password -- ) + [ twitter-username set ] [ twitter-password set ] bi* ; + +: set-request-twitter-auth ( request -- request ) + twitter-username twitter-password [ get ] bi@ set-basic-auth ; + +: update-post-data ( update -- assoc ) + "status" associate ; + +: tweet* ( string -- result ) + update-post-data "https://twitter.com/statuses/update.json" + set-request-twitter-auth + http-request nip json> ; + +: tweet ( string -- ) tweet* drop ; + From 92f3ae39ad8aaa458253500752f1fb46dfe2d56a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Feb 2009 22:56:46 -0600 Subject: [PATCH 149/168] gotta load urls.secure to use https --- extra/twitter/twitter.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index eceb40c1c2..707bcceda6 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -1,5 +1,5 @@ USING: accessors assocs hashtables http http.client json.reader -kernel namespaces urls.encoding ; +kernel namespaces urls.secure urls.encoding ; IN: twitter SYMBOLS: twitter-username twitter-password ; From f3e8bc12472d409c5c1d27d5c817bd8a664c5ba7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:55:38 -0600 Subject: [PATCH 150/168] make hexdump work for byte-vectors --- basis/tools/hexdump/hexdump.factor | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index b646760889..335e32e0a3 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays io io.streams.string kernel math math.parser -namespaces sequences splitting grouping strings ascii byte-arrays ; +namespaces sequences splitting grouping strings ascii +byte-arrays byte-vectors ; IN: tools.hexdump hex-digits write ] [ >ascii write ] bi nl ; +: hexdump-bytes + [ length write-header ] + [ 16 [ write-hex-line ] each-index ] bi ; + PRIVATE> GENERIC: hexdump. ( byte-array -- ) -M: byte-array hexdump. - [ length write-header ] - [ 16 [ write-hex-line ] each-index ] bi ; +M: byte-array hexdump. hexdump-bytes ; + +M: byte-vector hexdump. hexdump-bytes ; : hexdump ( byte-array -- str ) [ hexdump. ] with-string-writer ; From cd82735dea927dfb4dcc18e7d3416ec0ea57c210 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:55:56 -0600 Subject: [PATCH 151/168] remove zlib --- basis/zlib/authors.txt | 1 - basis/zlib/ffi/authors.txt | 1 - basis/zlib/ffi/ffi.factor | 30 ---------------------- basis/zlib/zlib-tests.factor | 9 ------- basis/zlib/zlib.factor | 48 ------------------------------------ 5 files changed, 89 deletions(-) delete mode 100755 basis/zlib/authors.txt delete mode 100755 basis/zlib/ffi/authors.txt delete mode 100755 basis/zlib/ffi/ffi.factor delete mode 100755 basis/zlib/zlib-tests.factor delete mode 100755 basis/zlib/zlib.factor diff --git a/basis/zlib/authors.txt b/basis/zlib/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/zlib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/zlib/ffi/authors.txt b/basis/zlib/ffi/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/zlib/ffi/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor deleted file mode 100755 index bda2809f56..0000000000 --- a/basis/zlib/ffi/ffi.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax combinators system ; -IN: zlib.ffi - -<< "zlib" { - { [ os winnt? ] [ "zlib1.dll" ] } - { [ os macosx? ] [ "libz.dylib" ] } - { [ os unix? ] [ "libz.so" ] } -} cond "cdecl" add-library >> - -LIBRARY: zlib - -CONSTANT: Z_OK 0 -CONSTANT: Z_STREAM_END 1 -CONSTANT: Z_NEED_DICT 2 -CONSTANT: Z_ERRNO -1 -CONSTANT: Z_STREAM_ERROR -2 -CONSTANT: Z_DATA_ERROR -3 -CONSTANT: Z_MEM_ERROR -4 -CONSTANT: Z_BUF_ERROR -5 -CONSTANT: Z_VERSION_ERROR -6 - -TYPEDEF: void Bytef -TYPEDEF: ulong uLongf -TYPEDEF: ulong uLong - -FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; -FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ; -FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor deleted file mode 100755 index 0ac77277dc..0000000000 --- a/basis/zlib/zlib-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test zlib classes ; -IN: zlib.tests - -: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; - -[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test -[ t ] [ compress-me compress compressed instance? ] unit-test diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor deleted file mode 100755 index b40d9c2a98..0000000000 --- a/basis/zlib/zlib.factor +++ /dev/null @@ -1,48 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax byte-arrays combinators -kernel math math.functions sequences system accessors -libc ; -QUALIFIED: zlib.ffi -IN: zlib - -TUPLE: compressed data length ; - -: ( data length -- compressed ) - compressed new - swap >>length - swap >>data ; - -ERROR: zlib-failed n string ; - -: zlib-error-message ( n -- * ) - dup zlib.ffi:Z_ERRNO = [ - drop errno "native libc error" - ] [ - dup { - "no error" "libc_error" - "stream error" "data error" - "memory error" "buffer error" "zlib version error" - } ?nth - ] if zlib-failed ; - -: zlib-error ( n -- ) - dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; - -: compressed-size ( byte-array -- n ) - length 1001/1000 * ceiling 12 + ; - -: compress ( byte-array -- compressed ) - [ - [ compressed-size dup length ] keep [ - dup length zlib.ffi:compress zlib-error - ] 3keep drop *ulong head - ] keep length ; - -: uncompress ( compressed -- byte-array ) - [ - length>> [ ] keep 2dup - ] [ - data>> dup length - zlib.ffi:uncompress zlib-error - ] bi *ulong head ; From 753cfcfd05ccb33af75cea89424b64f82fc54253 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:56:22 -0600 Subject: [PATCH 152/168] support .tif, start 96 bpp --- basis/images/images.factor | 14 ++++++++++++-- basis/images/loader/loader.factor | 1 + basis/images/tiff/tiff.factor | 7 ++++--- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 46c0936644..e8f5530706 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors grouping sequences combinators ; +USING: kernel accessors grouping sequences combinators +math specialized-arrays.direct.uint byte-arrays ; IN: images -SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR +32R32G32B ; TUPLE: image dim component-order byte-order bitmap ; @@ -15,6 +17,14 @@ GENERIC: load-image* ( path tuple -- image ) dup component-order>> { { RGBA [ ] } + { 32R32G32B [ + [ + ! >byte-array + ! dup length 4 /i [ 32 2^ /i ] map + ! >byte-array + ! 4 le> [ 32 2^ /i ] map concat + ] change-bitmap + ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 9e3f901269..6f2ae47c61 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -10,6 +10,7 @@ ERROR: unknown-image-extension extension ; : image-class ( path -- class ) file-extension >lower { { "bmp" [ bitmap-image ] } + { "tif" [ tiff-image ] } { "tiff" [ tiff-image ] } [ unknown-image-extension ] } case ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 0b749d0ade..baac3a2dfb 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -276,9 +276,10 @@ ERROR: unhandled-compression compression ; ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) - bits-per-sample find-tag sum { - { 32 [ RGBA ] } - { 24 [ RGB ] } + bits-per-sample find-tag { + { { 32 32 32 } [ 32R32G32B ] } + { { 8 8 8 8 } [ RGBA ] } + { { 8 8 8 } [ RGB ] } [ unknown-component-order ] } case ; From 3fb733b53cb07188827246afbe23c78177c2a1cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 10:16:58 -0600 Subject: [PATCH 153/168] add 48bpp mode to tiff --- basis/images/images.factor | 10 +--------- basis/images/tiff/tiff.factor | 1 + 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index e8f5530706..41d96a673b 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -5,7 +5,7 @@ math specialized-arrays.direct.uint byte-arrays ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR -32R32G32B ; +16R16G16B 32R32G32B ; TUPLE: image dim component-order byte-order bitmap ; @@ -17,14 +17,6 @@ GENERIC: load-image* ( path tuple -- image ) dup component-order>> { { RGBA [ ] } - { 32R32G32B [ - [ - ! >byte-array - ! dup length 4 /i [ 32 2^ /i ] map - ! >byte-array - ! 4 le> [ 32 2^ /i ] map concat - ] change-bitmap - ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index baac3a2dfb..28eee7d98a 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -278,6 +278,7 @@ ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { { { 32 32 32 } [ 32R32G32B ] } + { { 16 16 16 } [ 16R16G16B ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } [ unknown-component-order ] From cdc5aa60b0d304c10af3fb2f41c05de7464ef4eb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 10:48:11 -0600 Subject: [PATCH 154/168] add a stack effect to tuple article --- core/classes/tuple/tuple-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 561d0962ff..0469f3564a 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples" } "An example of using a changer:" { $code - ": positions" + ": positions ( -- seq )" " {" " \"junior programmer\"" " \"senior programmer\"" From fb844f2ac03aa0a03ff8448c7124d7f5bc7ef163 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 13 Feb 2009 11:54:07 -0600 Subject: [PATCH 155/168] twitter timelines --- extra/twitter/twitter.factor | 85 +++++++++++++++++++++++++++++++++--- 1 file changed, 80 insertions(+), 5 deletions(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index 707bcceda6..f9806a7c4f 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -1,9 +1,67 @@ -USING: accessors assocs hashtables http http.client json.reader -kernel namespaces urls.secure urls.encoding ; +USING: accessors assocs combinators hashtables http +http.client json.reader kernel macros namespaces sequences +urls.secure urls.encoding ; IN: twitter SYMBOLS: twitter-username twitter-password ; +TUPLE: twitter-status + created-at + id + text + source + truncated? + in-reply-to-status-id + in-reply-to-user-id + favorited? + user ; +TUPLE: twitter-user + id + name + screen-name + description + location + profile-image-url + url + protected? + followers-count ; + +MACRO: keys-boa ( keys class -- ) + [ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ; + +: ( assoc -- user ) + { + "id" + "name" + "screen_name" + "description" + "location" + "profile_image_url" + "url" + "protected" + "followers_count" + } twitter-user keys-boa ; + +: ( assoc -- tweet ) + clone "user" over [ ] change-at + { + "created_at" + "id" + "text" + "source" + "truncated" + "in_reply_to_status_id" + "in_reply_to_user_id" + "favorited" + "user" + } twitter-status keys-boa ; + +: json>twitter-statuses ( json-array -- tweets ) + json> [ ] map ; + +: json>twitter-status ( json-object -- tweet ) + json> ; + : set-twitter-credentials ( username password -- ) [ twitter-username set ] [ twitter-password set ] bi* ; @@ -13,10 +71,27 @@ SYMBOLS: twitter-username twitter-password ; : update-post-data ( update -- assoc ) "status" associate ; -: tweet* ( string -- result ) +: (tweet) ( string -- json ) update-post-data "https://twitter.com/statuses/update.json" set-request-twitter-auth - http-request nip json> ; + http-request nip ; -: tweet ( string -- ) tweet* drop ; +: tweet* ( string -- tweet ) + (tweet) json>twitter-status ; +: tweet ( string -- ) (tweet) drop ; + +: public-timeline ( -- tweets ) + "https://twitter.com/statuses/public_timeline.json" + set-request-twitter-auth + http-request nip json>twitter-statuses ; + +: friends-timeline ( -- tweets ) + "https://twitter.com/statuses/friends_timeline.json" + set-request-twitter-auth + http-request nip json>twitter-statuses ; + +: user-timeline ( username -- tweets ) + "https://twitter.com/statuses/user_timeline/" ".json" surround + set-request-twitter-auth + http-request nip json>twitter-statuses ; From 435a14f3b654193e16d35c20314189cfde4c7c1c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 11:57:45 -0600 Subject: [PATCH 156/168] add stack effect, oops --- basis/tools/hexdump/hexdump.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index 335e32e0a3..63b55729fb 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -27,7 +27,7 @@ IN: tools.hexdump : write-hex-line ( bytes lineno -- ) write-offset [ >hex-digits write ] [ >ascii write ] bi nl ; -: hexdump-bytes +: hexdump-bytes ( bytes -- ) [ length write-header ] [ 16 [ write-hex-line ] each-index ] bi ; From bd17f149290c3db90493ce1a45363db3461cc70c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 12:12:08 -0600 Subject: [PATCH 157/168] drawing 96bpp images works, add lots of previously unknown ifd fields --- basis/images/images.factor | 23 +++++++++++++++++------ basis/images/tiff/tiff.factor | 23 +++++++++++++++++------ 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 41d96a673b..e366dd2700 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -5,7 +5,7 @@ math specialized-arrays.direct.uint byte-arrays ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR -16R16G16B 32R32G32B ; +R16G16B16 R32G32B32 ; TUPLE: image dim component-order byte-order bitmap ; @@ -13,22 +13,32 @@ TUPLE: image dim component-order byte-order bitmap ; GENERIC: load-image* ( path tuple -- image ) +: add-dummy-alpha ( seq -- seq' ) + 3 + [ 255 suffix ] map concat ; + : normalize-component-order ( image -- image ) dup component-order>> { { RGBA [ ] } + { R32G32B32 [ + [ + dup length 4 / + [ bits>float 255.0 * >integer ] map + >byte-array add-dummy-alpha + ] change-bitmap + ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each ] change-bitmap ] } - { RGB [ - [ 3 [ 255 suffix ] map concat ] change-bitmap - ] } + { RGB [ [ add-dummy-alpha ] change-bitmap ] } { BGR [ [ - 3 dup [ [ 0 3 ] dip reverse-here ] each - [ 255 suffix ] map concat + 3 + [ [ [ 0 3 ] dip reverse-here ] each ] + [ add-dummy-alpha ] bi ] change-bitmap ] } } case @@ -39,5 +49,6 @@ GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; : normalize-image ( image -- image ) + [ >byte-array ] change-bitmap normalize-component-order normalize-scan-line-order ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 28eee7d98a..db5141521d 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -3,7 +3,7 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian constructors sequences arrays math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays -grouping images compression.lzw fry ; +grouping images compression.lzw fry strings ; IN: images.tiff TUPLE: tiff-image < image ; @@ -115,8 +115,9 @@ ERROR: bad-extra-samples n ; SINGLETONS: image-length image-width x-resolution y-resolution rows-per-strip strip-offsets strip-byte-counts bits-per-sample -samples-per-pixel new-subfile-type orientation -unhandled-ifd-entry ; +samples-per-pixel new-subfile-type orientation software +date-time photoshop exif-ifd sub-ifd inter-color-profile +xmp iptc unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -185,6 +186,7 @@ ERROR: unknown-ifd-type n ; { 10 [ 8 * ] } { 11 [ 4 * ] } { 12 [ 8 * ] } + { 13 [ 4 * ] } [ unknown-ifd-type ] } case ; @@ -200,6 +202,7 @@ ERROR: bad-small-ifd-type n ; { 8 [ 2 head endian> 16 >signed ] } { 9 [ endian> 32 >signed ] } { 11 [ endian> bits>float ] } + { 13 [ endian> 32 >signed ] } [ bad-small-ifd-type ] } case ; @@ -246,10 +249,18 @@ ERROR: bad-small-ifd-type n ; { 283 [ y-resolution ] } { 284 [ planar-configuration ] } { 296 [ lookup-resolution-unit resolution-unit ] } + { 305 [ >string software ] } + { 306 [ >string date-time ] } { 317 [ lookup-predictor predictor ] } + { 330 [ sub-ifd ] } { 338 [ lookup-extra-samples extra-samples ] } { 339 [ lookup-sample-format sample-format ] } - [ nip unhandled-ifd-entry ] + { 700 [ >string xmp ] } + { 34377 [ photoshop ] } + { 34665 [ exif-ifd ] } + { 33723 [ iptc ] } + { 34675 [ inter-color-profile ] } + [ nip unhandled-ifd-entry swap ] } case ; : process-ifd ( ifd -- ifd ) @@ -277,8 +288,8 @@ ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { - { { 32 32 32 } [ 32R32G32B ] } - { { 16 16 16 } [ 16R16G16B ] } + { { 32 32 32 } [ R32G32B32 ] } + { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } [ unknown-component-order ] From 1424380e5b1490d5df6975359dd24ef2da29134c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 13:04:14 -0600 Subject: [PATCH 158/168] x/y resolution should be a scalar --- basis/images/tiff/tiff.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index db5141521d..674188992a 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -245,8 +245,8 @@ ERROR: bad-small-ifd-type n ; { 277 [ samples-per-pixel ] } { 278 [ rows-per-strip ] } { 279 [ strip-byte-counts ] } - { 282 [ x-resolution ] } - { 283 [ y-resolution ] } + { 282 [ first x-resolution ] } + { 283 [ first y-resolution ] } { 284 [ planar-configuration ] } { 296 [ lookup-resolution-unit resolution-unit ] } { 305 [ >string software ] } From 53f6d394ea3d2e0c3bfe4408cb7c16f82f8002b3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 13 Feb 2009 13:07:48 -0600 Subject: [PATCH 159/168] let the world know you tweet from factor --- extra/twitter/twitter.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index f9806a7c4f..2172d7cf81 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -3,7 +3,9 @@ http.client json.reader kernel macros namespaces sequences urls.secure urls.encoding ; IN: twitter -SYMBOLS: twitter-username twitter-password ; +SYMBOLS: twitter-username twitter-password twitter-source ; + +twitter-source [ "factor" ] initialize TUPLE: twitter-status created-at @@ -69,7 +71,8 @@ MACRO: keys-boa ( keys class -- ) twitter-username twitter-password [ get ] bi@ set-basic-auth ; : update-post-data ( update -- assoc ) - "status" associate ; + "status" associate + [ twitter-source get "source" ] dip [ set-at ] keep ; : (tweet) ( string -- json ) update-post-data "https://twitter.com/statuses/update.json" From c6680eee60a3bbd432750ab4733f039c98ab9d73 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 13 Feb 2009 15:10:34 -0600 Subject: [PATCH 160/168] Making xml-undo words private; adding bytes>xml word --- basis/xml/syntax/syntax.factor | 4 ++++ basis/xml/tests/test.factor | 12 +++++++++--- basis/xml/xml-docs.factor | 9 +++++++-- basis/xml/xml.factor | 5 ++++- 4 files changed, 24 insertions(+), 6 deletions(-) diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor index 8e6bebfe6b..067bb9ec11 100644 --- a/basis/xml/syntax/syntax.factor +++ b/basis/xml/syntax/syntax.factor @@ -174,6 +174,8 @@ PRIVATE> : [XML "XML]" [ string>chunk ] parse-def ; parsing +enum ] ; \ interpolate-xml 1 [ undo-xml ] define-pop-inverse + +PRIVATE> diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index b1f6cf002f..0372132736 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -3,7 +3,7 @@ IN: xml.tests USING: kernel xml tools.test io namespaces make sequences xml.errors xml.entities.html parser strings xml.data io.files -xml.traversal continuations assocs +xml.traversal continuations assocs io.encodings.binary sequences.deep accessors io.streams.string ; ! This is insufficient @@ -12,8 +12,14 @@ sequences.deep accessors io.streams.string ; \ string>xml must-infer SYMBOL: xml-file -[ ] [ "resource:basis/xml/tests/test.xml" - [ file>xml ] with-html-entities xml-file set ] unit-test +[ ] [ + "resource:basis/xml/tests/test.xml" + [ file>xml ] with-html-entities xml-file set +] unit-test +[ t ] [ + "resource:basis/xml/tests/test.xml" binary file-contents + [ bytes>xml ] with-html-entities xml-file get = +] unit-test [ "1.0" ] [ xml-file get prolog>> version>> ] unit-test [ f ] [ xml-file get prolog>> standalone>> ] unit-test [ "a" ] [ xml-file get space>> ] unit-test diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 024b086ef9..77969c55cd 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax xml.data io strings ; +USING: help.markup help.syntax xml.data io strings byte-arrays ; IN: xml HELP: string>xml @@ -16,7 +16,11 @@ HELP: file>xml { $values { "filename" string } { "xml" xml } } { $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ; -{ string>xml read-xml file>xml } related-words +HELP: bytes>xml +{ $values { "byte-array" byte-array } { "xml" xml } } +{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ; + +{ string>xml read-xml file>xml bytes>xml } related-words HELP: read-xml-chunk { $values { "stream" "an input stream" } { "seq" "a sequence of elements" } } @@ -68,6 +72,7 @@ ARTICLE: { "xml" "reading" } "Reading XML" { $subsection read-xml-chunk } { $subsection string>xml-chunk } { $subsection file>xml } + { $subsection bytes>xml } "To read a DTD:" { $subsection read-dtd } { $subsection file>dtd } diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 57c1b6dbd3..073f46cbae 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files io.streams.string kernel namespaces sequences strings io.encodings.utf8 xml.data xml.errors xml.elements ascii xml.entities xml.writer xml.state xml.autoencoding assocs xml.tokenize -combinators.short-circuit xml.name splitting ; +combinators.short-circuit xml.name splitting io.streams.byte-array ; IN: xml : file>xml ( filename -- xml ) binary read-xml ; +: bytes>xml ( byte-array -- xml ) + binary read-xml ; + : read-dtd ( stream -- dtd ) [ H{ } clone extra-entities set From 0ce47f84c607b594da2c4854cfc3db3c9a1457f5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:14:09 -0600 Subject: [PATCH 161/168] use decode instead of >string in images.tiff --- basis/images/tiff/tiff.factor | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 674188992a..f57f15ae20 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators io io.encodings.binary io.files kernel -pack endian constructors sequences arrays math.order math.parser -prettyprint classes io.binary assocs math math.bitwise byte-arrays -grouping images compression.lzw fry strings ; +USING: accessors arrays assocs byte-arrays classes combinators +compression.lzw constructors endian fry grouping images io +io.binary io.encodings.ascii io.encodings.binary +io.encodings.string io.encodings.utf8 io.files kernel math +math.bitwise math.order math.parser pack prettyprint sequences +strings ; IN: images.tiff TUPLE: tiff-image < image ; @@ -249,13 +251,13 @@ ERROR: bad-small-ifd-type n ; { 283 [ first y-resolution ] } { 284 [ planar-configuration ] } { 296 [ lookup-resolution-unit resolution-unit ] } - { 305 [ >string software ] } - { 306 [ >string date-time ] } + { 305 [ ascii decode software ] } + { 306 [ ascii decode date-time ] } { 317 [ lookup-predictor predictor ] } { 330 [ sub-ifd ] } { 338 [ lookup-extra-samples extra-samples ] } { 339 [ lookup-sample-format sample-format ] } - { 700 [ >string xmp ] } + { 700 [ utf8 decode xmp ] } { 34377 [ photoshop ] } { 34665 [ exif-ifd ] } { 33723 [ iptc ] } From 813b0cb803e79eab45b58cb41c89510257290432 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:46:36 -0600 Subject: [PATCH 162/168] get the byte ordering correct for tiffs --- basis/images/bitmap/bitmap.factor | 4 ++-- basis/images/images.factor | 2 +- basis/images/tiff/tiff.factor | 17 +++++++++++++++-- 3 files changed, 18 insertions(+), 5 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index c9bb15192b..6713a729b5 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns combinators fry grouping io io.binary io.encodings.binary io.files kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary ; +strings images endian summary annotations ; IN: images.bitmap TUPLE: bitmap-image < image ; @@ -105,7 +105,7 @@ ERROR: unknown-component-order bitmap ; { [ [ width>> ] [ height>> ] bi 2array ] [ bitmap>component-order ] - [ drop little-endian ] ! XXX + [ drop little-endian ] !XXX [ buffer>> ] } cleave bitmap-image boa ; diff --git a/basis/images/images.factor b/basis/images/images.factor index e366dd2700..11452aa7d2 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -7,7 +7,7 @@ IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 ; -TUPLE: image dim component-order byte-order bitmap ; +TUPLE: image dim component-order bitmap ; : ( -- image ) image new ; inline diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 674188992a..8e981a8163 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -286,6 +286,18 @@ ERROR: unhandled-compression compression ; ERROR: unknown-component-order ifd ; +: fix-bitmap-endianness ( ifd -- ifd ) + dup [ bitmap>> ] [ bits-per-sample find-tag ] bi + { + { { 32 32 32 32 } [ 4 seq>native-endianness ] } + { { 32 32 32 } [ 4 seq>native-endianness ] } + { { 16 16 16 16 } [ 2 seq>native-endianness ] } + { { 16 16 16 } [ 2 seq>native-endianness ] } + { { 8 8 8 8 } [ ] } + { { 8 8 8 } [ ] } + [ unknown-component-order ] + } case >>bitmap ; + : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { { { 32 32 32 } [ R32G32B32 ] } @@ -299,7 +311,6 @@ ERROR: unknown-component-order ifd ; { [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ ifd-component-order ] - [ drop big-endian ] ! XXX [ bitmap>> ] } cleave tiff-image boa ; @@ -314,7 +325,9 @@ ERROR: unknown-component-order ifd ; dup ifds>> [ process-ifd read-strips uncompress-strips - strips>bitmap drop + strips>bitmap + fix-bitmap-endianness + drop ] each ] with-endianness ] with-file-reader ; From d7e10c3072c2795614656364b62abfb219b8ef8d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:47:07 -0600 Subject: [PATCH 163/168] remove XXX from bitmaps --- basis/images/bitmap/bitmap.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 6713a729b5..9005776e40 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns combinators fry grouping io io.binary io.encodings.binary io.files kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary annotations ; +strings images endian summary ; IN: images.bitmap TUPLE: bitmap-image < image ; @@ -105,7 +105,6 @@ ERROR: unknown-component-order bitmap ; { [ [ width>> ] [ height>> ] bi 2array ] [ bitmap>component-order ] - [ drop little-endian ] !XXX [ buffer>> ] } cleave bitmap-image boa ; From 03839aa3ccceb69355885eb59583f5afa4a16f64 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:47:48 -0600 Subject: [PATCH 164/168] str -> bytes, utility word in endian --- basis/endian/endian.factor | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor index a832d6c0a2..a453a71704 100755 --- a/basis/endian/endian.factor +++ b/basis/endian/endian.factor @@ -1,39 +1,39 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types namespaces io.binary fry -kernel math ; +kernel math grouping sequences ; IN: endian SINGLETONS: big-endian little-endian ; -: native-endianness ( -- class ) +: compute-native-endianness ( -- class ) 1 *char 0 = big-endian little-endian ? ; : >signed ( x n -- y ) 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; -native-endianness \ native-endianness set-global +SYMBOL: native-endianness +native-endianness [ compute-native-endianness ] initialize SYMBOL: endianness +endianness [ native-endianness get-global ] initialize -\ native-endianness get-global endianness set-global - -HOOK: >native-endian native-endianness ( obj n -- str ) +HOOK: >native-endian native-endianness ( obj n -- bytes ) M: big-endian >native-endian >be ; M: little-endian >native-endian >le ; -HOOK: unsigned-native-endian> native-endianness ( obj -- str ) +HOOK: unsigned-native-endian> native-endianness ( obj -- bytes ) M: big-endian unsigned-native-endian> be> ; M: little-endian unsigned-native-endian> le> ; -: signed-native-endian> ( obj n -- str ) +: signed-native-endian> ( obj n -- n' ) [ unsigned-native-endian> ] dip >signed ; -HOOK: >endian endianness ( obj n -- str ) +HOOK: >endian endianness ( obj n -- bytes ) M: big-endian >endian >be ; @@ -45,13 +45,13 @@ M: big-endian endian> be> ; M: little-endian endian> le> ; -HOOK: unsigned-endian> endianness ( obj -- str ) +HOOK: unsigned-endian> endianness ( obj -- bytes ) M: big-endian unsigned-endian> be> ; M: little-endian unsigned-endian> le> ; -: signed-endian> ( obj n -- str ) +: signed-endian> ( obj n -- bytes ) [ unsigned-endian> ] dip >signed ; : with-endianness ( endian quot -- ) @@ -65,3 +65,15 @@ M: little-endian unsigned-endian> le> ; : with-native-endian ( quot -- ) \ native-endianness get-global swap with-endianness ; inline + +: seq>native-endianness ( seq n -- seq' ) + native-endianness get-global dup endianness get = [ + 2drop + ] [ + [ [ ] keep ] dip + little-endian = [ + '[ be> _ >le ] map + ] [ + '[ le> _ >be ] map + ] if concat + ] if ; inline From 8223f4277514255eaf0a5f5d71ed8bfbce9904ed Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:52:17 -0600 Subject: [PATCH 165/168] decode uname strings as utf8 --- extra/system-info/linux/linux.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/system-info/linux/linux.factor b/extra/system-info/linux/linux.factor index 00a49fb2a2..b77e1fe649 100644 --- a/extra/system-info/linux/linux.factor +++ b/extra/system-info/linux/linux.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: unix alien alien.c-types kernel math sequences strings -io.backend.unix splitting ; +io.backend.unix splitting io.encodings.utf8 io.encodings.string ; IN: system-info.linux : (uname) ( buf -- int ) @@ -9,7 +9,7 @@ IN: system-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep - "\0" split harvest [ >string ] map + "\0" split harvest [ utf8 decode ] map 6 "" pad-tail ; : sysname ( -- string ) uname first ; From 3cf4c6fee20e5a36088a16a155e2f648e6d092ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 15:56:22 -0600 Subject: [PATCH 166/168] support 48bpp tiffs --- basis/images/images.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 11452aa7d2..32fbc54978 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors grouping sequences combinators -math specialized-arrays.direct.uint byte-arrays ; +math specialized-arrays.direct.uint byte-arrays +specialized-arrays.direct.ushort ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR @@ -28,6 +29,13 @@ GENERIC: load-image* ( path tuple -- image ) >byte-array add-dummy-alpha ] change-bitmap ] } + { R16G16B16 [ + [ + dup length 2 / + [ -8 shift ] map + >byte-array add-dummy-alpha + ] change-bitmap + ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each From 8253bf4662a141ea0b54af9dab66f667c032369c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 13 Feb 2009 16:05:18 -0600 Subject: [PATCH 167/168] Another failing test in db.sqlite --- basis/db/sqlite/sqlite-tests.factor | 36 +++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index e05d992014..529de9774b 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -127,3 +127,39 @@ hi "HELLO" { hi drop-table ] with-db ] unit-test + +TUPLE: show id ; +TUPLE: user username data ; +TUPLE: watch show user ; + +user "USER" { + { "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ } + { "data" "DATA" TEXT } +} define-persistent + +show "SHOW" { + { "id" "ID" +db-assigned-id+ } +} define-persistent + +watch "WATCH" { + { "user" "USER" TEXT +not-null+ + { +foreign-id+ user "USERNAME" } +user-assigned-id+ } + { "show" "SHOW" BIG-INTEGER +not-null+ + { +foreign-id+ show "ID" } +user-assigned-id+ } +} define-persistent + +[ T{ user { username "littledan" } { data "foo" } } ] [ + test.db [ + user create-table + show create-table + watch create-table + "littledan" "foo" user boa insert-tuple + "mark" "bar" user boa insert-tuple + show new insert-tuple + show new select-tuple + "littledan" f user boa select-tuple + watch boa insert-tuple + watch new select-tuple + user>> f user boa select-tuple + ] with-db +] unit-test From f3db8fdc4a4a88502c2d2527da9d491eb2670e07 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 13 Feb 2009 16:07:17 -0600 Subject: [PATCH 168/168] Another failing unit test for db.sqlite --- basis/db/sqlite/sqlite-tests.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 529de9774b..5ad4b0c889 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -163,3 +163,5 @@ watch "WATCH" { user>> f user boa select-tuple ] with-db ] unit-test + +[ \ swap ensure-table ] must-fail