Paste: another functor with latest syntax changes

Author: slava
Mode: factor
Date: Fri, 14 Nov 2008 11:56:00
Plain Text | 
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private
prettyprint.backend kernel words classes math parser ;
IN: specialized-arrays.functor

FUNCTOR: define-array ( T -- )

A       DEFINES ${T}-array
<A>     DEFINES <${A}>
>A      DEFINES >${A}
A{      DEFINES ${A}{

NTH     [ T dup c-getter array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]

WHERE

TUPLE: A
{ length array-capacity read-only }
{ underlying byte-array read-only } ;

: <A> ( n -- float-array ) dup T <c-array> A boa ; inline

M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;

M: A length length>> ;

M: A nth-unsafe underlying>> NTH call ;

M: A set-nth-unsafe underlying>> SET-NTH call ;

: >A A new clone-like ; inline

M: A like drop dup A instance? [ >A execute ] unless ;

M: A new-sequence drop <A> execute ;

M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;

M: A resize
    [ drop ] [
        [ T heap-size * ] [ underlying>> ] bi*
        resize-byte-array
    ] 2bi
    A boa ;

M: A byte-length underlying>> length ;

M: A pprint-delims drop A{ \ } ;

M: A >pprint-sequence ;

M: A pprint* pprint-object ;

: A{ [ >A execute ] parse-literal ; parsing

;FUNCTOR

Annotation: functors impl

Author: slava
Mode: factor
Date: Fri, 14 Nov 2008 12:15:47
Plain Text | 
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel locals.private quotations classes.tuple
classes.tuple.parser make lexer combinators generic words
multiline interpolate namespaces sequences io.streams.string
fry classes.mixin ;
IN: functors

: scan-param ( -- obj )
    scan-object dup special? [ literalize ] unless ;

: define* ( word def -- ) over set-word define ;

: `TUPLE:
    scan-param parsed
    scan {
        { ";" [ tuple parsed f parsed ] }
        { "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] }
        [
            [ tuple parsed ] dip
            [ parse-slot-name [ parse-tuple-slots ] when ] { }
            make parsed
        ]
    } case
    \ define-tuple-class parsed ; parsing

: `M:
    scan-param parsed
    scan-param parsed
    \ create-method parsed
    parse-definition parsed
    \ define* parsed ; parsing

: `C:
    scan-param parsed
    scan-param parsed
    [ [ boa ] curry define* ] over push-all ; parsing

: `:
    scan-param parsed
    parse-definition parsed
    \ define* parsed ; parsing

: `INSTANCE:
    scan-param parsed
    scan-param parsed
    \ add-mixin-instance parsed ; parsing

: `inline \ inline parsed ; parsing

: `parsing \ parsing parsed ; parsing

: WORD[
    "]" parse-multiline-string interpolate-locals parsed
    [ with-string-writer in get create ] over push-all ; parsing

: (INTERPOLATE) ( accum quot -- accum )
    [ scan interpolate-locals ] dip
    '[ _ with-string-writer @ ] parsed ;

: IS [ search ] (INTERPOLATE) ; parsing

: DEFINES [ in get create ] (INTERPOLATE) ; parsing

DEFER: ;FUNCTOR delimiter

: functor-words ( -- assoc )
    H{
        { "TUPLE:" POSTPONE: `TUPLE: }
        { "M:" POSTPONE: `M: }
        { "C:" POSTPONE: `C: }
        { ":" POSTPONE: `: }
        { "INSTANCE:" POSTPONE: `INSTANCE: }
        { "inline" POSTPONE: `inline }
        { "parsing" POSTPONE: `parsing }
    } ;

: push-functor-words ( -- )
    functor-words use get push ;

: pop-functor-words ( -- )
    functor-words use get delq ;

: parse-functor-body ( -- form )
    t in-lambda? [
        V{ } clone
        push-functor-words
        "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
        <let*> parsed-lambda
        pop-functor-words
        >quotation
    ] with-variable ;

: (FUNCTOR:) ( -- word def )
    CREATE
    parse-locals
    parse-functor-body swap pop-locals <lambda>
    lambda-rewrite first ;

: FUNCTOR: (FUNCTOR:) define ; parsing

: APPLY: scan-word scan-word execute swap '[ _ execute ] each ; parsing

New Annotation

Summary:
Author:
Mode:
Body: