Merge branch 'master' of git://factorcode.org/git/factor

basis/io/streams/limited/limited-tests.factor

@@ -1,7 +1,7 @@
-IN: io.streams.limited.tests
 USING: io io.streams.limited io.encodings io.encodings.string
 io.encodings.ascii io.encodings.binary io.streams.byte-array
-namespaces tools.test strings kernel ;
+namespaces tools.test strings kernel io.streams.string accessors ;
+IN: io.streams.limited.tests
 
 [ ] [
     "hello world\nhow are you today\nthis is a very long line indeed"
@@ -38,3 +38,18 @@ namespaces tools.test strings kernel ;
         "l" read-until
     ] with-input-stream
 ] unit-test
+
+[ CHAR: a ]
+[ "a" <string-reader> 1 <limited-stream> stream-read1 ] unit-test
+
+[ "abc" ]
+[
+    "abc" <string-reader> 3 <limited-stream> t >>no-throw?
+    4 swap stream-read
+] unit-test
+
+[ f ]
+[
+    "abc" <string-reader> 3 <limited-stream> t >>no-throw?
+    4 over stream-read drop 10 swap stream-read
+] unit-test

basis/io/streams/limited/limited.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math io io.encodings destructors accessors
-sequences namespaces byte-vectors ;
+sequences namespaces byte-vectors fry ;
 IN: io.streams.limited
 
-TUPLE: limited-stream stream count limit ;
+TUPLE: limited-stream stream count limit no-throw? ;
 
 : <limited-stream> ( stream limit -- stream' )
     limited-stream new
@@ -22,19 +22,30 @@ M: object limit <limited-stream> ;
 
 ERROR: limit-exceeded ;
 
-: check-limit ( n stream -- )
+: adjust-limit ( n stream -- n' stream )
-    [ + ] change-count
+    2dup [ + ] change-count
-    [ count>> ] [ limit>> ] bi >=
+    [ count>> ] [ limit>> ] bi >
-    [ limit-exceeded ] when ; inline
+    [
+        dup no-throw?>> [
+            dup [ count>> ] [ limit>> ] bi -
+            '[ _ - ] dip
+        ] [
+            limit-exceeded
+        ] if
+    ] when ; inline
+
+: maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f )
+    pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline
 
 M: limited-stream stream-read1
-    1 over check-limit stream>> stream-read1 ;
+    1 swap adjust-limit
+    [ nip stream-read1 ] maybe-read ;
 
 M: limited-stream stream-read
-    2dup check-limit stream>> stream-read ;
+    adjust-limit [ stream-read ] maybe-read ;
 
 M: limited-stream stream-read-partial
-    2dup check-limit stream>> stream-read-partial ;
+    adjust-limit [ stream-read-partial ] maybe-read ;
 
 : (read-until) ( stream seps buf -- stream seps buf sep/f )
     3dup [ [ stream-read1 dup ] dip memq? ] dip

basis/mime/multipart/multipart.factor

@@ -1,105 +1,164 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io kernel locals math multiline
+USING: multiline kernel sequences io splitting fry namespaces
-sequences splitting prettyprint namespaces http.parsers
+http.parsers hashtables assocs combinators ascii io.files.unique
-ascii assocs unicode.case io.files.unique io.files io.encodings.binary
+accessors io.encodings.binary io.files byte-arrays math
-byte-arrays io.encodings make fry ;
+io.streams.string combinators.short-circuit strings ;
 IN: mime.multipart
 
-TUPLE: multipart-stream stream n leftover separator ;
+CONSTANT: buffer-size 65536
+CONSTANT: separator-prefix "\r\n--"
 
-: <multipart-stream> ( stream separator -- multipart-stream )
+TUPLE: multipart
-    multipart-stream new
+end-of-stream?
-        swap >>separator
+current-separator mime-separator
-        swap >>stream
+header
-        16 2^ >>n ;
+content-disposition bytes
+filename temp-file
+name name-content
+uploaded-files
+form-variables ;
 
-<PRIVATE
+TUPLE: mime-file headers filename temporary-path ;
+TUPLE: mime-variable headers key value ;
 
-: ?append ( seq1 seq2 -- newseq/seq2 )
+: <multipart> ( mime-separator -- multipart )
-    over [ append ] [ nip ] if ;
+    multipart new
+        swap >>mime-separator
+        H{ } clone >>uploaded-files
+        H{ } clone >>form-variables ;
 
-: ?cut* ( seq n -- before after )
+ERROR: bad-header bytes ;
-    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 seq=? )
+: mime-write ( sequence -- )
-    2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
+    >byte-array write ;
 
-:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
+: parse-headers ( string -- sequence )
-    bytes [ quot unless-empty ]
+    string-lines harvest [ parse-header-line ] map ;
-    [ stream (>>leftover) quot unless-empty ] if-empty f ; inline
 
-:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
+ERROR: end-of-stream multipart ;
-    bytes end-stream? [
+
-        quot unless-empty f
+: fill-bytes ( multipart -- multipart )
+    buffer-size read
+    [ '[ _ append ] change-bytes ]
+    [ t >>end-of-stream? ] if* ;
+
+: maybe-fill-bytes ( multipart -- multipart )
+    dup bytes>> [ fill-bytes ] unless  ;
+
+: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
+    2dup [ length ] [ length 1- ] bi* < [
+        drop f
     ] [
-        separator length 1- ?cut* stream (>>leftover)
+        length 1- cut-slice swap
-        quot unless-empty t
-    ] if ; inline
-
-:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
-    #! return t to loop again
-    bytes separator multipart-split
-    [ 2drop f ]
-    [
-        [ stream quot multipart-step-found ]
-        [ stream end-stream? separator quot multipart-step-not-found ] if*
-    ] if stream leftover>> end-stream? not or >boolean ;
-
-
-:: multipart-step-loop ( stream quot1: ( bytes -- ) -- ? )
-    stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
-    swap [ drop stream quot1 multipart-step-loop ] when ; inline recursive
-
-SYMBOL: header
-SYMBOL: parsed-header
-SYMBOL: magic-separator
-
-: trim-blanks ( str -- str' ) [ blank? ] trim ;
-
-: trim-quotes ( str -- str' )
-    [ [ CHAR: " = ] [ CHAR: ' = ] bi or ] trim ;
-
-: parse-content-disposition ( str -- content-disposition hash )
-    ";" split [ first ] [ rest-slice ] bi [ "=" split ] map
-    [ [ trim-blanks ] [ trim-quotes ] bi* ] H{ } assoc-map-as ;
-
-: parse-multipart-header ( string -- headers )
-    "\r\n" split harvest
-    [ parse-header-line first2 ] H{ } map>assoc ;
-
-ERROR: expected-file ;
-
-TUPLE: uploaded-file path filename name ;
-
-: (parse-multipart) ( stream -- ? )
-    "\r\n\r\n" >>separator
-    header off
-    dup [ header [ prepend ] change ] multipart-step-loop drop
-    header get dup magic-separator get [ length ] bi@ < [
-        2drop f
-    ] [
-        parse-multipart-header
-        parsed-header set
-        "\r\n" magic-separator get append >>separator
-        "factor-upload" "httpd" make-unique-file tuck
-        binary [ [ write ] multipart-step-loop ] with-file-writer swap
-        "content-disposition" parsed-header get at parse-content-disposition
-        nip [ "filename" swap at ] [ "name" swap at ] bi
-        uploaded-file boa ,
     ] if ;
 
-PRIVATE>
+: dump-until-separator ( multipart -- multipart )
+    dup [ current-separator>> ] [ bytes>> ] bi tuck start [
+        cut-slice
+        [ mime-write ]
+        [ over current-separator>> length tail-slice >>bytes ] bi*
+    ] [
+        drop
+        dup [ bytes>> ] [ current-separator>> ] bi split-bytes
+        [ mime-write ] when*
+        >>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
+    ] if* ;
 
-: parse-multipart ( stream -- array )
+: dump-string ( multipart separator -- multipart string )
-    [
+    >>current-separator
-        "\r\n" <multipart-stream>
+    [ dump-until-separator ] with-string-writer ;
-        magic-separator off
+
-        dup [ magic-separator [ prepend ] change ]
+: read-header ( multipart -- multipart )
-            multipart-step-loop drop
+    "\r\n\r\n" dump-string dup "--\r" = [
-        '[ [ _ (parse-multipart) ] loop ] { } make
+        drop
-    ] with-scope ;
+    ] [
+        parse-headers >hashtable >>header
+    ] if ;
+
+: quote? ( ch -- ? ) "'\"" member? ;
+
+: quoted? ( str -- ? )
+    {
+        [ length 1 > ]
+        [ first quote? ]
+        [ [ first ] [ peek ] bi = ]
+    } 1&& ;
+
+: unquote ( string -- string' )
+    dup quoted? [ but-last-slice rest-slice >string ] when ;
+
+: save-uploaded-file ( multipart -- )
+    [ unquote ] change-filename
+    dup filename>> empty? [
+        drop
+    ] [
+        [ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
+        [ filename>> ]
+        [ uploaded-files>> set-at ] tri
+    ] if ;
+
+: save-form-variable ( multipart -- )
+    [ unquote ] change-name
+    [ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
+    [ name>> ]
+    [ form-variables>> set-at ] tri ;
+
+: dump-mime-file ( multipart filename -- multipart )
+    binary <file-writer> [
+        dup mime-separator>> >>current-separator dump-until-separator
+    ] with-output-stream ;
+
+: dump-file ( multipart -- multipart )
+    "factor-" "-upload" make-unique-file
+    [ >>temp-file ] [ dump-mime-file ] bi ;
+
+: parse-content-disposition-form-data ( string -- hashtable )
+    ";" split
+    [ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
+
+: lookup-disposition ( multipart string -- multipart value/f )
+    over content-disposition>> at ;
+
+ERROR: unknown-content-disposition multipart ;
+
+: parse-form-data ( multipart -- multipart )
+    "filename" lookup-disposition [
+        >>filename
+        [ dump-file ] [ save-uploaded-file ] bi
+    ] [
+        "name" lookup-disposition [
+            [ dup mime-separator>> dump-string >>name-content ] dip
+            >>name dup save-form-variable
+        ] [
+             unknown-content-disposition
+        ] if*
+    ] if* ;
+
+ERROR: no-content-disposition multipart ;
+
+: process-header ( multipart -- multipart )
+    "content-disposition" over header>> at ";" split1 swap {
+        { "form-data" [
+            parse-content-disposition-form-data >>content-disposition
+            parse-form-data
+        ] }
+        [ no-content-disposition ]
+    } case ;
+
+: read-assert= ( string -- )
+    [ length read ] keep assert= ;
+
+: parse-beginning ( multipart -- multipart )
+    "--" read-assert=
+    dup mime-separator>>
+    [ read-assert= ]
+    [ separator-prefix prepend >>mime-separator ] bi ;
+
+: parse-multipart-loop ( multipart -- multipart )
+    read-header
+    dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
+
+: parse-multipart ( sep -- uploaded-files form-variables )
+    <multipart> parse-beginning parse-multipart-loop
+    [ uploaded-files>> ] [ form-variables>> ] bi ;

misc/fuel/README

@@ -74,6 +74,9 @@ beast.
 
     - C-cz : switch to listener
     - C-co : cycle between code, tests and docs factor files
+    - C-cs : switch to other factor buffer (M-x fuel-switch-to-buffer)
+    - C-x4s : switch to other factor buffer in other window
+    - C-x5s : switch to other factor buffer in other frame
 
     - M-. : edit word at point in Emacs (see fuel-edit-word-method custom var)
     - M-, : go back to where M-. was last invoked

misc/fuel/fuel-edit.el

@@ -132,6 +132,32 @@ was last invoked."
       (pop-tag-mark)
     (error "No previous location for find word or vocab invokation")))
 
+(defvar fuel-edit--buffer-history nil)
+
+(defun fuel-switch-to-buffer (&optional method)
+  "Switch to any of the existing Factor buffers, with completion."
+  (interactive)
+  (let ((buffer (completing-read "Factor buffer: "
+                                 (remove (buffer-name)
+                                         (mapcar 'buffer-name (buffer-list)))
+                                 '(lambda (s) (string-match "\\.factor$" s))
+                                 t
+                                 nil
+                                 fuel-edit--buffer-history)))
+    (cond ((eq method 'window) (switch-to-buffer-other-window buffer))
+          ((eq method 'frame) (switch-to-buffer-other-frame buffer))
+          (t (switch-to-buffer buffer)))))
+
+(defun fuel-switch-to-buffer-other-window ()
+  "Switch to any of the existing Factor buffers, in other window."
+  (interactive)
+  (fuel-switch-to-buffer 'window))
+
+(defun fuel-switch-to-buffer-other-frame ()
+  "Switch to any of the existing Factor buffers, in other frame."
+  (interactive)
+  (fuel-switch-to-buffer 'frame))
+
 
 (provide 'fuel-edit)
 ;;; fuel-edit.el ends here

misc/fuel/fuel-font-lock.el

@@ -73,18 +73,20 @@
 ;;; Font lock:
 
 (defun fuel-font-lock--syntactic-face (state)
-  (cond ((nth 3 state) 'factor-font-lock-string)
+  (if (nth 3 state) 'factor-font-lock-string
-        ((char-equal (char-after (nth 8 state)) ?\ )
+    (let ((c (char-after (nth 8 state))))
-         (save-excursion
+      (cond ((char-equal c ?\ )
-           (goto-char (nth 8 state))
+             (save-excursion
-           (beginning-of-line)
+               (goto-char (nth 8 state))
-           (cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
+               (beginning-of-line)
-                 ((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
+               (cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
-                  'factor-font-lock-symbol)
+                     ((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
-                 (t 'default))))
+                      'factor-font-lock-symbol)
-        ((char-equal (char-after (nth 8 state)) ?U)
+                     (t 'default))))
-         'factor-font-lock-parsing-word)
+            ((char-equal c ?U) 'factor-font-lock-parsing-word)
-        (t 'factor-font-lock-comment)))
+            ((char-equal c ?\() 'factor-font-lock-stack-effect)
+            ((char-equal c ?\") 'factor-font-lock-string)
+            (t 'factor-font-lock-comment)))))
 
 (defconst fuel-font-lock--font-lock-keywords
   `((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
@@ -135,16 +137,18 @@
 
 ;;; Fontify strings as Factor code:
 
-(defvar fuel-font-lock--font-lock-buffer
+(defun fuel-font-lock--font-lock-buffer ()
-  (let ((buffer (get-buffer-create " *fuel font lock*")))
+  (let ((name " *fuel font lock*"))
-    (set-buffer buffer)
+    (or (get-buffer name)
-    (set-syntax-table fuel-syntax--syntax-table)
+        (let ((buffer (get-buffer-create name)))
-    (fuel-font-lock--font-lock-setup)
+          (set-buffer buffer)
-    buffer))
+          (set-syntax-table fuel-syntax--syntax-table)
+          (fuel-font-lock--font-lock-setup)
+          buffer))))
 
 (defun fuel-font-lock--factor-str (str)
   (save-current-buffer
-    (set-buffer fuel-font-lock--font-lock-buffer)
+    (set-buffer (fuel-font-lock--font-lock-buffer))
     (erase-buffer)
     (insert str)
     (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))

misc/fuel/fuel-mode.el

@@ -177,6 +177,9 @@ interacting with a factor listener is at your disposal.
 (fuel-mode--key-1 ?l 'fuel-run-file)
 (fuel-mode--key-1 ?r 'fuel-eval-region)
 (fuel-mode--key-1 ?z 'run-factor)
+(fuel-mode--key-1 ?s 'fuel-switch-to-buffer)
+(define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window)
+(define-key fuel-mode-map "\C-x5s" 'fuel-switch-to-buffer-other-frame)
 
 (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
 (define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)

misc/fuel/fuel-syntax.el

@@ -240,14 +240,15 @@
 
 (defconst fuel-syntax--syntactic-keywords
   `(;; CHARs:
-    ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
+    ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
     ;; Comments:
     ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
     ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
+    ("\\_<\\((\\) \\([^)\n]*?\\) \\()\\)\\_>" (1 "<b") (2 "w") (3 ">b"))
     ;; Strings
     ("\\_<\\(\"\\)\\([^\n\r\f\"]\\|\\\\\"\\)*\\(\"\\)\\_>" (1 "\"") (3 "\""))
-    ("\\_<<\\(\"\\)\\_>" (1 "\""))
+    ("\\_<<\\(\"\\)\\_>" (1 "<b"))
-    ("\\_<\\(\"\\)>\\_>" (1 "\""))
+    ("\\_<\\(\"\\)>\\_>" (1 ">b"))
     ;; Multiline constructs
     ("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
     ("\\_<USING:\\( \\)" (1 "<b"))

vm/factor.c

@@ -53,8 +53,10 @@ INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
 void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
 {
 	default_parameters(p);
+	const F_CHAR *executable_path = vm_executable_path();
+	p->executable_path = executable_path ? executable_path : argv[0];
 
-	int i;
+	int i = 0;
 
 	for(i = 1; i < argc; i++)
 	{
@@ -107,10 +109,6 @@ void init_factor(F_PARAMETERS *p)
 	if(p->image_path == NULL)
 		p->image_path = default_image_path();
 
-	const F_CHAR *executable_path = vm_executable_path();
-	if(executable_path)
-		p->executable_path = executable_path;
-
 	srand(current_micros());
 	init_ffi();
 	init_stacks(p->ds_size,p->rs_size);