#lang scheme/base

;; This contains the base language for macros. It implements:
;;  * partial evaluation
;;  * bindings to code compilation (labels)
;;  * basic Forth control macros


 ""       ;; compile + literal
 ""  ;; target:


;; To enable macros to reference instantiated runtime library words,
;; the convention is used to create stub words that start with
;; tilde. These can then be overridden by instantiated code words, or
;; throw an error if instantiated before that.

(define (undefined-stub name)
   (lambda _
     (error 'undefined-stub "~a" name))))

(define-syntax-rule (declare-stubs name ...)
    (define-ns (macro) name (undefined-stub 'name))


;; Universal list -> macro convertor: each element is quoted and
;; posprocessed with a glue macro. This can be used to construct
;; tables or simple embedded point-free languages.
(define (list->macro glue lst)
   (map (lambda (el) (macro: ',el ,glue)) lst)))

;; For use in the (? fn) pattern matcher. This creates a curried
;; function which lifts all its arguments to normal values.
(define (target fn . vs)
  (lambda (v)
     (lambda ()
       (apply fn
              (map target-value-eval
                   (cons v vs)))))))

;; Convert a wrapper macro to the word instance, leave other types
;; intact.  NOTE: it might be best to restrict this to 'address' only,
;; because ticked words (macros) are really different from addresses.
(define (unwrap macro)
  (if (word? macro)
      (let ((word (macro->data macro 'cw)))
        (tscat: word))

(define macro-word? word?)



 ;; Transfer of Scat semantics to Coma (postponed) semantics.

 (([qw a] dup)         ([qw a] [qw a]))
 (([qw a] drop)        ())
 (([qw a] not)         ([qw (not a)]))
 (([qw a] [qw b] swap) ([qw b] [qw a]))

 (([qw a] [qw b] +)    ([qw (tscat: a b +)]))

 (([dw a]  dw>)     ([qw a]))

 ;; Will be redefined when data word size != program word size. The
 ;; convention is to use the data word size as unit.
 (([qw a] |,|)   ([dw a]))

 (([qw x] |string,|)  (list->macro
                       (macro: |,|) ;; glue
                       (let ((l (->byte-list x)))
                         (cons (length l) l))))


 (([qw ma] [qw mb] compose)   ([qw (macro: ,ma ,mb)]))

 (([qw label] jump)         ([jw label]))

 ;; Get the address from the macro that wraps a postponed
 ;; word. Perform the macro->data part immediately (as a type check
 ;; for the macro). Postpone the address evaluation, since it is only
 ;; available during assembly.
 (([qw a] address) ([qw (unwrap a)]))

 ;; The basic behaviour is 'run, which will invoke a quoted macro, or
 ;; will delegate a call to the run-time word.

 (([qw (? macro-word? w)] run) w)
 ((run) (macro: ~run))

 ;; 'execute has a lower level semantics: it operates on quoted
 ;; numbers/labels instead, and will not execute macros.
 (([qw label] execute) ([cw label]))
 ((execute) (macro: ~run))

 ;; 'compile will operate on both macros and labels, but won't
 ;; delegate to run-time.
 (([qw (? target-word? w)] compile) ([cw w]))
 (([qw (? macro-word? w)] compile)  w)

 ((save)     ([save]))

 ;; This has a bit of an awkward syntax due its generality. The
 ;; 'asm-transformers' syntax serves the greater good of the pattern
 ;; matching assemblers (one level of quoting)..

; (([,rator . rands] opcode)
;  (list `([,rator ,@rands] [qw ,rator])))

 ;; If a macro is found in the macro dictionary, run the macro, else
 ;; pass the name to another macro. This is used in VM -> native
 ;; forth mapping.
;;  (([qw word-name] [qw default-semantics-name] macro/default)
;;   ((insert
;;     (if (macro-find/false word-name)
;;         `(,(macro-prim: '(word-name) :macro run/s))
;;         `([qw ,word-name]
;;           ,(macro-prim: '(default-semantics-name) :macro run/s))))))

 ;; Quoted parser backends.

 (([qw thing] |*'|)              ([qw thing]))
 ;; RAM
 ;; (([qw realm] [qw n] allot) ([allot realm n]))
 (([qw n] allot) ([allot-data n]))
 ((here)         ([here]))
 ;; Dictionary lookup.
 ;; (([qw tag] [qw dict] dict-find) ([qw (dict-find dict tag)]))

 ;; Name mangling.
 (([qw method] [qw class] [qw dash] prefix)
  ([qw (string->symbol
        (format "~a~a~a" class dash method))]))


 (macro) macro:

 ;; Namespaces
 (pc     ' |.| prefix compile)  ;; method object --



;; Asm ops used in this module. These all needs to be substituted or
;; implemented by the target assembler.
 (dw value)
 (jw word)
 (cw word)
 (qw value))
(check-opcodes asm-find)