#lang scheme/base

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


(provide
 (all-defined-out))

(require
 scheme/match
 "../tools.ss"
 "../scat.ss"
 "pattern.ss"
 "macro-utils.ss"
 "macro-prim.ss"
 "macro-syntax.ss"
 "macro-eval.ss"
 "core.ss"       ;; compile + literal
 "../target.ss"
 "target-scat.ss"  ;; target:
 "../asm/dictionary.ss"
 )

;; TOOLS

;; 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)
  (make-word
   (lambda _
     (error 'undefined-stub "~a" name))))

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

(declare-stubs
 ~run)

;; 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)
  (scat-compose
   (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)
    (target-value-catch-undefined
     (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))
      macro))

(define macro-word? word?)


;; LOWLEVEL MACROS.

(patterns
 (macro)

 ;; 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))))

 ;; DELAYED CODE

 (([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)

 ;; WORD CREATION
 
 ((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))]))
 
 )




;; HIGLEVEL MACROS

(compositions
 (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.
(ir-ops
 (save)
 (stub)
 (dw value)
 (jw word)
 (cw word)
 (qw value))
(check-opcodes asm-find)