1;;;; -*-Mode:LISP; Package:LISP; Base:10; Syntax:ISLISP -*-
2;;;; Title:     fprint.lsp
3;;;; Author:    Richard Gabriel
4;;;; License:   New BSD license
5;;;; ISLISP:    Yes
6;;;; CVS:       $Id: fprint.lsp,v 1.8 2013/06/18 05:21:53 jullien Exp $
7
8;;; (19) FPRINT -- Benchmark to print to a file.
9
10;; NOTE,  *test-atoms*  has  been  modified  to  match  ISLISP syntax
11;; reader for symbols and numbers.
12
13(defglobal *test-atoms*
14           '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67
15             mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12
16             wxyzab23 xyzabc34 _23456ab [34567bc {45678cd
17             <56789de >67890xf ]78901fg }89012gh *90123hi))
18
19(defun init-aux (m n atoms)
20   (cond ((= m 0)
21          (car atoms))
22         (t (for ((i n (- i 2))
23                  (a ()))
24                 ((< i 1) a)
25                 (setf a (cons (car atoms) a))
26                 (setf atoms (cdr atoms))
27                 (setf a (cons (init-aux (- m 1) n atoms) a))))))
28
29(defun init (m n atoms)
30   (let ((at (mapcar #'identity atoms))) ;; (copy-list atoms)
31        (for ((a at (cdr a)))
32             ((null (cdr a)) (set-cdr at a)))
33        (init-aux m n at)))
34
35(defglobal test-pattern (init 6 6 *test-atoms*))
36
37(defun fprint ()
38   (let ((stream (open-output-file "fprint.tst")))
39        (format stream "~S~%" test-pattern)
40        (close stream)
41        t))
42
43;;; call:  (fprint)
44