;;; MAKE_UFUN Makes Ufun list for user-defined functions. ;;; ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL 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, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (in-package 'compiler) (defvar gazonk (make-package 'symbol-table :use nil)) (defvar eof (cons nil nil)) (defvar *Ufun-out*) (defvar *str* (make-array 128 :element-type 'string-char :fill-pointer 0)) (defun make-Ufun (in-files &key (out-file "Ufun_list.lsp")) (with-open-file (*Ufun-out* out-file :direction :output) (print '(in-package "COMPILER") *Ufun-out*) (dolist (file in-files) (with-open-file (in (merge-pathnames file #".lsp")) (loop (when (eq (setq form (read in nil eof)) eof) (return)) (do-form form)))))) (defun do-form (form) (when (consp form) (case (car form) (defun (let ((*package* (find-package 'compiler))) (print `(si:putprop ',(cadr form) ,(get-cname (cadr form)) 'Ufun) *Ufun-out*)) (eval form)) (progn (mapc #'do-form (cdr form))) (eval-when (if (member 'load (cadr form)) (mapc #'do-form (cddr form)) (if (member 'compile (cadr form)) (mapc #'eval (cddr form))))) (t (if (macro-function (car form)) (do-form (macroexpand-1 form)) (eval form)))))) (defun get-cname (symbol &aux (name (symbol-name symbol))) (setf (fill-pointer *str*) 0) (vector-push #\U *str*) (dotimes (n (length name)) (let ((char (schar name n))) (cond ((alphanumericp char) (vector-push (char-downcase char) *str*)) ((char= char #\-) (vector-push #\_ *str*)) ((char= char #\*) (vector-push #\A *str*)) ))) (multiple-value-bind (foo flag) (find-symbol *str* 'symbol-table) (unless flag ;(setq foo (intern (copy-seq *str*) 'symbol-table)) (setq foo (intern *str* 'symbol-table)) ;(set foo nil) (return-from get-cname *str*)) (gensym *str*) (gensym 0) (loop (setq name (symbol-name (gensym))) (multiple-value-bind (foo flag1) (intern name 'symbol-table) (unless flag1 ;(set foo nil) (return-from get-cname name))))) )