;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.


;; *** Keywords ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


;; <keyword> no longer inherits from <variable>

(define-hrecord-type <keyword> () address)

(define-hrecord-type <keyword-if> (<keyword>))

(define-hrecord-type <keyword-if-object> (<keyword>))

(define-hrecord-type <keyword-define-class> (<keyword>))

(define-hrecord-type <keyword-define> (<keyword>))

(define-hrecord-type <keyword-define-variable> (<keyword>))

(define-hrecord-type <keyword-define-volatile> (<keyword>))

(define-hrecord-type <keyword-define-gen-proc> (<keyword>))

(define-hrecord-type <keyword-add-method> (<keyword>))

(define-hrecord-type <keyword-add-static-method> (<keyword>))

(define-hrecord-type <keyword-procedure> (<keyword>))

(define-hrecord-type <keyword-procedure-aut> (<keyword>))

(define-hrecord-type <keyword-primitive-procedure> (<keyword>))

(define-hrecord-type <keyword-unchecked-primitive-procedure> (<keyword>))

(define-hrecord-type <keyword-param-prim-proc> (<keyword>))

(define-hrecord-type <keyword-unchecked-param-prim-proc> (<keyword>))

(define-hrecord-type <keyword-define-prim-class> (<keyword>))

(define-hrecord-type <keyword-define-goops-class> (<keyword>))

(define-hrecord-type <keyword-param-proc> (<keyword>))

(define-hrecord-type <keyword-param-proc-aut> (<keyword>))

(define-hrecord-type <keyword-cast> (<keyword>))

(define-hrecord-type <keyword-try-cast> (<keyword>))

(define-hrecord-type <keyword-static-cast> (<keyword>))

(define-hrecord-type <keyword-match-type> (<keyword>))

(define-hrecord-type <keyword-match-type-strong> (<keyword>))

(define-hrecord-type <keyword-begin> (<keyword>))

(define-hrecord-type <keyword-let> (<keyword>))

(define-hrecord-type <keyword-let-variables> (<keyword>))

(define-hrecord-type <keyword-let-volatile> (<keyword>))

(define-hrecord-type <keyword-letrec> (<keyword>))

(define-hrecord-type <keyword-letrec-variables> (<keyword>))

(define-hrecord-type <keyword-letrec-volatile> (<keyword>))

(define-hrecord-type <keyword-letrec*> (<keyword>))

(define-hrecord-type <keyword-letrec*-variables> (<keyword>))

(define-hrecord-type <keyword-letrec*-volatile> (<keyword>))

(define-hrecord-type <keyword-import> (<keyword>))

(define-hrecord-type <keyword-import-and-reexport> (<keyword>))

(define-hrecord-type <keyword-use> (<keyword>))

(define-hrecord-type <keyword-prelink-body> (<keyword>))

(define-hrecord-type <keyword-reexport> (<keyword>))

(define-hrecord-type <keyword-define-proper-program> (<keyword>))

(define-hrecord-type <keyword-define-script> (<keyword>))

(define-hrecord-type <keyword-define-interface> (<keyword>))

(define-hrecord-type <keyword-define-body> (<keyword>))

(define-hrecord-type <keyword-quote> (<keyword>))

(define-hrecord-type <keyword-set> (<keyword>))

(define-hrecord-type <keyword-until> (<keyword>))

(define-hrecord-type <keyword-declare> (<keyword>))

(define-hrecord-type <keyword-declare-mutable> (<keyword>))

(define-hrecord-type <keyword-declare-volatile> (<keyword>))

(define-hrecord-type <keyword-declare-method> (<keyword>))

(define-hrecord-type <keyword-declare-static-method> (<keyword>))

(define-hrecord-type <keyword-constructor> (<keyword>))

(define-hrecord-type <keyword-def-param-class> (<keyword>))

(define-hrecord-type <keyword-def-param-logical-type> (<keyword>))

(define-hrecord-type <keyword-def-param-proc-alt> (<keyword>))

(define-hrecord-type <keyword-define-signature> (<keyword>))

(define-hrecord-type <keyword-define-param-signature> (<keyword>))

(define-hrecord-type <keyword-param-proc-instance> (<keyword>))

(define-hrecord-type <keyword-param-proc-dispatch> (<keyword>))

(define-hrecord-type <keyword-param-proc-cond-appl> (<keyword>))

(define-hrecord-type <keyword-generic-proc-dispatch> (<keyword>))

(define-hrecord-type <keyword-generic-proc-dispatch-without-result>
  (<keyword>))

(define-hrecord-type <keyword-rest> (<keyword>))

(define-hrecord-type <keyword-splice> (<keyword>))

(define-hrecord-type <keyword-type-list> (<keyword>))

(define-hrecord-type <keyword-type-loop> (<keyword>))

(define-hrecord-type <keyword-type-join> (<keyword>))

(define-hrecord-type <keyword-zero> (<keyword>))

(define-hrecord-type <keyword-force-pure-expr> (<keyword>))

(define-hrecord-type <keyword-static-type-of> (<keyword>))

(define-hrecord-type <keyword-prevent-stripping> (<keyword>))

(define-hrecord-type <keyword-assert> (<keyword>))

(define-hrecord-type <keyword-strong-assert> (<keyword>))

(define-hrecord-type <keyword-do-assert> (<keyword>))

(define-hrecord-type <keyword-do-strong-assert> (<keyword>))

(define-hrecord-type <keyword-define-syntax> (<keyword>))

(define-hrecord-type <keyword-module-ref> (<keyword>))

(define skw-define 'define)
(define skw-define-variable 'define-mutable)
(define skw-define-volatile 'define-volatile)
(define skw-define-class 'define-class)
(define skw-define-gen-proc 'define-generic-proc)
(define skw-add-method 'add-method)
(define skw-add-static-method 'add-static-method)
(define skw-procedure 'lambda)
(define skw-procedure-aut 'lambda-automatic)
(define skw-primitive-procedure 'prim-proc)
(define skw-unchecked-primitive-procedure 'unchecked-prim-proc)
(define skw-param-prim-proc 'param-prim-proc)
(define skw-unchecked-param-prim-proc 'unchecked-param-prim-proc)
(define skw-define-prim-class 'define-prim-class)
(define skw-define-goops-class 'define-goops-class)
(define skw-param-proc 'param-lambda)
(define skw-param-proc-aut 'param-lambda-automatic)
(define skw-if 'if)
(define skw-if-object 'if-object)
(define skw-cast 'cast)
(define skw-try-cast 'try-cast)
(define skw-static-cast 'static-cast)
(define skw-match-type 'match-type)
(define skw-match-type-strong 'match-type-strong)
(define skw-begin 'begin)
(define skw-let 'let)
(define skw-let-variables 'let-mutable)
(define skw-let-volatile 'let-volatile)
(define skw-letrec 'letrec)
(define skw-letrec-variables 'letrec-mutable)
(define skw-letrec-volatile 'letrec-volatile)
(define skw-letrec* 'letrec*)
(define skw-letrec*-variables 'letrec*-mutable)
(define skw-letrec*-volatile 'letrec*-volatile)
(define skw-import 'import)
(define skw-import-and-reexport 'import-and-reexport)
(define skw-use 'use)
(define skw-prelink-body 'prelink-body)
(define skw-reexport 'reexport)
(define skw-define-proper-program 'define-proper-program)
(define skw-define-script 'define-script)
(define skw-define-interface 'define-interface)
(define skw-define-body 'define-body)
(define skw-quote 'quote)
(define skw-set 'set!)
(define skw-until 'until)
(define skw-declare 'declare)
(define skw-declare-mutable 'declare-mutable)
(define skw-declare-volatile 'declare-volatile)
(define skw-declare-method 'declare-method)
(define skw-declare-static-method 'declare-static-method)
(define skw-constructor 'constructor)
(define skw-def-param-class 'define-param-class)
(define skw-def-param-logical-type 'define-param-logical-type)
(define skw-def-param-proc-alt 'define-param-proc-alt)
(define skw-define-signature 'define-signature)
(define skw-define-param-signature 'define-param-signature)
(define skw-param-proc-instance 'param-proc-instance)
(define skw-param-proc-dispatch 'param-proc-dispatch)
(define skw-param-proc-cond-appl 'param-proc-cond-appl)
(define skw-generic-proc-dispatch 'generic-proc-dispatch)
(define skw-generic-proc-dispatch-without-result
  'generic-proc-dispatch-without-result)
(define skw-rest 'rest)
(define skw-splice 'splice)
;; Note the following.
(define skw-type-list ':tuple)
(define skw-type-loop 'type-loop)
(define skw-type-join 'join-tuple-types)
(define skw-zero 'zero)
(define skw-force-pure-expr 'force-pure-expr)
(define skw-static-type-of 'static-type-of)
(define skw-prevent-stripping 'prevent-stripping)
(define skw-assert 'assert)
(define skw-strong-assert 'strong-assert)
(define skw-do-assert '_assert)
(define skw-do-strong-assert '_strong-assert)
(define skw-module-ref '@)
(define skw-let-syntax 'let-syntax)
(define skw-letrec-syntax 'letrec-syntax)
(define skw-define-syntax 'define-syntax)
(define skw-syntax 'syntax)
(define skw-syntax-case 'syntax-case)
(define skw-$define '$define)
(define skw-$lambda '$lambda)
(define skw-$let '$let)

(define keywords
  `((,skw-define ,<keyword-define>)
    (,skw-define-variable ,<keyword-define-variable>)
    (,skw-define-volatile ,<keyword-define-volatile>)
    (,skw-define-class ,<keyword-define-class>)
    (,skw-define-gen-proc ,<keyword-define-gen-proc>)
    (,skw-add-method ,<keyword-add-method>)
    (,skw-add-static-method ,<keyword-add-static-method>)
    (,skw-procedure ,<keyword-procedure>)
    (,skw-procedure-aut ,<keyword-procedure-aut>)
    (,skw-primitive-procedure ,<keyword-primitive-procedure>)
    (,skw-unchecked-primitive-procedure
     ,<keyword-unchecked-primitive-procedure>)
    (,skw-param-prim-proc ,<keyword-param-prim-proc>)
    (,skw-unchecked-param-prim-proc ,<keyword-unchecked-param-prim-proc>)
    (,skw-define-prim-class ,<keyword-define-prim-class>)
    (,skw-define-goops-class ,<keyword-define-goops-class>)
    (,skw-param-proc ,<keyword-param-proc>)
    (,skw-param-proc-aut ,<keyword-param-proc-aut>)
    (,skw-if ,<keyword-if>)
    (,skw-if-object ,<keyword-if-object>)
    (,skw-cast ,<keyword-cast>)
    (,skw-try-cast ,<keyword-try-cast>)
    (,skw-static-cast ,<keyword-static-cast>)
    (,skw-match-type ,<keyword-match-type>)
    (,skw-match-type-strong ,<keyword-match-type-strong>)
    (,skw-begin ,<keyword-begin>)
    (,skw-let ,<keyword-let>)
    (,skw-let-variables ,<keyword-let-variables>)
    (,skw-let-volatile ,<keyword-let-volatile>)
    (,skw-letrec ,<keyword-letrec>)
    (,skw-letrec-variables ,<keyword-letrec-variables>)
    (,skw-letrec-volatile ,<keyword-letrec-volatile>)
    (,skw-letrec* ,<keyword-letrec*>)
    (,skw-letrec*-variables ,<keyword-letrec*-variables>)
    (,skw-letrec*-volatile ,<keyword-letrec*-volatile>)
    (,skw-import ,<keyword-import>)
    (,skw-import-and-reexport ,<keyword-import-and-reexport>)
    (,skw-use ,<keyword-use>)
    (,skw-prelink-body ,<keyword-prelink-body>)
    (,skw-reexport ,<keyword-reexport>)
    (,skw-define-proper-program ,<keyword-define-proper-program>)
    (,skw-define-script ,<keyword-define-script>)
    (,skw-define-interface ,<keyword-define-interface>)
    (,skw-define-body ,<keyword-define-body>)
    (,skw-quote ,<keyword-quote>)
    (,skw-set ,<keyword-set>)
    (,skw-until ,<keyword-until>)
    (,skw-declare ,<keyword-declare>)
    (,skw-declare-mutable ,<keyword-declare-mutable>)
    (,skw-declare-volatile ,<keyword-declare-volatile>)
    (,skw-declare-method ,<keyword-declare-method>)
    (,skw-declare-static-method ,<keyword-declare-static-method>)
    (,skw-constructor ,<keyword-constructor>)
    (,skw-def-param-class ,<keyword-def-param-class>)
    (,skw-def-param-logical-type ,<keyword-def-param-logical-type>)
    (,skw-def-param-proc-alt ,<keyword-def-param-proc-alt>)
    (,skw-define-signature ,<keyword-define-signature>)
    (,skw-define-param-signature ,<keyword-define-param-signature>)
    (,skw-param-proc-instance ,<keyword-param-proc-instance>)
    (,skw-param-proc-dispatch ,<keyword-param-proc-dispatch>)
    (,skw-param-proc-cond-appl ,<keyword-param-proc-cond-appl>)
    (,skw-generic-proc-dispatch ,<keyword-generic-proc-dispatch>)
    (,skw-generic-proc-dispatch-without-result
     ,<keyword-generic-proc-dispatch-without-result>)
    (,skw-rest ,<keyword-rest>)
    (,skw-splice ,<keyword-splice>)
    (,skw-type-list ,<keyword-type-list>)
    (,skw-type-loop ,<keyword-type-loop>)
    (,skw-type-join ,<keyword-type-join>)
    (,skw-zero ,<keyword-zero>)
    (,skw-force-pure-expr ,<keyword-force-pure-expr>)
    (,skw-static-type-of ,<keyword-static-type-of>)
    (,skw-prevent-stripping ,<keyword-prevent-stripping>)
    (,skw-define-syntax ,<keyword-define-syntax>)
    (,skw-module-ref ,<keyword-module-ref>)
    (,skw-assert ,<keyword-assert>)
    (,skw-strong-assert ,<keyword-strong-assert>)
    (,skw-do-assert ,<keyword-do-assert>)
    (,skw-do-strong-assert ,<keyword-do-strong-assert>)))


(for-each (lambda (pair)
	    (let* ((skw (car pair))
		   (kwclass (cadr pair))
		   (address (make-keyword-address skw)))
	      (add-symbol!
	       global-builtins-symtbl skw
	       (make-hrecord kwclass address))))
	  keywords)


(define gl-pure 'pure)
(define gl-force-pure 'force-pure)
(define gl-nonpure 'nonpure)
(define gl-may-return 'may-return)
(define gl-always-returns 'always-returns)
(define gl-never-returns 'never-returns)
(define gl-match-type-else 'else)


(define gl-proc-attributes
  (list gl-pure gl-force-pure gl-nonpure
	gl-may-return gl-always-returns gl-never-returns))


(define gl-access-specifiers (list 'public 'module 'hidden))
