ide/ide.lisp

   1 ;;; ide.lisp -- backend functions for an interactive development environment
   2 ;;; Written in 2004 by  Luke Gorrie <luke@member.fsf.org>
   3 ;;;
   4 ;;; This program has been released into the public domain.
   5 ;;;
   6 ;;; We define a simple interface for manipulating a Movitz image
   7 ;;; within its host Lisp. The interface is intended for use by Emacs
   8 ;;; modes such as SLIME and (hopefully) ELI.
   9
  10 (defpackage #:movitz.ide
  11   (:use #:cl)
  12   (:export #:compile-movitz-file
  13            #:compile-defun
  14            #:dump-image
  15            #:movitz-disassemble
  16            #:movitz-disassemble-primitive
  17            #:movitz-disassemble-method
  18            #:movitz-arglist
  19            #:movitz-macroexpand))
  20
  21 (in-package #:movitz.ide)
  22
  23 (defmacro with-image ((&optional (image-form 'movitz:*image*)) &body body)
  24   `(let ((movitz:*image* ,image-form))
  25      (check-type movitz:*image* movitz::movitz-image "a Movitz image")
  26      ,@body))
  27
  28 (defun compile-movitz-file (filename)
  29   "Compile FILENAME as Movitz source."
  30   (with-image ()
  31     (movitz:movitz-compile-file filename)))
  32
  33 (defun compile-defun (source package-printname)
  34   "Compile the string SOURCE as Movitz source."
  35   (with-image ()
  36     (with-input-from-string (stream source)
  37       (movitz:movitz-compile-stream stream :path "movitz-ide-toplevel"
  38                                            :package (get-package package-printname)))))
  39
  40 (defun dump-image (filename)
  41   "Dump the current image into FILENAME."
  42   (with-image ()
  43     (movitz:dump-image :path filename)))
  44
  45 ;;; slime-friendly entry point.
  46 (defun movitz-disassemble (printname package-printname)
  47   "Return the disassembly of SYMBOL-NAME's function as a string."
  48   (with-image ()
  49     (with-output-to-string (*standard-output*)
  50       (movitz:movitz-disassemble (get-sexpr printname
  51                                             (get-package package-printname))))))
  52
  53 (defun movitz-disassemble-primitive (printname package-printname)
  54   "Return the disassembly of SYMBOL-NAME's function as a string."
  55   (with-image ()
  56     (with-output-to-string (*standard-output*)
  57       (movitz::movitz-disassemble-primitive (get-sexpr printname
  58                                                        (get-package package-printname))))))
  59
  60 (defun movitz-disassemble-method (gf-name lambda-list qualifiers package-name)
  61   (with-image ()
  62     (let ((package (get-package package-name)))
  63       (with-output-to-string (*standard-output*)
  64         (movitz:movitz-disassemble-method (get-sexpr gf-name package)
  65                                           (get-sexpr lambda-list package)
  66                                           (mapcar #'read-from-string qualifiers))))))
  67
  68 (defun movitz-arglist (name package-name)
  69   (with-image ()
  70     (let* ((package (get-package package-name))
  71            (funobj (movitz::movitz-env-named-function (get-sexpr name package))))
  72       (if (not funobj)
  73           "not defined"
  74           (let ((*package* package))
  75             (princ-to-string (movitz::movitz-print (movitz::movitz-funobj-lambda-list funobj))))))))
  76
  77 (defun movitz-macroexpand (string package-name)
  78   (with-image ()
  79     (let* ((*package* (get-package package-name))
  80            (form (get-sexpr string *package*))
  81            (expansion (movitz::movitz-macroexpand-1 form)))
  82       (princ-to-string (movitz::movitz-print expansion)))))
  83
  84
  85 \f
  86 ;;;; Utilities.
  87
  88 (defvar scratch-package (make-package '#:movitz.ide.scratch)
  89   "Scratch package used internally for reading symbols into.")
  90
  91 (defun get-symbol (printname &optional (package *package*))
  92   "Return the symbol with PRINTNAME in PACKAGE.
  93 Signal an error if there is no such symbol."
  94   (or (find-symbol (readname printname) package)
  95       (error "Can't find \"~A\" as a symbol in ~S" printname package)))
  96
  97 (defun get-sexpr (printname &optional (package *package*))
  98   (let ((*package* package))
  99     (read-from-string printname)))
 100
 101 (defun get-package (printname)
 102   "Return the package with PRINTNAME.
 103 Signal an error if there is no such package."
 104   (or (find-package (readname printname))
 105       (error "Can't find package \"~A\"" printname)))
 106
 107 (defun readname (printname)
 108   "Read the string PRINTNAME into a symbol and return the symbol-name.
 109 Trigger an error if PRINTNAME does not read as a symbol."
 110   (let ((*package* scratch-package))
 111     (let ((obj (read-from-string printname)))
 112       (if (symbolp obj)
 113           (symbol-name obj)
 114           (error "Not a symbol: ~S" obj)))))
 115