mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-13 04:42:13 -08:00
84 lines
3.2 KiB
Common Lisp
84 lines
3.2 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")
|
|
(ext:package-lock (find-package :cl) nil)
|
|
|
|
(defun cl:compile (name &optional (def nil supplied-p))
|
|
(cond ((and supplied-p def)
|
|
(when (functionp def)
|
|
(unless (function-lambda-expression def)
|
|
(return-from compile def))
|
|
(setf def (function-lambda-expression def)))
|
|
(setq form (if name
|
|
`(setf (symbol-function ',name) #',def)
|
|
`(set '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 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 compile (values def t nil)))
|
|
(t
|
|
(setq form `(setf (symbol-function ',name) #',form))))
|
|
(eval form)
|
|
(values name nil nil))
|
|
|
|
(defun cl:compile-file-pathname (name &key (output-file name) (type :fasl type-supplied-p)
|
|
verbose print c-file h-file data-file shared-data-file
|
|
system-p load)
|
|
(let ((extension "fasb"))
|
|
(case type
|
|
((:fasl :fas) (setf extension "fasb"))
|
|
(t (error "In COMPILE-FILE-PATHNAME, the type ~A is unsupported." type)))
|
|
(make-pathname :type extension :defaults output-file)))
|
|
|
|
(defun cl:compile-file (input-pathname
|
|
&key
|
|
((:verbose *compile-verbose*) *compile-verbose*)
|
|
((:print *compile-print*) *compile-print*)
|
|
(load nil)
|
|
(output-pathname 't output-pathname-p)
|
|
&allow-other-keys)
|
|
(setf output-pathname (if (eq output-pathname 't)
|
|
(compile-file-pathname input-pathname)
|
|
(pathname output-pathname)))
|
|
(when *compile-verbose*
|
|
(format t "~&;;; Compiling ~A" input-pathname))
|
|
(with-open-file (sin input-pathname :direction :input)
|
|
(with-open-file (sout output-pathname :direction :output :if-exists :supersede
|
|
:if-does-not-exist :create)
|
|
(loop with *package* = *package*
|
|
and ext:*bytecodes-compiler* = t
|
|
for form = (read sin nil :EOF)
|
|
until (eq form :EOF)
|
|
do (let ((bytecodes (ext:eval-with-env form nil nil nil)))
|
|
(with-standard-io-syntax
|
|
(write `(FUNCALL ,bytecodes) :stream sout :circle t
|
|
:escape t :readably t :pretty nil)
|
|
(terpri sout))))))
|
|
(when load
|
|
(load output-pathname :verbose *compile-verbose*))
|
|
(values output-pathname nil nil))
|
|
|
|
(ext::package-lock (find-package :cl) t)
|
|
|
|
(pushnew :ecl-bytecmp *features*)
|
|
|
|
(provide 'BYTECMP)
|