mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-06 02:40:26 -08:00
133 lines
5.1 KiB
Common Lisp
133 lines
5.1 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
|
;;;; Copyright (c) 1990, Giuseppe Attardi.
|
|
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
;;;; BYTECMP Fake compiler which is used as a replacement when we do not
|
|
;;;; want or can have the real native compiler.
|
|
|
|
(in-package "EXT")
|
|
|
|
(defun bc-disassemble (thing)
|
|
(when (si::valid-function-name-p thing)
|
|
(setq thing (fdefinition thing)))
|
|
(cond ((null thing))
|
|
((functionp thing)
|
|
(si::bc-disassemble thing))
|
|
((and (consp thing)
|
|
(member (car thing) '(LAMBDA 'EXT:LAMBDA-BLOCK)))
|
|
(disassemble (compile nil thing)))
|
|
(t
|
|
(error 'simple-type-error
|
|
:datum thing
|
|
:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
|
|
:format-control "DISASSEMBLE cannot accept ~A"
|
|
:format-arguments (list thing))))
|
|
nil)
|
|
|
|
(defun bc-compile (name &optional (def nil supplied-p))
|
|
(cond ((and supplied-p def)
|
|
(when (functionp def)
|
|
(unless (function-lambda-expression def)
|
|
(return-from bc-compile (values def nil nil)))
|
|
(setf def (function-lambda-expression def)))
|
|
(setq form (if name
|
|
`(progn (setf (symbol-function ',name) #',def) ',name)
|
|
`(setq GAZONK #',def))))
|
|
((not (fboundp name))
|
|
(error "Symbol ~s is unbound." name))
|
|
((typep (setf def (symbol-function name)) 'standard-generic-function)
|
|
(warn "COMPILE can not compile generic functions yet")
|
|
(return-from bc-compile (values def t nil)))
|
|
((null (setq form (function-lambda-expression def)))
|
|
(warn "We have lost the original function definition for ~s. Compilation failed"
|
|
name)
|
|
(return-from bc-compile (values def t nil)))
|
|
(t
|
|
(setq form `(progn (setf (symbol-function ',name) #',form) ',name))))
|
|
(values (eval form) nil nil))
|
|
|
|
(defun bc-compile-file-pathname (name &key (output-file name) (type :fasl)
|
|
verbose print c-file h-file data-file
|
|
shared-data-file system-p load)
|
|
(declare (ignore load c-file h-file data-file shared-data-file system-p verbose print))
|
|
(let ((extension "fasc"))
|
|
(case type
|
|
((:fasl :fas) (setf extension "fasc"))
|
|
(t (error "In COMPILE-FILE-PATHNAME, the type ~A is unsupported." type)))
|
|
(make-pathname :type extension :defaults output-file)))
|
|
|
|
(defun bc-compile-file (input
|
|
&key
|
|
((:verbose *compile-verbose*) *compile-verbose*)
|
|
((:print *compile-print*) *compile-print*)
|
|
(load nil)
|
|
(output-file nil output-file-p)
|
|
&allow-other-keys &aux foo)
|
|
(setf output-file (if output-file-p
|
|
(pathname output-file)
|
|
(bc-compile-file-pathname input)))
|
|
(when *compile-verbose*
|
|
(format t "~&;;; Compiling ~A" input))
|
|
(cond ((not (streamp input))
|
|
(let* ((ext:*source-location* (cons (truename input) 0))
|
|
(*compile-file-pathname* (pathname (merge-pathnames input)))
|
|
(*compile-file-truename* (truename input)))
|
|
(with-open-file (sin input :direction :input)
|
|
(bc-compile-file sin :output-file output-file))))
|
|
((not output-file-p)
|
|
(error "COMPILE-FILE invoked with a stream input and no :OUTPUT-FILE"))
|
|
(t
|
|
(with-open-file (sout output-file :direction :output :if-exists :supersede
|
|
:if-does-not-exist :create)
|
|
(handler-case
|
|
(let ((binary (loop with *package* = *package*
|
|
with ext:*bytecodes-compiler* = t
|
|
for position = (file-position input)
|
|
for form = (read input nil :EOF)
|
|
until (eq form :EOF)
|
|
do (when ext::*source-location*
|
|
(rplacd ext:*source-location* position))
|
|
collect (si:eval-with-env form nil nil nil nil))))
|
|
(sys:with-ecl-io-syntax
|
|
(write binary :stream sout :circle t :escape t :readably t :pretty nil))
|
|
(terpri sout))
|
|
(error (c) (let ((*print-readably* nil)
|
|
(*print-pretty* nil)
|
|
(*print-circle* t))
|
|
(princ c)
|
|
(print foo)
|
|
(break)))))))
|
|
(when load
|
|
(load output-file :verbose *compile-verbose*))
|
|
(values output-file nil nil))
|
|
|
|
(defun install-bytecodes-compiler ()
|
|
(ext::package-lock (find-package :cl) nil)
|
|
(pushnew :ecl-bytecmp *features*)
|
|
(setf (fdefinition 'disassemble) #'bc-disassemble
|
|
(fdefinition 'compile) #'bc-compile
|
|
(fdefinition 'compile-file) #'bc-compile-file
|
|
(fdefinition 'compile-file-pathname) #'bc-compile-file-pathname)
|
|
(ext::package-lock (find-package :cl) t))
|
|
|
|
#-ecl-min
|
|
(progn
|
|
#+(and dlopen (not windows))
|
|
(sys::autoload "SYS:cmp" 'compile-file 'compile 'compile-file-pathname 'disassemble)
|
|
#-(and dlopen (not windows))
|
|
(install-bytecodes-compiler)
|
|
)
|
|
|
|
(provide 'BYTECMP)
|
|
|
|
#-ecl-min
|
|
(package-lock "COMMON-LISP" t)
|