;;;;
;;;;
;;;; runtime-macros.stk         -- Macros available at bootstrap
;;;;
;;;; Copyright © 2022-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 14-Apr-2022 15:55
;;;;

;; NOTE: Force the module to STklos (this is the case by default, EXCEPT that
;; it is STKLOS-COMPILER when we are bootstrapping.
(select-module STklos)


;;;;
;;;; WHEN/UNLESS
;;;;
(define-macro (when . args)
  (if (<= (length args) 1)
      (syntax-error 'when "bad syntax in ~S" `(when ,@args))
      `(if ,(car args) (begin ,@(cdr args)))))

(define-macro (unless . args)
  (if (<= (length args) 1)
      (syntax-error 'unless "bad syntax in ~S" `(unless ,@args))
      `(if (not ,(car args)) (begin ,@(cdr args)))))

;;;;
;;;; SET!
;;;;
(define-macro (set! . args)
  `(%%set! ,@args))


;; ======================================================================
;;
;; %claim-error
;;
;; Permit to claim that a function has detected an error
;; For instance
;;   (define (change-first-char! str char)
;;      (%claim-error 'change-first-char! (string-set! str 0 char)))
;;   > (change-first-char! (string-copy "abc") 10)
;;   **** Error:
;;  change-first-char!: bad character `10'
;;
;; Here the error is claimed by change-first-char! instead of string-set!
(define-macro (%claim-error owner . body)
  (let ((x (gensym)))
    `(with-handler (lambda (,x) (error ,owner (condition-ref ,x 'message)))
                   ,@body)))


;; ----------------------------------------------------------------------
;; syntax-error
;; ----------------------------------------------------------------------
(define-macro (syntax-error . args)
  (if (zero? (length args))
      (error 'syntax-error "needs at least one argument")
      `(%syntax-error ,@args)))


;; ----------------------------------------------------------------------
;; define-syntax
;; ----------------------------------------------------------------------
(define-macro (define-syntax macro-name syn-rules)
  (if (or (not (pair? syn-rules))
          (not (eq? (car syn-rules) 'syntax-rules)))
      (error 'define-syntax "in `~S', bad syntax-rules ~S" macro-name syn-rules)

      ;; SRFI-46:
      ;; Let the user pick the ellipsis symbol. Since STklos does not recognize
      ;; symbols starting with ":", we test for symbol and keyword here.
      ;; If we find that the user included a symbol or keyword instead of a list
      ;; after "SYNTAX-RULES", then it's the ellipsis marker to be used,
      ;; (SYNTAX-RULES ::: () ((_ (f x :::)) (do-something x :::)))
      (let ((ellipsis '...))
        (when (or (symbol?  (cadr syn-rules))
                  (keyword? (cadr syn-rules)))
          (set! ellipsis (cadr syn-rules))
          (set! syn-rules (cdr syn-rules)))


        (let ((keywords    (cons macro-name (cadr syn-rules)))
              (clauses     (cddr syn-rules))
              (find-clause (symbol-value 'find-clause (find-module 'MBE))))
          `(define-macro (,macro-name . args)
             (%find-macro-clause ',macro-name args
                                 ',keywords
                                 ',clauses
                                 ',ellipsis))))))
