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 / expform.sc < prev    next >
Text File  |  1991-10-11  |  21KB  |  537 lines
  1. ;;; The "first pass" of this Scheme compiler reads the source files and
  2. ;;; performs the following operations:
  3. ;;;
  4. ;;;    - macro and special form expansion
  5. ;;;    - alpha-conversion
  6. ;;;     - lexical variable usage recording
  7. ;;;
  8. ;;; At the end of this pass, all bindings and control flows should be visible
  9. ;;; in the tree.
  10. ;;;
  11.  
  12. ;*              Copyright 1989 Digital Equipment Corporation
  13. ;*                         All Rights Reserved
  14. ;*
  15. ;* Permission to use, copy, and modify this software and its documentation is
  16. ;* hereby granted only under the following terms and conditions.  Both the
  17. ;* above copyright notice and this permission notice must appear in all copies
  18. ;* of the software, derivative works or modified versions, and any portions
  19. ;* thereof, and both notices must appear in supporting documentation.
  20. ;*
  21. ;* Users of this software agree to the terms and conditions set forth herein,
  22. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  23. ;* right and license under any changes, enhancements or extensions made to the
  24. ;* core functions of the software, including but not limited to those affording
  25. ;* compatibility with other hardware or software environments, but excluding
  26. ;* applications which incorporate this software.  Users further agree to use
  27. ;* their best efforts to return to Digital any such changes, enhancements or
  28. ;* extensions that they make and inform Digital of noteworthy uses of this
  29. ;* software.  Correspondence should be provided to Digital at:
  30. ;* 
  31. ;*                       Director of Licensing
  32. ;*                       Western Research Laboratory
  33. ;*                       Digital Equipment Corporation
  34. ;*                       100 Hamilton Avenue
  35. ;*                       Palo Alto, California  94301  
  36. ;* 
  37. ;* This software may be distributed (but not offered for sale or transferred
  38. ;* for compensation) to third parties, provided such third parties agree to
  39. ;* abide by the terms and conditions of this notice.  
  40. ;* 
  41. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  42. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  43. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  44. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  45. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  46. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  47. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  48. ;* SOFTWARE.
  49.  
  50. (module expform)
  51.  
  52. ;;; Pick up external declarations.
  53.  
  54. (include "plist.sch")
  55. (include "expform.sch")
  56. (include "lambdaexp.sch")
  57.  
  58. ;;; During compilation, variable binding information is kept in the following
  59. ;;; global variables.  Each is an a-list with entries of the form:
  60. ;;;
  61. ;;;    (external-name alpha-converted-name)
  62. ;;;
  63. ;;; LEXICAL-BOUND-VARS contains the variables which are bound at the current
  64. ;;; lexical level.  LEXICAL-FREE-VARS contains the variables which are
  65. ;;; lexically bound at higher lexical levels.  GLOBAL-FREE-VARS contains those
  66. ;;; variables which are bound at the "top-level".
  67.  
  68. (define GLOBAL-FREE-VARS '())
  69.  
  70. (define LEXICAL-FREE-VARS '())
  71.  
  72. (define LEXICAL-BOUND-VARS '())
  73.  
  74. ;;; Information relating to the current lambda expression is kept in the
  75. ;;; following variables.  CURRENT-LAMBDA-ID is the identifier for the current
  76. ;;; lambda expression.
  77.  
  78. (define CURRENT-LAMBDA-ID 'top-level)
  79.  
  80. ;;; Alpha-conversion requires the generation of unique names.  The sequence
  81. ;;; number which is used is kept in MAKE-ALPHA-SEQ.
  82.  
  83. (define MAKE-ALPHA-SEQ 0)
  84.  
  85. ;;; Source processing starts with the following function which is entered with
  86. ;;; a generator function for the source.  It will return a list of forms which
  87. ;;; is the result of the first pass.
  88.  
  89. (define (EXPAND-FORMS)
  90.     (let ((results '()))
  91.      (do ((exp (read-text) (read-text)))
  92.          ((eof-object? exp) (set! results (reverse results)))
  93.          (set! lexical-free-vars '())
  94.          (set! current-lambda-id 'top-level)
  95.          (set! exp (exp-form exp exp-form))
  96.          (if exp (set! results (cons exp results))))
  97.      (for-each
  98.          (lambda (var-alpha)
  99.              (let ((var   (car var-alpha))
  100.                (alpha (cadr var-alpha)))
  101.               (if (and (eq? (id-use alpha) 'global)
  102.                    (not (id-module alpha)))
  103.                   (begin (set! current-define-name
  104.                        (id-undefref alpha))
  105.                      (report-warning
  106.                      "Variable assumed to be TOP-LEVEL:"
  107.                      var)
  108.                      (set-id-use! alpha 'top-level)
  109.                      (set-id-module! alpha 'top-level)
  110.                      (set-id-vname! alpha
  111.                      (string-append
  112.                          (hex28 "" (lchexname var))
  113.                          "_v"))
  114.                      (set! quote-constants
  115.                        (cons (list var alpha)
  116.                          quote-constants))))))
  117.          global-free-vars)
  118.      results))
  119.  
  120. ;;; The expressions are recursively expanded by the following function which
  121. ;;; is called with the expression and the expansion function.  The expansion
  122. ;;; process is similar to macro expansion, but it does the alpha-conversion
  123. ;;; using the functions stored under the property EXPAND.
  124.  
  125. (define (EXP-FORM exp exp-func)
  126.     (cond  ((symbol? exp)
  127.         (bound exp))
  128.        ((or (number? exp) (string? exp) (char? exp)
  129.         (member exp '(#t #f)))
  130.         (exp-func (list 'quote exp) exp-func))
  131.        ((islist exp 1)
  132.         (let ((func (if (symbol? (car exp)) (get (car exp) 'expand) '())))
  133.          (apply (if func func call-exp)    (list exp exp-func))))
  134.        (else
  135.         (expand-error "" exp))))
  136.  
  137. ;;; A similar function is used to expand a list of functions.
  138.  
  139. (define (EXP-FORM-LIST exp-list func)
  140.     (if (islist exp-list 0)
  141.     (map (lambda (exp) (func exp func)) exp-list)
  142.     (expand-error 'expression-list exp-list)))
  143.  
  144. ;;; During the alpha-conversion phase, all variables will be replaced with
  145. ;;; unique variables.  Information about each variable will be saved as
  146. ;;; properties of the alpha-converted variable.  The items saved are:
  147. ;;;
  148. ;;; PRINTNAME:    original program variable name.
  149. ;;; VNAME:    C name to access the item as a variable.
  150. ;;; CNAME:    C name to access the item as a procedure.
  151. ;;; MODULE:    module name containing the item.
  152. ;;; USE:    tag indicating what the variable signifies.  The possible
  153. ;;;        tags are:  LABEL, LAMBDA, LEXICAL, CONSTANT, GLOBAL, TOP-LEVEL,
  154. ;;;            TEMPORARY, CLOSUREP, and MACRO.
  155. ;;; TYPE:    data type which is either false indicating a TSCP or the
  156. ;;;        appropriate C datatype.
  157. ;;; DISPLAY:    boolean that indicates that the variable is be allocated in a
  158. ;;;        display cell.
  159. ;;; BOUNDID:    id of the lambda expression where this variable is bound.
  160. ;;; LAMBDA:    id of the lambda expression which is this var's value.
  161. ;;; EXTERNAL:   indicates that variable is external to this compile and is
  162. ;;;        referenced.
  163. ;;; DEFINED:    indicates that variable is defined by a top-level define in
  164. ;;;        this module.
  165. ;;; VALUE:      value for identifiers which are constants.
  166. ;;; SET!:    boolean indicating that the variable has been SET!.
  167. ;;; REFS:    counter for # of times a lambda bound variable is referenced.
  168. ;;; CALLS:      counter for # of times a lambda bound variable is called as a
  169. ;;;        function.
  170. ;;; ALIAS:      label alias (see emit-lap).
  171. ;;; GOTOS:      counter for # of branches to a label.
  172. ;;; UNDEFREF    current-define-name for first use when undefined.
  173.  
  174. (define (ID-PRINTNAME id) (id-printname id))
  175.  
  176. (define (SET-ID-PRINTNAME! id name)  (set-id-printname! id name))
  177.  
  178. (define (ID-VNAME id)  (id-vname id))
  179.  
  180. (define (SET-ID-VNAME! id name) (set-id-vname! id name))
  181.  
  182. (define (ID-CNAME id) (id-cname id))
  183.  
  184. (define (SET-ID-CNAME! id name)  (set-id-cname! id name))
  185.  
  186. (define (ID-MODULE id)  (id-module id))
  187.  
  188. (define (SET-ID-MODULE! id name)  (set-id-module! id name))
  189.  
  190. (define (ID-USE id) (id-use id))
  191.  
  192. (define (SET-ID-USE! id tag) (set-id-use! id tag))
  193.  
  194. (define (ID-TYPE id) (id-type id))
  195.  
  196. (define (SET-ID-TYPE! id tag) (set-id-type! id tag))
  197.  
  198. (define (ID-DISPLAY id) (id-display id))
  199.  
  200. (define (SET-ID-DISPLAY! id flag) (set-id-display! id flag))
  201.  
  202. (define (ID-BOUNDID id) (id-boundid id))
  203.  
  204. (define (SET-ID-BOUNDID id value)(set-id-boundid id value))
  205.  
  206. (define (ID-LAMBDA id) (id-lambda id))
  207.  
  208. (define (SET-ID-LAMBDA! id lambda-id) (set-id-lambda! id lambda-id))
  209.  
  210. (define (ID-EXTERNAL id) (id-external id))
  211.  
  212. (define (SET-ID-EXTERNAL! id flag) (set-id-external! id flag))
  213.  
  214. (define (ID-DEFINED id) (id-defined id))
  215.  
  216. (define (SET-ID-DEFINED! id flag) (set-id-defined! id flag))
  217.  
  218. (define (ID-VALUE id) (id-value id))
  219.  
  220. (define (SET-ID-VALUE! id x) (set-id-value! id x))
  221.  
  222. (define (ID-SET! id) (id-set! id))
  223.  
  224. (define (SET-ID-SET!! id flag) (set-id-set!! id flag))
  225.  
  226. (define (ID-REFS id) (id-refs id))
  227.  
  228. (define (SET-ID-REFS! id cnt) (set-id-refs! id cnt))
  229.  
  230. (define (ID-CALLS id) (id-calls id))
  231.  
  232. (define (SET-ID-CALLS! id cnt) (set-id-calls! id cnt))
  233.  
  234. (define (ID-ALIAS id) (id-alias id))
  235.     
  236. (define (SET-ID-ALIAS! id label) (set-id-alias! id label))
  237.  
  238. (define (ID-GOTOS id) (id-gotos id))
  239.  
  240. (define (SET-ID-GOTOS! id cnt) (set-id-gotos! id cnt))
  241.  
  242. (define (ID-UNDEFREF id) (id-undefref id))
  243.  
  244. (define (SET-ID-UNDEFREF! id var) (set-id-undefref! id var))
  245.  
  246. ;;; Variables which represent globally defined items will have their property
  247. ;;; GLOBAL set to their alphatized variable.  This allows rapid global lookup.
  248.  
  249. (define (ID-GLOBAL id) (id-global id))
  250.  
  251. (define (SET-ID-GLOBAL! id alpha) (set-id-global! id alpha))
  252.  
  253. ;;; Names are generated for externally visible variables by the following
  254. ;;; function.
  255.  
  256. (define (ASSIGN-KNOWN-NAME var)
  257.     (let* ((use    (id-use var))
  258.        (module (id-module var))
  259.        (name   (lchexname (id-printname var))))
  260.       (cond ((memq use '(lexical closurep))
  261.          (let ((lcvar (lchexname var)))
  262.               (cond ((id-lambda var)
  263.                  (set-id-cname! var
  264.                  (string-append module-name "_" lcvar))
  265.                  (set-id-vname! var (string-append lcvar "_v")))
  266.                 (else
  267.                  (set-id-vname! var lcvar)))))
  268.         ((and (eq? use 'global) (id-type var)))
  269.         (else
  270.          (set-id-vname! var (string-append (hex28 module name) "_v"))
  271.          (set-id-cname! var (string-append (hex28 module name)))))))
  272.  
  273. ;;; This function is called to establish the linkage between a variable and a
  274. ;;; lambda expression.
  275.  
  276. (define (NAME-A-LAMBDA name exp)
  277.     (set! exp ($lambda-id exp))
  278.     (if exp
  279.     (begin (set-id-lambda! name exp)
  280.            (set-lambda-name! exp name))))
  281.  
  282. ;;; Often one wants the VNAME or CNAME of an arbitrary expression.  These
  283. ;;; functions  will produce it.
  284.  
  285. (define (VNAME exp)
  286.     (if (symbol? exp)
  287.     (begin (if (and (eq? (id-use exp) 'lambda) (lambda-name exp))
  288.            (set! exp (lambda-name exp)))
  289.            (id-vname exp))
  290.     exp))
  291.  
  292. (define (CNAME exp)
  293.     (if (symbol? exp)
  294.         (begin (if (and (eq? (id-use exp) 'lambda) (lambda-name exp))
  295.            (set! exp (lambda-name exp)))
  296.                (id-cname exp))
  297.         exp))
  298.  
  299. ;;; This function is called to convert a name into its "lower case hex" format.
  300.  
  301. (define (LCHEXNAME name)
  302.     (if (symbol? name) (set! name (symbol->string name)))
  303.     (do ((c '())
  304.      (i 0 (+ 1 i))
  305.      (new (list 1)))
  306.     ((= i (string-length name)) (list->string (cdr new)))
  307.     (set! c (string-ref name i))
  308.     (cond ((char=? c #\_)
  309.            (set-cdr! (last-pair new) (list #\_ #\_)))
  310.           ((and (char>=? c #\A) (char<=? c #\Z))
  311.            (set-cdr! (last-pair new)
  312.            (list (integer->char (+ (char->integer c) 32)))))
  313.           ((or (and (char>=? c #\a) (char<=? c #\z))
  314.            (and (char>=? c #\0) (char<=? c #\9) (> i 0)))
  315.            (set-cdr! (last-pair new) (list c)))
  316.           (else
  317.         (set-cdr! (last-pair new) (cons #\_ (char->dl c 16 2)))))))
  318.  
  319. ;;; This function is one of those that you hope you never have to write, but
  320. ;;; inevitably you must.  It exists because vcc will only recognize the first
  321. ;;; 31 characters of a variable name.  In order to force the first 31
  322. ;;; characters of a generated name to be unique, it is necessary that the
  323. ;;; lchexnames of the module and variable be less than or equal to 28
  324. ;;; characters.  If it doesn't fit, then a name is generated consisting of
  325. ;;; the last 9 characters of the module name, the last 10 characters of the
  326. ;;; name, and the hex crc-32 of the module and name.
  327.  
  328. (define (HEX28 module name)
  329.     (if (<= (+ (string-length module) (string-length name)) 28)
  330.     (if (equal? module "") name (string-append module "_" name))
  331.     (let ((value (format '() "~a_~a_~a"
  332.                  (substring module
  333.                  (max 0 (- (string-length module) 9))
  334.                  (string-length module))
  335.                  (substring name
  336.                  (max 0 (- (string-length name) 10))
  337.                  (string-length name))
  338.                  (crc-32x2 (string->list
  339.                        (string-append module name)) 0 0))))
  340.          (if (char-numeric? (string-ref value 0))
  341.          (string-set! value 0 #\_))
  342.          value)))
  343.  
  344. ;;; Compute a crc-32 for a list of characters using a per character table and
  345. ;;; return a string with the hex value.  The crc is computed in two 16-bit
  346. ;;; integers to avoid having to use floating point numbers.
  347.  
  348. (define (CRC-32x2 chars crc-left crc-right)
  349.     (if (null? chars)
  350.     (let loop ((cl '()) (left crc-left) (right crc-right))
  351.          (if (and (zero? left) (zero? right))
  352.          (if (null? cl) "0" (list->string cl))
  353.          (loop (cons (string-ref "0123456789abcdef"
  354.                  (remainder right 16))
  355.                  cl)
  356.                (quotient left 16)
  357.                (+ (bit-lsh (remainder left 16) 12)
  358.               (quotient right 16)))))
  359.     (let ((char (char->integer (car chars))))
  360.          (crc-32x2 (cdr chars)
  361.          (bit-xor (bit-rsh crc-left 8)
  362.              (vector-ref t-left char)
  363.              (vector-ref t-left (remainder crc-right 256)))
  364.          (bit-xor (bit-or (bit-lsh (bit-and crc-left 255) 8)
  365.                   (bit-rsh crc-right 8))
  366.              (vector-ref t-right char)
  367.              (vector-ref t-right (remainder crc-right 256)))))))
  368.  
  369. (define T-LEFT '#(
  370.   #x0000  #x7707  #xEE0E  #x9909  #x076D  #x706A  #xE963  #x9E64
  371.   #x0EDB  #x79DC  #xE0D5  #x97D2  #x09B6  #x7EB1  #xE7B8  #x90BF
  372.   #x1DB7  #x6AB0  #xF3B9  #x84BE  #x1ADA  #x6DDD  #xF4D4  #x83D3
  373.   #x136C  #x646B  #xFD62  #x8A65  #x1401  #x6306  #xFA0F  #x8D08
  374.   #x3B6E  #x4C69  #xD560  #xA267  #x3C03  #x4B04  #xD20D  #xA50A
  375.   #x35B5  #x42B2  #xDBBB  #xACBC  #x32D8  #x45DF  #xDCD6  #xABD1
  376.   #x26D9  #x51DE  #xC8D7  #xBFD0  #x21B4  #x56B3  #xCFBA  #xB8BD
  377.   #x2802  #x5F05  #xC60C  #xB10B  #x2F6F  #x5868  #xC161  #xB666
  378.   #x76DC  #x01DB  #x98D2  #xEFD5  #x71B1  #x06B6  #x9FBF  #xE8B8
  379.   #x7807  #x0F00  #x9609  #xE10E  #x7F6A  #x086D  #x9164  #xE663
  380.   #x6B6B  #x1C6C  #x8565  #xF262  #x6C06  #x1B01  #x8208  #xF50F
  381.   #x65B0  #x12B7  #x8BBE  #xFCB9  #x62DD  #x15DA  #x8CD3  #xFBD4
  382.   #x4DB2  #x3AB5  #xA3BC  #xD4BB  #x4ADF  #x3DD8  #xA4D1  #xD3D6
  383.   #x4369  #x346E  #xAD67  #xDA60  #x4404  #x3303  #xAA0A  #xDD0D
  384.   #x5005  #x2702  #xBE0B  #xC90C  #x5768  #x206F  #xB966  #xCE61
  385.   #x5EDE  #x29D9  #xB0D0  #xC7D7  #x59B3  #x2EB4  #xB7BD  #xC0BA
  386.   #xEDB8  #x9ABF  #x03B6  #x74B1  #xEAD5  #x9DD2  #x04DB  #x73DC
  387.   #xE363  #x9464  #x0D6D  #x7A6A  #xE40E  #x9309  #x0A00  #x7D07
  388.   #xF00F  #x8708  #x1E01  #x6906  #xF762  #x8065  #x196C  #x6E6B
  389.   #xFED4  #x89D3  #x10DA  #x67DD  #xF9B9  #x8EBE  #x17B7  #x60B0
  390.   #xD6D6  #xA1D1  #x38D8  #x4FDF  #xD1BB  #xA6BC  #x3FB5  #x48B2
  391.   #xD80D  #xAF0A  #x3603  #x4104  #xDF60  #xA867  #x316E  #x4669
  392.   #xCB61  #xBC66  #x256F  #x5268  #xCC0C  #xBB0B  #x2202  #x5505
  393.   #xC5BA  #xB2BD  #x2BB4  #x5CB3  #xC2D7  #xB5D0  #x2CD9  #x5BDE
  394.   #x9B64  #xEC63  #x756A  #x026D  #x9C09  #xEB0E  #x7207  #x0500
  395.   #x95BF  #xE2B8  #x7BB1  #x0CB6  #x92D2  #xE5D5  #x7CDC  #x0BDB
  396.   #x86D3  #xF1D4  #x68DD  #x1FDA  #x81BE  #xF6B9  #x6FB0  #x18B7
  397.   #x8808  #xFF0F  #x6606  #x1101  #x8F65  #xF862  #x616B  #x166C
  398.   #xA00A  #xD70D  #x4E04  #x3903  #xA767  #xD060  #x4969  #x3E6E
  399.   #xAED1  #xD9D6  #x40DF  #x37D8  #xA9BC  #xDEBB  #x47B2  #x30B5
  400.   #xBDBD  #xCABA  #x53B3  #x24B4  #xBAD0  #xCDD7  #x54DE  #x23D9
  401.   #xB366  #xC461  #x5D68  #x2A6F  #xB40B  #xC30C  #x5A05  #x2D02
  402. ))
  403.  
  404. (define T-RIGHT '#(
  405.   #x0000  #x3096  #x612C  #x51BA  #xC419  #xF48F  #xA535  #x95A3
  406.   #x8832  #xB8A4  #xE91E  #xD988  #x4C2B  #x7CBD  #x2D07  #x1D91
  407.   #x1064  #x20F2  #x7148  #x41DE  #xD47D  #xE4EB  #xB551  #x85C7
  408.   #x9856  #xA8C0  #xF97A  #xC9EC  #x5C4F  #x6CD9  #x3D63  #x0DF5
  409.   #x20C8  #x105E  #x41E4  #x7172  #xE4D1  #xD447  #x85FD  #xB56B
  410.   #xA8FA  #x986C  #xC9D6  #xF940  #x6CE3  #x5C75  #x0DCF  #x3D59
  411.   #x30AC  #x003A  #x5180  #x6116  #xF4B5  #xC423  #x9599  #xA50F
  412.   #xB89E  #x8808  #xD9B2  #xE924  #x7C87  #x4C11  #x1DAB  #x2D3D
  413.   #x4190  #x7106  #x20BC  #x102A  #x8589  #xB51F  #xE4A5  #xD433
  414.   #xC9A2  #xF934  #xA88E  #x9818  #x0DBB  #x3D2D  #x6C97  #x5C01
  415.   #x51F4  #x6162  #x30D8  #x004E  #x95ED  #xA57B  #xF4C1  #xC457
  416.   #xD9C6  #xE950  #xB8EA  #x887C  #x1DDF  #x2D49  #x7CF3  #x4C65
  417.   #x6158  #x51CE  #x0074  #x30E2  #xA541  #x95D7  #xC46D  #xF4FB
  418.   #xE96A  #xD9FC  #x8846  #xB8D0  #x2D73  #x1DE5  #x4C5F  #x7CC9
  419.   #x713C  #x41AA  #x1010  #x2086  #xB525  #x85B3  #xD409  #xE49F
  420.   #xF90E  #xC998  #x9822  #xA8B4  #x3D17  #x0D81  #x5C3B  #x6CAD
  421.   #x8320  #xB3B6  #xE20C  #xD29A  #x4739  #x77AF  #x2615  #x1683
  422.   #x0B12  #x3B84  #x6A3E  #x5AA8  #xCF0B  #xFF9D  #xAE27  #x9EB1
  423.   #x9344  #xA3D2  #xF268  #xC2FE  #x575D  #x67CB  #x3671  #x06E7
  424.   #x1B76  #x2BE0  #x7A5A  #x4ACC  #xDF6F  #xEFF9  #xBE43  #x8ED5
  425.   #xA3E8  #x937E  #xC2C4  #xF252  #x67F1  #x5767  #x06DD  #x364B
  426.   #x2BDA  #x1B4C  #x4AF6  #x7A60  #xEFC3  #xDF55  #x8EEF  #xBE79
  427.   #xB38C  #x831A  #xD2A0  #xE236  #x7795  #x4703  #x16B9  #x262F
  428.   #x3BBE  #x0B28  #x5A92  #x6A04  #xFFA7  #xCF31  #x9E8B  #xAE1D
  429.   #xC2B0  #xF226  #xA39C  #x930A  #x06A9  #x363F  #x6785  #x5713
  430.   #x4A82  #x7A14  #x2BAE  #x1B38  #x8E9B  #xBE0D  #xEFB7  #xDF21
  431.   #xD2D4  #xE242  #xB3F8  #x836E  #x16CD  #x265B  #x77E1  #x4777
  432.   #x5AE6  #x6A70  #x3BCA  #x0B5C  #x9EFF  #xAE69  #xFFD3  #xCF45
  433.   #xE278  #xD2EE  #x8354  #xB3C2  #x2661  #x16F7  #x474D  #x77DB
  434.   #x6A4A  #x5ADC  #x0B66  #x3BF0  #xAE53  #x9EC5  #xCF7F  #xFFE9
  435.   #xF21C  #xC28A  #x9330  #xA3A6  #x3605  #x0693  #x5729  #x67BF
  436.   #x7A2E  #x4AB8  #x1B02  #x2B94  #xBE37  #x8EA1  #xDF1B  #xEF8D
  437. ))
  438.  
  439. ;;; This function converts the character "c" into numeric string of length
  440. ;;; "len" in base "base".
  441.  
  442. (define (CHAR->DL c base len)
  443.     (set! c (char->integer c))
  444.     (do ((dl '()))
  445.     ((zero? len) dl)
  446.     (set! dl (cons (string-ref "0123456789abcdef" (remainder c base)) dl))
  447.     (set! c (quotient c base))
  448.     (set! len (- len 1))))
  449.  
  450. ;;; Variables are initially bound and their alpha-converted value is returned
  451. ;;; by the following function.  It takes the variable name and an optional
  452. ;;; list of properties and values.  It returns the alphabetized name.
  453.  
  454. (define (NEWV var . pl)
  455.     (let* ((oldalpha (id-global var))
  456.        (use      (cadr (memq 'use pl)))
  457.        (alpha    '()))
  458.       (if (and oldalpha (memq use '(global macro lexical)))
  459.           (begin (if (and (id-module oldalpha)
  460.                   (or (eq? (id-use oldalpha) 'macro)
  461.                   (eq? use 'global)))
  462.              (if (id-defined oldalpha)
  463.                  (report-error
  464.                  "Duplicately defined symbol:" var)
  465.                  (report-warning
  466.                  "Duplicately defined symbol:" var)))
  467.              (if (eq? use 'global)
  468.              (begin (set! alpha oldalpha)
  469.                 (set-id-lambda! alpha '())
  470.                 (set-id-module! alpha '())
  471.                 (set-id-vname! alpha '())
  472.                 (set-id-cname! alpha '()))
  473.              (set! alpha (make-alpha var))))
  474.           (set! alpha (make-alpha var)))
  475.       (set-id-printname! alpha var)
  476.       (do ((pl pl (cddr pl)))
  477.           ((null? pl)
  478.            (case (id-use alpha)
  479.              ((global macro top-level)
  480.               (set-id-global! var alpha)
  481.               (if (not (eq? alpha oldalpha))
  482.                   (set! global-free-vars
  483.                     (cons (list var alpha) global-free-vars))))
  484.              ((lexical)
  485.               (set! lexical-bound-vars
  486.                 (cons (list var alpha) lexical-bound-vars)))
  487.              ((label constant lambda temporary closurep)
  488.               (let ((dsa (downshift alpha)))
  489.                (set-id-printname! alpha alpha)
  490.                (if (eq? (id-use alpha) 'lambda)
  491.                    (set-id-cname! alpha (hex28 module-name dsa))
  492.                    (set-id-cname! alpha (hex28 "" dsa)))
  493.                (set-id-vname! alpha (hex28 "" dsa)))))
  494.            alpha)
  495.           (put alpha (car pl) (cadr pl)))))
  496.  
  497. ;;; All variable names will be alpha-converted by taking the first character
  498. ;;; of their name and following it with an id number.
  499.  
  500. (define (MAKE-ALPHA var)
  501.     (let* ((c (string-ref (symbol->string var) 0))
  502.        (alpha (string->symbol (format '() "~A~A" c make-alpha-seq))))
  503.       (set! make-alpha-seq (+ make-alpha-seq 1))
  504.       (if (id-printname alpha)
  505.           (make-alpha var)
  506.           alpha)))
  507.  
  508. ;;; The following function looks up a variable in the current bindings.  If it
  509. ;;; is not found, then it will be added to GLOBAL-FREE-VARS.  TOP-LEVEL
  510. ;;; variables which are referenced will have a symbol pointer added to the
  511. ;;; constant list so that their value can be looked up.
  512.  
  513. (define (BOUND var)
  514.     (let* ((varalist (assq var lexical-bound-vars))
  515.        (varlex   (or varalist (assq var lexical-free-vars)))
  516.        (varglob  (or varlex (id-global var))))
  517.       (cond (varalist
  518.          (cadr varalist))
  519.         (varlex
  520.          (set! varlex (cadr varlex))
  521.          varlex)
  522.         (varglob
  523.          (if (and (eq? (id-use varglob) 'top-level)
  524.               (not (assoc var quote-constants)))
  525.              (set! quote-constants
  526.                (cons (list var varglob) quote-constants)))
  527.          varglob)
  528.         (else
  529.          (newv var 'use 'global 'undefref current-define-name)))))
  530.  
  531. ;;; Syntax errors are reported by the following function which will return
  532. ;;; (begin #t) as its value.
  533.  
  534. (define (EXPAND-ERROR form exp)
  535.     (report-error "Illegal" form "syntax:" exp)
  536.     '(begin #t))
  537.