minor cleanups here and there
Slava Pestov
parent
626336915b
commit
6c11b788e0
|
|
@ -26,7 +26,8 @@
|
|||
|
||||
+ ffi:
|
||||
|
||||
- auto-generate box/unbox, and alien accessors
|
||||
- if a boxer triggers GC, already-pushed addresses might become
|
||||
invalid!
|
||||
- box/unbox_signed/unsigned_8
|
||||
- ffi unicode strings: null char security hole
|
||||
- utf16 string boxing
|
||||
|
|
@ -76,7 +77,6 @@
|
|||
- unions containing tuples do not work properly
|
||||
- need G: combinations
|
||||
- method doc strings
|
||||
- make-image: use a list not a vector
|
||||
- code walker & exceptions
|
||||
- string sub-primitives
|
||||
- clean up metaclasses
|
||||
|
|
|
|||
|
|
@ -19,13 +19,13 @@ hashtables ;
|
|||
"/library/collections/sequences.factor"
|
||||
"/library/collections/arrays.factor"
|
||||
"/library/kernel.factor"
|
||||
"/library/collections/cons.factor"
|
||||
"/library/collections/assoc.factor"
|
||||
"/library/math/math.factor"
|
||||
"/library/math/integer.factor"
|
||||
"/library/math/ratio.factor"
|
||||
"/library/math/float.factor"
|
||||
"/library/math/complex.factor"
|
||||
"/library/collections/cons.factor"
|
||||
"/library/collections/assoc.factor"
|
||||
"/library/collections/lists.factor"
|
||||
"/library/collections/vectors.factor"
|
||||
"/library/collections/strings.factor"
|
||||
|
|
@ -33,9 +33,9 @@ hashtables ;
|
|||
"/library/collections/vectors-epilogue.factor"
|
||||
"/library/collections/hashtables.factor"
|
||||
"/library/collections/namespaces.factor"
|
||||
"/library/collections/sbuf.factor"
|
||||
"/library/words.factor"
|
||||
"/library/vocabularies.factor"
|
||||
"/library/collections/sbuf.factor"
|
||||
"/library/errors.factor"
|
||||
"/library/continuations.factor"
|
||||
"/library/threads.factor"
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ t [
|
|||
|
||||
! This has to be loaded here because it overloads sequence
|
||||
! generics, and we don't want to compile twice.
|
||||
"/library/math/matrices.factor"
|
||||
! "/library/math/matrices.factor"
|
||||
|
||||
"/library/tools/debugger.factor"
|
||||
"/library/tools/gensym.factor"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: assembler compiler kernel lists namespaces parser stdio
|
||||
unparser ;
|
||||
USING: assembler compiler kernel lists namespaces parser
|
||||
sequences stdio unparser ;
|
||||
|
||||
"Bootstrap stage 3..." print
|
||||
|
||||
|
|
@ -9,6 +9,7 @@ unparser ;
|
|||
init-assembler
|
||||
\ car compile
|
||||
\ = compile
|
||||
\ length compile
|
||||
\ unparse compile
|
||||
\ scan compile
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -179,7 +179,7 @@ M: f ' ( obj -- ptr )
|
|||
: fixup-words ( -- )
|
||||
image get [
|
||||
dup word? [ fixup-word ] when
|
||||
] vector-map image set ;
|
||||
] seq-map image set ;
|
||||
|
||||
M: word ' ( word -- pointer )
|
||||
transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2003, 2004 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: command-line
|
||||
USING: files kernel lists namespaces parser strings
|
||||
kernel-internals ;
|
||||
USING: files kernel kernel-internals lists namespaces parser
|
||||
sequences strings ;
|
||||
|
||||
! This file is run as the last stage of boot.factor; it relies
|
||||
! on all other words already being defined.
|
||||
|
|
@ -37,7 +37,7 @@ kernel-internals ;
|
|||
#! Handle a command-line argument. If the argument was
|
||||
#! consumed, returns f. Otherwise returns the argument.
|
||||
#! Parameters that start with + are runtime parameters.
|
||||
dup f-or-"" [
|
||||
dup empty? [
|
||||
"-" ?string-head [ cli-param f ] when
|
||||
dup [ "+" ?string-head [ drop f ] when ] when
|
||||
] unless ;
|
||||
|
|
|
|||
|
|
@ -103,21 +103,7 @@ M: cons nth ( n list -- element )
|
|||
|
||||
: all=? ( list -- ? )
|
||||
#! Check if all elements of a list are equal.
|
||||
dup [ uncons [ over = ] all? nip ] [ drop t ] ifte ;
|
||||
|
||||
: maximize ( pred o1 o2 -- o1/o2 )
|
||||
#! Return o1 if pred returns true, o2 otherwise.
|
||||
[ rot call ] 2keep ? ; inline
|
||||
|
||||
: (top) ( list maximizer -- elt )
|
||||
#! Return the highest element in the list, where maximizer
|
||||
#! has stack effect ( o1 o2 -- max(o1,o2) ).
|
||||
>r uncons r> each ; inline
|
||||
|
||||
: top ( list pred -- elt )
|
||||
#! Return the highest element in the list, where pred is a
|
||||
#! partial order with stack effect ( o1 o2 -- ? ).
|
||||
swap [ pick >r maximize r> swap ] (top) nip ; inline
|
||||
[ uncons [ = ] all-with? ] [ t ] ifte* ;
|
||||
|
||||
M: cons = ( obj cons -- ? )
|
||||
2dup eq? [
|
||||
|
|
|
|||
|
|
@ -8,29 +8,24 @@ M: sbuf set-length set-sbuf-length ;
|
|||
M: sbuf nth sbuf-nth ;
|
||||
M: sbuf set-nth set-sbuf-nth ;
|
||||
|
||||
: fill ( count char -- string )
|
||||
#! Push a string that consists of the same character
|
||||
#! repeated.
|
||||
[ swap [ dup , ] times drop ] make-string ;
|
||||
: >sbuf ( seq -- sbuf ) 0 <sbuf> [ swap nappend ] keep ;
|
||||
|
||||
: >string ( seq -- string ) >sbuf sbuf>string ;
|
||||
|
||||
: fill ( count char -- string ) <repeated> >string ;
|
||||
|
||||
: pad ( string count char -- string )
|
||||
>r over string-length - dup 0 <= [
|
||||
>r over length - dup 0 <= [
|
||||
r> 2drop
|
||||
] [
|
||||
r> fill swap cat2
|
||||
r> fill swap seq-append
|
||||
] ifte ;
|
||||
|
||||
: string-map ( str code -- str )
|
||||
#! Apply a quotation to each character in the string, and
|
||||
#! push a new string constructed from return values.
|
||||
#! The quotation must have stack effect ( X -- X ).
|
||||
>r >list r> map cat ; inline
|
||||
|
||||
: split-next ( index string split -- next )
|
||||
3dup index-of* dup -1 = [
|
||||
>r drop string-tail , r> ( end of string )
|
||||
] [
|
||||
swap string-length dupd + >r swap substring , r>
|
||||
swap length dupd + >r swap substring , r>
|
||||
] ifte ;
|
||||
|
||||
: (split) ( index string split -- )
|
||||
|
|
@ -46,10 +41,10 @@ M: sbuf set-nth set-sbuf-nth ;
|
|||
[ 0 -rot (split) ] make-list ;
|
||||
|
||||
: split-n-advance substring , >r tuck + swap r> ;
|
||||
: split-n-finish nip dup string-length swap substring , ;
|
||||
: split-n-finish nip dup length swap substring , ;
|
||||
|
||||
: (split-n) ( start n str -- )
|
||||
3dup >r dupd + r> 2dup string-length < [
|
||||
3dup >r dupd + r> 2dup length < [
|
||||
split-n-advance (split-n)
|
||||
] [
|
||||
split-n-finish 3drop
|
||||
|
|
@ -59,13 +54,7 @@ M: sbuf set-nth set-sbuf-nth ;
|
|||
#! Split a string into n-character chunks.
|
||||
[ 0 -rot (split-n) ] make-list ;
|
||||
|
||||
: ch>string ( ch -- str )
|
||||
1 <sbuf> [ sbuf-append ] keep sbuf>string ;
|
||||
: ch>string ( ch -- str ) 1 <sbuf> [ push ] keep sbuf>string ;
|
||||
|
||||
: >sbuf ( list -- vector ) 0 <sbuf> swap seq-append ;
|
||||
|
||||
: string>sbuf ( str -- sbuf )
|
||||
dup string-length <sbuf> [ sbuf-append ] keep ;
|
||||
|
||||
M: string unfreeze string>sbuf ;
|
||||
M: string unfreeze >sbuf ;
|
||||
M: string freeze drop sbuf>string ;
|
||||
|
|
|
|||
|
|
@ -10,6 +10,12 @@ vectors ;
|
|||
! defined tuples that respond to the sequence protocol.
|
||||
UNION: sequence array string sbuf vector ;
|
||||
|
||||
M: object ensure-capacity 2drop ;
|
||||
M: object unfreeze clone ;
|
||||
M: object freeze drop ;
|
||||
|
||||
: empty? ( seq -- ? ) length 0 = ;
|
||||
|
||||
: (>list) ( n i seq -- list )
|
||||
pick pick <= [
|
||||
3drop [ ]
|
||||
|
|
@ -173,7 +179,7 @@ M: sequence = ( obj seq -- ? )
|
|||
] ifte ;
|
||||
|
||||
! A repeated sequence is the same element n times.
|
||||
TUPLE: repeated object length ;
|
||||
TUPLE: repeated length object ;
|
||||
M: repeated length repeated-length ;
|
||||
M: repeated nth nip repeated-object ;
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,3 @@ GENERIC: set-nth ( value n sequence -- obj )
|
|||
GENERIC: >list ( seq -- list )
|
||||
GENERIC: unfreeze ( seq -- mutable-seq )
|
||||
GENERIC: freeze ( new orig -- new )
|
||||
|
||||
M: object ensure-capacity 2drop ;
|
||||
M: object unfreeze ;
|
||||
M: object freeze drop ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: strings USING: generic kernel kernel-internals lists math
|
||||
sequences ;
|
||||
|
||||
BUILTIN: string 12 [ 1 "string-length" f ] [ 2 hashcode f ] ;
|
||||
BUILTIN: string 12 [ 1 length f ] [ 2 hashcode f ] ;
|
||||
M: string = string= ;
|
||||
|
||||
BUILTIN: sbuf 13 ;
|
||||
|
|
@ -11,20 +11,11 @@ M: sbuf = sbuf= ;
|
|||
|
||||
UNION: text string integer ;
|
||||
|
||||
M: string length string-length ;
|
||||
M: string nth string-nth ;
|
||||
|
||||
: f-or-"" ( obj -- ? )
|
||||
dup not swap "" = or ;
|
||||
|
||||
: string-length< ( str str -- boolean )
|
||||
#! Compare string lengths.
|
||||
swap string-length swap string-length < ;
|
||||
|
||||
: cat ( [ "a" "b" "c" ] -- "abc" )
|
||||
! If f appears in the list, it is not appended to the
|
||||
! string.
|
||||
80 <sbuf> swap [ [ over sbuf-append ] when* ] each sbuf>string ;
|
||||
: length< ( seq seq -- ? )
|
||||
#! Compare sequence lengths.
|
||||
swap length swap length < ;
|
||||
|
||||
: cat2 ( "a" "b" -- "ab" )
|
||||
swap
|
||||
|
|
@ -42,6 +33,9 @@ M: string nth string-nth ;
|
|||
: index-of ( string substring -- index )
|
||||
0 -rot index-of* ;
|
||||
|
||||
: string-contains? ( substr str -- ? )
|
||||
swap index-of -1 = not ;
|
||||
|
||||
: string> ( str1 str2 -- ? )
|
||||
! Returns if the first string lexicographically follows str2
|
||||
string-compare 0 > ;
|
||||
|
|
@ -51,13 +45,10 @@ M: string nth string-nth ;
|
|||
#! until the given index.
|
||||
0 -rot substring ;
|
||||
|
||||
: string-contains? ( substr str -- ? )
|
||||
swap index-of -1 = not ;
|
||||
|
||||
: string-tail ( index str -- str )
|
||||
#! Returns a new string, from the given index until the end
|
||||
#! of the string.
|
||||
[ string-length ] keep substring ;
|
||||
[ length ] keep substring ;
|
||||
|
||||
: string/ ( str index -- str str )
|
||||
#! Returns 2 strings, that when concatenated yield the
|
||||
|
|
@ -71,29 +62,29 @@ M: string nth string-nth ;
|
|||
[ swap string-head ] 2keep 1 + swap string-tail ;
|
||||
|
||||
: string-head? ( str begin -- ? )
|
||||
2dup string-length< [
|
||||
2dup length< [
|
||||
2drop f
|
||||
] [
|
||||
dup string-length rot string-head =
|
||||
dup length rot string-head =
|
||||
] ifte ;
|
||||
|
||||
: ?string-head ( str begin -- str ? )
|
||||
2dup string-head? [
|
||||
string-length swap string-tail t
|
||||
length swap string-tail t
|
||||
] [
|
||||
drop f
|
||||
] ifte ;
|
||||
|
||||
: string-tail? ( str end -- ? )
|
||||
2dup string-length< [
|
||||
2dup length< [
|
||||
2drop f
|
||||
] [
|
||||
dup string-length pick string-length swap - rot string-tail =
|
||||
dup length pick length swap - rot string-tail =
|
||||
] ifte ;
|
||||
|
||||
: ?string-tail ( str end -- ? )
|
||||
: ?string-tail ( str end -- str ? )
|
||||
2dup string-tail? [
|
||||
string-length swap [ string-length swap - ] keep string-head t
|
||||
length swap [ length swap - ] keep string-head t
|
||||
] [
|
||||
drop f
|
||||
] ifte ;
|
||||
|
|
@ -102,7 +93,7 @@ M: string nth string-nth ;
|
|||
2dup index-of dup -1 = [
|
||||
2drop f
|
||||
] [
|
||||
[ swap string-length + over string-tail ] keep
|
||||
[ swap length + over string-tail ] keep
|
||||
rot string-head swap
|
||||
] ifte ;
|
||||
|
||||
|
|
@ -124,3 +115,5 @@ PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
|
|||
over LETTER? or
|
||||
over digit? or
|
||||
swap "/_?." string-contains? or ;
|
||||
|
||||
: string-length ( deprecated ) length ;
|
||||
|
|
|
|||
|
|
@ -5,19 +5,7 @@ math-internals sequences ;
|
|||
|
||||
IN: vectors
|
||||
|
||||
: >vector ( list -- vector )
|
||||
dup length <vector> swap [ over push ] seq-each ;
|
||||
|
||||
: vector-map ( vector code -- vector )
|
||||
#! Applies code to each element of the vector, return a new
|
||||
#! vector with the results. The code must have stack effect
|
||||
#! ( obj -- obj ).
|
||||
>r >list r> map >vector ; inline
|
||||
|
||||
: vector-append ( v1 v2 -- vec )
|
||||
over length over length + <vector>
|
||||
[ rot nappend ] keep
|
||||
[ swap nappend ] keep ;
|
||||
: >vector ( list -- vector ) 0 <vector> [ swap nappend ] keep ;
|
||||
|
||||
: vector-project ( n quot -- vector )
|
||||
#! Execute the quotation n times, passing the loop counter
|
||||
|
|
|
|||
|
|
@ -69,9 +69,9 @@ errors unparser logging listener url-encoding hashtables memory ;
|
|||
: write-editable-word-source ( vocab word -- )
|
||||
#! Write the source in a manner allowing it to be edited.
|
||||
<textarea name= "eval" rows= "30" cols= "80" textarea>
|
||||
1024 <string-output> dup >r [
|
||||
[
|
||||
>r words r> swap [ over swap dup word-name rot = [ see ] [ drop ] ifte ] each drop
|
||||
] with-stream r> stream>str chars>entities write
|
||||
] with-string chars>entities write
|
||||
</textarea> <br/>
|
||||
"Accept" button ;
|
||||
|
||||
|
|
|
|||
|
|
@ -199,11 +199,6 @@ SYMBOL: callback-cc
|
|||
store-callback-cc
|
||||
] callcc0 ;
|
||||
|
||||
: with-string-stream ( quot -- string )
|
||||
#! Call the quotation with standard output bound to a string output
|
||||
#! stream. Return the string on exit.
|
||||
1024 <string-output> dup >r swap with-stream r> stream>str ;
|
||||
|
||||
: forward-to-url ( url -- )
|
||||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
|
|
@ -242,7 +237,7 @@ SYMBOL: callback-cc
|
|||
store-callback-cc redirect-to-here
|
||||
[
|
||||
expirable register-continuation id>url swap
|
||||
\ serving-html swons with-string-stream call-exit-continuation
|
||||
\ serving-html swons with-string call-exit-continuation
|
||||
] callcc1
|
||||
nip ;
|
||||
|
||||
|
|
@ -254,7 +249,7 @@ SYMBOL: callback-cc
|
|||
#! use is an optimisation to save having to generate and save a continuation
|
||||
#! in that special case.
|
||||
store-callback-cc redirect-to-here
|
||||
\ serving-html swons with-string-stream call-exit-continuation ;
|
||||
\ serving-html swons with-string call-exit-continuation ;
|
||||
|
||||
#! Name of variable for holding initial continuation id that starts
|
||||
#! the responder.
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: html
|
||||
USING: lists kernel namespaces stdio streams strings unparser
|
||||
url-encoding presentation generic ;
|
||||
USING: generic kernel lists namespaces presentation sequences
|
||||
stdio streams strings unparser url-encoding ;
|
||||
|
||||
: html-entities ( -- alist )
|
||||
[
|
||||
|
|
@ -18,10 +18,14 @@ url-encoding presentation generic ;
|
|||
|
||||
: chars>entities ( str -- str )
|
||||
#! Convert <, >, &, ' and " to HTML entities.
|
||||
[ dup html-entities assoc dup rot ? ] string-map ;
|
||||
[
|
||||
[
|
||||
dup html-entities assoc [ % ] [ , ] ?ifte
|
||||
] seq-each
|
||||
] make-string ;
|
||||
|
||||
: >hex-color ( triplet -- hex )
|
||||
[ CHAR: # , [ >hex 2 "0" pad % ] each ] make-string ;
|
||||
[ CHAR: # , [ >hex 2 CHAR: 0 pad % ] each ] make-string ;
|
||||
|
||||
: fg-css, ( color -- )
|
||||
"color: " , >hex-color , "; " , ;
|
||||
|
|
|
|||
|
|
@ -1,43 +1,7 @@
|
|||
! :folding=indent:collapseFolds=1:
|
||||
|
||||
! $Id$
|
||||
!
|
||||
! Copyright (C) 2003, 2004 Slava Pestov.
|
||||
! Copyright (C) 2004 Chris Double.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
! Copyright (C) 2003, 2005 Slava Pestov, Chris Double
|
||||
IN: httpd
|
||||
USE: kernel
|
||||
USE: lists
|
||||
USE: logging
|
||||
USE: namespaces
|
||||
USE: parser
|
||||
USE: stdio
|
||||
USE: streams
|
||||
USE: strings
|
||||
USE: unparser
|
||||
|
||||
USE: url-encoding
|
||||
USING: kernel lists logging namespaces parser sequences stdio
|
||||
strings url-encoding ;
|
||||
|
||||
: print-header ( alist -- )
|
||||
[ unswons write ": " write url-encode print ] each ;
|
||||
|
|
@ -87,7 +51,7 @@ USE: url-encoding
|
|||
|
||||
: (read-header) ( alist -- alist )
|
||||
read-line dup
|
||||
f-or-"" [ drop ] [ header-line (read-header) ] ifte ;
|
||||
empty? [ drop ] [ header-line (read-header) ] ifte ;
|
||||
|
||||
: read-header ( -- alist )
|
||||
[ ] (read-header) ;
|
||||
|
|
|
|||
|
|
@ -1,41 +1,8 @@
|
|||
! :folding=indent:collapseFolds=1:
|
||||
|
||||
! $Id$
|
||||
!
|
||||
! Copyright (C) 2004 Slava Pestov.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: httpd-responder
|
||||
|
||||
USE: hashtables
|
||||
USE: httpd
|
||||
USE: kernel
|
||||
USE: lists
|
||||
USE: logging
|
||||
USE: namespaces
|
||||
USE: stdio
|
||||
USE: streams
|
||||
USE: strings
|
||||
USING: hashtables httpd kernel logging namespaces sequences
|
||||
strings ;
|
||||
|
||||
! Responders are called in a new namespace with these
|
||||
! variables:
|
||||
|
|
@ -82,7 +49,7 @@ USE: strings
|
|||
get-responder "default" "httpd-responders" get set-hash ;
|
||||
|
||||
: responder-argument ( argument -- argument )
|
||||
dup f-or-"" [ drop "default-argument" get ] when ;
|
||||
dup empty? [ drop "default-argument" get ] when ;
|
||||
|
||||
: call-responder ( method argument responder -- )
|
||||
[ responder-argument swap get call ] bind ;
|
||||
|
|
|
|||
|
|
@ -1,46 +1,19 @@
|
|||
! :folding=indent:collapseFolds=1:
|
||||
|
||||
! $Id$
|
||||
!
|
||||
! Copyright (C) 2004 Slava Pestov.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: url-encoding
|
||||
USE: errors
|
||||
USE: kernel
|
||||
USE: lists
|
||||
USE: math
|
||||
USE: namespaces
|
||||
USE: parser
|
||||
USE: strings
|
||||
USE: unparser
|
||||
USING: errors kernel math namespaces parser sequences strings
|
||||
unparser ;
|
||||
|
||||
: url-encode ( str -- str )
|
||||
[
|
||||
dup url-quotable? [
|
||||
"%" swap >hex 2 "0" pad cat2
|
||||
] unless
|
||||
] string-map ;
|
||||
[
|
||||
dup url-quotable? [
|
||||
,
|
||||
] [
|
||||
CHAR: % , >hex 2 CHAR: 0 pad %
|
||||
] ifte
|
||||
] seq-each
|
||||
] make-string ;
|
||||
|
||||
: catch-hex> ( str -- n )
|
||||
#! Push f if string is not a valid hex literal.
|
||||
|
|
|
|||
|
|
@ -5,15 +5,14 @@ USING: errors generic interpreter kernel lists math namespaces
|
|||
sequences strings vectors words hashtables prettyprint ;
|
||||
|
||||
: longest-vector ( list -- length )
|
||||
[ vector-length ] map [ > ] top ;
|
||||
0 swap [ length max ] each ;
|
||||
|
||||
: computed-value-vector ( n -- vector )
|
||||
[ drop object <computed> ] vector-project ;
|
||||
|
||||
: add-inputs ( count stack -- stack )
|
||||
#! Add this many inputs to the given stack.
|
||||
[ vector-length - computed-value-vector ] keep
|
||||
vector-append ;
|
||||
[ length - computed-value-vector ] keep seq-append ;
|
||||
|
||||
: unify-lengths ( list -- list )
|
||||
#! Pad all vectors to the same length. If one vector is
|
||||
|
|
@ -38,7 +37,7 @@ sequences strings vectors words hashtables prettyprint ;
|
|||
: unify-stacks ( list -- stack )
|
||||
#! Replace differing literals in stacks with unknown
|
||||
#! results.
|
||||
unify-lengths vector-transpose [ unify-results ] vector-map ;
|
||||
unify-lengths vector-transpose [ unify-results ] seq-map ;
|
||||
|
||||
: balanced? ( list -- ? )
|
||||
#! Check if a list of [[ instack outstack ]] pairs is
|
||||
|
|
@ -83,17 +82,17 @@ SYMBOL: cloned
|
|||
dup clone [ swap cloned [ acons ] change ] keep
|
||||
] ?ifte ;
|
||||
|
||||
: deep-clone-vector ( vector -- vector )
|
||||
#! Clone a vector of vectors.
|
||||
[ deep-clone ] vector-map ;
|
||||
: deep-clone-seq ( seq -- seq )
|
||||
#! Clone a sequence and each object it contains.
|
||||
[ deep-clone ] seq-map ;
|
||||
|
||||
: copy-inference ( -- )
|
||||
#! We avoid cloning the same object more than once in order
|
||||
#! to preserve identity structure.
|
||||
cloned off
|
||||
meta-r [ deep-clone-vector ] change
|
||||
meta-d [ deep-clone-vector ] change
|
||||
d-in [ deep-clone-vector ] change
|
||||
meta-r [ deep-clone-seq ] change
|
||||
meta-d [ deep-clone-seq ] change
|
||||
d-in [ deep-clone-seq ] change
|
||||
dataflow-graph off ;
|
||||
|
||||
: infer-branch ( value -- namespace )
|
||||
|
|
|
|||
|
|
@ -104,14 +104,11 @@ M: computed literal-value ( value -- )
|
|||
2drop f
|
||||
] ifte ;
|
||||
|
||||
: vector-prepend ( values stack -- stack )
|
||||
>r >vector r> vector-append ;
|
||||
|
||||
: ensure-d ( typelist -- )
|
||||
dup meta-d get ensure-types
|
||||
meta-d get required-inputs dup
|
||||
meta-d [ vector-prepend ] change
|
||||
d-in [ vector-prepend ] change ;
|
||||
meta-d get required-inputs >vector dup
|
||||
meta-d [ seq-append ] change
|
||||
d-in [ seq-append ] change ;
|
||||
|
||||
: (present-effect) ( vector -- list )
|
||||
>list [ value-class ] map ;
|
||||
|
|
|
|||
|
|
@ -25,9 +25,7 @@ SYMBOL: stdio
|
|||
: with-string ( quot -- str )
|
||||
#! Execute a quotation, and push a string containing all
|
||||
#! text printed by the quotation.
|
||||
1024 <string-output> [
|
||||
call stdio get stream>str
|
||||
] with-stream ;
|
||||
1024 <sbuf> [ call stdio get sbuf>string ] with-stream ;
|
||||
|
||||
TUPLE: stdio-stream ;
|
||||
C: stdio-stream ( stream -- stream ) [ set-delegate ] keep ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
IN: stdio
|
||||
DEFER: stdio
|
||||
IN: streams
|
||||
USING: errors generic kernel lists math namespaces strings ;
|
||||
USING: errors generic kernel lists math namespaces sequences
|
||||
strings ;
|
||||
|
||||
! Stream protocol.
|
||||
GENERIC: stream-flush ( stream -- )
|
||||
|
|
@ -15,7 +16,7 @@ GENERIC: stream-close ( stream -- )
|
|||
|
||||
: stream-read1 ( stream -- char/f )
|
||||
1 swap stream-read
|
||||
dup f-or-"" [ drop f ] [ 0 swap string-nth ] ifte ;
|
||||
dup empty? [ drop f ] [ 0 swap string-nth ] ifte ;
|
||||
|
||||
: stream-write ( string stream -- )
|
||||
f swap stream-write-attr ;
|
||||
|
|
@ -34,24 +35,11 @@ M: null-stream stream-read 2drop f ;
|
|||
M: null-stream stream-write-attr 3drop ;
|
||||
M: null-stream stream-close drop ;
|
||||
|
||||
! A stream that builds a string of all text written to it.
|
||||
TUPLE: string-output buf ;
|
||||
|
||||
M: string-output stream-write-attr ( string style stream -- )
|
||||
nip string-output-buf sbuf-append ;
|
||||
|
||||
M: string-output stream-close ( stream -- ) drop ;
|
||||
M: string-output stream-flush ( stream -- ) drop ;
|
||||
M: string-output stream-auto-flush ( stream -- ) drop ;
|
||||
|
||||
: stream>str ( stream -- string )
|
||||
#! Returns the string written to the given string output
|
||||
#! stream.
|
||||
string-output-buf sbuf>string ;
|
||||
|
||||
C: string-output ( size -- stream )
|
||||
#! Creates a new stream for writing to a string buffer.
|
||||
[ >r <sbuf> r> set-string-output-buf ] keep ;
|
||||
! String buffers support the stream output protocol.
|
||||
M: sbuf stream-write-attr nip sbuf-append ;
|
||||
M: sbuf stream-close drop ;
|
||||
M: sbuf stream-flush drop ;
|
||||
M: sbuf stream-auto-flush drop ;
|
||||
|
||||
! Sometimes, we want to have a delegating stream that uses stdio
|
||||
! words.
|
||||
|
|
@ -112,4 +100,4 @@ SYMBOL: parser-stream
|
|||
: <actions> ( path alist -- alist )
|
||||
#! For each element of the alist, change the value to
|
||||
#! path " " value
|
||||
[ uncons >r over " " r> cat3 cons ] map nip ;
|
||||
[ uncons >r swap " " r> seq-append3 cons ] map-with ;
|
||||
|
|
|
|||
|
|
@ -81,10 +81,6 @@ TUPLE: row index matrix ;
|
|||
M: row length row-matrix matrix-cols ;
|
||||
M: row nth ( n row -- ) >row< matrix-get ;
|
||||
|
||||
! These will be removed after seq-2each is fixed and v. is redone
|
||||
M: row set-nth ( value n row -- ) >row< matrix-set ;
|
||||
M: row clone >vector ;
|
||||
|
||||
! A sequence of rows.
|
||||
TUPLE: row-seq matrix ;
|
||||
M: row-seq length row-seq-matrix matrix-rows ;
|
||||
|
|
@ -96,10 +92,6 @@ TUPLE: col index matrix ;
|
|||
M: col length col-matrix matrix-rows ;
|
||||
M: col nth ( n column -- ) >col< swapd matrix-get ;
|
||||
|
||||
! These will be removed after seq-2each is fixed and v. is redone
|
||||
M: col set-nth ( value n column ) >col< matrix-set ;
|
||||
M: col clone >vector ;
|
||||
|
||||
! A sequence of columns.
|
||||
TUPLE: col-seq matrix ;
|
||||
M: col-seq length col-seq-matrix matrix-cols ;
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ BUILTIN: f 9 ; : f f swons ; parsing
|
|||
|
||||
: " parse-string swons ; parsing
|
||||
|
||||
: SBUF" skip-blank parse-string string>sbuf swons ; parsing
|
||||
: SBUF" skip-blank parse-string >sbuf swons ; parsing
|
||||
|
||||
! Comments
|
||||
: (
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ M: word prettyprint* ( indent word -- indent )
|
|||
|
||||
: indent ( indent -- )
|
||||
#! Print the given number of spaces.
|
||||
" " fill write ;
|
||||
CHAR: \s fill write ;
|
||||
|
||||
: prettyprint-newline ( indent -- )
|
||||
"\n" write indent ;
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@ M: complex unparse ( num -- str )
|
|||
] assoc ;
|
||||
|
||||
: ch>unicode-escape ( ch -- esc )
|
||||
>hex 4 "0" pad "\\u" swap cat2 ;
|
||||
>hex 4 CHAR: 0 pad "\\u" swap cat2 ;
|
||||
|
||||
: unparse-ch ( ch -- ch/str )
|
||||
dup quotable? [
|
||||
|
|
|
|||
|
|
@ -3,9 +3,9 @@ USING: kernel namespaces sequences strings test ;
|
|||
|
||||
[ "Hello" ] [
|
||||
100 <sbuf> "buf" set
|
||||
"Hello" "buf" get sbuf-append
|
||||
"Hello" "buf" get nappend
|
||||
"buf" get sbuf-clone "buf-clone" set
|
||||
"World" "buf-clone" get sbuf-append
|
||||
"World" "buf-clone" get nappend
|
||||
"buf" get sbuf>string
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -8,10 +8,6 @@ USE: namespaces
|
|||
USE: strings
|
||||
USE: test
|
||||
|
||||
[ f ] [ "A string." f-or-"" ] unit-test
|
||||
[ t ] [ "" f-or-"" ] unit-test
|
||||
[ t ] [ f f-or-"" ] unit-test
|
||||
|
||||
[ "abc" ] [ [ "a" "b" "c" ] cat ] unit-test
|
||||
|
||||
[ "abc" ] [ "ab" "c" cat2 ] unit-test
|
||||
|
|
@ -90,7 +86,7 @@ unit-test
|
|||
[ "Replacing+spaces+with+plus" ]
|
||||
[
|
||||
"Replacing spaces with plus"
|
||||
[ dup CHAR: \s = [ drop CHAR: + ] when ] string-map
|
||||
[ dup CHAR: \s = [ drop CHAR: + ] when ] seq-map
|
||||
]
|
||||
unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ sequences strings test vectors ;
|
|||
[ { 1 2 } ] [ [ 1 2 ] >vector ] unit-test
|
||||
|
||||
[ t ] [
|
||||
100 empty-vector [ drop 0 100 random-int ] vector-map
|
||||
100 empty-vector [ drop 0 100 random-int ] seq-map
|
||||
dup >list >vector =
|
||||
] unit-test
|
||||
|
||||
|
|
@ -37,7 +37,7 @@ sequences strings test vectors ;
|
|||
[ [ 1 4 9 16 ] ]
|
||||
[
|
||||
[ 1 2 3 4 ]
|
||||
>vector [ dup * ] vector-map >list
|
||||
>vector [ dup * ] seq-map >list
|
||||
] unit-test
|
||||
|
||||
[ t ] [ { } hashcode { } hashcode = ] unit-test
|
||||
|
|
@ -45,8 +45,8 @@ sequences strings test vectors ;
|
|||
[ t ] [ { 1 { 2 } 3 } hashcode { 1 { 2 } 3 } hashcode = ] unit-test
|
||||
[ t ] [ { } hashcode { } hashcode = ] unit-test
|
||||
|
||||
[ { 1 2 3 4 5 6 } ]
|
||||
[ { 1 2 3 } { 4 5 6 } vector-append ] unit-test
|
||||
[ { 1 2 3 } { 1 2 3 4 5 6 } ]
|
||||
[ { 1 2 3 } dup { 4 5 6 } seq-append ] unit-test
|
||||
|
||||
[ { "" "a" "aa" "aaa" } ]
|
||||
[ 4 [ CHAR: a fill ] vector-project ]
|
||||
|
|
|
|||
|
|
@ -95,14 +95,14 @@ M: no-method error. ( error -- )
|
|||
|
||||
: parse-dump ( error -- )
|
||||
[
|
||||
"Parsing " ,
|
||||
dup parse-error-file [ "<interactive>" ] unless* , ":" ,
|
||||
"Parsing " %
|
||||
dup parse-error-file [ "<interactive>" ] unless* % ":" %
|
||||
dup parse-error-line [ 1 ] unless* unparse ,
|
||||
] make-string print
|
||||
|
||||
dup parse-error-text dup string? [ print ] [ drop ] ifte
|
||||
|
||||
[ parse-error-col " " fill , "^" , ] make-string print ;
|
||||
[ parse-error-col CHAR: \s fill % "^" % ] make-string print ;
|
||||
|
||||
M: parse-error error. ( error -- )
|
||||
dup parse-dump delegate error. ;
|
||||
|
|
|
|||
|
|
@ -1,40 +1,30 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: dump
|
||||
USING: alien assembler generic kernel kernel-internals math
|
||||
memory sequences stdio strings unparser ;
|
||||
USING: alien assembler generic kernel kernel-internals lists
|
||||
math memory sequences stdio strings unparser ;
|
||||
|
||||
: cell. >hex cell 2 * CHAR: 0 pad write ;
|
||||
|
||||
TUPLE: integer-slot-seq object ;
|
||||
|
||||
M: integer-slot-seq length
|
||||
integer-slot-seq-object size cell / ;
|
||||
|
||||
M: integer-slot-seq nth
|
||||
integer-slot-seq-object swap >fixnum integer-slot ;
|
||||
|
||||
: slot@ ( address n -- n ) cell * swap 7 bitnot bitand + ;
|
||||
|
||||
: dump-line ( address n value -- )
|
||||
>r slot@ cell. ": " write r> cell. terpri ;
|
||||
|
||||
: (dump) ( address sequence -- )
|
||||
0 swap [ 2dup dump-line 1 + ] seq-each 2drop ;
|
||||
: (dump) ( address list -- )
|
||||
0 swap [ >r 2dup r> dump-line 1 + ] each 2drop ;
|
||||
|
||||
TUPLE: alien-seq alien length ;
|
||||
|
||||
M: alien-seq length
|
||||
alien-seq-length ;
|
||||
|
||||
M: alien-seq nth
|
||||
alien-seq-alien swap cell * alien-unsigned-4 ;
|
||||
: integer-slots ( obj -- list )
|
||||
dup size cell / [ integer-slot ] project-with ;
|
||||
|
||||
: dump ( obj -- )
|
||||
#! Dump an object's memory.
|
||||
dup address <integer-slot-seq> (dump) ;
|
||||
dup address swap integer-slots (dump) ;
|
||||
|
||||
: alien-slots ( address length -- list )
|
||||
cell / [ cell * alien-unsigned-4 ] project-with ;
|
||||
|
||||
: dump* ( alien len -- )
|
||||
#! Dump an alien's memory.
|
||||
dup string? [ c-size ] when
|
||||
>r [ alien-address ] keep r> <alien-seq> (dump) ;
|
||||
>r [ alien-address ] keep r> alien-slots (dump) ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Strings are shapes too. This is somewhat of a hack and strings
|
||||
! do not have x/y co-ordinates.
|
||||
IN: gadgets
|
||||
USING: alien hashtables kernel lists namespaces sdl streams
|
||||
strings ;
|
||||
USING: alien hashtables kernel lists namespaces sdl sequences
|
||||
streams strings ;
|
||||
|
||||
SYMBOL: fonts
|
||||
|
||||
|
|
@ -52,7 +52,7 @@ global [
|
|||
|
||||
: filter-nulls ( str -- str )
|
||||
"\0" over string-contains? [
|
||||
[ dup CHAR: \0 = [ drop CHAR: \s ] when ] string-map
|
||||
[ dup CHAR: \0 = [ drop CHAR: \s ] when ] seq-map
|
||||
] when ;
|
||||
|
||||
: size-string ( font text -- w h )
|
||||
|
|
|
|||
|
|
@ -140,7 +140,7 @@ M: reader stream-close ( stream -- ) port-handle close ;
|
|||
dup buffer-pop dup CHAR: \n = [
|
||||
3drop t
|
||||
] [
|
||||
pick sbuf-append read-line-loop
|
||||
pick push read-line-loop
|
||||
] ifte
|
||||
] ifte ;
|
||||
|
||||
|
|
@ -205,9 +205,9 @@ M: reader stream-readln ( stream -- line )
|
|||
: read-count-step ( count reader -- ? )
|
||||
dup reader-line -rot >r over length - r>
|
||||
2dup buffer-fill <= [
|
||||
buffer> swap sbuf-append t
|
||||
buffer> swap nappend t
|
||||
] [
|
||||
buffer>> nip swap sbuf-append f
|
||||
buffer>> nip swap nappend f
|
||||
] ifte ;
|
||||
|
||||
: can-read-count? ( count reader -- ? )
|
||||
|
|
|
|||
Loading…
Reference in New Issue