From f0824b64b67d8faf9964b23fc3369be54067c617 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 13 Nov 2008 09:48:42 -0800
Subject: [PATCH 001/126] change cairo-gadget so it can handle constantly
updating content
---
extra/cairo/gadgets/gadgets.factor | 58 +++++++++--------------------
extra/opengl/gadgets/gadgets.factor | 5 +++
2 files changed, 22 insertions(+), 41 deletions(-)
diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor
index d160740c44..8ed7a3c31b 100644
--- a/extra/cairo/gadgets/gadgets.factor
+++ b/extra/cairo/gadgets/gadgets.factor
@@ -1,58 +1,34 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math opengl.gadgets kernel
-byte-arrays cairo.ffi cairo io.backend
-ui.gadgets accessors opengl.gl
-arrays fry classes ;
+USING: sequences math kernel byte-arrays cairo.ffi cairo
+io.backend ui.gadgets accessors opengl.gl arrays fry
+classes ui.render namespaces ;
IN: cairo.gadgets
: width>stride ( width -- stride ) 4 * ;
-: copy-cairo ( dim quot -- byte-array )
- >r first2 over width>stride
- [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
- [ cairo_image_surface_create_for_data ] 3bi
- r> with-cairo-from-surface ; inline
+GENERIC: render-cairo* ( gadget -- )
-TUPLE: cairo-gadget < texture-gadget ;
+: render-cairo ( gadget -- byte-array )
+ dup dim>> first2 over width>stride
+ [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_create_for_data ] 3bi
+ rot '[ _ render-cairo* ] with-cairo-from-surface ; inline
+
+TUPLE: cairo-gadget < gadget ;
: <cairo-gadget> ( dim -- gadget )
cairo-gadget new-gadget
swap >>dim ;
-M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ;
-
-: render-cairo ( dim quot -- bytes format )
- >r 2^-bounds r> copy-cairo GL_BGRA ; inline
-
-GENERIC: render-cairo* ( gadget -- )
-
-M: cairo-gadget render*
- [ dim>> dup ] [ '[ _ render-cairo* ] ] bi
- render-cairo render-bytes* ;
-
-! maybe also texture>png
-! : cairo>png ( gadget path -- )
-! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
-! [ height>> ] tri over width>stride
-! cairo_image_surface_create_for_data
-! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
+M: cairo-gadget draw-gadget*
+ [ dim>> ] [ render-cairo ] bi
+ origin get first2 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ >r first2 GL_BGRA GL_UNSIGNED_BYTE r>
+ glDrawPixels ;
: copy-surface ( surface -- )
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
-
-TUPLE: png-gadget < texture-gadget path ;
-: <png> ( path -- gadget )
- png-gadget new-gadget
- swap >>path ;
-
-M: png-gadget render*
- path>> normalize-path cairo_image_surface_create_from_png
- [ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height 2array dup 2^-bounds ]
- [ [ copy-surface ] curry copy-cairo ] tri
- GL_BGRA render-bytes* ;
-
-M: png-gadget cache-key* path>> ;
diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor
index cfedf32079..1fefcd5665 100644
--- a/extra/opengl/gadgets/gadgets.factor
+++ b/extra/opengl/gadgets/gadgets.factor
@@ -47,6 +47,11 @@ C: <entry> cache-entry
cache-key* textures get delete-at*
[ tex>> delete-texture ] [ drop ] if ;
+: clear-textures ( -- )
+ textures get values [ tex>> delete-texture ] each
+ H{ } clone textures set-global
+ H{ } clone refcounts set-global ;
+
M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
M: texture-gadget ungraft* ( gadget -- )
From a9f8856b0d7c4cb757fa6c9e5e5871618e973621 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 13 Nov 2008 09:49:18 -0800
Subject: [PATCH 002/126] make shader code in spheres a little more readable
---
basis/io/encodings/utf16/.utf16.factor.swo | Bin 16384 -> 0 bytes
extra/spheres/spheres.factor | 22 +++++++++++++++++----
2 files changed, 18 insertions(+), 4 deletions(-)
delete mode 100644 basis/io/encodings/utf16/.utf16.factor.swo
diff --git a/basis/io/encodings/utf16/.utf16.factor.swo b/basis/io/encodings/utf16/.utf16.factor.swo
deleted file mode 100644
index 01be8fdab2946825bf902b05af5135496b67501b..0000000000000000000000000000000000000000
GIT binary patch
literal 0
HcmV?d00001
literal 16384
zcmeI2O^h5z6~~JZJ2)Xgk^>yynghG?_Uz0o*wI+KE7mc=!kZA*YZ+E6rDwW&rnNoY
z<L;W+o7Eyr3?UI9P8>)iI3Oil$N>d};6Q}Pkxwa+V&wxN1rQP!j)@fhue!RYyLY^-
zk3rSeZ`RZO>Q%jey{hi6nr`#rxivb~XbK!36XLVK`tgImeC~w!?FWPi1EoUgxe;GG
z;8=5eL8Rhz;Iu#82;-g`PB;E);c&rsdn!&AdT}Bbf_Onjz1Rz)e!4JLe(PlR*~pBh
z`?6=P0#<=rRp9Q8#dfRt$>TG0-@O~RTG-lK1*`&A0jq#jz$#!BunJfOtOD<I1=Q#^
z@g8Eh4O|C!?bmz|e?JbsVZP&!J*)y&0jq#jz$#!BunJfOtO8a6tAJI&Dqt0OpDN&b
zLVN^mZ}S2G_WyYe;4dE);s@X>;4@$rd<uL5+zH-Afq#QH!5iQg;OF4`;OpQTcm$jR
zC&4lBx4VV-HFyT>fj;oT61WGv^<g1i0>1%If@|OsSOj;0x9<|-1#k^0kb-s40!<*m
zjXQ;S5quLo3eJF4a1Z#`F(G~iz5~7u*1;M$0gi$<K7{MwyWkr58h8{egC)=a1m3wr
zh`)ljz#qYj;Co;MVsHU0gE?>q_{UKp{s4XtehRLGC%^!F2`m8uN5S8ZAWrZycosYZ
z6iC5&@CD$2Bj9%M>g__j0)7IX2Tz0R;1ZYz$H2Q-$ax3+4m=H>0#`vBw7`GR?>E3}
z;8}1TJOM6(4WRP^@=lHpr6ac|X_gY129LYlP?F<N630U)l)j=lDBB_ZLk?U@RU+M?
zgAcDoElRJrqw+aAjreh>ac`SasT@y+vhOO13nec>6euVEl?bZNycU(9ep8=guAmWz
zb?eFO$0vt$J45FpQUgi;Sd9}okN*cLrGt1JdgMtZdy3r1qo5z**Dd7I>ceZ~DqW;2
z`#}`phc4p6#uv|@ou~vA;8)QVH>F-Y3ZzGV5)Ube8+p`e10mk8U7O0fXhU#SdMJ8f
zAW;|E;YJj9)1Hh_^DrJqieeugJxShp6b3z41#v`doe8vui)id=trjb`OPi!<3!hpS
z>BuCB6P(zqm}t4Xa;0o(&P}%sr`RGra=*KxlUJzSaA(NNoLJ~kPAQ`mSE(<x^fh_8
zO)E4<T_hjmSQ#MA5KL~(mEOb}br;qgx0YEtx^i4&hn&5fuI^|gwMLza6?;b8xQS?~
zZlY<%>Mni$?4=I*(){&lk4{q%g+T<}JGuA5&M)lCcHFE@{Ob+eWI1ox7D=}^fNm(f
zM?-g;M@qF}Xm`D7?27wzu-skfW>L-4JWd5Z8YcKMA4Y@}BLV@#Lg>@@K=$NU{UAwI
z<)RL@)x<%LF2UCN<mYhEGHs%Tl_+NQSJuu9)M}jQ%0t8ntApd5gjmE;jZk;*fnn~m
zxW!m?8#(k+tlH=5xraK`G6!`7#dAhB3|T$reoQF=W>aI=geByKU7YA(D&<=(<6)8s
zSs!MDTvurN<4{#`Pfn_GTFtC66Yn|)GUuB#Yi0_QqI2lG><r?mj_NEkE8`lug*@)L
zDd#bN;bWIBk6mw(6Be?B($Qa0I-f2kMr|17?aSJ1%I-I9!89AoPBb2-+OA!5>BVEd
zp%oRI?^S1d8i$RS#3QO%@I<yxkXh=Eed_MuwuZ5rD!#uV_xWV;-3$aCrETqaG{!F~
z6FCZTw;f8%<k@Hy96KK-1M&_nM^;MG6Q(ab!DVzN==^H$&o5fi1GOf3we1JA8gryG
z9EU2<an>4pU{Jbg+`P?tQ28j($(VOoVa|bMDrEV}L#RpU+pbKOwACcu#eMNs!!_M_
zsAy{`-<1cXd^SlPCgsfo!vRW_Z^8Kh`Cr{$%Wp2mL#EWpZ9Uu8ec#exsds(ZS!J;3
zFWF7DRO`Mm!-`gW;*ev;iyb3lE&rAi$}>J$u4maKyB2F%lb0#Y!g+qx#|q1cHk&by
zaWZXW7n23wcZ)nOW|DH_OIK?no%^swTZKU}4EPS*G`9&J3y;erUeRWH$WIvpW~}H~
zs(n+E|0ZL;oO#)N&o?lB6e-UGB|i}4Ca$W(oSl@N*HzVzT9clhWv>&lF$0(sz;odG
zm)BMwKHo8Cim!U`RKB$<-&)1Dtiy!hyEPuh^({`6pUUz4JnROMi~BO(0`Q2f6rS%P
z#K!u$haT+U2~7=XTPBeV`8jcn2M`HEO#LZ6hIa)n7P&*IU#e2BgS{m?c&J~Ok_JkR
zIt%9a^86g%h?D*T9^_?|%7(hC$j8(9>iPqepF_bj@n|Or`U6F?XXdEgY@VFw&r|e(
z8wF^`*+C*B%#r<u;P?Nx@qT>~@8JCY&wKuV#ykF>!1Lfa5QDSe2>2)7<@ufeb?`EH
z3VaJ}1AgDX7u<la*T75QN8pFxNucYPyhz&rSp}>DRspMkRlq7>6|f3e1*`&Af&T*q
z2nSXiYI_P;cqn$avTZ8oN)pt!y2@9w6;^m^;Vi#a!bSNyUNcLZWaTTZ(#miAm_%EK
zBek<a`u|a!ZBgY*O+NWpCb}|^5gc;cH?xI8-n4VDhZKZP7-Ok(i;f@HTMpVtzh@RZ
zRlC&Fn|!Fsv}015_GV^grnGcoQ3Q&0o`g36&6b>A2rcVo)|kyUpRRGL2<$p@T3ZO3
z;y_2kVUGgdgw(s6s1qVg_AV=%Q&^Dh4aU(n1lg8yq|2j|ba8(ihASuw2aCG(%kaWo
zw*^^6vEx?>AX_6TmN2qvc~!#{)e9b(<Jzt(?|o$r)@wbGLN|t&d&ZF`lW>Qt)~leK
U6w0WN#fU9xV|69mAqVFF1)sD~<p2Nx
diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor
index f119956db6..d203d49eab 100755
--- a/extra/spheres/spheres.factor
+++ b/extra/spheres/spheres.factor
@@ -14,16 +14,26 @@ main()
;
STRING: plane-fragment-shader
+uniform float checker_size_inv;
+uniform vec4 checker_color_1, checker_color_2;
varying vec3 object_position;
+
+bool
+checker_color(vec3 p)
+{
+ vec3 pprime = checker_size_inv * object_position;
+ return fract((floor(pprime.x) + floor(pprime.z)) * 0.5) == 0.0;
+}
+
void
main()
{
float distance_factor = (gl_FragCoord.z * 0.5 + 0.5);
distance_factor = pow(distance_factor, 500.0)*0.5;
- gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0
- ? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0)
- : vec4(1.0, distance_factor, distance_factor, 1.0);
+ gl_FragColor = checker_color(object_position)
+ ? mix(checker_color_1, checker_color_2, distance_factor)
+ : mix(checker_color_2, checker_color_1, distance_factor);
}
;
@@ -212,7 +222,11 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
] with-gl-program
] [
plane-program>> [
- drop
+ {
+ [ "checker_size_inv" glGetUniformLocation 0.125 glUniform1f ]
+ [ "checker_color_1" glGetUniformLocation 1.0 0.5 0.0 1.0 glUniform4f ]
+ [ "checker_color_2" glGetUniformLocation 0.0 0.0 0.0 1.0 glUniform4f ]
+ } cleave
GL_QUADS [
-1000.0 -30.0 1000.0 glVertex3f
-1000.0 -30.0 -1000.0 glVertex3f
From 27bcb413a503db621d6a2001f952dc65ab553d0d Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Wed, 19 Nov 2008 00:59:43 +0100
Subject: [PATCH 003/126] Emacs factor-mode: better font lock: constructors,
setters and parent types (with accompanying custom faces).
---
misc/factor.el | 222 +++++++++++++++++++++++++++----------------------
1 file changed, 121 insertions(+), 101 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index 6204bdbef6..c18a3102e7 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -113,6 +113,14 @@ value from the existing code in the buffer."
"Face for type (tuple) names."
:group 'factor-faces)
+(defface factor-font-lock-constructor (factor--face font-lock-type-face)
+ "Face for constructors (<foo>)."
+ :group 'factor-faces)
+
+(defface factor-font-lock-setter-word (factor--face font-lock-function-name-face)
+ "Face for setter words (>>foo)."
+ :group 'factor-faces)
+
(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
"Face for parsing words."
:group 'factor-faces)
@@ -146,6 +154,12 @@ value from the existing code in the buffer."
(defconst factor--regex-type-definition
(factor--regex-second-word '("TUPLE:")))
+(defconst factor--regex-parent-type "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
+
+(defconst factor--regex-constructor "<[^ >]+>")
+
+(defconst factor--regex-setter "\\W>>[^ ]+\\b")
+
(defconst factor--regex-symbol-definition
(factor--regex-second-word '("SYMBOL:")))
@@ -166,6 +180,9 @@ value from the existing code in the buffer."
(,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word)
(,factor--regex-word-definition 2 'factor-font-lock-word-definition)
(,factor--regex-type-definition 2 'factor-font-lock-type-definition)
+ (,factor--regex-parent-type 1 'factor-font-lock-type-definition)
+ (,factor--regex-constructor . 'factor-font-lock-constructor)
+ (,factor--regex-setter . 'factor-font-lock-setter-word)
(,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
(,factor--regex-using-line 1 'factor-font-lock-vocabulary-name)
(,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
@@ -217,6 +234,109 @@ value from the existing code in the buffer."
(modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
(modify-syntax-entry ?\" "\" " factor-mode-syntax-table)))
+
+;;; Factor mode indentation:
+
+(make-variable-buffer-local
+ (defvar factor-indent-width factor-default-indent-width
+ "Indentation width in factor buffers. A local variable."))
+
+(defconst factor--regexp-word-start
+ (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
+ (format "^\\(%s\\): " (mapconcat 'identity sws "\\|"))))
+
+(defun factor--guess-indent-width ()
+ "Chooses an indentation value from existing code."
+ (let ((word-cont "^ +[^ ]")
+ (iw))
+ (save-excursion
+ (beginning-of-buffer)
+ (while (not iw)
+ (if (not (re-search-forward factor--regexp-word-start nil t))
+ (setq iw factor-default-indent-width)
+ (forward-line)
+ (when (looking-at word-cont)
+ (setq iw (current-indentation))))))
+ iw))
+
+(defsubst factor--ppss-brackets-depth ()
+ (nth 0 (syntax-ppss)))
+
+(defsubst factor--ppss-brackets-start ()
+ (nth 1 (syntax-ppss)))
+
+(defsubst factor--line-indent (pos)
+ (save-excursion (goto-char pos) (current-indentation)))
+
+(defconst factor--regex-closing-paren "[])}]")
+(defsubst factor--at-closing-paren-p ()
+ (looking-at factor--regex-closing-paren))
+
+(defsubst factor--at-first-char-p ()
+ (= (- (point) (line-beginning-position)) (current-indentation)))
+
+(defconst factor--regex-single-liner
+ (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" "PRIVATE>" "<PRIVATE" "USE:"))))
+
+(defsubst factor--at-begin-of-def ()
+ (looking-at "\\([^ ]\\|^\\)+:"))
+
+(defun factor--at-end-of-def ()
+ (or (looking-at ".*;[ \t]*$")
+ (looking-at factor--regex-single-liner)))
+
+(defun factor--indent-in-brackets ()
+ (save-excursion
+ (beginning-of-line)
+ (when (or (and (re-search-forward factor--regex-closing-paren
+ (line-end-position) t)
+ (not (backward-char)))
+ (> (factor--ppss-brackets-depth) 0))
+ (let ((op (factor--ppss-brackets-start)))
+ (when (> (line-number-at-pos) (line-number-at-pos op))
+ (if (factor--at-closing-paren-p)
+ (factor--line-indent op)
+ (+ (factor--line-indent op) factor-indent-width)))))))
+
+(defun factor--indent-definition ()
+ (save-excursion
+ (beginning-of-line)
+ (when (factor--at-begin-of-def) 0)))
+
+(defun factor--indent-continuation ()
+ (save-excursion
+ (forward-line -1)
+ (beginning-of-line)
+ (if (bobp) 0
+ (if (looking-at "^[ \t]*$")
+ (factor--indent-continuation)
+ (if (factor--at-end-of-def)
+ (- (current-indentation) factor-indent-width)
+ (if (factor--at-begin-of-def)
+ (+ (current-indentation) factor-indent-width)
+ (current-indentation)))))))
+
+(defun factor--calculate-indentation ()
+ "Calculate Factor indentation for line at point."
+ (or (and (bobp) 0)
+ (factor--indent-definition)
+ (factor--indent-in-brackets)
+ (factor--indent-continuation)
+ 0))
+
+(defun factor--indent-line ()
+ "Indent current line as Factor code"
+ (let ((target (factor--calculate-indentation))
+ (pos (- (point-max) (point))))
+ (if (= target (current-indentation))
+ (if (< (current-column) (current-indentation))
+ (back-to-indentation))
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to target)
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos))))))
+
;;; Factor mode commands:
@@ -314,105 +434,6 @@ value from the existing code in the buffer."
(define-key factor-mode-map [return] 'newline-and-indent)
(define-key factor-mode-map [tab] 'indent-for-tab-command)
-
-;;; Factor mode indentation:
-
-(make-variable-buffer-local
- (defvar factor-indent-width factor-default-indent-width
- "Indentation width in factor buffers. A local variable."))
-
-(defconst factor--regexp-word-start
- (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
- (format "^\\(%s\\): " (mapconcat 'identity sws "\\|"))))
-
-(defun factor--guess-indent-width ()
- "Chooses an indentation value from existing code."
- (let ((word-cont "^ +[^ ]")
- (iw))
- (save-excursion
- (beginning-of-buffer)
- (while (not iw)
- (if (not (re-search-forward factor--regexp-word-start nil t))
- (setq iw factor-default-indent-width)
- (forward-line)
- (when (looking-at word-cont)
- (setq iw (current-indentation))))))
- iw))
-
-(defsubst factor--ppss-brackets-depth ()
- (nth 0 (syntax-ppss)))
-
-(defsubst factor--ppss-brackets-start ()
- (nth 1 (syntax-ppss)))
-
-(defsubst factor--line-indent (pos)
- (save-excursion (goto-char pos) (current-indentation)))
-
-(defconst factor--regex-closing-paren "[])}]")
-(defsubst factor--at-closing-paren-p ()
- (looking-at factor--regex-closing-paren))
-
-(defsubst factor--at-first-char-p ()
- (= (- (point) (line-beginning-position)) (current-indentation)))
-
-(defconst factor--regex-single-liner
- (format "^%s" (regexp-opt '("USE:" "IN:" "PRIVATE>" "<PRIVATE"))))
-
-(defun factor--at-end-of-def ()
- (or (looking-at ".*;[ \t]*$")
- (looking-at factor--regex-single-liner)))
-
-(defun factor--indent-in-brackets ()
- (save-excursion
- (beginning-of-line)
- (when (or (and (re-search-forward factor--regex-closing-paren
- (line-end-position) t)
- (not (backward-char)))
- (> (factor--ppss-brackets-depth) 0))
- (let ((op (factor--ppss-brackets-start)))
- (when (> (line-number-at-pos) (line-number-at-pos op))
- (if (factor--at-closing-paren-p)
- (factor--line-indent op)
- (+ (factor--line-indent op) factor-indent-width)))))))
-
-(defun factor--indent-definition ()
- (save-excursion
- (beginning-of-line)
- (when (looking-at "\\([^ ]\\|^\\)+:") 0)))
-
-(defun factor--indent-continuation ()
- (save-excursion
- (forward-line -1)
- (beginning-of-line)
- (if (bobp) 0
- (if (looking-at "^[ \t]*$")
- (factor--indent-continuation)
- (if (factor--at-end-of-def)
- (- (current-indentation) factor-indent-width)
- (if (factor--indent-definition)
- (+ (current-indentation) factor-indent-width)
- (current-indentation)))))))
-
-(defun factor--calculate-indentation ()
- "Calculate Factor indentation for line at point."
- (or (and (bobp) 0)
- (factor--indent-definition)
- (factor--indent-in-brackets)
- (factor--indent-continuation)
- 0))
-
-(defun factor-indent-line ()
- "Indent current line as Factor code"
- (let ((target (factor--calculate-indentation))
- (pos (- (point-max) (point))))
- (if (= target (current-indentation))
- (if (< (current-column) (current-indentation))
- (back-to-indentation))
- (beginning-of-line)
- (delete-horizontal-space)
- (indent-to target)
- (if (> (- (point-max) pos) (point))
- (goto-char (- (point-max) pos))))))
;; Factor mode:
@@ -426,12 +447,11 @@ value from the existing code in the buffer."
(use-local-map factor-mode-map)
(setq major-mode 'factor-mode)
(setq mode-name "Factor")
- (set (make-local-variable 'indent-line-function) #'factor-indent-line)
(set (make-local-variable 'comment-start) "! ")
(set (make-local-variable 'font-lock-defaults)
'(factor-font-lock-keywords t nil nil nil))
(set-syntax-table factor-mode-syntax-table)
- (set (make-local-variable 'indent-line-function) 'factor-indent-line)
+ (set (make-local-variable 'indent-line-function) 'factor--indent-line)
(setq factor-indent-width (factor--guess-indent-width))
(setq indent-tabs-mode nil)
(run-hooks 'factor-mode-hook))
From 2ffecd3acc9d00dab23657c3aa267489ba12f12c Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Tue, 18 Nov 2008 18:51:52 -0600
Subject: [PATCH 004/126] Fix VM compile on 32-bit Windows
---
vm/main-windows-nt.c | 2 +-
vm/os-windows.h | 13 +++++++------
2 files changed, 8 insertions(+), 7 deletions(-)
mode change 100644 => 100755 vm/main-windows-nt.c
diff --git a/vm/main-windows-nt.c b/vm/main-windows-nt.c
old mode 100644
new mode 100755
index 95fd68549d..ef66651846
--- a/vm/main-windows-nt.c
+++ b/vm/main-windows-nt.c
@@ -15,7 +15,7 @@ int WINAPI WinMain(
szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
if(NULL == szArglist)
{
- print_string("CommandLineToArgvW failed\n");
+ puts("CommandLineToArgvW failed");
return 1;
}
diff --git a/vm/os-windows.h b/vm/os-windows.h
index 2a56b03ef6..8d0f15648a 100755
--- a/vm/os-windows.h
+++ b/vm/os-windows.h
@@ -20,13 +20,14 @@ typedef wchar_t F_CHAR;
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
-#define CELL_FORMAT "%Iu"
-#define CELL_HEX_FORMAT "%Ix"
-
-#ifdef FACTOR_64
+#ifdef WIN64
+ #define CELL_FORMAT "%Iu"
+ #define CELL_HEX_FORMAT "%Ix"
#define CELL_HEX_PAD_FORMAT "%016Ix"
#else
- #define CELL_HEX_PAD_FORMAT "%08Ix"
+ #define CELL_FORMAT "%lu"
+ #define CELL_HEX_FORMAT "%lx"
+ #define CELL_HEX_PAD_FORMAT "%08lx"
#endif
#define FIXNUM_FORMAT "%Id"
@@ -34,7 +35,7 @@ typedef wchar_t F_CHAR;
#define OPEN_READ(path) _wfopen(path,L"rb")
#define OPEN_WRITE(path) _wfopen(path,L"wb")
-#define print_native_string(string) wprintf(L"%s",arg)
+#define print_native_string(string) wprintf(L"%s",string)
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
From dad3a5ead1db0e54a2d647c507cb9c6552b70a2d Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Wed, 19 Nov 2008 02:00:00 +0100
Subject: [PATCH 005/126] Emacs factor-mode: correct indentation for field
setters after constructors.
---
misc/factor.el | 36 ++++++++++++++++++++++++++++++++++--
1 file changed, 34 insertions(+), 2 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index c18a3102e7..f75cb7f359 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -281,10 +281,27 @@ value from the existing code in the buffer."
(defsubst factor--at-begin-of-def ()
(looking-at "\\([^ ]\\|^\\)+:"))
+(defsubst factor--looking-at-emptiness ()
+ (looking-at "^[ \t]*$"))
+
(defun factor--at-end-of-def ()
(or (looking-at ".*;[ \t]*$")
(looking-at factor--regex-single-liner)))
+(defun factor--at-setter-line ()
+ (save-excursion
+ (beginning-of-line)
+ (if (not (factor--looking-at-emptiness))
+ (re-search-forward factor--regex-setter (line-end-position) t)
+ (forward-line -1)
+ (or (factor--at-constructor-line)
+ (factor--at-setter-line)))))
+
+(defun factor--at-constructor-line ()
+ (save-excursion
+ (beginning-of-line)
+ (re-search-forward factor--regex-constructor (line-end-position) t)))
+
(defun factor--indent-in-brackets ()
(save-excursion
(beginning-of-line)
@@ -303,14 +320,28 @@ value from the existing code in the buffer."
(beginning-of-line)
(when (factor--at-begin-of-def) 0)))
+(defun factor--indent-setter-line ()
+ (when (factor--at-setter-line)
+ (save-excursion
+ (beginning-of-line)
+ (let ((indent (when (factor--at-constructor-line) (current-indentation))))
+ (while (not (or indent
+ (bobp)
+ (factor--at-begin-of-def)
+ (factor--at-end-of-def)))
+ (if (factor--at-constructor-line)
+ (setq indent (+ (current-indentation) factor-indent-width))
+ (forward-line -1)))
+ indent))))
+
(defun factor--indent-continuation ()
(save-excursion
(forward-line -1)
(beginning-of-line)
(if (bobp) 0
- (if (looking-at "^[ \t]*$")
+ (if (factor--looking-at-emptiness)
(factor--indent-continuation)
- (if (factor--at-end-of-def)
+ (if (or (factor--at-end-of-def) (factor--at-setter-line))
(- (current-indentation) factor-indent-width)
(if (factor--at-begin-of-def)
(+ (current-indentation) factor-indent-width)
@@ -321,6 +352,7 @@ value from the existing code in the buffer."
(or (and (bobp) 0)
(factor--indent-definition)
(factor--indent-in-brackets)
+ (factor--indent-setter-line)
(factor--indent-continuation)
0))
From 13509fcabe78f3a16724aeff9021be878521a2ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 18 Nov 2008 20:35:41 -0600
Subject: [PATCH 006/126] Fix memory corruption in cap
---
extra/cap/cap.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor
index ea5462acf2..3bd1a5f174 100644
--- a/extra/cap/cap.factor
+++ b/extra/cap/cap.factor
@@ -6,7 +6,7 @@ models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry alien.syntax ;
IN: cap
: screenshot-array ( world -- byte-array )
- dim>> product 3 * <byte-array> ;
+ dim>> [ first 3 * 4 align ] [ second ] bi * <byte-array> ;
: gl-screenshot ( gadget -- byte-array )
[
From db42113bb9d8a3fb71e3640c2f9c854b2e1ac5ef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 18 Nov 2008 20:35:50 -0600
Subject: [PATCH 007/126] Fix ui.render.test
---
extra/ui/render/test/reference.bmp | Bin 73554 -> 73654 bytes
extra/ui/render/test/test.factor | 36 ++++++++++++++++-------------
2 files changed, 20 insertions(+), 16 deletions(-)
diff --git a/extra/ui/render/test/reference.bmp b/extra/ui/render/test/reference.bmp
index 0740fcc8173f0a6fc4fcfa76802b5146e5a7c59b..3ba20c404340ea581d6be7d0dd0c81ef97940cec 100644
GIT binary patch
literal 73654
zcmeI%L6X`q5QSmq7Fnb!+ngW=$Ue8orMO6Lmi0uoQA-gRx7>of!oLf!kR{VReRfeZ
zKYsrH`e~ZC@9Ft1J^!TVuk`#heNL~_^yPYdd2@aFU~?xhO&>g*3AjUj?!YOXzUEGQ
zD}g1b=Pt(EoIPCwA{)N9Jh%O6!E}~QM9)?kIzi#Pb-eYy_I+X7NMIF@?=3~T{f+Of
zTi2QUlX-mW3VvJ}zIQKOd_N{6eH7pLmIfLu4&V3=5|W;dZ+uGw4Hk!Qd<O|hPscaD
zrGW;E!#BQzgrukA8{g7EgT>(+-$6ps)A5aOX`sR4@Qv>vA?fM(#<w)kU~%}ycaV_u
zbbRAm8fdUMeB(PvNP0TH@huHBSRB6b9V8?@9pCtt1{y35-}nv^lAexld`klj7Kd+q
z2MI|}$2Y#Efd-4iH@<^}q^IK>-_k&X#o-&@K|<2g@r`e3puytsjqe~K>FM~!w=~dT
zarnk}kdX9reB)ahXs|eZ<2y)5dOE)GEe$kS9KP`#BqTi@-}sgW8Y~Xq_zn`1o{n#P
zO9KrShi`lb2}w`KH@>BT28+WtzJr9Mr{f#n(m;d7;TzvULekUmjc;k7!Q$|Z?;s)R
z>G;OCG|*si_{MjTko0tX<69bNusD3<J4i@+I=+wio~DmukKGUR4Vac?lZGWy+!E9^
z)XU}Ki}zfkES5z2x|LR}C(rKP<J)`rq-1TeY$1E&e(&)Xiv?98vu|FG<t|T89^1Re
zH@<t#Y>t26yBN-`yf3$n+n&u&av#7qzTH^%2IAX`NpM_RT)V;8Lhh~jxsF>b7L-MH
ztS25H_iyi|gzsH#`1WEF9EWdw3$h$m629?043prA@QrUlmcvTIH@=5q5<C&U@h!-5
zSV{QC_b^O?C&G8ccbQxM5}x}!J$Y>Jp1*&4FQt^MErk7{w>R$h9&fQ&P$e?^=H*!K
z^7Q1fy?cD)yVuO-`1`&S-vf`$59vFAZ+!QOc`*9E?`DGMZhbqZIf?r%zVYqGvNsUl
zUQB}H(&E}}#TIgJ#m{xzVzHnsvSU5*__%+2FC~2MYQwh|li)af<6DsBu#)hN?_rn(
zPlRuL3$h$m629?043prA@QrUlmcvTIH@=5q5<C&U@h!-5SV{QC_b^O?C&G8ccbQxM
zlbQQGJ$Y>Jp8sEZFQt^MErk7}t~c)Y9&fQ&P$e?^=H*!K^7Q1fy?cD)yVuO-`1`&S
z-vf`E5Am+kzgG*sy}6~pEjnAsn^ib<hs9z+mB=iZax8awdgk!wEzh~Xza4|`HIx0<
zl&HmP3wb~0v-Vmn7F3DMGAYM$m#1g(ohCdWz8-1@;Co;8I${a;x+J!cd5PH130N#e
zY;NU!xk-3>>R1h~H9SZ0jqln?sQnt>sl<kO{kCq;BiGU1MLzMkC8+c=Z?=%@TVB@$
zEEdnb*)ygNwuPJLZ}qQp@$J22Q(iezeAn<w`<1?z<(Sv5eEiaCdhm_!M#%BE`1WEF
z9G8~eZWgwX$1S|$OpC>WvdE70)FHJu=6uGj{&g<*Z||j)^2(9&`=o|f+As6{z;t_P
zSvKz)pLra<3*?Q~YkW6?*IKO88rS}`JF{B<cVB{9L*xE^&7s-7z<0y9E?_;>4B+>P
zS9pq&-zT-F+xD}4H+F9eSl6=d$2Y!f525x0-{rh^ldvvNPtUImJ8^2@`=IZ%mTb2P
zthS2S(#q<N_2k*Tdwd`9-J9~+#uvk>b?h-HGJNBE5T)ug#dp>DUz)RTHfI9I?nLLD
K<&5;%!=}F=HK2U}
literal 73554
zcmeIwu?Ye}7=+RPx-bw-t-u1zO{~HGGvjlWD?&cr!Y&*a&CI($o|kRD=eF*3-S@h$
zb+<XKcjkQj|9u?K?r5Ofz;vTYrh%Pr2+9rcU0zo<z8NStz;}6F+4yFl+yLL@b!Fq5
zfpP<Um)DhzZwAT@@LgV4Hoh4sH^6s!UD^0%pxgl8<#lD_n}Koze3#dijc*3Z4e(uF
zS2n&GC^x`&d0pA~W}w^v-{o~><C}qU1ALd)m5px($_?;cURO5087McvcX?ge_-3Ho
z0N>?xW#gNHaszyq*OiTL2FeZaU0zo<z8NStz;}6F+4yFl+yLL@b!Fq5fpP<Um)Dhz
zZwAT@@LgV4Hoh4sH^6s!UD^0%pxgl8<#lD_n}Koze3#dijc*3Z4e(uFS2n&GC^x`&
zd0pA~W}w^v-{o~><C}qU1ALd)m5px($_?;cURO5087McvcX?ge_-3Ho0N>?xW#gNH
zaszyq*OiTL2FeZaU0zo<z8NStz;}6F+4yFl+yLL@b!Fq5fpP<Um)DhzZwAT@@LgV4
zHoh4sH^6s!UD^0%pxgl8<#lD_n}Koze3#dijc*3Z4e(uFS2n&GC^x`&d0pA~W}w^v
z-{o~><C}qU1ALd)m5px($_?;cURO5087McvcX?ge_-3Ho0N>?xW#gNHaszyq*OiTL
O2FeZaU0(OkvwZ-#zpe-X
diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor
index bf7b7b4556..484d255b72 100755
--- a/extra/ui/render/test/test.factor
+++ b/extra/ui/render/test/test.factor
@@ -17,8 +17,6 @@ M: line-test draw-interior
line-test >>interior
{ 1 10 } >>dim ;
-TUPLE: ui-render-test < pack { first-time? initial: t } ;
-
: message-window ( text -- )
<label> "Message" open-window ;
@@ -26,24 +24,30 @@ TUPLE: ui-render-test < pack { first-time? initial: t } ;
#! On Windows, white is { 253 253 253 } ?
[ dup 253 = [ 2 + ] when ] map ;
-: check-rendering ( gadget -- )
- gl-screenshot twiddle
- "resource:extra/ui/render/test/reference.bmp" load-bitmap array>>
- = "perfect" "needs work" ? "Your UI rendering is " prepend
- message-window ;
+SYMBOL: render-output
-M: ui-render-test draw-gadget*
- [ call-next-method ] [
- dup first-time?>> [
- dup check-rendering
- f >>first-time?
- ] when
- drop
+: check-rendering ( gadget -- )
+ screenshot [ twiddle ] change-array
+ [ render-output set-global ]
+ [
+ "resource:extra/ui/render/test/reference.bmp" load-bitmap
+ [ array>> ] bi@ = "perfect" "needs work" ?
+ "Your UI rendering is " prepend
+ message-window
] bi ;
+TUPLE: take-screenshot { first-time? initial: t } ;
+
+M: take-screenshot draw-boundary
+ dup first-time?>> [
+ over check-rendering
+ f >>first-time?
+ ] when
+ 2drop ;
+
: <ui-render-test> ( -- gadget )
- \ ui-render-test new-gadget
- { 1 0 } >>orientation
+ <shelf>
+ take-screenshot new >>boundary
<gadget>
black <solid> >>interior
{ 98 98 } >>dim
From bfc44e68cde0f701abb7f5358c322865d64b477c Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Tue, 18 Nov 2008 20:51:45 -0600
Subject: [PATCH 008/126] Another render test fix; more fuzz
---
extra/ui/render/test/test.factor | 22 +++++++++++++++-------
1 file changed, 15 insertions(+), 7 deletions(-)
diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor
index 484d255b72..0493b83fd3 100755
--- a/extra/ui/render/test/test.factor
+++ b/extra/ui/render/test/test.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors arrays kernel sequences math byte-arrays
-namespaces cap graphics.bitmap
+namespaces grouping fry cap graphics.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 ;
@@ -20,18 +20,26 @@ M: line-test draw-interior
: message-window ( text -- )
<label> "Message" open-window ;
-: twiddle ( bytes -- bytes )
- #! On Windows, white is { 253 253 253 } ?
- [ dup 253 = [ 2 + ] when ] map ;
-
SYMBOL: render-output
+: twiddle ( bytes -- bytes )
+ #! On Windows, white is { 253 253 253 } ?
+ [ 10 /i ] map ;
+
+: stride ( bitmap -- n ) width>> 3 * ;
+
+: bitmap= ( bitmap1 bitmap2 -- ? )
+ [
+ [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi
+ '[ _ head twiddle ] map
+ ] bi@ = ;
+
: check-rendering ( gadget -- )
- screenshot [ twiddle ] change-array
+ screenshot
[ render-output set-global ]
[
"resource:extra/ui/render/test/reference.bmp" load-bitmap
- [ array>> ] bi@ = "perfect" "needs work" ?
+ bitmap= "perfect" "needs work" ?
"Your UI rendering is " prepend
message-window
] bi ;
From ebd95130206aa99bac457c7c6faa22bde1929813 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 18 Nov 2008 21:57:50 -0600
Subject: [PATCH 009/126] Fix stray pixel on Linux
---
basis/ui/gadgets/buttons/buttons.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index c975e64b12..d74284cbd6 100644
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/basis/ui/gadgets/buttons/buttons.factor
@@ -6,7 +6,6 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect locals alien.c-types ;
-
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
@@ -111,10 +110,10 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ;
: checkmark-points ( dim -- points )
{
- [ { 0 0 } v* ]
- [ { 1 1 } v* ]
- [ { 0 1 } v* ]
- [ { 1 0 } v* ]
+ [ { 0 0 } v* { 0.5 0.5 } v+ ]
+ [ { 1 1 } v* { 0.5 0.5 } v+ ]
+ [ { 1 0 } v* { -0.3 0.5 } v+ ]
+ [ { 0 1 } v* { -0.3 0.5 } v+ ]
} cleave 4array ;
: checkmark-vertices ( dim -- vertices )
From 7bf450e0f1fd630a1dc6e36b47a2eb17b9753bef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 18 Nov 2008 21:58:30 -0600
Subject: [PATCH 010/126] Fix typo
---
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 484d255b72..e13b829b75 100755
--- a/extra/ui/render/test/test.factor
+++ b/extra/ui/render/test/test.factor
@@ -31,8 +31,8 @@ SYMBOL: render-output
[ render-output set-global ]
[
"resource:extra/ui/render/test/reference.bmp" load-bitmap
- [ array>> ] bi@ = "perfect" "needs work" ?
- "Your UI rendering is " prepend
+ [ array>> ] bi@ = "is perfect" "needs work" ?
+ "Your UI rendering " prepend
message-window
] bi ;
From d62a6c4b094c144e250e5bacb79e589854eb9875 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 18 Nov 2008 22:08:02 -0600
Subject: [PATCH 011/126] Minor core cleanup
---
core/kernel/kernel-docs.factor | 6 +++---
core/kernel/kernel.factor | 12 ++++++------
2 files changed, 9 insertions(+), 9 deletions(-)
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 289d39868c..40094d5589 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -606,7 +606,7 @@ HELP: 3compose
} ;
HELP: dip
-{ $values { "obj" object } { "quot" quotation } }
+{ $values { "x" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
{ $code ">r foo bar r>" }
@@ -614,7 +614,7 @@ HELP: dip
} ;
HELP: 2dip
-{ $values { "obj1" object } { "obj2" object } { "quot" quotation } }
+{ $values { "x" object } { "y" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } " and " { $snippet "obj2" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
{ $code ">r >r foo bar r> r>" }
@@ -622,7 +622,7 @@ HELP: 2dip
} ;
HELP: 3dip
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" quotation } }
+{ $values { "x" object } { "y" object } { "z" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
{ $code ">r >r >r foo bar r> r> r>" }
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 62e37ef301..18bead109d 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -55,18 +55,18 @@ DEFER: if
: 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline
-: dip ( obj quot -- obj ) swap slip ; inline
+: dip ( x quot -- x ) swap slip ; inline
-: 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline
+: 2dip ( x y quot -- x y ) swap >r dip r> ; inline
-: 3dip ( obj1 obj2 obj3 quot -- obj1 obj2 obj3 ) -roll 3slip ; inline
+: 3dip ( x y z quot -- x y z ) swap >r 2dip r> ; inline
! Keepers
-: keep ( x quot -- x ) over slip ; inline
+: keep ( x quot -- x ) dupd dip ; inline
-: 2keep ( x y quot -- x y ) 2over 2slip ; inline
+: 2keep ( x y quot -- x y ) >r 2dup r> 2dip ; inline
-: 3keep ( x y z quot -- x y z ) >r 3dup r> -roll 3slip ; inline
+: 3keep ( x y z quot -- x y z ) >r 3dup r> 3dip ; inline
! Cleavers
: bi ( x p q -- )
From bcd314aa465b96e2ed9e04af15ebbf2d387bf93e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 18 Nov 2008 22:54:22 -0600
Subject: [PATCH 012/126] less aggressive make clean
---
Makefile | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/Makefile b/Makefile
index 973ba1f3d4..7ef6be33da 100644
--- a/Makefile
+++ b/Makefile
@@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean:
rm -f vm/*.o
- rm -f factor*.dll libfactor*.*
+ rm -f factor*.dll libfactor{.a,.so}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
From 020a866e426d6554225e54938170d79936518a49 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 18 Nov 2008 23:56:51 -0600
Subject: [PATCH 013/126] disable regexp failing tests for now
---
basis/regexp/regexp-tests.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor
index 4878b67d0f..388a71e028 100644
--- a/basis/regexp/regexp-tests.factor
+++ b/basis/regexp/regexp-tests.factor
@@ -347,6 +347,8 @@ IN: regexp-tests
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
-[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
+! Disable tests so builds will upload, for now...
-[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
+! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
+
+! [ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
From fb2523dc8187d0e8d13184d872bf350a39c110c8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 01:57:44 -0600
Subject: [PATCH 014/126] Revert "disable regexp failing tests for now"
This reverts commit 020a866e426d6554225e54938170d79936518a49.
---
basis/regexp/regexp-tests.factor | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor
index 388a71e028..4878b67d0f 100644
--- a/basis/regexp/regexp-tests.factor
+++ b/basis/regexp/regexp-tests.factor
@@ -347,8 +347,6 @@ IN: regexp-tests
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
-! Disable tests so builds will upload, for now...
+[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
-! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
-
-! [ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
+[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
From 358f99d7dd8aa3adae2db7f6eb1bab0039ed5b9a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 01:58:22 -0600
Subject: [PATCH 015/126] Revert "less aggressive make clean"
This reverts commit bcd314aa465b96e2ed9e04af15ebbf2d387bf93e.
---
Makefile | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/Makefile b/Makefile
index 7ef6be33da..973ba1f3d4 100644
--- a/Makefile
+++ b/Makefile
@@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean:
rm -f vm/*.o
- rm -f factor*.dll libfactor{.a,.so}
+ rm -f factor*.dll libfactor*.*
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
From 5df0a0073f74a02c90d22b69b0b2f1a624fcb13d Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Wed, 19 Nov 2008 10:37:54 +0100
Subject: [PATCH 016/126] Emacs factor-mode: small indentation fixes and
cleanups.
---
misc/factor.el | 35 +++++++++++++++++++----------------
1 file changed, 19 insertions(+), 16 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index f75cb7f359..170da980be 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -265,7 +265,7 @@ value from the existing code in the buffer."
(defsubst factor--ppss-brackets-start ()
(nth 1 (syntax-ppss)))
-(defsubst factor--line-indent (pos)
+(defsubst factor--indentation-at (pos)
(save-excursion (goto-char pos) (current-indentation)))
(defconst factor--regex-closing-paren "[])}]")
@@ -276,7 +276,8 @@ value from the existing code in the buffer."
(= (- (point) (line-beginning-position)) (current-indentation)))
(defconst factor--regex-single-liner
- (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" "PRIVATE>" "<PRIVATE" "USE:"))))
+ (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
+ "PRIVATE>" "<PRIVATE" "SYMBOL:" "USE:"))))
(defsubst factor--at-begin-of-def ()
(looking-at "\\([^ ]\\|^\\)+:"))
@@ -302,6 +303,11 @@ value from the existing code in the buffer."
(beginning-of-line)
(re-search-forward factor--regex-constructor (line-end-position) t)))
+(defsubst factor--increased-indentation (&optional i)
+ (+ (or i (current-indentation)) factor-indent-width))
+(defsubst factor--decreased-indentation (&optional i)
+ (- (or i (current-indentation)) factor-indent-width))
+
(defun factor--indent-in-brackets ()
(save-excursion
(beginning-of-line)
@@ -312,8 +318,8 @@ value from the existing code in the buffer."
(let ((op (factor--ppss-brackets-start)))
(when (> (line-number-at-pos) (line-number-at-pos op))
(if (factor--at-closing-paren-p)
- (factor--line-indent op)
- (+ (factor--line-indent op) factor-indent-width)))))))
+ (factor--indentation-at op)
+ (factor--increased-indentation (factor--indentation-at op))))))))
(defun factor--indent-definition ()
(save-excursion
@@ -323,29 +329,26 @@ value from the existing code in the buffer."
(defun factor--indent-setter-line ()
(when (factor--at-setter-line)
(save-excursion
- (beginning-of-line)
- (let ((indent (when (factor--at-constructor-line) (current-indentation))))
+ (let ((indent (and (factor--at-constructor-line) (current-indentation))))
(while (not (or indent
(bobp)
(factor--at-begin-of-def)
(factor--at-end-of-def)))
(if (factor--at-constructor-line)
- (setq indent (+ (current-indentation) factor-indent-width))
+ (setq indent (factor--increased-indentation))
(forward-line -1)))
indent))))
(defun factor--indent-continuation ()
(save-excursion
(forward-line -1)
- (beginning-of-line)
- (if (bobp) 0
- (if (factor--looking-at-emptiness)
- (factor--indent-continuation)
- (if (or (factor--at-end-of-def) (factor--at-setter-line))
- (- (current-indentation) factor-indent-width)
- (if (factor--at-begin-of-def)
- (+ (current-indentation) factor-indent-width)
- (current-indentation)))))))
+ (while (and (not (bobp)) (factor--looking-at-emptiness))
+ (forward-line -1))
+ (if (or (factor--at-end-of-def) (factor--at-setter-line))
+ (factor--decreased-indentation)
+ (if (factor--at-begin-of-def)
+ (factor--increased-indentation)
+ (current-indentation)))))
(defun factor--calculate-indentation ()
"Calculate Factor indentation for line at point."
From 12601b7eb03938bdb588dd2151e6b34240b7d81e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 13:02:33 -0600
Subject: [PATCH 017/126] Add failing unit test
---
basis/locals/locals-tests.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index ca6697be1c..04e077fc4f 100644
--- a/basis/locals/locals-tests.factor
+++ b/basis/locals/locals-tests.factor
@@ -388,6 +388,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
+[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
+
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]
From 5bf4065314f7661fba3d0ca56e92b06f5dd99a7f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 14:28:26 -0600
Subject: [PATCH 018/126] better fix for deleting the factor library on make
clean
---
Makefile | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/Makefile b/Makefile
index 973ba1f3d4..ffcbf6364c 100644
--- a/Makefile
+++ b/Makefile
@@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean:
rm -f vm/*.o
- rm -f factor*.dll libfactor*.*
+ rm -f factor*.dll libfactor.{a,so,dylib}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
From cdf743666715a99546e44085429ab83fbaa1c2cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 16:01:48 -0600
Subject: [PATCH 019/126] Add parallel-cleave, parallel-spread, parallel-napply
combinators
---
.../combinators/combinators-docs.factor | 10 ++++-
.../combinators/combinators-tests.factor | 10 ++++-
.../combinators/combinators.factor | 40 +++++++++++++++----
3 files changed, 49 insertions(+), 11 deletions(-)
diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor
index cb07e5a8d6..c61967fc8a 100644
--- a/basis/concurrency/combinators/combinators-docs.factor
+++ b/basis/concurrency/combinators/combinators-docs.factor
@@ -27,11 +27,17 @@ HELP: parallel-filter
{ $errors "Throws an error if one of the iterations throws an error." } ;
ARTICLE: "concurrency.combinators" "Concurrent combinators"
-"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
+"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators."
+$nl
+"Concurrent sequence combinators:"
{ $subsection parallel-each }
{ $subsection 2parallel-each }
{ $subsection parallel-map }
{ $subsection 2parallel-map }
-{ $subsection parallel-filter } ;
+{ $subsection parallel-filter }
+"Concurrent cleave combinators:"
+{ $subsection parallel-cleave }
+{ $subsection parallel-spread }
+{ $subsection parallel-napply } ;
ABOUT: "concurrency.combinators"
diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor
index 562111242d..3a38daed86 100644
--- a/basis/concurrency/combinators/combinators-tests.factor
+++ b/basis/concurrency/combinators/combinators-tests.factor
@@ -1,6 +1,7 @@
IN: concurrency.combinators.tests
USING: concurrency.combinators tools.test random kernel math
-concurrency.mailboxes threads sequences accessors arrays ;
+concurrency.mailboxes threads sequences accessors arrays
+math.parser ;
[ [ drop ] parallel-each ] must-infer
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
@@ -45,3 +46,10 @@ concurrency.mailboxes threads sequences accessors arrays ;
] unit-test
[ { f } [ "OOPS" throw ] parallel-each ] must-fail
+
+[ "1a" "4b" "3c" ] [
+ 2
+ { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave
+ [ number>string ] 3 parallel-napply
+ { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread
+] unit-test
diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor
index ab3ca7ed4a..4608faf79b 100644
--- a/basis/concurrency/combinators/combinators.factor
+++ b/basis/concurrency/combinators/combinators.factor
@@ -1,34 +1,58 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.futures concurrency.count-downs sequences
-kernel ;
+kernel macros fry combinators generalizations ;
IN: concurrency.combinators
<PRIVATE
+
: (parallel-each) ( n quot -- )
- >r <count-down> r> keep await ; inline
+ [ <count-down> ] dip keep await ; inline
+
PRIVATE>
: parallel-each ( seq quot -- )
over length [
- [ >r curry r> spawn-stage ] 2curry each
+ '[ _ curry _ spawn-stage ] each
] (parallel-each) ; inline
: 2parallel-each ( seq1 seq2 quot -- )
2over min-length [
- [ >r 2curry r> spawn-stage ] 2curry 2each
+ '[ _ 2curry _ spawn-stage ] 2each
] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq )
- over >r pusher >r each r> r> like ; inline
+ over [ pusher [ each ] dip ] dip like ; inline
<PRIVATE
+
+: [future] ( quot -- quot' ) '[ _ curry future ] ; inline
+
: future-values dup [ ?future ] change-each ; inline
+
PRIVATE>
: parallel-map ( seq quot -- newseq )
- [ curry future ] curry map future-values ;
- inline
+ [future] map future-values ; inline
: 2parallel-map ( seq1 seq2 quot -- newseq )
- [ 2curry future ] curry 2map future-values ;
+ '[ _ 2curry future ] 2map future-values ;
+
+<PRIVATE
+
+: (parallel-spread) ( n -- spread-array )
+ [ ?future ] <repetition> ; inline
+
+: (parallel-cleave) ( quots -- quot-array spread-array )
+ [ [future] ] map dup length (parallel-spread) ; inline
+
+PRIVATE>
+
+MACRO: parallel-cleave ( quots -- )
+ (parallel-cleave) '[ _ cleave _ spread ] ;
+
+MACRO: parallel-spread ( quots -- )
+ (parallel-cleave) '[ _ spread _ spread ] ;
+
+MACRO: parallel-napply ( quot n -- )
+ [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;
From 84d1a91966cc056cf279867b6cc0117c7ffcd291 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 16:02:43 -0600
Subject: [PATCH 020/126] limited-completions now gives you the most relevant
completions if there are too many, instead of just giving back the empty list
---
basis/tools/completion/completion.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor
index 4bb6d6142f..2306ff53a8 100644
--- a/basis/tools/completion/completion.factor
+++ b/basis/tools/completion/completion.factor
@@ -72,7 +72,9 @@ IN: tools.completion
] if ;
: string-completions ( short strs -- seq )
- [ dup ] { } map>assoc completions ;
+ dup zip completions ;
: limited-completions ( short candidates -- seq )
- completions dup length 1000 > [ drop f ] when ;
+ [ completions ] [ drop ] 2bi
+ 2dup [ length 50 > ] [ empty? ] bi* and
+ [ 2drop f ] [ drop 50 short head ] if ;
From 60855571162c8bbc407819587fb8c69771436e2e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 16:03:05 -0600
Subject: [PATCH 021/126] Parser now prints an IN:/USING: form if restarts were
invoked; add more restarts for certain errors
---
basis/prettyprint/prettyprint.factor | 18 ++++++++++-
core/parser/parser.factor | 48 ++++++++++++++++++++++------
2 files changed, 55 insertions(+), 11 deletions(-)
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 3befdaff2b..1ecca0ec19 100644
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
-combinators quotations sets accessors colors ;
+combinators quotations sets accessors colors parser ;
IN: prettyprint
: make-pprint ( obj quot -- block in use )
@@ -48,6 +48,22 @@ IN: prettyprint
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ;
+: vocab-names ( words -- vocabs )
+ dictionary get
+ [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
+
+: prelude. ( -- )
+ in get use get vocab-names vocabs. ;
+
+[
+ nl
+ "Restarts were invoked adding vocabularies to the search path." print
+ "To avoid doing this in the future, add the following USING:" print
+ "and IN: forms at the top of the source file:" print nl
+ prelude.
+ nl
+] print-use-hook set-global
+
: with-use ( obj quot -- )
make-pprint vocabs. do-pprint ; inline
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index ed8fc4510b..00d13e6e56 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -52,7 +52,12 @@ SYMBOL: in
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
-ERROR: no-current-vocab ;
+TUPLE: no-current-vocab ;
+
+: no-current-vocab ( -- vocab )
+ \ no-current-vocab boa
+ { { "Define words in scratchpad vocabulary" "scratchpad" } }
+ throw-restarts dup set-in ;
: current-vocab ( -- str )
in get [ no-current-vocab ] unless* ;
@@ -64,20 +69,31 @@ ERROR: no-current-vocab ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
-: word-restarts ( possibilities -- restarts )
- natural-sort [
+: word-restarts ( possibilities name -- restarts )
+ [
+ natural-sort
[
- "Use the " swap vocabulary>> " vocabulary" 3append
- ] keep
- ] { } map>assoc ;
+ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep
+ ] { } map>assoc
+ ]
+ [ "Defer word in current vocabulary" swap 2array ] bi*
+ suffix ;
ERROR: no-word-error name ;
+SYMBOL: amended-use?
+
+: no-word-restarted ( restart-value -- word )
+ dup word?
+ [ amended-use? on dup vocabulary>> (use+) ]
+ [ create-in ]
+ if ;
+
: no-word ( name -- newword )
dup \ no-word-error boa
- swap words-named [ forward-reference? not ] filter
+ swap [ words-named [ forward-reference? not ] filter ] keep
word-restarts throw-restarts
- dup vocabulary>> (use+) ;
+ no-word-restarted ;
: check-forward ( str word -- word/f )
dup forward-reference? [
@@ -127,7 +143,9 @@ ERROR: staging-violation word ;
: parsed ( accum obj -- accum ) over push ;
: (parse-lines) ( lexer -- quot )
- [ f parse-until >quotation ] with-lexer ;
+ [
+ f parse-until >quotation
+ ] with-lexer ;
: parse-lines ( lines -- quot )
lexer-factory get call (parse-lines) ;
@@ -206,8 +224,18 @@ SYMBOL: interactive-vocabs
call
] with-scope ; inline
+SYMBOL: print-use-hook
+
+[ ] print-use-hook set-global
+
: parse-fresh ( lines -- quot )
- [ parse-lines ] with-file-vocabs ;
+ [
+ amended-use? off
+ parse-lines
+ amended-use? get [
+ print-use-hook get call
+ ] when
+ ] with-file-vocabs ;
: parsing-file ( file -- )
"quiet" get [
From 3ea773fa80b5afb5415d998915b379075022a97d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 16:10:00 -0600
Subject: [PATCH 022/126] remove UNKNOWN test
---
vm/os-netbsd.h | 1 -
1 file changed, 1 deletion(-)
diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h
index 54b5d0bcff..6486acda4a 100644
--- a/vm/os-netbsd.h
+++ b/vm/os-netbsd.h
@@ -2,5 +2,4 @@
#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
-#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
From 25d9fd68fc62247a2ddd15d4c66f384fb20383bb Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 16:22:42 -0600
Subject: [PATCH 023/126] translate directory-type flags to our factor symbols
---
basis/io/unix/files/files.factor | 9 ++++++---
basis/unix/bsd/bsd.factor | 10 ----------
basis/unix/unix.factor | 25 ++++++++++++++++++++++++-
core/io/files/files.factor | 1 +
4 files changed, 31 insertions(+), 14 deletions(-)
diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor
index 3f254e7713..98206bc992 100644
--- a/basis/io/unix/files/files.factor
+++ b/basis/io/unix/files/files.factor
@@ -117,8 +117,8 @@ M: unix stat>file-info ( stat -- file-info )
[ stat-st_blksize >>blocksize ]
} cleave ;
-M: unix stat>type ( stat -- type )
- stat-st_mode S_IFMT bitand {
+: n>file-type ( n -- type )
+ S_IFMT bitand {
{ S_IFREG [ +regular-file+ ] }
{ S_IFDIR [ +directory+ ] }
{ S_IFCHR [ +character-device+ ] }
@@ -129,6 +129,9 @@ M: unix stat>type ( stat -- type )
[ drop +unknown+ ]
} case ;
+M: unix stat>type ( stat -- type )
+ stat-st_mode n>file-type ;
+
! Linux has no extra fields in its stat struct
os {
{ macosx [ "io.unix.files.bsd" require ] }
@@ -150,7 +153,7 @@ os {
M: unix >directory-entry ( byte-array -- directory-entry )
[ dirent-d_name utf8 alien>string ]
- [ dirent-d_type ] bi directory-entry boa ;
+ [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
[
diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor
index bd66c5253e..bf426ad867 100644
--- a/basis/unix/bsd/bsd.factor
+++ b/basis/unix/bsd/bsd.factor
@@ -83,16 +83,6 @@ C-STRUCT: passwd
: SEEK_CUR 1 ; inline
: SEEK_END 2 ; inline
-: DT_UNKNOWN 0 ; inline
-: DT_FIFO 1 ; inline
-: DT_CHR 2 ; inline
-: DT_DIR 4 ; inline
-: DT_BLK 6 ; inline
-: DT_REG 8 ; inline
-: DT_LNK 10 ; inline
-: DT_SOCK 12 ; inline
-: DT_WHT 14 ; inline
-
os {
{ macosx [ "unix.bsd.macosx" require ] }
{ freebsd [ "unix.bsd.freebsd" require ] }
diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor
index 4950daef2c..ca8a7a2e60 100644
--- a/basis/unix/unix.factor
+++ b/basis/unix/unix.factor
@@ -4,7 +4,7 @@ USING: alien alien.c-types alien.syntax kernel libc
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader qualified accessors
stack-checker macros locals generalizations unix.types
-debugger io prettyprint ;
+debugger io prettyprint io.files ;
IN: unix
: PROT_NONE 0 ; inline
@@ -20,6 +20,29 @@ IN: unix
: NGROUPS_MAX 16 ; inline
+: DT_UNKNOWN 0 ; inline
+: DT_FIFO 1 ; inline
+: DT_CHR 2 ; inline
+: DT_DIR 4 ; inline
+: DT_BLK 6 ; inline
+: DT_REG 8 ; inline
+: DT_LNK 10 ; inline
+: DT_SOCK 12 ; inline
+: DT_WHT 14 ; inline
+
+: dirent-type>file-type ( ch -- type )
+ {
+ { DT_BLK [ +block-device+ ] }
+ { DT_CHR [ +character-device+ ] }
+ { DT_DIR [ +directory+ ] }
+ { DT_LNK [ +symbolic-link+ ] }
+ { DT_SOCK [ +socket+ ] }
+ { DT_FIFO [ +fifo+ ] }
+ { DT_REG [ +regular-file+ ] }
+ { DT_WHT [ +whiteout+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
C-STRUCT: group
{ "char*" "gr_name" }
{ "char*" "gr_passwd" }
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index ca8125d936..25f6f36e7c 100644
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -175,6 +175,7 @@ SYMBOL: +character-device+
SYMBOL: +block-device+
SYMBOL: +fifo+
SYMBOL: +socket+
+SYMBOL: +whiteout+
SYMBOL: +unknown+
! File metadata
From e121a0822d3bc608df2d955de550b6008adfe7f4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 16:27:12 -0600
Subject: [PATCH 024/126] make a backup of the factor binary, library, and
image before bootstrapping
---
build-support/factor.sh | 69 +++++++++++++++++++++++++++++++++--------
1 file changed, 56 insertions(+), 13 deletions(-)
diff --git a/build-support/factor.sh b/build-support/factor.sh
index 8d75b8cff2..1a4aa9f965 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -131,10 +131,10 @@ check_library_exists() {
$ECHO "***Factor will compile NO_UI=1"
NO_UI=1
fi
- rm -f $GCC_TEST
- check_ret rm
- rm -f $GCC_OUT
- check_ret rm
+ $DELETE -f $GCC_TEST
+ check_ret $DELETE
+ $DELETE -f $GCC_OUT
+ check_ret $DELETE
$ECHO "found."
}
@@ -209,7 +209,7 @@ c_find_word_size() {
gcc -o $C_WORD $C_WORD.c
WORD=$(./$C_WORD)
check_ret $C_WORD
- rm -f $C_WORD*
+ $DELETE -f $C_WORD*
}
intel_macosx_word_size() {
@@ -236,17 +236,30 @@ find_word_size() {
set_factor_binary() {
case $OS in
- # winnt) FACTOR_BINARY=factor-nt;;
- # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
+ winnt) FACTOR_BINARY=factor.exe;;
*) FACTOR_BINARY=factor;;
esac
}
+set_factor_library() {
+ case $OS in
+ winnt) FACTOR_LIBRARY=factor.dll;;
+ macosx) FACTOR_LIBRARY=libfactor.dylib;;
+ *) FACTOR_LIBRARY=libfactor.a;;
+ esac
+}
+
+set_factor_image() {
+ FACTOR_IMAGE=factor.image
+}
+
echo_build_info() {
$ECHO OS=$OS
$ECHO ARCH=$ARCH
$ECHO WORD=$WORD
$ECHO FACTOR_BINARY=$FACTOR_BINARY
+ $ECHO FACTOR_LIBRARY=$FACTOR_LIBRARY
+ $ECHO FACTOR_IMAGE=$FACTOR_IMAGE
$ECHO MAKE_TARGET=$MAKE_TARGET
$ECHO BOOT_IMAGE=$BOOT_IMAGE
$ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
@@ -255,6 +268,8 @@ echo_build_info() {
$ECHO DOWNLOADER=$DOWNLOADER
$ECHO CC=$CC
$ECHO MAKE=$MAKE
+ $ECHO COPY=$COPY
+ $ECHO DELETE=$DELETE
}
check_os_arch_word() {
@@ -312,6 +327,8 @@ find_build_info() {
find_architecture
find_word_size
set_factor_binary
+ set_factor_library
+ set_factor_image
set_build_info
set_downloader
set_gcc
@@ -339,6 +356,28 @@ cd_factor() {
check_ret cd
}
+set_copy() {
+ case $OS in
+ winnt) COPY=cp;;
+ *) COPY=cp;;
+ esac
+}
+
+set_delete() {
+ case $OS in
+ winnt) DELETE=rm;;
+ *) DELETE=rm;;
+ esac
+}
+
+backup_factor() {
+ $ECHO "Backing up factor..."
+ $COPY $FACTOR_BINARY $FACTOR_BINARY.bak
+ $COPY $FACTOR_LIBRARY $FACTOR_LIBRARY.bak
+ $COPY $FACTOR_IMAGE $FACTOR_IMAGE.bak
+ $ECHO "Done with backup."
+}
+
check_makefile_exists() {
if [[ ! -e "Makefile" ]] ; then
echo ""
@@ -366,9 +405,9 @@ make_factor() {
update_boot_images() {
echo "Deleting old images..."
- rm checksums.txt* > /dev/null 2>&1
- rm $BOOT_IMAGE.* > /dev/null 2>&1
- rm temp/staging.*.image > /dev/null 2>&1
+ $DELETE checksums.txt* > /dev/null 2>&1
+ $DELETE $BOOT_IMAGE.* > /dev/null 2>&1
+ $DELETE temp/staging.*.image > /dev/null 2>&1
if [[ -f $BOOT_IMAGE ]] ; then
get_url http://factorcode.org/images/latest/checksums.txt
factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
@@ -382,7 +421,7 @@ update_boot_images() {
if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
echo "Your disk boot image matches the one on factorcode.org."
else
- rm $BOOT_IMAGE > /dev/null 2>&1
+ $DELETE $BOOT_IMAGE > /dev/null 2>&1
get_boot_image;
fi
else
@@ -459,6 +498,7 @@ install() {
update() {
get_config_info
git_pull_factorcode
+ backup_factor
make_clean
make_factor
}
@@ -469,12 +509,12 @@ update_bootstrap() {
}
refresh_image() {
- ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
+ ./$FACTOR_BINARY -script -e="USE: vocabs.loader USE: system refresh-all USE: memory save 0 exit"
check_ret factor
}
make_boot_image() {
- ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
+ ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: system USE: bootstrap.image make-image save 0 exit"
check_ret factor
}
@@ -513,6 +553,9 @@ if [[ -n "$2" ]] ; then
parse_build_info $2
fi
+set_copy
+set_delete
+
case "$1" in
install) install ;;
install-x11) install_build_system_apt; install ;;
From 002563ce44e958c6ef95ed5f19946031327ef10a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 16:27:16 -0600
Subject: [PATCH 025/126] Add DWIM mode
---
core/parser/parser.factor | 28 +++++++++++++++-------------
1 file changed, 15 insertions(+), 13 deletions(-)
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 00d13e6e56..007120fd19 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -69,20 +69,21 @@ TUPLE: no-current-vocab ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
-: word-restarts ( possibilities name -- restarts )
- [
- natural-sort
- [
- [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep
- ] { } map>assoc
- ]
- [ "Defer word in current vocabulary" swap 2array ] bi*
+: word-restarts ( name possibilities -- restarts )
+ natural-sort
+ [ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc
+ swap "Defer word in current vocabulary" swap 2array
suffix ;
ERROR: no-word-error name ;
+: <no-word-error> ( name possibilities -- error restarts )
+ [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
+
SYMBOL: amended-use?
+SYMBOL: do-what-i-mean?
+
: no-word-restarted ( restart-value -- word )
dup word?
[ amended-use? on dup vocabulary>> (use+) ]
@@ -90,10 +91,11 @@ SYMBOL: amended-use?
if ;
: no-word ( name -- newword )
- dup \ no-word-error boa
- swap [ words-named [ forward-reference? not ] filter ] keep
- word-restarts throw-restarts
- no-word-restarted ;
+ dup words-named [ forward-reference? not ] filter
+ dup length 1 = do-what-i-mean? get and
+ [ nip first no-word-restarted ]
+ [ <no-word-error> throw-restarts no-word-restarted ]
+ if ;
: check-forward ( str word -- word/f )
dup forward-reference? [
@@ -226,7 +228,7 @@ SYMBOL: interactive-vocabs
SYMBOL: print-use-hook
-[ ] print-use-hook set-global
+print-use-hook global [ [ ] or ] change-at
: parse-fresh ( lines -- quot )
[
From a62641e4698466ceb84585c6ad204adafed47abc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 16:32:12 -0600
Subject: [PATCH 026/126] add .bak to gitignore for factor backups
---
.gitignore | 1 +
1 file changed, 1 insertion(+)
diff --git a/.gitignore b/.gitignore
index 290f075aae..f4334f3727 100644
--- a/.gitignore
+++ b/.gitignore
@@ -20,3 +20,4 @@ temp
logs
work
build-support/wordsize
+*.bak
From 1ef21ba2d3626ee4186ba129543abf21534f4ae9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 16:40:50 -0600
Subject: [PATCH 027/126] add type to directory-entry on windows
---
basis/io/windows/files/files.factor | 13 ++++++++-----
1 file changed, 8 insertions(+), 5 deletions(-)
diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor
index d0409ce59a..5746eb252d 100755
--- a/basis/io/windows/files/files.factor
+++ b/basis/io/windows/files/files.factor
@@ -114,11 +114,6 @@ M: windows delete-directory ( path -- )
normalize-path
RemoveDirectory win32-error=0/f ;
-M: windows >directory-entry ( byte-array -- directory-entry )
- [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
- [ WIN32_FIND_DATA-dwFileAttributes ]
- bi directory-entry boa ;
-
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck
FindFirstFile
@@ -177,6 +172,14 @@ TUPLE: windows-file-info < file-info attributes ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
+TUPLE: windows-directory-entry < directory-entry attributes ;
+
+M: windows >directory-entry ( byte-array -- directory-entry )
+ [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
+ tri windows-directory-entry boa ;
+
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{
From 4849636fd7b7ad6ceb6e37f93493d566e1b02286 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 16:45:13 -0600
Subject: [PATCH 028/126] remove attribute if it's the same as the type
---
basis/io/windows/files/files.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor
index 5746eb252d..7f84b9d9e5 100755
--- a/basis/io/windows/files/files.factor
+++ b/basis/io/windows/files/files.factor
@@ -178,7 +178,8 @@ M: windows >directory-entry ( byte-array -- directory-entry )
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
- tri windows-directory-entry boa ;
+ tri
+ dupd remove windows-directory-entry boa ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
From 3e93d3599c75a423795ea67366681544ce06b971 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 17:00:35 -0600
Subject: [PATCH 029/126] make a copy of your boot image before deleting it
---
build-support/factor.sh | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/build-support/factor.sh b/build-support/factor.sh
index 1a4aa9f965..b2b6ad1ff9 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -374,6 +374,7 @@ backup_factor() {
$ECHO "Backing up factor..."
$COPY $FACTOR_BINARY $FACTOR_BINARY.bak
$COPY $FACTOR_LIBRARY $FACTOR_LIBRARY.bak
+ $COPY $BOOT_IMAGE $BOOT_IMAGE.bak
$COPY $FACTOR_IMAGE $FACTOR_IMAGE.bak
$ECHO "Done with backup."
}
@@ -406,7 +407,8 @@ make_factor() {
update_boot_images() {
echo "Deleting old images..."
$DELETE checksums.txt* > /dev/null 2>&1
- $DELETE $BOOT_IMAGE.* > /dev/null 2>&1
+ # delete boot images with one or two characters after the dot
+ $DELETE $BOOT_IMAGE.{?,??} > /dev/null 2>&1
$DELETE temp/staging.*.image > /dev/null 2>&1
if [[ -f $BOOT_IMAGE ]] ; then
get_url http://factorcode.org/images/latest/checksums.txt
From 6aff81052eab0b4273a6c53d8f7f7dc25479d25a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 17:10:19 -0600
Subject: [PATCH 030/126] Doc update
---
basis/math/geometry/rect/rect-docs.factor | 16 ++++++++++++++++
basis/ui/ui-docs.factor | 19 +------------------
2 files changed, 17 insertions(+), 18 deletions(-)
diff --git a/basis/math/geometry/rect/rect-docs.factor b/basis/math/geometry/rect/rect-docs.factor
index a892940363..0e34ace943 100644
--- a/basis/math/geometry/rect/rect-docs.factor
+++ b/basis/math/geometry/rect/rect-docs.factor
@@ -47,3 +47,19 @@ HELP: <zero-rect>
{ $values { "rect" "a new " { $link rect } } }
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
+ARTICLE: "math.geometry.rect" "Rectangles"
+"The " { $vocab-link "math.geometry.rect" } " vocabulary defines a rectangle data type and operations on them."
+{ $subsection rect }
+"Rectangles can be taken apart:"
+{ $subsection rect-loc }
+{ $subsection rect-dim }
+{ $subsection rect-bounds }
+{ $subsection rect-extent }
+"New rectangles can be created:"
+{ $subsection <zero-rect> }
+{ $subsection <rect> }
+{ $subsection <extent-rect> }
+"More utility words for working with rectangles:"
+{ $subsection offset-rect }
+{ $subsection rect-intersect }
+{ $subsection intersects? } ;
diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index 58509fc2df..c10205ed26 100644
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -105,24 +105,7 @@ ARTICLE: "gadgets" "Pre-made UI gadgets"
ARTICLE: "ui-geometry" "Gadget geometry"
"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
-{ $subsection rect }
-"Rectangles can be taken apart:"
-{ $subsection rect-loc }
-{ $subsection rect-dim }
-{ $subsection rect-bounds }
-{ $subsection rect-extent }
-"New rectangles can be created:"
-{ $subsection <zero-rect> }
-{ $subsection <rect> }
-{ $subsection <extent-rect> }
-"More utility words for working with rectangles:"
-{ $subsection offset-rect }
-{ $subsection rect-intersect }
-{ $subsection intersects? }
-
-! "A gadget's bounding box is always relative to its parent. "
-! { $subsection gadget-parent }
-
+{ $subsection "math.geometry.rect" }
"Word for converting from a child gadget's co-ordinate system to a parent's:"
{ $subsection relative-loc }
{ $subsection screen-loc }
From 6681d4bca3f98d92147ed0ad3662dabd70209297 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 17:13:10 -0600
Subject: [PATCH 031/126] Add an ABOUT: to math.geometry.rect
---
basis/math/geometry/rect/rect-docs.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/basis/math/geometry/rect/rect-docs.factor b/basis/math/geometry/rect/rect-docs.factor
index 0e34ace943..31c9e44b1d 100644
--- a/basis/math/geometry/rect/rect-docs.factor
+++ b/basis/math/geometry/rect/rect-docs.factor
@@ -63,3 +63,5 @@ ARTICLE: "math.geometry.rect" "Rectangles"
{ $subsection offset-rect }
{ $subsection rect-intersect }
{ $subsection intersects? } ;
+
+ABOUT: "math.geometry.rect"
From 344657b93b59360875ebab60bc5da1d8528f7a72 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 17:13:39 -0600
Subject: [PATCH 032/126] Improve scroll>rect and scroll>caret so that the
caret is always visible
---
basis/ui/gadgets/editors/editors.factor | 7 ++++---
basis/ui/gadgets/scrollers/scrollers.factor | 10 +++++-----
2 files changed, 9 insertions(+), 8 deletions(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 2cf6d24154..d42df93b72 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -120,9 +120,10 @@ M: editor ungraft*
: scroll>caret ( editor -- )
dup graft-state>> second [
- dup caret-loc over caret-dim <rect>
- over scroll>rect
- ] when drop ;
+ [
+ [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
+ ] keep scroll>rect
+ ] [ drop ] if ;
: draw-caret ( -- )
editor get focused?>> [
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index d1429c4006..6c37c37acf 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -43,7 +43,7 @@ scroller H{
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
tuck model>> <viewport> >>viewport
- dup viewport>> @center grid-add ;
+ dup viewport>> @center grid-add ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
@@ -54,18 +54,18 @@ scroller H{
] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ;
-: rect-min ( rect1 rect2 -- rect )
- >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
+: rect-min ( rect dim -- rect' )
+ [ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
: (scroll>rect) ( rect scroller -- )
[
scroller-value vneg offset-rect
viewport-gap offset-rect
] keep
- [ viewport>> rect-min ] keep
+ [ viewport>> dim>> rect-min ] keep
[
viewport>> 2rect-extent
- >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
+ [ v- { 1 1 } v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+
] keep dup scroller-value rot v+ swap scroll ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
From eb6cdcc06eb439c7ad67e9511cf8a02f318637ca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 17:41:39 -0600
Subject: [PATCH 033/126] Fix parser tests
---
core/parser/parser-tests.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index c4fa0890f9..d2d407e147 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -428,7 +428,7 @@ must-fail-with
"USE: this-better-not-exist" eval
] must-fail
-[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with
+[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
[ 92 ] [ "CHAR: \\" eval ] unit-test
[ 92 ] [ "CHAR: \\\\" eval ] unit-test
@@ -483,7 +483,7 @@ must-fail-with
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
-[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
+[ "DEFER: blah" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
[
"IN: parser.tests : blah ; parsing FORGET: blah" eval
From 6e9b2a6c739f911fc721ab017473b1ab8d785a89 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 17:47:12 -0600
Subject: [PATCH 034/126] Make limited scrollers more versatile: they now have
a min-dim and a max-dim
---
basis/ui/gadgets/scrollers/scrollers.factor | 10 ++++++----
basis/ui/tools/deploy/deploy.factor | 7 +++++--
basis/ui/tools/listener/listener.factor | 4 +++-
basis/ui/tools/traceback/traceback.factor | 5 ++++-
basis/ui/tools/workspace/workspace.factor | 11 +++++++----
5 files changed, 25 insertions(+), 12 deletions(-)
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 6c37c37acf..045ecc7990 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -129,10 +129,12 @@ M: scroller focusable-child*
M: scroller model-changed
nip f >>follows drop ;
-TUPLE: limited-scroller < scroller fixed-dim ;
+TUPLE: limited-scroller < scroller
+{ min-dim initial: { 0 0 } }
+{ max-dim initial: { 1/0. 1/0. } } ;
-: <limited-scroller> ( gadget dim -- scroller )
- >r limited-scroller new-scroller r> >>fixed-dim ;
+: <limited-scroller> ( gadget -- scroller )
+ limited-scroller new-scroller ;
M: limited-scroller pref-dim*
- fixed-dim>> ;
+ [ call-next-method ] [ min-dim>> vmax ] [ max-dim>> vmin ] tri ;
diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor
index 0ac89e122f..f310f72780 100644
--- a/basis/ui/tools/deploy/deploy.factor
+++ b/basis/ui/tools/deploy/deploy.factor
@@ -96,9 +96,12 @@ TUPLE: deploy-gadget < pack vocab settings ;
: com-close ( gadget -- )
close-window ;
+deploy-gadget "misc" "Miscellaneous commands" {
+ { T{ key-down f f "ESC" } com-close }
+} define-command-map
+
deploy-gadget "toolbar" f {
- { f com-close }
- { f com-help }
+ { T{ key-down f f "F1" } com-help }
{ f com-revert }
{ f com-save }
{ T{ key-down f f "RET" } com-deploy }
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index d842bf8a68..49ce5203d3 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -25,7 +25,9 @@ TUPLE: listener-gadget < track input output stack ;
: listener-input, ( listener -- listener )
dup <listener-input> >>input
dup input>>
- { 0 100 } <limited-scroller>
+ <limited-scroller>
+ { 0 100 } >>min-dim
+ { 1/0. 100 } >>max-dim
"Input" <labelled-gadget>
f track-add ;
diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor
index 6cb79916e0..7e2158e0e9 100644
--- a/basis/ui/tools/traceback/traceback.factor
+++ b/basis/ui/tools/traceback/traceback.factor
@@ -43,7 +43,10 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
<pane-control> ;
: <variables-gadget> ( model -- gadget )
- <namestack-display> { 400 400 } <limited-scroller> ;
+ <namestack-display>
+ <limited-scroller>
+ { 400 400 } >>min-dim
+ { 400 400 } >>max-dim ;
: variables ( traceback -- )
model>> <variables-gadget>
diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor
index bbe4b12712..f06e0aae26 100644
--- a/basis/ui/tools/workspace/workspace.factor
+++ b/basis/ui/tools/workspace/workspace.factor
@@ -47,12 +47,15 @@ M: gadget tool-scroller drop f ;
: get-tool ( class -- gadget )
get-workspace find-tool nip ;
+: <help-pane> ( topic -- pane )
+ <pane> [ [ help ] with-pane ] keep ;
+
: help-window ( topic -- )
[
- <pane> [ [ help ] with-pane ] keep
- { 550 700 } <limited-scroller>
- ] keep
- article-title open-window ;
+ <help-pane> <limited-scroller>
+ { 550 700 } >>max-dim
+ ] [ article-title ] bi
+ open-window ;
: hide-popup ( workspace -- )
dup popup>> track-remove
From b9e1f5bf8ae2382f5f4b247bd7751452ec4eda2a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 17:47:25 -0600
Subject: [PATCH 035/126] M: track pref-dim did not take the gap into account
---
basis/ui/gadgets/tracks/tracks.factor | 19 +++++++++++--------
1 file changed, 11 insertions(+), 8 deletions(-)
diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor
index 5a9683ceff..771c489ce3 100644
--- a/basis/ui/gadgets/tracks/tracks.factor
+++ b/basis/ui/gadgets/tracks/tracks.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io kernel math namespaces
- sequences words math.vectors ui.gadgets ui.gadgets.packs
- math.geometry.rect fry ;
+USING: accessors io kernel namespaces fry
+math math.vectors math.geometry.rect math.order
+sequences words ui.gadgets ui.gadgets.packs ;
IN: ui.gadgets.tracks
@@ -35,13 +35,16 @@ TUPLE: track < pack sizes ;
M: track layout* ( track -- ) dup track-layout pack-layout ;
-: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
+: track-pref-dims-1 ( track -- dim )
+ children>> pref-dims max-dim ;
: track-pref-dims-2 ( track -- dim )
- [ children>> pref-dims ] [ normalized-sizes ] bi
- [ [ v/n ] when* ] 2map
- max-dim
- [ >fixnum ] map ;
+ [
+ [ children>> pref-dims ] [ normalized-sizes ] bi
+ [ [ v/n ] when* ] 2map max-dim [ >fixnum ] map
+ ]
+ [ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
+ v+ ;
M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ]
From 503c0a09710c5b465d6f357e7912b02c44f064eb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 18:23:19 -0600
Subject: [PATCH 036/126] Add a new cookbook page
---
basis/help/cookbook/cookbook.factor | 19 +++++++++++++++++--
1 file changed, 17 insertions(+), 2 deletions(-)
diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor
index 9fb837a873..6e27bd9256 100644
--- a/basis/help/cookbook/cookbook.factor
+++ b/basis/help/cookbook/cookbook.factor
@@ -1,5 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
-prettyprint sequences vocabs.loader namespaces stack-checker ;
+prettyprint sequences vocabs.loader namespaces stack-checker
+help ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
@@ -324,6 +325,19 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
+ARTICLE: "cookbook-next" "Next steps"
+"Once you have read through " { $link "first-program" } " and " { $link "cookbook" } ", the best way to keep learning Factor is to start looking at some simple example programs. Here are a few particularly nice vocabularies which should keep you busy for a little while:"
+{ $list
+ { $vocab-link "base64" }
+ { $vocab-link "roman" }
+ { $vocab-link "rot13" }
+ { $vocab-link "smtp" }
+ { $vocab-link "time-server" }
+ { $vocab-link "tools.hexdump" }
+ { $vocab-link "webapps.counter" }
+}
+"If you see code in there that you do not understand, use " { $link see } " and " { $link help } " to explore." ;
+
ARTICLE: "cookbook" "Factor cookbook"
"The Factor cookbook is a high-level overview of the most important concepts required to program in Factor."
{ $subsection "cookbook-syntax" }
@@ -336,6 +350,7 @@ ARTICLE: "cookbook" "Factor cookbook"
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-compiler" }
{ $subsection "cookbook-philosophy" }
-{ $subsection "cookbook-pitfalls" } ;
+{ $subsection "cookbook-pitfalls" }
+{ $subsection "cookbook-next" } ;
ABOUT: "cookbook"
From af5e5611dceb9c625ba085ab2f2238e56da3f6ef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 18:59:30 -0600
Subject: [PATCH 037/126] Better invalid callable check
---
basis/prettyprint/backend/backend.factor | 16 +++++++++++++---
basis/prettyprint/prettyprint-tests.factor | 5 +++++
2 files changed, 18 insertions(+), 3 deletions(-)
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 31b6ba3f26..2af0224e32 100644
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -217,14 +217,24 @@ M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
+GENERIC: valid-callable? ( obj -- ? )
+
+M: object valid-callable? drop f ;
+
+M: quotation valid-callable? drop t ;
+
+M: curry valid-callable? quot>> valid-callable? ;
+
+M: compose valid-callable?
+ [ first>> ] [ second>> ] bi [ valid-callable? ] both? ;
+
M: curry pprint*
- dup quot>> callable? [ pprint-object ] [
+ dup valid-callable? [ pprint-object ] [
"( invalid curry )" swap present-text
] if ;
M: compose pprint*
- dup [ first>> callable? ] [ second>> callable? ] bi and
- [ pprint-object ] [
+ dup valid-callable? [ pprint-object ] [
"( invalid compose )" swap present-text
] if ;
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index 8eaaab3c1d..7fa3c5a1a3 100644
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -365,3 +365,8 @@ M: started-out-hustlin' ended-up-ballin' ; inline
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
[ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
] unit-test
+
+[ "( invalid curry )" ] [ 1 2 curry unparse ] unit-test
+[ "( invalid curry )" ] [ 1 2 3 curry curry unparse ] unit-test
+[ "( invalid compose )" ] [ 1 2 compose unparse ] unit-test
+[ "( invalid compose )" ] [ [ 1 ] 2 3 curry compose unparse ] unit-test
From e687d179e6b9fa4b1448464cf36b8cf25fd4974f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 18:59:53 -0600
Subject: [PATCH 038/126] Re-word fry docs slightly
---
basis/fry/fry-docs.factor | 12 +++++++-----
1 file changed, 7 insertions(+), 5 deletions(-)
diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor
index 286dbb469e..03ac01ad61 100644
--- a/basis/fry/fry-docs.factor
+++ b/basis/fry/fry-docs.factor
@@ -15,7 +15,7 @@ HELP: fry
} ;
HELP: '[
-{ $syntax "code... ]" }
+{ $syntax "'[ code... ]" }
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ;
@@ -49,6 +49,8 @@ $nl
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
+"The following is a no-op:"
+{ $code "'[ @ ]" }
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
@@ -74,14 +76,14 @@ ARTICLE: "fry.limitations" "Fried quotation limitations"
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
ARTICLE: "fry" "Fried quotations"
-"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."
+"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
$nl
-"Fried quotations are denoted with a special parsing word:"
+"Fried quotations are started by a special parsing word:"
{ $subsection POSTPONE: '[ }
-"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"
+"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
{ $subsection _ }
{ $subsection @ }
-"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."
+"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
{ $subsection "fry.examples" }
{ $subsection "fry.philosophy" }
{ $subsection "fry.limitations" }
From 044d3f06659cdcbfbc550a40f53229deb5098d9c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 19:06:41 -0600
Subject: [PATCH 039/126] Add another piece of info
---
basis/fry/fry-docs.factor | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor
index 03ac01ad61..8f402f2e8c 100644
--- a/basis/fry/fry-docs.factor
+++ b/basis/fry/fry-docs.factor
@@ -87,7 +87,10 @@ $nl
{ $subsection "fry.examples" }
{ $subsection "fry.philosophy" }
{ $subsection "fry.limitations" }
-"Quotations can also be fried without using a parsing word:"
-{ $subsection fry } ;
+"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
+$nl
+"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
+{ $subsection fry }
+"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
ABOUT: "fry"
From c75c4efefd73a599485fa3d9963c0ced0b5739a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 19:08:12 -0600
Subject: [PATCH 040/126] Add unit test for pack pref-dim bug
---
basis/ui/gadgets/labels/labels-tests.factor | 9 +++++++++
1 file changed, 9 insertions(+)
create mode 100644 basis/ui/gadgets/labels/labels-tests.factor
diff --git a/basis/ui/gadgets/labels/labels-tests.factor b/basis/ui/gadgets/labels/labels-tests.factor
new file mode 100644
index 0000000000..a9b5074e4c
--- /dev/null
+++ b/basis/ui/gadgets/labels/labels-tests.factor
@@ -0,0 +1,9 @@
+USING: accessors tools.test ui.gadgets ui.gadgets.labels ;
+IN: ui.gadgets.labels.tests
+
+[ { 119 14 } ] [
+ <gadget> { 100 14 } >>dim
+ <gadget> { 14 14 } >>dim
+ label-on-right { 5 5 } >>gap
+ pref-dim
+] unit-test
From ae2f5e54398575e258b7602798b00b5ba7dc3231 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 19:17:47 -0600
Subject: [PATCH 041/126] Clarify tail-call optimization documentation
---
basis/help/handbook/handbook.factor | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
index d1d9ca049a..2ed86a0a19 100644
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -65,6 +65,11 @@ $nl
{ "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } }
} ;
+ARTICLE: "tail-call-opt" "Tail-call optimization"
+"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $emphasis "tail-call optimization" } " and the Factor implementation guarantees that it will be performed."
+$nl
+"Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ;
+
ARTICLE: "evaluator" "Evaluation semantics"
{ $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:"
{ $list
@@ -72,7 +77,7 @@ ARTICLE: "evaluator" "Evaluation semantics"
{ "a " { $link wrapper } " - the wrapped object is pushed on the data stack. Wrappers are used to push word objects directly on the stack when they would otherwise execute. See the " { $link POSTPONE: \ } " parsing word." }
{ "All other types of objects are pushed on the data stack." }
}
-"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
+{ $subsection "tail-call-opt" }
{ $see-also "compiler" } ;
ARTICLE: "objects" "Objects"
From 3d8f432856044bbd56c2ec18c0dc3aa445397292 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 19:23:11 -0600
Subject: [PATCH 042/126] Clarify math.bitwise -vs- bitwise-arithmetic docs
---
basis/math/bitwise/bitwise-docs.factor | 5 +++--
core/math/math-docs.factor | 1 +
2 files changed, 4 insertions(+), 2 deletions(-)
diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor
index 4f2606bda0..9ed164330b 100644
--- a/basis/math/bitwise/bitwise-docs.factor
+++ b/basis/math/bitwise/bitwise-docs.factor
@@ -310,8 +310,9 @@ ARTICLE: "math-bitfields" "Constructing bit fields"
"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
{ $subsection bitfield } ;
-ARTICLE: "math.bitwise" "Bitwise arithmetic"
-"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
+ARTICLE: "math.bitwise" "Additional bitwise arithmetic"
+"The " { $vocab-link "math.bitwise" } " vocabulary provides bitwise arithmetic words extending " { $link "bitwise-arithmetic" } ". They are useful for efficiency, low-level programming, and interfacing with C libraries."
+$nl
"Setting and clearing bits:"
{ $subsection set-bit }
{ $subsection clear-bit }
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index 20b4e0bbbe..aca43add5c 100644
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -348,6 +348,7 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
{ $subsection 2/ }
{ $subsection 2^ }
{ $subsection bit? }
+"The " { $vocab-link "math.bitwise" } " vocabulary implements additional bitwise integer operations."
{ $see-also "conditionals" } ;
ARTICLE: "arithmetic" "Arithmetic"
From d6264a32ce82a1bfb427d92a36cec5de0929c7f6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 19:43:11 -0600
Subject: [PATCH 043/126] Better values docs
---
basis/values/values-docs.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor
index 69e2801110..866af469e9 100644
--- a/basis/values/values-docs.factor
+++ b/basis/values/values-docs.factor
@@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: values
ARTICLE: "values" "Global values"
-"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. Values abstract over this concept. To create a new word as a value, use the following syntax:"
+"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:"
{ $subsection POSTPONE: VALUE: }
"To get the value, just call the word. The following words manipulate values:"
{ $subsection get-value }
@@ -10,6 +10,8 @@ ARTICLE: "values" "Global values"
{ $subsection POSTPONE: to: }
{ $subsection change-value } ;
+ABOUT: "values"
+
HELP: VALUE:
{ $syntax "VALUE: word" }
{ $values { "word" "a word to be created" } }
From a100968f030fc1d67fa69c22f69045182c11974e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 19 Nov 2008 20:32:28 -0600
Subject: [PATCH 044/126] boids: another indentation fix
---
extra/boids/boids.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index 3d4cd392ca..097b952db9 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -156,7 +156,7 @@ VAR: separation-radius
2&& ;
: alignment-neighborhood ( self -- boids )
-boids> [ within-alignment-neighborhood? ] with filter ;
+ boids> [ within-alignment-neighborhood? ] with filter ;
: alignment-force ( self -- force )
alignment-neighborhood
From 10d57d7edda3eab3512df259d2e67656a4a5aaf3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 20:48:30 -0600
Subject: [PATCH 045/126] move mime-types to mime.types
---
basis/mime/types/authors.txt | 1 +
basis/mime/types/mime.types | 988 ++++++++++++++++++
.../types/types-docs.factor} | 8 +-
.../types/types-tests.factor} | 4 +-
.../types/types.factor} | 4 +-
5 files changed, 997 insertions(+), 8 deletions(-)
create mode 100755 basis/mime/types/authors.txt
create mode 100644 basis/mime/types/mime.types
rename basis/{mime-types/mime-types-docs.factor => mime/types/types-docs.factor} (90%)
rename basis/{mime-types/mime-types-tests.factor => mime/types/types-tests.factor} (77%)
rename basis/{mime-types/mime-types.factor => mime/types/types.factor} (91%)
diff --git a/basis/mime/types/authors.txt b/basis/mime/types/authors.txt
new file mode 100755
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/mime/types/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/mime/types/mime.types b/basis/mime/types/mime.types
new file mode 100644
index 0000000000..b602e9dc68
--- /dev/null
+++ b/basis/mime/types/mime.types
@@ -0,0 +1,988 @@
+# This is a comment. I love comments.
+
+# This file controls what Internet media types are sent to the client for
+# given file extension(s). Sending the correct media type to the client
+# is important so they know how to handle the content of the file.
+# Extra types can either be added here or by using an AddType directive
+# in your config files. For more information about Internet media types,
+# please read RFC 2045, 2046, 2047, 2048, and 2077. The Internet media type
+# registry is at <http://www.iana.org/assignments/media-types/>.
+
+# MIME type Extensions
+application/activemessage
+application/andrew-inset ez
+application/applefile
+application/atom+xml atom
+application/atomcat+xml atomcat
+application/atomicmail
+application/atomsvc+xml atomsvc
+application/auth-policy+xml
+application/batch-smtp
+application/beep+xml
+application/cals-1840
+application/ccxml+xml ccxml
+application/cellml+xml
+application/cnrp+xml
+application/commonground
+application/conference-info+xml
+application/cpl+xml
+application/csta+xml
+application/cstadata+xml
+application/cybercash
+application/davmount+xml davmount
+application/dca-rft
+application/dec-dx
+application/dialog-info+xml
+application/dicom
+application/dns
+application/dvcs
+application/ecmascript ecma
+application/edi-consent
+application/edi-x12
+application/edifact
+application/epp+xml
+application/eshop
+application/fastinfoset
+application/fastsoap
+application/fits
+application/font-tdpfr pfr
+application/h224
+application/http
+application/hyperstudio stk
+application/iges
+application/im-iscomposing+xml
+application/index
+application/index.cmd
+application/index.obj
+application/index.response
+application/index.vnd
+application/iotp
+application/ipp
+application/isup
+application/javascript js
+application/json json
+application/kpml-request+xml
+application/kpml-response+xml
+application/mac-binhex40 hqx
+application/mac-compactpro cpt
+application/macwriteii
+application/marc mrc
+application/mathematica ma nb mb
+application/mathml+xml mathml
+application/mbms-associated-procedure-description+xml
+application/mbms-deregister+xml
+application/mbms-envelope+xml
+application/mbms-msk+xml
+application/mbms-msk-response+xml
+application/mbms-protection-description+xml
+application/mbms-reception-report+xml
+application/mbms-register+xml
+application/mbms-register-response+xml
+application/mbms-user-service-description+xml
+application/mbox mbox
+application/mediaservercontrol+xml mscml
+application/mikey
+application/mp4 mp4s
+application/mpeg4-generic
+application/mpeg4-iod
+application/mpeg4-iod-xmt
+application/msword doc dot
+application/mxf mxf
+application/nasdata
+application/news-message-id
+application/news-transmission
+application/nss
+application/ocsp-request
+application/ocsp-response
+application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc scpt
+application/oda oda
+application/oebps-package+xml
+application/ogg ogg
+application/parityfec
+application/pdf pdf
+application/pgp-encrypted pgp
+application/pgp-keys
+application/pgp-signature asc sig
+application/pics-rules prf
+application/pidf+xml
+application/pkcs10 p10
+application/pkcs7-mime p7m p7c
+application/pkcs7-signature p7s
+application/pkix-cert cer
+application/pkix-crl crl
+application/pkix-pkipath pkipath
+application/pkixcmp pki
+application/pls+xml pls
+application/poc-settings+xml
+application/postscript ai eps ps
+application/prs.alvestrand.titrax-sheet
+application/prs.cww cww
+application/prs.nprend
+application/prs.plucker
+application/qsig
+application/rdf+xml rdf
+application/reginfo+xml rif
+application/relax-ng-compact-syntax rnc
+application/remote-printing
+application/resource-lists+xml rl
+application/riscos
+application/rlmi+xml
+application/rls-services+xml rs
+application/rsd+xml rsd
+application/rss+xml rss
+application/rtf rtf
+application/rtx
+application/samlassertion+xml
+application/samlmetadata+xml
+application/sbml+xml sbml
+application/sdp sdp
+application/set-payment
+application/set-payment-initiation setpay
+application/set-registration
+application/set-registration-initiation setreg
+application/sgml
+application/sgml-open-catalog
+application/shf+xml shf
+application/sieve
+application/simple-filter+xml
+application/simple-message-summary
+application/simplesymbolcontainer
+application/slate
+application/smil
+application/smil+xml smi smil
+application/soap+fastinfoset
+application/soap+xml
+application/spirits-event+xml
+application/srgs gram
+application/srgs+xml grxml
+application/ssml+xml ssml
+application/timestamp-query
+application/timestamp-reply
+application/tve-trigger
+application/vemmi
+application/vividence.scriptfile
+application/vnd.3gpp.bsf+xml
+application/vnd.3gpp.pic-bw-large plb
+application/vnd.3gpp.pic-bw-small psb
+application/vnd.3gpp.pic-bw-var pvb
+application/vnd.3gpp.sms
+application/vnd.3gpp2.bcmcsinfo+xml
+application/vnd.3gpp2.sms
+application/vnd.3m.post-it-notes pwn
+application/vnd.accpac.simply.aso aso
+application/vnd.accpac.simply.imp imp
+application/vnd.acucobol acu
+application/vnd.acucorp atc acutc
+application/vnd.adobe.xdp+xml xdp
+application/vnd.adobe.xfdf xfdf
+application/vnd.aether.imp
+application/vnd.amiga.ami ami
+application/vnd.anser-web-certificate-issue-initiation cii
+application/vnd.anser-web-funds-transfer-initiation fti
+application/vnd.antix.game-component atx
+application/vnd.apple.installer+xml mpkg
+application/vnd.audiograph aep
+application/vnd.autopackage
+application/vnd.avistar+xml
+application/vnd.blueice.multipass mpm
+application/vnd.bmi bmi
+application/vnd.businessobjects rep
+application/vnd.cab-jscript
+application/vnd.canon-cpdl
+application/vnd.canon-lips
+application/vnd.cendio.thinlinc.clientconf
+application/vnd.chemdraw+xml cdxml
+application/vnd.chipnuts.karaoke-mmd mmd
+application/vnd.cinderella cdy
+application/vnd.cirpack.isdn-ext
+application/vnd.claymore cla
+application/vnd.clonk.c4group c4g c4d c4f c4p c4u
+application/vnd.commerce-battelle
+application/vnd.commonspace csp cst
+application/vnd.contact.cmsg cdbcmsg
+application/vnd.cosmocaller cmc
+application/vnd.crick.clicker clkx
+application/vnd.crick.clicker.keyboard clkk
+application/vnd.crick.clicker.palette clkp
+application/vnd.crick.clicker.template clkt
+application/vnd.crick.clicker.wordbank clkw
+application/vnd.criticaltools.wbs+xml wbs
+application/vnd.ctc-posml pml
+application/vnd.cups-pdf
+application/vnd.cups-postscript
+application/vnd.cups-ppd ppd
+application/vnd.cups-raster
+application/vnd.cups-raw
+application/vnd.curl curl
+application/vnd.cybank
+application/vnd.data-vision.rdz rdz
+application/vnd.denovo.fcselayout-link fe_launch
+application/vnd.dna dna
+application/vnd.dolby.mlp mlp
+application/vnd.dpgraph dpg
+application/vnd.dreamfactory dfac
+application/vnd.dvb.esgcontainer
+application/vnd.dvb.ipdcesgaccess
+application/vnd.dxr
+application/vnd.ecdis-update
+application/vnd.ecowin.chart mag
+application/vnd.ecowin.filerequest
+application/vnd.ecowin.fileupdate
+application/vnd.ecowin.series
+application/vnd.ecowin.seriesrequest
+application/vnd.ecowin.seriesupdate
+application/vnd.enliven nml
+application/vnd.epson.esf esf
+application/vnd.epson.msf msf
+application/vnd.epson.quickanime qam
+application/vnd.epson.salt slt
+application/vnd.epson.ssf ssf
+application/vnd.ericsson.quickcall
+application/vnd.eszigno3+xml es3 et3
+application/vnd.eudora.data
+application/vnd.ezpix-album ez2
+application/vnd.ezpix-package ez3
+application/vnd.fdf fdf
+application/vnd.ffsns
+application/vnd.fints
+application/vnd.flographit gph
+application/vnd.fluxtime.clip ftc
+application/vnd.framemaker fm frame maker
+application/vnd.frogans.fnc fnc
+application/vnd.frogans.ltf ltf
+application/vnd.fsc.weblaunch fsc
+application/vnd.fujitsu.oasys oas
+application/vnd.fujitsu.oasys2 oa2
+application/vnd.fujitsu.oasys3 oa3
+application/vnd.fujitsu.oasysgp fg5
+application/vnd.fujitsu.oasysprs bh2
+application/vnd.fujixerox.art-ex
+application/vnd.fujixerox.art4
+application/vnd.fujixerox.hbpl
+application/vnd.fujixerox.ddd ddd
+application/vnd.fujixerox.docuworks xdw
+application/vnd.fujixerox.docuworks.binder xbd
+application/vnd.fut-misnet
+application/vnd.fuzzysheet fzs
+application/vnd.genomatix.tuxedo txd
+application/vnd.google-earth.kml+xml kml
+application/vnd.google-earth.kmz kmz
+application/vnd.grafeq gqf gqs
+application/vnd.gridmp
+application/vnd.groove-account gac
+application/vnd.groove-help ghf
+application/vnd.groove-identity-message gim
+application/vnd.groove-injector grv
+application/vnd.groove-tool-message gtm
+application/vnd.groove-tool-template tpl
+application/vnd.groove-vcard vcg
+application/vnd.handheld-entertainment+xml zmm
+application/vnd.hbci hbci
+application/vnd.hcl-bireports
+application/vnd.hhe.lesson-player les
+application/vnd.hp-hpgl hpgl
+application/vnd.hp-hpid hpid
+application/vnd.hp-hps hps
+application/vnd.hp-jlyt jlt
+application/vnd.hp-pcl pcl
+application/vnd.hp-pclxl pclxl
+application/vnd.httphone
+application/vnd.hzn-3d-crossword x3d
+application/vnd.ibm.afplinedata
+application/vnd.ibm.electronic-media
+application/vnd.ibm.minipay mpy
+application/vnd.ibm.modcap afp listafp list3820
+application/vnd.ibm.rights-management irm
+application/vnd.ibm.secure-container sc
+application/vnd.igloader igl
+application/vnd.immervision-ivp ivp
+application/vnd.immervision-ivu ivu
+application/vnd.informedcontrol.rms+xml
+application/vnd.intercon.formnet xpw xpx
+application/vnd.intertrust.digibox
+application/vnd.intertrust.nncp
+application/vnd.intu.qbo qbo
+application/vnd.intu.qfx qfx
+application/vnd.ipunplugged.rcprofile rcprofile
+application/vnd.irepository.package+xml irp
+application/vnd.is-xpr xpr
+application/vnd.jam jam
+application/vnd.japannet-directory-service
+application/vnd.japannet-jpnstore-wakeup
+application/vnd.japannet-payment-wakeup
+application/vnd.japannet-registration
+application/vnd.japannet-registration-wakeup
+application/vnd.japannet-setstore-wakeup
+application/vnd.japannet-verification
+application/vnd.japannet-verification-wakeup
+application/vnd.jcp.javame.midlet-rms rms
+application/vnd.jisp jisp
+application/vnd.kahootz ktz ktr
+application/vnd.kde.karbon karbon
+application/vnd.kde.kchart chrt
+application/vnd.kde.kformula kfo
+application/vnd.kde.kivio flw
+application/vnd.kde.kontour kon
+application/vnd.kde.kpresenter kpr kpt
+application/vnd.kde.kspread ksp
+application/vnd.kde.kword kwd kwt
+application/vnd.kenameaapp htke
+application/vnd.kidspiration kia
+application/vnd.kinar kne knp
+application/vnd.koan skp skd skt skm
+application/vnd.liberty-request+xml
+application/vnd.llamagraphics.life-balance.desktop lbd
+application/vnd.llamagraphics.life-balance.exchange+xml lbe
+application/vnd.lotus-1-2-3 123
+application/vnd.lotus-approach apr
+application/vnd.lotus-freelance pre
+application/vnd.lotus-notes nsf
+application/vnd.lotus-organizer org
+application/vnd.lotus-screencam scm
+application/vnd.lotus-wordpro lwp
+application/vnd.macports.portpkg portpkg
+application/vnd.marlin.drm.actiontoken+xml
+application/vnd.marlin.drm.conftoken+xml
+application/vnd.marlin.drm.mdcf
+application/vnd.mcd mcd
+application/vnd.medcalcdata mc1
+application/vnd.mediastation.cdkey cdkey
+application/vnd.meridian-slingshot
+application/vnd.mfer mwf
+application/vnd.mfmp mfm
+application/vnd.micrografx.flo flo
+application/vnd.micrografx.igx igx
+application/vnd.mif mif
+application/vnd.minisoft-hp3000-save
+application/vnd.mitsubishi.misty-guard.trustweb
+application/vnd.mobius.daf daf
+application/vnd.mobius.dis dis
+application/vnd.mobius.mbk mbk
+application/vnd.mobius.mqy mqy
+application/vnd.mobius.msl msl
+application/vnd.mobius.plc plc
+application/vnd.mobius.txf txf
+application/vnd.mophun.application mpn
+application/vnd.mophun.certificate mpc
+application/vnd.motorola.flexsuite
+application/vnd.motorola.flexsuite.adsi
+application/vnd.motorola.flexsuite.fis
+application/vnd.motorola.flexsuite.gotap
+application/vnd.motorola.flexsuite.kmr
+application/vnd.motorola.flexsuite.ttc
+application/vnd.motorola.flexsuite.wem
+application/vnd.mozilla.xul+xml xul
+application/vnd.ms-artgalry cil
+application/vnd.ms-asf asf
+application/vnd.ms-cab-compressed cab
+application/vnd.ms-excel xls xlm xla xlc xlt xlw
+application/vnd.ms-fontobject eot
+application/vnd.ms-htmlhelp chm
+application/vnd.ms-ims ims
+application/vnd.ms-lrm lrm
+application/vnd.ms-playready.initiator+xml
+application/vnd.ms-powerpoint ppt pps pot
+application/vnd.ms-project mpp mpt
+application/vnd.ms-tnef
+application/vnd.ms-wmdrm.lic-chlg-req
+application/vnd.ms-wmdrm.lic-resp
+application/vnd.ms-wmdrm.meter-chlg-req
+application/vnd.ms-wmdrm.meter-resp
+application/vnd.ms-works wps wks wcm wdb
+application/vnd.ms-wpl wpl
+application/vnd.ms-xpsdocument xps
+application/vnd.mseq mseq
+application/vnd.msign
+application/vnd.music-niff
+application/vnd.musician mus
+application/vnd.ncd.control
+application/vnd.nervana
+application/vnd.netfpx
+application/vnd.neurolanguage.nlu nlu
+application/vnd.noblenet-directory nnd
+application/vnd.noblenet-sealer nns
+application/vnd.noblenet-web nnw
+application/vnd.nokia.catalogs
+application/vnd.nokia.conml+wbxml
+application/vnd.nokia.conml+xml
+application/vnd.nokia.isds-radio-presets
+application/vnd.nokia.iptv.config+xml
+application/vnd.nokia.landmark+wbxml
+application/vnd.nokia.landmark+xml
+application/vnd.nokia.landmarkcollection+xml
+application/vnd.nokia.n-gage.ac+xml
+application/vnd.nokia.n-gage.data ngdat
+application/vnd.nokia.n-gage.symbian.install n-gage
+application/vnd.nokia.ncd
+application/vnd.nokia.pcd+wbxml
+application/vnd.nokia.pcd+xml
+application/vnd.nokia.radio-preset rpst
+application/vnd.nokia.radio-presets rpss
+application/vnd.novadigm.edm edm
+application/vnd.novadigm.edx edx
+application/vnd.novadigm.ext ext
+application/vnd.oasis.opendocument.chart odc
+application/vnd.oasis.opendocument.chart-template otc
+application/vnd.oasis.opendocument.formula odf
+application/vnd.oasis.opendocument.formula-template otf
+application/vnd.oasis.opendocument.graphics odg
+application/vnd.oasis.opendocument.graphics-template otg
+application/vnd.oasis.opendocument.image odi
+application/vnd.oasis.opendocument.image-template oti
+application/vnd.oasis.opendocument.presentation odp
+application/vnd.oasis.opendocument.presentation-template otp
+application/vnd.oasis.opendocument.spreadsheet ods
+application/vnd.oasis.opendocument.spreadsheet-template ots
+application/vnd.oasis.opendocument.text odt
+application/vnd.oasis.opendocument.text-master otm
+application/vnd.oasis.opendocument.text-template ott
+application/vnd.oasis.opendocument.text-web oth
+application/vnd.obn
+application/vnd.olpc-sugar xo
+application/vnd.oma-scws-config
+application/vnd.oma-scws-http-request
+application/vnd.oma-scws-http-response
+application/vnd.oma.bcast.associated-procedure-parameter+xml
+application/vnd.oma.bcast.drm-trigger+xml
+application/vnd.oma.bcast.imd+xml
+application/vnd.oma.bcast.notification+xml
+application/vnd.oma.bcast.sgboot
+application/vnd.oma.bcast.sgdd+xml
+application/vnd.oma.bcast.sgdu
+application/vnd.oma.bcast.simple-symbol-container
+application/vnd.oma.bcast.smartcard-trigger+xml
+application/vnd.oma.bcast.sprov+xml
+application/vnd.oma.dd2+xml dd2
+application/vnd.oma.drm.risd+xml
+application/vnd.oma.group-usage-list+xml
+application/vnd.oma.poc.groups+xml
+application/vnd.oma.xcap-directory+xml
+application/vnd.omads-email+xml
+application/vnd.omads-file+xml
+application/vnd.omads-folder+xml
+application/vnd.omaloc-supl-init
+application/vnd.openofficeorg.extension oxt
+application/vnd.osa.netdeploy
+application/vnd.osgi.dp dp
+application/vnd.otps.ct-kip+xml
+application/vnd.palm prc pdb pqa oprc
+application/vnd.paos.xml
+application/vnd.pg.format str
+application/vnd.pg.osasli ei6
+application/vnd.piaccess.application-licence
+application/vnd.picsel efif
+application/vnd.poc.group-advertisement+xml
+application/vnd.pocketlearn plf
+application/vnd.powerbuilder6 pbd
+application/vnd.powerbuilder6-s
+application/vnd.powerbuilder7
+application/vnd.powerbuilder7-s
+application/vnd.powerbuilder75
+application/vnd.powerbuilder75-s
+application/vnd.preminet
+application/vnd.previewsystems.box box
+application/vnd.proteus.magazine mgz
+application/vnd.publishare-delta-tree qps
+application/vnd.pvi.ptid1 ptid
+application/vnd.pwg-multiplexed
+application/vnd.pwg-xhtml-print+xml
+application/vnd.qualcomm.brew-app-res
+application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb
+application/vnd.rapid
+application/vnd.recordare.musicxml mxl
+application/vnd.recordare.musicxml+xml
+application/vnd.renlearn.rlprint
+application/vnd.rn-realmedia rm
+application/vnd.ruckus.download
+application/vnd.s3sms
+application/vnd.scribus
+application/vnd.sealed.3df
+application/vnd.sealed.csf
+application/vnd.sealed.doc
+application/vnd.sealed.eml
+application/vnd.sealed.mht
+application/vnd.sealed.net
+application/vnd.sealed.ppt
+application/vnd.sealed.tiff
+application/vnd.sealed.xls
+application/vnd.sealedmedia.softseal.html
+application/vnd.sealedmedia.softseal.pdf
+application/vnd.seemail see
+application/vnd.sema sema
+application/vnd.semd semd
+application/vnd.semf semf
+application/vnd.shana.informed.formdata ifm
+application/vnd.shana.informed.formtemplate itp
+application/vnd.shana.informed.interchange iif
+application/vnd.shana.informed.package ipk
+application/vnd.simtech-mindmapper twd twds
+application/vnd.smaf mmf
+application/vnd.solent.sdkm+xml sdkm sdkd
+application/vnd.spotfire.dxp dxp
+application/vnd.spotfire.sfs sfs
+application/vnd.sss-cod
+application/vnd.sss-dtf
+application/vnd.sss-ntf
+application/vnd.street-stream
+application/vnd.sun.wadl+xml
+application/vnd.sus-calendar sus susp
+application/vnd.svd svd
+application/vnd.swiftview-ics
+application/vnd.syncml+xml xsm
+application/vnd.syncml.dm+wbxml bdm
+application/vnd.syncml.dm+xml xdm
+application/vnd.syncml.ds.notification
+application/vnd.tao.intent-module-archive tao
+application/vnd.tmobile-livetv tmo
+application/vnd.trid.tpt tpt
+application/vnd.triscape.mxs mxs
+application/vnd.trueapp tra
+application/vnd.truedoc
+application/vnd.ufdl ufd ufdl
+application/vnd.uiq.theme utz
+application/vnd.umajin umj
+application/vnd.unity unityweb
+application/vnd.uoml+xml uoml
+application/vnd.uplanet.alert
+application/vnd.uplanet.alert-wbxml
+application/vnd.uplanet.bearer-choice
+application/vnd.uplanet.bearer-choice-wbxml
+application/vnd.uplanet.cacheop
+application/vnd.uplanet.cacheop-wbxml
+application/vnd.uplanet.channel
+application/vnd.uplanet.channel-wbxml
+application/vnd.uplanet.list
+application/vnd.uplanet.list-wbxml
+application/vnd.uplanet.listcmd
+application/vnd.uplanet.listcmd-wbxml
+application/vnd.uplanet.signal
+application/vnd.vcx vcx
+application/vnd.vd-study
+application/vnd.vectorworks
+application/vnd.vidsoft.vidconference
+application/vnd.visio vsd vst vss vsw
+application/vnd.visionary vis
+application/vnd.vividence.scriptfile
+application/vnd.vsf vsf
+application/vnd.wap.sic
+application/vnd.wap.slc
+application/vnd.wap.wbxml wbxml
+application/vnd.wap.wmlc wmlc
+application/vnd.wap.wmlscriptc wmlsc
+application/vnd.webturbo wtb
+application/vnd.wfa.wsc
+application/vnd.wordperfect wpd
+application/vnd.wqd wqd
+application/vnd.wrq-hp3000-labelled
+application/vnd.wt.stf stf
+application/vnd.wv.csp+wbxml
+application/vnd.wv.csp+xml
+application/vnd.wv.ssp+xml
+application/vnd.xara xar
+application/vnd.xfdl xfdl
+application/vnd.xmpie.cpkg
+application/vnd.xmpie.dpkg
+application/vnd.xmpie.plan
+application/vnd.xmpie.ppkg
+application/vnd.xmpie.xlim
+application/vnd.yamaha.hv-dic hvd
+application/vnd.yamaha.hv-script hvs
+application/vnd.yamaha.hv-voice hvp
+application/vnd.yamaha.smaf-audio saf
+application/vnd.yamaha.smaf-phrase spf
+application/vnd.yellowriver-custom-menu cmp
+application/vnd.zzazz.deck+xml zaz
+application/voicexml+xml vxml
+application/watcherinfo+xml
+application/whoispp-query
+application/whoispp-response
+application/winhlp hlp
+application/wita
+application/wordperfect5.1
+application/wsdl+xml wsdl
+application/wspolicy+xml wspolicy
+application/x-ace-compressed ace
+application/x-bcpio bcpio
+application/x-bittorrent torrent
+application/x-bzip bz
+application/x-bzip2 bz2 boz
+application/x-cdlink vcd
+application/x-chat chat
+application/x-chess-pgn pgn
+application/x-compress
+application/x-cpio cpio
+application/x-csh csh
+application/x-director dcr dir dxr fgd
+application/x-dvi dvi
+application/x-futuresplash spl
+application/x-gtar gtar
+application/x-gzip
+application/x-hdf hdf
+application/x-java-jnlp-file jnlp
+application/x-latex latex
+application/x-ms-wmd wmd
+application/x-ms-wmz wmz
+application/x-msaccess mdb
+application/x-msbinder obd
+application/x-mscardfile crd
+application/x-msclip clp
+application/x-msdownload exe dll com bat msi
+application/x-msmediaview mvb m13 m14
+application/x-msmetafile wmf
+application/x-msmoney mny
+application/x-mspublisher pub
+application/x-msschedule scd
+application/x-msterminal trm
+application/x-mswrite wri
+application/x-netcdf nc cdf
+application/x-pkcs12 p12 pfx
+application/x-pkcs7-certificates p7b spc
+application/x-pkcs7-certreqresp p7r
+application/x-rar-compressed rar
+application/x-sh sh
+application/x-shar shar
+application/x-shockwave-flash swf
+application/x-stuffit sit
+application/x-stuffitx sitx
+application/x-sv4cpio sv4cpio
+application/x-sv4crc sv4crc
+application/x-tar tar
+application/x-tcl tcl
+application/x-tex tex
+application/x-texinfo texinfo texi
+application/x-ustar ustar
+application/x-wais-source src
+application/x-x509-ca-cert der crt
+application/x400-bp
+application/xcap-att+xml
+application/xcap-caps+xml
+application/xcap-el+xml
+application/xcap-error+xml
+application/xcap-ns+xml
+application/xenc+xml xenc
+application/xhtml+xml xhtml xht
+application/xml xml xsl
+application/xml-dtd dtd
+application/xml-external-parsed-entity
+application/xmpp+xml
+application/xop+xml xop
+application/xslt+xml xslt
+application/xspf+xml xspf
+application/xv+xml mxml xhvml xvml xvm
+application/zip zip
+audio/32kadpcm
+audio/3gpp
+audio/3gpp2
+audio/ac3
+audio/amr
+audio/amr-wb
+audio/amr-wb+
+audio/asc
+audio/basic au snd
+audio/bv16
+audio/bv32
+audio/clearmode
+audio/cn
+audio/dat12
+audio/dls
+audio/dsr-es201108
+audio/dsr-es202050
+audio/dsr-es202211
+audio/dsr-es202212
+audio/dvi4
+audio/eac3
+audio/evrc
+audio/evrc-qcp
+audio/evrc0
+audio/evrc1
+audio/evrcb
+audio/evrcb0
+audio/evrcb1
+audio/g722
+audio/g7221
+audio/g723
+audio/g726-16
+audio/g726-24
+audio/g726-32
+audio/g726-40
+audio/g728
+audio/g729
+audio/g7291
+audio/g729d
+audio/g729e
+audio/gsm
+audio/gsm-efr
+audio/ilbc
+audio/l16
+audio/l20
+audio/l24
+audio/l8
+audio/lpc
+audio/midi mid midi kar rmi
+audio/mobile-xmf
+audio/mp4 mp4a
+audio/mp4a-latm m4a m4p
+audio/mpa
+audio/mpa-robust
+audio/mpeg mpga mp2 mp2a mp3 m2a m3a
+audio/mpeg4-generic
+audio/parityfec
+audio/pcma
+audio/pcmu
+audio/prs.sid
+audio/qcelp
+audio/red
+audio/rtp-enc-aescm128
+audio/rtp-midi
+audio/rtx
+audio/smv
+audio/smv0
+audio/smv-qcp
+audio/sp-midi
+audio/t140c
+audio/t38
+audio/telephone-event
+audio/tone
+audio/vdvi
+audio/vmr-wb
+audio/vnd.3gpp.iufp
+audio/vnd.4sb
+audio/vnd.audiokoz
+audio/vnd.celp
+audio/vnd.cisco.nse
+audio/vnd.cmles.radio-events
+audio/vnd.cns.anp1
+audio/vnd.cns.inf1
+audio/vnd.digital-winds eol
+audio/vnd.dlna.adts
+audio/vnd.dolby.mlp
+audio/vnd.everad.plj
+audio/vnd.hns.audio
+audio/vnd.lucent.voice lvp
+audio/vnd.nokia.mobile-xmf
+audio/vnd.nortel.vbk
+audio/vnd.nuera.ecelp4800 ecelp4800
+audio/vnd.nuera.ecelp7470 ecelp7470
+audio/vnd.nuera.ecelp9600 ecelp9600
+audio/vnd.octel.sbc
+audio/vnd.qcelp
+audio/vnd.rhetorex.32kadpcm
+audio/vnd.sealedmedia.softseal.mpeg
+audio/vnd.vmx.cvsd
+audio/wav wav
+audio/x-aiff aif aiff aifc
+audio/x-mpegurl m3u
+audio/x-ms-wax wax
+audio/x-ms-wma wma
+audio/x-pn-realaudio ram ra
+audio/x-pn-realaudio-plugin rmp
+audio/x-wav wav
+chemical/x-cdx cdx
+chemical/x-cif cif
+chemical/x-cmdf cmdf
+chemical/x-cml cml
+chemical/x-csml csml
+chemical/x-pdb pdb
+chemical/x-xyz xyz
+image/bmp bmp
+image/cgm cgm
+image/fits
+image/g3fax g3
+image/gif gif
+image/ief ief
+image/jp2 jp2
+image/jpeg jpeg jpg jpe
+image/jpm
+image/jpx
+image/naplps
+image/pict pict pic pct
+image/png png
+image/prs.btif btif
+image/prs.pti
+image/svg+xml svg svgz
+image/t38
+image/tiff tiff tif
+image/tiff-fx
+image/vnd.adobe.photoshop psd
+image/vnd.cns.inf2
+image/vnd.djvu djvu djv
+image/vnd.dwg dwg
+image/vnd.dxf dxf
+image/vnd.fastbidsheet fbs
+image/vnd.fpx fpx
+image/vnd.fst fst
+image/vnd.fujixerox.edmics-mmr mmr
+image/vnd.fujixerox.edmics-rlc rlc
+image/vnd.globalgraphics.pgb
+image/vnd.microsoft.icon ico
+image/vnd.mix
+image/vnd.ms-modi mdi
+image/vnd.net-fpx npx
+image/vnd.sealed.png
+image/vnd.sealedmedia.softseal.gif
+image/vnd.sealedmedia.softseal.jpg
+image/vnd.svf
+image/vnd.wap.wbmp wbmp
+image/vnd.xiff xif
+image/x-cmu-raster ras
+image/x-cmx cmx
+image/x-icon
+image/x-macpaint pntg pnt mac
+image/x-pcx pcx
+image/x-pict pic pct
+image/x-portable-anymap pnm
+image/x-portable-bitmap pbm
+image/x-portable-graymap pgm
+image/x-portable-pixmap ppm
+image/x-quicktime qtif qti
+image/x-rgb rgb
+image/x-xbitmap xbm
+image/x-xpixmap xpm
+image/x-xwindowdump xwd
+message/cpim
+message/delivery-status
+message/disposition-notification
+message/external-body
+message/http
+message/news
+message/partial
+message/rfc822 eml mime
+message/s-http
+message/sip
+message/sipfrag
+message/tracking-status
+model/iges igs iges
+model/mesh msh mesh silo
+model/vnd.dwf dwf
+model/vnd.flatland.3dml
+model/vnd.gdl gdl
+model/vnd.gs.gdl
+model/vnd.gtw gtw
+model/vnd.moml+xml
+model/vnd.mts mts
+model/vnd.parasolid.transmit.binary
+model/vnd.parasolid.transmit.text
+model/vnd.vtu vtu
+model/vrml wrl vrml
+multipart/alternative
+multipart/appledouble
+multipart/byteranges
+multipart/digest
+multipart/encrypted
+multipart/form-data
+multipart/header-set
+multipart/mixed
+multipart/parallel
+multipart/related
+multipart/report
+multipart/signed
+multipart/voice-message
+text/calendar ics ifb
+text/css css
+text/csv csv
+text/directory
+text/dns
+text/enriched
+text/html html htm
+text/parityfec
+text/plain txt text conf def list log in
+text/prs.fallenstein.rst
+text/prs.lines.tag dsc
+text/red
+text/rfc822-headers
+text/richtext rtx
+text/rtf
+text/rtp-enc-aescm128
+text/rtx
+text/sgml sgml sgm
+text/t140
+text/tab-separated-values tsv
+text/troff t tr roff man me ms
+text/uri-list uri uris urls
+text/vnd.abc
+text/vnd.curl
+text/vnd.dmclientscript
+text/vnd.esmertec.theme-descriptor
+text/vnd.fly fly
+text/vnd.fmi.flexstor flx
+text/vnd.in3d.3dml 3dml
+text/vnd.in3d.spot spot
+text/vnd.iptc.newsml
+text/vnd.iptc.nitf
+text/vnd.latex-z
+text/vnd.motorola.reflex
+text/vnd.ms-mediapackage
+text/vnd.net2phone.commcenter.command
+text/vnd.sun.j2me.app-descriptor jad
+text/vnd.trolltech.linguist
+text/vnd.wap.si
+text/vnd.wap.sl
+text/vnd.wap.wml wml
+text/vnd.wap.wmlscript wmls
+text/x-asm s asm
+text/x-c c cc cxx cpp h hh dic
+text/x-fortran f for f77 f90
+text/x-pascal p pas
+text/x-java-source java
+text/x-setext etx
+text/x-uuencode uu
+text/x-vcalendar vcs
+text/x-vcard vcf
+text/xml
+text/xml-external-parsed-entity
+video/3gpp 3gp
+video/3gpp-tt
+video/3gpp2 3g2
+video/bmpeg
+video/bt656
+video/celb
+video/dv
+video/h261 h261
+video/h263 h263
+video/h263-1998
+video/h263-2000
+video/h264 h264
+video/jpeg jpgv
+video/jpm jpm jpgm
+video/mj2 mj2 mjp2
+video/mp1s
+video/mp2p
+video/mp2t
+video/mp4 mp4 mp4v mpg4 m4v
+video/mp4v-es
+video/mpeg mpeg mpg mpe m1v m2v
+video/mpeg4-generic
+video/mpv
+video/nv
+video/parityfec
+video/pointer
+video/quicktime qt mov
+video/raw
+video/rtp-enc-aescm128
+video/rtx
+video/smpte292m
+video/vc1
+video/vnd.dlna.mpeg-tts
+video/vnd.fvt fvt
+video/vnd.hns.video
+video/vnd.motorola.video
+video/vnd.motorola.videop
+video/vnd.mpegurl mxu m4u
+video/vnd.nokia.interleaved-multimedia
+video/vnd.nokia.videovoip
+video/vnd.objectvideo
+video/vnd.sealed.mpeg1
+video/vnd.sealed.mpeg4
+video/vnd.sealed.swf
+video/vnd.sealedmedia.softseal.mov
+video/vnd.vivo viv
+video/x-dv dv dif
+video/x-fli fli
+video/x-ms-asf asf asx
+video/x-ms-wm wm
+video/x-ms-wmv wmv
+video/x-ms-wmx wmx
+video/x-ms-wvx wvx
+video/x-msvideo avi
+video/x-sgi-movie movie
+x-conference/x-cooltalk ice
diff --git a/basis/mime-types/mime-types-docs.factor b/basis/mime/types/types-docs.factor
similarity index 90%
rename from basis/mime-types/mime-types-docs.factor
rename to basis/mime/types/types-docs.factor
index b7fa46d587..fc14227e2d 100644
--- a/basis/mime-types/mime-types-docs.factor
+++ b/basis/mime/types/types-docs.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax io.streams.string sequences ;
-IN: mime-types
+IN: mime.types
HELP: mime-db
{ $values
@@ -27,9 +27,9 @@ HELP: nonstandard-mime-types
{ "assoc" assoc } }
{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ;
-ARTICLE: "mime-types" "MIME types"
-"The " { $vocab-link "mime-types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl
+ARTICLE: "mime.types" "MIME types"
+"The " { $vocab-link "mime.types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl
"Looking up a MIME type:"
{ $subsection mime-type } ;
-ABOUT: "mime-types"
+ABOUT: "mime.types"
diff --git a/basis/mime-types/mime-types-tests.factor b/basis/mime/types/types-tests.factor
similarity index 77%
rename from basis/mime-types/mime-types-tests.factor
rename to basis/mime/types/types-tests.factor
index 925eca2e9d..63535afa9a 100644
--- a/basis/mime-types/mime-types-tests.factor
+++ b/basis/mime/types/types-tests.factor
@@ -1,5 +1,5 @@
-IN: mime-types.tests
-USING: mime-types tools.test ;
+IN: mime.types.tests
+USING: mime.types tools.test ;
[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test
diff --git a/basis/mime-types/mime-types.factor b/basis/mime/types/types.factor
similarity index 91%
rename from basis/mime-types/mime-types.factor
rename to basis/mime/types/types.factor
index 909f762c50..bb0d674f23 100644
--- a/basis/mime-types/mime-types.factor
+++ b/basis/mime/types/types.factor
@@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii assocs sequences splitting
kernel namespaces fry memoize ;
-IN: mime-types
+IN: mime.types
MEMO: mime-db ( -- seq )
- "resource:basis/mime-types/mime.types" ascii file-lines
+ "resource:basis/mime/types/mime.types" ascii file-lines
[ "#" head? not ] filter [ " \t" split harvest ] map harvest ;
: nonstandard-mime-types ( -- assoc )
From 825ad4e59de9bb6a2afea502850c9e7590bfb33f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 21:02:21 -0600
Subject: [PATCH 046/126] Remove unmaintained/io/ since basis/io/ now has all
of the features from the old I/O library
---
unmaintained/io/load.factor | 24 -------
unmaintained/io/os-unix-shell.factor | 46 -------------
unmaintained/io/os-unix.factor | 24 -------
unmaintained/io/os-winnt-shell.factor | 55 ---------------
unmaintained/io/os-winnt.factor | 96 ---------------------------
unmaintained/io/shell.factor | 40 -----------
unmaintained/io/test/io.factor | 42 ------------
unmaintained/io/test/mmap.factor | 21 ------
8 files changed, 348 deletions(-)
delete mode 100644 unmaintained/io/load.factor
delete mode 100644 unmaintained/io/os-unix-shell.factor
delete mode 100644 unmaintained/io/os-unix.factor
delete mode 100644 unmaintained/io/os-winnt-shell.factor
delete mode 100644 unmaintained/io/os-winnt.factor
delete mode 100644 unmaintained/io/shell.factor
delete mode 100644 unmaintained/io/test/io.factor
delete mode 100644 unmaintained/io/test/mmap.factor
diff --git a/unmaintained/io/load.factor b/unmaintained/io/load.factor
deleted file mode 100644
index ac9b9542c5..0000000000
--- a/unmaintained/io/load.factor
+++ /dev/null
@@ -1,24 +0,0 @@
-USING: kernel ;
-
-REQUIRES: libs/calendar libs/shuffle ;
-
-PROVIDE: libs/io
-{ +files+ {
- "io.factor"
- "mmap.factor"
- "shell.factor"
- { "os-unix.factor" [ unix? ] }
- { "os-unix-shell.factor" [ unix? ] }
- { "mmap-os-unix.factor" [ unix? ] }
-
- { "os-winnt.factor" [ winnt? ] }
- { "os-winnt-shell.factor" [ winnt? ] }
- { "mmap-os-winnt.factor" [ winnt? ] }
-
- { "os-wince.factor" [ wince? ] }
-} }
-{ +tests+ {
- "test/io.factor"
- "test/mmap.factor"
-} } ;
-
diff --git a/unmaintained/io/os-unix-shell.factor b/unmaintained/io/os-unix-shell.factor
deleted file mode 100644
index 6c3919ddb2..0000000000
--- a/unmaintained/io/os-unix-shell.factor
+++ /dev/null
@@ -1,46 +0,0 @@
-USING: arrays kernel libs-io sequences prettyprint unix-internals
-calendar namespaces math ;
-USE: io
-IN: shell
-
-TUPLE: unix-shell ;
-
-T{ unix-shell } \ shell set-global
-
-TUPLE: file name mode nlink uid gid size mtime symbol ;
-
-M: unix-shell directory* ( path -- seq )
- dup (directory) [ tuck >r "/" r> 3append stat* 2array ] map-with ;
-
-M: unix-shell make-file ( path -- file )
- first2
- [ stat-mode ] keep
- [ stat-nlink ] keep
- [ stat-uid ] keep
- [ stat-gid ] keep
- [ stat-size ] keep
- [ stat-mtime timespec>timestamp >local-time ] keep
- stat-mode mode>symbol <file> ;
-
-M: unix-shell file. ( file -- )
- [ [ file-mode >oct write ] keep ] with-cell
- [ bl ] with-cell
- [ [ file-nlink unparse write ] keep ] with-cell
- [ bl ] with-cell
- [ [ file-uid unparse write ] keep ] with-cell
- [ bl ] with-cell
- [ [ file-gid unparse write ] keep ] with-cell
- [ bl ] with-cell
- [ [ file-size unparse write ] keep ] with-cell
- [ bl ] with-cell
- [ [ file-mtime file-time-string write ] keep ] with-cell
- [ bl ] with-cell
- [ file-name write ] with-cell ;
-
-USE: unix-internals
-M: unix-shell touch-file ( path -- )
- dup open-append dup -1 = [
- drop now dup set-file-times
- ] [
- nip [ now dup set-file-times* ] keep close
- ] if ;
diff --git a/unmaintained/io/os-unix.factor b/unmaintained/io/os-unix.factor
deleted file mode 100644
index 280908b406..0000000000
--- a/unmaintained/io/os-unix.factor
+++ /dev/null
@@ -1,24 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays calendar errors io io-internals kernel
-math nonblocking-io sequences unix-internals unix-io ;
-IN: libs-io
-
-: O_APPEND HEX: 100 ; inline
-: O_EXCL HEX: 800 ; inline
-: SEEK_SET 0 ; inline
-: SEEK_CUR 1 ; inline
-: SEEK_END 2 ; inline
-: EEXIST 17 ; inline
-
-: mode>symbol ( mode -- ch )
- S_IFMT bitand
- {
- { [ dup S_IFDIR = ] [ drop "/" ] }
- { [ dup S_IFIFO = ] [ drop "|" ] }
- { [ dup S_IXUSR = ] [ drop "*" ] }
- { [ dup S_IFLNK = ] [ drop "@" ] }
- { [ dup S_IFWHT = ] [ drop "%" ] }
- { [ dup S_IFSOCK = ] [ drop "=" ] }
- { [ t ] [ drop "" ] }
- } cond ;
diff --git a/unmaintained/io/os-winnt-shell.factor b/unmaintained/io/os-winnt-shell.factor
deleted file mode 100644
index a2be22daf8..0000000000
--- a/unmaintained/io/os-winnt-shell.factor
+++ /dev/null
@@ -1,55 +0,0 @@
-USING: alien calendar io io-internals kernel libs-io math
-namespaces prettyprint sequences windows-api ;
-IN: shell
-
-TUPLE: winnt-shell ;
-
-T{ winnt-shell } \ shell set-global
-
-TUPLE: file name size mtime attributes ;
-
-: ((directory*)) ( handle -- )
- "WIN32_FIND_DATA" <c-object> [ FindNextFile ] 2keep
- rot zero? [ 2drop ] [ , ((directory*)) ] if ;
-
-: (directory*) ( path -- )
- "WIN32_FIND_DATA" <c-object> [
- FindFirstFile dup INVALID_HANDLE_VALUE = [
- win32-error
- ] when
- ] keep ,
- [ ((directory*)) ] keep FindClose win32-error=0/f ;
-
-: append-star ( path -- path )
- dup peek CHAR: \\ = "*" "\\*" ? append ;
-
-M: winnt-shell directory* ( path -- seq )
- normalize-pathname append-star [ (directory*) ] { } make ;
-
-: WIN32_FIND_DATA>file-size ( WIN32_FILE_ATTRIBUTE_DATA -- n )
- [ WIN32_FIND_DATA-nFileSizeLow ] keep
- WIN32_FIND_DATA-nFileSizeHigh 32 shift + ;
-
-M: winnt-shell make-file ( WIN32_FIND_DATA -- file )
- [ WIN32_FIND_DATA-cFileName alien>u16-string ] keep
- [ WIN32_FIND_DATA>file-size ] keep
- [
- WIN32_FIND_DATA-ftCreationTime
- FILETIME>timestamp >local-time
- ] keep
- WIN32_FIND_DATA-dwFileAttributes <file> ;
-
-M: winnt-shell file. ( file -- )
- [ [ file-attributes >oct write ] keep ] with-cell
- [ bl ] with-cell
- [ [ file-size unparse write ] keep ] with-cell
- [ bl ] with-cell
- [ [ file-mtime file-time-string write ] keep ] with-cell
- [ bl ] with-cell
- [ file-name write ] with-cell ;
-
-M: winnt-shell touch-file ( path -- )
- #! Set the file write time to 'now'
- normalize-pathname
- dup maybe-create-file [ drop ] [ now set-file-write-time ] if ;
-
diff --git a/unmaintained/io/os-winnt.factor b/unmaintained/io/os-winnt.factor
deleted file mode 100644
index 971ae79097..0000000000
--- a/unmaintained/io/os-winnt.factor
+++ /dev/null
@@ -1,96 +0,0 @@
-USING: alien calendar errors generic io io-internals kernel
-math namespaces nonblocking-io parser quotations sequences
-shuffle windows-api words ;
-IN: libs-io
-
-: stat* ( path -- WIN32_FIND_DATA )
- "WIN32_FIND_DATA" <c-object>
- [
- FindFirstFile
- [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
- FindClose win32-error=0/f
- ] keep ;
-
-: set-file-time ( path timestamp/f timestamp/f timestamp/f -- )
- #! timestamp order: creation access write
- >r >r >r open-existing dup r> r> r>
- [ timestamp>FILETIME ] 3 napply
- SetFileTime win32-error=0/f
- close-handle ;
-
-: set-file-times ( path timestamp/f timestamp/f -- )
- f -rot set-file-time ;
-
-: set-file-create-time ( path timestamp -- )
- f f set-file-time ;
-
-: set-file-access-time ( path timestamp -- )
- >r f r> f set-file-time ;
-
-: set-file-write-time ( path timestamp -- )
- >r f f r> set-file-time ;
-
-: maybe-make-filetime ( ? -- FILETIME/f )
- [ "FILETIME" <c-object> ] [ f ] if ;
-
-: file-time ( path ? ? ? -- FILETIME/f FILETIME/f FILETIME/f )
- >r >r >r open-existing dup r> r> r>
- [ maybe-make-filetime ] 3 napply
- [ GetFileTime win32-error=0/f close-handle ] 3keep ;
-
-: file-times ( path -- FILETIME FILETIME FILETIME )
- t t t file-time [ FILETIME>timestamp ] 3 napply ;
-
-: file-create-time ( path -- FILETIME )
- t f f file-time 2drop FILETIME>timestamp ;
-
-: file-access-time ( path -- FILETIME )
- f t f file-time drop nip FILETIME>timestamp ;
-
-: file-write-time ( path -- FILETIME )
- f f t file-time 2nip FILETIME>timestamp ;
-
-: attrib ( path -- n )
- [ stat* WIN32_FIND_DATA-dwFileAttributes ] catch
- [ drop 0 ] when ;
-
-: (read-only?) ( mode -- ? )
- FILE_ATTRIBUTE_READONLY bit-set? ;
-
-: read-only? ( path -- ? )
- attrib (read-only?) ;
-
-: (hidden?) ( mode -- ? )
- FILE_ATTRIBUTE_HIDDEN bit-set? ;
-
-: hidden? ( path -- ? )
- attrib (hidden?) ;
-
-: (system?) ( mode -- ? )
- FILE_ATTRIBUTE_SYSTEM bit-set? ;
-
-: system? ( path -- ? )
- attrib (system?) ;
-
-: (directory?) ( mode -- ? )
- FILE_ATTRIBUTE_DIRECTORY bit-set? ;
-
-: directory? ( path -- ? )
- attrib (directory?) ;
-
-: (archive?) ( mode -- ? )
- FILE_ATTRIBUTE_ARCHIVE bit-set? ;
-
-: archive? ( path -- ? )
- attrib (archive?) ;
-
-! FILE_ATTRIBUTE_DEVICE
-! FILE_ATTRIBUTE_NORMAL
-! FILE_ATTRIBUTE_TEMPORARY
-! FILE_ATTRIBUTE_SPARSE_FILE
-! FILE_ATTRIBUTE_REPARSE_POINT
-! FILE_ATTRIBUTE_COMPRESSED
-! FILE_ATTRIBUTE_OFFLINE
-! FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
-! FILE_ATTRIBUTE_ENCRYPTED
-
diff --git a/unmaintained/io/shell.factor b/unmaintained/io/shell.factor
deleted file mode 100644
index 5213eb22c7..0000000000
--- a/unmaintained/io/shell.factor
+++ /dev/null
@@ -1,40 +0,0 @@
-USING: calendar io io-internals kernel math namespaces
-nonblocking-io prettyprint quotations sequences ;
-IN: shell
-
-SYMBOL: shell
-HOOK: directory* shell ( path -- seq )
-HOOK: make-file shell ( bytes -- file )
-HOOK: file. shell ( file -- )
-HOOK: touch-file shell ( path -- )
-
-: (ls) ( path -- )
- >r H{ } r> directory*
- [
- [ [ make-file file. ] with-row ] each
- ] curry tabular-output ;
-
-: ls ( -- )
- cwd (ls) ;
-
-: pwd ( -- )
- cwd pprint nl ;
-
-: (slurp) ( quot -- )
- >r default-buffer-size read r> over [
- dup slip (slurp)
- ] [
- 2drop
- ] if ;
-
-: slurp ( stream quot -- )
- [ (slurp) ] curry with-stream ;
-
-: cat ( path -- )
- <file-reader> stdio get
- duplex-stream-out <duplex-stream>
- [ write ] slurp ;
-
-: copy-file ( path path -- )
- >r <file-reader> r>
- <file-writer> <duplex-stream> [ write ] slurp ;
diff --git a/unmaintained/io/test/io.factor b/unmaintained/io/test/io.factor
deleted file mode 100644
index 379e1233f0..0000000000
--- a/unmaintained/io/test/io.factor
+++ /dev/null
@@ -1,42 +0,0 @@
-USING: calendar errors io kernel libs-io math namespaces sequences
-shell test ;
-IN: temporary
-
-SYMBOL: file "file-appender-test.txt" \ file set
-[ \ file get delete-file ] catch drop
-[ f ] [ \ file get exists? ] unit-test
-\ file get <file-appender> [ "asdf" write ] with-stream
-[ t ] [ \ file get exists? ] unit-test
-[ 4 ] [ \ file get file-length ] unit-test
-\ file get <file-appender> [ "jkl;" write ] with-stream
-[ t ] [ \ file get exists? ] unit-test
-[ 8 ] [ \ file get file-length ] unit-test
-[ "asdfjkl;" ] [ \ file get <file-reader> contents ] unit-test
-\ file get delete-file
-[ f ] [ \ file get exists? ] unit-test
-
-SYMBOL: directory "test-directory" \ directory set
-\ directory get create-directory
-[ t ] [ \ directory get directory? ] unit-test
-\ directory get delete-directory
-[ f ] [ \ directory get directory? ] unit-test
-
-SYMBOL: time "time-test.txt" \ time set
-[ \ time get delete-file ] catch drop
-\ time get touch-file
-[ 0 ] [ \ time get file-length ] unit-test
-[ t ] [ \ time get exists? ] unit-test
-\ time get 0 unix-time>timestamp dup set-file-times
-[ t ] [ \ time get file-write-time 0 unix-time>timestamp = ] unit-test
-[ t ] [ \ time get file-access-time 0 unix-time>timestamp = ] unit-test
-\ time get touch-file
-[ t ] [ now \ time get file-write-time timestamp- 10 < ] unit-test
-\ time get delete-file
-
-SYMBOL: longname "" 255 CHAR: a pad-left \ longname set
-\ longname get touch-file
-[ t ] [ \ longname get exists? ] unit-test
-[ 0 ] [ \ longname get file-length ] unit-test
-\ longname get delete-file
-[ f ] [ \ longname get exists? ] unit-test
-
diff --git a/unmaintained/io/test/mmap.factor b/unmaintained/io/test/mmap.factor
deleted file mode 100644
index faeca551c0..0000000000
--- a/unmaintained/io/test/mmap.factor
+++ /dev/null
@@ -1,21 +0,0 @@
-USING: alien errors io kernel libs-io mmap namespaces test ;
-
-IN: temporary
-SYMBOL: mmap "mmap-test.txt" \ mmap set
-
-[ \ mmap get delete-file ] catch drop
-\ mmap get [
- "Four" write
-] with-file-writer
-
-\ mmap get [
- >r CHAR: R r> mmap-address 3 set-alien-unsigned-1
-] with-mmap
-
-\ mmap get [
- mmap-address 3 alien-unsigned-1 CHAR: R = [
- "mmap test failed" throw
- ] unless
-] with-mmap
-
-[ \ mmap get delete-file ] catch drop
From 8f0b335f4b7c3acbbd3240231ceef6bd415626d7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 21:13:50 -0600
Subject: [PATCH 047/126] Clean up
---
basis/ui/gadgets/frames/frames.factor | 29 +++++++++++++--------------
1 file changed, 14 insertions(+), 15 deletions(-)
diff --git a/basis/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor
index c210d1b7e2..2005fefed7 100644
--- a/basis/ui/gadgets/frames/frames.factor
+++ b/basis/ui/gadgets/frames/frames.factor
@@ -11,16 +11,16 @@ TUPLE: frame < grid ;
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
-: @center 1 1 ;
-: @left 0 1 ;
-: @right 2 1 ;
-: @top 1 0 ;
-: @bottom 1 2 ;
+: @center 1 1 ; inline
+: @left 0 1 ; inline
+: @right 2 1 ; inline
+: @top 1 0 ; inline
+: @bottom 1 2 ; inline
-: @top-left 0 0 ;
-: @top-right 2 0 ;
-: @bottom-left 0 2 ;
-: @bottom-right 2 2 ;
+: @top-left 0 0 ; inline
+: @top-right 2 0 ; inline
+: @bottom-left 0 2 ; inline
+: @bottom-right 2 2 ; inline
: new-frame ( class -- frame )
<frame-grid> swap new-grid ; inline
@@ -28,13 +28,12 @@ TUPLE: frame < grid ;
: <frame> ( -- frame )
frame new-frame ;
-: (fill-center) ( vec n -- )
- over first pick third v+ [v-] 1 rot set-nth ;
+: (fill-center) ( n vec -- )
+ [ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
-: fill-center ( horiz vert dim -- )
- tuck (fill-center) (fill-center) ;
+: fill-center ( dim horiz vert -- )
+ [ over ] dip [ (fill-center) ] 2bi@ ;
M: frame layout*
dup compute-grid
- [ rot rect-dim fill-center ] 3keep
- grid-layout ;
+ [ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
From f5b19f8c3193d3ebbde6dc9b4c05428f09689252 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 19 Nov 2008 21:15:27 -0600
Subject: [PATCH 048/126] add the characters for ls -F to io.files.listing
---
basis/io/files/listing/unix/unix.factor | 14 +++++++++++++-
basis/io/unix/files/files.factor | 12 +++++++++++-
basis/unix/stat/stat.factor | 1 +
3 files changed, 25 insertions(+), 2 deletions(-)
diff --git a/basis/io/files/listing/unix/unix.factor b/basis/io/files/listing/unix/unix.factor
index 313ce1f79a..bef8d3dc56 100755
--- a/basis/io/files/listing/unix/unix.factor
+++ b/basis/io/files/listing/unix/unix.factor
@@ -3,7 +3,7 @@
USING: accessors combinators kernel system unicode.case
io.unix.files io.files.listing generalizations strings
arrays sequences io.files math.parser unix.groups unix.users
-io.files.listing.private ;
+io.files.listing.private unix.stat math ;
IN: io.files.listing.unix
<PRIVATE
@@ -30,6 +30,18 @@ IN: io.files.listing.unix
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ;
+: mode>symbol ( mode -- ch )
+ S_IFMT bitand
+ {
+ { [ dup S_IFDIR = ] [ drop "/" ] }
+ { [ dup S_IFIFO = ] [ drop "|" ] }
+ { [ dup any-execute? ] [ drop "*" ] }
+ { [ dup S_IFLNK = ] [ drop "@" ] }
+ { [ dup S_IFWHT = ] [ drop "%" ] }
+ { [ dup S_IFSOCK = ] [ drop "=" ] }
+ { [ t ] [ drop "" ] }
+ } cond ;
+
M: unix (directory.) ( path -- lines )
[ [
[
diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor
index 98206bc992..ad5c192a39 100644
--- a/basis/io/unix/files/files.factor
+++ b/basis/io/unix/files/files.factor
@@ -6,7 +6,8 @@ math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private destructors vocabs.loader calendar.unix
unix.stat alien.c-types arrays unix.users unix.groups
-environment fry io.encodings.utf8 alien.strings unix.statfs ;
+environment fry io.encodings.utf8 alien.strings unix.statfs
+combinators.short-circuit ;
IN: io.unix.files
M: unix cwd ( -- path )
@@ -228,6 +229,15 @@ GENERIC: other-read? ( obj -- ? )
GENERIC: other-write? ( obj -- ? )
GENERIC: other-execute? ( obj -- ? )
+: any-read? ( obj -- ? )
+ { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
+
+: any-write? ( obj -- ? )
+ { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
+
+: any-execute? ( obj -- ? )
+ { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
+
M: integer uid? ( integer -- ? ) UID mask? ;
M: integer gid? ( integer -- ? ) GID mask? ;
M: integer sticky? ( integer -- ? ) STICKY mask? ;
diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor
index 17d6604fc0..a3b0ed11b7 100644
--- a/basis/unix/stat/stat.factor
+++ b/basis/unix/stat/stat.factor
@@ -13,6 +13,7 @@ IN: unix.stat
: S_IFIFO OCT: 010000 ; inline ! FIFO.
: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
: S_IFSOCK OCT: 140000 ; inline ! Socket.
+: S_IFWHT OCT: 160000 ; inline ! Whiteout.
FUNCTION: int chmod ( char* path, mode_t mode ) ;
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
From 5a99526598d7df109c76b5bca5b50cf1bd0593e6 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 19 Nov 2008 21:15:29 -0600
Subject: [PATCH 049/126] boids: adjust 'USING:' line
---
extra/boids/boids.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor
index 097b952db9..eeebe1c12d 100644
--- a/extra/boids/boids.factor
+++ b/extra/boids/boids.factor
@@ -1,5 +1,5 @@
-USING: combinators.short-circuit kernel namespaces
+USING: kernel namespaces
math
math.constants
math.functions
@@ -10,6 +10,7 @@ USING: combinators.short-circuit kernel namespaces
math.physics.vel
combinators arrays sequences random vars
combinators.lib
+ combinators.short-circuit
accessors ;
IN: boids
From bcd2ffc830fa5d35b39872462fe52cc7d8e00cbb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 21:57:59 -0600
Subject: [PATCH 050/126] If rendering an error popup fails, don't open an
endless stream
---
basis/ui/gadgets/worlds/worlds.factor | 4 ++--
basis/ui/tools/debugger/debugger.factor | 10 +++++++++-
2 files changed, 11 insertions(+), 3 deletions(-)
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 6f901c37ee..e338d6d4f4 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -30,7 +30,7 @@ ERROR: no-world-found ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
- >r >r dup parent>> dup r> r>
+ [ dup parent>> dup ] 2dip
[ (request-focus) ] keep
] unless focus-child ;
@@ -80,7 +80,7 @@ SYMBOL: ui-error-hook
: ui-error ( error -- )
ui-error-hook get [ call ] [ print-error ] if* ;
-[ rethrow ] ui-error-hook set-global
+ui-error-hook global [ [ rethrow ] or ] change-at
: draw-world ( world -- )
dup draw-world? [
diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
index 4ba4374bb8..1f019fca7c 100644
--- a/basis/ui/tools/debugger/debugger.factor
+++ b/basis/ui/tools/debugger/debugger.factor
@@ -35,7 +35,15 @@ M: debugger focusable-child* restarts>> ;
#! No restarts for the debugger window
f [ drop ] <debugger> "Error" open-window ;
-[ debugger-window ] ui-error-hook set-global
+GENERIC: error-in-debugger? ( error -- ? )
+
+M: world-error error-in-debugger? world>> gadget-child debugger? ;
+
+M: object error-in-debugger? drop f ;
+
+[
+ dup error-in-debugger? [ rethrow ] [ debugger-window ] if
+] ui-error-hook set-global
M: world-error error.
"An error occurred while drawing the world " write
From 4af2592369d2ddeb41436398b84be36e45a09a6f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 21:58:45 -0600
Subject: [PATCH 051/126] Fix some scrollers problems
---
.../gadgets/scrollers/scrollers-tests.factor | 23 ++++++-
basis/ui/gadgets/scrollers/scrollers.factor | 62 ++++++++++---------
2 files changed, 53 insertions(+), 32 deletions(-)
diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor
index 625bfd7880..d6792abd49 100644
--- a/basis/ui/gadgets/scrollers/scrollers-tests.factor
+++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor
@@ -2,7 +2,8 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
kernel models models.compose models.range ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences
-tools.test.ui math.geometry.rect accessors ;
+tools.test.ui math.geometry.rect accessors ui.gadgets.buttons
+ui.gadgets.packs ;
IN: ui.gadgets.scrollers.tests
[ ] [
@@ -74,7 +75,7 @@ dup layout
"g2" get scroll>gadget
"s" get layout
"s" get scroller-value
- ] map [ { 3 0 } = ] all?
+ ] map [ { 2 0 } = ] all?
] unit-test
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
@@ -86,4 +87,22 @@ dup layout
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
+[ ] [
+ "Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
+ [ <pile> swap add-gadget <scroller> ] keep
+ dup quot>> call
+ layout
+] unit-test
+
+[ t ] [
+ <gadget> { 200 200 } >>dim
+ [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
+ dup
+ <pile> swap add-gadget <scroller> { 100 100 } >>dim dup layout
+ swap dup quot>> call
+ dup layout
+ model>> dependencies>> [ range-max value>> ] map
+ viewport-gap 2 v*n =
+] unit-test
+
\ <scroller> must-infer
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 045ecc7990..37f6e83e0c 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -3,9 +3,8 @@
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
-models models.range models.compose
-combinators math.vectors classes.tuple math.geometry.rect
-combinators.short-circuit ;
+models models.range models.compose combinators math.vectors
+classes.tuple math.geometry.rect combinators.short-circuit ;
IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ;
@@ -22,9 +21,10 @@ TUPLE: scroller < frame viewport x y follows ;
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
: do-mouse-scroll ( scroller -- )
- scroll-direction get-global first2
- pick y>> slide-by-line
- swap x>> slide-by-line ;
+ scroll-direction get-global
+ [ first swap x>> slide-by-line ]
+ [ second swap y>> slide-by-line ]
+ 2bi ;
scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] }
@@ -49,8 +49,8 @@ scroller H{
: scroll ( value scroller -- )
[
- dup viewport>> rect-dim { 0 0 }
- rot viewport>> viewport-dim 4array flip
+ viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
+ 4array flip
] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ;
@@ -58,15 +58,14 @@ scroller H{
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
: (scroll>rect) ( rect scroller -- )
- [
- scroller-value vneg offset-rect
- viewport-gap offset-rect
- ] keep
- [ viewport>> dim>> rect-min ] keep
- [
- viewport>> 2rect-extent
- [ v- { 1 1 } v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+
- ] keep dup scroller-value rot v+ swap scroll ;
+ [ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
+ {
+ [ scroller-value vneg offset-rect viewport-gap offset-rect ]
+ [ viewport>> dim>> rect-min ]
+ [ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
+ [ scroller-value v+ ]
+ [ scroll ]
+ } cleave ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
viewport>> gadget-child relative-loc offset-rect ;
@@ -81,14 +80,17 @@ scroller H{
[ relative-scroll-rect ] keep
swap >>follows
relayout
- ] [
- 3drop
- ] if ;
+ ] [ 3drop ] if ;
+
+: (update-scroller) ( scroller -- )
+ [ scroller-value ] keep scroll ;
: (scroll>gadget) ( gadget scroller -- )
- >r { 0 0 } over pref-dim <rect> swap r>
- [ relative-scroll-rect ] keep
- (scroll>rect) ;
+ 2dup swap child? [
+ [ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
+ [ relative-scroll-rect ] keep
+ (scroll>rect)
+ ] [ f >>follows (update-scroller) drop ] if ;
: scroll>gadget ( gadget -- )
dup find-scroller* dup [
@@ -99,7 +101,7 @@ scroller H{
] if ;
: (scroll>bottom) ( scroller -- )
- dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
+ [ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
: scroll>bottom ( gadget -- )
find-scroller [ t >>follows relayout-1 ] when* ;
@@ -115,19 +117,19 @@ M: gadget update-scroller swap (scroll>gadget) ;
M: rect update-scroller swap (scroll>rect) ;
-M: f update-scroller drop dup scroller-value swap scroll ;
+M: f update-scroller drop (update-scroller) ;
M: scroller layout*
- dup call-next-method
- dup follows>>
- 2dup update-scroller
- >>follows drop ;
+ [ call-next-method ] [
+ dup follows>>
+ [ update-scroller ] [ >>follows drop ] 2bi
+ ] bi ;
M: scroller focusable-child*
viewport>> ;
M: scroller model-changed
- nip f >>follows drop ;
+ f >>follows 2drop ;
TUPLE: limited-scroller < scroller
{ min-dim initial: { 0 0 } }
From 375a9df29b234ebd7341e8bb9c29a0e8ed913583 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 21:59:11 -0600
Subject: [PATCH 052/126] Fix shift-click in editor nested inside a pane
---
basis/ui/gadgets/editors/editors.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index d42df93b72..a1c4f3d04e 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -453,7 +453,7 @@ editor "caret-motion" f {
T{ doc-elt } editor-select-next ;
editor "selection" f {
- { T{ button-down f { S+ } } extend-selection }
+ { T{ button-down f { S+ } 1 } extend-selection }
{ T{ drag } drag-selection }
{ T{ gain-focus } focus-editor }
{ T{ lose-focus } unfocus-editor }
From 248cb0df5ed7bf97c7fdd08bc647293934350a50 Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Thu, 20 Nov 2008 03:47:39 -0600
Subject: [PATCH 053/126] Add some error checking to the X11 UI: if an event
handler throws an error, we open a debugger window, as on other platforms,
instead of stopping the UI
---
basis/ui/x11/x11.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
index e3c8421080..fd599635b1 100644
--- a/basis/ui/x11/x11.factor
+++ b/basis/ui/x11/x11.factor
@@ -185,7 +185,7 @@ M: world client-event
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup
- [ [ 2dup handle-event ] assert-depth ] when 2drop ;
+ [ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ;
: x-clipboard@ ( gadget clipboard -- prop win )
atom>> swap
From 1477a0f6f5c5733a2c20db37e692a3421b00a1ce Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 18:11:25 -0600
Subject: [PATCH 054/126] Code cleanups
---
basis/ui/gadgets/frames/frames.factor | 2 +-
basis/ui/gadgets/viewports/viewports.factor | 8 +++++---
basis/ui/tools/search/search.factor | 2 +-
basis/ui/ui.factor | 4 ++--
4 files changed, 9 insertions(+), 7 deletions(-)
diff --git a/basis/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor
index 2005fefed7..b5c3736896 100644
--- a/basis/ui/gadgets/frames/frames.factor
+++ b/basis/ui/gadgets/frames/frames.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor
index 5f714a526b..f01ef3bf42 100644
--- a/basis/ui/gadgets/viewports/viewports.factor
+++ b/basis/ui/gadgets/viewports/viewports.factor
@@ -21,9 +21,11 @@ TUPLE: viewport < gadget ;
swap add-gadget ;
M: viewport layout*
- dup rect-dim viewport-gap 2 v*n v-
- over gadget-child pref-dim vmax
- swap gadget-child (>>dim) ;
+ [
+ [ rect-dim viewport-gap 2 v*n v- ]
+ [ gadget-child pref-dim ]
+ bi vmax
+ ] [ gadget-child ] bi (>>dim) ;
M: viewport focusable-child*
gadget-child ;
diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor
index b88fe8454e..3081eb1cdc 100644
--- a/basis/ui/tools/search/search.factor
+++ b/basis/ui/tools/search/search.factor
@@ -48,7 +48,7 @@ search-field H{
} set-gestures
: <search-model> ( live-search producer -- live-search filter )
- >r dup field>> model>> ! live-search model :: producer
+ >r dup field>> model>>
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index f561f3cd49..db0ac9a624 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -129,8 +129,8 @@ SYMBOL: ui-hook
: notify ( gadget -- )
dup graft-state>>
- dup first { f f } { t t } ?
- pick (>>graft-state) {
+ [ first { f f } { t t } ? >>graft-state ] keep
+ {
{ { f t } [ dup activate-control graft* ] }
{ { t f } [ dup deactivate-control ungraft* ] }
} case ;
From d74af138e18e3c97de1cdfc342787a690daaf885 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 18:30:08 -0600
Subject: [PATCH 055/126] Fix shift-drag selection in panes
---
basis/ui/gadgets/panes/panes.factor | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index ef5745809e..c1b3df3857 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -363,7 +363,11 @@ M: f sloppy-pick-up*
dup hand-rel over sloppy-pick-up >>caret
dup relayout-1 ;
-: begin-selection ( pane -- ) move-caret f >>mark drop ;
+: begin-selection ( pane -- )
+ f >>selecting?
+ move-caret
+ f >>mark
+ drop ;
: extend-selection ( pane -- )
hand-moved? [
@@ -389,6 +393,7 @@ M: f sloppy-pick-up*
] if ;
: select-to-caret ( pane -- )
+ t >>selecting?
dup mark>> [ caret>mark ] unless
move-caret
dup request-focus
From 44c090d0a7f0e8155e361b4c7ecfda4c2e8960ef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 19:04:10 -0600
Subject: [PATCH 056/126] Strip out print-use-hook to reduce image size
---
basis/tools/deploy/shaker/shaker.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index f8f9680c16..1992dbcda3 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -267,6 +267,7 @@ IN: tools.deploy.shaker
layouts:type-numbers
lexer-factory
listener:listener-hook
+ parser:print-use-hook
root-cache
vocab-roots
vocabs:dictionary
From 2620a101071c345c329e868da316ad362a45170e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 20:34:49 -0600
Subject: [PATCH 057/126] Display help in browser tool
---
basis/help/help-docs.factor | 9 +++++++--
basis/help/help.factor | 9 ++++++++-
basis/ui/tools/browser/browser.factor | 19 ++++++++++---------
3 files changed, 25 insertions(+), 12 deletions(-)
diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor
index 277d965e39..4a06235c69 100644
--- a/basis/help/help-docs.factor
+++ b/basis/help/help-docs.factor
@@ -129,12 +129,17 @@ HELP: $title
{ $values { "topic" "a help article name or a word" } }
{ $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ;
+HELP: print-topic
+{ $values { "topic" "an article name or a word" } }
+{ $description
+ "Displays a help topic on " { $link output-stream } "."
+} ;
+
HELP: help
{ $values { "topic" "an article name or a word" } }
{ $description
- "Displays a help article or documentation associated to a word on " { $link output-stream } "."
+ "Displays a help topic."
} ;
-
HELP: about
{ $values { "vocab" "a vocabulary specifier" } }
{ $description
diff --git a/basis/help/help.factor b/basis/help/help.factor
index 686578f1b6..f9775e2668 100644
--- a/basis/help/help.factor
+++ b/basis/help/help.factor
@@ -89,10 +89,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
] with-nesting
] with-style nl ;
-: help ( topic -- )
+: print-topic ( topic -- )
last-element off dup $title
article-content print-content nl ;
+SYMBOL: help-hook
+
+help-hook global [ [ print-topic ] or ] change-at
+
+: help ( topic -- )
+ help-hook get call ;
+
: about ( vocab -- )
dup require
dup vocab [ ] [
diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor
index 83a3b7ff68..b717bbb2f9 100644
--- a/basis/ui/tools/browser/browser.factor
+++ b/basis/ui/tools/browser/browser.factor
@@ -4,17 +4,17 @@ USING: debugger ui.tools.workspace help help.topics kernel
models models.history ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
ui.gadgets.buttons compiler.units assocs words vocabs
-accessors ;
+accessors fry combinators.short-circuit ;
IN: ui.tools.browser
TUPLE: browser-gadget < track pane history ;
: show-help ( link help -- )
- dup history>> add-history
- >r >link r> history>> set-model ;
+ history>> dup add-history
+ [ >link ] dip set-model ;
: <help-pane> ( browser-gadget -- gadget )
- history>> [ [ help ] curry try ] <pane-control> ;
+ history>> [ '[ _ print-topic ] try ] <pane-control> ;
: init-history ( browser-gadget -- )
"handbook" >link <history> >>history drop ;
@@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ;
: <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track
dup init-history
- dup <toolbar> f track-add
+ add-toolbar
dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add ;
@@ -38,10 +38,11 @@ M: browser-gadget ungraft*
[ call-next-method ] [ remove-definition-observer ] bi ;
: showing-definition? ( defspec assoc -- ? )
- [ key? ] 2keep
- [ >r dup word-link? [ name>> ] when r> key? ] 2keep
- >r dup vocab-link? [ vocab ] when r> key?
- or or ;
+ {
+ [ key? ]
+ [ [ dup word-link? [ name>> ] when ] dip key? ]
+ [ [ dup vocab-link? [ vocab ] when ] dip key? ]
+ } 2|| ;
M: browser-gadget definitions-changed ( assoc browser -- )
history>>
From 98d109a9a8caf8bc1d62a9f964c46cc6c6ce381b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 20:35:01 -0600
Subject: [PATCH 058/126] Rename do-what-i-mean? to auto-use?
---
core/parser/parser.factor | 15 +++++++++------
1 file changed, 9 insertions(+), 6 deletions(-)
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 007120fd19..414e9ea499 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -82,17 +82,20 @@ ERROR: no-word-error name ;
SYMBOL: amended-use?
-SYMBOL: do-what-i-mean?
+SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word )
- dup word?
- [ amended-use? on dup vocabulary>> (use+) ]
- [ create-in ]
- if ;
+ dup word? [
+ amended-use? on
+ dup vocabulary>>
+ [ (use+) ] [
+ "Added ``" swap "'' vocabulary to search path" 3append note.
+ ] bi
+ ] [ create-in ] if ;
: no-word ( name -- newword )
dup words-named [ forward-reference? not ] filter
- dup length 1 = do-what-i-mean? get and
+ dup length 1 = auto-use? get and
[ nip first no-word-restarted ]
[ <no-word-error> throw-restarts no-word-restarted ]
if ;
From 00869b6ad4df23591182d6ad677a267ad61ace35 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 20:35:58 -0600
Subject: [PATCH 059/126] Documentation update
---
basis/prettyprint/prettyprint-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor
index 159421c18c..3c004e5b30 100644
--- a/basis/prettyprint/prettyprint-docs.factor
+++ b/basis/prettyprint/prettyprint-docs.factor
@@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks"
"Prettyprinting any stack:"
{ $subsection stack. }
"Prettyprinting any call stack:"
-{ $subsection callstack. } ;
+{ $subsection callstack. }
+"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ;
ARTICLE: "prettyprint-variables" "Prettyprint control variables"
"The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:"
From 25ec44b0b31ee774b2b7d65bfb5d6945bcc44a64 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 20:37:34 -0600
Subject: [PATCH 060/126] Listener now displays stacks and can watch variables
---
basis/listener/listener-docs.factor | 25 +++++++-----
basis/listener/listener.factor | 59 +++++++++++++++++++++++------
2 files changed, 62 insertions(+), 22 deletions(-)
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index beea9005b4..9b2903970a 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -1,34 +1,39 @@
USING: help.markup help.syntax kernel io system prettyprint ;
IN: listener
+ARTICLE: "listener-watch" "Watching variables in the listener"
+"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
+{ $subsection visible-vars }
+"To add or remove a single variable:"
+{ $subsection watch-var }
+{ $subsection unwatch-var }
+"To add and remove multiple variables:"
+{ $subsection watch-vars }
+{ $subsection unwatch-vars } ;
+
ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
-"Multi-line phrases are supported:"
+"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
-$nl
-"A very common operation is to inspect the contents of the data stack in the listener:"
-{ $subsection .s }
-"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "."
-$nl
+{ $subsection "listener-watch" }
"You can start a nested listener or exit a listener using the following words:"
{ $subsection listener }
{ $subsection bye }
-"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:"
-{ $subsection listener-hook }
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
{ $subsection read-quot } ;
ABOUT: "listener"
+<PRIVATE
+
HELP: quit-flag
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
-HELP: listener-hook
-{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
+PRIVATE>
HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index feddbdc042..ee16f6369a 100644
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -3,16 +3,10 @@
USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
-definitions compiler.units accessors colors ;
-
+definitions compiler.units accessors colors prettyprint fry
+sets ;
IN: listener
-SYMBOL: quit-flag
-
-SYMBOL: listener-hook
-
-[ ] listener-hook set-global
-
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-lines-interactive ( lines -- quot/f )
@@ -38,18 +32,57 @@ M: object stream-read-quot
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
+<PRIVATE
+
+SYMBOL: quit-flag
+
+PRIVATE>
+
: bye ( -- ) quit-flag on ;
-: prompt. ( -- )
- "( " in get " )" 3append
- H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
+SYMBOL: visible-vars
+
+: watch-var ( sym -- ) visible-vars [ swap suffix ] change ;
+
+: watch-vars ( seq -- ) visible-vars [ swap union ] change ;
+
+: unwatch-var ( sym -- ) visible-vars [ remove ] change ;
+
+: unwatch-vars ( seq -- ) visible-vars [ swap diff ] change ;
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
+<PRIVATE
+
+: title. ( string -- )
+ H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
+
+: visible-vars. ( -- )
+ visible-vars get [
+ nl "--- Watched variables:" title.
+ standard-table-style [
+ [
+ [
+ [ [ short. ] with-cell ]
+ [ [ get short. ] with-cell ]
+ bi
+ ] with-row
+ ] each
+ ] tabular-output
+ ] unless-empty ;
+
+: stacks. ( -- )
+ datastack [ nl "--- Data stack:" title. stack. ] unless-empty
+ retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ;
+
+: prompt. ( -- )
+ "( " in get auto-use? get [ " - auto" append ] when " )" 3append
+ H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
+
: listen ( -- )
- listener-hook get call prompt.
+ visible-vars. stacks. prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup lexer-error? [
@@ -62,6 +95,8 @@ SYMBOL: error-hook
: until-quit ( -- )
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
+PRIVATE>
+
: listener ( -- )
[ until-quit ] with-interactive-vocabs ;
From 3b037c89474341fcfff8eddfea52714758fcd59c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 21:54:07 -0600
Subject: [PATCH 061/126] Fix load error in tools.deploy.shaker
---
basis/tools/deploy/shaker/shaker.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 1992dbcda3..f5778e410f 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -266,8 +266,7 @@ IN: tools.deploy.shaker
layouts:tag-numbers
layouts:type-numbers
lexer-factory
- listener:listener-hook
- parser:print-use-hook
+ print-use-hook
root-cache
vocab-roots
vocabs:dictionary
From 786ca76d02245480b5cb28a0f8acab6379b005be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 21:54:28 -0600
Subject: [PATCH 062/126] Listener now displays stacks and watched variables
---
basis/listener/listener-docs.factor | 8 ++++----
basis/listener/listener.factor | 8 ++++----
2 files changed, 8 insertions(+), 8 deletions(-)
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index 9b2903970a..8ef49ca0d9 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -5,11 +5,11 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
{ $subsection visible-vars }
"To add or remove a single variable:"
-{ $subsection watch-var }
-{ $subsection unwatch-var }
+{ $subsection show-var }
+{ $subsection hide-var }
"To add and remove multiple variables:"
-{ $subsection watch-vars }
-{ $subsection unwatch-vars } ;
+{ $subsection show-vars }
+{ $subsection hide-vars } ;
ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index ee16f6369a..5d58cafe29 100644
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -42,13 +42,13 @@ PRIVATE>
SYMBOL: visible-vars
-: watch-var ( sym -- ) visible-vars [ swap suffix ] change ;
+: show-var ( sym -- ) visible-vars [ swap suffix ] change ;
-: watch-vars ( seq -- ) visible-vars [ swap union ] change ;
+: show-vars ( seq -- ) visible-vars [ swap union ] change ;
-: unwatch-var ( sym -- ) visible-vars [ remove ] change ;
+: hide-var ( sym -- ) visible-vars [ remove ] change ;
-: unwatch-vars ( seq -- ) visible-vars [ swap diff ] change ;
+: hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
SYMBOL: error-hook
From 2e2856b9a490e80a568cdebbba8e389535619d5f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 21:54:38 -0600
Subject: [PATCH 063/126] Document auto-use? feature
---
core/parser/parser-docs.factor | 20 +++++++++++++-------
1 file changed, 13 insertions(+), 7 deletions(-)
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index d3c2cff19d..92e5922802 100644
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -41,13 +41,15 @@ $nl
}
"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
-ARTICLE: "vocabulary-search-errors" "Word lookup errors"
-"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
-{ $list
- { "If there are no words having this name at all, an error is thrown and parsing stops." }
- { "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
-}
-"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ;
+ARTICLE: "vocabulary-search-errors" "Word lookup errors"
+"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
+$nl
+"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used."
+$nl
+"If " { $link auto-use? } " mode is on and only one vocabulary has a word with this name, the vocabulary is added to the search path and parsing continues."
+$nl
+"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file."
+{ $subsection auto-use? } ;
ARTICLE: "vocabulary-search" "Vocabulary search path"
"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
@@ -353,3 +355,7 @@ HELP: staging-violation
{ $description "Throws a " { $link staging-violation } " error." }
{ $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." }
{ $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ;
+
+HELP: auto-use?
+{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
+{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "vocabulary-search-errors" } "." } ;
From 2eac58c271e2eaaeacb25931905ef87e2ecc292d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 21:57:56 -0600
Subject: [PATCH 064/126] Fix '0 track-add'
---
basis/ui/gadgets/tracks/tracks-tests.factor | 7 +++++++
basis/ui/gadgets/tracks/tracks.factor | 8 ++++++--
2 files changed, 13 insertions(+), 2 deletions(-)
diff --git a/basis/ui/gadgets/tracks/tracks-tests.factor b/basis/ui/gadgets/tracks/tracks-tests.factor
index 93f2d14528..5381eebb01 100644
--- a/basis/ui/gadgets/tracks/tracks-tests.factor
+++ b/basis/ui/gadgets/tracks/tracks-tests.factor
@@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests
<gadget> { 100 100 } >>dim 1 track-add
pref-dim
] unit-test
+
+[ { 10 10 } ] [
+ { 0 1 } <track>
+ <gadget> { 10 10 } >>dim 1 track-add
+ <gadget> { 10 10 } >>dim 0 track-add
+ pref-dim
+] unit-test
diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor
index 771c489ce3..dc176b5bf7 100644
--- a/basis/ui/gadgets/tracks/tracks.factor
+++ b/basis/ui/gadgets/tracks/tracks.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel namespaces fry
math math.vectors math.geometry.rect math.order
-sequences words ui.gadgets ui.gadgets.packs ;
+sequences words ui.gadgets ui.gadgets.packs ui.gadgets.buttons ;
IN: ui.gadgets.tracks
@@ -41,7 +41,8 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
: track-pref-dims-2 ( track -- dim )
[
[ children>> pref-dims ] [ normalized-sizes ] bi
- [ [ v/n ] when* ] 2map max-dim [ >fixnum ] map
+ [ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map
+ max-dim [ >fixnum ] map
]
[ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
v+ ;
@@ -56,6 +57,9 @@ M: track pref-dim* ( gadget -- dim )
: track-add ( track gadget constraint -- track )
pick sizes>> push add-gadget ;
+: add-toolbar ( track -- track )
+ dup <toolbar> f track-add ;
+
: track-remove ( track gadget -- track )
dupd dup [
[ swap children>> index ]
From f27ebdd1ef225344101fe9793a6013cee2b62a49 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 21:58:30 -0600
Subject: [PATCH 065/126] Use add-toolbar word in a few places
---
basis/ui/gadgets/slots/slots.factor | 2 +-
basis/ui/tools/debugger/debugger.factor | 2 +-
basis/ui/tools/inspector/inspector.factor | 2 +-
basis/ui/tools/profiler/profiler.factor | 2 +-
basis/ui/tools/search/search.factor | 72 ++++++++++++-----------
basis/ui/tools/traceback/traceback.factor | 2 +-
basis/ui/tools/walker/walker.factor | 4 +-
basis/ui/tools/workspace/workspace.factor | 18 +++---
8 files changed, 53 insertions(+), 51 deletions(-)
diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor
index 1cf23e2d06..ff2220b60e 100644
--- a/basis/ui/gadgets/slots/slots.factor
+++ b/basis/ui/gadgets/slots/slots.factor
@@ -71,7 +71,7 @@ M: value-ref finish-editing
: <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track
swap >>ref
- dup <toolbar> f track-add
+ add-toolbar
<source-editor> >>text
dup text>> <scroller> 1 track-add
dup revert ;
diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
index 1f019fca7c..641763c0b1 100644
--- a/basis/ui/tools/debugger/debugger.factor
+++ b/basis/ui/tools/debugger/debugger.factor
@@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ;
: <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track
- dup <toolbar> f track-add
+ add-toolbar
-rot <restart-list> >>restarts
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor
index dcb3a3f8ad..579210325b 100644
--- a/basis/ui/tools/inspector/inspector.factor
+++ b/basis/ui/tools/inspector/inspector.factor
@@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ;
: <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track
- dup <toolbar> f track-add
+ add-toolbar
<pane> >>pane
dup pane>> <scroller> 1 track-add ;
diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor
index c60d0dac09..05d1ccdb82 100644
--- a/basis/ui/tools/profiler/profiler.factor
+++ b/basis/ui/tools/profiler/profiler.factor
@@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track
- dup <toolbar> f track-add
+ add-toolbar
<pane> >>pane
dup pane>> <scroller> 1 track-add ;
diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor
index 3081eb1cdc..033aacc1b3 100644
--- a/basis/ui/tools/search/search.factor
+++ b/basis/ui/tools/search/search.factor
@@ -1,14 +1,14 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs ui.tools.interactor ui.tools.listener
-ui.tools.workspace help help.topics io.files io.styles kernel
-models models.delay models.filter namespaces prettyprint
+USING: accessors assocs help help.topics io.files io.styles
+kernel models models.delay models.filter namespaces prettyprint
quotations sequences sorting source-files definitions strings
-tools.completion tools.crossref classes.tuple ui.commands
-ui.gadgets ui.gadgets.editors ui.gadgets.lists
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
-vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
-;
+tools.completion tools.crossref classes.tuple vocabs words
+vocabs.loader tools.vocabs unicode.case calendar locals
+ui.tools.interactor ui.tools.listener ui.tools.workspace
+ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
+ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
+ui.gestures ui.operations ui ;
IN: ui.tools.search
TUPLE: live-search < track field list ;
@@ -23,7 +23,7 @@ TUPLE: live-search < track field list ;
M: live-search handle-gesture ( gesture live-search -- ? )
tuck search-gesture dup [
over find-workspace hide-popup
- >r search-value r> invoke-command f
+ [ search-value ] dip invoke-command f
] [
2drop t
] if ;
@@ -47,27 +47,29 @@ search-field H{
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
} set-gestures
-: <search-model> ( live-search producer -- live-search filter )
- >r dup field>> model>>
- ui-running? [ 1/5 seconds <delay> ] when
- [ "\n" join ] r> append <filter> ;
+: <search-model> ( live-search producer -- filter )
+ [
+ field>> model>>
+ ui-running? [ 1/5 seconds <delay> ] when
+ ] dip [ "\n" join ] prepend <filter> ;
-: <search-list> ( live-search seq limited? presenter -- live-search list )
- >r
- [ limited-completions ] [ completions ] ? curry
- <search-model>
- >r [ find-workspace hide-popup ] r> r>
- swap <list> ;
+: init-search-model ( live-search seq limited? -- live-search )
+ [ 2drop ]
+ [ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
+ >>model ; inline
-: <live-search> ( string seq limited? presenter -- gadget )
+: <search-list> ( presenter live-search -- list )
+ [ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
+
+:: <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track
<search-field> >>field
- dup field>> f track-add
- -roll <search-list> >>list
+ seq limited? init-search-model
+ presenter over <search-list> >>list
+ dup field>> 1 <border> { 0 0 } >>align f track-add
dup list>> <scroller> 1 track-add
- swap
- over field>> set-editor-string
- dup field>> end-of-document ;
+ string over field>> set-editor-string
+ dup field>> end-of-document ;
M: live-search focusable-child* field>> ;
@@ -80,26 +82,27 @@ M: live-search pref-dim* drop { 400 200 } ;
[ dup synopsis >lower ] { } map>assoc sort-values ;
: <definition-search> ( string words limited? -- gadget )
- >r definition-candidates r> [ synopsis ] <live-search> ;
+ [ definition-candidates ] dip [ synopsis ] <live-search> ;
: word-candidates ( words -- candidates )
[ dup name>> >lower ] { } map>assoc ;
: <word-search> ( string words limited? -- gadget )
- >r word-candidates r> [ synopsis ] <live-search> ;
+ [ word-candidates ] dip [ synopsis ] <live-search> ;
: com-words ( workspace -- )
dup current-word all-words t <word-search>
"Word search" show-titled-popup ;
: show-vocab-words ( workspace vocab -- )
- "" over words natural-sort f <word-search>
- "Words in " rot vocab-name append show-titled-popup ;
+ [ "" swap words natural-sort f <word-search> ]
+ [ "Words in " swap vocab-name append ]
+ bi show-titled-popup ;
: show-word-usage ( workspace word -- )
- "" over smart-usage f <definition-search>
- "Words and methods using " rot name>> append
- show-titled-popup ;
+ [ "" swap smart-usage f <definition-search> ]
+ [ "Words and methods using " swap name>> append ]
+ bi show-titled-popup ;
: help-candidates ( seq -- candidates )
[ dup >link swap article-title >lower ] { } map>assoc
@@ -127,8 +130,9 @@ M: live-search pref-dim* drop { 400 200 } ;
"Source file search" show-titled-popup ;
: show-vocab-files ( workspace vocab -- )
- "" over vocab-files <source-file-search>
- "Source files in " rot vocab-name append show-titled-popup ;
+ [ "" swap vocab-files <source-file-search> ]
+ [ "Source files in " swap vocab-name append ]
+ bi show-titled-popup ;
: vocab-candidates ( -- candidates )
all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor
index 7e2158e0e9..45f15b1ffc 100644
--- a/basis/ui/tools/traceback/traceback.factor
+++ b/basis/ui/tools/traceback/traceback.factor
@@ -36,7 +36,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
dup model>> <callstack-display> 2/3 track-add
- dup <toolbar> f track-add ;
+ add-toolbar ;
: <namestack-display> ( model -- gadget )
[ [ name>> namestack. ] when* ]
diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor
index 7bc42ea676..9c825d4920 100644
--- a/basis/ui/tools/walker/walker.factor
+++ b/basis/ui/tools/walker/walker.factor
@@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
swap >>status
dup continuation>> <traceback-gadget> >>traceback
- dup <toolbar> f track-add
+ add-toolbar
dup status>> self <thread-status> f track-add
- dup traceback>> 1 track-add ;
+ dup traceback>> 1 track-add ;
: walker-help ( -- ) "ui-walker" help-window ;
diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor
index f06e0aae26..6536cb8c7d 100644
--- a/basis/ui/tools/workspace/workspace.factor
+++ b/basis/ui/tools/workspace/workspace.factor
@@ -1,12 +1,12 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes continuations help help.topics kernel models
- sequences ui ui.backend ui.tools.debugger ui.gadgets
- ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
- ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
- ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
- ui.commands ui.gestures assocs arrays namespaces accessors ;
-
+sequences assocs arrays namespaces accessors math.vectors ui
+ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
+ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
+ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
+ui.gadgets.presentations ui.gadgets.status-bar ui.commands
+ui.gestures ;
IN: ui.tools.workspace
TUPLE: workspace < track book listener popup ;
@@ -32,8 +32,6 @@ M: gadget tool-scroller drop f ;
[ find-tool swap ] keep book>> model>>
set-model ;
-: select-tool ( workspace class -- ) swap show-tool drop ;
-
: get-workspace* ( quot -- workspace )
[ >r dup workspace? r> [ drop f ] if ] curry find-window
[ dup raise-window gadget-child ]
@@ -81,7 +79,7 @@ SYMBOL: workspace-dim
{ 600 700 } workspace-dim set-global
-M: workspace pref-dim* drop workspace-dim get ;
+M: workspace pref-dim* call-next-method workspace-dim get vmax ;
M: workspace focusable-child*
dup popup>> [ ] [ listener>> ] ?if ;
From 08f7e02a3be61e64a4743771fa1b01a3102c7b17 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 21:59:22 -0600
Subject: [PATCH 066/126] Remove stack display from listener tool, and tweak
appearance
---
basis/ui/tools/interactor/interactor.factor | 4 -
basis/ui/tools/listener/listener.factor | 86 ++++++++++-----------
basis/ui/tools/tools-docs.factor | 2 +-
basis/ui/tools/tools.factor | 25 +++---
4 files changed, 54 insertions(+), 63 deletions(-)
diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor
index a36610a7f5..36ce67e57b 100644
--- a/basis/ui/tools/interactor/interactor.factor
+++ b/basis/ui/tools/interactor/interactor.factor
@@ -178,10 +178,6 @@ M: interactor stream-read-quot
]
} cond ;
-M: interactor pref-dim*
- [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
- vmax ;
-
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }
{ T{ key-down f { C+ } "k" } clear-input }
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 49ce5203d3..4e2cb0b1e9 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -1,20 +1,21 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: inspector ui.tools.interactor ui.tools.inspector
-ui.tools.workspace help.markup io io.styles
-kernel models namespaces parser quotations sequences ui.commands
+USING: inspector help help.markup io io.styles
+kernel models namespaces parser quotations sequences vocabs words
+prettyprint listener debugger threads boxes concurrency.flags
+math arrays generic accessors combinators assocs fry ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.operations vocabs words
-prettyprint listener debugger threads boxes concurrency.flags
-math arrays generic accessors combinators assocs ;
+ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
+ui.tools.browser ui.tools.interactor ui.tools.inspector
+ui.tools.workspace ;
IN: ui.tools.listener
-TUPLE: listener-gadget < track input output stack ;
+TUPLE: listener-gadget < track input output ;
: listener-output, ( listener -- listener )
- <scrolling-pane> >>output
- dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
+ <scrolling-pane>
+ [ >>output ] [ <scroller> 1 track-add ] bi ;
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
@@ -23,17 +24,13 @@ TUPLE: listener-gadget < track input output stack ;
output>> <pane-stream> <interactor> ;
: listener-input, ( listener -- listener )
- dup <listener-input> >>input
- dup input>>
- <limited-scroller>
- { 0 100 } >>min-dim
- { 1/0. 100 } >>max-dim
- "Input" <labelled-gadget>
- f track-add ;
+ dup <listener-input>
+ [ >>input ] [ 1 <border> { 0 0 } >>align f track-add ] bi ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
- "handbook" ($link) "." print nl ;
+ "handbook" ($link) ". To see a list of keyboard shortcuts," print
+ "press F1." print nl ;
M: listener-gadget focusable-child*
input>> ;
@@ -60,7 +57,7 @@ M: listener-gadget tool-scroller
: call-listener ( quot -- )
[ workspace-busy? not ] get-workspace* listener>>
- [ dup wait-for-listener (call-listener) ] 2curry
+ '[ _ _ dup wait-for-listener (call-listener) ]
"Listener call" spawn drop ;
M: listener-command invoke-command ( target command -- )
@@ -76,7 +73,7 @@ M: listener-operation invoke-command ( target command -- )
: listener-run-files ( seq -- )
[
- [ [ run-file ] each ] curry call-listener
+ '[ _ [ run-file ] each ] call-listener
] unless-empty ;
: com-end ( listener -- )
@@ -122,20 +119,8 @@ M: engine-word word-completion-string
[ select-all ]
2bi ;
-TUPLE: stack-display < track ;
-
-: <stack-display> ( workspace -- gadget )
- listener>>
- { 0 1 } stack-display new-track
- over <toolbar> f track-add
- swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
- 1 track-add ;
-
-M: stack-display tool-scroller
- find-workspace listener>> tool-scroller ;
-
-: ui-listener-hook ( listener -- )
- >r datastack r> stack>> set-model ;
+: ui-help-hook ( topic -- )
+ browser-gadget call-tool ;
: ui-error-hook ( error listener -- )
find-workspace debugger-popup ;
@@ -146,17 +131,20 @@ M: stack-display tool-scroller
: listener-thread ( listener -- )
dup listener-streams [
- [ [ ui-listener-hook ] curry listener-hook set ]
- [ [ ui-error-hook ] curry error-hook set ]
- [ [ ui-inspector-hook ] curry inspector-hook set ] tri
+ [ ui-help-hook ] help-hook set
+ [ '[ _ ui-error-hook ] error-hook set ]
+ [ '[ _ ui-inspector-hook ] inspector-hook set ] bi
welcome.
listener
] with-streams* ;
: start-listener-thread ( listener -- )
- [
- [ input>> register-self ] [ listener-thread ] bi
- ] curry "Listener" spawn drop ;
+ '[
+ _
+ [ input>> register-self ]
+ [ listener-thread ]
+ bi
+ ] "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
@@ -168,12 +156,9 @@ M: stack-display tool-scroller
[ wait-for-listener ]
} cleave ;
-: init-listener ( listener -- )
- f <model> >>stack drop ;
-
: <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track
- dup init-listener
+ add-toolbar
listener-output,
listener-input, ;
@@ -181,12 +166,21 @@ M: stack-display tool-scroller
\ listener-help H{ { +nullary+ t } } define-command
+: com-auto-use ( -- )
+ auto-use? [ not ] change ;
+
+\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
+
+listener-gadget "misc" "Miscellaneous commands" {
+ { T{ key-down f f "F1" } listener-help }
+} define-command-map
+
listener-gadget "toolbar" f {
{ f restart-listener }
- { T{ key-down f { A+ } "c" } clear-output }
- { T{ key-down f { A+ } "C" } clear-stack }
+ { T{ key-down f { A+ } "a" } com-auto-use }
+ { T{ key-down f { A+ } "c" } clear-output }
+ { T{ key-down f { A+ } "C" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
- { T{ key-down f f "F1" } listener-help }
} define-command-map
M: listener-gadget handle-gesture ( gesture gadget -- ? )
diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor
index f54e1e4041..6368737460 100644
--- a/basis/ui/tools/tools-docs.factor
+++ b/basis/ui/tools/tools-docs.factor
@@ -32,7 +32,7 @@ ARTICLE: "ui-listener" "UI listener"
{ $heading "Editing commands" }
"The text editing commands are standard; see " { $link "gadgets-editors" } "."
{ $heading "Implementation" }
-"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ;
+"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ;
ARTICLE: "ui-inspector" "UI inspector"
"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."
diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor
index aed4b9d675..3310a3e0a5 100644
--- a/basis/ui/tools/tools.factor
+++ b/basis/ui/tools/tools.factor
@@ -19,8 +19,7 @@ IN: ui.tools
<toggle-buttons> ;
: <workspace-book> ( workspace -- gadget )
- dup
- <stack-display>
+ <gadget>
<browser-gadget>
<inspector-gadget>
<profiler-gadget>
@@ -34,14 +33,14 @@ IN: ui.tools
dup <workspace-book> >>book
dup <workspace-tabs> f track-add
- dup book>> 1/5 track-add
- dup listener>> 4/5 track-add
- dup <toolbar> f track-add ;
+ dup book>> 0 track-add
+ dup listener>> 1 track-add
+ add-toolbar ;
: resize-workspace ( workspace -- )
- dup sizes>> over control-value zero? [
- 1/5 over set-second
- 4/5 swap set-third
+ dup sizes>> over control-value 0 = [
+ 0 over set-second
+ 1 swap set-third
] [
2/3 over set-second
1/3 swap set-third
@@ -55,13 +54,15 @@ M: workspace model-changed
[ workspace-window ] ui-hook set-global
-: com-listener ( workspace -- ) stack-display select-tool ;
+: select-tool ( workspace n -- ) swap book>> model>> set-model ;
-: com-browser ( workspace -- ) browser-gadget select-tool ;
+: com-listener ( workspace -- ) 0 select-tool ;
-: com-inspector ( workspace -- ) inspector-gadget select-tool ;
+: com-browser ( workspace -- ) 1 select-tool ;
-: com-profiler ( workspace -- ) profiler-gadget select-tool ;
+: com-inspector ( workspace -- ) 2 select-tool ;
+
+: com-profiler ( workspace -- ) 3 select-tool ;
workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }
From f24036834ef29ab7678c92b8afc357a7957adc0d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 22:13:24 -0600
Subject: [PATCH 067/126] Usability fix
---
basis/ui/tools/listener/listener.factor | 2 +-
basis/ui/tools/search/search.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 4e2cb0b1e9..250fc371c7 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -25,7 +25,7 @@ TUPLE: listener-gadget < track input output ;
: listener-input, ( listener -- listener )
dup <listener-input>
- [ >>input ] [ 1 <border> { 0 0 } >>align f track-add ] bi ;
+ [ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor
index 033aacc1b3..cf980cfc23 100644
--- a/basis/ui/tools/search/search.factor
+++ b/basis/ui/tools/search/search.factor
@@ -66,7 +66,7 @@ search-field H{
<search-field> >>field
seq limited? init-search-model
presenter over <search-list> >>list
- dup field>> 1 <border> { 0 0 } >>align f track-add
+ dup field>> 1 <border> { 1 1 } >>fill f track-add
dup list>> <scroller> 1 track-add
string over field>> set-editor-string
dup field>> end-of-document ;
From 17b2566017ddd378c57a6fc12a8becb54848836d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 22:13:32 -0600
Subject: [PATCH 068/126] Blinking cursor
---
basis/ui/gadgets/editors/editors.factor | 95 ++++++++++++++++---------
1 file changed, 61 insertions(+), 34 deletions(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index a1c4f3d04e..2ab39ada31 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -2,17 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents io kernel math models
namespaces make opengl opengl.gl sequences strings io.styles
-math.vectors sorting colors combinators assocs math.order
-ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
-math.geometry.rect ;
+math.vectors sorting colors combinators assocs math.order fry
+calendar alarms ui.clipboards ui.commands ui.gadgets
+ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
+ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
+ui.render ui.gestures math.geometry.rect ;
IN: ui.gadgets.editors
TUPLE: editor < gadget
font color caret-color selection-color
caret mark
-focused? ;
+focused? blink blink-alarm ;
: <loc> ( -- loc ) { 0 0 } <model> ;
@@ -64,14 +64,14 @@ M: editor ungraft*
caret>> set-model ;
: change-caret ( editor quot -- )
- over >r >r dup editor-caret* swap model>> r> call r>
+ [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi
set-caret ; inline
: mark>caret ( editor -- )
- dup editor-caret* swap mark>> set-model ;
+ [ editor-caret* ] [ mark>> ] bi set-model ;
: change-caret&mark ( editor quot -- )
- over >r change-caret r> mark>caret ; inline
+ [ change-caret ] [ drop mark>caret ] 2bi ; inline
: editor-line ( n editor -- str ) control-value nth ;
@@ -85,8 +85,8 @@ M: editor ungraft*
: point>loc ( point editor -- loc )
[
- >r first2 r> tuck y>line dup ,
- >r dup editor-font* r>
+ [ first2 ] dip tuck y>line dup ,
+ [ dup editor-font* ] dip
rot editor-line x>offset ,
] { } make ;
@@ -94,11 +94,35 @@ M: editor ungraft*
[ hand-rel ] keep point>loc ;
: click-loc ( editor model -- )
- >r clicked-loc r> set-model ;
+ [ clicked-loc ] dip set-model ;
-: focus-editor ( editor -- ) t >>focused? relayout-1 ;
+: blink-caret ( editor -- )
+ [ not ] change-blink relayout-1 ;
-: unfocus-editor ( editor -- ) f >>focused? relayout-1 ;
+: start-blinking ( editor -- )
+ t >>blink
+ dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ;
+
+: stop-blinking ( editor -- )
+ blink-alarm>> cancel-alarm ;
+
+: restart-blinking ( editor -- )
+ dup focused?>> [
+ [ stop-blinking ]
+ [ start-blinking ]
+ [ relayout-1 ]
+ tri
+ ] [ drop ] if ;
+
+: focus-editor ( editor -- )
+ dup start-blinking
+ t >>focused?
+ relayout-1 ;
+
+: unfocus-editor ( editor -- )
+ dup stop-blinking
+ f >>focused?
+ relayout-1 ;
: (offset>x) ( font col# str -- x )
swap head-slice string-width ;
@@ -106,7 +130,7 @@ M: editor ungraft*
: offset>x ( col# line# editor -- x )
[ editor-line ] keep editor-font* -rot (offset>x) ;
-: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
+: loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
: line>y ( lines# editor -- y )
line-height * ;
@@ -126,7 +150,7 @@ M: editor ungraft*
] [ drop ] if ;
: draw-caret ( -- )
- editor get focused?>> [
+ editor get [ focused?>> ] [ blink>> ] bi and [
editor get
[ caret-color>> gl-color ]
[
@@ -143,7 +167,7 @@ M: editor ungraft*
line-translation gl-translate ;
: draw-line ( editor str -- )
- >r font>> r> { 0 0 } draw-string ;
+ [ font>> ] dip { 0 0 } draw-string ;
: first-visible-line ( editor -- n )
clip get rect-loc second origin get second -
@@ -169,7 +193,7 @@ M: editor ungraft*
rot control-value <slice> ;
: with-editor-translation ( n quot -- )
- >r line-translation origin get v+ r> with-translation ;
+ [ line-translation origin get v+ ] dip with-translation ;
inline
: draw-lines ( -- )
@@ -199,7 +223,7 @@ M: editor ungraft*
editor get selection-start/end
over first [
2dup [
- >r 2dup r> draw-selected-line
+ [ 2dup ] dip draw-selected-line
1 translate-lines
] each-line 2drop
] with-editor-translation ;
@@ -217,7 +241,7 @@ M: editor pref-dim*
drop relayout ;
: caret/mark-changed ( model editor -- )
- nip [ relayout-1 ] [ scroll>caret ] bi ;
+ nip [ restart-blinking ] [ scroll>caret ] bi ;
M: editor model-changed
{
@@ -247,7 +271,9 @@ M: editor user-input*
M: editor gadget-text* editor-string % ;
: extend-selection ( editor -- )
- dup request-focus dup caret>> click-loc ;
+ dup request-focus
+ dup restart-blinking
+ dup caret>> click-loc ;
: mouse-elt ( -- element )
hand-click# get {
@@ -259,14 +285,15 @@ M: editor gadget-text* editor-string % ;
editor-mark* before? ;
: drag-selection-caret ( loc editor element -- loc )
- >r [ drag-direction? ] 2keep
- model>>
- r> prev/next-elt ? ;
+ [
+ [ drag-direction? ] 2keep model>>
+ ] dip prev/next-elt ? ;
: drag-selection-mark ( loc editor element -- loc )
- >r [ drag-direction? not ] 2keep
- nip dup editor-mark* swap model>>
- r> prev/next-elt ? ;
+ [
+ [ drag-direction? not ] keep
+ [ editor-mark* ] [ model>> ] bi
+ ] dip prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark )
dup clicked-loc swap mouse-elt
@@ -285,15 +312,16 @@ M: editor gadget-text* editor-string % ;
over gadget-selection? [
drop nip remove-selection
] [
- over >r >r dup editor-caret* swap model>>
- r> call r> model>> remove-doc-range
+ [ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
+ [ drop model>> ]
+ 2bi remove-doc-range
] if ; inline
: editor-delete ( editor elt -- )
- swap [ over >r rot next-elt r> swap ] delete/backspace ;
+ swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
: editor-backspace ( editor elt -- )
- swap [ over >r rot prev-elt r> ] delete/backspace ;
+ swap [ over [ rot prev-elt ] dip ] delete/backspace ;
: editor-select-prev ( editor elt -- )
swap [ rot prev-elt ] change-caret ;
@@ -311,9 +339,8 @@ M: editor gadget-text* editor-string % ;
tuck caret>> set-model mark>> set-model ;
: select-elt ( editor elt -- )
- over >r
- >r dup editor-caret* swap model>> r> prev/next-elt
- r> editor-select ;
+ [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
+ editor-select ;
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
From decdcbe120487fec050b2fe8de070c20a087734d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 22:14:35 -0600
Subject: [PATCH 069/126] Stop blinking in ungraft just in case
---
basis/ui/gadgets/editors/editors.factor | 37 +++++++++++++------------
1 file changed, 19 insertions(+), 18 deletions(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 2ab39ada31..ebe092aa10 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -45,6 +45,24 @@ focused? blink blink-alarm ;
dup deactivate-model
swap model>> remove-loc ;
+: blink-caret ( editor -- )
+ [ not ] change-blink relayout-1 ;
+
+: start-blinking ( editor -- )
+ t >>blink
+ dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ;
+
+: stop-blinking ( editor -- )
+ blink-alarm>> cancel-alarm ;
+
+: restart-blinking ( editor -- )
+ dup focused?>> [
+ [ stop-blinking ]
+ [ start-blinking ]
+ [ relayout-1 ]
+ tri
+ ] [ drop ] if ;
+
M: editor graft*
dup
dup caret>> activate-editor-model
@@ -52,6 +70,7 @@ M: editor graft*
M: editor ungraft*
dup
+ dup stop-blinking
dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ;
@@ -96,24 +115,6 @@ M: editor ungraft*
: click-loc ( editor model -- )
[ clicked-loc ] dip set-model ;
-: blink-caret ( editor -- )
- [ not ] change-blink relayout-1 ;
-
-: start-blinking ( editor -- )
- t >>blink
- dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ;
-
-: stop-blinking ( editor -- )
- blink-alarm>> cancel-alarm ;
-
-: restart-blinking ( editor -- )
- dup focused?>> [
- [ stop-blinking ]
- [ start-blinking ]
- [ relayout-1 ]
- tri
- ] [ drop ] if ;
-
: focus-editor ( editor -- )
dup start-blinking
t >>focused?
From 53646a076b21d2c03578d6e94689036b74915895 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 22:15:07 -0600
Subject: [PATCH 070/126] Set blink-alarm to f after we stop it
---
basis/ui/gadgets/editors/editors.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index ebe092aa10..e8b79bed72 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -53,7 +53,7 @@ focused? blink blink-alarm ;
dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ;
: stop-blinking ( editor -- )
- blink-alarm>> cancel-alarm ;
+ [ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
: restart-blinking ( editor -- )
dup focused?>> [
From 5911ad913f305d26bf6a4016052417b65719788e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 23:29:16 -0600
Subject: [PATCH 071/126] Make blink interval configurable
---
basis/ui/gadgets/editors/editors.factor | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index e8b79bed72..b5d30dd2d6 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -48,9 +48,13 @@ focused? blink blink-alarm ;
: blink-caret ( editor -- )
[ not ] change-blink relayout-1 ;
+SYMBOL: blink-interval
+
+750 milliseconds blink-interval set-global
+
: start-blinking ( editor -- )
t >>blink
- dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ;
+ dup '[ _ blink-caret ] blink-interval get every >>blink-alarm drop ;
: stop-blinking ( editor -- )
[ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
From 9d68d5882a9d746745115659301fee7688c3df5e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 20 Nov 2008 23:54:27 -0600
Subject: [PATCH 072/126] Fix circularity
---
basis/ui/gadgets/buttons/buttons.factor | 34 ++++++++++++-------------
basis/ui/gadgets/tracks/tracks.factor | 5 +---
2 files changed, 17 insertions(+), 22 deletions(-)
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index d74284cbd6..6b687f7e20 100644
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/basis/ui/gadgets/buttons/buttons.factor
@@ -2,10 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors
-classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
-ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
-ui.render math.geometry.rect locals alien.c-types ;
+classes.tuple locals alien.c-types fry opengl opengl.gl
+math.vectors ui.commands ui.gadgets ui.gadgets.borders
+ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
+ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render
+math.geometry.rect ;
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
@@ -27,7 +28,7 @@ TUPLE: button < border pressed? selected? quot ;
relayout-1 ;
: if-clicked ( button quot -- )
- >r dup button-update dup button-rollover? r> [ drop ] if ;
+ [ dup button-update dup button-rollover? ] dip [ drop ] if ;
: button-clicked ( button -- ) dup quot>> if-clicked ;
@@ -219,9 +220,8 @@ M: radio-control model-changed
over value>> = >>selected?
relayout-1 ;
-: <radio-controls> ( parent model assoc quot -- parent )
- #! quot has stack effect ( value model label -- )
- swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
+: <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
+ '[ _ swap _ call add-gadget ] assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
@@ -232,8 +232,7 @@ M: radio-control model-changed
: <radio-buttons> ( model assoc -- gadget )
<filled-pile>
- -rot
- [ <radio-button> ] <radio-controls>
+ spin [ <radio-button> ] <radio-controls>
{ 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget )
@@ -241,20 +240,19 @@ M: radio-control model-changed
: <toggle-buttons> ( model assoc -- gadget )
<shelf>
- -rot
- [ <toggle-button> ] <radio-controls> ;
+ spin [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot )
- [ invoke-command drop ] 2curry ;
+ '[ _ _ invoke-command drop ] ;
: <command-button> ( target gesture command -- button )
- [ command-string ] keep
- swapd
- command-button-quot
- <bevel-button> ;
+ [ command-string swap ] keep command-button-quot <bevel-button> ;
: <toolbar> ( target -- toolbar )
<shelf>
swap
"toolbar" over class command-map commands>> swap
- [ -rot <command-button> add-gadget ] curry assoc-each ;
+ '[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
+
+: add-toolbar ( track -- track )
+ dup <toolbar> f track-add ;
diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor
index dc176b5bf7..ddc7cf18fd 100644
--- a/basis/ui/gadgets/tracks/tracks.factor
+++ b/basis/ui/gadgets/tracks/tracks.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel namespaces fry
math math.vectors math.geometry.rect math.order
-sequences words ui.gadgets ui.gadgets.packs ui.gadgets.buttons ;
+sequences words ui.gadgets ui.gadgets.packs ;
IN: ui.gadgets.tracks
@@ -57,9 +57,6 @@ M: track pref-dim* ( gadget -- dim )
: track-add ( track gadget constraint -- track )
pick sizes>> push add-gadget ;
-: add-toolbar ( track -- track )
- dup <toolbar> f track-add ;
-
: track-remove ( track gadget -- track )
dupd dup [
[ swap children>> index ]
From 1addde156769f22131d0cc4ebf699c466fbdd43a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 00:18:25 -0600
Subject: [PATCH 073/126] If 'search' was called outside of the parser, note.
might be called, which would fail if no lexer was set
---
core/parser/parser-tests.factor | 2 ++
core/parser/parser.factor | 2 +-
2 files changed, 3 insertions(+), 1 deletion(-)
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index d2d407e147..f621cbb84a 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -496,3 +496,5 @@ DEFER: blah
[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
[ error>> error>> def>> \ blah eq? ] must-fail-with
+
+[ ] [ f lexer set f file set "Hello world" note. ] unit-test
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 414e9ea499..1728b471e2 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -25,7 +25,7 @@ t parser-notes set-global
: note. ( str -- )
parser-notes? [
file get [ path>> write ":" write ] when*
- lexer get line>> number>string write ": " write
+ lexer get [ line>> number>string write ": " write ] when*
"Note: " write dup print
] when drop ;
From 27503bf67f2af840d150c8f3e830d9759999daa9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 01:54:45 -0600
Subject: [PATCH 074/126] Faster /mod and /i primitives
---
vm/math.c | 43 ++++++++++++++++++++++++++++---------------
1 file changed, 28 insertions(+), 15 deletions(-)
diff --git a/vm/math.c b/vm/math.c
index c6b91bc8f7..6a0acf7180 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -33,18 +33,18 @@ void primitive_float_to_fixnum(void)
#define POP_FIXNUMS(x,y) \
F_FIXNUM y = untag_fixnum_fast(dpop()); \
- F_FIXNUM x = untag_fixnum_fast(dpop());
+ F_FIXNUM x = untag_fixnum_fast(dpeek());
void primitive_fixnum_add(void)
{
POP_FIXNUMS(x,y)
- box_signed_cell(x + y);
+ drepl(allot_integer(x + y));
}
void primitive_fixnum_subtract(void)
{
POP_FIXNUMS(x,y)
- box_signed_cell(x - y);
+ drepl(allot_integer(x - y));
}
/* Multiply two integers, and trap overflow.
@@ -54,20 +54,20 @@ void primitive_fixnum_multiply(void)
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
- dpush(tag_fixnum(0));
+ drepl(tag_fixnum(0));
else
{
F_FIXNUM prod = x * y;
/* if this is not equal, we have overflow */
if(prod / x == y)
- box_signed_cell(prod);
+ drepl(allot_integer(prod));
else
{
F_ARRAY *bx = fixnum_to_bignum(x);
REGISTER_BIGNUM(bx);
F_ARRAY *by = fixnum_to_bignum(y);
UNREGISTER_BIGNUM(bx);
- dpush(tag_bignum(bignum_multiply(bx,by)));
+ drepl(tag_bignum(bignum_multiply(bx,by)));
}
}
}
@@ -75,14 +75,27 @@ void primitive_fixnum_multiply(void)
void primitive_fixnum_divint(void)
{
POP_FIXNUMS(x,y)
- box_signed_cell(x / y);
+ F_FIXNUM result = x / y;
+ if(result == -FIXNUM_MIN)
+ drepl(allot_integer(-FIXNUM_MIN));
+ else
+ drepl(tag_fixnum(result));
}
void primitive_fixnum_divmod(void)
{
- POP_FIXNUMS(x,y)
- box_signed_cell(x / y);
- dpush(tag_fixnum(x % y));
+ F_FIXNUM y = get(ds);
+ F_FIXNUM x = get(ds - CELLS);
+ if(y == -1 && x == tag_fixnum(FIXNUM_MIN))
+ {
+ put(ds - CELLS,allot_integer(-FIXNUM_MIN));
+ put(ds,tag_fixnum(0));
+ }
+ else
+ {
+ put(ds - CELLS,tag_fixnum(x / y));
+ put(ds,x % y);
+ }
}
/*
@@ -96,15 +109,15 @@ void primitive_fixnum_shift(void)
if(x == 0 || y == 0)
{
- dpush(tag_fixnum(x));
+ drepl(tag_fixnum(x));
return;
}
else if(y < 0)
{
if(y <= -WORD_SIZE)
- dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
+ drepl(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
else
- dpush(tag_fixnum(x >> -y));
+ drepl(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
@@ -112,12 +125,12 @@ void primitive_fixnum_shift(void)
F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
{
- dpush(tag_fixnum(x << y));
+ drepl(tag_fixnum(x << y));
return;
}
}
- dpush(tag_bignum(bignum_arithmetic_shift(
+ drepl(tag_bignum(bignum_arithmetic_shift(
fixnum_to_bignum(x),y)));
}
From 79bffecc2ec2733a0a9745b096e2b941793428a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 01:54:56 -0600
Subject: [PATCH 075/126] Add type function for /mod
---
.../tree/propagation/known-words/known-words.factor | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 3b698e0001..f6e2bc0940 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -138,6 +138,12 @@ most-negative-fixnum most-positive-fixnum [a,b]
\ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
\ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
+{ /mod fixnum/mod } [
+ \ /i \ mod
+ [ "outputs" word-prop ] bi@
+ '[ _ _ 2bi ] "outputs" set-word-prop
+] each
+
\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
From ae4f9a2809dc9806c9c2cac5059ff34834fc0273 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 02:11:36 -0600
Subject: [PATCH 076/126] Add fixnum/mod-fast and fixnum/i-fast subprimitives
---
basis/cpu/ppc/bootstrap.factor | 18 +++++++++++++
basis/cpu/x86/bootstrap.factor | 25 ++++++++++++++++---
.../partial-dispatch/partial-dispatch.factor | 2 ++
core/bootstrap/primitives.factor | 2 ++
4 files changed, 43 insertions(+), 4 deletions(-)
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index aee0f3f4f3..efe55f9a22 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -335,6 +335,24 @@ big-endian on
7 ds-reg 0 STW
] f f f \ fixnum-mod define-sub-primitive
+[
+ 3 ds-reg 0 LWZ
+ ds-reg ds-reg 4 SUBI
+ 4 ds-reg 0 LWZ
+ 5 4 3 DIVW
+ 5 ds-reg 0 STW
+] f f f \ fixnum/i-fast define-sub-primitive
+
+[
+ 3 ds-reg 0 LWZ
+ 4 ds-reg -4 LWZ
+ 5 4 3 DIVW
+ 6 5 3 MULLW
+ 7 6 4 SUBF
+ 5 ds-reg -4 STW
+ 7 ds-reg 0 STW
+] f f f \ fixnum-/mod-fast define-sub-primitive
+
[
3 ds-reg 0 LWZ
3 3 1 SRAWI
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 1ee74a434b..2c54880788 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -305,16 +305,33 @@ big-endian off
ds-reg [] arg1 MOV ! push to stack
] f f f \ fixnum-shift-fast define-sub-primitive
-[
+: jit-fixnum-/mod
temp-reg ds-reg [] MOV ! load second parameter
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- div-arg ds-reg [] MOV ! load first parameter
+ div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter
mod-arg div-arg MOV ! make a copy
mod-arg bootstrap-cell-bits 1- SAR ! sign-extend
- temp-reg IDIV ! divide
+ temp-reg IDIV ; ! divide
+
+[
+ jit-fixnum-/mod
+ ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] mod-arg MOV ! push to stack
] f f f \ fixnum-mod define-sub-primitive
+[
+ jit-fixnum-/mod
+ ds-reg bootstrap-cell SUB ! adjust stack pointer
+ div-arg tag-bits get SHL ! tag it
+ ds-reg [] div-arg MOV ! push to stack
+] f f f \ fixnum/i-fast define-sub-primitive
+
+[
+ jit-fixnum-/mod
+ div-arg tag-bits get SHL ! tag it
+ ds-reg [] mod-arg MOV ! push to stack
+ ds-reg bootstrap-cell neg [+] div-arg MOV
+] f f f \ fixnum/mod-fast define-sub-primitive
+
[
arg0 ds-reg [] MOV ! load local number
fixnum>slot@ ! turn local number into offset
diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor
index 6874b79d2e..ddde4e1244 100644
--- a/basis/math/partial-dispatch/partial-dispatch.factor
+++ b/basis/math/partial-dispatch/partial-dispatch.factor
@@ -29,6 +29,8 @@ M: word integer-op-input-classes
{ fixnum- fixnum-fast }
{ fixnum* fixnum*fast }
{ fixnum-shift fixnum-shift-fast }
+ { fixnum/i fixnum/i-fast }
+ { fixnum/mod fixnum/mod-fast }
} at ;
: modular-variant ( op -- fast-op )
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 24faf81662..20113d0e25 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -341,6 +341,8 @@ tuple
{ "fixnum-bitnot" "math.private" }
{ "fixnum-mod" "math.private" }
{ "fixnum-shift-fast" "math.private" }
+ { "fixnum/i-fast" "math.private" }
+ { "fixnum/mod-fast" "math.private" }
{ "fixnum<" "math.private" }
{ "fixnum<=" "math.private" }
{ "fixnum>" "math.private" }
From 0255f83be2776e3f56e76cea6e8a12b449a076b4 Mon Sep 17 00:00:00 2001
From: prunedtree <mew@.(none)>
Date: Fri, 21 Nov 2008 17:16:16 +0900
Subject: [PATCH 077/126] Committer: prunedtree
notepad2 integration
---
basis/editors/notepad2/authors.txt | 1 +
basis/editors/notepad2/notepad2.factor | 16 ++++++++++++++++
basis/editors/notepad2/summary.txt | 1 +
basis/editors/notepad2/tags.txt | 1 +
4 files changed, 19 insertions(+)
create mode 100644 basis/editors/notepad2/authors.txt
create mode 100644 basis/editors/notepad2/notepad2.factor
create mode 100644 basis/editors/notepad2/summary.txt
create mode 100644 basis/editors/notepad2/tags.txt
diff --git a/basis/editors/notepad2/authors.txt b/basis/editors/notepad2/authors.txt
new file mode 100644
index 0000000000..7852139357
--- /dev/null
+++ b/basis/editors/notepad2/authors.txt
@@ -0,0 +1 @@
+Marc Fauconneau
diff --git a/basis/editors/notepad2/notepad2.factor b/basis/editors/notepad2/notepad2.factor
new file mode 100644
index 0000000000..4d333e45dd
--- /dev/null
+++ b/basis/editors/notepad2/notepad2.factor
@@ -0,0 +1,16 @@
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 make ;
+IN: editors.notepad2
+
+: notepad2-path ( -- str )
+ \ notepad2-path get-global [
+ program-files "C:\\Windows\\system32\\notepad.exe" append-path
+ ] unless* ;
+
+: notepad2 ( file line -- )
+ [
+ notepad2-path ,
+ "/g" , number>string , ,
+ ] { } make run-detached drop ;
+
+[ notepad2 ] edit-hook set-global
\ No newline at end of file
diff --git a/basis/editors/notepad2/summary.txt b/basis/editors/notepad2/summary.txt
new file mode 100644
index 0000000000..ab4a8ce377
--- /dev/null
+++ b/basis/editors/notepad2/summary.txt
@@ -0,0 +1 @@
+Notepad2 editor integration
diff --git a/basis/editors/notepad2/tags.txt b/basis/editors/notepad2/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/editors/notepad2/tags.txt
@@ -0,0 +1 @@
+unportable
From d5559d41320b743ca45d443026f185dc871c756c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 02:24:37 -0600
Subject: [PATCH 078/126] Add fixnum/mod and fixnum/i subprimitives on PowerPC
---
basis/cpu/ppc/bootstrap.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index efe55f9a22..014d2b31a0 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -351,7 +351,7 @@ big-endian on
7 6 4 SUBF
5 ds-reg -4 STW
7 ds-reg 0 STW
-] f f f \ fixnum-/mod-fast define-sub-primitive
+] f f f \ fixnum/mod-fast define-sub-primitive
[
3 ds-reg 0 LWZ
From af29312a9ee471a119ec5d675103331dbf916243 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 02:25:43 -0600
Subject: [PATCH 079/126] Fix parser tests
---
core/parser/parser-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index f621cbb84a..ca80533a2e 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting classes.tuple compiler.units debugger vocabs
-vocabs.loader accessors eval combinators ;
+vocabs.loader accessors eval combinators lexer ;
IN: parser.tests
[
From 9e0db58c0fce43b39620ed5b77fb2b49020482dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 02:26:08 -0600
Subject: [PATCH 080/126] Remove display-stack since its functionaly was merged
into the listener
---
extra/display-stack/display-stack.factor | 43 ------------------------
1 file changed, 43 deletions(-)
delete mode 100644 extra/display-stack/display-stack.factor
diff --git a/extra/display-stack/display-stack.factor b/extra/display-stack/display-stack.factor
deleted file mode 100644
index 98af43fec8..0000000000
--- a/extra/display-stack/display-stack.factor
+++ /dev/null
@@ -1,43 +0,0 @@
-
-USING: kernel namespaces sequences math
- listener io prettyprint sequences.lib bake bake.fry ;
-
-IN: display-stack
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: watched-variables
-
-: watch-var ( sym -- ) watched-variables get push ;
-
-: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
-
-: unwatch-var ( sym -- ) watched-variables get delete ;
-
-: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
-
-: print-watched-variables ( -- )
- watched-variables get length 0 >
- [
- "----------" print
- watched-variables get
- watched-variables get [ unparse ] map longest length 2 +
- '[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
- each
-
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: display-stack ( -- )
- V{ } clone watched-variables set
- [
- print-watched-variables
- "----------" print
- datastack [ . ] each
- "----------" print
- retainstack reverse [ . ] each
- ]
- listener-hook set ;
-
From 0b6916158de7415e948533bac958d48bbf1261f4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 03:36:37 -0600
Subject: [PATCH 081/126] Fix [ ] nsequence
---
basis/generalizations/generalizations-tests.factor | 2 ++
basis/generalizations/generalizations.factor | 7 +++++--
2 files changed, 7 insertions(+), 2 deletions(-)
diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor
index 75985c9368..1ebe528f35 100644
--- a/basis/generalizations/generalizations-tests.factor
+++ b/basis/generalizations/generalizations-tests.factor
@@ -36,3 +36,5 @@ IN: generalizations.tests
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test
+
+[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index 069d59cee1..c63c2b66ca 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -6,8 +6,11 @@ math.ranges combinators macros quotations fry arrays ;
IN: generalizations
MACRO: nsequence ( n seq -- quot )
- [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
- [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ;
+ [
+ [ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
+ [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
+ ] keep
+ '[ @ _ like ] ;
MACRO: narray ( n -- quot )
'[ _ { } nsequence ] ;
From 23550ebe16d3c9c67532f613e919edc153058f17 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 04:00:28 -0600
Subject: [PATCH 082/126] Clean up combinators.short-circuit
---
.../short-circuit/short-circuit.factor | 53 +++++++++----------
1 file changed, 24 insertions(+), 29 deletions(-)
diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor
index 7b6c1d126d..e6a4bfe913 100644
--- a/basis/combinators/short-circuit/short-circuit.factor
+++ b/basis/combinators/short-circuit/short-circuit.factor
@@ -1,35 +1,30 @@
-
USING: kernel combinators quotations arrays sequences assocs
- locals generalizations macros fry ;
-
+locals generalizations macros fry ;
IN: combinators.short-circuit
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+MACRO:: n&& ( quots n -- quot )
+ [let | pairs [
+ quots [| q | { [ drop n ndup q dup not ] [ drop n ndrop f ] } ] map
+ { [ t ] [ n nnip ] } suffix
+ ] |
+ [ f pairs cond ]
+ ] ;
-:: n&&-rewrite ( quots N -- quot )
- quots
- [ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
- map
- [ t ] [ N nnip ] 2array suffix
- '[ f _ cond ] ;
+MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
+MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
+MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
+MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
-MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
-MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
-MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
-MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
+MACRO:: n|| ( quots n -- quot )
+ [let | pairs [
+ quots
+ [| q | { [ drop n ndup q dup ] [ n nnip ] } ] map
+ { [ drop n ndrop t ] [ f ] } suffix
+ ] |
+ [ f pairs cond ]
+ ] ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: n||-rewrite ( quots N -- quot )
- quots
- [ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
- map
- [ drop N ndrop t ] [ f ] 2array suffix
- '[ f _ cond ] ;
-
-MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
-MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
-MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
-MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
+MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
+MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
+MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
From c678e6e362257a49257f31166b3bc75c26d3ecec Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 04:00:37 -0600
Subject: [PATCH 083/126] Don't use combinators.short-circuit in compiler
---
basis/compiler/tree/propagation/info/info.factor | 15 ++++++++-------
1 file changed, 8 insertions(+), 7 deletions(-)
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index e89a9c6211..771d3800df 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals
-namespaces sequences words combinators combinators.short-circuit
+namespaces sequences words combinators
arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
@@ -253,12 +253,13 @@ DEFER: (value-info-union)
{ [ over not ] [ 2drop f ] }
[
{
- [ [ class>> ] bi@ class<= ]
- [ [ interval>> ] bi@ interval-subset? ]
- [ literals<= ]
- [ [ length>> ] bi@ value-info<= ]
- [ [ slots>> ] bi@ [ value-info<= ] 2all? ]
- } 2&&
+ { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
+ { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
+ { [ 2dup literals<= not ] [ f ] }
+ { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
+ { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
+ [ t ]
+ } cond 2nip
]
} cond ;
From 34b8bcf3050d92ee4acc5cbe33283ad247ec78fa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 04:36:18 -0600
Subject: [PATCH 084/126] Clean up short-circuit combinators
---
.../short-circuit/short-circuit-docs.factor | 14 ++++++------
.../short-circuit/short-circuit.factor | 22 ++++++++-----------
.../short-circuit/smart/smart.factor | 8 +++----
3 files changed, 19 insertions(+), 25 deletions(-)
diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor
index 54fc3aac43..b1e4a6cf21 100644
--- a/basis/combinators/short-circuit/short-circuit-docs.factor
+++ b/basis/combinators/short-circuit/short-circuit-docs.factor
@@ -52,17 +52,17 @@ HELP: 3||
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
-HELP: n&&-rewrite
+HELP: n&&
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
-{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
+{ $description "A macro that reqrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
-HELP: n||-rewrite
+HELP: n||
{ $values
- { "quots" "a sequence of quotations" } { "N" integer }
+ { "quots" "a sequence of quotations" } { "n" integer }
{ "quot" quotation } }
-{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
+{ $description "A macro that reqrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
@@ -77,8 +77,8 @@ ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
{ $subsection 2|| }
{ $subsection 3|| }
"Generalized combinators:"
-{ $subsection n&&-rewrite }
-{ $subsection n||-rewrite }
+{ $subsection n&& }
+{ $subsection n|| }
;
ABOUT: "combinators.short-circuit"
diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor
index e6a4bfe913..2b4e522789 100644
--- a/basis/combinators/short-circuit/short-circuit.factor
+++ b/basis/combinators/short-circuit/short-circuit.factor
@@ -3,12 +3,10 @@ locals generalizations macros fry ;
IN: combinators.short-circuit
MACRO:: n&& ( quots n -- quot )
- [let | pairs [
- quots [| q | { [ drop n ndup q dup not ] [ drop n ndrop f ] } ] map
- { [ t ] [ n nnip ] } suffix
- ] |
- [ f pairs cond ]
- ] ;
+ [ f ]
+ quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
+ [ n nnip ] suffix 1array
+ [ cond ] 3append ;
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
@@ -16,13 +14,11 @@ MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
MACRO:: n|| ( quots n -- quot )
- [let | pairs [
- quots
- [| q | { [ drop n ndup q dup ] [ n nnip ] } ] map
- { [ drop n ndrop t ] [ f ] } suffix
- ] |
- [ f pairs cond ]
- ] ;
+ [ f ]
+ quots
+ [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
+ { [ drop n ndrop t ] [ f ] } suffix 1array
+ [ cond ] 3append ;
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
diff --git a/basis/combinators/short-circuit/smart/smart.factor b/basis/combinators/short-circuit/smart/smart.factor
index ca659cacbe..b80e7294d1 100644
--- a/basis/combinators/short-circuit/smart/smart.factor
+++ b/basis/combinators/short-circuit/smart/smart.factor
@@ -1,7 +1,5 @@
-
USING: kernel sequences math stack-checker effects accessors macros
- combinators.short-circuit ;
-
+fry combinators.short-circuit ;
IN: combinators.short-circuit.smart
<PRIVATE
@@ -13,6 +11,6 @@ IN: combinators.short-circuit.smart
PRIVATE>
-MACRO: && ( quots -- quot ) dup arity n&&-rewrite ;
+MACRO: && ( quots -- quot ) dup arity '[ _ _ n&& ] ;
-MACRO: || ( quots -- quot ) dup arity n||-rewrite ;
+MACRO: || ( quots -- quot ) dup arity '[ _ _ n|| ] ;
From 883ad5389ca1e8246783f5e35331892a687877e9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 04:36:52 -0600
Subject: [PATCH 085/126] Don't throw if macro expansion fails; this allows
macros-in-locals to work in more cases
---
basis/macros/expander/expander.factor | 18 ++++++++++++------
1 file changed, 12 insertions(+), 6 deletions(-)
diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor
index 3666fa2423..cdd2b49d9c 100644
--- a/basis/macros/expander/expander.factor
+++ b/basis/macros/expander/expander.factor
@@ -37,9 +37,17 @@ M: wrapper expand-macros* wrapped>> literal ;
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;
-: expand-macro ( quot -- )
- stack [ swap with-datastack >vector ] change
- stack get pop >quotation end (expand-macros) ;
+: word, ( word -- ) end , ;
+
+: expand-macro ( word quot -- )
+ '[
+ drop
+ stack [ _ with-datastack >vector ] change
+ stack get pop >quotation end (expand-macros)
+ ] [
+ drop
+ word,
+ ] recover ;
: expand-macro? ( word -- quot ? )
dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
@@ -47,11 +55,9 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get length <=
] [ 2drop f f ] if ;
-: word, ( word -- ) end , ;
-
M: word expand-macros*
dup expand-dispatch? [ drop expand-dispatch ] [
- dup expand-macro? [ nip expand-macro ] [
+ dup expand-macro? [ expand-macro ] [
drop word,
] if
] if ;
From 89440b2a2316f101c73f5462dd7f1e2c9f73dd1f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 04:37:17 -0600
Subject: [PATCH 086/126] curry and compose now check their inputs
---
core/bootstrap/primitives.factor | 19 +++++++++++++++++--
core/quotations/quotations-tests.factor | 2 +-
2 files changed, 18 insertions(+), 3 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 20113d0e25..65731dd1ad 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -303,7 +303,13 @@ tuple
[ f "inline" set-word-prop ]
[ make-flushable ]
[ ]
- [ tuple-layout [ <tuple-boa> ] curry ]
+ [
+ [
+ callable instance-check-quot %
+ tuple-layout ,
+ \ <tuple-boa> ,
+ ] [ ] make
+ ]
} cleave
(( obj quot -- curry )) define-declared
@@ -319,7 +325,16 @@ tuple
[ f "inline" set-word-prop ]
[ make-flushable ]
[ ]
- [ tuple-layout [ <tuple-boa> ] curry ]
+ [
+ [
+ \ >r ,
+ callable instance-check-quot %
+ \ r> ,
+ callable instance-check-quot %
+ tuple-layout ,
+ \ <tuple-boa> ,
+ ] [ ] make
+ ]
} cleave
(( quot1 quot2 -- compose )) define-declared
diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor
index d311dfad71..29e1304334 100644
--- a/core/quotations/quotations-tests.factor
+++ b/core/quotations/quotations-tests.factor
@@ -15,4 +15,4 @@ IN: quotations.tests
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
-! [ 1 \ + curry ] must-fail
+[ 1 \ + curry ] must-fail
From 3e29a31493b20a45a94804ce67bcd4015d7ab885 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 05:17:20 -0600
Subject: [PATCH 087/126] Residual fixes for curry/compose change
---
basis/prettyprint/backend/backend.factor | 23 ++--------------------
basis/prettyprint/prettyprint-tests.factor | 9 ---------
core/classes/tuple/tuple.factor | 2 +-
3 files changed, 3 insertions(+), 31 deletions(-)
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 2af0224e32..f1fd749666 100644
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -216,27 +216,8 @@ M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
-
-GENERIC: valid-callable? ( obj -- ? )
-
-M: object valid-callable? drop f ;
-
-M: quotation valid-callable? drop t ;
-
-M: curry valid-callable? quot>> valid-callable? ;
-
-M: compose valid-callable?
- [ first>> ] [ second>> ] bi [ valid-callable? ] both? ;
-
-M: curry pprint*
- dup valid-callable? [ pprint-object ] [
- "( invalid curry )" swap present-text
- ] if ;
-
-M: compose pprint*
- dup valid-callable? [ pprint-object ] [
- "( invalid compose )" swap present-text
- ] if ;
+M: curry pprint* pprint-object ;
+M: compose pprint* pprint-object ;
M: wrapper pprint*
dup wrapped>> word? [
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index 7fa3c5a1a3..96698fc18f 100644
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -323,10 +323,6 @@ M: class-see-layout class-see-layout ;
[ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
-[ ] [ 1 \ + curry unparse drop ] unit-test
-
-[ ] [ 1 \ + compose unparse drop ] unit-test
-
GENERIC: generic-see-test-with-f ( obj -- obj )
M: f generic-see-test-with-f ;
@@ -365,8 +361,3 @@ M: started-out-hustlin' ended-up-ballin' ; inline
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
[ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
] unit-test
-
-[ "( invalid curry )" ] [ 1 2 curry unparse ] unit-test
-[ "( invalid curry )" ] [ 1 2 3 curry curry unparse ] unit-test
-[ "( invalid compose )" ] [ 1 2 compose unparse ] unit-test
-[ "( invalid compose )" ] [ [ 1 ] 2 3 curry compose unparse ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index a56a4df029..70b189852f 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -121,7 +121,7 @@ ERROR: bad-superclass class ;
[
\ dup ,
[ "predicate" word-prop % ]
- [ [ bad-slot-value ] curry , ] bi
+ [ [ literalize , \ bad-slot-value , ] [ ] make , ] bi
\ unless ,
] [ ] make ;
From 420ff0a447dba13efebbd798e8f352ea563b74ec Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 05:17:51 -0600
Subject: [PATCH 088/126] Fry now throws a parse time error if it detects >r r>
usage, tweak fry to better interact with locals
---
basis/fry/fry-docs.factor | 8 +++++-
basis/fry/fry-tests.factor | 16 ++++++------
basis/fry/fry.factor | 38 ++++++++++++++++-------------
core/combinators/combinators.factor | 5 +---
4 files changed, 37 insertions(+), 30 deletions(-)
diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor
index 8f402f2e8c..b5d1b8d8d2 100644
--- a/basis/fry/fry-docs.factor
+++ b/basis/fry/fry-docs.factor
@@ -19,6 +19,9 @@ HELP: '[
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ;
+HELP: >r/r>-in-fry-error
+{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ;
+
ARTICLE: "fry.examples" "Examples of fried quotations"
"The easiest way to understand fried quotations is to look at some examples."
$nl
@@ -73,7 +76,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
} ;
ARTICLE: "fry.limitations" "Fried quotation limitations"
-"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
+"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead."
+$nl
+"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":"
+{ $subsection >r/r>-in-fry-error } ;
ARTICLE: "fry" "Fried quotations"
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor
index d4a3b8b734..27d5430d33 100644
--- a/basis/fry/fry-tests.factor
+++ b/basis/fry/fry-tests.factor
@@ -1,23 +1,20 @@
IN: fry.tests
USING: fry tools.test math prettyprint kernel io arrays
-sequences ;
+sequences eval accessors ;
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
[ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
-[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
+[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
-[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
+[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
-[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
+[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
-[ [ "a" write "b" print ] ]
+[ [ "a" "b" [ write ] dip print ] ]
[ "a" "b" '[ _ write _ print ] ] unit-test
-[ [ 1 2 + 3 4 - ] ]
-[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
-
[ 1/2 ] [
1 '[ [ _ ] dip / ] 2 swap call
] unit-test
@@ -58,3 +55,6 @@ sequences ;
[ { { { 3 } } } ] [
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
+
+[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
+[ error>> >r/r>-in-fry-error? ] must-fail-with
diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
index 87c59e18a0..bab49de108 100644
--- a/basis/fry/fry.factor
+++ b/basis/fry/fry.factor
@@ -1,33 +1,37 @@
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting math
-quotations arrays make words ;
+quotations arrays make words locals.backend summary sets ;
IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ;
: @ ( -- * ) "Only valid inside a fry" throw ;
+ERROR: >r/r>-in-fry-error ;
+
<PRIVATE
-DEFER: (shallow-fry)
-DEFER: shallow-fry
+: [ncurry] ( n -- quot )
+ {
+ { 0 [ [ ] ] }
+ { 1 [ [ curry ] ] }
+ { 2 [ [ 2curry ] ] }
+ { 3 [ [ 3curry ] ] }
+ [ [ curry ] <repetition> ]
+ } case ;
-: ((shallow-fry)) ( accum quot adder -- result )
- >r shallow-fry r>
- append swap [
- [ prepose ] curry append
- ] unless-empty ; inline
+M: >r/r>-in-fry-error summary
+ drop
+ "Explicit retain stack manipulation is not permitted in fried quotations" ;
-: (shallow-fry) ( accum quot -- result )
- [ 1quotation ] [
- unclip {
- { \ _ [ [ curry ] ((shallow-fry)) ] }
- { \ @ [ [ compose ] ((shallow-fry)) ] }
- [ swap >r suffix r> (shallow-fry) ]
- } case
- ] if-empty ;
+: check-fry ( quot -- quot )
+ dup { >r r> load-locals get-local drop-locals } intersect
+ empty? [ >r/r>-in-fry-error ] unless ;
-: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
+: shallow-fry ( quot -- quot' )
+ check-fry
+ [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
+ { _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ;
PREDICATE: fry-specifier < word { _ @ } memq? ;
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 8cfa671a8b..82744276fd 100644
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -28,10 +28,7 @@ IN: combinators
! spread
: spread>quot ( seq -- quot )
- [ ] [
- [ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
- append
- ] reduce ;
+ [ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
: spread ( objs... seq -- )
spread>quot call ;
From 6324b4dd651999b8f115cb9953f3f9d9c8ea7cba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 05:18:41 -0600
Subject: [PATCH 089/126] Fix some bugs in locals, throw a parse time error if
usage of >r r> is detected
---
basis/locals/locals-docs.factor | 4 ++--
basis/locals/locals-tests.factor | 24 +++++++++++++++++++-
basis/locals/locals.factor | 38 +++++++++++++++++++++-----------
3 files changed, 50 insertions(+), 16 deletions(-)
diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor
index 35e0536530..18488ed1dd 100644
--- a/basis/locals/locals-docs.factor
+++ b/basis/locals/locals-docs.factor
@@ -132,8 +132,8 @@ $nl
"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
ARTICLE: "locals-limitations" "Limitations of locals"
-"The first limitation is that the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator."
-$nl
+"The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:"
+{ $subsection >r/r>-in-lambda-error }
"Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
{ $code
":: good-cond-usage ( a -- ... )"
diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index 04e077fc4f..60e40b9629 100644
--- a/basis/locals/locals-tests.factor
+++ b/basis/locals/locals-tests.factor
@@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
-definitions compiler.units ;
+definitions compiler.units fry ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@@ -286,6 +286,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ [ a b > ] [ 5 ] }
} cond ;
+\ cond-test must-infer
+
[ 3 ] [ 1 2 cond-test ] unit-test
[ 4 ] [ 2 2 cond-test ] unit-test
[ 5 ] [ 3 2 cond-test ] unit-test
@@ -293,6 +295,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
:: 0&&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
+\ 0&&-test must-infer
+
[ f ] [ 1.5 0&&-test ] unit-test
[ f ] [ 3 0&&-test ] unit-test
[ f ] [ 8 0&&-test ] unit-test
@@ -301,6 +305,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
:: &&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
+\ &&-test must-infer
+
[ f ] [ 1.5 &&-test ] unit-test
[ f ] [ 3 &&-test ] unit-test
[ f ] [ 8 &&-test ] unit-test
@@ -346,6 +352,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
+ERROR: punned-class x ;
+
+[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
+
:: literal-identity-test ( -- a b )
{ } V{ } ;
@@ -390,6 +400,18 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
+[
+ "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
+] [ error>> >r/r>-in-fry-error? ] must-fail-with
+
+:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
+: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
+
+\ funny-macro-test must-infer
+
+[ t ] [ 3 funny-macro-test ] unit-test
+[ f ] [ 2 funny-macro-test ] unit-test
+
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index 7de9d10436..1e205e10b0 100644
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -6,12 +6,18 @@ quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
-locals.backend memoize macros.expander lexer classes ;
+locals.backend memoize macros.expander lexer classes summary ;
IN: locals
! Inspired by
! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
+ERROR: >r/r>-in-lambda-error ;
+
+M: >r/r>-in-lambda-error summary
+ drop
+ "Explicit retain stack manipulation is not permitted in lambda bodies" ;
+
<PRIVATE
TUPLE: lambda vars body ;
@@ -141,20 +147,17 @@ GENERIC: free-vars* ( form -- )
: free-vars ( form -- vars )
[ free-vars* ] { } make prune ;
-: add-if-free ( object -- )
- {
- { [ dup local-writer? ] [ "local-reader" word-prop , ] }
- { [ dup lexical? ] [ , ] }
- { [ dup quote? ] [ local>> , ] }
- { [ t ] [ free-vars* ] }
- } cond ;
+M: local-writer free-vars* "local-reader" word-prop , ;
+
+M: lexical free-vars* , ;
+
+M: quote free-vars* , ;
M: object free-vars* drop ;
-M: quotation free-vars* [ add-if-free ] each ;
+M: quotation free-vars* [ free-vars* ] each ;
-M: lambda free-vars*
- [ vars>> ] [ body>> ] bi free-vars swap diff % ;
+M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
GENERIC: lambda-rewrite* ( obj -- )
@@ -201,6 +204,8 @@ M: special rewrite-literal? drop t ;
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
+M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
+
M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ;
@@ -215,17 +220,20 @@ GENERIC: rewrite-element ( obj -- )
[ rewrite-element ] each ;
: rewrite-sequence ( seq -- )
- [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
+ [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
+M: quotation rewrite-element
+ dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
+
M: vector rewrite-element rewrite-sequence ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element
- [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
+ [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
M: local rewrite-element , ;
@@ -243,6 +251,10 @@ M: tuple local-rewrite* rewrite-element ;
M: hashtable local-rewrite* rewrite-element ;
+M: word local-rewrite*
+ dup { >r r> } memq?
+ [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
+
M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
From 322d115d2e9f7eec2ff631e8dc4784540e8c1632 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 05:18:55 -0600
Subject: [PATCH 090/126] /mod didn't handle overflow correctly
---
vm/math.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/vm/math.c b/vm/math.c
index 6a0acf7180..07493a947f 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -86,7 +86,7 @@ void primitive_fixnum_divmod(void)
{
F_FIXNUM y = get(ds);
F_FIXNUM x = get(ds - CELLS);
- if(y == -1 && x == tag_fixnum(FIXNUM_MIN))
+ if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
{
put(ds - CELLS,allot_integer(-FIXNUM_MIN));
put(ds,tag_fixnum(0));
From 4886f6184b540855e550d1a9a7ddfcf832e4e065 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 05:47:47 -0600
Subject: [PATCH 091/126] Fix fry with > 3 holes
---
basis/fry/fry-tests.factor | 4 ++++
basis/fry/fry.factor | 2 +-
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor
index 27d5430d33..0137e8be22 100644
--- a/basis/fry/fry-tests.factor
+++ b/basis/fry/fry-tests.factor
@@ -58,3 +58,7 @@ sequences eval accessors ;
[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
+
+[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
+ 1 2 3 4 '[ "a" _ 2array "b" _ 2array "c" _ 2array "d" _ 2array 4array ] call
+] unit-test
diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
index bab49de108..ac036f58ad 100644
--- a/basis/fry/fry.factor
+++ b/basis/fry/fry.factor
@@ -17,7 +17,7 @@ ERROR: >r/r>-in-fry-error ;
{ 1 [ [ curry ] ] }
{ 2 [ [ 2curry ] ] }
{ 3 [ [ 3curry ] ] }
- [ [ curry ] <repetition> ]
+ [ \ curry <repetition> ]
} case ;
M: >r/r>-in-fry-error summary
From a87fb04098bcf26abe017c7274ca750cc921fc47 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 21 Nov 2008 07:12:35 -0600
Subject: [PATCH 092/126] combinators.short-circuit docs: Fix typo
---
basis/combinators/short-circuit/short-circuit-docs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor
index b1e4a6cf21..6cd18201fe 100644
--- a/basis/combinators/short-circuit/short-circuit-docs.factor
+++ b/basis/combinators/short-circuit/short-circuit-docs.factor
@@ -56,13 +56,13 @@ HELP: n&&
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
-{ $description "A macro that reqrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
HELP: n||
{ $values
{ "quots" "a sequence of quotations" } { "n" integer }
{ "quot" quotation } }
-{ $description "A macro that reqrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
From 4d7c6fe48b64a2a86b382d77089374f4c56ac3a0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 18:55:14 -0600
Subject: [PATCH 093/126] Make stack display configurable
---
basis/listener/listener.factor | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 5d58cafe29..7d8b72849b 100644
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -73,9 +73,15 @@ SYMBOL: error-hook
] tabular-output
] unless-empty ;
+SYMBOL: display-stacks?
+
+t display-stacks? set-global
+
: stacks. ( -- )
- datastack [ nl "--- Data stack:" title. stack. ] unless-empty
- retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ;
+ display-stacks? get [
+ datastack [ nl "--- Data stack:" title. stack. ] unless-empty
+ retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty
+ ] when ;
: prompt. ( -- )
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
From 985aca75babb390275a7caa555dcb2b66380e8db Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 18:55:24 -0600
Subject: [PATCH 094/126] Highlight rollover buttons when clicked
---
basis/ui/gadgets/buttons/buttons.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index 6b687f7e20..88d957f8cc 100644
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/basis/ui/gadgets/buttons/buttons.factor
@@ -71,6 +71,7 @@ M: button-paint draw-boundary
: roll-button-theme ( button -- button )
f black <solid> dup f <button-paint> >>boundary
+ f f pressed-gradient f <button-paint> >>interior
align-left ; inline
: <roll-button> ( label quot -- button )
From 2cbc9794603ea983ca5074520bbef60a1c9bd97e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 20:09:23 -0600
Subject: [PATCH 095/126] Bail out on line-endings workarounds now that we have
a better fix for that on Win64
---
basis/html/templates/fhtml/fhtml-tests.factor | 7 ++-----
extra/benchmark/regex-dna/regex-dna-tests.factor | 4 ++--
2 files changed, 4 insertions(+), 7 deletions(-)
diff --git a/basis/html/templates/fhtml/fhtml-tests.factor b/basis/html/templates/fhtml/fhtml-tests.factor
index d314a60124..6cebb55688 100644
--- a/basis/html/templates/fhtml/fhtml-tests.factor
+++ b/basis/html/templates/fhtml/fhtml-tests.factor
@@ -6,11 +6,8 @@ IN: html.templates.fhtml.tests
: test-template ( path -- ? )
"resource:basis/html/templates/fhtml/test/"
prepend
- [
- ".fhtml" append <fhtml> [ call-template ] with-string-writer
- <string-reader> lines
- ] keep
- ".html" append utf8 file-lines
+ [ ".fhtml" append <fhtml> [ call-template ] with-string-writer ]
+ [ ".html" append utf8 file-contents ] bi
[ . . ] [ = ] 2bi ;
[ t ] [ "example" test-template ] unit-test
diff --git a/extra/benchmark/regex-dna/regex-dna-tests.factor b/extra/benchmark/regex-dna/regex-dna-tests.factor
index 9f64d438c7..cdd83cb9af 100644
--- a/extra/benchmark/regex-dna/regex-dna-tests.factor
+++ b/extra/benchmark/regex-dna/regex-dna-tests.factor
@@ -4,7 +4,7 @@ IN: benchmark.regex-dna.tests
[ t ] [
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt"
- [ regex-dna ] with-string-writer <string-reader> lines
+ [ regex-dna ] with-string-writer
"resource:extra/benchmark/regex-dna/regex-dna-test-out.txt"
- ascii file-lines =
+ ascii file-contents =
] unit-test
From d504d6b8dea089e0b222eeb9d2d7aef834a9817a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 21:00:30 -0600
Subject: [PATCH 096/126] slice-errors now report the parameters to the slicing
operation
---
basis/debugger/debugger.factor | 5 ++---
core/sequences/sequences.factor | 2 +-
2 files changed, 3 insertions(+), 4 deletions(-)
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index ec93a01c19..0e7a56ee5f 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -206,9 +206,8 @@ M: no-cond summary
M: no-case summary
drop "Fall-through in case" ;
-M: slice-error error.
- "Cannot create slice because " write
- reason>> print ;
+M: slice-error summary
+ drop "Cannot create slice" ;
M: bounds-error summary drop "Sequence index out of bounds" ;
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 0fe47f0099..9afc7c6168 100644
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -190,7 +190,7 @@ TUPLE: slice
: collapse-slice ( m n slice -- m' n' seq )
[ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline
-ERROR: slice-error reason ;
+ERROR: slice-error from to seq reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when
From f2e8d4dda52409eb0d8f467d0edc9e78c5a374c7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 21:00:49 -0600
Subject: [PATCH 097/126] Add hide-all-vars word, document var watching wordS
---
basis/listener/listener-docs.factor | 24 +++++++++++++++++++++++-
basis/listener/listener.factor | 6 ++++--
2 files changed, 27 insertions(+), 3 deletions(-)
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index 8ef49ca0d9..ba3bb7275e 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -9,7 +9,29 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
{ $subsection hide-var }
"To add and remove multiple variables:"
{ $subsection show-vars }
-{ $subsection hide-vars } ;
+{ $subsection hide-vars }
+"Hiding all visible variables:"
+{ $subsection hide-all-vars } ;
+
+HELP: show-var
+{ $values { "var" "a variable name" } }
+{ $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ;
+
+HELP: show-vars
+{ $values { "seq" "a sequence of variable names" } }
+{ $description "Adds a sequence of variables to the watch list; their values will be printed by the listener after every expression." } ;
+
+HELP: hide-var
+{ $values { "var" "a variable name" } }
+{ $description "Removes a variable from the watch list." } ;
+
+HELP: hide-vars
+{ $values { "seq" "a sequence of variable names" } }
+{ $description "Removes a sequence of variables from the watch list." } ;
+
+HELP: hide-all-vars
+{ $values { "seq" "a sequence of variable names" } }
+{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 7d8b72849b..95ad264000 100644
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -42,14 +42,16 @@ PRIVATE>
SYMBOL: visible-vars
-: show-var ( sym -- ) visible-vars [ swap suffix ] change ;
+: show-var ( var -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
-: hide-var ( sym -- ) visible-vars [ remove ] change ;
+: hide-var ( var -- ) visible-vars [ remove ] change ;
: hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
+: hide-all-vars ( -- ) visible-vars off ;
+
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
From 70645e0d3a7d9f5ca88ace6a49aa9695610c0846 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sat, 22 Nov 2008 04:22:38 +0100
Subject: [PATCH 098/126] Emacs Factor listener: new help mode; better
run-factor/switch-to-factor behaviour.
---
misc/factor.el | 196 ++++++++++++++++++++++++++++++++++++++++---------
1 file changed, 162 insertions(+), 34 deletions(-)
diff --git a/misc/factor.el b/misc/factor.el
index 170da980be..351b0e97d1 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -35,6 +35,7 @@
(require 'font-lock)
(require 'comint)
+(require 'view)
;;; Customization:
@@ -64,6 +65,30 @@ value from the existing code in the buffer."
:type '(file :must-match t)
:group 'factor)
+(defcustom factor-use-doc-window t
+ "When on, use a separate window to display help information.
+Disable to see that information in the factor-listener comint
+window."
+ :type 'boolean
+ :group 'factor)
+
+(defcustom factor-listener-use-other-window t
+ "Use a window other than the current buffer's when switching to
+the factor-listener buffer."
+ :type 'boolean
+ :group 'factor)
+
+(defcustom factor-listener-window-allow-split t
+ "Allow window splitting when switching to the factor-listener
+buffer."
+ :type 'boolean
+ :group 'factor)
+
+(defcustom factor-help-always-ask t
+ "When enabled, always ask for confirmation in help prompts."
+ :type 'boolean
+ :group 'factor)
+
(defcustom factor-display-compilation-output t
"Display the REPL buffer before compiling files."
:type 'boolean
@@ -74,6 +99,11 @@ value from the existing code in the buffer."
:type 'hook
:group 'factor)
+(defcustom factor-help-mode-hook nil
+ "Hook run by `factor-help-mode'."
+ :type 'hook
+ :group 'factor)
+
(defgroup factor-faces nil
"Faces used in Factor mode"
:group 'factor
@@ -125,6 +155,10 @@ value from the existing code in the buffer."
"Face for parsing words."
:group 'factor-faces)
+(defface factor-font-lock-help-mode-headlines '((t (:bold t :weight bold)))
+ "Face for headlines in help buffers."
+ :group 'factor-faces)
+
;;; Factor mode font lock:
@@ -429,18 +463,6 @@ value from the existing code in the buffer."
(factor-send-region (search-backward ":")
(search-forward ";")))
-(defun factor-see ()
- (interactive)
- (comint-send-string "*factor*" "\\ ")
- (comint-send-string "*factor*" (thing-at-point 'sexp))
- (comint-send-string "*factor*" " see\n"))
-
-(defun factor-help ()
- (interactive)
- (comint-send-string "*factor*" "\\ ")
- (comint-send-string "*factor*" (thing-at-point 'sexp))
- (comint-send-string "*factor*" " help\n"))
-
(defun factor-edit ()
(interactive)
(comint-send-string "*factor*" "\\ ")
@@ -459,17 +481,6 @@ value from the existing code in the buffer."
(defvar factor-mode-map (make-sparse-keymap)
"Key map used by Factor mode.")
-(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
-(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
-(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
-(define-key factor-mode-map "\C-c\C-s" 'factor-see)
-(define-key factor-mode-map "\C-ce" 'factor-edit)
-(define-key factor-mode-map "\C-c\C-h" 'factor-help)
-(define-key factor-mode-map "\C-cc" 'comment-region)
-(define-key factor-mode-map [return] 'newline-and-indent)
-(define-key factor-mode-map [tab] 'indent-for-tab-command)
-
-
;; Factor mode:
@@ -494,23 +505,118 @@ value from the existing code in the buffer."
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
-;;; Factor listener mode
+;;; Factor listener mode:
;;;###autoload
-(define-derived-mode factor-listener-mode comint-mode "Factor Listener")
+(define-derived-mode factor-listener-mode comint-mode "Factor Listener"
+ "Major mode for interacting with an inferior Factor listener process.
+\\{factor-listener-mode-map}"
+ (set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
-(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+(defvar factor--listener-buffer nil
+ "The buffer in which the Factor listener is running.")
+
+(defun factor--listener-start-process ()
+ "Start an inferior Factor listener process, using
+`factor-binary' and `factor-image'."
+ (setq factor--listener-buffer
+ (apply 'make-comint "factor" (expand-file-name factor-binary) nil
+ `("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
+ (with-current-buffer factor--listener-buffer
+ (factor-listener-mode)))
+
+(defun factor--listener-process ()
+ (or (and (buffer-live-p factor--listener-buffer)
+ (get-buffer-process factor--listener-buffer))
+ (progn (factor--listener-start-process)
+ (factor--listener-process))))
;;;###autoload
-(defun run-factor ()
- "Start a factor listener inside emacs, or switch to it if it
-already exists."
+(defalias 'switch-to-factor 'run-factor)
+;;;###autoload
+(defun run-factor (&optional arg)
+ "Show the factor-listener buffer, starting the process if needed."
(interactive)
- (switch-to-buffer
- (make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil
- (concat "-i=" (expand-file-name factor-image))
- "-run=listener"))
- (factor-listener-mode))
+ (let ((buf (process-buffer (factor--listener-process)))
+ (pop-up-windows factor-listener-window-allow-split))
+ (if factor-listener-use-other-window
+ (pop-to-buffer buf)
+ (switch-to-buffer buf))))
+
+
+;;;; Factor help mode:
+
+(defvar factor-help-mode-map (make-sparse-keymap)
+ "Keymap for Factor help mode.")
+
+(defconst factor--help-headlines
+ (regexp-opt '("Parent topics:"
+ "Inputs and outputs"
+ "Word description"
+ "Generic word contract"
+ "Vocabulary"
+ "Definition")
+ t))
+
+(defconst factor--help-headlines-regexp (format "^%s" factor--help-headlines))
+
+(defconst factor--help-font-lock-keywords
+ `((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines)
+ ,@factor-font-lock-keywords))
+
+(defun factor-help-mode ()
+ "Major mode for displaying Factor help messages.
+\\{factor-help-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map factor-help-mode-map)
+ (setq mode-name "Factor Help")
+ (setq major-mode 'factor-help-mode)
+ (set (make-local-variable 'font-lock-defaults)
+ '(factor--help-font-lock-keywords t nil nil nil))
+ (set (make-local-variable 'comint-redirect-subvert-readonly) t)
+ (set (make-local-variable 'view-no-disable-on-exit) t)
+ (view-mode)
+ (setq view-exit-action
+ (lambda (buffer)
+ ;; Use `with-current-buffer' to make sure that `bury-buffer'
+ ;; also removes BUFFER from the selected window.
+ (with-current-buffer buffer
+ (bury-buffer))))
+ (run-mode-hooks 'factor-help-mode-hook))
+
+(defun factor--listener-help-buffer ()
+ (set-buffer (get-buffer-create "*factor-help*"))
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) (point-max)))
+ (factor-help-mode)
+ (current-buffer))
+
+(defvar factor--help-history nil)
+
+(defun factor--listener-show-help (&optional see)
+ (let* ((def (thing-at-point 'sexp))
+ (prompt (format "%s (%s): " (if see "See" "Help") def))
+ (ask (or (not (eq major-mode 'factor-mode))
+ (not def)
+ factor-help-always-ask))
+ (cmd (format "\\ %s %s"
+ (if ask (read-string prompt nil 'factor--help-history def) def)
+ (if see "see" "help")))
+ (hb (factor--listener-help-buffer))
+ (proc (factor--listener-process)))
+ (comint-redirect-send-command-to-process cmd hb proc nil)
+ (pop-to-buffer hb)))
+
+(defun factor-see ()
+ (interactive)
+ (factor--listener-show-help t))
+
+(defun factor-help ()
+ (interactive)
+ (factor--listener-show-help))
+
+
(defun factor-refresh-all ()
"Reload source files and documentation for all loaded
@@ -519,6 +625,28 @@ vocabularies which have been modified on disk."
(comint-send-string "*factor*" "refresh-all\n"))
+;;; Key bindings:
+(defmacro factor--define-key (key cmd)
+ `(progn
+ (define-key factor-mode-map [(control ?c) ,key] ,cmd)
+ (define-key factor-mode-map [(control ?c) (control ,key)] ,cmd)))
+
+(factor--define-key ?f 'factor-run-file)
+(factor--define-key ?r 'factor-send-region)
+(factor--define-key ?d 'factor-send-definition)
+(factor--define-key ?s 'factor-see)
+(factor--define-key ?e 'factor-edit)
+(factor--define-key ?z 'switch-to-factor)
+(factor--define-key ?c 'comment-region)
+
+(define-key factor-mode-map "\C-ch" 'factor-help)
+(define-key factor-mode-map "\C-m" 'newline-and-indent)
+(define-key factor-mode-map [tab] 'indent-for-tab-command)
+
+(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+
+
+
(provide 'factor)
;;; factor.el ends here
From e65368a1372d23a5f1decda8e6b49eb9fe4c5a43 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 22:03:14 -0600
Subject: [PATCH 099/126] UI event handling refactoring - A+ is now the command
key, and M+ is the option key, on mac - new send-gesture, propagate-gesture
words clean up gesture sending - always send user-input after key-down,
without checking if a gadget handled the key-down first
---
basis/ui/cocoa/views/views.factor | 20 ++++-----
basis/ui/gadgets/slots/slots.factor | 10 ++---
basis/ui/gadgets/worlds/worlds.factor | 14 ++++++
basis/ui/gestures/gestures-docs.factor | 6 +--
basis/ui/gestures/gestures.factor | 61 ++++++++++++--------------
basis/ui/tools/browser/browser.factor | 8 ++--
basis/ui/windows/windows.factor | 4 +-
basis/ui/x11/x11.factor | 10 +++--
8 files changed, 73 insertions(+), 60 deletions(-)
diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor
index c6942a8158..f72eab0862 100644
--- a/basis/ui/cocoa/views/views.factor
+++ b/basis/ui/cocoa/views/views.factor
@@ -18,8 +18,8 @@ IN: ui.cocoa.views
{
{ S+ HEX: 20000 }
{ C+ HEX: 40000 }
- { A+ HEX: 80000 }
- { M+ HEX: 100000 }
+ { A+ HEX: 100000 }
+ { M+ HEX: 80000 }
} ;
: key-codes
@@ -59,9 +59,8 @@ IN: ui.cocoa.views
: key-event>gesture ( event -- modifiers keycode action? )
dup event-modifiers swap key-code ;
-: send-key-event ( view event quot -- ? )
- >r key-event>gesture r> call swap window-focus
- send-gesture ; inline
+: send-key-event ( view gesture -- )
+ swap window-focus propagate-gesture ;
: send-user-input ( view string -- )
CF>string swap window-focus user-input ;
@@ -70,18 +69,19 @@ IN: ui.cocoa.views
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
: send-key-down-event ( view event -- )
- 2dup [ <key-down> ] send-key-event
- [ interpret-key-event ] [ 2drop ] if ;
+ [ key-event>gesture <key-down> send-key-event ]
+ [ interpret-key-event ]
+ 2bi ;
: send-key-up-event ( view event -- )
- [ <key-up> ] send-key-event drop ;
+ key-event>gesture <key-up> send-key-event ;
: mouse-event>gesture ( event -- modifiers button )
dup event-modifiers swap button ;
: send-button-down$ ( view event -- )
- [ mouse-event>gesture <button-down> ] 2keep
- mouse-location rot window send-button-down ;
+ [ mouse-event>gesture <button-down> ]
+ [ mouse-location rot window send-button-down ] 2bi ;
: send-button-up$ ( view event -- )
[ mouse-event>gesture <button-up> ] 2keep
diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor
index ff2220b60e..e04b288a5d 100644
--- a/basis/ui/gadgets/slots/slots.factor
+++ b/basis/ui/gadgets/slots/slots.factor
@@ -26,10 +26,10 @@ TUPLE: slot-editor < track ref text ;
GENERIC: finish-editing ( slot-editor ref -- )
M: key-ref finish-editing
- drop T{ update-object } swap send-gesture drop ;
+ drop T{ update-object } swap propagate-gesture ;
M: value-ref finish-editing
- drop T{ update-slot } swap send-gesture drop ;
+ drop T{ update-slot } swap propagate-gesture ;
: slot-editor-value ( slot-editor -- object )
text>> control-value parse-fresh ;
@@ -55,14 +55,14 @@ M: value-ref finish-editing
: delete ( slot-editor -- )
dup ref>> delete-ref
- T{ update-object } swap send-gesture drop ;
+ T{ update-object } swap propagate-gesture ;
\ delete H{
{ +description+ "Delete the slot and close the slot editor." }
} define-command
: close ( slot-editor -- )
- T{ update-slot } swap send-gesture drop ;
+ T{ update-slot } swap propagate-gesture ;
\ close H{
{ +description+ "Close the slot editor without saving changes." }
@@ -92,7 +92,7 @@ TUPLE: editable-slot < track printer ref ;
: <edit-button> ( -- gadget )
"..."
- [ T{ edit-slot } swap send-gesture drop ]
+ [ T{ edit-slot } swap propagate-gesture ]
<roll-button> ;
: display-slot ( gadget editable-slot -- )
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index e338d6d4f4..29c663e914 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -107,6 +107,20 @@ world H{
{ T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
} set-gestures
+PREDICATE: specific-button-up < button-up #>> ;
+
+PREDICATE: specific-button-down < button-down #>> ;
+
+: generalize-gesture ( gesture -- )
+ clone f >># button-gesture ;
+
+M: world handle-gesture ( gesture gadget -- ? )
+ {
+ { [ over specific-button-up? ] [ drop generalize-gesture t ] }
+ { [ over specific-button-down? ] [ drop generalize-gesture t ] }
+ [ call-next-method ]
+ } cond ;
+
: close-global ( world global -- )
dup get-global find-world rot eq?
[ f swap set-global ] [ drop ] if ;
diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index 3471bd2cdb..69425cca0f 100644
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@@ -15,11 +15,11 @@ $nl
"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." }
{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
-{ send-gesture handle-gesture set-gestures } related-words
+{ propagate-gesture handle-gesture set-gestures } related-words
-HELP: send-gesture
+HELP: propagate-gesture
{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
+{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
HELP: user-input
{ $values { "str" string } { "gadget" gadget } }
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 2a29d32055..63ecbc2a80 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math models namespaces
make sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets boxes calendar
-alarms symbols combinators sets columns ;
+math.vectors classes.tuple classes boxes calendar
+alarms symbols combinators sets columns fry ui.gadgets ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
@@ -15,13 +15,17 @@ M: object handle-gesture
[ "gestures" word-prop ] map
assoc-stack dup [ call f ] [ 2drop t ] if ;
-: send-gesture ( gesture gadget -- ? )
- [ dupd handle-gesture ] each-parent nip ;
+: send-gesture ( gesture gadget -- )
+ handle-gesture drop ;
+
+: each-gesture ( gesture seq -- )
+ [ send-gesture ] with each ;
+
+: propagate-gesture ( gesture gadget -- )
+ [ handle-gesture ] with each-parent drop ;
: user-input ( str gadget -- )
- over empty?
- [ [ dupd user-input* ] each-parent ] unless
- 2drop ;
+ '[ _ [ user-input* ] with each-parent drop ] unless-empty ;
! Gesture objects
TUPLE: motion ; C: <motion> motion
@@ -46,11 +50,8 @@ TUPLE: right-action ; C: <right-action> right-action
TUPLE: up-action ; C: <up-action> up-action
TUPLE: down-action ; C: <down-action> down-action
-TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
-TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
-
-: generalize-gesture ( gesture -- newgesture )
- clone f >># ;
+TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
! Modifiers
SYMBOLS: C+ A+ M+ S+ ;
@@ -58,7 +59,7 @@ SYMBOLS: C+ A+ M+ S+ ;
TUPLE: key-down mods sym ;
: <key-gesture> ( mods sym action? class -- mods' sym' )
- >r [ S+ rot remove swap ] unless r> boa ; inline
+ [ [ S+ rot remove swap ] unless ] dip boa ; inline
: <key-down> ( mods sym action? -- key-down )
key-down <key-gesture> ;
@@ -100,11 +101,7 @@ SYMBOL: double-click-timeout
hand-loc get hand-click-loc get = not ;
: button-gesture ( gesture -- )
- hand-clicked get-global 2dup send-gesture [
- >r generalize-gesture r> send-gesture drop
- ] [
- 2drop
- ] if ;
+ hand-clicked get-global propagate-gesture ;
: drag-gesture ( -- )
hand-buttons get-global
@@ -130,14 +127,11 @@ SYMBOL: drag-timer
: fire-motion ( -- )
hand-buttons get-global empty? [
- T{ motion } hand-gadget get-global send-gesture drop
+ T{ motion } hand-gadget get-global propagate-gesture
] [
drag-gesture
] if ;
-: each-gesture ( gesture seq -- )
- [ handle-gesture drop ] with each ;
-
: hand-gestures ( new old -- )
drop-prefix <reversed>
T{ mouse-leave } swap each-gesture
@@ -145,15 +139,15 @@ SYMBOL: drag-timer
: forget-rollover ( -- )
f hand-world set-global
- hand-gadget get-global >r
- f hand-gadget set-global
- f r> parents hand-gestures ;
+ hand-gadget get-global
+ [ f hand-gadget set-global f ] dip
+ parents hand-gestures ;
: send-lose-focus ( gadget -- )
- T{ lose-focus } swap handle-gesture drop ;
+ T{ lose-focus } swap send-gesture ;
: send-gain-focus ( gadget -- )
- T{ gain-focus } swap handle-gesture drop ;
+ T{ gain-focus } swap send-gesture ;
: focus-child ( child gadget ? -- )
[
@@ -219,9 +213,11 @@ SYMBOL: drag-timer
: move-hand ( loc world -- )
dup hand-world set-global
- under-hand >r over hand-loc set-global
- pick-up hand-gadget set-global
- under-hand r> hand-gestures ;
+ under-hand [
+ over hand-loc set-global
+ pick-up hand-gadget set-global
+ under-hand
+ ] dip hand-gestures ;
: send-button-down ( gesture loc world -- )
move-hand
@@ -240,14 +236,13 @@ SYMBOL: drag-timer
: send-wheel ( direction loc world -- )
move-hand
scroll-direction set-global
- T{ mouse-scroll } hand-gadget get-global send-gesture
- drop ;
+ T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
: world-focus ( world -- gadget )
dup focus>> [ world-focus ] [ ] ?if ;
: send-action ( world gesture -- )
- swap world-focus send-gesture drop ;
+ swap world-focus propagate-gesture ;
GENERIC: gesture>string ( gesture -- string/f )
diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor
index b717bbb2f9..becb401fa6 100644
--- a/basis/ui/tools/browser/browser.factor
+++ b/basis/ui/tools/browser/browser.factor
@@ -67,10 +67,10 @@ M: browser-gadget definitions-changed ( assoc browser -- )
\ browser-help H{ { +nullary+ t } } define-command
browser-gadget "toolbar" f {
- { T{ key-down f { A+ } "b" } com-back }
- { T{ key-down f { A+ } "f" } com-forward }
- { T{ key-down f { A+ } "h" } com-documentation }
- { T{ key-down f { A+ } "v" } com-vocabularies }
+ { T{ key-down f { A+ } "LEFT" } com-back }
+ { T{ key-down f { A+ } "RIGHT" } com-forward }
+ { f com-documentation }
+ { f com-vocabularies }
{ T{ key-down f f "F1" } browser-help }
} define-command-map
diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor
index 3e600d2e3c..81cc0a0b70 100644
--- a/basis/ui/windows/windows.factor
+++ b/basis/ui/windows/windows.factor
@@ -194,7 +194,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
wParam exclude-key-wm-keydown? [
wParam keystroke>gesture <key-down>
- hWnd window-focus send-gesture drop
+ hWnd window-focus propagate-gesture
] unless ;
:: handle-wm-char ( hWnd uMsg wParam lParam -- )
@@ -205,7 +205,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
wParam keystroke>gesture <key-up>
- hWnd window-focus send-gesture drop ;
+ hWnd window-focus propagate-gesture ;
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
? hwnd window (>>active?)
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
index fd599635b1..04e47763a8 100644
--- a/basis/ui/x11/x11.factor
+++ b/basis/ui/x11/x11.factor
@@ -72,15 +72,19 @@ M: world configure-event
handle>> xic>> lookup-string
>r swap event-modifiers r> key-code <key-down> ;
+: valid-input? ( string -- ? )
+ [ f ] [ [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all? ] if-empty ;
+
M: world key-down-event
- [ key-down-event>gesture ] keep world-focus
- [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
+ [ key-down-event>gesture ] keep
+ world-focus [ propagate-gesture ] keep
+ over valid-input? [ user-input ] [ 2drop ] if ;
: key-up-event>gesture ( event -- gesture )
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event
- >r key-up-event>gesture r> world-focus send-gesture drop ;
+ >r key-up-event>gesture r> world-focus propagate-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
dup event-modifiers over XButtonEvent-button
From 96ba8f8b062bff48fc6462c35973c03418bd7c6e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 21 Nov 2008 22:10:58 -0600
Subject: [PATCH 100/126] add multipart stream, actual multipart parsing to
follow soon
---
basis/mime/multipart/authors.txt | 1 +
basis/mime/multipart/multipart-tests.factor | 248 ++++++++++++++++++++
basis/mime/multipart/multipart.factor | 68 ++++++
3 files changed, 317 insertions(+)
create mode 100644 basis/mime/multipart/authors.txt
create mode 100644 basis/mime/multipart/multipart-tests.factor
create mode 100644 basis/mime/multipart/multipart.factor
diff --git a/basis/mime/multipart/authors.txt b/basis/mime/multipart/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/mime/multipart/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/mime/multipart/multipart-tests.factor b/basis/mime/multipart/multipart-tests.factor
new file mode 100644
index 0000000000..e8a12eeea4
--- /dev/null
+++ b/basis/mime/multipart/multipart-tests.factor
@@ -0,0 +1,248 @@
+USING: accessors io io.streams.string kernel mime.multipart
+tools.test make multiline ;
+IN: mime.multipart.tests
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+
+[ { "a" "a" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "aa" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "aa" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "aa" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "aa" f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+
+
+[ { "a" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "zz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" "zz" } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "zzz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "az" "zb" "zz" "cz" "zd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "a" "zzb" "zzc" "zzd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "az" "zbzz" "czzd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+[ { "azz" "bzzcz" "zd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-step-loop drop
+ ] { } make
+] unit-test
+
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+
+[ { "a" "a" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "aa" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "aa" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "aa" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "aa" f f "b" f f "c" f f "d" f f } ] [
+ [
+ "aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+
+
+[ { "a" f "b" f "c" f "d" f } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "zz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" "zz" } ] [
+ [
+ "azzbzzczzdzz" <string-reader> "zzz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 1 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "az" "zb" "zz" "cz" "zd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 2 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "a" "zzb" "zzc" "zzd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 3 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "az" "zbzz" "czzd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 4 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
+
+[ { "azz" "bzzcz" "zd" f } ] [
+ [
+ "azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 5 >>n
+ [ , ] [ ] multipart-loop-all
+ ] { } make
+] unit-test
diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor
new file mode 100644
index 0000000000..433e89ed41
--- /dev/null
+++ b/basis/mime/multipart/multipart.factor
@@ -0,0 +1,68 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io kernel locals math multiline
+sequences splitting ;
+IN: mime.multipart
+
+TUPLE: multipart-stream stream n leftover separator ;
+
+: <multipart-stream> ( stream separator -- multipart-stream )
+ multipart-stream new
+ swap >>separator
+ swap >>stream
+ 16 2^ >>n ;
+
+<PRIVATE
+
+: ?append ( seq1 seq2 -- newseq/seq2 )
+ over [ append ] [ nip ] if ;
+
+: ?cut* ( seq n -- before after )
+ over length over <= [ drop f swap ] [ cut* ] if ;
+
+: read-n ( stream -- bytes end-stream? )
+ [ f ] change-leftover
+ [ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
+
+: multipart-split ( bytes separator -- before after ? empty? )
+ #! first boolean: return true if found
+ #! second boolean: true if sequence=
+ 2dup sequence= [
+ 2drop f f f t
+ ] [
+ split1 dup >boolean f
+ ] if ;
+
+PRIVATE>
+
+:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
+ #! return t to loop again
+ bytes separator multipart-split [
+ ! separator == input
+ 3drop f quot call f
+ ] [
+ [
+ ! found
+ [ [ quot call ] unless-empty ]
+ [
+ stream (>>leftover)
+ [ quot call ] unless-empty
+ ] if-empty f quot call f
+ ] [
+ ! not found
+ drop
+ end-stream? [
+ [ quot call ] unless-empty f
+ ] [
+ separator length 1- ?cut* stream (>>leftover)
+ [ quot call ] unless-empty t
+ ] if
+ ] if
+ ] if stream leftover>> end-stream? not or ;
+
+:: multipart-step-loop ( stream quot1: ( bytes -- ) quot2: ( -- ) -- ? )
+ stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
+ swap [ drop stream quot1 quot2 multipart-step-loop ] quot2 if ;
+
+: multipart-loop-all ( stream quot1: ( bytes -- ) quot2: ( -- ) -- )
+ 3dup multipart-step-loop [ multipart-loop-all ] [ 3drop ] if ;
From de7b002baf43b3b509167cef6f2c90a36d0264b9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 21 Nov 2008 22:13:14 -0600
Subject: [PATCH 101/126] use mime.types not mime-types
---
basis/http/server/static/static.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor
index 208273364c..0bc644d019 100644
--- a/basis/http/server/static/static.factor
+++ b/basis/http/server/static/static.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: calendar io io.files kernel math math.order
math.parser namespaces parser sequences strings
-assocs hashtables debugger mime-types sorting logging
+assocs hashtables debugger mime.types sorting logging
calendar.format accessors splitting
io.encodings.binary fry xml.entities destructors urls
html.elements html.templates.fhtml
From 3909c42962baf269781d053d4848200f29d3bd6c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 21 Nov 2008 22:31:05 -0600
Subject: [PATCH 102/126] clean up teh newb code
---
basis/mime/multipart/multipart.factor | 20 +++++++-------------
1 file changed, 7 insertions(+), 13 deletions(-)
diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor
index 433e89ed41..5e9949c70c 100644
--- a/basis/mime/multipart/multipart.factor
+++ b/basis/mime/multipart/multipart.factor
@@ -24,38 +24,32 @@ TUPLE: multipart-stream stream n leftover separator ;
[ f ] change-leftover
[ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
-: multipart-split ( bytes separator -- before after ? empty? )
- #! first boolean: return true if found
- #! second boolean: true if sequence=
- 2dup sequence= [
- 2drop f f f t
- ] [
- split1 dup >boolean f
- ] if ;
+: multipart-split ( bytes separator -- before after seq=? )
+ 2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
PRIVATE>
:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
#! return t to loop again
- bytes separator multipart-split [
+ bytes separator multipart-split [ dup >boolean ] dip [
! separator == input
3drop f quot call f
] [
[
! found
- [ [ quot call ] unless-empty ]
+ [ quot unless-empty ]
[
stream (>>leftover)
- [ quot call ] unless-empty
+ quot unless-empty
] if-empty f quot call f
] [
! not found
drop
end-stream? [
- [ quot call ] unless-empty f
+ quot unless-empty f
] [
separator length 1- ?cut* stream (>>leftover)
- [ quot call ] unless-empty t
+ quot unless-empty t
] if
] if
] if stream leftover>> end-stream? not or ;
From fb918ab7567ad251547f2d40ecbc0931ffbe0b2a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 23:01:20 -0600
Subject: [PATCH 103/126] The event loop thread now adds events to a queue
slurped by the UI update thread instead of handling them directly. This fixes
a race condition where a gadget could end up handling an event before it was
grafted or laid out
---
basis/ui/cocoa/cocoa.factor | 4 +-
basis/ui/cocoa/views/views.factor | 55 +++++++++-----------
basis/ui/gadgets/editors/editors.factor | 2 +-
basis/ui/gadgets/gadgets.factor | 8 ++-
basis/ui/gadgets/panes/panes-tests.factor | 8 +--
basis/ui/gestures/gestures-docs.factor | 6 +--
basis/ui/gestures/gestures.factor | 41 +++++++++++----
basis/ui/tools/debugger/debugger-docs.factor | 2 +-
basis/ui/tools/interactor/interactor.factor | 2 +-
basis/ui/tools/listener/listener.factor | 42 ++++++++-------
basis/ui/ui-docs.factor | 5 --
basis/ui/ui.factor | 25 +++++----
basis/ui/windows/windows.factor | 8 ++-
basis/ui/x11/x11.factor | 2 +-
14 files changed, 112 insertions(+), 98 deletions(-)
diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor
index 1a05d23aa0..9ff3a59f71 100644
--- a/basis/ui/cocoa/cocoa.factor
+++ b/basis/ui/cocoa/cocoa.factor
@@ -15,9 +15,7 @@ C: <handle> handle
SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
- [
- [ NSApp [ do-event ] curry loop ui-wait ] ui-try
- ] with-autorelease-pool ;
+ [ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
TUPLE: pasteboard handle ;
diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor
index f72eab0862..82a31ad0d9 100644
--- a/basis/ui/cocoa/views/views.factor
+++ b/basis/ui/cocoa/views/views.factor
@@ -62,9 +62,6 @@ IN: ui.cocoa.views
: send-key-event ( view gesture -- )
swap window-focus propagate-gesture ;
-: send-user-input ( view string -- )
- CF>string swap window-focus user-input ;
-
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
@@ -138,83 +135,83 @@ CLASS: {
}
{ "mouseEntered:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "mouseExited:" "void" { "id" "SEL" "id" }
- [ [ 3drop forget-rollover ] ui-try ]
+ [ 3drop forget-rollover ]
}
{ "mouseMoved:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "mouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
+ [ nip send-mouse-moved ]
}
{ "mouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
+ [ nip send-button-down$ ]
}
{ "mouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
+ [ nip send-button-up$ ]
}
{ "rightMouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
+ [ nip send-button-down$ ]
}
{ "rightMouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
+ [ nip send-button-up$ ]
}
{ "otherMouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
+ [ nip send-button-down$ ]
}
{ "otherMouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
+ [ nip send-button-up$ ]
}
{ "scrollWheel:" "void" { "id" "SEL" "id" }
- [ [ nip send-wheel$ ] ui-try ]
+ [ nip send-wheel$ ]
}
{ "keyDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-key-down-event ] ui-try ]
+ [ nip send-key-down-event ]
}
{ "keyUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-key-up-event ] ui-try ]
+ [ nip send-key-up-event ]
}
{ "cut:" "id" { "id" "SEL" "id" }
- [ [ nip T{ cut-action } send-action$ ] ui-try ]
+ [ nip T{ cut-action } send-action$ ]
}
{ "copy:" "id" { "id" "SEL" "id" }
- [ [ nip T{ copy-action } send-action$ ] ui-try ]
+ [ nip T{ copy-action } send-action$ ]
}
{ "paste:" "id" { "id" "SEL" "id" }
- [ [ nip T{ paste-action } send-action$ ] ui-try ]
+ [ nip T{ paste-action } send-action$ ]
}
{ "delete:" "id" { "id" "SEL" "id" }
- [ [ nip T{ delete-action } send-action$ ] ui-try ]
+ [ nip T{ delete-action } send-action$ ]
}
{ "selectAll:" "id" { "id" "SEL" "id" }
- [ [ nip T{ select-all-action } send-action$ ] ui-try ]
+ [ nip T{ select-all-action } send-action$ ]
}
! Multi-touch gestures: this is undocumented.
@@ -290,7 +287,7 @@ CLASS: {
! Text input
{ "insertText:" "void" { "id" "SEL" "id" }
- [ [ nip send-user-input ] ui-try ]
+ [ nip CF>string swap window-focus user-input ]
}
{ "hasMarkedText" "char" { "id" "SEL" }
@@ -335,11 +332,11 @@ CLASS: {
! Initialization
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [
- [
- 2drop dup view-dim swap window (>>dim) yield
- ] ui-try
- ]
+ [ 2drop dup view-dim swap window (>>dim) yield ]
+}
+
+{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
+ [ 3drop ]
}
{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index b5d30dd2d6..3753e98a8a 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -356,7 +356,7 @@ M: editor gadget-text* editor-string % ;
[ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ;
-: insert-newline ( editor -- ) "\n" swap user-input ;
+: insert-newline ( editor -- ) "\n" swap user-input* ;
: delete-next-character ( editor -- )
T{ char-elt } editor-delete ;
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index a18571d472..7d33ec21fd 100644
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@ -10,11 +10,9 @@ SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
-TUPLE: gadget < rect
- pref-dim parent children orientation focus
- visible? root? clipped? layout-state graft-state graft-node
- interior boundary
- model ;
+TUPLE: gadget < rect pref-dim parent children orientation focus
+visible? root? clipped? layout-state graft-state graft-node
+interior boundary model ;
M: gadget equal? 2drop f ;
diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor
index 109c0a1461..8627f7fbfe 100644
--- a/basis/ui/gadgets/panes/panes-tests.factor
+++ b/basis/ui/gadgets/panes/panes-tests.factor
@@ -40,7 +40,7 @@ IN: ui.gadgets.panes.tests
[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
[ t ] [ [ \ = see ] test-gadget-text ] unit-test
-[ t ] [ [ \ = help ] test-gadget-text ] unit-test
+[ t ] [ [ \ = print-topic ] test-gadget-text ] unit-test
[ t ] [
[
@@ -84,16 +84,16 @@ ARTICLE: "test-article-1" "This is a test article"
[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
-[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-1" print-topic ] test-gadget-text ] unit-test
ARTICLE: "test-article-2" "This is a test article"
"Hello world, how are you today."
{ $table { "a" "b" } { "c" "d" } } ;
-[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-2" print-topic ] test-gadget-text ] unit-test
<pane> [ \ = see ] with-pane
-<pane> [ \ = help ] with-pane
+<pane> [ \ = print-topic ] with-pane
[ ] [
\ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index 69425cca0f..e94bcf6d93 100644
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@@ -22,7 +22,7 @@ HELP: propagate-gesture
{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
HELP: user-input
-{ $values { "str" string } { "gadget" gadget } }
+{ $values { "string" string } { "gadget" gadget } }
{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
HELP: motion
@@ -90,10 +90,6 @@ HELP: select-all-action
{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
{ $examples { $code "T{ select-all-action }" } } ;
-HELP: generalize-gesture
-{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
-{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
-
HELP: C+
{ $description "Control key modifier." } ;
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 63ecbc2a80..180447ff4f 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -3,11 +3,9 @@
USING: accessors arrays assocs kernel math models namespaces
make sequences words strings system hashtables math.parser
math.vectors classes.tuple classes boxes calendar
-alarms symbols combinators sets columns fry ui.gadgets ;
+alarms symbols combinators sets columns fry deques ui.gadgets ;
IN: ui.gestures
-: set-gestures ( class hash -- ) "gestures" set-word-prop ;
-
GENERIC: handle-gesture ( gesture gadget -- ? )
M: object handle-gesture
@@ -15,17 +13,42 @@ M: object handle-gesture
[ "gestures" word-prop ] map
assoc-stack dup [ call f ] [ 2drop t ] if ;
+: set-gestures ( class hash -- ) "gestures" set-word-prop ;
+
+: gesture-queue ( -- deque ) \ gesture-queue get ;
+
+GENERIC: send-queued-gesture ( request -- )
+
+TUPLE: send-gesture gesture gadget ;
+
+M: send-gesture send-queued-gesture
+ [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
+
+: queue-gesture ( ... class -- )
+ boa gesture-queue push-front notify-ui-thread ; inline
+
: send-gesture ( gesture gadget -- )
- handle-gesture drop ;
+ \ send-gesture queue-gesture ;
-: each-gesture ( gesture seq -- )
- [ send-gesture ] with each ;
+: each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
-: propagate-gesture ( gesture gadget -- )
+TUPLE: propagate-gesture gesture gadget ;
+
+M: propagate-gesture send-queued-gesture
+ [ gesture>> ] [ gadget>> ] bi
[ handle-gesture ] with each-parent drop ;
-: user-input ( str gadget -- )
- '[ _ [ user-input* ] with each-parent drop ] unless-empty ;
+: propagate-gesture ( gesture gadget -- )
+ \ propagate-gesture queue-gesture ;
+
+TUPLE: user-input string gadget ;
+
+M: user-input send-queued-gesture
+ [ string>> ] [ gadget>> ] bi
+ [ user-input* ] with each-parent drop ;
+
+: user-input ( string gadget -- )
+ '[ _ \ user-input queue-gesture ] unless-empty ;
! Gesture objects
TUPLE: motion ; C: <motion> motion
diff --git a/basis/ui/tools/debugger/debugger-docs.factor b/basis/ui/tools/debugger/debugger-docs.factor
index 12a2e0d806..94c118953d 100644
--- a/basis/ui/tools/debugger/debugger-docs.factor
+++ b/basis/ui/tools/debugger/debugger-docs.factor
@@ -8,7 +8,7 @@ HELP: <debugger>
"Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
} ;
-{ <debugger> debugger-window ui-try } related-words
+{ <debugger> debugger-window } related-words
HELP: debugger-window
{ $values { "error" "an error" } }
diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor
index 36ce67e57b..94aa878942 100644
--- a/basis/ui/tools/interactor/interactor.factor
+++ b/basis/ui/tools/interactor/interactor.factor
@@ -164,7 +164,7 @@ M: interactor dispose drop ;
: handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse {
{ [ dup quotation? ] [ nip t ] }
- { [ dup not ] [ drop "\n" swap user-input f f ] }
+ { [ dup not ] [ drop "\n" swap user-input* f f ] }
[ handle-parse-error f f ]
} cond ;
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 250fc371c7..bf62f5372d 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: inspector help help.markup io io.styles
-kernel models namespaces parser quotations sequences vocabs words
-prettyprint listener debugger threads boxes concurrency.flags
-math arrays generic accessors combinators assocs fry ui.commands
-ui.gadgets ui.gadgets.editors ui.gadgets.labelled
-ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
+USING: inspector help help.markup io io.styles kernel models
+namespaces parser quotations sequences vocabs words prettyprint
+listener debugger threads boxes concurrency.flags math arrays
+generic accessors combinators assocs fry ui.commands ui.gadgets
+ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
+ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.browser ui.tools.interactor ui.tools.inspector
ui.tools.workspace ;
@@ -13,20 +13,12 @@ IN: ui.tools.listener
TUPLE: listener-gadget < track input output ;
-: listener-output, ( listener -- listener )
- <scrolling-pane>
- [ >>output ] [ <scroller> 1 track-add ] bi ;
-
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
: <listener-input> ( listener -- gadget )
output>> <pane-stream> <interactor> ;
-: listener-input, ( listener -- listener )
- dup <listener-input>
- [ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
-
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
"handbook" ($link) ". To see a list of keyboard shortcuts," print
@@ -109,7 +101,7 @@ M: engine-word word-completion-string
: insert-word ( word -- )
get-workspace listener>> input>>
- [ >r word-completion-string r> user-input ]
+ [ >r word-completion-string r> user-input* ]
[ interactor-use use-if-necessary ]
2bi ;
@@ -156,11 +148,21 @@ M: engine-word word-completion-string
[ wait-for-listener ]
} cleave ;
+: init-listener ( listener -- listener )
+ <scrolling-pane> >>output
+ dup <listener-input> >>input ;
+
+: <listener-scroller> ( listener -- scroller )
+ <filled-pile>
+ over output>> add-gadget
+ swap input>> add-gadget
+ <scroller> ;
+
: <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track
add-toolbar
- listener-output,
- listener-input, ;
+ init-listener
+ dup <listener-scroller> 1 track-add ;
: listener-help ( -- ) "ui-listener" help-window ;
@@ -177,9 +179,9 @@ listener-gadget "misc" "Miscellaneous commands" {
listener-gadget "toolbar" f {
{ f restart-listener }
- { T{ key-down f { A+ } "a" } com-auto-use }
- { T{ key-down f { A+ } "c" } clear-output }
- { T{ key-down f { A+ } "C" } clear-stack }
+ { T{ key-down f { A+ } "u" } com-auto-use }
+ { T{ key-down f { A+ } "k" } clear-output }
+ { T{ key-down f { A+ } "K" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
} define-command-map
diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index c10205ed26..978bd24055 100644
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -47,11 +47,6 @@ HELP: (open-window)
{ $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
{ $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
-HELP: ui-try
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
-{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
-
ARTICLE: "ui-glossary" "UI glossary"
{ $table
{ "color specifier"
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index db0ac9a624..e05341f3fc 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make
prettyprint dlists deques sequences threads sequences words
@@ -87,6 +87,7 @@ SYMBOL: ui-hook
: init-ui ( -- )
<dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global
+ <dlist> \ gesture-queue set-global
V{ } clone windows set-global ;
: restore-gadget-later ( gadget -- )
@@ -138,14 +139,22 @@ SYMBOL: ui-hook
: notify-queued ( -- )
graft-queue [ notify ] slurp-deque ;
+: send-queued-gestures ( -- )
+ gesture-queue [ send-queued-gesture ] slurp-deque ;
+
: update-ui ( -- )
- [ notify-queued layout-queued redraw-worlds ] assert-depth ;
+ [
+ [
+ notify-queued
+ layout-queued
+ redraw-worlds
+ send-queued-gestures
+ ] assert-depth
+ ] [ ui-error ] recover ;
: ui-wait ( -- )
10 sleep ;
-: ui-try ( quot -- ) [ ui-error ] recover ;
-
SYMBOL: ui-thread
: ui-running ( quot -- )
@@ -156,11 +165,9 @@ SYMBOL: ui-thread
\ ui-running get-global ;
: update-ui-loop ( -- )
- ui-running? ui-thread get-global self eq? and [
- ui-notify-flag get lower-flag
- [ update-ui ] ui-try
- update-ui-loop
- ] when ;
+ [ ui-running? ui-thread get-global self eq? and ]
+ [ ui-notify-flag get lower-flag update-ui ]
+ [ ] while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor
index 81cc0a0b70..fc22f30e0a 100644
--- a/basis/ui/windows/windows.factor
+++ b/basis/ui/windows/windows.factor
@@ -381,11 +381,9 @@ SYMBOL: trace-messages?
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
"uint" { "void*" "uint" "long" "long" } "stdcall" [
- [
- pick
- trace-messages? get-global [ dup windows-message-name name>> print flush ] when
- wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
- ] ui-try
+ pick
+ trace-messages? get-global [ dup windows-message-name name>> print flush ] when
+ wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
] alien-callback ;
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
index 04e47763a8..9faf888559 100644
--- a/basis/ui/x11/x11.factor
+++ b/basis/ui/x11/x11.factor
@@ -189,7 +189,7 @@ M: world client-event
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup
- [ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ;
+ [ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win )
atom>> swap
From dab66552bd7a298ef9f634a0e2730905df3e1e92 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 23:04:24 -0600
Subject: [PATCH 104/126] Fix listener help lint
---
basis/listener/listener-docs.factor | 1 -
1 file changed, 1 deletion(-)
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index ba3bb7275e..014e096b1d 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -30,7 +30,6 @@ HELP: hide-vars
{ $description "Removes a sequence of variables from the watch list." } ;
HELP: hide-all-vars
-{ $values { "seq" "a sequence of variable names" } }
{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
From 1b091b5a26edec2486957eea0aeb5167c0dd6dbc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 23:13:14 -0600
Subject: [PATCH 105/126] Reuse F_CONTEXT instances used for FFI callbacks: 60x
speed improvement on benchmark.fib6
---
vm/run.c | 36 ++++++++++++++++++++++++++++--------
vm/run.h | 2 ++
2 files changed, 30 insertions(+), 8 deletions(-)
diff --git a/vm/run.c b/vm/run.c
index c7d93d29c8..79792d79f3 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -29,10 +29,35 @@ void save_stacks(void)
}
}
+F_CONTEXT *alloc_context(void)
+{
+ F_CONTEXT *context;
+
+ if(unused_contexts)
+ {
+ context = unused_contexts;
+ unused_contexts = unused_contexts->next;
+ }
+ else
+ {
+ context = safe_malloc(sizeof(F_CONTEXT));
+ context->datastack_region = alloc_segment(ds_size);
+ context->retainstack_region = alloc_segment(rs_size);
+ }
+
+ return context;
+}
+
+void dealloc_context(F_CONTEXT *context)
+{
+ context->next = unused_contexts;
+ unused_contexts = context;
+}
+
/* called on entry into a compiled callback */
void nest_stacks(void)
{
- F_CONTEXT *new_stacks = safe_malloc(sizeof(F_CONTEXT));
+ F_CONTEXT *new_stacks = alloc_context();
new_stacks->callstack_bottom = (F_STACK_FRAME *)-1;
new_stacks->callstack_top = (F_STACK_FRAME *)-1;
@@ -54,9 +79,6 @@ void nest_stacks(void)
new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
new_stacks->catchstack_save = userenv[CATCHSTACK_ENV];
- new_stacks->datastack_region = alloc_segment(ds_size);
- new_stacks->retainstack_region = alloc_segment(rs_size);
-
new_stacks->next = stack_chain;
stack_chain = new_stacks;
@@ -67,9 +89,6 @@ void nest_stacks(void)
/* called when leaving a compiled callback */
void unnest_stacks(void)
{
- dealloc_segment(stack_chain->datastack_region);
- dealloc_segment(stack_chain->retainstack_region);
-
ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save;
@@ -79,7 +98,7 @@ void unnest_stacks(void)
F_CONTEXT *old_stacks = stack_chain;
stack_chain = old_stacks->next;
- free(old_stacks);
+ dealloc_context(old_stacks);
}
/* called on startup */
@@ -88,6 +107,7 @@ void init_stacks(CELL ds_size_, CELL rs_size_)
ds_size = ds_size_;
rs_size = rs_size_;
stack_chain = NULL;
+ unused_contexts = NULL;
}
bool stack_to_array(CELL bottom, CELL top)
diff --git a/vm/run.h b/vm/run.h
index 2dbbcc8c06..be133b7eca 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -211,6 +211,8 @@ typedef struct _F_CONTEXT {
DLLEXPORT F_CONTEXT *stack_chain;
+F_CONTEXT *unused_contexts;
+
CELL ds_size, rs_size;
#define ds_bot (stack_chain->datastack_region->start)
From e516795a7508d0cb2c3884b5ccebbf889f06bb67 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 23:24:59 -0600
Subject: [PATCH 106/126] Increase benchmark.fib6 running time
---
extra/benchmark/fib6/fib6.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor
index 594b451876..64d1b6c533 100755
--- a/extra/benchmark/fib6/fib6.factor
+++ b/extra/benchmark/fib6/fib6.factor
@@ -9,6 +9,6 @@ USING: math kernel alien ;
] alien-callback
"int" { "int" } "cdecl" alien-indirect ;
-: fib-main ( -- ) 25 fib drop ;
+: fib-main ( -- ) 34 fib drop ;
MAIN: fib-main
From c0c9855c2689f96e06ebc3ced43848fe717f49e7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 23:25:19 -0600
Subject: [PATCH 107/126] Fix stack effects
---
basis/ui/gadgets/editors/editors.factor | 2 +-
basis/ui/tools/interactor/interactor.factor | 2 +-
basis/ui/tools/listener/listener.factor | 2 +-
3 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 3753e98a8a..856795e4ed 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -356,7 +356,7 @@ M: editor gadget-text* editor-string % ;
[ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ;
-: insert-newline ( editor -- ) "\n" swap user-input* ;
+: insert-newline ( editor -- ) "\n" swap user-input* drop ;
: delete-next-character ( editor -- )
T{ char-elt } editor-delete ;
diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor
index 94aa878942..5739a469ea 100644
--- a/basis/ui/tools/interactor/interactor.factor
+++ b/basis/ui/tools/interactor/interactor.factor
@@ -164,7 +164,7 @@ M: interactor dispose drop ;
: handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse {
{ [ dup quotation? ] [ nip t ] }
- { [ dup not ] [ drop "\n" swap user-input* f f ] }
+ { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
[ handle-parse-error f f ]
} cond ;
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index bf62f5372d..1fe2d8eb24 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -101,7 +101,7 @@ M: engine-word word-completion-string
: insert-word ( word -- )
get-workspace listener>> input>>
- [ >r word-completion-string r> user-input* ]
+ [ >r word-completion-string r> user-input* drop ]
[ interactor-use use-if-necessary ]
2bi ;
From 0efa5e09c98e2ab908ecc0033a616f5bbd982d3c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 23:31:56 -0600
Subject: [PATCH 108/126] Add some gadgets which are broken on purpose to test
UI error handling
---
extra/ui/gadgets/broken/broken.factor | 26 ++++++++++++++++++++++++++
1 file changed, 26 insertions(+)
create mode 100644 extra/ui/gadgets/broken/broken.factor
diff --git a/extra/ui/gadgets/broken/broken.factor b/extra/ui/gadgets/broken/broken.factor
new file mode 100644
index 0000000000..d282e417bf
--- /dev/null
+++ b/extra/ui/gadgets/broken/broken.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors ui ui.gadgets ui.gadgets.buttons ui.render ;
+IN: ui.gadgets.broken
+
+! An intentionally broken gadget -- used to test UI error handling,
+! make sure that one bad gadget doesn't bring the whole system down
+
+: <bad-button> ( -- button )
+ "Click me if you dare"
+ [ "Haha" throw ]
+ <bevel-button> ;
+
+TUPLE: bad-gadget < gadget ;
+
+M: bad-gadget draw-gadget* "Lulz" throw ;
+
+M: bad-gadget pref-dim* drop { 100 100 } ;
+
+: <bad-gadget> ( -- gadget ) bad-gadget new-gadget ;
+
+: bad-gadget-test ( -- )
+ <bad-button> "Test 1" open-window
+ <bad-gadget> "Test 2" open-window ;
+
+MAIN: bad-gadget-test
From 5236f49800ae9705271ed8e61afc2d045703a84b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 21 Nov 2008 23:56:45 -0600
Subject: [PATCH 109/126] Add unit test now that event-loop infers
---
basis/ui/ui-tests.factor | 4 ++++
1 file changed, 4 insertions(+)
create mode 100644 basis/ui/ui-tests.factor
diff --git a/basis/ui/ui-tests.factor b/basis/ui/ui-tests.factor
new file mode 100644
index 0000000000..49c272c1b4
--- /dev/null
+++ b/basis/ui/ui-tests.factor
@@ -0,0 +1,4 @@
+IN: ui.tests
+USING: ui tools.test ;
+
+\ event-loop must-infer
From ae8e3ecb78104e013b8192dd55d453ba47f99375 Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Sat, 22 Nov 2008 00:23:56 -0600
Subject: [PATCH 110/126] Fix X11 input problems
---
basis/ui/gestures/gestures.factor | 2 +-
basis/ui/x11/x11.factor | 20 ++++++++++++++------
2 files changed, 15 insertions(+), 7 deletions(-)
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 180447ff4f..2f7bee927b 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -82,7 +82,7 @@ SYMBOLS: C+ A+ M+ S+ ;
TUPLE: key-down mods sym ;
: <key-gesture> ( mods sym action? class -- mods' sym' )
- [ [ S+ rot remove swap ] unless ] dip boa ; inline
+ [ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
: <key-down> ( mods sym action? -- key-down )
key-down <key-gesture> ;
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
index 9faf888559..de57c2dc72 100644
--- a/basis/ui/x11/x11.factor
+++ b/basis/ui/x11/x11.factor
@@ -7,7 +7,7 @@ x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect
-environment ;
+environment ascii ;
IN: ui.x11
SINGLETON: x11-ui-backend
@@ -67,18 +67,26 @@ M: world configure-event
: event-modifiers ( event -- seq )
XKeyEvent-state modifiers modifier ;
+: valid-input? ( string gesture -- ? )
+ over empty? [ 2drop f ] [
+ mods>> { f { S+ } } member? [
+ [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
+ ] [
+ [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
+ ] if
+ ] if ;
+
: key-down-event>gesture ( event world -- string gesture )
dupd
handle>> xic>> lookup-string
>r swap event-modifiers r> key-code <key-down> ;
-: valid-input? ( string -- ? )
- [ f ] [ [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all? ] if-empty ;
-
M: world key-down-event
[ key-down-event>gesture ] keep
- world-focus [ propagate-gesture ] keep
- over valid-input? [ user-input ] [ 2drop ] if ;
+ world-focus
+ [ propagate-gesture drop ]
+ [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
+ 3bi ;
: key-up-event>gesture ( event -- gesture )
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
From 2be5693f38f8e0f982cdda17e294dd859b2d5948 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 00:30:39 -0600
Subject: [PATCH 111/126] Clean up documents
---
basis/documents/documents.factor | 68 +++++++++++++++++---------------
1 file changed, 36 insertions(+), 32 deletions(-)
diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor
index 54bc85284a..a82437ba40 100644
--- a/basis/documents/documents.factor
+++ b/basis/documents/documents.factor
@@ -5,9 +5,9 @@ sequences strings splitting combinators unicode.categories
math.order ;
IN: documents
-: +col ( loc n -- newloc ) >r first2 r> + 2array ;
+: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
-: +line ( loc n -- newloc ) >r first2 swap r> + swap 2array ;
+: +line ( loc n -- newloc ) [ first2 swap ] dip + swap 2array ;
: =col ( n loc -- newloc ) first swap 2array ;
@@ -31,10 +31,10 @@ TUPLE: document < model locs ;
: doc-line ( n document -- string ) value>> nth ;
: doc-lines ( from to document -- slice )
- >r 1+ r> value>> <slice> ;
+ [ 1+ ] dip value>> <slice> ;
: start-on-line ( document from line# -- n1 )
- >r dup first r> = [ nip second ] [ 2drop 0 ] if ;
+ [ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
: end-on-line ( document to line# -- n2 )
over first over = [
@@ -47,12 +47,14 @@ TUPLE: document < model locs ;
2over = [
3drop
] [
- >r [ first ] bi@ 1+ dup <slice> r> each
+ [ [ first ] bi@ 1+ dup <slice> ] dip each
] if ; inline
: start/end-on-line ( from to line# -- n1 n2 )
- tuck >r >r document get -rot start-on-line r> r>
- document get -rot end-on-line ;
+ tuck
+ [ [ document get ] 2dip start-on-line ]
+ [ [ document get ] 2dip end-on-line ]
+ 2bi* ;
: (doc-range) ( from to line# -- )
[ start/end-on-line ] keep document get doc-line <slice> , ;
@@ -60,16 +62,18 @@ TUPLE: document < model locs ;
: doc-range ( from to document -- string )
[
document set 2dup [
- >r 2dup r> (doc-range)
+ [ 2dup ] dip (doc-range)
] each-line 2drop
] { } make "\n" join ;
: text+loc ( lines loc -- loc )
- over >r over length 1 = [
- nip first2
- ] [
- first swap length 1- + 0
- ] if r> peek length + 2array ;
+ over [
+ over length 1 = [
+ nip first2
+ ] [
+ first swap length 1- + 0
+ ] if
+ ] dip peek length + 2array ;
: prepend-first ( str seq -- )
0 swap [ append ] change-nth ;
@@ -78,25 +82,25 @@ TUPLE: document < model locs ;
[ length 1- ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col )
- >r first2 swap r> nth swap ;
+ [ first2 swap ] dip nth swap ;
: prepare-insert ( newinput from to lines -- newinput )
- tuck loc-col/str tail-slice >r loc-col/str head-slice r>
+ tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
pick append-last over prepend-first ;
: (set-doc-range) ( newlines from to lines -- )
[ prepare-insert ] 3keep
- >r [ first ] bi@ 1+ r>
+ [ [ first ] bi@ 1+ ] dip
replace-slice ;
: set-doc-range ( string from to document -- )
[
- >r >r >r string-lines r> [ text+loc ] 2keep r> r>
+ [ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
[ [ (set-doc-range) ] keep ] change-model
] keep update-locs ;
: remove-doc-range ( from to document -- )
- >r >r >r "" r> r> r> set-doc-range ;
+ [ "" ] 3dip set-doc-range ;
: last-line# ( document -- line )
value>> length 1- ;
@@ -111,7 +115,7 @@ TUPLE: document < model locs ;
dupd doc-line length 2array ;
: line-end? ( loc document -- ? )
- >r first2 swap r> doc-line length = ;
+ [ first2 swap ] dip doc-line length = ;
: doc-end ( document -- loc )
[ last-line# ] keep line-end ;
@@ -123,7 +127,7 @@ TUPLE: document < model locs ;
over first 0 < [
2drop { 0 0 }
] [
- >r first2 swap tuck r> validate-col 2array
+ [ first2 swap tuck ] dip validate-col 2array
] if
] if ;
@@ -131,7 +135,7 @@ TUPLE: document < model locs ;
value>> "\n" join ;
: set-doc-string ( string document -- )
- >r string-lines V{ } like r> [ set-model ] keep
+ [ string-lines V{ } like ] dip [ set-model ] keep
[ doc-end ] [ update-locs ] bi ;
: clear-doc ( document -- )
@@ -141,17 +145,17 @@ GENERIC: prev-elt ( loc document elt -- newloc )
GENERIC: next-elt ( loc document elt -- newloc )
: prev/next-elt ( loc document elt -- start end )
- 3dup next-elt >r prev-elt r> ;
+ [ prev-elt ] [ next-elt ] 3bi ;
: elt-string ( loc document elt -- string )
- over >r prev/next-elt r> doc-range ;
+ [ prev/next-elt ] [ drop ] 2bi doc-range ;
TUPLE: char-elt ;
: (prev-char) ( loc document quot -- loc )
-rot {
{ [ over { 0 0 } = ] [ drop ] }
- { [ over second zero? ] [ >r first 1- r> line-end ] }
+ { [ over second zero? ] [ [ first 1- ] dip line-end ] }
[ pick call ]
} cond nip ; inline
@@ -175,14 +179,14 @@ M: one-char-elt prev-elt 2drop ;
M: one-char-elt next-elt 2drop ;
: (word-elt) ( loc document quot -- loc )
- pick >r
- >r >r first2 swap r> doc-line r> call
- r> =col ; inline
+ pick [
+ [ [ first2 swap ] dip doc-line ] dip call
+ ] dip =col ; inline
: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot )
- [ >r blank? r> xor ] curry ; inline
+ [ [ blank? ] dip xor ] curry ; inline
: (prev-word) ( ? col str -- col )
rot break-detector find-last-from drop ?1+ ;
@@ -195,17 +199,17 @@ TUPLE: one-word-elt ;
M: one-word-elt prev-elt
drop
- [ f -rot >r 1- r> (prev-word) ] (word-elt) ;
+ [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
M: one-word-elt next-elt
drop
- [ f -rot (next-word) ] (word-elt) ;
+ [ [ f ] 2dip (next-word) ] (word-elt) ;
TUPLE: word-elt ;
M: word-elt prev-elt
drop
- [ [ >r 1- r> ((word-elt)) (prev-word) ] (word-elt) ]
+ [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
(prev-char) ;
M: word-elt next-elt
@@ -219,7 +223,7 @@ M: one-line-elt prev-elt
2drop first 0 2array ;
M: one-line-elt next-elt
- drop >r first dup r> doc-line length 2array ;
+ drop [ first dup ] dip doc-line length 2array ;
TUPLE: line-elt ;
From 8ec486f9a8a552710b8015eaa02142c5fceb86a3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 01:20:47 -0600
Subject: [PATCH 112/126] Add unit test now that open-window infers
---
basis/ui/ui-tests.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/basis/ui/ui-tests.factor b/basis/ui/ui-tests.factor
index 49c272c1b4..2920b58fff 100644
--- a/basis/ui/ui-tests.factor
+++ b/basis/ui/ui-tests.factor
@@ -2,3 +2,4 @@ IN: ui.tests
USING: ui tools.test ;
\ event-loop must-infer
+\ open-window must-infer
From ff8b9cf7e066ec777d2dc3f3b70081ee523e2aab Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 01:21:01 -0600
Subject: [PATCH 113/126] Fix compile error: inferrability of open-window
exposed an invalid stack comment
---
extra/cfdg/cfdg.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor
index 102de8fd22..3278cc6ec1 100644
--- a/extra/cfdg/cfdg.factor
+++ b/extra/cfdg/cfdg.factor
@@ -224,13 +224,13 @@ SYMBOL: dlist
: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
-: cfdg-window* ( -- )
+: cfdg-window* ( -- slate )
C[ display ] <slate>
{ 500 500 } >>pdim
C[ delete-dlist ] >>ungraft
dup "CFDG" open-window ;
-: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
+: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 17cb29e74e6df55ff796e6c4247aa9cd4dedbd10 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 01:24:05 -0600
Subject: [PATCH 114/126] "help" test in UI should not affect browser tool
---
basis/help/definitions/definitions-tests.factor | 2 +-
basis/help/handbook/handbook-tests.factor | 10 +++++-----
basis/help/lint/lint.factor | 2 +-
basis/help/markup/markup-tests.factor | 10 +++++-----
4 files changed, 12 insertions(+), 12 deletions(-)
diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor
index 1b8bcccce7..d95f6988a2 100644
--- a/basis/help/definitions/definitions-tests.factor
+++ b/basis/help/definitions/definitions-tests.factor
@@ -34,7 +34,7 @@ IN: help.definitions.tests
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
- [ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test
+ [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test
] with-file-vocabs
diff --git a/basis/help/handbook/handbook-tests.factor b/basis/help/handbook/handbook-tests.factor
index ae6c7d55f4..240ce67240 100644
--- a/basis/help/handbook/handbook-tests.factor
+++ b/basis/help/handbook/handbook-tests.factor
@@ -1,8 +1,8 @@
IN: help.handbook.tests
USING: help tools.test ;
-[ ] [ "article-index" help ] unit-test
-[ ] [ "primitive-index" help ] unit-test
-[ ] [ "error-index" help ] unit-test
-[ ] [ "type-index" help ] unit-test
-[ ] [ "class-index" help ] unit-test
+[ ] [ "article-index" print-topic ] unit-test
+[ ] [ "primitive-index" print-topic ] unit-test
+[ ] [ "error-index" print-topic ] unit-test
+[ ] [ "type-index" print-topic ] unit-test
+[ ] [ "class-index" print-topic ] unit-test
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index be6206f59c..c7d505d86a 100644
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -68,7 +68,7 @@ IN: help.lint
] each ;
: check-rendering ( word element -- )
- [ help ] with-string-writer drop ;
+ [ print-topic ] with-string-writer drop ;
: all-word-help ( words -- seq )
[ word-help ] filter ;
diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor
index 222c4e7d3f..b9ec34a831 100644
--- a/basis/help/markup/markup-tests.factor
+++ b/basis/help/markup/markup-tests.factor
@@ -6,12 +6,12 @@ TUPLE: blahblah quux ;
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
-[ ] [ \ quux>> help ] unit-test
-[ ] [ \ >>quux help ] unit-test
-[ ] [ \ blahblah? help ] unit-test
+[ ] [ \ quux>> print-topic ] unit-test
+[ ] [ \ >>quux print-topic ] unit-test
+[ ] [ \ blahblah? print-topic ] unit-test
: fooey "fooey" throw ;
-[ ] [ \ fooey help ] unit-test
+[ ] [ \ fooey print-topic ] unit-test
-[ ] [ gensym help ] unit-test
+[ ] [ gensym print-topic ] unit-test
From 0b8cbc7d67fc3e127662b90ffd49c68cd8fdcad3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 01:42:16 -0600
Subject: [PATCH 115/126] Fix drag gestures
---
basis/ui/gadgets/worlds/worlds.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 29c663e914..d9ed50c2ec 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -103,13 +103,15 @@ world H{
{ T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
{ T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
{ T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
+ { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
{ T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
{ T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
+ { T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
} set-gestures
PREDICATE: specific-button-up < button-up #>> ;
-
PREDICATE: specific-button-down < button-down #>> ;
+PREDICATE: specific-drag < drag #>> ;
: generalize-gesture ( gesture -- )
clone f >># button-gesture ;
@@ -118,6 +120,7 @@ M: world handle-gesture ( gesture gadget -- ? )
{
{ [ over specific-button-up? ] [ drop generalize-gesture t ] }
{ [ over specific-button-down? ] [ drop generalize-gesture t ] }
+ { [ over specific-drag? ] [ drop generalize-gesture t ] }
[ call-next-method ]
} cond ;
From fa56d2849b4e6e67833cb3865424531135247e2c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 02:23:43 -0600
Subject: [PATCH 116/126] Fix alt-click and control-click to simulate middle
and right mouse button clicks
---
basis/ui/gadgets/worlds/worlds.factor | 14 ++++++++------
1 file changed, 8 insertions(+), 6 deletions(-)
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index d9ed50c2ec..904a2a5bac 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -117,12 +117,14 @@ PREDICATE: specific-drag < drag #>> ;
clone f >># button-gesture ;
M: world handle-gesture ( gesture gadget -- ? )
- {
- { [ over specific-button-up? ] [ drop generalize-gesture t ] }
- { [ over specific-button-down? ] [ drop generalize-gesture t ] }
- { [ over specific-drag? ] [ drop generalize-gesture t ] }
- [ call-next-method ]
- } cond ;
+ 2dup call-next-method [
+ {
+ { [ over specific-button-up? ] [ drop generalize-gesture f ] }
+ { [ over specific-button-down? ] [ drop generalize-gesture f ] }
+ { [ over specific-drag? ] [ drop generalize-gesture f ] }
+ [ 2drop t ]
+ } cond
+ ] [ 2drop f ] if ;
: close-global ( world global -- )
dup get-global find-world rot eq?
From 7e71fe081cda913f1179512d648cb8d9eeeddd9c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 02:24:17 -0600
Subject: [PATCH 117/126] Fix shift-drag again
---
basis/ui/gadgets/panes/panes.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index c1b3df3857..c612cbef0a 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -10,7 +10,6 @@ io.streams.nested assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect ;
-
IN: ui.gadgets.panes
TUPLE: pane < pack
@@ -402,7 +401,7 @@ M: f sloppy-pick-up*
pane H{
{ T{ button-down } [ begin-selection ] }
{ T{ button-down f { S+ } 1 } [ select-to-caret ] }
- { T{ button-up f { S+ } 1 } [ drop ] }
+ { T{ button-up f { S+ } 1 } [ end-selection ] }
{ T{ button-up } [ end-selection ] }
{ T{ drag } [ extend-selection ] }
{ T{ copy-action } [ com-copy ] }
From 42926ebfcf8f33b401097b72e6e5e28f604a7110 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 02:24:24 -0600
Subject: [PATCH 118/126] Fix ui.gestures help-lint
---
basis/ui/gestures/gestures-docs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index e94bcf6d93..b7c5c94c62 100644
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@@ -18,8 +18,8 @@ $nl
{ propagate-gesture handle-gesture set-gestures } related-words
HELP: propagate-gesture
-{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
+{ $values { "gesture" "a gesture" } { "gadget" gadget } }
+{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ;
HELP: user-input
{ $values { "string" string } { "gadget" gadget } }
From 1162ee6b0f609347f2ffeda5e3a219f3a169a2f3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 03:22:19 -0600
Subject: [PATCH 119/126] Add <> word
---
basis/help/help.factor | 2 +-
basis/help/markup/markup.factor | 3 +++
basis/ui/commands/commands-docs.factor | 2 +-
3 files changed, 5 insertions(+), 2 deletions(-)
diff --git a/basis/help/help.factor b/basis/help/help.factor
index f9775e2668..2ad7290517 100644
--- a/basis/help/help.factor
+++ b/basis/help/help.factor
@@ -19,7 +19,7 @@ GENERIC: word-help* ( word -- content )
{ { "object" object } { "?" "a boolean" } } $values
[
"Tests if the object is an instance of the " ,
- first "predicating" word-prop \ $link swap 2array ,
+ first "predicating" word-prop <$link> ,
" class." ,
] { } make $description ;
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index a307833338..4cbb06a44e 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -348,3 +348,6 @@ M: array elements*
] each
] curry each
] H{ } make-assoc keys ;
+
+: <$link> ( topic -- element )
+ \ $link swap 2array ;
diff --git a/basis/ui/commands/commands-docs.factor b/basis/ui/commands/commands-docs.factor
index 5f1ff6dabd..78b82a345c 100644
--- a/basis/ui/commands/commands-docs.factor
+++ b/basis/ui/commands/commands-docs.factor
@@ -8,7 +8,7 @@ IN: ui.commands
[ gesture>string , ]
[
[ command-name , ]
- [ command-word \ $link swap 2array , ]
+ [ command-word <$link> , ]
[ command-description , ]
tri
] bi*
From 208a54e08e1839c792e55c67323ec4dda2868781 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 03:37:46 -0600
Subject: [PATCH 120/126] Help for generic words and classes now lists methods
---
basis/help/help.factor | 33 +++++++++++++++++++++++++++------
basis/help/markup/markup.factor | 5 +++++
2 files changed, 32 insertions(+), 6 deletions(-)
diff --git a/basis/help/help.factor b/basis/help/help.factor
index 2ad7290517..a3e3890687 100644
--- a/basis/help/help.factor
+++ b/basis/help/help.factor
@@ -58,15 +58,36 @@ M: word article-title
append
] if ;
-M: word article-content
+<PRIVATE
+
+: (word-help) ( word -- element )
[
- \ $vocabulary over 2array ,
- dup word-help %
- \ $related over 2array ,
- dup get-global [ \ $value swap 2array , ] when*
- \ $definition swap 2array ,
+ {
+ [ \ $vocabulary swap 2array , ]
+ [ word-help % ]
+ [ \ $related swap 2array , ]
+ [ get-global [ \ $value swap 2array , ] when* ]
+ [ \ $definition swap 2array , ]
+ } cleave
] { } make ;
+M: word article-content (word-help) ;
+
+<PRIVATE
+
+: word-with-methods ( word -- elements )
+ [
+ [ (word-help) % ]
+ [ \ $methods swap 2array , ]
+ bi
+ ] { } make ;
+
+PRIVATE>
+
+M: generic article-content word-with-methods ;
+
+M: class article-content word-with-methods ;
+
M: word article-parent "help-parent" word-prop ;
M: word set-article-parent swap "help-parent" set-word-prop ;
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index 4cbb06a44e..899cad2404 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -285,11 +285,16 @@ M: f ($instance)
: $see ( element -- ) first [ see ] ($see) ;
+: $see-methods ( element -- ) first [ see-methods ] ($see) ;
+
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
: $definition ( element -- )
"Definition" $heading $see ;
+: $methods ( element -- )
+ "Methods" $heading $see-methods ;
+
: $value ( object -- )
"Variable value" $heading
"Current value in global namespace:" print-element
From 958ba935f69f17c65ad3d12674daef58b1c23aad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 03:38:00 -0600
Subject: [PATCH 121/126] Rename words
---
basis/prettyprint/prettyprint.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 1ecca0ec19..6dd7175db8 100644
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -44,7 +44,7 @@ IN: prettyprint
] with-pprint nl
] unless-empty ;
-: vocabs. ( in use -- )
+: use/in. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ;
@@ -53,7 +53,7 @@ IN: prettyprint
[ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
: prelude. ( -- )
- in get use get vocab-names vocabs. ;
+ in get use get vocab-names use/in. ;
[
nl
@@ -65,7 +65,7 @@ IN: prettyprint
] print-use-hook set-global
: with-use ( obj quot -- )
- make-pprint vocabs. do-pprint ; inline
+ make-pprint use/in. do-pprint ; inline
: with-in ( obj quot -- )
make-pprint drop [ write-in bl ] when* do-pprint ; inline
From d7e1c276f85e9de3565e616bed81faeb75d96145 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 03:38:19 -0600
Subject: [PATCH 122/126] Add vocab-usage. and vocab-uses. words, vocab browser
now prints more information
---
.../tools/vocabs/browser/browser-docs.factor | 10 +-
basis/tools/vocabs/browser/browser.factor | 242 +++++++++++++-----
basis/tools/vocabs/vocabs.factor | 24 +-
3 files changed, 204 insertions(+), 72 deletions(-)
diff --git a/basis/tools/vocabs/browser/browser-docs.factor b/basis/tools/vocabs/browser/browser-docs.factor
index 3765efb863..6c5fb596e8 100644
--- a/basis/tools/vocabs/browser/browser-docs.factor
+++ b/basis/tools/vocabs/browser/browser-docs.factor
@@ -1,7 +1,13 @@
USING: help.markup help.syntax io strings ;
IN: tools.vocabs.browser
+ARTICLE: "vocab-tags" "Vocabulary tags"
+{ $all-tags } ;
+
+ARTICLE: "vocab-authors" "Vocabulary authors"
+{ $all-authors } ;
+
ARTICLE: "vocab-index" "Vocabulary index"
-{ $tags }
-{ $authors }
+{ $subsection "vocab-tags" }
+{ $subsection "vocab-authors" }
{ $describe-vocab "" } ;
diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor
index c3296df280..54e03763fc 100644
--- a/basis/tools/vocabs/browser/browser.factor
+++ b/basis/tools/vocabs/browser/browser.factor
@@ -1,9 +1,12 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel combinators vocabs vocabs.loader
-tools.vocabs io io.files io.styles help.markup help.stylesheet
-sequences assocs help.topics namespaces prettyprint words
-sorting definitions arrays summary sets generic ;
+USING: accessors arrays assocs classes classes.builtin
+classes.intersection classes.mixin classes.predicate
+classes.singleton classes.tuple classes.union combinators
+definitions effects fry generic help help.markup
+help.stylesheet help.topics io io.files io.styles kernel macros
+make namespaces prettyprint sequences sets sorting summary
+tools.vocabs vocabs vocabs.loader words ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
@@ -34,7 +37,7 @@ IN: tools.vocabs.browser
[ "Children from " prepend ] [ "Children" ] if*
$heading ;
-: vocabs. ( assoc -- )
+: $vocabs ( assoc -- )
[
[
drop
@@ -46,23 +49,13 @@ IN: tools.vocabs.browser
] if-empty
] assoc-each ;
-: describe-summary ( vocab -- )
- vocab-summary [
- "Summary" $heading print-element
- ] when* ;
-
TUPLE: vocab-tag name ;
INSTANCE: vocab-tag topic
C: <vocab-tag> vocab-tag
-: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
-
-: describe-tags ( vocab -- )
- vocab-tags f like [
- "Tags" $heading tags.
- ] when* ;
+: $tags ( seq -- ) [ <vocab-tag> ] map $links ;
TUPLE: vocab-author name ;
@@ -70,20 +63,18 @@ INSTANCE: vocab-author topic
C: <vocab-author> vocab-author
-: authors. ( seq -- ) [ <vocab-author> ] map $links ;
-
-: describe-authors ( vocab -- )
- vocab-authors f like [
- "Authors" $heading authors.
- ] when* ;
+: $authors ( seq -- ) [ <vocab-author> ] map $links ;
: describe-help ( vocab -- )
- vocab-help [
- "Documentation" $heading ($link)
- ] when* ;
+ [
+ dup vocab-help
+ [ "Documentation" $heading ($link) ]
+ [ "Summary" $heading vocab-summary print-element ]
+ ?if
+ ] unless-empty ;
: describe-children ( vocab -- )
- vocab-name all-child-vocabs vocabs. ;
+ vocab-name all-child-vocabs $vocabs ;
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
@@ -95,50 +86,163 @@ C: <vocab-author> vocab-author
] with-nesting
] with-style
] ($block)
- ] when* ;
+ ] unless-empty ;
-: describe-words ( vocab -- )
+: describe-tuple-classes ( classes -- )
+ [
+ "Tuple classes" $subheading
+ [
+ [ <$link> ]
+ [ superclass <$link> ]
+ [ "slots" word-prop [ name>> ] map " " join \ $snippet swap 2array ]
+ tri 3array
+ ] map
+ { { $strong "Class" } { $strong "Superclass" } { $strong "Slots" } } prefix
+ $table
+ ] unless-empty ;
+
+: describe-predicate-classes ( classes -- )
+ [
+ "Predicate classes" $subheading
+ [
+ [ <$link> ]
+ [ superclass <$link> ]
+ bi 2array
+ ] map
+ { { $strong "Class" } { $strong "Superclass" } } prefix
+ $table
+ ] unless-empty ;
+
+: (describe-classes) ( classes heading -- )
+ '[
+ _ $subheading
+ [ <$link> 1array ] map $table
+ ] unless-empty ;
+
+: describe-builtin-classes ( classes -- )
+ "Builtin classes" (describe-classes) ;
+
+: describe-singleton-classes ( classes -- )
+ "Singleton classes" (describe-classes) ;
+
+: describe-mixin-classes ( classes -- )
+ "Mixin classes" (describe-classes) ;
+
+: describe-union-classes ( classes -- )
+ "Union classes" (describe-classes) ;
+
+: describe-intersection-classes ( classes -- )
+ "Intersection classes" (describe-classes) ;
+
+: describe-classes ( classes -- )
+ [ builtin-class? ] partition
+ [ tuple-class? ] partition
+ [ singleton-class? ] partition
+ [ predicate-class? ] partition
+ [ mixin-class? ] partition
+ [ union-class? ] partition
+ [ intersection-class? ] filter
+ {
+ [ describe-builtin-classes ]
+ [ describe-tuple-classes ]
+ [ describe-singleton-classes ]
+ [ describe-predicate-classes ]
+ [ describe-mixin-classes ]
+ [ describe-union-classes ]
+ [ describe-intersection-classes ]
+ } spread ;
+
+: word-syntax ( word -- string/f )
+ \ $syntax swap word-help elements dup length 1 =
+ [ first second ] [ drop f ] if ;
+
+: describe-parsing ( words -- )
+ [
+ "Parsing words" $subheading
+ [
+ [ <$link> ]
+ [ word-syntax dup [ \ $snippet swap 2array ] when ]
+ bi 2array
+ ] map
+ { { $strong "Word" } { $strong "Syntax" } } prefix
+ $table
+ ] unless-empty ;
+
+: (describe-words) ( words heading -- )
+ '[
+ _ $subheading
+ [
+ [ <$link> ]
+ [ stack-effect dup [ effect>string \ $snippet swap 2array ] when ]
+ bi 2array
+ ] map
+ { { $strong "Word" } { $strong "Stack effect" } } prefix
+ $table
+ ] unless-empty ;
+
+: describe-generics ( words -- )
+ "Generic words" (describe-words) ;
+
+: describe-macros ( words -- )
+ "Macro words" (describe-words) ;
+
+: describe-primitives ( words -- )
+ "Primitives" (describe-words) ;
+
+: describe-compounds ( words -- )
+ "Ordinary words" (describe-words) ;
+
+: describe-predicates ( words -- )
+ "Class predicate words" (describe-words) ;
+
+: describe-symbols ( words -- )
+ [
+ "Symbol words" $subheading
+ [ <$link> 1array ] map $table
+ ] unless-empty ;
+
+: words. ( vocab -- )
words [
"Words" $heading
- natural-sort $links
+
+ natural-sort
+ [ [ class? ] filter describe-classes ]
+ [
+ [ [ class? ] [ symbol? ] bi and not ] filter
+ [ parsing-word? ] partition
+ [ generic? ] partition
+ [ macro? ] partition
+ [ symbol? ] partition
+ [ primitive? ] partition
+ [ predicate? ] partition swap
+ {
+ [ describe-parsing ]
+ [ describe-generics ]
+ [ describe-macros ]
+ [ describe-symbols ]
+ [ describe-primitives ]
+ [ describe-compounds ]
+ [ describe-predicates ]
+ } spread
+ ] bi
] unless-empty ;
-: vocab-xref ( vocab quot -- vocabs )
- >r dup vocab-name swap words [ generic? not ] filter r> map
- [ [ word? ] filter [ vocabulary>> ] map ] gather natural-sort
- remove sift ; inline
-
-: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
-
-: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
-
-: describe-uses ( vocab -- )
- vocab-uses [
- "Uses" $heading
- $vocab-links
- ] unless-empty ;
-
-: describe-usage ( vocab -- )
- vocab-usage [
- "Used by" $heading
- $vocab-links
- ] unless-empty ;
+: describe-metadata ( vocab -- )
+ [
+ [ vocab-tags [ "Tags:" swap \ $tags prefix 2array , ] unless-empty ]
+ [ vocab-authors [ "Authors:" swap \ $authors prefix 2array , ] unless-empty ]
+ bi
+ ] { } make
+ [ "Meta-data" $heading $table ] unless-empty ;
: $describe-vocab ( element -- )
- first
- dup describe-children
- dup find-vocab-root [
- dup describe-summary
- dup describe-tags
- dup describe-authors
- dup describe-files
- ] when
- dup vocab [
- dup describe-help
- dup describe-words
- dup describe-uses
- dup describe-usage
- ] when drop ;
+ first {
+ [ describe-help ]
+ [ describe-metadata ]
+ [ words. ]
+ [ describe-files ]
+ [ describe-children ]
+ } cleave ;
: keyed-vocabs ( str quot -- seq )
all-vocabs [
@@ -154,16 +258,16 @@ C: <vocab-author> vocab-author
[ vocab-authors ] keyed-vocabs ;
: $tagged-vocabs ( element -- )
- first tagged vocabs. ;
+ first tagged $vocabs ;
: $authored-vocabs ( element -- )
- first authored vocabs. ;
+ first authored $vocabs ;
-: $tags ( element -- )
- drop "Tags" $heading all-tags tags. ;
+: $all-tags ( element -- )
+ drop "Tags" $heading all-tags $tags ;
-: $authors ( element -- )
- drop "Authors" $heading all-authors authors. ;
+: $all-authors ( element -- )
+ drop "Authors" $heading all-authors $authors ;
INSTANCE: vocab topic
diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor
index b929c62e04..b492ef4da2 100644
--- a/basis/tools/vocabs/vocabs.factor
+++ b/basis/tools/vocabs/vocabs.factor
@@ -4,9 +4,31 @@ USING: kernel io io.styles io.files io.encodings.utf8
vocabs.loader vocabs sequences namespaces make math.parser
arrays hashtables assocs memoize summary sorting splitting
combinators source-files debugger continuations compiler.errors
-init checksums checksums.crc32 sets accessors ;
+init checksums checksums.crc32 sets accessors generic
+definitions words ;
IN: tools.vocabs
+: vocab-xref ( vocab quot -- vocabs )
+ [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
+ [
+ [ [ word? ] [ generic? not ] bi and ] filter [
+ dup method-body?
+ [ "method-generic" word-prop ] when
+ vocabulary>>
+ ] map
+ ] gather natural-sort remove sift ; inline
+
+: vocabs. ( seq -- )
+ [ dup >vocab-link write-object nl ] each ;
+
+: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
+
+: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;
+
+: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
+
+: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;
+
: vocab-tests-file ( vocab -- path )
dup "-tests.factor" vocab-dir+ vocab-append-path dup
[ dup exists? [ drop f ] unless ] [ drop f ] if ;
From 91b0696f1c015ae126c692d0ef621564e354ba1f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 03:38:50 -0600
Subject: [PATCH 123/126] Remove unfinished/vocab-browser now that the main
vocab browser incorporates ideas
---
unfinished/vocab-browser/vocab-browser.factor | 310 ------------------
1 file changed, 310 deletions(-)
delete mode 100644 unfinished/vocab-browser/vocab-browser.factor
diff --git a/unfinished/vocab-browser/vocab-browser.factor b/unfinished/vocab-browser/vocab-browser.factor
deleted file mode 100644
index cec2dd21e7..0000000000
--- a/unfinished/vocab-browser/vocab-browser.factor
+++ /dev/null
@@ -1,310 +0,0 @@
-
-USING: kernel words accessors
- classes
- classes.builtin
- classes.tuple
- classes.predicate
- vocabs
- arrays
- sequences sorting
- io help.markup
- effects
- generic
- prettyprint
- prettyprint.sections
- prettyprint.backend
- combinators.cleave
- obj.print ;
-
-IN: vocab-browser
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: word-effect-as-string ( word -- string )
- stack-effect dup
- [ effect>string ]
- [ drop "" ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: print-vocabulary-summary ( vocabulary -- )
-
- dup vocab words [ builtin-class? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Builtin Classes" $heading nl
- print-seq
- ]
- if
-
- dup vocab words [ tuple-class? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Tuple Classes" $heading nl
- [
- { [ ] [ superclass ] [ "slots" word-prop [ name>> ] map " " join ] }
- 1arr
- ]
- map
- { "CLASS" "PARENT" "SLOTS" } prefix
- print-table
- ]
- if
-
- dup vocab words [ predicate-class? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Predicate Classes" $heading nl
- ! [ pprint-class ] each
- [ { [ ] [ superclass ] } 1arr ] map
- { "CLASS" "SUPERCLASS" } prefix
- print-table
- ]
- if
-
- dup vocab words [ class? not ] filter [ symbol? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Symbols" $heading nl
- print-seq
- ]
- if
-
- dup vocab words [ generic? ] filter natural-sort
- dup empty?
- [ drop ]
- [
- "Generic words" $heading nl
- [ [ ] [ stack-effect effect>string ] bi 2array ] map
- print-table
- ]
- if
-
- "Words" $heading nl
- dup vocab words
- [ predicate-class? not ] filter
- [ builtin-class? not ] filter
- [ tuple-class? not ] filter
- [ generic? not ] filter
- [ symbol? not ] filter
- [ word? ] filter
- natural-sort
- [ [ ] [ word-effect-as-string ] bi 2array ] map
- print-table
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: vocabs.loader tools.vocabs.browser ;
-
-: $vocab-summary ( seq -- )
- first
- dup vocab
- [
- dup print-vocabulary-summary
- dup describe-help
- ! dup describe-uses
- ! dup describe-usage
- ]
- when
- dup find-vocab-root
- [
- dup describe-summary
- dup describe-tags
- dup describe-authors
- ! dup describe-files
- ]
- when
- ! dup describe-children
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: assocs ui.tools.browser ui.operations io.styles ;
-
-! IN: tools.vocabs.browser
-
-! : $describe-vocab ( element -- ) $vocab-summary ;
-
-USING: tools.vocabs ;
-
-: print-vocabs ( -- )
- vocabs
- [ { [ vocab ] [ vocab-summary ] } 1arr ]
- map
- print-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : $all-vocabs ( seq -- ) drop print-vocabs ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: help.syntax help.topics ;
-
-! ARTICLE: "vocab-index" "Vocabulary Index" { $all-vocabs } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: vocab-spec article-content ( vocab-spec -- content )
- { $vocab-summary } swap name>> suffix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: loaded-and-unloaded-vocabs ( -- seq )
- "" all-child-vocabs values concat [ name>> ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! ARTICLE: "loaded-vocabs-index" "Loaded Vocabularies" { $loaded-vocabs } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: debugger ;
-
-TUPLE: load-this-vocab name ;
-
-! : do-load-vocab ( ltv -- )
-! dup name>> require
-! name>> vocab com-follow ;
-
-: do-load-vocab ( ltv -- )
- [
- dup name>> require
- name>> vocab com-follow
- ]
- curry
- try ;
-
-[ load-this-vocab? ] \ do-load-vocab { { +primary+ t } } define-operation
-
-M: load-this-vocab pprint* ( obj -- )
- [ name>> "*" append ] [ ] bi write-object ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: vocab-or-loader ( name -- obj )
- dup vocab
- [ vocab ]
- [ load-this-vocab boa ]
- if ;
-
-: vocab-summary-text ( vocab-name -- text )
- dup vocab-summary-path vocab-file-contents
- dup empty?
- [ drop "" ]
- [ first ]
- if ;
-
-! : vocab-table-entry ( vocab-name -- seq )
-! { [ vocab-or-loader ] [ vocab-summary ] } 1arr ;
-
-: vocab-table-entry ( vocab-name -- seq )
- { [ vocab-or-loader ] [ vocab-summary-text ] } 1arr ;
-
-: print-these-vocabs ( seq -- ) [ vocab-table-entry ] map print-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : vocab-list ( -- seq ) "" all-child-vocabs values concat [ name>> ] map ;
-
-: all-vocab-names ( -- seq )
- all-vocabs values concat [ name>> ] map natural-sort ;
-
-: loaded-vocab-names ( -- seq ) all-vocab-names [ vocab ] filter ;
-
-: unloaded-vocab-names ( -- seq ) all-vocab-names [ vocab not ] filter ;
-
-: root->names ( root -- seq ) all-vocabs at [ name>> ] map natural-sort ;
-
-: vocab-names-core ( -- seq ) "resource:core" root->names ;
-: vocab-names-basis ( -- seq ) "resource:basis" root->names ;
-: vocab-names-extra ( -- seq ) "resource:extra" root->names ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: $all-vocabs ( seq -- ) drop all-vocab-names print-these-vocabs ;
-: $loaded-vocabs ( seq -- ) drop loaded-vocab-names print-these-vocabs ;
-: $unloaded-vocabs ( seq -- ) drop unloaded-vocab-names print-these-vocabs ;
-
-: $vocabs-core ( seq -- ) drop vocab-names-core print-these-vocabs ;
-: $vocabs-basis ( seq -- ) drop vocab-names-basis print-these-vocabs ;
-: $vocabs-extra ( seq -- ) drop vocab-names-extra print-these-vocabs ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! { "" }
-
-! all-child-vocabs values concat [ name>> ] map
-
-! : vocab-tree ( vocab -- seq )
-! dup
-! all-child-vocabs values concat [ name>> ] map prune
-! [ vocab-tree ]
-! map
-! concat
-! swap prefix
-! [ vocab-source-path ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: vocab-author pprint* ( vocab-author -- ) [ name>> ] [ ] bi write-object ;
-
-: $vocab-authors ( seq -- )
- drop all-authors [ vocab-author boa ] map print-seq ;
-
-ARTICLE: "vocab-authors" "Vocabulary Authors" { $vocab-authors } ;
-
-: vocabs-by-author ( author -- vocab-names )
- authored values concat [ name>> ] map ;
-
-: $vocabs-by-author ( seq -- )
- first name>> vocabs-by-author print-these-vocabs ;
-
-M: vocab-author article-content ( vocab-author -- content )
- { $vocabs-by-author } swap suffix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: vocab-tag pprint* ( vocab-tag -- ) [ name>> ] [ ] bi write-object ;
-
-: print-vocab-tags ( -- ) all-tags [ vocab-tag boa ] map print-seq ;
-
-: $vocab-tags ( seq -- ) drop print-vocab-tags ;
-
-ARTICLE: "vocab-tags" "Vocabulary Tags" { $vocab-tags } ;
-
-: $vocabs-with-tag ( seq -- )
- first tagged values concat [ name>> ] map print-these-vocabs ;
-
-M: vocab-tag article-content ( vocab-tag -- content )
- name>> { $vocabs-with-tag } swap suffix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "vocab-index-all" "All Vocabularies" { $all-vocabs } ;
-ARTICLE: "vocab-index-loaded" "Loaded Vocabularies" { $loaded-vocabs } ;
-ARTICLE: "vocab-index-unloaded" "Unloaded Vocabularies" { $loaded-vocabs } ;
-
-ARTICLE: "vocab-index-core" "Core Vocabularies" { $vocabs-core } ;
-ARTICLE: "vocab-index-basis" "Basis Vocabularies" { $vocabs-basis } ;
-ARTICLE: "vocab-index-extra" "Extra Vocabularies" { $vocabs-extra } ;
-
-ARTICLE: "vocab-indices" "Vocabulary Indices"
- { $subsection "vocab-index-core" }
- { $subsection "vocab-index-basis" }
- { $subsection "vocab-index-extra" }
- { $subsection "vocab-index-all" }
- { $subsection "vocab-index-loaded" }
- { $subsection "vocab-index-unloaded" }
- { $subsection "vocab-authors" }
- { $subsection "vocab-tags" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
From 935a3d20423bc9ffe44636df37f8f6fbd699cc2a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 03:39:05 -0600
Subject: [PATCH 124/126] Give credit
---
basis/tools/vocabs/browser/authors.txt | 1 +
1 file changed, 1 insertion(+)
diff --git a/basis/tools/vocabs/browser/authors.txt b/basis/tools/vocabs/browser/authors.txt
index 1901f27a24..e1907c6d91 100755
--- a/basis/tools/vocabs/browser/authors.txt
+++ b/basis/tools/vocabs/browser/authors.txt
@@ -1 +1,2 @@
Slava Pestov
+Eduardo Cavazos
From b5a51224c2e6a147e4f6d6efa8ed300300717e2e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 22 Nov 2008 03:43:05 -0600
Subject: [PATCH 125/126] Clean up and fix minor issue with words. word
---
basis/tools/vocabs/browser/browser.factor | 28 +++++++++++++----------
1 file changed, 16 insertions(+), 12 deletions(-)
diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor
index 54e03763fc..cfc541d9bc 100644
--- a/basis/tools/vocabs/browser/browser.factor
+++ b/basis/tools/vocabs/browser/browser.factor
@@ -21,9 +21,9 @@ IN: tools.vocabs.browser
: vocab. ( vocab -- )
[
- dup [ write-status ] with-cell
- dup [ ($link) ] with-cell
- [ vocab-summary write ] with-cell
+ [ [ write-status ] with-cell ]
+ [ [ ($link) ] with-cell ]
+ [ [ vocab-summary write ] with-cell ] tri
] with-row ;
: vocab-headings. ( -- )
@@ -39,13 +39,13 @@ IN: tools.vocabs.browser
: $vocabs ( assoc -- )
[
- [
- drop
- ] [
- swap root-heading.
- standard-table-style [
- vocab-headings. [ vocab. ] each
- ] ($grid)
+ [ drop ] [
+ [ root-heading. ]
+ [
+ standard-table-style [
+ vocab-headings. [ vocab. ] each
+ ] ($grid)
+ ] bi*
] if-empty
] assoc-each ;
@@ -201,7 +201,7 @@ C: <vocab-author> vocab-author
[ <$link> 1array ] map $table
] unless-empty ;
-: words. ( vocab -- )
+: describe-words ( vocab -- )
words [
"Words" $heading
@@ -227,6 +227,10 @@ C: <vocab-author> vocab-author
] bi
] unless-empty ;
+: words. ( vocab -- )
+ last-element off
+ vocab-name describe-words ;
+
: describe-metadata ( vocab -- )
[
[ vocab-tags [ "Tags:" swap \ $tags prefix 2array , ] unless-empty ]
@@ -239,7 +243,7 @@ C: <vocab-author> vocab-author
first {
[ describe-help ]
[ describe-metadata ]
- [ words. ]
+ [ describe-words ]
[ describe-files ]
[ describe-children ]
} cleave ;
From e53d02bc5e65e64c8442e8657929114309baf12e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 22 Nov 2008 06:45:12 -0600
Subject: [PATCH 126/126] locals: Allow comments in binding forms
---
basis/locals/locals.factor | 20 ++++++++++++--------
1 file changed, 12 insertions(+), 8 deletions(-)
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index 1e205e10b0..6e7f660a66 100644
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -289,14 +289,18 @@ SYMBOL: in-lambda?
\ ] (parse-lambda) <lambda> ;
: parse-binding ( -- pair/f )
- scan dup "|" = [
- drop f
- ] [
- scan {
- { "[" [ \ ] parse-until >quotation ] }
- { "[|" [ parse-lambda ] }
- } case 2array
- ] if ;
+ scan {
+ { [ dup "|" = ] [ drop f ] }
+ { [ dup "!" = ] [ drop lexer get next-line parse-binding ] }
+ { [ t ]
+ [
+ scan {
+ { "[" [ \ ] parse-until >quotation ] }
+ { "[|" [ parse-lambda ] }
+ } case 2array
+ ]
+ }
+ } cond ;
: (parse-bindings) ( -- )
parse-binding [