;;;-*- Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT HL12B HL12BI) -*-

;;; Copyright (C) 1987 Texas Instruments Incorporated. All rights reserved.


2;;;  This file contains features for compatibility with "Pseudoscheme" from MIT.*


(export '(scheme:scheme scheme:quit) scheme-package)

(defun scheme:scheme ()
  "Initialize for execution of Scheme programs."
  (turn-scheme-on)
  (format t "~&Scheme.~&")
  (values))

(defun scheme:quit ()
  "Leave Scheme, returning to Common Lisp mode."
  (turn-common-lisp-on)
  (format t "~&Common Lisp.~&")
  (values))


;; "##" is an expression evaluating to the last expression computed by
;;   the read-eval-print loop.  This corresponds to "*" in Common Lisp and
;;   "(%out)" in MIT Scheme.

(defun sharp-sharp-read-macro (stream subchar arg)
  (cond (arg (sharp-not-scheme stream subchar arg))
	(t 'lisp:*)))
(set-dispatch-macro-character #\# #\# #'sharp-sharp-read-macro SCHEME-READTABLE)

(export '(scheme:%out) scheme-package)
(defun scheme:%out () *)


(export '(scheme:define-macro) scheme-package)
(defmacro scheme:define-macro (pattern &body body) ; from Yale Scheme
  (let* ((name (car pattern))
	 (formals (cdr pattern))
	 (args (convert-formals formals)))
    (let ((rest (member '&rest args)))
      (when (and rest (string= (second rest) "BODY"))
	;; very effective hack, for proper indentation
	(setf (first rest) '&body)))
    `(defmacro ,name ,args
       (with-scheme-semantics
	 ,@body))))