home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmptest.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  8.1 KB  |  268 lines
  1. ;;; CMPTEST  Functions for compiler test.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (defun self-compile ()
  25.  (with-open-file (log "lsplog" :direction :output)
  26.   (let ((*standard-output* (make-broadcast-stream *standard-output* log)))
  27.  
  28. ;       (self-compile2 "cmpbind")
  29. ;       (self-compile2 "cmpblock")
  30. ;       (self-compile2 "cmpcall")
  31. ;       (self-compile2 "cmpcatch")
  32.        (self-compile2 "cmpenv")
  33. ;       (self-compile2 "cmpeval")
  34. ;       (self-compile2 "cmpflet")
  35. ;       (self-compile2 "cmpfun")
  36. ;       (self-compile2 "cmpif")
  37. ;       (self-compile2 "cmpinline")
  38.        (self-compile2 "cmplabel")
  39. ;       (self-compile2 "cmplam")
  40. ;       (self-compile2 "cmplet")
  41. ;       (self-compile2 "cmploc")
  42. ;       (self-compile2 "cmpmap")
  43. ;       (self-compile2 "cmpmulti")
  44. ;       (self-compile2 "cmpspecial")
  45. ;       (self-compile2 "cmptag")
  46. ;       (self-compile2 "cmptop")
  47. ;       (self-compile2 "cmptype")
  48.        (self-compile2 "cmputil")
  49. ;       (self-compile2 "cmpvar")
  50. ;       (self-compile2 "cmpvs")
  51. ;       (self-compile2 "cmpwt")
  52.  
  53.        ))
  54.  t)
  55.  
  56. (defun setup ()
  57.  
  58. ;  (allocate 'cons 800)
  59. ;  (allocate 'string 256)
  60. ;  (allocate 'structure 32)
  61. ;  (allocate-relocatable-pages 128)
  62.  
  63. ;  (load ":udd:common:cmpnew:cmpinline.lsp")
  64.   (load ":udd:common:cmpnew:cmputil.lsp")
  65. ;  (load ":udd:common:cmpnew:cmptype.lsp")
  66.  
  67. ;  (load ":udd:common:cmpnew:cmpbind.lsp")
  68. ;  (load ":udd:common:cmpnew:cmpblock.lsp")
  69.   (load ":udd:common:cmpnew:cmpcall.lsp")
  70. ;  (load ":udd:common:cmpnew:cmpcatch.lsp")
  71. ;  (load ":udd:common:cmpnew:cmpenv.lsp")
  72. ;  (load ":udd:common:cmpnew:cmpeval.lsp")
  73.   (load ":udd:common:cmpnew:cmpflet.lsp")
  74. ;  (load ":udd:common:cmpnew:cmpfun.lsp")
  75. ;  (load ":udd:common:cmpnew:cmpif.lsp")
  76.   (load ":udd:common:cmpnew:cmplabel.lsp")
  77. ;  (load ":udd:common:cmpnew:cmplam.lsp")
  78. ;  (load ":udd:common:cmpnew:cmplet.lsp")
  79.   (load ":udd:common:cmpnew:cmploc.lsp")
  80. ;  (load ":udd:common:cmpnew:cmpmain.lsp")
  81. ;  (load ":udd:common:cmpnew:cmpmap.lsp")
  82. ;  (load ":udd:common:cmpnew:cmpmulti.lsp")
  83. ;  (load ":udd:common:cmpnew:cmpspecial.lsp")
  84. ;  (load ":udd:common:cmpnew:cmptag.lsp")
  85.   (load ":udd:common:cmpnew:cmptop.lsp")
  86. ;  (load ":udd:common:cmpnew:cmpvar.lsp")
  87. ;  (load ":udd:common:cmpnew:cmpvs.lsp")
  88. ;  (load ":udd:common:cmpnew:cmpwt.lsp")
  89.  
  90. ;  (load ":udd:common:cmpnew:lfun_list")
  91. ;  (load ":udd:common:cmpnew:cmpopt.lsp")
  92.  
  93.   )
  94.  
  95. (defun cli () (process ":cli.pr"))
  96.  
  97. (defun load-fasl ()
  98.  
  99.   (load "cmpinline")
  100.   (load "cmputil")
  101.   (load "cmpbind")
  102.   (load "cmpblock")
  103.   (load "cmpcall")
  104.   (load "cmpcatch")
  105.   (load "cmpenv")
  106.   (load "cmpeval")
  107.   (load "cmpflet")
  108.   (load "cmpfun")
  109.   (load "cmpif")
  110.   (load "cmplabel")
  111.   (load "cmplam")
  112.   (load "cmplet")
  113.   (load "cmploc")
  114.   (load "cmpmap")
  115.   (load "cmpmulti")
  116.   (load "cmpspecial")
  117.   (load "cmptag")
  118.   (load "cmptop")
  119.   (load "cmptype")
  120.   (load "cmpvar")
  121.   (load "cmpvs")
  122.   (load "cmpwt")
  123.  
  124.   (load "cmpmain.lsp")
  125.   (load "lfun_list.lsp")
  126.   (load "cmpopt.lsp")
  127.  
  128.   )
  129.  
  130. (setq *macroexpand-hook* 'funcall)
  131.  
  132. (defun self-compile1 (file)
  133.   (prin1 file) (terpri)
  134.   (compile-file1 file
  135.     :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t))
  136.  
  137. (defun self-compile2 (file)
  138.   (prin1 file) (terpri)
  139.   (compile-file1 file
  140.     :fasl-file t :c-file t :h-file t :data-file t :ob-file t :system-p t)
  141.   (prin1 (load file)) (terpri))
  142.  
  143. (defvar *previous-form* nil)
  144.  
  145. (defun cmp (form)
  146.   (setq *previous-form* form)
  147.   (again))
  148.  
  149. (defun again ()
  150.   (init-env)
  151.   (print *previous-form*)
  152.   (terpri)
  153.   (setq *compiler-output1* *standard-output*)
  154.   (setq *compiler-output2* *standard-output*)
  155.   (setq *compiler-output-data* *standard-output*)
  156.   (let ((prev (get-dispatch-macro-character #\# #\,)))
  157.        (set-dispatch-macro-character #\# #\,
  158.                                      'si:sharp-comma-reader-for-compiler)
  159.        (unwind-protect
  160.         (t1expr *previous-form*)
  161.         (set-dispatch-macro-character #\# #\, prev)))
  162.   (catch *cmperr-tag* (ctop-write "test"))
  163.   t)
  164.  
  165. ;(defun make-cmpmain-for-unix ()
  166. ;       (print "unixmain")
  167. ;       (format t "~&The old value of *FEATURES* is ~s." *features*)
  168. ;       (let ((*features* '(unix common kcl)))
  169. ;            (format t "~&The new value of *FEATURES* is ~s." *features*)
  170. ;            (init-env)
  171. ;            (compile-file1 "cmpmain.lsp"
  172. ;                           :output-file "unixmain"
  173. ;                           :c-file t
  174. ;                           :h-file t
  175. ;                           :data-file t
  176. ;                           :system-p t
  177. ;                           ))
  178. ;       (format t "~&The resumed value of *FEATURES* is ~s." *features*)
  179. ;       )
  180.  
  181. (defun compiler-make-ufun ()
  182.   (make-ufun '(
  183.   "cmpbind.lsp"
  184.   "cmpblock.lsp"
  185.   "cmpcall.lsp"
  186.   "cmpcatch.lsp"
  187.   "cmpenv.lsp"
  188.   "cmpeval.lsp"
  189.   "cmpflet.lsp"
  190.   "cmpfun.lsp"
  191.   "cmpif.lsp"
  192.   "cmpinline.lsp"
  193.   "cmplabel.lsp"
  194.   "cmplam.lsp"
  195.   "cmplet.lsp"
  196.   "cmploc.lsp"
  197.   "cmpmain.lsp"
  198.   "cmpmap.lsp"
  199.   "cmpmulti.lsp"
  200.   "cmpspecial.lsp"
  201.   "cmptag.lsp"
  202.   "cmptop.lsp"
  203.   "cmptype.lsp"
  204.   "cmputil.lsp"
  205.   "cmpvar.lsp"
  206.   "cmpvs.lsp"
  207.   "cmpwt.lsp"
  208.  
  209.   ))
  210.  
  211.   t)
  212.  
  213. (defun remrem ()
  214.        (do-symbols (x (find-package 'lisp))
  215.                    (remprop x 'inline-always)
  216.                    (remprop x 'inline-safe)
  217.                    (remprop x 'inline-unsafe))
  218.        (do-symbols (x (find-package 'system))
  219.                    (remprop x 'inline-always)
  220.                    (remprop x 'inline-safe)
  221.                    (remprop x 'inline-unsafe)))
  222. (defun ckck ()
  223.        (do-symbols (x (find-package 'lisp))
  224.                    (when (or (get x 'inline-always)
  225.                              (get x 'inline-safe)
  226.                              (get x 'inline-unsafe))
  227.                          (print x)))
  228.        (do-symbols (x (find-package 'si))
  229.                    (when (or (get x 'inline-always)
  230.                              (get x 'inline-safe)
  231.                              (get x 'inline-unsafe))
  232.                          (print x))))
  233.  
  234. (defun make-cmpopt (&aux (eof (cons nil nil)))
  235.   (with-open-file (in "cmpopt.db")
  236.     (with-open-file (out "cmpopt.lsp" :direction :output)
  237.       (print '(in-package 'compiler) out)
  238.       (terpri out) (terpri out)
  239.       (do ((x (read in nil eof) (read in nil eof)))
  240.           ((eq x eof))
  241.           (apply #'(lambda (property return-type side-effectp new-object-p
  242.                                      name arg-types body)
  243.                      (when (stringp body)
  244.                        (do ((i 0 (1+ i))
  245.                             (l nil)
  246.                             (l1 nil))
  247.                            ((>= i (length body))
  248.                             (when l1
  249.                               (setq body
  250.                                     (concatenate 'string
  251.                                                  "@"
  252.                                                  (reverse l1)
  253.                                                  ";"
  254.                                                  body))))
  255.                          (when (char= (aref body i) #\#)
  256.                            (incf i)
  257.                            (cond ((member (aref body i) l)
  258.                                   (pushnew (aref body i) l1))
  259.                                  (t (push (aref body i) l))))))
  260.                      (print
  261.                       `(push '(,arg-types ,return-type ,side-effectp
  262.                                           ,new-object-p ,body)
  263.                              (get ',name ',property))
  264.                       out))
  265.                  (cdr x)))
  266.       (terpri out))))
  267.  
  268.