[S-EXP] Remove code for Common Lisp S-Exp
We dropped support for it in SWIG 4.0.0 and nobody has stepped forward to revive it in over 2 years. See #2009.
This commit is contained in:
Olly Betts
parent
11bb422bd3
commit
b7a99f22f5
4 changed files with 5 additions and 793 deletions
|
|
@ -7,6 +7,11 @@ the issue number to the end of the URL: https://github.com/swig/swig/issues/
|
||||||
Version 4.1.0 (in progress)
|
Version 4.1.0 (in progress)
|
||||||
===========================
|
===========================
|
||||||
|
|
||||||
|
2021-05-13: olly
|
||||||
|
[S-EXP] #2009 Remove code for Common Lisp S-Exp. We dropped
|
||||||
|
support for it in SWIG 4.0.0 and nobody has stepped forward to
|
||||||
|
revive it in over 2 years.
|
||||||
|
|
||||||
2021-05-13: olly
|
2021-05-13: olly
|
||||||
[Pike] #2009 Remove code for Pike. We dropped support for it in
|
[Pike] #2009 Remove code for Pike. We dropped support for it in
|
||||||
SWIG 4.0.0 and nobody has stepped forward to revive it in over 2
|
SWIG 4.0.0 and nobody has stepped forward to revive it in over 2
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,8 @@
|
||||||
/* File : example.i */
|
/* File : example.i */
|
||||||
%module(directors="1") example
|
%module(directors="1") example
|
||||||
#ifndef SWIGSEXP
|
|
||||||
%{
|
%{
|
||||||
#include "example.h"
|
#include "example.h"
|
||||||
%}
|
%}
|
||||||
#endif
|
|
||||||
|
|
||||||
%feature("director");
|
%feature("director");
|
||||||
%include "example.h"
|
%include "example.h"
|
||||||
|
|
|
||||||
|
|
@ -1,389 +0,0 @@
|
||||||
;;; This is experimental code that uses the s-expression
|
|
||||||
;;; representation of a C/C++ library interface to generate Foreign
|
|
||||||
;;; Function Interface definitions for use with Kevin Rosenberg's
|
|
||||||
;;; UFFI.
|
|
||||||
;;;
|
|
||||||
;;; Written by Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
|
|
||||||
|
|
||||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
||||||
(require 'port) ; from CLOCC
|
|
||||||
(require 'uffi))
|
|
||||||
|
|
||||||
(in-package :cl-user)
|
|
||||||
|
|
||||||
;; Interaction with the SWIG binary
|
|
||||||
|
|
||||||
(defvar *swig-source-directory* #p"/home/mkoeppe/s/swig1.3/")
|
|
||||||
|
|
||||||
(defvar *swig-program* (merge-pathnames "swig" *swig-source-directory*))
|
|
||||||
|
|
||||||
(defun run-swig (swig-interface-file-name &key directory-search-list module
|
|
||||||
ignore-errors c++)
|
|
||||||
(let ((temp-file-name "/tmp/swig.lsp"))
|
|
||||||
(let ((process
|
|
||||||
(port:run-prog (namestring *swig-program*)
|
|
||||||
:output t
|
|
||||||
:args `(,@(and c++ '("-c++"))
|
|
||||||
"-sexp"
|
|
||||||
,@(mapcar (lambda (dir)
|
|
||||||
(concatenate 'string
|
|
||||||
"-I" (namestring dir)))
|
|
||||||
directory-search-list)
|
|
||||||
,@(and module
|
|
||||||
`("-module" ,module))
|
|
||||||
"-o" ,temp-file-name
|
|
||||||
,(namestring swig-interface-file-name)))))
|
|
||||||
#+cmu (unless (or (zerop (ext:process-exit-code process))
|
|
||||||
ignore-errors)
|
|
||||||
(error "Process swig exited abnormally"))
|
|
||||||
(with-open-file (s temp-file-name)
|
|
||||||
(read s)))))
|
|
||||||
|
|
||||||
;; Type system
|
|
||||||
|
|
||||||
(defun parse-swigtype (type-string &key start end junk-ok)
|
|
||||||
"Parse TYPE-STRING as SWIG's internal representation of C/C++
|
|
||||||
types. Return two values: The type description (an improper list) and
|
|
||||||
the terminating index into TYPE-STRING."
|
|
||||||
;; SWIG's internal representation is described in Source/Swig/stype.c
|
|
||||||
(unless start
|
|
||||||
(setq start 0))
|
|
||||||
(unless end
|
|
||||||
(setq end (length type-string)))
|
|
||||||
(flet ((prefix-match (prefix)
|
|
||||||
(let ((position (mismatch prefix type-string :start2 start :end2 end)))
|
|
||||||
(or (not position)
|
|
||||||
(= position (length prefix)))))
|
|
||||||
(bad-type-error (reason)
|
|
||||||
(error "Bad SWIG type (~A): ~A" reason
|
|
||||||
(subseq type-string start end)))
|
|
||||||
(type-char (index)
|
|
||||||
(and (< index (length type-string))
|
|
||||||
(char type-string index)))
|
|
||||||
(cons-and-recurse (prefix start end)
|
|
||||||
(multiple-value-bind (type-description index)
|
|
||||||
(parse-swigtype type-string :start start :end end
|
|
||||||
:junk-ok junk-ok)
|
|
||||||
(values (cons prefix type-description)
|
|
||||||
index))))
|
|
||||||
(cond
|
|
||||||
((prefix-match "p.") ; pointer
|
|
||||||
(cons-and-recurse '* (+ start 2) end))
|
|
||||||
((prefix-match "r.") ; C++ reference
|
|
||||||
(cons-and-recurse '& (+ start 2) end))
|
|
||||||
((prefix-match "a(") ; array
|
|
||||||
(let ((closing-paren (position #\) type-string
|
|
||||||
:start (+ start 2)
|
|
||||||
:end end)))
|
|
||||||
(unless closing-paren
|
|
||||||
(bad-type-error "missing right paren"))
|
|
||||||
(unless (eql (type-char (+ closing-paren 1)) #\.)
|
|
||||||
(bad-type-error "missing dot"))
|
|
||||||
(cons-and-recurse (list 'ARRAY (subseq type-string (+ start 2) closing-paren))
|
|
||||||
(+ closing-paren 2) end)))
|
|
||||||
((prefix-match "q(") ; qualifier (const, volatile)
|
|
||||||
(let ((closing-paren (position #\) type-string
|
|
||||||
:start (+ start 2)
|
|
||||||
:end end)))
|
|
||||||
(unless closing-paren
|
|
||||||
(bad-type-error "missing right paren"))
|
|
||||||
(unless (eql (type-char (+ closing-paren 1)) #\.)
|
|
||||||
(bad-type-error "missing dot"))
|
|
||||||
(cons-and-recurse (list 'QUALIFIER (subseq type-string (+ start 2) closing-paren))
|
|
||||||
(+ closing-paren 2) end)))
|
|
||||||
((prefix-match "m(") ; C++ member pointer
|
|
||||||
(multiple-value-bind (class-type class-end-index)
|
|
||||||
(parse-swigtype type-string :junk-ok t
|
|
||||||
:start (+ start 2) :end end)
|
|
||||||
(unless (eql (type-char class-end-index) #\))
|
|
||||||
(bad-type-error "missing right paren"))
|
|
||||||
(unless (eql (type-char (+ class-end-index 1)) #\.)
|
|
||||||
(bad-type-error "missing dot"))
|
|
||||||
(cons-and-recurse (list 'MEMBER-POINTER class-type)
|
|
||||||
(+ class-end-index 2) end)))
|
|
||||||
((prefix-match "f(") ; function
|
|
||||||
(loop with index = (+ start 2)
|
|
||||||
until (eql (type-char index) #\))
|
|
||||||
collect (multiple-value-bind (arg-type arg-end-index)
|
|
||||||
(parse-swigtype type-string :junk-ok t
|
|
||||||
:start index :end end)
|
|
||||||
(case (type-char arg-end-index)
|
|
||||||
(#\, (setq index (+ arg-end-index 1)))
|
|
||||||
(#\) (setq index arg-end-index))
|
|
||||||
(otherwise (bad-type-error "comma or right paren expected")))
|
|
||||||
arg-type)
|
|
||||||
into arg-types
|
|
||||||
finally (unless (eql (type-char (+ index 1)) #\.)
|
|
||||||
(bad-type-error "missing dot"))
|
|
||||||
(return (cons-and-recurse (cons 'FUNCTION arg-types)
|
|
||||||
(+ index 2) end))))
|
|
||||||
((prefix-match "v(") ;varargs
|
|
||||||
(let ((closing-paren (position #\) type-string
|
|
||||||
:start (+ start 2)
|
|
||||||
:end end)))
|
|
||||||
(unless closing-paren
|
|
||||||
(bad-type-error "missing right paren"))
|
|
||||||
(values (list 'VARARGS (subseq type-string (+ start 2) closing-paren))
|
|
||||||
(+ closing-paren 1))))
|
|
||||||
(t (let ((junk-position (position-if (lambda (char)
|
|
||||||
(member char '(#\, #\( #\) #\.)))
|
|
||||||
type-string
|
|
||||||
:start start :end end)))
|
|
||||||
(cond (junk-position ; found junk
|
|
||||||
(unless junk-ok
|
|
||||||
(bad-type-error "trailing junk"))
|
|
||||||
(values (subseq type-string start junk-position)
|
|
||||||
junk-position))
|
|
||||||
(t
|
|
||||||
(values (subseq type-string start end)
|
|
||||||
end))))))))
|
|
||||||
|
|
||||||
(defun swigtype-function-p (swigtype)
|
|
||||||
"Check whether SWIGTYPE designates a function. If so, the second
|
|
||||||
value is the list of argument types, and the third value is the return
|
|
||||||
type."
|
|
||||||
(if (and (consp swigtype)
|
|
||||||
(consp (first swigtype))
|
|
||||||
(eql (first (first swigtype)) 'FUNCTION))
|
|
||||||
(values t (rest (first swigtype)) (rest swigtype))
|
|
||||||
(values nil nil nil)))
|
|
||||||
|
|
||||||
|
|
||||||
;; UFFI
|
|
||||||
|
|
||||||
(defvar *uffi-definitions* '())
|
|
||||||
|
|
||||||
(defconstant *uffi-default-primitive-type-alist*
|
|
||||||
'(("char" . :char)
|
|
||||||
("unsigned char" . :unsigned-byte)
|
|
||||||
("signed char" . :byte)
|
|
||||||
("short" . :short)
|
|
||||||
("signed short" . :short)
|
|
||||||
("unsigned short" . :unsigned-short)
|
|
||||||
("int" . :int)
|
|
||||||
("signed int" . :int)
|
|
||||||
("unsigned int" . :unsigned-int)
|
|
||||||
("long" . :long)
|
|
||||||
("signed long" . :long)
|
|
||||||
("unsigned long" . :unsigned-long)
|
|
||||||
("float" . :float)
|
|
||||||
("double" . :double)
|
|
||||||
((* . "char") . :cstring)
|
|
||||||
((* . "void") . :pointer-void)
|
|
||||||
("void" . :void)))
|
|
||||||
|
|
||||||
(defvar *uffi-primitive-type-alist* *uffi-default-primitive-type-alist*)
|
|
||||||
|
|
||||||
(defun uffi-type-spec (type-list)
|
|
||||||
"Return the UFFI type spec equivalent to TYPE-LIST, or NIL if there
|
|
||||||
is no representation."
|
|
||||||
(let ((primitive-type-pair
|
|
||||||
(assoc type-list *uffi-primitive-type-alist* :test 'equal)))
|
|
||||||
(cond
|
|
||||||
(primitive-type-pair
|
|
||||||
(cdr primitive-type-pair))
|
|
||||||
((and (consp type-list)
|
|
||||||
(eql (first type-list) '*))
|
|
||||||
(let ((base-type-spec (uffi-type-spec (rest type-list))))
|
|
||||||
(cond
|
|
||||||
((not base-type-spec)
|
|
||||||
:pointer-void)
|
|
||||||
(t
|
|
||||||
(list '* base-type-spec)))))
|
|
||||||
(t nil))))
|
|
||||||
|
|
||||||
;; Parse tree
|
|
||||||
|
|
||||||
(defvar *uffi-output* nil)
|
|
||||||
|
|
||||||
(defun emit-uffi-definition (uffi-definition)
|
|
||||||
(format *uffi-output* "~&~S~%" uffi-definition)
|
|
||||||
(push uffi-definition *uffi-definitions*))
|
|
||||||
|
|
||||||
(defun make-cl-symbol (c-identifier &key uninterned)
|
|
||||||
(let ((name (substitute #\- #\_ (string-upcase c-identifier))))
|
|
||||||
(if uninterned
|
|
||||||
(make-symbol name)
|
|
||||||
(intern name))))
|
|
||||||
|
|
||||||
(defvar *class-scope* '() "A stack of names of nested C++ classes.")
|
|
||||||
|
|
||||||
(defvar *struct-fields* '())
|
|
||||||
|
|
||||||
(defvar *linkage* :C "NIL or :C")
|
|
||||||
|
|
||||||
(defgeneric handle-node (node-type &key &allow-other-keys)
|
|
||||||
(:documentation "Handle a node of SWIG's parse tree of a C/C++ program"))
|
|
||||||
|
|
||||||
(defmethod handle-node ((node-type t) &key &allow-other-keys)
|
|
||||||
;; do nothing for unknown node types
|
|
||||||
nil)
|
|
||||||
|
|
||||||
(defmethod handle-node ((node-type (eql 'cdecl)) &key name decl storage parms type &allow-other-keys)
|
|
||||||
(let ((swigtype (parse-swigtype (concatenate 'string decl type))))
|
|
||||||
(let ((*print-pretty* nil) ; or FUNCTION would be printed as #' by cmucl
|
|
||||||
(*print-circle* t))
|
|
||||||
(format *uffi-output* "~&;; C Declaration: ~A ~A ~A ~A~%;; with-parms ~W~%;; of-type ~W~%"
|
|
||||||
storage type name decl parms swigtype))
|
|
||||||
(multiple-value-bind (function-p arg-swigtype-list return-swigtype)
|
|
||||||
(swigtype-function-p swigtype)
|
|
||||||
(declare (ignore arg-swigtype-list))
|
|
||||||
(cond
|
|
||||||
((and (null *class-scope*) function-p
|
|
||||||
(or (eql *linkage* :c)
|
|
||||||
(string= storage "externc")))
|
|
||||||
;; ordinary top-level function with C linkage
|
|
||||||
(let ((argnum 0)
|
|
||||||
(argname-list '()))
|
|
||||||
(flet ((unique-argname (name)
|
|
||||||
;; Sometimes the functions in SWIG interfaces
|
|
||||||
;; do not have unique names. Make them unique
|
|
||||||
;; by adding a suffix. Also avoid symbols
|
|
||||||
;; that are specially bound.
|
|
||||||
(unless name
|
|
||||||
(setq name (format nil "arg~D" argnum)))
|
|
||||||
(let ((argname (make-cl-symbol name)))
|
|
||||||
(when (boundp argname) ;specially bound
|
|
||||||
(setq argname (make-cl-symbol name :uninterned t)))
|
|
||||||
(push argname argname-list)
|
|
||||||
argname)))
|
|
||||||
(let ((uffi-arg-list
|
|
||||||
(mapcan (lambda (param)
|
|
||||||
(incf argnum)
|
|
||||||
(destructuring-bind (&key name type &allow-other-keys) param
|
|
||||||
(let ((uffi-type (uffi-type-spec (parse-swigtype type))))
|
|
||||||
(cond
|
|
||||||
((not uffi-type)
|
|
||||||
(format *uffi-output* "~&;; Warning: Cannot handle type ~S of argument `~A'~%"
|
|
||||||
type name)
|
|
||||||
(return-from handle-node))
|
|
||||||
((eq uffi-type :void)
|
|
||||||
'())
|
|
||||||
(t
|
|
||||||
(let ((symbol (unique-argname name)))
|
|
||||||
(list `(,symbol ,uffi-type))))))))
|
|
||||||
parms))
|
|
||||||
(uffi-return-type
|
|
||||||
(uffi-type-spec return-swigtype)))
|
|
||||||
(unless uffi-return-type
|
|
||||||
(format *uffi-output* "~&;; Warning: Cannot handle return type `~S'~%"
|
|
||||||
return-swigtype)
|
|
||||||
(return-from handle-node))
|
|
||||||
(emit-uffi-definition `(UFFI:DEF-FUNCTION ,name ,uffi-arg-list :RETURNING ,uffi-return-type))))))
|
|
||||||
((and (not (null *class-scope*)) (null (rest *class-scope*))
|
|
||||||
(not function-p)) ; class/struct member (no nested structs)
|
|
||||||
(let ((uffi-type (uffi-type-spec swigtype)))
|
|
||||||
(unless uffi-type
|
|
||||||
(format *uffi-output* "~&;; Warning: Cannot handle type ~S of struct field `~A'~%"
|
|
||||||
type name)
|
|
||||||
(return-from handle-node))
|
|
||||||
(push `(,(make-cl-symbol name) ,uffi-type) *struct-fields*)))))))
|
|
||||||
|
|
||||||
(defmethod handle-node ((node-type (eql 'class)) &key name children kind &allow-other-keys)
|
|
||||||
(format *uffi-output* "~&;; Class ~A~%" name)
|
|
||||||
(let ((*class-scope* (cons name *class-scope*))
|
|
||||||
(*struct-fields* '()))
|
|
||||||
(dolist (child children)
|
|
||||||
(apply 'handle-node child))
|
|
||||||
(emit-uffi-definition `(,(if (string= kind "union")
|
|
||||||
'UFFI:DEF-UNION
|
|
||||||
'UFFI:DEF-STRUCT)
|
|
||||||
,(make-cl-symbol name) ,@(nreverse *struct-fields*)))))
|
|
||||||
|
|
||||||
(defmethod handle-node ((node-type (eql 'top)) &key children &allow-other-keys)
|
|
||||||
(dolist (child children)
|
|
||||||
(apply 'handle-node child)))
|
|
||||||
|
|
||||||
(defmethod handle-node ((node-type (eql 'include)) &key name children &allow-other-keys)
|
|
||||||
(format *uffi-output* ";; INCLUDE ~A~%" name)
|
|
||||||
(dolist (child children)
|
|
||||||
(apply 'handle-node child)))
|
|
||||||
|
|
||||||
(defmethod handle-node ((node-type (eql 'extern)) &key name children &allow-other-keys)
|
|
||||||
(format *uffi-output* ";; EXTERN \"C\" ~A~%" name)
|
|
||||||
(let ((*linkage* :c))
|
|
||||||
(dolist (child children)
|
|
||||||
(apply 'handle-node child))))
|
|
||||||
|
|
||||||
;;(defun compute-uffi-definitions (swig-interface)
|
|
||||||
;; (let ((*uffi-definitions* '()))
|
|
||||||
;; (handle-node swig-interface)
|
|
||||||
;; *uffi-definitions*))
|
|
||||||
|
|
||||||
;; Test instances
|
|
||||||
|
|
||||||
;;; Link to SWIG itself
|
|
||||||
|
|
||||||
#||
|
|
||||||
|
|
||||||
(defparameter *c++-compiler* "g++")
|
|
||||||
|
|
||||||
(defun stdc++-library (&key env)
|
|
||||||
(let ((error-output (make-string-output-stream)))
|
|
||||||
(let ((name-output (make-string-output-stream)))
|
|
||||||
(let ((proc (ext:run-program
|
|
||||||
*c++-compiler*
|
|
||||||
'("-print-file-name=libstdc++.so")
|
|
||||||
:env env
|
|
||||||
:input nil
|
|
||||||
:output name-output
|
|
||||||
:error error-output)))
|
|
||||||
(unless proc
|
|
||||||
(error "Could not run ~A" *c++-compiler*))
|
|
||||||
(unless (zerop (ext:process-exit-code proc))
|
|
||||||
(system:serve-all-events 0)
|
|
||||||
(error "~A failed:~%~A" *c++-compiler*
|
|
||||||
(get-output-stream-string error-output))))
|
|
||||||
(string-right-trim '(#\Newline) (get-output-stream-string name-output)))))
|
|
||||||
|
|
||||||
(defvar *swig-interface* nil)
|
|
||||||
|
|
||||||
(defvar *swig-uffi-pathname* #p"/tmp/swig-uffi.lisp")
|
|
||||||
|
|
||||||
(defun link-swig ()
|
|
||||||
(setq *swig-interface*
|
|
||||||
(run-swig (merge-pathnames "Source/swig.i" *swig-source-directory*)
|
|
||||||
:directory-search-list
|
|
||||||
(list (merge-pathnames "Source/" *swig-source-directory*))
|
|
||||||
:module "swig"
|
|
||||||
:ignore-errors t
|
|
||||||
:c++ t))
|
|
||||||
(with-open-file (f *swig-uffi-pathname* :direction :output)
|
|
||||||
(let ((*linkage* :c++)
|
|
||||||
(*uffi-definitions* '())
|
|
||||||
(*uffi-output* f)
|
|
||||||
(*uffi-primitive-type-alist* *uffi-default-primitive-type-alist*))
|
|
||||||
(apply 'handle-node *swig-interface*)))
|
|
||||||
(compile-file *swig-uffi-pathname*)
|
|
||||||
(alien:load-foreign (merge-pathnames "Source/libswig.a"
|
|
||||||
*swig-source-directory*)
|
|
||||||
:libraries (list (stdc++-library)))
|
|
||||||
;; FIXME: UFFI stuffes a "-l" in front of the passed library names
|
|
||||||
;; (uffi:load-foreign-library (merge-pathnames "Source/libswig.a"
|
|
||||||
;; *swig-source-directory*)
|
|
||||||
;; :supporting-libraries
|
|
||||||
;; (list (stdc++-library)))
|
|
||||||
(load (compile-file-pathname *swig-uffi-pathname*)))
|
|
||||||
|
|
||||||
||#
|
|
||||||
|
|
||||||
;;;; TODO:
|
|
||||||
|
|
||||||
;; * How to do type lookups? Is everything important that SWIG knows
|
|
||||||
;; about the types written out? What to make of typemaps?
|
|
||||||
;;
|
|
||||||
;; * Wrapped functions should probably automatically COERCE their
|
|
||||||
;; arguments (as of type DOUBLE-FLOAT), to make the functions more
|
|
||||||
;; flexible?
|
|
||||||
;;
|
|
||||||
;; * Why are the functions created by FFI interpreted?
|
|
||||||
;;
|
|
||||||
;; * We can't deal with more complicated structs and C++ classes
|
|
||||||
;; directly with the FFI; we have to emit SWIG wrappers that access
|
|
||||||
;; those classes.
|
|
||||||
;;
|
|
||||||
;; * A CLOS layer where structure fields are mapped as slots. It
|
|
||||||
;; looks like we need MOP functions to implement this.
|
|
||||||
;;
|
|
||||||
;; * Maybe modify SWIG so that key-value hashes are distinguished from
|
|
||||||
;; value-value hashes.
|
|
||||||
|
|
@ -1,402 +0,0 @@
|
||||||
/* -----------------------------------------------------------------------------
|
|
||||||
* This file is part of SWIG, which is licensed as a whole under version 3
|
|
||||||
* (or any later version) of the GNU General Public License. Some additional
|
|
||||||
* terms also apply to certain portions of SWIG. The full details of the SWIG
|
|
||||||
* license and copyrights can be found in the LICENSE and COPYRIGHT files
|
|
||||||
* included with the SWIG source code as distributed by the SWIG developers
|
|
||||||
* and at http://www.swig.org/legal.html.
|
|
||||||
*
|
|
||||||
* s-exp.cxx
|
|
||||||
*
|
|
||||||
* A parse tree represented as Lisp s-expressions.
|
|
||||||
* ----------------------------------------------------------------------------- */
|
|
||||||
|
|
||||||
#include "swigmod.h"
|
|
||||||
#include "dohint.h"
|
|
||||||
|
|
||||||
static const char *usage = "\
|
|
||||||
S-Exp Options (available with -sexp)\n\
|
|
||||||
-typemaplang <lang> - Typemap language\n\n";
|
|
||||||
|
|
||||||
//static Node *view_top = 0;
|
|
||||||
static File *out = 0;
|
|
||||||
|
|
||||||
class Sexp:public Language {
|
|
||||||
int indent_level;
|
|
||||||
DOHHash *print_circle_hash;
|
|
||||||
int print_circle_count;
|
|
||||||
int hanging_parens;
|
|
||||||
bool need_whitespace;
|
|
||||||
bool need_newline;
|
|
||||||
|
|
||||||
public:
|
|
||||||
Sexp():
|
|
||||||
indent_level(0),
|
|
||||||
print_circle_hash(0),
|
|
||||||
print_circle_count(0),
|
|
||||||
hanging_parens(0),
|
|
||||||
need_whitespace(0),
|
|
||||||
need_newline(0) {
|
|
||||||
}
|
|
||||||
|
|
||||||
virtual ~ Sexp() {
|
|
||||||
}
|
|
||||||
|
|
||||||
virtual void main(int argc, char *argv[]) {
|
|
||||||
// Add a symbol to the parser for conditional compilation
|
|
||||||
Preprocessor_define("SWIGSEXP 1", 0);
|
|
||||||
|
|
||||||
SWIG_typemap_lang("sexp");
|
|
||||||
for (int iX = 0; iX < argc; iX++) {
|
|
||||||
if (strcmp(argv[iX], "-typemaplang") == 0) {
|
|
||||||
Swig_mark_arg(iX);
|
|
||||||
iX++;
|
|
||||||
SWIG_typemap_lang(argv[iX]);
|
|
||||||
Swig_mark_arg(iX);
|
|
||||||
continue;
|
|
||||||
}
|
|
||||||
if (strcmp(argv[iX], "-help") == 0) {
|
|
||||||
fputs(usage, stdout);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Top of the parse tree */
|
|
||||||
virtual int top(Node *n) {
|
|
||||||
if (out == 0) {
|
|
||||||
String *outfile = Getattr(n, "outfile");
|
|
||||||
Replaceall(outfile, "_wrap.cxx", ".lisp");
|
|
||||||
Replaceall(outfile, "_wrap.c", ".lisp");
|
|
||||||
out = NewFile(outfile, "w", SWIG_output_files());
|
|
||||||
if (!out) {
|
|
||||||
FileErrorDisplay(outfile);
|
|
||||||
SWIG_exit(EXIT_FAILURE);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
String *f_sink = NewString("");
|
|
||||||
Swig_register_filebyname("header", f_sink);
|
|
||||||
Swig_register_filebyname("wrapper", f_sink);
|
|
||||||
Swig_register_filebyname("begin", f_sink);
|
|
||||||
Swig_register_filebyname("runtime", f_sink);
|
|
||||||
Swig_register_filebyname("init", f_sink);
|
|
||||||
|
|
||||||
Swig_banner_target_lang(out, ";;;");
|
|
||||||
|
|
||||||
Language::top(n);
|
|
||||||
Printf(out, "\n");
|
|
||||||
Printf(out, ";;; Lisp parse tree produced by SWIG\n");
|
|
||||||
print_circle_hash = NewHash();
|
|
||||||
print_circle_count = 0;
|
|
||||||
hanging_parens = 0;
|
|
||||||
need_whitespace = 0;
|
|
||||||
need_newline = 0;
|
|
||||||
Sexp_print_node(n);
|
|
||||||
flush_parens();
|
|
||||||
return SWIG_OK;
|
|
||||||
}
|
|
||||||
|
|
||||||
void print_indent() {
|
|
||||||
int i;
|
|
||||||
for (i = 0; i < indent_level; i++) {
|
|
||||||
Printf(out, " ");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void open_paren(const String *oper) {
|
|
||||||
flush_parens();
|
|
||||||
Printf(out, "(");
|
|
||||||
if (oper)
|
|
||||||
Printf(out, "%s ", oper);
|
|
||||||
indent_level += 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
void close_paren(bool neednewline = false) {
|
|
||||||
hanging_parens++;
|
|
||||||
if (neednewline)
|
|
||||||
print_lazy_whitespace();
|
|
||||||
indent_level -= 2;
|
|
||||||
}
|
|
||||||
|
|
||||||
void flush_parens() {
|
|
||||||
int i;
|
|
||||||
if (hanging_parens) {
|
|
||||||
for (i = 0; i < hanging_parens; i++)
|
|
||||||
Printf(out, ")");
|
|
||||||
hanging_parens = 0;
|
|
||||||
need_newline = true;
|
|
||||||
need_whitespace = true;
|
|
||||||
}
|
|
||||||
if (need_newline) {
|
|
||||||
Printf(out, "\n");
|
|
||||||
print_indent();
|
|
||||||
need_newline = false;
|
|
||||||
need_whitespace = false;
|
|
||||||
} else if (need_whitespace) {
|
|
||||||
Printf(out, " ");
|
|
||||||
need_whitespace = false;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void print_lazy_whitespace() {
|
|
||||||
need_whitespace = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
void print_lazy_newline() {
|
|
||||||
need_newline = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
bool internal_key_p(DOH *key) {
|
|
||||||
return ((Cmp(key, "nodeType") == 0)
|
|
||||||
|| (Cmp(key, "firstChild") == 0)
|
|
||||||
|| (Cmp(key, "lastChild") == 0)
|
|
||||||
|| (Cmp(key, "parentNode") == 0)
|
|
||||||
|| (Cmp(key, "nextSibling") == 0)
|
|
||||||
|| (Cmp(key, "previousSibling") == 0)
|
|
||||||
|| (Cmp(key, "csym:nextSibling") == 0)
|
|
||||||
|| (Cmp(key, "csym:previousSibling") == 0)
|
|
||||||
|| (Cmp(key, "typepass:visit") == 0)
|
|
||||||
|| (Cmp(key, "allocate:visit") == 0)
|
|
||||||
|| (*(Char(key)) == '$'));
|
|
||||||
}
|
|
||||||
|
|
||||||
bool boolean_key_p(DOH *key) {
|
|
||||||
return ((Cmp(key, "allocate:default_constructor") == 0)
|
|
||||||
|| (Cmp(key, "allocate:default_destructor") == 0)
|
|
||||||
|| (Cmp(key, "allows_typedef") == 0)
|
|
||||||
|| (Cmp(key, "feature:immutable") == 0));
|
|
||||||
}
|
|
||||||
|
|
||||||
bool list_key_p(DOH *key) {
|
|
||||||
return ((Cmp(key, "parms") == 0)
|
|
||||||
|| (Cmp(key, "baselist") == 0));
|
|
||||||
}
|
|
||||||
|
|
||||||
bool plist_key_p(DOH *key)
|
|
||||||
// true if KEY is the name of data that is a mapping from keys to
|
|
||||||
// values, which should be printed as a plist.
|
|
||||||
{
|
|
||||||
return ((Cmp(key, "typescope") == 0));
|
|
||||||
}
|
|
||||||
|
|
||||||
bool maybe_plist_key_p(DOH *key) {
|
|
||||||
return (Strncmp(key, "tmap:", 5) == 0);
|
|
||||||
}
|
|
||||||
|
|
||||||
bool print_circle(DOH *obj, bool list_p)
|
|
||||||
// We have a complex object, which might be referenced several
|
|
||||||
// times, or even recursively. Use Lisp's reader notation for
|
|
||||||
// circular structures (#n#, #n=).
|
|
||||||
//
|
|
||||||
// An object can be printed in list-mode or object-mode; LIST_P toggles.
|
|
||||||
// return TRUE if OBJ still needs to be printed
|
|
||||||
{
|
|
||||||
flush_parens();
|
|
||||||
// Following is a silly hack. It works around the limitation of
|
|
||||||
// DOH's hash tables that only work with string keys!
|
|
||||||
char address[32];
|
|
||||||
sprintf(address, "%p%c", obj, list_p ? 'L' : 'O');
|
|
||||||
DOH *placeholder = Getattr(print_circle_hash, address);
|
|
||||||
if (placeholder) {
|
|
||||||
Printv(out, placeholder, NIL);
|
|
||||||
return false;
|
|
||||||
} else {
|
|
||||||
String *placeholder = NewStringf("#%d#", ++print_circle_count);
|
|
||||||
Setattr(print_circle_hash, address, placeholder);
|
|
||||||
Printf(out, "#%d=", print_circle_count);
|
|
||||||
return true;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_value_of_key(DOH *value, DOH *key) {
|
|
||||||
if ((Cmp(key, "parms") == 0) || (Cmp(key, "wrap:parms") == 0)
|
|
||||||
|| (Cmp(key, "kwargs") == 0) || (Cmp(key, "pattern") == 0))
|
|
||||||
Sexp_print_parms(value);
|
|
||||||
else if (plist_key_p(key))
|
|
||||||
Sexp_print_plist(value);
|
|
||||||
else if (maybe_plist_key_p(key)) {
|
|
||||||
if (DohIsMapping(value))
|
|
||||||
Sexp_print_plist(value);
|
|
||||||
else
|
|
||||||
Sexp_print_doh(value);
|
|
||||||
} else if (list_key_p(key))
|
|
||||||
Sexp_print_list(value);
|
|
||||||
else if (boolean_key_p(key))
|
|
||||||
Sexp_print_boolean(value);
|
|
||||||
else
|
|
||||||
Sexp_print_doh(value);
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_boolean(DOH *obj) {
|
|
||||||
flush_parens();
|
|
||||||
/* See DOH/Doh/base.c, DohGetInt() */
|
|
||||||
if (DohIsString(obj)) {
|
|
||||||
if (atoi(Char(obj)) != 0)
|
|
||||||
Printf(out, "t");
|
|
||||||
else
|
|
||||||
Printf(out, "nil");
|
|
||||||
} else
|
|
||||||
Printf(out, "nil");
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_list(DOH *obj) {
|
|
||||||
if (print_circle(obj, true)) {
|
|
||||||
open_paren(NIL);
|
|
||||||
for (; obj; obj = nextSibling(obj)) {
|
|
||||||
Sexp_print_doh(obj);
|
|
||||||
print_lazy_whitespace();
|
|
||||||
}
|
|
||||||
close_paren(true);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_parms(DOH *obj) {
|
|
||||||
// print it as a list of plists
|
|
||||||
if (print_circle(obj, true)) {
|
|
||||||
open_paren(NIL);
|
|
||||||
for (; obj; obj = nextSibling(obj)) {
|
|
||||||
if (DohIsMapping(obj)) {
|
|
||||||
Iterator k;
|
|
||||||
open_paren(NIL);
|
|
||||||
for (k = First(obj); k.key; k = Next(k)) {
|
|
||||||
if (!internal_key_p(k.key)) {
|
|
||||||
DOH *value = Getattr(obj, k.key);
|
|
||||||
Sexp_print_as_keyword(k.key);
|
|
||||||
Sexp_print_value_of_key(value, k.key);
|
|
||||||
print_lazy_whitespace();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
close_paren(true);
|
|
||||||
} else
|
|
||||||
Sexp_print_doh(obj);
|
|
||||||
print_lazy_whitespace();
|
|
||||||
}
|
|
||||||
close_paren(true);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_doh(DOH *obj) {
|
|
||||||
flush_parens();
|
|
||||||
if (DohIsString(obj)) {
|
|
||||||
String *o = Str(obj);
|
|
||||||
Replaceall(o, "\\", "\\\\");
|
|
||||||
Replaceall(o, "\"", "\\\"");
|
|
||||||
Printf(out, "\"%s\"", o);
|
|
||||||
Delete(o);
|
|
||||||
} else {
|
|
||||||
if (print_circle(obj, false)) {
|
|
||||||
// Dispatch type
|
|
||||||
if (nodeType(obj)) {
|
|
||||||
Sexp_print_node(obj);
|
|
||||||
}
|
|
||||||
|
|
||||||
else if (DohIsMapping(obj)) {
|
|
||||||
Iterator k;
|
|
||||||
open_paren(NIL);
|
|
||||||
for (k = First(obj); k.key; k = Next(k)) {
|
|
||||||
if (!internal_key_p(k.key)) {
|
|
||||||
DOH *value = Getattr(obj, k.key);
|
|
||||||
flush_parens();
|
|
||||||
open_paren(NIL);
|
|
||||||
Sexp_print_doh(k.key);
|
|
||||||
Printf(out, " . ");
|
|
||||||
Sexp_print_value_of_key(value, k.key);
|
|
||||||
close_paren();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
close_paren();
|
|
||||||
} else if (strcmp(ObjType(obj)->objname, "List") == 0) {
|
|
||||||
int i;
|
|
||||||
open_paren(NIL);
|
|
||||||
for (i = 0; i < Len(obj); i++) {
|
|
||||||
DOH *item = Getitem(obj, i);
|
|
||||||
Sexp_print_doh(item);
|
|
||||||
}
|
|
||||||
close_paren();
|
|
||||||
} else {
|
|
||||||
// What is it?
|
|
||||||
Printf(out, "#<DOH %s %p>", ObjType(obj)->objname, obj);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_as_keyword(const DOH *k) {
|
|
||||||
/* Print key, replacing ":" with "-" because : is CL's package prefix */
|
|
||||||
flush_parens();
|
|
||||||
String *key = NewString(k);
|
|
||||||
Replaceall(key, ":", "-");
|
|
||||||
Replaceall(key, "_", "-");
|
|
||||||
Printf(out, ":%s ", key);
|
|
||||||
Delete(key);
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_plist_noparens(DOH *obj) {
|
|
||||||
/* attributes map names to objects */
|
|
||||||
Iterator k;
|
|
||||||
bool first;
|
|
||||||
for (k = First(obj), first = true; k.key; k = Next(k), first = false) {
|
|
||||||
if (!internal_key_p(k.key)) {
|
|
||||||
DOH *value = Getattr(obj, k.key);
|
|
||||||
flush_parens();
|
|
||||||
if (!first) {
|
|
||||||
Printf(out, " ");
|
|
||||||
}
|
|
||||||
Sexp_print_as_keyword(k.key);
|
|
||||||
/* Print value */
|
|
||||||
Sexp_print_value_of_key(value, k.key);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_plist(DOH *obj) {
|
|
||||||
flush_parens();
|
|
||||||
if (print_circle(obj, true)) {
|
|
||||||
open_paren(NIL);
|
|
||||||
Sexp_print_plist_noparens(obj);
|
|
||||||
close_paren();
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_attributes(Node *obj) {
|
|
||||||
Sexp_print_plist_noparens(obj);
|
|
||||||
}
|
|
||||||
|
|
||||||
void Sexp_print_node(Node *obj) {
|
|
||||||
Node *cobj;
|
|
||||||
open_paren(nodeType(obj));
|
|
||||||
/* A node has an attribute list... */
|
|
||||||
Sexp_print_attributes(obj);
|
|
||||||
/* ... and child nodes. */
|
|
||||||
cobj = firstChild(obj);
|
|
||||||
if (cobj) {
|
|
||||||
print_lazy_newline();
|
|
||||||
flush_parens();
|
|
||||||
Sexp_print_as_keyword("children");
|
|
||||||
open_paren(NIL);
|
|
||||||
for (; cobj; cobj = nextSibling(cobj)) {
|
|
||||||
Sexp_print_node(cobj);
|
|
||||||
}
|
|
||||||
close_paren();
|
|
||||||
}
|
|
||||||
close_paren();
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
virtual int functionWrapper(Node *n) {
|
|
||||||
ParmList *l = Getattr(n, "parms");
|
|
||||||
Wrapper *f = NewWrapper();
|
|
||||||
emit_attach_parmmaps(l, f);
|
|
||||||
Setattr(n, "wrap:parms", l);
|
|
||||||
DelWrapper(f);
|
|
||||||
return SWIG_OK;
|
|
||||||
}
|
|
||||||
|
|
||||||
};
|
|
||||||
|
|
||||||
|
|
||||||
static Language *new_swig_sexp() {
|
|
||||||
return new Sexp();
|
|
||||||
}
|
|
||||||
extern "C" Language *swig_sexp(void) {
|
|
||||||
return new_swig_sexp();
|
|
||||||
}
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue