steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

redid HTML tags; tweaked continuations to infer properly

cvs
Slava Pestov 2005-09-23 01:01:55 +00:00
parent a838821556
commit b4b1e3d1a6
15 changed files with 113 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
TODO.FACTOR.txt
View File

@ -1,5 +1,6 @@
- nodes: lazily create history, class/literal map hashes
- write tests for callcc and catch inference
- 5 car gives wrong error
- compile interruption checks
+ ui:

2
library/bootstrap/boot-stage1.factor
View File

@ -64,8 +64,8 @@ sequences io vectors words ;
"/library/words.factor"
"/library/vocabularies.factor"
"/library/errors.factor"
"/library/continuations.factor"
"/library/errors.factor"
"/library/styles.factor"
"/library/io/stream.factor"

58
library/continuations.factor
View File

@ -1,7 +1,13 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: errors
USING: kernel-internals ;
: catchstack ( -- cs ) 6 getenv ;
: set-catchstack ( cs -- ) 6 setenv ;
IN: kernel
USING: arrays errors lists namespaces sequences words vectors ;
USING: namespaces sequences ;
TUPLE: continuation data c call name catch ;
@ -26,6 +32,32 @@ TUPLE: continuation data c call name catch ;
[ continuation-name ] keep
continuation-catch ; inline
: ifcc ( terminator balance -- | quot: continuation -- )
[
t continuation
dup continuation-data dup pop* f swap push
swap >r -rot r>
] call -rot ifte ; inline
: infer-only ( quot -- )
#! For stack effect inference, pretend the quotation is
#! there, but ignore it during execution.
drop ;
: (callcc0) ( -- ) [ drop ] infer-only ; inline
: (callcc1) ( -- value ) (callcc0) 9 getenv ; inline
: callcc1 ( quot -- | quot: continuation -- )
#! Call a quotation with the current continuation, which may
#! be restored using continue-with.
[ (callcc1) ] ifcc ; inline
: callcc0 ( quot -- | quot: continuation -- )
#! Call a quotation with the current continuation, which may
#! be restored using continue-with.
[ (callcc0) ] ifcc ; inline
: continue ( continuation -- )
#! Restore a continuation.
>continuation< set-catchstack set-namestack set-callstack
@ -34,26 +66,4 @@ TUPLE: continuation data c call name catch ;
: continue-with ( object continuation -- object )
#! Restore a continuation, and place the object in the
#! restored data stack.
>continuation< set-catchstack set-namestack set-callstack
>r swap >r set-datastack r> r> set-c-stack ;
: (callcc) ( terminator balance -- | quot: continuation -- )
#! Direct calls to this word will not compile correctly;
#! use callcc0 or callcc1 to declare continuation arity
#! instead. The terminator branch always executes. It might
#! contain a call to 'continue', which ends control flow.
#! The balance branch is never called, but it is there to
#! give the callcc form a stack effect.
>r >r
continuation dup continuation-call dup pop* pop*
t r> r> ifte ; inline
: callcc0 ( quot -- | quot: continuation -- )
#! Call a quotation with the current continuation, which may
#! be restored using continue.
[ drop ] (callcc) ; inline
: callcc1 ( quot -- | quot: continuation -- )
#! Call a quotation with the current continuation, which may
#! be restored using continue-with.
[ ] (callcc) ; inline
swap 9 setenv continue ; inline

23
library/errors.factor
View File

@ -1,11 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel
DEFER: callcc1
DEFER: continue-with
IN: errors
USING: kernel-internals lists sequences ;
USING: kernel kernel-internals lists sequences ;
! This is a very lightweight exception handling system.
@ -13,9 +9,6 @@ TUPLE: no-method object generic ;
: no-method ( object generic -- ) <no-method> throw ;
: catchstack ( -- cs ) 6 getenv ;
: set-catchstack ( cs -- ) 6 setenv ;
: >c ( catch -- ) catchstack cons set-catchstack ;
: c> ( catch -- ) catchstack uncons set-catchstack ;
@ -28,25 +21,23 @@ TUPLE: no-method object generic ;
: rethrow ( error -- )
#! Use rethrow when passing an error on from a catch block.
catchstack empty? [
die "Can't happen" throw
] [
c> continue-with
] ifte ;
catchstack empty?
[ die "Can't happen" throw ] [ c> continue-with ] ifte ;
: cleanup ( try cleanup -- | try: -- | cleanup: -- )
#! Call the try quotation. If an exception is thrown in the
#! dynamic extent of the quotation, restore the datastack
#! and run the cleanup quotation. Then throw the error to
#! the next outermost catch handler.
>r [ dup slip ] catch nip r>
swap slip [ rethrow ] when* ; inline
[ >c >r call c> drop r> call ]
[ (callcc1) >r nip call r> rethrow ] ifcc ; inline
: recover ( try recovery -- | try: -- | recovery: error -- )
#! Call the try quotation. If an exception is thrown in the
#! dynamic extent of the quotation, restore the datastack,
#! push the exception on the datastack, and call the
#! recovery quotation.
>r catch r> when* ; inline
[ >c drop call c> drop ]
[ (callcc1) rot drop swap call ] ifcc ; inline
GENERIC: error. ( error -- )

20
library/httpd/browser-responder.factor
View File

@ -42,14 +42,14 @@ USING: html cont-responder kernel io namespaces words lists prettyprint
: vocab-list ( vocab -- )
#! Write out the HTML for the list of vocabularies. Make the currently
#! selected vocab be 'vocab'.
<select name= "vocab" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select>
<select "vocab" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
vocabs [ over swap option ] each drop
</select> ;
: word-list ( vocab word -- )
#! Write out the HTML for the list of words in a vocabulary. Make the 'word' item
#! the currently selected option.
<select name= "word" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select>
<select "word" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
swap words [ word-name over swap option ] each drop
</select> ;
@ -65,16 +65,16 @@ USING: html cont-responder kernel io namespaces words lists prettyprint
: browser-body ( vocab word -- )
#! Write out the HTML for the body of the main browser page.
<table width= "100%" table>
<table "100%" =width table>
<tr>
<td> "<b>Vocabularies</b>" write </td>
<td> "<b>Words</b>" write </td>
<td> "<b>Source</b>" write </td>
<td> <b> "Vocabularies" write </b> </td>
<td> <b> "Words" write </b> </td>
<td> <b> "Source" write </b> </td>
</tr>
<tr>
<td valign= "top" style= "width: 200" td> over vocab-list </td>
<td valign= "top" style= "width: 200" td> 2dup word-list </td>
<td valign= "top" td> word-source </td>
<td "top" =valign "width: 200" =style td> over vocab-list </td>
<td "top" =valign "width: 200" =style td> 2dup word-list </td>
<td "top" =valign td> word-source </td>
</tr>
</table>
vm-statistics ;
@ -104,7 +104,7 @@ USING: html cont-responder kernel io namespaces words lists prettyprint
<html>
<head> 2dup browser-title browser-style </head>
<body>
<form name= "main" action= "" method= "get" form> browser-body </form>
<form "main" =name "" =action "get" =method form> browser-body </form>
</body>
</html>
] show-final ;

8
library/httpd/cont-responder.factor
View File

@ -286,7 +286,7 @@ SYMBOL: root-continuation
#! back to the most recent 'show' call (via the callback-cc).
#! The text of the link will be the 'text' argument on the
#! stack.
<a href= callback-quot expirable register-continuation id>url a> write </a> ;
<a =href callback-quot expirable register-continuation id>url a> write </a> ;
: init-session-namespace ( -- )
#! Setup the initial session namespace. Currently this only
@ -340,7 +340,7 @@ SYMBOL: root-continuation
[
"Press OK to Continue" [
swap paragraph
<a href= a> "OK" write </a>
<a =href a> "OK" write </a>
] simple-page
] show 2drop ;
@ -353,12 +353,12 @@ SYMBOL: root-continuation
: horizontal-layout ( list -- )
#! Given a list of HTML components, arrange them horizontally.
<table>
<tr valign= "top" tr> [ <td> call </td> ] each </tr>
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
</table> ;
: button ( label -- )
#! Output an HTML submit button with the given label.
<input type= "submit" value= input/> ;
<input "submit" =type =value input/> ;
: with-simple-html-output ( quot -- )
#! Run the quotation inside an HTML stream wrapped

32
library/httpd/html-tags.factor
View File

@ -42,18 +42,16 @@ USE: sequences
!
! <p> "someoutput" write </p>
!
! <p> will outupt the opening tag and </p> will output the closing
! <p> will output the opening tag and </p> will output the closing
! tag with no attributes.
!
! <p class= "red" p> "someoutput" write </p>
! <p "red" =class p> "someoutput" write </p>
!
! This time the opening tag does not have the '>'. It pushes
! a namespace on the stack to hold the attributes and values.
! Any attribute words used will store the attribute and values
! in that namespace. After the attribute word should come the
! value of that attribute. The next attribute word or
! finishing word (which is the html word followed by '>')
! will actually set the attribute to that value in the namespace.
! in that namespace. Before the attribute word should come the
! value of that attribute.
! The finishing word will print out the operning tag including
! attributes.
! Any writes after this will appear after the opening tag.
@ -62,17 +60,17 @@ USE: sequences
! operations:
!
! (url -- )
! <a href= a> "Click me" write </a>
! <a =href a> "Click me" write </a>
!
! (url -- )
! <a href= "http://" swap append a> "click" write </a>
! <a "http://" swap append =href a> "click" write </a>
!
! (url -- )
! <a href= [ "http://" % % ] "" make a> "click" write </a>
! <a [ "http://" % % ] "" make =href a> "click" write </a>
!
! Tags that have no 'closing' equivalent have a trailing tag/> form:
!
! <input type= "text" name= "name" size= "20" input/>
! <input "text" =type "name" =name "20" =size input/>
: attrs>string ( alist -- string )
#! Convert the attrs alist to a string
@ -85,14 +83,6 @@ USE: sequences
#! nothing.
"attrs" get attrs>string write ;
: store-prev-attribute ( n: tag value -- )
#! Assumes an attribute namespace is on the stack.
#! Gets the previous attribute that was used (if any)
#! and sets it's value to the current value on the stack.
#! If there is no previous attribute, no value is expected
#! on the stack.
"current-attribute" get [ swons "attrs" get push ] when* ;
: html-word ( name def -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
@ -118,7 +108,7 @@ USE: sequences
: foo> ">" append ;
: do-foo> store-prev-attribute write-attributes n> drop ">" write ;
: do-foo> write-attributes n> drop ">" write ;
: def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned
@ -162,8 +152,8 @@ USE: sequences
def-for-html-word-foo/> ;
: define-attribute-word ( name -- )
dup "=" append swap [
\ store-prev-attribute , , [ "current-attribute" set ] %
dup "=" swap append swap [
, [ swons "attrs" get push ] %
] [ ] make html-word drop ;
! Define some closed HTML tags

6
library/httpd/html.factor
View File

@ -55,7 +55,7 @@ presentation sequences strings styles words ;
over css-style dup "" = [
drop call
] [
<span style= span> call </span>
<span =style span> call </span>
] ifte ;
: resolve-file-link ( path -- link )
@ -70,7 +70,7 @@ presentation sequences strings styles words ;
: file-link-tag ( style quot -- )
over file swap assoc [
<a href= file-link-href a> call </a>
<a file-link-href =href a> call </a>
] [
call
] ifte* ;
@ -86,7 +86,7 @@ presentation sequences strings styles words ;
: browser-link-tag ( style quot -- style )
over presented swap assoc dup word? [
<a href= browser-link-href a> call </a>
<a browser-link-href =href a> call </a>
] [
drop call
] ifte ;

11
library/inference/known-words.factor
View File

@ -526,3 +526,14 @@ prettyprint ;
] "infer" set-word-prop
\ flush-icache [ [ ] [ ] ] "infer-effect" set-word-prop
\ infer-only [ [ object ] [ ] ] "infer-effect" set-word-prop
\ infer-only [ pop-literal infer-quot-value ] "infer" set-word-prop
\ (callcc0) [
"(callcc0) cannot be compiled (yet)" throw
] "infer" set-word-prop
\ (callcc1) [
"(callcc1) cannot be compiled (yet)" throw
] "infer" set-word-prop

4
library/sdl/sdl-ttf.factor
View File

@ -9,8 +9,8 @@ USE: alien
: TTF_ByteSwappedUNICODE ( swapped -- )
"void" "sdl-ttf" "TTF_ByteSwappedUNICODE" [ "int" ] alien-invoke ;
: TTF_Init ( -- )
"void" "sdl-ttf" "TTF_Init" [ ] alien-invoke ;
: TTF_Init ( -- n )
"int" "sdl-ttf" "TTF_Init" [ ] alien-invoke ;
: TTF_OpenFont ( file ptsize -- font )
"void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" ] alien-invoke ;

7
library/test/continuations.factor
View File

@ -27,10 +27,3 @@ USE: test
[ t ] [ 10 callcc1-test 10 >list = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test
: multishot-test ( -- stack )
[
dup "cc" set 5 swap continue-with
] callcc1 "cc" get continuation-data ;
[ 5 { } ] [ multishot-test ] unit-test

5
library/test/errors.factor
View File

@ -26,8 +26,9 @@ USE: memory
[ [ "2 car" ] parse ] catch print-error
! This should not raise an error
[ 1 2 3 ] [ 1 2 3 f throw ] unit-test
[ car ] [ [ 5 car ] catch no-method-generic ] unit-test
[ 1 2 3 ] [ f throw ] unit-test-fails
! See how well callstack overflow is handled
: callstack-overflow callstack-overflow f ;

30
library/tools/debugger.factor
View File

@ -45,24 +45,24 @@ parser prettyprint sequences io strings vectors words ;
"User interrupt" print drop ;
PREDICATE: cons kernel-error ( obj -- ? )
car kernel-error = ;
dup first kernel-error = swap second 0 11 between? and ;
M: kernel-error error. ( error -- )
#! Kernel errors are indexed by integers.
cdr uncons car swap {
expired-error.
io-error.
undefined-word-error.
type-check-error.
float-format-error.
signal-error.
negative-array-size-error.
c-string-error.
ffi-error.
heap-scan-error.
undefined-symbol-error.
user-interrupt.
} nth execute ;
cdr uncons car swap @{
[ expired-error. ]
[ io-error. ]
[ undefined-word-error. ]
[ type-check-error. ]
[ float-format-error. ]
[ signal-error. ]
[ negative-array-size-error. ]
[ c-string-error. ]
[ ffi-error. ]
[ heap-scan-error. ]
[ undefined-symbol-error. ]
[ user-interrupt. ]
}@ dispatch ;
M: no-method error. ( error -- )
"No suitable method." print

11
library/ui/fonts.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: alien arrays hashtables io kernel lists namespaces sdl
sequences styles ;
USING: alien arrays errors hashtables io kernel lists namespaces
sdl sequences styles ;
: ttf-name ( font style -- name )
cons {{
@ -23,8 +23,9 @@ sequences styles ;
: ttf-path ( name -- string )
[ "/fonts/" % % ".ttf" % ] "" make resource-path ;
: open-font ( [ font style ptsize ] -- alien )
first3 >r ttf-name ttf-path r> TTF_OpenFont ;
: open-font ( { font style ptsize } -- alien )
first3 >r ttf-name ttf-path r> TTF_OpenFont
dup alien-address 0 = [ SDL_GetError throw ] when ;
SYMBOL: open-fonts
@ -34,7 +35,7 @@ SYMBOL: open-fonts
global [ open-fonts nest drop ] bind
: ttf-init ( -- )
TTF_Init
TTF_Init -1 = [ SDL_GetError throw ] when
global [
open-fonts [ [ cdr expired? not ] hash-subset ] change
] bind ;

8
library/ui/world.factor
View File

@ -41,11 +41,11 @@ C: world ( -- world )
<gadget> dup add-layer dup world get set-world-glass
dupd add-gadget prefer ;
: world-clip ( -- rect )
@{ 0 0 0 }@ width get height get 0 3array <rect> ;
: draw-world ( world -- )
[
@{ 0 0 0 }@ width get height get 0 3array <rect> clip set
draw-gadget
] with-surface ;
[ world-clip clip set draw-gadget ] with-surface ;
DEFER: handle-event