home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d556 / scheme2c.lha / Scheme2C / Scheme-src.lzh / scsc / readtext.sc < prev    next >
Text File  |  1991-10-11  |  14KB  |  395 lines
  1. ;;; The functions in this file read the program text, expand text macros, and
  2. ;;; process all MODULE, INCLUDE, DEFINE-EXTERNAL, DEFINE-C-EXTERNAK and
  3. ;;; DEFINE-MACRO directives. The function READ-TEXT is called to read each
  4. ;;; S-expression from the source files(s).  It will return the eof-object when
  5. ;;; all text has been read.
  6. ;;;
  7.  
  8. ;*              Copyright 1989 Digital Equipment Corporation
  9. ;*                         All Rights Reserved
  10. ;*
  11. ;* Permission to use, copy, and modify this software and its documentation is
  12. ;* hereby granted only under the following terms and conditions.  Both the
  13. ;* above copyright notice and this permission notice must appear in all copies
  14. ;* of the software, derivative works or modified versions, and any portions
  15. ;* thereof, and both notices must appear in supporting documentation.
  16. ;*
  17. ;* Users of this software agree to the terms and conditions set forth herein,
  18. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  19. ;* right and license under any changes, enhancements or extensions made to the
  20. ;* core functions of the software, including but not limited to those affording
  21. ;* compatibility with other hardware or software environments, but excluding
  22. ;* applications which incorporate this software.  Users further agree to use
  23. ;* their best efforts to return to Digital any such changes, enhancements or
  24. ;* extensions that they make and inform Digital of noteworthy uses of this
  25. ;* software.  Correspondence should be provided to Digital at:
  26. ;* 
  27. ;*                       Director of Licensing
  28. ;*                       Western Research Laboratory
  29. ;*                       Digital Equipment Corporation
  30. ;*                       100 Hamilton Avenue
  31. ;*                       Palo Alto, California  94301  
  32. ;* 
  33. ;* This software may be distributed (but not offered for sale or transferred
  34. ;* for compensation) to third parties, provided such third parties agree to
  35. ;* abide by the terms and conditions of this notice.  
  36. ;* 
  37. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  38. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  39. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  40. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  41. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  42. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  43. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  44. ;* SOFTWARE.
  45.  
  46. (module readtext)
  47.  
  48. ;;; External definitions.
  49.  
  50. (include "plist.sch")
  51. (include "expform.sch")
  52.  
  53. (define (READ-TEXT)
  54.     (let ((form '()))
  55.      (if sc-splice
  56.          (begin (set! form (car sc-splice))
  57.             (set! sc-splice (cdr sc-splice)))
  58.          (begin (set! form (sc-expand (read-from-sc-input)))
  59.             (if (log? 'macro)
  60.             (begin (pretty-print-$tree form sc-icode)
  61.                    (newline sc-icode)))))
  62.      (case (and (pair? form) (car form))
  63.            ((define-external)
  64.         (do-define-external form)
  65.         (read-text))
  66.            ((define-c-external)
  67.         (do-define-c-external form)
  68.         (read-text))
  69.            ((define-macro)
  70.         (read-text))
  71.            ((module)
  72.         (do-module form)
  73.         (read-text))
  74.            ((include)
  75.         (do-include form)
  76.         (read-text))
  77.            ((define-constant)
  78.         (read-text))
  79.            ((eval-when)
  80.         (if (memq 'compile (cadr form))
  81.             (eval (cons 'begin (cddr form))))
  82.         (read-text))
  83.            (else  (cond ((and (pair? form)
  84.                   (pair? (car form))
  85.                   (eq? (caar form) 'lambda)
  86.                   (null? (cadar form)))
  87.                  (set! sc-splice (append (cddar form) sc-splice))
  88.                  (read-text))
  89.                 (else (if (equal? module-name "")
  90.                       (begin (report-error
  91.                          "Module name is not defined")
  92.                          (set! module-name "noname")))
  93.                   form))))))
  94.  
  95. (define (READ-FROM-SC-INPUT)
  96.     (do ((form (read (car sc-input)) (read (car sc-input))))
  97.     ((or (and (eof-object? form) (null? (cdr sc-input)))
  98.          (not (eof-object? form)))
  99.      (if (log? 'source)
  100.          (begin (pretty-print-$tree form sc-icode)
  101.             (newline sc-icode)))
  102.      form)
  103.     (close-port (car sc-input))
  104.     (set! sc-splice (cadr sc-input))
  105.     (set! sc-input (cddr sc-input))))
  106.  
  107. ;;; Macro expansion is done by this code.  It is based upon the ideas in
  108. ;;; "Expansion-Passing Style: Beyond Conventional Macros", 1986 ACM Conference
  109. ;;; on Lisp and Functional Programming.
  110.  
  111. (define (SC-EXPAND x) (sc-initial-expander x sc-initial-expander))
  112.  
  113. (define (SC-INITIAL-EXPANDER x e)
  114.     (let ((e1 (cond ((symbol? x) *sc-identifier-expander*)
  115.             ((not (pair? x)) (lambda (x e) x))
  116.             ((symbol? (car x))
  117.              (let ((func (get (car x) 'macro)))
  118.               (if (procedure? func)
  119.                   func
  120.                   *sc-application-expander*)))
  121.             (else *sc-application-expander*))))
  122.      (e1 x e)))
  123.  
  124. (define (SC-EXPAND-ONCE x) (sc-initial-expander x (lambda (x e) x)))
  125.  
  126. (define (*SC-IDENTIFIER-EXPANDER* x e)
  127.     (let ((constant (get x 'macro)))
  128.      (if (pair? constant) (car constant) x)))
  129.  
  130. (define (*SC-APPLICATION-EXPANDER* x e)
  131.     (if (islist x 1)
  132.     (map (lambda (x) (e x e)) x)
  133.     (expand-error '*SC-APPLICATION-EXPANDER* x)))
  134.  
  135. (define (INSTALL-SC-EXPANDER keyword function)
  136.     (put keyword 'macro function))
  137.  
  138. ;;; External functions and variables which follow Scheme's conventions are
  139. ;;; defined by the following form:
  140. ;;;
  141. ;;;    (DEFINE-EXTERNAL var module)
  142. ;;;
  143. ;;;    (DEFINE-EXTERNAL var TOP-LEVEL)
  144. ;;;
  145. ;;;    (DEFINE-EXTERNAL var "module" "name")
  146. ;;;
  147. ;;;    (DEFINE-EXTERNAL (func args...) module)
  148. ;;;
  149. ;;;    (DEFINE-EXTERNAL (func args...) "module" "name")
  150.  
  151. (define (DO-DEFINE-EXTERNAL exp)
  152.     (cond ((and (islist exp 3 3) (symbol? (cadr exp)) (symbol? (caddr exp)))
  153.        (let* ((var    (cadr exp))
  154.           (hex    (lchexname var))
  155.           (module (lchexname (caddr exp))))
  156.          (if (eq? (caddr exp) 'top-level)
  157.              (newv var 'use 'top-level 'module 'top-level
  158.                'vname (string-append (hex28 "" hex) "_v"))
  159.              (newv var 'use 'global 'module module
  160.                    'vname (string-append (hex28 module hex) "_v")))))
  161.       ((and (islist exp 4 4) (symbol? (cadr exp)) (string? (caddr exp))
  162.         (string? (cadddr exp)))
  163.        (let* ((var    (cadr exp))
  164.           (module (caddr exp))
  165.           (vname  (cadddr exp)))
  166.          (if (not (equal? module ""))
  167.              (set! vname (string-append module "_" vname)))
  168.          (newv var 'use 'global 'module module 'vname vname)))
  169.       ((and (islist exp 3 3) (pair? (cadr exp)) (symbol? (caadr exp))
  170.         (symbol? (caddr exp)))
  171.        (let* ((func   (caadr exp))
  172.           (vars   (cdadr exp))
  173.           (hex    (lchexname func))
  174.           (module (lchexname (caddr exp)))
  175.           (id     ($lambda-id
  176.                   (exp-form `(lambda ,vars) exp-form)))
  177.           (alpha  '()))
  178.          (set! alpha (newv func 'use 'global 'module module
  179.                    'vname
  180.                    (string-append (hex28 module hex) "_v")
  181.                    'cname
  182.                    (string-append (hex28 module hex))))
  183.          (set-id-lambda! alpha id)
  184.          (set-lambda-generate! id 'procedure)
  185.          (set-lambda-name! id alpha)))
  186.       ((and (islist exp 4 4) (pair? (cadr exp)) (symbol? (caadr exp))
  187.         (string? (caddr exp)))
  188.        (let* ((func   (caadr exp))
  189.           (vars   (cdadr exp))
  190.           (module (caddr exp))
  191.           (cname  (cadddr exp))
  192.           (id    ($lambda-id
  193.                  (exp-form `(lambda ,vars) exp-form)))
  194.           (alpha '()))
  195.          (if (not (equal? module ""))
  196.              (set! cname (string-append module "_" cname)))
  197.          (set! alpha (newv func 'use 'global 'module module
  198.                    'cname cname))
  199.          (set-id-lambda! alpha id)
  200.          (set-lambda-generate! id 'procedure)
  201.          (set-lambda-name! id alpha)))
  202.       (else (expand-error 'define-external exp))))
  203.  
  204. ;;; External variables and functions which follow C's conventions are defined
  205. ;;; by the following forms:
  206. ;;;
  207. ;;;    (DEFINE-C-EXTERNAL var type "name")
  208. ;;;
  209. ;;;    (DEFINE-C-EXTERNAL (var type ...) type "name")
  210. ;;;
  211. ;;;    (DEFINE-C-EXTERNAL (var type ... . type) type "name")
  212. ;;;
  213. ;;; where "type" is one of the following: tscp, pointer, void, char, int,
  214. ;;; shortint, longint, unsigned, shortunsigned longunsigned, float or double.
  215. ;;; Argument conversion is determined by the type specifications as follows:
  216. ;;;
  217. ;;;     pointer    argument may be a string, procedure, or a number.  The address
  218. ;;;        of the first character of the string will be provided.  The
  219. ;;;        code address of a procedure will be provided.  The integer
  220. ;;;        value of a number will be provided.
  221. ;;;
  222. ;;;     char    argument is a character.  Its value will be supplied.
  223. ;;;
  224. ;;;    int    argument is a number.  Its int value will be supplied.
  225. ;;;     shortint
  226. ;;;    longint
  227. ;;;
  228. ;;;    unsigned  argument is a number.  Its value will be supplied.
  229. ;;;     shortunsigned
  230. ;;;     longunsigned
  231. ;;;
  232. ;;;    float   argument is a number.  Its float value will be supplied.
  233. ;;;
  234. ;;;    double    argument is a number.  Its double value will be supplied.
  235. ;;;
  236. ;;;    tscp    argument is any Scheme value which will be passed as is.
  237. ;;;
  238. ;;;    void    not allowed.
  239. ;;;
  240. ;;; Result conversion is as follows:
  241. ;;;
  242. ;;;    pointer    the pointer result (an unsigned value) is returned as a number.
  243. ;;;
  244. ;;;     char    the character result is returned as a character.
  245. ;;;
  246. ;;;    int    the integer result is returned as a number.
  247. ;;;     shortint
  248. ;;;     longint
  249. ;;;
  250. ;;;    unsigned  the unsigned result is returned as a number.
  251. ;;;     shortunsigned
  252. ;;;    longunsigned
  253. ;;;
  254. ;;;    float    the float result is returned as a number.
  255. ;;;
  256. ;;;    double    the double result is returned as a number.
  257. ;;;
  258. ;;;    tscp    the result is returned as is.
  259. ;;;
  260. ;;;    void    no result is returned.
  261.  
  262. (define (DO-DEFINE-C-EXTERNAL exp)
  263.     (if (islist exp 4 4)
  264.     (let ((form (cadr exp))
  265.           (c-type (caddr exp))
  266.           (cname (cadddr exp))
  267.           (c-type? (lambda (x)
  268.                    (memq x
  269.                      '(pointer char int shortint longint
  270.                        unsigned shortunsigned longunsigned
  271.                        float double tscp)))))
  272.          (cond ((and (symbol? form) (c-type? c-type))
  273.             (newv form 'use 'global 'module "" 'vname cname
  274.               'type c-type))
  275.            ((and (pair? form) (symbol? (car form))
  276.              (or (c-type? c-type) (eq? c-type 'void)))
  277.             (let ((id ($lambda-id (exp-form `(lambda ,(cdr form))
  278.                           exp-form)))
  279.               (alpha (newv (car form) 'use 'global 'module ""
  280.                        'cname cname 'type c-type)))
  281.              (let loop ((req '()) (vars (cdr form)))
  282.                   (cond ((null? vars)
  283.                      (set-lambda-reqvars! id (reverse req)))
  284.                     ((c-type? vars)
  285.                      (set-lambda-reqvars! id (reverse req))
  286.                      (set-lambda-optvars! id (list vars)))
  287.                     ((and (pair? vars) (c-type? (car vars)))
  288.                      (loop (cons (car vars) req) (cdr vars)))
  289.                     (else (expand-error 'define-c-external
  290.                           exp))))
  291.              (set-id-lambda! alpha id)
  292.              (set-lambda-generate! id 'procedure)
  293.              (set-lambda-name! id alpha)))
  294.            (else (expand-error 'define-c-external exp))))
  295.     (expand-error 'define-c-external exp)))
  296.        
  297. ;;; Compile time text macros are defined by the form:
  298. ;;;
  299. ;;;    (DEFINE-MACRO id macro-expander)
  300. ;;;
  301. ;;; where "id" is the identifier which is to be expanded, and "macro-expander"
  302. ;;; is an expression which is evaluated by the compiler and returns the 
  303. ;;; function which does the macro expansion.  This function must be a function
  304. ;;; of two arguments, where the first is the expression containing the
  305. ;;; identifier, and the second is the function to use to recursively expand
  306. ;;; the expression.
  307.  
  308. (define (DO-DEFINE-MACRO exp)
  309.     (if (and (islist exp 3 3) (symbol? (cadr exp)))
  310.     (put (cadr exp) 'macro (eval (caddr exp) '()))
  311.     (expand-error 'define-macro exp)))
  312.  
  313. ;;; Source from additional files is included in the compilation by the
  314. ;;; INCLUDE form:
  315. ;;;
  316. ;;; (INCLUDE file)
  317. ;;;
  318. ;;; where file is a string which is the file name of the file containing the
  319. ;;; additional LISP source.
  320.  
  321. (define (DO-INCLUDE exp)
  322.     (define (TRY-OPEN name)
  323.         (call-with-current-continuation
  324.         (lambda (return)
  325.             (let ((save-error *error-handler*))
  326.                  (set! *error-handler*
  327.                    (lambda x
  328.                        (set! *error-handler* save-error)
  329.                        (return #f)))
  330.                  (let ((result (open-input-file name)))
  331.                   (set! *error-handler* save-error)
  332.                   result)))))
  333.     (let ((file-name (and (islist exp 2 2) (string? (cadr exp)) (cadr exp))))
  334.      (if file-name
  335.          (let loop ((dirs sc-include-dirs))
  336.           (if dirs
  337.               (let ((port (try-open (string-append (car dirs)
  338.                         file-name))))
  339.                (if port
  340.                    (begin (set! sc-input
  341.                         (cons port (cons sc-splice
  342.                                  sc-input)))
  343.                       (set! sc-splice '()))
  344.                    (loop (cdr dirs))))
  345.               (report-error "Can't open INCLUDE file:" file-name)))
  346.          (expand-error 'include exp))))
  347.  
  348. ;;; The module name for this compilation is defined by including one (and only
  349. ;;; one)  MODULE directive:
  350. ;;;
  351. ;;; (MODULE module-name
  352. ;;;        [ (MAIN main-function) ]
  353. ;;;        [ (HEAP heap-size)     ]
  354. ;;;        [ (TOP-LEVEL function ... ) ]
  355. ;;;        [ (WITH module-name ...) ] )
  356. ;;;
  357. ;;; where module-name is a symbol which is the name for the current module and
  358. ;;; main-program is an optional symbol which denotes the "main" program.
  359.  
  360. (define (DO-MODULE exp)
  361.     (if (and (islist exp 2) (symbol? (cadr exp)))
  362.     (begin    (if (equal? module-name "")
  363.             (begin (set! module-name (lchexname (cadr exp)))
  364.                (set! module-name-upcase
  365.                  (symbol->string (cadr exp))))
  366.             (report-error "MODULE name is already defined as:"
  367.             module-name))
  368.         (for-each do-module-clauses (cddr exp)))
  369.     (expand-error 'module exp)))
  370.  
  371. (define (DO-MODULE-CLAUSES clause)
  372.     (cond ((and (islist clause 2 2) (eq? (car clause) 'main)
  373.         (not main-program-name) (symbol? (cadr clause)))
  374.        (if (not sc-interpreter)
  375.            (set! main-program-name (cadr clause))))
  376.       ((and (islist clause 2 2) (eq? (car clause) 'heap)
  377.         (integer? (cadr clause)) (positive? (cadr clause)))
  378.        (set! heap-size (cadr clause)))
  379.       ((and (islist clause 1) (eq? (car clause) 'top-level)
  380.         (eq? top-level-symbols #t))
  381.        (set! top-level-symbols (cdr clause)))
  382.       ((and (islist clause 2) (eq? (car clause) 'with)
  383.         (not with-modules))
  384.        (set! with-modules (map lchexname (cdr clause))))
  385.       (else (report-error "Illegal or duplicate MODULE clause"))))
  386.  
  387. ;;; Constants may be defined by the form:
  388. ;;;
  389. ;;; (DEFINE-CONSTANT symbol value)
  390.  
  391. (define (DO-DEFINE-CONSTANT exp)
  392.     (if (and (islist exp 3 3) (symbol? (cadr exp)))
  393.     (install-sc-expander (cadr exp) (list (eval (caddr exp) '())))
  394.     (expand-error 'define-constant exp)))
  395.