Changeset 8448


Ignore:
Timestamp:
02/02/05 16:52:06 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/compile-file.lisp

    r8442 r8448  
    22;;;
    33;;; Copyright (C) 2004-2005 Peter Graves
    4 ;;; $Id: compile-file.lisp,v 1.53 2005-02-01 14:21:03 piso Exp $
     4;;; $Id: compile-file.lisp,v 1.54 2005-02-02 16:52:06 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    127127                           (when compile-time-too
    128128                             (eval form))))))
    129                 (push name jvm::*toplevel-defuns*)
     129                (push name jvm::*functions-defined-in-current-file*)
     130                (jvm::note-name-defined name)
    130131                ;; If NAME is not fbound, provide a dummy definition so that
    131132                ;; getSymbolFunctionOrDie() will succeed when we try to verify that
     
    134135                  (setf (symbol-function name) #'dummy)
    135136                  (push name *fbound-names*)))))
     137           ((DEFGENERIC DEFMETHOD)
     138            (jvm::note-name-defined (second form))
     139            (process-toplevel-form (macroexpand-1 form) stream compile-time-too)
     140            (return-from process-toplevel-form))
    136141           (DEFMACRO
    137142            (let ((name (second form)))
     
    253258                  (jvm:*safety* jvm:*safety*)
    254259                  (jvm:*debug* jvm:*debug*)
    255                   (jvm::*toplevel-defuns* ())
    256                   (*fbound-names* ()))
     260                  (jvm::*functions-defined-in-current-file* '())
     261                  (*fbound-names* '()))
    257262              (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
    258263              (terpri out)
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8446 r8448  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.383 2005-02-01 22:24:26 piso Exp $
     4;;; $Id: jvm.lisp,v 1.384 2005-02-02 16:47:14 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    193193
    194194(defun dump-1-variable (variable)
    195   (%format t "  ~S special-p = ~S register = ~S level = ~S index = ~S declared-type = ~S~%"
     195  (%format t "  ~S special-p = ~S register = ~S index = ~S declared-type = ~S~%"
    196196           (variable-name variable)
    197197           (variable-special-p variable)
    198198           (variable-register variable)
    199            (variable-level variable)
    200199           (variable-index variable)
    201200           (variable-declared-type variable)))
     
    710709    new-form))
    711710
     711(defun p1-function-call (form)
     712  (let ((op (car form)))
     713    (let ((new-form (rewrite-function-call form)))
     714      (when (neq new-form form)
     715        (dformat t "old form = ~S~%" form)
     716        (dformat t "new form = ~S~%" new-form)
     717        (return-from p1-function-call (p1 new-form))))
     718    (let ((source-transform (source-transform op)))
     719      (when source-transform
     720        (let ((new-form (expand-source-transform form)))
     721          (when (neq new-form form)
     722            (return-from p1-function-call (p1 new-form))))))
     723    (let ((expansion (inline-expansion op)))
     724      (when expansion
     725        (return-from p1-function-call (p1 (expand-inline form expansion)))))
     726    (let ((local-function (find-local-function op)))
     727      (cond (local-function
     728             (dformat t "p1 local function ~S~%" op)
     729
     730             ;; FIXME
     731             (dformat t "local function assumed not single-valued~%")
     732             (setf (compiland-single-valued-p *current-compiland*) nil)
     733
     734             (unless (eq (local-function-compiland local-function)
     735                         *current-compiland*)
     736               (let ((variable (local-function-variable local-function)))
     737                 (when variable
     738                   (unless (eq (variable-compiland variable) *current-compiland*)
     739                     (dformat t "p1 ~S used non-locally~%" (variable-name variable))
     740                     (setf (variable-used-non-locally-p variable) t))))))
     741            (t
     742             ;; Not a local function call.
     743             (unless (single-valued-p op)
     744               (%format t "not single-valued op = ~S~%" op)
     745               (setf (compiland-single-valued-p *current-compiland*) nil)))))
     746    (list* op (mapcar #'p1 (cdr form)))))
     747
    712748(defun p1 (form)
    713749  (cond ((symbolp form)
     
    748784                         (compiler-unsupported "P1: unsupported special operator ~S" op))
    749785                        (t
    750                          ;; Function call.
    751                          (let ((new-form (rewrite-function-call form)))
    752                            (when (neq new-form form)
    753                              (dformat t "old form = ~S~%" form)
    754                              (dformat t "new form = ~S~%" new-form)
    755                              (return-from p1 (p1 new-form))))
    756                          (let ((source-transform (source-transform op)))
    757                            (when source-transform
    758                              (let ((new-form (expand-source-transform form)))
    759                                (when (neq new-form form)
    760                                  (return-from p1 (p1 new-form))))))
    761                          (let ((expansion (inline-expansion op)))
    762                            (when expansion
    763                              (return-from p1 (p1 (expand-inline form expansion)))))
    764                          (let ((local-function (find-local-function op)))
    765                            (cond (local-function
    766                                   (dformat t "p1 local function ~S~%" op)
    767 
    768                                   ;; FIXME
    769                                   (dformat t "local function assumed not single-valued~%")
    770                                   (setf (compiland-single-valued-p *current-compiland*) nil)
    771 
    772                                   (unless (eq (local-function-compiland local-function)
    773                                               *current-compiland*)
    774                                     (let ((variable (local-function-variable local-function)))
    775                                       (when variable
    776                                         (unless (eq (variable-compiland variable) *current-compiland*)
    777                                           (dformat t "p1 ~S used non-locally~%" (variable-name variable))
    778                                           (setf (variable-used-non-locally-p variable) t))))))
    779                                  (t
    780                                   ;; Not a local function call.
    781                                   (unless (single-valued-p op)
    782                                     (%format t "not single-valued op = ~S~%" op)
    783                                     (setf (compiland-single-valued-p *current-compiland*) nil)))))
    784                          (list* op (mapcar #'p1 (cdr form))))))
     786                         (p1-function-call form)
     787                         )
     788                        ))
    785789                 ((and (consp op) (eq (car op) 'LAMBDA))
    786790                  (p1 (list* 'FUNCALL form)))
     
    25602564     nil)))
    25612565
    2562 (defvar *toplevel-defuns* nil)
     2566(defvar *defined-functions*)
     2567
     2568(defvar *undefined-functions*)
     2569
     2570(defun note-name-defined (name)
     2571  (when (boundp '*defined-functions*)
     2572    (push name *defined-functions*))
     2573  (when (boundp '*undefined-functions*)
     2574    (setf *undefined-functions* (remove name *undefined-functions*))))
     2575
     2576(defvar *functions-defined-in-current-file* nil)
    25632577
    25642578(defsubst notinline-p (name)
     
    25722586        ((sys:built-in-function-p name)
    25732587         t)
    2574         ((memq name *toplevel-defuns*)
     2588        ((memq name *functions-defined-in-current-file*)
    25752589         t)
    25762590        (t
     
    26592673      (return-from compile-function-call
    26602674                   (compile-local-function-call form target representation)))
     2675    (when (and (boundp '*defined-functions*) (boundp '*undefined-functions*))
     2676      (unless (or (fboundp op)
     2677                  (eq op (compiland-name *current-compiland*))
     2678                  (memq op *defined-functions*))
     2679        (push op *undefined-functions*)))
    26612680    (let ((numargs (length args)))
    26622681      (case (length args)
     
    39673986          ((and (consp name) (eq (car name) 'SETF))
    39683987           ; FIXME Need to check for NOTINLINE declaration!
    3969            (cond ((member name *toplevel-defuns* :test #'equal)
     3988           (cond ((member name *functions-defined-in-current-file* :test #'equal)
    39703989                  (emit 'getstatic *this-class*
    39713990                        (declare-setf-function name) +lisp-object+)
     
    54575476            (*warnings* 0)
    54585477            (*errors* 0)
     5478            (*defined-functions* '())
     5479            (*undefined-functions* '())
    54595480            (*in-compilation-unit* t))
    54605481        (unwind-protect
    54615482            (funcall fn)
    5462           (unless (zerop (+ *errors* *warnings* *style-warnings*))
     5483          (unless (and (zerop (+ *errors* *warnings* *style-warnings*))
     5484                       (null *undefined-functions*))
    54635485            (format t "~%; Compilation unit finished~%")
    54645486            (unless (zerop *errors*)
     
    54715493              (format t ";   Caught ~D STYLE-WARNING condition~P~%"
    54725494                      *style-warnings* *style-warnings*))
     5495            (when *undefined-functions*
     5496              (format t ";   The following functions were used but not defined:~%")
     5497              (dolist (name *undefined-functions*)
     5498                (format t ";     ~S~%" name)))
    54735499            (terpri))))))
    54745500
Note: See TracChangeset for help on using the changeset viewer.