;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

;;; Cold startup for SCHEME.

;;; Simple syntaxer written in Common Lisp.

(defvar *cold-obarray* '())

(defun cold-intern (symbol)
  (let ((s-symbol
	  (cli:member symbol *cold-obarray*
		     :test #'(lambda (s s-symbol)
			       (eq? s (send s-symbol :external-object))))))
    (if s-symbol
	(first s-symbol)
	(let ((s-symbol (make-instance 'scheme-symbol :external-object symbol)))
	  (push s-symbol *cold-obarray*)
	  s-symbol))))

(defvar *external-syntax-table* '())

(defun external-syntax (expression)
  (if (symbol? expression)
      (syntax-variable expression)
      (let ((syntaxer-pair (assq (first expression) *external-syntax-table*)))
	(if (null? syntaxer-pair)
	    (syntax-combination expression)
	    (apply (cadr syntaxer-pair) (rest expression))))))

(defun syntax-variable (expression)
  (make-instance 'c-variable
		 :symbol expression
		 :depth  nil
		 :offset nil))

(defun syntax-combination (expression)
  (make-instance 'combination
		 :guts (mapcar #'external-syntax expression)))

(defun syntax-define (name value)
  (make-instance 'definition
		 :identifier name
		 :value (external-syntax value)))

(push (list 'define #'syntax-define) *external-syntax-table*)

(defun syntax-set (name value)
  (make-instance 'assignment
		 :identifier name
		 :value (external-syntax value)))

(push (list 'set! #'syntax-set) *external-syntax-table*)

(defun syntax-named-lambda (bound-variables body)
  (make-instance 'lambda
		 :bound-variables bound-variables
		 :body (external-syntax body)))

(push (list 'named-lambda #'syntax-named-lambda) *external-syntax-table*)

(defun syntax-sequence (&rest expressions)
  (labels
    ((syntax-sequence-internal (elist)
       (let ((exp1 (external-syntax (first elist)))
	     (others (rest  elist)))
       (if (null? others)
	   exp1
	   (make-instance 'sequence
			  :first-form exp1
			  :second-form (syntax-sequence-internal others))))))
    (syntax-sequence-internal expressions)))

(push (list 'sequence #'syntax-sequence) *external-syntax-table*)

(defun syntax-quote (object)
  (make-instance 'external-list-structure
		 :external-object object))

(push (list 'quote #'syntax-quote) *external-syntax-table*)

(defun syntax-the-environment ()
  (make-instance 'the-environment))

(push (list 'the-environment #'syntax-the-environment) *external-syntax-table*)