diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 12860337ff..3a7cecb800 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors parser generic kernel classes classes.tuple words slots assocs sequences arrays vectors definitions -prettyprint math hashtables sets macros namespaces make ; +prettyprint math hashtables sets generalizations namespaces make ; IN: delegate : protocol-words ( protocol -- words ) @@ -25,15 +25,7 @@ M: tuple-class group-words : consult-method ( word class quot -- ) [ drop swap first create-method ] - [ - nip - [ - over second saver % - % - dup second restorer % - first , - ] [ ] make - ] 3bi + [ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi define ; : change-word-prop ( word prop quot -- ) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 74291bae33..490fa77204 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,10 +1,18 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences sequences.private namespaces math -math.ranges combinators macros quotations fry arrays ; +USING: kernel sequences sequences.private math math.ranges +combinators macros quotations fry ; IN: generalizations +<< + +: n*quot ( n seq -- seq' ) concat >quotation ; + +: repeat ( n obj quot -- ) swapd times ; inline + +>> + MACRO: nsequence ( n seq -- quot ) [ [ drop ] [ '[ _ _ new-sequence ] ] 2bi @@ -22,44 +30,38 @@ MACRO: firstn ( n -- ) bi prefix '[ _ cleave ] ] if ; -: npick-wrap ( quot n -- quot ) - dup 1 > - [ swap '[ _ dip swap ] swap 1 - npick-wrap ] - [ drop ] - if ; - -MACRO: npick ( n -- quot ) [ dup ] swap npick-wrap ; +MACRO: npick ( n -- quot ) + 1- [ dup ] [ '[ _ dip swap ] ] repeat ; MACRO: ndup ( n -- ) dup '[ _ npick ] n*quot ; MACRO: nrot ( n -- ) - 1- dup saver swap [ r> swap ] n*quot append ; + 1- [ ] [ '[ _ dip swap ] ] repeat ; MACRO: -nrot ( n -- ) - 1- dup [ swap >r ] n*quot swap restorer append ; + 1- [ ] [ '[ swap _ dip ] ] repeat ; MACRO: ndrop ( n -- ) [ drop ] n*quot ; -: nnip ( n -- ) - swap >r ndrop r> ; inline +MACRO: nnip ( n -- ) + '[ [ _ ndrop ] dip ] ; MACRO: ntuck ( n -- ) - 2 + [ dupd -nrot ] curry ; + 2 + '[ dup _ -nrot ] ; MACRO: nrev ( n -- quot ) 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ; MACRO: ndip ( quot n -- ) - dup saver -rot restorer 3append ; + [ '[ _ dip ] ] times ; MACRO: nslip ( n -- ) - dup saver [ call ] rot restorer 3append ; + '[ [ call ] _ ndip ] ; -MACRO: nkeep ( n -- ) - [ ] [ 1+ ] [ ] tri - '[ [ _ ndup ] dip _ -nrot _ nslip ] ; +MACRO: nkeep ( quot n -- ) + tuck '[ _ ndup _ _ ndip ] ; MACRO: ncurry ( n -- ) [ curry ] n*quot ; @@ -69,5 +71,5 @@ MACRO: nwith ( n -- ) MACRO: napply ( n -- ) 2 [a,b] - [ [ 1- ] keep '[ _ ntuck _ nslip ] ] + [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ] map concat >quotation [ call ] append ; diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 794d523d00..1481e6eea5 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -22,9 +22,3 @@ M: macro definition "macro" word-prop ; M: macro reset-word [ call-next-method ] [ f "macro" set-word-prop ] bi ; - -: n*quot ( n seq -- seq' ) concat >quotation ; - -: saver ( n -- quot ) \ >r >quotation ; - -: restorer ( n -- quot ) \ r> >quotation ; diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor index 4ff7519a85..0028b9b165 100644 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -12,8 +12,7 @@ TUPLE: canvas < gadget dlist ; : delete-canvas-dlist ( canvas -- ) [ find-gl-context ] - [ dlist>> [ delete-dlist ] when* ] - [ f >>dlist drop ] tri ; + [ [ [ delete-dlist ] when* f ] change-dlist drop ] bi ; : make-canvas-dlist ( canvas quot -- dlist ) [ drop ] [ GL_COMPILE swap make-dlist ] 2bi diff --git a/misc/factor.el b/misc/factor.el index 6c9faf50c9..346642f70c 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -160,10 +160,6 @@ buffer." ;;; Factor mode font lock: -(defconst factor--regexp-word-start - (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) - (format "^\\(%s\\)\\(:\\) " (mapconcat 'identity sws "\\|")))) - (defconst factor--parsing-words '("{" "}" "^:" "^::" ";" "<<" ">" "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" @@ -222,6 +218,10 @@ buffer." ;;; Factor mode syntax: +(defconst factor--regexp-word-start + (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) + (format "^\\(%s\\)\\(:\\) " (regexp-opt sws)))) + (defconst factor--font-lock-syntactic-keywords `(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;")) (,factor--regexp-word-start (2 "(;")) @@ -321,7 +321,7 @@ buffer." "PRIVATE>" "