Merge branch 'master' of git://factorcode.org/git/jamesnvc
commit
e721f124a4
|
@ -0,0 +1,22 @@
|
|||
IN: advice
|
||||
USING: help.markup help.syntax tools.annotations words ;
|
||||
|
||||
HELP: make-advised
|
||||
{ $values { "word" "a word to annotate in preparation of advising" } }
|
||||
{ $description "Prepares a word for being advised. This is done by: "
|
||||
{ $list
|
||||
{ "Annotating it to call the appropriate words before, around, and after the original body " }
|
||||
{ "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
|
||||
{ "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
|
||||
}
|
||||
}
|
||||
{ $see-also advised? annotate } ;
|
||||
|
||||
HELP: advised?
|
||||
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet word } " is advised" } }
|
||||
{ $description "Determines whether or not the given word has any advice on it." } ;
|
||||
|
||||
ARTICLE: "advice" "Advice"
|
||||
"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
|
||||
|
||||
ABOUT: "advice"
|
|
@ -0,0 +1,40 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences math tools.test advice parser namespaces ;
|
||||
IN: advice.tests
|
||||
|
||||
[
|
||||
: foo "foo" ;
|
||||
\ foo make-advised
|
||||
|
||||
{ "bar" "foo" } [
|
||||
[ "bar" ] "barify" \ foo advise-before
|
||||
foo ] unit-test
|
||||
|
||||
{ "bar" "foo" "baz" } [
|
||||
[ "baz" ] "bazify" \ foo advise-after
|
||||
foo ] unit-test
|
||||
|
||||
{ "foo" "baz" } [
|
||||
"barify" \ foo before remove-advice
|
||||
foo ] unit-test
|
||||
|
||||
: bar ( a -- b ) 1+ ;
|
||||
\ bar make-advised
|
||||
|
||||
{ 11 } [
|
||||
[ 2 * ] "double" \ bar advise-before
|
||||
5 bar
|
||||
] unit-test
|
||||
|
||||
{ 11/3 } [
|
||||
[ 3 / ] "third" \ bar advise-after
|
||||
5 bar
|
||||
] unit-test
|
||||
|
||||
{ -2 } [
|
||||
[ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
|
||||
5 bar
|
||||
] unit-test
|
||||
|
||||
] with-scope
|
|
@ -0,0 +1,49 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
|
||||
IN: advice
|
||||
|
||||
SYMBOLS: before after around advised ;
|
||||
|
||||
<PRIVATE
|
||||
: advise ( quot name word loc -- )
|
||||
word-prop set-at ;
|
||||
PRIVATE>
|
||||
|
||||
: advise-before ( quot name word -- )
|
||||
before advise ;
|
||||
|
||||
: advise-after ( quot name word -- )
|
||||
after advise ;
|
||||
|
||||
: advise-around ( quot name word -- )
|
||||
[ \ coterminate suffix ] 2dip
|
||||
around advise ;
|
||||
|
||||
: get-advice ( word type -- seq )
|
||||
word-prop values ;
|
||||
|
||||
: call-before ( word -- )
|
||||
before get-advice [ call ] each ;
|
||||
|
||||
: call-after ( word -- )
|
||||
after get-advice [ call ] each ;
|
||||
|
||||
: call-around ( main word -- )
|
||||
around get-advice [ cocreate ] map tuck
|
||||
[ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
|
||||
|
||||
: remove-advice ( name word loc -- )
|
||||
word-prop delete-at ;
|
||||
|
||||
: ad-do-it ( input -- result )
|
||||
coyield ;
|
||||
|
||||
: advised? ( word -- ? )
|
||||
advised word-prop ;
|
||||
|
||||
: make-advised ( word -- )
|
||||
[ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
|
||||
[ { before after around } [ H{ } clone swap set-word-prop ] with each ]
|
||||
[ t advised set-word-prop ] tri ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
James Cash
|
|
@ -0,0 +1 @@
|
|||
Implmentation of advice/aspects
|
|
@ -0,0 +1,3 @@
|
|||
advice
|
||||
aspect
|
||||
annotations
|
|
@ -1,5 +1,12 @@
|
|||
IN: lisp
|
||||
USING: help.markup help.syntax ;
|
||||
HELP: <LISP
|
||||
{ $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
|
||||
{ $see-also lisp-string>factor } ;
|
||||
|
||||
HELP: lisp-string>factor
|
||||
{ $values { "str" "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
|
||||
{ $description "Turns a string of lisp into a factor quotation" } ;
|
||||
|
||||
ARTICLE: "lisp" "Lisp in Factor"
|
||||
"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl
|
||||
|
|
|
@ -84,4 +84,11 @@ IN: lisp.test
|
|||
<LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
|
||||
] unit-test
|
||||
|
||||
{ { 3 3 4 } } [
|
||||
<LISP (defun foo (x y &rest z)
|
||||
(cons (+ x y) z))
|
||||
(foo 1 2 3 4)
|
||||
LISP> cons>seq
|
||||
] unit-test
|
||||
|
||||
] with-interactive-vocabs
|
||||
|
|
|
@ -64,14 +64,9 @@ PRIVATE>
|
|||
: macro-expand ( cons -- quot )
|
||||
uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
|
||||
|
||||
<PRIVATE
|
||||
: (expand-macros) ( cons -- cons )
|
||||
[ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
|
||||
PRIVATE>
|
||||
|
||||
: expand-macros ( cons -- cons )
|
||||
dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
|
||||
|
||||
dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ;
|
||||
|
||||
: convert-begin ( cons -- quot )
|
||||
cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
|
||||
[ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
|
||||
|
@ -169,15 +164,15 @@ M: no-such-var summary drop "No such variable" ;
|
|||
|
||||
"set" "lisp" "define-lisp-var" define-primitive
|
||||
|
||||
"(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
|
||||
"(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
|
||||
"(set 'list (lambda (&rest xs) xs))" lisp-eval
|
||||
"(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval
|
||||
|
||||
<" (defmacro defun (name vars &rest body)
|
||||
(list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
|
||||
(list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval
|
||||
|
||||
"(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
|
||||
"(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval
|
||||
;
|
||||
|
||||
: <LISP
|
||||
"LISP>" parse-multiline-string define-lisp-builtins
|
||||
lisp-string>factor parsed \ call parsed ; parsing
|
||||
"LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins
|
||||
lisp-string>factor parsed \ call parsed ; parsing
|
|
@ -65,4 +65,16 @@ IN: lisp.parser.tests
|
|||
}
|
||||
} [
|
||||
"(1 (3 4) 2)" lisp-expr
|
||||
] unit-test
|
||||
|
||||
{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [
|
||||
"'(1 2 3)" lisp-expr cons>seq
|
||||
] unit-test
|
||||
|
||||
{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
|
||||
"'foo" lisp-expr cons>seq
|
||||
] unit-test
|
||||
|
||||
{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [
|
||||
"(1 2 '(3 4) 5)" lisp-expr cons>seq
|
||||
] unit-test
|
|
@ -35,5 +35,7 @@ atom = number
|
|||
| identifier
|
||||
| string
|
||||
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
|
||||
list-item = _ ( atom | s-expression ) _ => [[ second ]]
|
||||
;EBNF
|
||||
list-item = _ ( atom | s-expression | quoted ) _ => [[ second ]]
|
||||
quoted = squote list-item => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
|
||||
expr = list-item
|
||||
;EBNF
|
|
@ -1 +0,0 @@
|
|||
The 'work' directory is for your own personal vocabularies.
|
Loading…
Reference in New Issue