;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2016, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This module contains information about Cyclone's scheme primitives.
;;;;
(define-library (scheme cyclone primitives)
  (import (scheme base))
  (export
    prim?
    *primitives*
    ;; TODO: replace w/list that cannot be precomputed: precompute-prim-app?
    prim-call?
    prim->c-func
    prim/data-arg?
    prim/c-var-assign
    prim/cvar?
    prim:cont?
    prim:cont/no-args?
    prim:arg-count?
    prim:allocates-object?)
  (begin
    ; prim? : exp -> boolean
    (define (prim? exp)
      (member exp *primitives*))

    (define *primitives* '(
         Cyc-global-vars
         Cyc-get-cvar
         Cyc-set-cvar!
         Cyc-cvar? ;; Cyclone-specific
         Cyc-opaque?
         Cyc-has-cycle?
         Cyc-spawn-thread!
         Cyc-end-thread!
         Cyc-stdout
         Cyc-stdin
         Cyc-stderr
         +
         -
         *
         /
         =
         >
         <
         >=
         <=
         apply
         %halt
         exit
         system
         command-line-arguments
         Cyc-installation-dir
         Cyc-default-exception-handler
         Cyc-current-exception-handler
         cons
         cell-get
         set-global!
         set-cell!
         cell
         eq?
         eqv?
         equal?
         assoc
         assq
         assv
         memq
         memv
         member
         length
         set-car!
         set-cdr!
         car
         cdr
         caar cadr cdar cddr
         caaar caadr cadar caddr cdaar cdadr cddar cdddr
         caaaar caaadr caadar caaddr cadaar cadadr
         caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
         char->integer
         integer->char
         string->number
         string-append
         string-cmp
         list->string
         string->symbol
         symbol->string
         number->string
         string-length
         string-ref
         string-set!
         substring
         make-bytevector
         bytevector-length
         bytevector
         bytevector-append
         Cyc-bytevector-copy
         Cyc-utf8->string
         Cyc-string->utf8
         bytevector-u8-ref
         bytevector-u8-set!
         bytevector?
         make-vector
         list->vector
         vector-length
         vector-ref
         vector-set!
         boolean?
         char?
         eof-object?
         null?
         number?
         real?
         integer?
         pair?
         port?
         procedure?
         macro?
         vector?
         string?
         symbol?
         open-input-file
         open-output-file
         close-port
         close-input-port
         close-output-port
         Cyc-flush-output-port
         file-exists?
         delete-file
         read-char
         peek-char
         Cyc-read-line
         Cyc-write-char
         Cyc-write
         Cyc-display))

;; TODO: dont' put this here, just the list
;    ;; Constant Folding
;    ;; Is a primitive being applied in such a way that it can be
;    ;; evaluated at compile time?
;    (define (precompute-prim-app? ast)
;      (and 
;        (pair? ast)
;        (prim? (car ast))
;        ;; Does not make sense to precompute these
;        (not (member (car ast)
;                    '(Cyc-global-vars
;                      Cyc-get-cvar
;                      Cyc-set-cvar!
;                      Cyc-cvar?
;                      Cyc-opaque?
;                      Cyc-spawn-thread!
;                      Cyc-end-thread!
;                      apply
;                      %halt
;                      exit
;                      system
;                      command-line-arguments
;                      Cyc-installation-dir
;                      Cyc-default-exception-handler
;                      Cyc-current-exception-handler
;                      cell-get
;                      set-global!
;                      set-cell!
;                      cell
;                      cons
;                      set-car!
;                      set-cdr!
;                      string-set!
;                      string->symbol ;; Could be mistaken for an identifier
;                      make-bytevector
;                      make-vector
;                      ;; I/O must be done at runtime for side effects:
;                      Cyc-stdout
;                      Cyc-stdin
;                      Cyc-stderr
;                      open-input-file
;                      open-output-file
;                      close-port
;                      close-input-port
;                      close-output-port
;                      Cyc-flush-output-port
;                      file-exists?
;                      delete-file
;                      read-char
;                      peek-char
;                      Cyc-read-line
;                      Cyc-write-char
;                      Cyc-write
;                      Cyc-display)))
;        (call/cc
;          (lambda (return)
;            (for-each
;              (lambda (expr)
;                (if (or (vector? expr)
;                        (not (const? expr)))
;                  (return #f)))
;              (cdr ast))
;            #t))))

    (define (prim-call? exp)
      (and (list? exp) (prim? (car exp))))

    (define (prim->c-func p)
      (cond
         ((eq? p 'Cyc-global-vars)       "Cyc_get_global_variables")
         ((eq? p 'Cyc-get-cvar)          "Cyc_get_cvar")
         ((eq? p 'Cyc-set-cvar!)         "Cyc_set_cvar")
         ((eq? p 'Cyc-cvar?)             "Cyc_is_cvar")
         ((eq? p 'Cyc-opaque?)           "Cyc_is_opaque")
         ((eq? p 'Cyc-has-cycle?)        "Cyc_has_cycle")
         ((eq? p 'Cyc-spawn-thread!)     "Cyc_spawn_thread")
         ((eq? p 'Cyc-end-thread!)       "Cyc_end_thread")
         ((eq? p 'Cyc-stdout)            "Cyc_stdout")
         ((eq? p 'Cyc-stdin)             "Cyc_stdin")
         ((eq? p 'Cyc-stderr)            "Cyc_stderr")
         ((eq? p '+)                     "Cyc_sum")
         ((eq? p '-)                     "Cyc_sub")
         ((eq? p '*)                     "Cyc_mul")
         ((eq? p '/)                     "Cyc_div")
         ((eq? p '=)                     "Cyc_num_eq")
         ((eq? p '>)                     "Cyc_num_gt")
         ((eq? p '<)                     "Cyc_num_lt")
         ((eq? p '>=)                    "Cyc_num_gte")
         ((eq? p '<=)                    "Cyc_num_lte")
         ((eq? p 'apply)                 "apply")
         ((eq? p '%halt)                 "__halt")
         ((eq? p 'exit)                  "__halt")
         ((eq? p 'Cyc-default-exception-handler)  "Cyc_default_exception_handler")
         ((eq? p 'Cyc-current-exception-handler)  "Cyc_current_exception_handler")
         ((eq? p 'open-input-file)       "Cyc_io_open_input_file")
         ((eq? p 'open-output-file)      "Cyc_io_open_output_file")
         ((eq? p 'close-port)            "Cyc_io_close_port")
         ((eq? p 'close-input-port)      "Cyc_io_close_input_port")
         ((eq? p 'close-output-port)     "Cyc_io_close_output_port")
         ((eq? p 'Cyc-flush-output-port) "Cyc_io_flush_output_port")
         ((eq? p 'file-exists?)          "Cyc_io_file_exists")
         ((eq? p 'delete-file)           "Cyc_io_delete_file")
         ((eq? p 'read-char)             "Cyc_io_read_char")
         ((eq? p 'peek-char)             "Cyc_io_peek_char")
         ((eq? p 'Cyc-read-line)         "Cyc_io_read_line")
         ((eq? p 'Cyc-display)           "Cyc_display_va")
         ((eq? p 'Cyc-write)             "Cyc_write_va")
         ((eq? p 'Cyc-write-char)        "Cyc_write_char")
         ((eq? p 'car)           "car")
         ((eq? p 'cdr)           "cdr")
         ((eq? p 'caar)          "caar")
         ((eq? p 'cadr)          "cadr")
         ((eq? p 'cdar)          "cdar")
         ((eq? p 'cddr)          "cddr")
         ((eq? p 'caaar)         "caaar")
         ((eq? p 'caadr)         "caadr")
         ((eq? p 'cadar)         "cadar")
         ((eq? p 'caddr)         "caddr")
         ((eq? p 'cdaar)         "cdaar")
         ((eq? p 'cdadr)         "cdadr")
         ((eq? p 'cddar)         "cddar")
         ((eq? p 'cdddr)         "cdddr")
         ((eq? p 'caaaar)        "caaaar")
         ((eq? p 'caaadr)        "caaadr")
         ((eq? p 'caadar)        "caadar")
         ((eq? p 'caaddr)        "caaddr")
         ((eq? p 'cadaar)        "cadaar")
         ((eq? p 'cadadr)        "cadadr")
         ((eq? p 'caddar)        "caddar")
         ((eq? p 'cadddr)        "cadddr")
         ((eq? p 'cdaaar)        "cdaaar")
         ((eq? p 'cdaadr)        "cdaadr")
         ((eq? p 'cdadar)        "cdadar")
         ((eq? p 'cdaddr)        "cdaddr")
         ((eq? p 'cddaar)        "cddaar")
         ((eq? p 'cddadr)        "cddadr")
         ((eq? p 'cdddar)        "cdddar")
         ((eq? p 'cddddr)        "cddddr")
         ((eq? p 'char->integer) "Cyc_char2integer")
         ((eq? p 'integer->char) "Cyc_integer2char")
         ((eq? p 'string->number)"Cyc_string2number2_")
         ((eq? p 'list->string)  "Cyc_list2string")
         ((eq? p 'make-bytevector)   "Cyc_make_bytevector")
         ((eq? p 'bytevector-length) "Cyc_bytevector_length")
         ((eq? p 'bytevector)        "Cyc_bytevector")
         ((eq? p 'bytevector-append)    "Cyc_bytevector_append")
         ((eq? p 'Cyc-bytevector-copy)    "Cyc_bytevector_copy")
         ((eq? p 'Cyc-utf8->string)    "Cyc_utf82string")
         ((eq? p 'Cyc-string->utf8)    "Cyc_string2utf8")
         ((eq? p 'bytevector-u8-ref)    "Cyc_bytevector_u8_ref")
         ((eq? p 'bytevector-u8-set!)   "Cyc_bytevector_u8_set")
         ((eq? p 'make-vector)   "Cyc_make_vector")
         ((eq? p 'list->vector)  "Cyc_list2vector")
         ((eq? p 'vector-length) "Cyc_vector_length")
         ((eq? p 'vector-ref)    "Cyc_vector_ref")
         ((eq? p 'vector-set!)   "Cyc_vector_set")
         ((eq? p 'string-append) "Cyc_string_append")
         ((eq? p 'string-cmp)    "Cyc_string_cmp")
         ((eq? p 'string->symbol) "Cyc_string2symbol")
         ((eq? p 'symbol->string) "Cyc_symbol2string")
         ((eq? p 'number->string) "Cyc_number2string2")
         ((eq? p 'string-length)  "Cyc_string_length")
         ((eq? p 'string-ref)     "Cyc_string_ref")
         ((eq? p 'string-set!)    "Cyc_string_set")
         ((eq? p 'substring)      "Cyc_substring")
         ((eq? p 'Cyc-installation-dir) "Cyc_installation_dir")
         ((eq? p 'command-line-arguments) "Cyc_command_line_arguments")
         ((eq? p 'system)         "Cyc_system")
         ((eq? p 'assq)          "assq")
         ((eq? p 'assv)          "assq")
         ((eq? p 'assoc)         "assoc")
         ((eq? p 'memq)          "memqp")
         ((eq? p 'memv)          "memqp")
         ((eq? p 'member)        "memberp")
         ((eq? p 'length)        "Cyc_length")
         ((eq? p 'set-car!)      "Cyc_set_car")
         ((eq? p 'set-cdr!)      "Cyc_set_cdr")
         ((eq? p 'eq?)           "Cyc_eq")
         ((eq? p 'eqv?)          "Cyc_eq")
         ((eq? p 'equal?)        "equalp")
         ((eq? p 'boolean?)      "Cyc_is_boolean")
         ((eq? p 'char?)         "Cyc_is_char")
         ((eq? p 'null?)         "Cyc_is_null")
         ((eq? p 'number?)       "Cyc_is_number")
         ((eq? p 'real?)         "Cyc_is_real")
         ((eq? p 'integer?)      "Cyc_is_integer")
         ((eq? p 'pair?)         "Cyc_is_pair")
         ((eq? p 'procedure?)    "Cyc_is_procedure")
         ((eq? p 'macro?)        "Cyc_is_macro")
         ((eq? p 'port?)         "Cyc_is_port")
         ((eq? p 'vector?)       "Cyc_is_vector")
         ((eq? p 'bytevector?)   "Cyc_is_bytevector")
         ((eq? p 'string?)       "Cyc_is_string")
         ((eq? p 'eof-object?)   "Cyc_is_eof_object")
         ((eq? p 'symbol?)       "Cyc_is_symbol")
         ((eq? p 'cons)          "make_pair")
         ((eq? p 'cell)          "make_cell")
         ((eq? p 'cell-get)      "cell_get")
         ((eq? p 'set-cell!)     "Cyc_set_car")
         ((eq? p 'set-global!)   "global_set")
         (else
           (error "unhandled primitive: " p))))

    ;; Does the primitive require passing thread data as its first argument?
    (define (prim/data-arg? p)
      (member p '(
        +
        -
        *
        /
        =
        >
        <
        >=
        <=
        apply
        Cyc-default-exception-handler
        Cyc-current-exception-handler
        Cyc-end-thread!
        open-input-file
        open-output-file
        close-port
        close-input-port
        close-output-port
        Cyc-flush-output-port
        file-exists?
        delete-file
        read-char
        peek-char
        Cyc-read-line
        Cyc-write-char
        integer->char
        string->number
        list->string
        make-bytevector
        bytevector-length
        bytevector-append
        Cyc-bytevector-copy
        Cyc-utf8->string
        Cyc-string->utf8
        bytevector
        bytevector-u8-ref
        bytevector-u8-set!
        make-vector
        list->vector
        vector-length
        vector-ref
        vector-set!
        string-append
        string-cmp
        string->symbol
        symbol->string
        number->string
        string-length
        string-ref
        string-set!
        substring
        Cyc-installation-dir
        command-line-arguments
        assq
        assv
        assoc
        memq
        memv
        member
        length
        set-car!
        set-cdr!
        procedure?
        set-cell!)))

    ;; Determine if primitive assigns (allocates) a C variable
    ;; EG: int v = prim();
    (define (prim/c-var-assign p)
      (cond
        ((eq? p 'Cyc-stdout) "port_type")
        ((eq? p 'Cyc-stdin) "port_type")
        ((eq? p 'Cyc-stderr) "port_type")
        ((eq? p 'open-input-file) "port_type")
        ((eq? p 'open-output-file) "port_type")
        ((eq? p '+) "object")
        ((eq? p '-) "object")
        ((eq? p '*) "object")
        ((eq? p '/) "object")
        ((eq? p '=) "object")
        ((eq? p '>) "object")
        ((eq? p '<) "object")
        ((eq? p '>=) "object")
        ((eq? p '<=) "object")
        ((eq? p 'string->number) "object")
        ((eq? p 'string-append) "object")
        ((eq? p 'apply)  "object")
        ((eq? p 'Cyc-read-line) "object")
        ((eq? p 'read-char) "object")
        ((eq? p 'peek-char) "object")
        ((eq? p 'command-line-arguments) "object")
        ((eq? p 'number->string) "object")
        ((eq? p 'symbol->string) "object")
        ((eq? p 'substring) "object")
        ((eq? p 'make-bytevector) "object")
        ((eq? p 'bytevector) "object")
        ((eq? p 'bytevector-append) "object")
        ((eq? p 'Cyc-bytevector-copy) "object")
        ((eq? p 'Cyc-utf8->string) "object")
        ((eq? p 'Cyc-string->utf8) "object")
        ((eq? p 'make-vector) "object")
        ((eq? p 'list->string) "object")
        ((eq? p 'list->vector) "object")
        ((eq? p 'Cyc-installation-dir) "object")
        (else #f)))

    ;; Determine if primitive creates a C variable
    (define (prim/cvar? exp)
        (and (prim? exp)
             (member exp '(
                 Cyc-stdout
                 Cyc-stdin
                 Cyc-stderr
                 open-input-file
                 open-output-file
                 Cyc-installation-dir
                 string->number 
                 string-append list->string
                 make-bytevector
                 bytevector
                 bytevector-append
                 Cyc-bytevector-copy
                 Cyc-utf8->string
                 Cyc-string->utf8
                 make-vector list->vector
                 symbol->string number->string 
                 substring
                 + - * / apply 
                 = > < >= <=
                 command-line-arguments
                 Cyc-read-line
                 read-char peek-char
                 cons cell))))

    ;; Pass continuation as the function's first parameter?
    (define (prim:cont? exp)
      (and (prim? exp)
           (member exp '(Cyc-read-line apply command-line-arguments number->string 
                         + - * /
                         = > < >= <=
                         read-char peek-char 
                         symbol->string list->string substring string-append string->number
                         make-bytevector
                         bytevector-append
                         Cyc-bytevector-copy
                         Cyc-utf8->string
                         Cyc-string->utf8
                         bytevector
                         bytevector-u8-ref
                         bytevector-u8-set!
                         make-vector list->vector Cyc-installation-dir))))

    ;; Primitive functions that pass a continuation or thread data but have no other arguments
    (define (prim:cont/no-args? exp)
      (and (prim? exp)
           (member exp '(command-line-arguments Cyc-current-exception-handler))))

    ;; Pass an integer arg count as the function's first parameter?
    (define (prim:arg-count? exp)
        (and (prim? exp)
             (member exp '(error Cyc-write Cyc-display 
                           number->string string->number string-append 
                           make-bytevector
                           bytevector
                           bytevector-append
                           make-vector
                           = > < >= <=
                           + - * /))))

    ;; Does primitive allocate an object?
    ;; TODO: these are the functions that are defined via macros. This method
    ;; is obsolete and should be replaced by prim:cont? functions over time.
    (define (prim:allocates-object? exp)
        (and  (prim? exp)
              (member exp '())))
))