Demo entry 6636342

xD

   

Submitted by anonymous on Aug 23, 2017 at 18:42
Language: EmacsLisp. Code size: 6.9 kB.

;; https://www.youtube.com/watch?v=Or_yKiI3Ha4

(require 'cl-lib)

(defun pair? (form)
  (and (not (consp form))
       (listp form)
       (null (nthcdr 2 form))))

(define-error 'ambiguous-binding "ambiguous")

(defvar core-scope (make-symbol "core-scope"))

(defconst core-forms
  '(lambda let-syntax quote quote-syntax))

(defconst core-primitives
  '(datum->syntax syntax-datum syntax-e list cons))


;; Syntax objects

(defun syntax (e scopes)
  "Return a syntax object of symbol E and list of SCOPES."
  (vector 'syntax e scopes))

(defun syntax-e (stx)
  (aref stx 1))

(defun syntax-scopes (stx)
  (aref stx 2))

(defun syntax? (v)
  (and (vectorp v)
       (= (length v) 3)
       (eq (aref v 0) 'syntax)))

(defalias 'identifier? 'syntax?)

(defun datum->syntax (v)
  (cond
   ((syntax? v) v)
   ((symbolp v) (syntax v nil))
   ((listp v) (mapcar #'datum->syntax v))
   (t v)))

(defun syntax->datum (s)
  "Discard lexical information from syntax S."
  (cond
   ((syntax? s) (syntax-e s))
   ((listp s) (mapcar #'syntax->datum s))
   (t s)))


;; Scopes

(defun scope ()
  (cl-gensym "sc"))

(defun adjust-scope (s sc op)
  (cond
   ((syntax? s)
    (syntax (syntax-e s)
            (funcall op (syntax-scopes s) sc)))
   ((listp s)
    (mapcar (lambda (e) (adjust-scope e sc op)) s))
   (t s)))

(defun set-add (s e)
  (if (member e s)
      s
    (cons e s)))

(defun add-scope (s sc)
  (adjust-scope s sc #'set-add))

(defun set-flip (s e)
  (if (member e s)
      (remove e s)
    (cons e s)))

;; (flip-scope [syntax x (sc1)] sc2) => [syntax x (sc1 sc2)]
;; (flip-scope [syntax x (sc1 sc2)] sc2) => [syntax x (sc1)]
(defun flip-scope (s sc)
  (adjust-scope s sc #'set-flip))


;; Global binding table

(defvar all-bindings (make-hash-table))

(defun add-binding! (id binding)
  (puthash id binding all-bindings))

(defun resolve (id)
  "Return the binding for a given identifier ID.
Return nil if the identifier is unbound."
  (let ((candidate-ids (find-all-matching-bindings id)))
    (cond
     ;; Why is this `pair?' in the racket example?
     ((listp candidate-ids)
      (let ((max-id
             (let (arg max)
               (setq max 0)
               (dolist (id candidate-ids)
                 (when (> (length (syntax-scopes id)) max)
                   (setq arg id)))
               arg)))
        (check-unambiguous max-id candidate-ids)
        (gethash max-id all-bindings)))
     (t nil))))

(defun find-all-matching-bindings (id)
  "Find all candidate bindings for ID.
Candidate bindings are those with a subset of the scopes of ID."
  (cl-loop for c-id being the hash-keys of all-bindings
           when (and (eq (syntax-e c-id) (syntax-e id))
                     (cl-subsetp (syntax-scopes c-id)
                                 (syntax-scopes id)))
           collect c-id))

(defun check-unambiguous (max-id candidate-ids)
  (cl-loop for c-id in candidate-ids
           unless (cl-subsetp (syntax-scopes c-id)
                              (syntax-scopes max-id))
           do (signal 'ambiguous-binding max-id)))


;; Core syntax and primitives

(defconst core-scope (make-symbol "core-scope"))

(defconst core-forms
  '(lambda let-syntax quote quote-syntax))

(defconst core-primitives
  '(datum->syntax syntax->datum syntax-e list cons car cdr map))

(dolist (sym (append core-forms core-primitives))
  (add-binding! (syntax sym (list core-scope)) sym))

(defun introduce (s)
  "Add `core-scope' to syntax object S."
  (add-scope s core-scope))


;; Compile-time environment

(defvar empty-env (make-hash-table :test 'eq))

(defconst env-variable (make-symbol "variable"))

(defun env-extend (env key val)
  (puthash key val env)
  env)

(defun env-lookup (env binding)
  (gethash binding env))

(defun add-local-binding! (id)
  (let ((key (make-symbol (symbol-name (syntax-e id)))))
    (add-binding! id key)
    key))


;; Expansion dispatch

(defun expand (s &optional env)
  (or env (setq env empty-env))
  (cond
   ((identifier? s)
    (expand-identifier s env))
   ;; Why pair?
   ((and (listp s)
         (identifier? (car s)))
    (expand-id-application-form s env))
   ;; Why pair?
   ((or (listp s)
        (null s))
    (expand-app s env))
   (t (error "bad syntax: %S" s))))

(defun expand-identifier (s env)
  (let ((binding (resolve s)))
    (cond
     ((null binding) (error "free variable: %S" s))
     ((member binding core-primitives) s)
     ((member binding core-forms) (error "bad syntax: %S" s))
     (t
      (let ((v (env-lookup env binding)))
        (cond
         ((eq v env-variable) s)
         ((null v) (error "out of context: %S" s))
         (t (error "bad syntax: %S" s))))))))

(defun expand-id-application-form (s env)
  (let* ((id (car s))
         (binding (resolve id)))
    (cond
     ((memq binding '(lambda))
      (expand-lambda s env))
     ;; ((memq binding '(let-syntax))
     ;;  (expand-let-syntax s env))
     ;; ((memq binding '(quote quote-syntax))
     ;;  s)
     ((memq binding '(quote))
      s)
     (t
      (let ((v (env-lookup env binding)))
        (cond
         ((functionp v)
          (expand (apply-transformer v s) env))
         (t (expand-app s env))))))))

(defun apply-transformer (trn s)
  (let* ((intro-scope (scope))
         (intro-s (add-scope s intro-scope))
         (transformed-s (funcall trn intro-s)))
    (flip-scope transformed-s intro-scope)))

(defun expand-lambda (s env)
  (pcase-let ((`(,lambda-id (,arg-id) . ,body) s))
    (let* ((sc (scope))
           (id (add-scope arg-id sc))
           (binding (add-local-binding! id))
           (body-env (env-extend env binding env-variable))
           (exp-body (expand (add-scope body sc) body-env)))
      `(,lambda-id (,id) ,@exp-body))))

;; (defun expand-let-syntax)

(defun expand-app (s env)
  (mapcar (lambda (sub-s) (expand sub-s env)) s))

(defun eval-for-syntax-binding (rhs)
  (eval-compiled (compile (expand rhs empty-env))))

(defun compile (s)
  (cond
   ((listp s)
    (let ((core-sym (and (identifier? (car s))
                         (resolve (car s)))))
      (cond
       ((memq core-sym '(lambda))
        (pcase-let ((`(_ (,id) . ,body) s))
          `(lambda (,(resolve id)) ,(compile body))))
       ((memq core-sym '(quote))
        (pcase-let ((`(_ ,datum) s))
          `(quote ,(syntax->datum datum))))
       ;; ((memq core-sym '(quote-syntax))
       ;;  (pcase-let ((`(,quote-syntax-id ,datum) s))
       ;;    `(quote ,datum)))
       (t (mapcar #'compile s)))))
   ((identifier? s)
    (resolve s))
   (t (error "bad syntax after expansion: %S" s))))

(defun eval-compiled (s)
  (eval s))

This snippet took 0.02 seconds to highlight.

Back to the Entry List or Home.

Delete this entry (admin only).