factor/core/syntax/syntax.factor

! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays byte-arrays definitions generic
hashtables kernel math namespaces parser lexer sequences strings
strings.parser sbufs vectors words quotations io assocs
splitting classes.tuple generic.standard generic.math
generic.parser classes io.files vocabs classes.parser
classes.union classes.intersection classes.mixin
classes.predicate classes.singleton classes.tuple.parser
compiler.units combinators effects.parser slots ;
IN: bootstrap.syntax

! These words are defined as a top-level form, instead of with
! defining parsing words, because during stage1 bootstrap, the
! "syntax" vocabulary is copied from the host. When stage1
! bootstrap completes, the host's syntax vocabulary is deleted
! from the target, then this top-level form creates the
! target's "syntax" vocabulary as one of the first things done
! in stage2.

: define-delimiter ( name -- )
    "syntax" lookup t "delimiter" set-word-prop ;

: define-syntax ( name quot -- )
    [ "syntax" lookup dup ] dip define make-parsing ;

[
    { "]" "}" ";" ">>" } [ define-delimiter ] each

    "PRIMITIVE:" [
        "Primitive definition is not supported" throw
    ] define-syntax

    "CS{" [
        "Call stack literals are not supported" throw
    ] define-syntax

    "!" [ lexer get next-line ] define-syntax

    "#!" [ POSTPONE: ! ] define-syntax

    "IN:" [ scan set-in ] define-syntax

    "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-syntax

    "<PRIVATE" [
        POSTPONE: PRIVATE> in get ".private" append set-in
    ] define-syntax

    "USE:" [ scan use+ ] define-syntax

    "USING:" [ ";" parse-tokens add-use ] define-syntax

    "HEX:" [ 16 parse-base ] define-syntax
    "OCT:" [ 8 parse-base ] define-syntax
    "BIN:" [ 2 parse-base ] define-syntax

    "f" [ f parsed ] define-syntax
    "t" "syntax" lookup define-singleton-class

    "CHAR:" [
        scan {
            { [ dup length 1 = ] [ first ] }
            { [ "\\" ?head ] [ next-escape >string "" assert= ] }
            [ name>char-hook get call ]
        } cond parsed
    ] define-syntax

    "\"" [ parse-string parsed ] define-syntax

    "SBUF\"" [
        lexer get skip-blank parse-string >sbuf parsed
    ] define-syntax

    "P\"" [
        lexer get skip-blank parse-string <pathname> parsed
    ] define-syntax

    "[" [ \ ] [ >quotation ] parse-literal ] define-syntax
    "{" [ \ } [ >array ] parse-literal ] define-syntax
    "V{" [ \ } [ >vector ] parse-literal ] define-syntax
    "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
    "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
    "T{" [ parse-tuple-literal parsed ] define-syntax
    "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax

    "POSTPONE:" [ scan-word parsed ] define-syntax
    "\\" [ scan-word literalize parsed ] define-syntax
    "inline" [ word make-inline ] define-syntax
    "recursive" [ word make-recursive ] define-syntax
    "foldable" [ word make-foldable ] define-syntax
    "flushable" [ word make-flushable ] define-syntax
    "delimiter" [ word t "delimiter" set-word-prop ] define-syntax
    "parsing" [ word make-parsing ] define-syntax

    "SYMBOL:" [
        CREATE-WORD define-symbol
    ] define-syntax

    "DEFER:" [
        scan current-vocab create
        dup old-definitions get [ delete-at ] with each
        set-word
    ] define-syntax

    ":" [
        (:) define
    ] define-syntax

    "GENERIC:" [
        CREATE-GENERIC define-simple-generic
    ] define-syntax

    "GENERIC#" [
        CREATE-GENERIC
        scan-word <standard-combination> define-generic
    ] define-syntax

    "MATH:" [
        CREATE-GENERIC
        T{ math-combination } define-generic
    ] define-syntax

    "HOOK:" [
        CREATE-GENERIC scan-word
        <hook-combination> define-generic
    ] define-syntax

    "M:" [
        (M:) define
    ] define-syntax

    "UNION:" [
        CREATE-CLASS parse-definition define-union-class
    ] define-syntax

    "INTERSECTION:" [
        CREATE-CLASS parse-definition define-intersection-class
    ] define-syntax

    "MIXIN:" [
        CREATE-CLASS define-mixin-class
    ] define-syntax

    "INSTANCE:" [
        location [
            scan-word scan-word 2dup add-mixin-instance
            <mixin-instance>
        ] dip remember-definition
    ] define-syntax

    "PREDICATE:" [
        CREATE-CLASS
        scan "<" assert=
        scan-word
        parse-definition define-predicate-class
    ] define-syntax

    "SINGLETON:" [
        CREATE-CLASS define-singleton-class
    ] define-syntax

    "TUPLE:" [
        parse-tuple-definition define-tuple-class
    ] define-syntax

    "SLOT:" [
        scan define-protocol-slot
    ] define-syntax

    "C:" [
        CREATE-WORD
        scan-word [ boa ] curry define-inline
    ] define-syntax

    "ERROR:" [
        parse-tuple-definition
        pick save-location
        define-error-class
    ] define-syntax

    "FORGET:" [
        scan-object forget
    ] define-syntax

    "(" [
        ")" parse-effect
        word dup [ set-stack-effect ] [ 2drop ] if
    ] define-syntax

    "((" [
        "))" parse-effect parsed
    ] define-syntax

    "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax

    "<<" [
        [
            \ >> parse-until >quotation
        ] with-nested-compilation-unit call
    ] define-syntax

    "call-next-method" [
        current-method get [
            literalize parsed
            \ (call-next-method) parsed
        ] [
            not-in-a-method-error
        ] if*
    ] define-syntax
    
    "initial:" "syntax" lookup define-symbol
    
    "read-only" "syntax" lookup define-symbol
] with-compilation-unit